diff --git a/.gitignore b/.gitignore index cafb205f72..e24b6fa55e 100644 --- a/.gitignore +++ b/.gitignore @@ -14,7 +14,7 @@ src/physics/pumas src/physics/pumas-frozen src/physics/rrtmgp/data src/physics/rrtmgp/ext -src/dynamics/fv3/atmos_cubed_sphere +src/dynamics/fv3 libraries/FMS libraries/mct libraries/parallelio diff --git a/Externals.cfg b/Externals.cfg index dfe04d45c4..ffe2c4b012 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -1,5 +1,5 @@ [ccs_config] -tag = ccs_config_cesm0.0.82 +tag = ccs_config_cesm0.0.85 protocol = git repo_url = https://github.com/ESMCI/ccs_config_cesm local_path = ccs_config @@ -21,14 +21,14 @@ externals = Externals.cfg required = True [cmeps] -tag = cmeps0.14.43 +tag = cmeps0.14.59 protocol = git repo_url = https://github.com/ESCOMP/CMEPS.git local_path = components/cmeps required = True [cdeps] -tag = cdeps1.0.24 +tag = cdeps1.0.31 protocol = git repo_url = https://github.com/ESCOMP/CDEPS.git local_path = components/cdeps @@ -43,7 +43,7 @@ local_path = components/cpl7 required = True [share] -tag = share1.0.17 +tag = share1.0.18 protocol = git repo_url = https://github.com/ESCOMP/CESM_share local_path = share @@ -64,7 +64,7 @@ local_path = libraries/parallelio required = True [cime] -tag = cime6.0.175 +tag = cime6.0.236_httpsbranch01 protocol = git repo_url = https://github.com/ESMCI/cime local_path = cime @@ -79,7 +79,7 @@ externals = Externals_CISM.cfg required = True [clm] -tag = ctsm5.1.dev142 +tag = ctsm5.1.dev145 protocol = git repo_url = https://github.com/ESCOMP/CTSM local_path = components/clm @@ -87,8 +87,7 @@ externals = Externals_CLM.cfg required = True [fms] -# Older tag than CESM as there is a compilation error mismatch -tag = fi_20211011 +tag = fi_230818 protocol = git repo_url = https://github.com/ESCOMP/FMS_interface local_path = libraries/FMS diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 736dcee274..f09ec0f444 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -25,7 +25,7 @@ local_path = src/physics/clubb protocol = git repo_url = https://github.com/larson-group/clubb_release sparse = ../.clubb_sparse_checkout -tag = clubb_4ncar_20221129_59cb19f_20230330_branchtag +tag = clubb_4ncar_20231115_5406350 required = True [pumas] @@ -50,17 +50,18 @@ tag = ALI_ARMS_v1.0.1 required = True [atmos_phys] -tag = atmos_phys0_02_000 +tag = atmos_phys0_02_006 protocol = git repo_url = https://github.com/ESCOMP/atmospheric_physics required = True local_path = src/atmos_phys -[atmos_cubed_sphere] -tag = fv3_cesm.04 +[fv3] +tag = fv3int_022824 protocol = git -repo_url = https://github.com/ESCOMP/FV3_CESM.git -local_path = src/dynamics/fv3/atmos_cubed_sphere +repo_url = https://github.com/ESCOMP/CAM_FV3_interface.git +local_path = src/dynamics/fv3 +externals = Externals_FV3.cfg required = True [mpas] diff --git a/README_EXTERNALS b/README_EXTERNALS deleted file mode 100644 index 2b6c2bc4e3..0000000000 --- a/README_EXTERNALS +++ /dev/null @@ -1,49 +0,0 @@ -Example taken from bulletin board forum for "Subversion Issues" in the -thread for "Introduction to Subversion"...(070208) - - -Working with externals: - -checkout the HEAD of cam's trunk into working copy directory -> svn co $SVN/cam1/trunk cam_trunk_head_wc - -view the property set for cam's external definitions -> svn propget svn:externals cam_trunk_head_wc - -view revision, URL and other useful information specific to external files -> cd cam_trunk_head_wc/models/lnd/clm2/src -> svn info main - -create new clm branch for mods required of cam -> svn copy $SVN/clm2/trunk_tags/ $SVN/clm2/branches/ -m "appropriate message" - -have external directories in working copy refer to new clm branch to make changes -> svn switch $SVN/clm2/branches//src/main main - ---make changes to clm files-- - -when satisfied with changes and testing, commit to HEAD of clm branch -> svn commit main -m "appropriate message" - -tag new version of clm branch - review naming conventions! -> svn copy $SVN/clm2/branches/ $SVN/clm2/branch_tags/_tags/ -m "appropriate message" - -have external directories in working copy refer to new clm tag -> svn switch $SVN/clm2/branch_tags/_tags//src/main main - -modify cam's property for external definitions in working copy -> emacs cam_trunk_head_wc/SVN_EXTERNAL_DIRECTORIES - ---point definition to URL of new-tag-name-- - -set the property - don't forget the 'dot' at the end! -> svn propset svn:externals -F SVN_EXTERNAL_DIRECTORIES cam_trunk_head_wc - ---continue with other cam mods-- - -commit changes from working copy directory to HEAD of cam trunk - NOTE: a commit from here will *NOT* recurse to external directories -> cd cam_trunk_head_wc -> svn commit -m "appropriate message" - -tag new version of cam trunk -> svn copy $SVN/cam1/trunk $SVN/cam1/trunk_tags/ -m "appropriate message" diff --git a/bld/build-namelist b/bld/build-namelist index dcdf858f81..a07e8965df 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -3446,6 +3446,7 @@ if ($clubb_sgs =~ /$TRUE/io) { add_default($nl, 'clubb_gamma_coefb'); } + add_default($nl, 'clubb_bv_efold'); add_default($nl, 'clubb_C7'); add_default($nl, 'clubb_C7b'); add_default($nl, 'clubb_c_K1'); @@ -3510,6 +3511,8 @@ if ($clubb_sgs =~ /$TRUE/io) { add_default($nl, 'clubb_tridiag_solve_method'); add_default($nl, 'clubb_up2_sfc_coef'); add_default($nl, 'clubb_wpxp_L_thresh'); + add_default($nl, 'clubb_wpxp_Ri_exp'); + add_default($nl, 'clubb_z_displace'); #CLUBB+MF options add_default($nl, 'do_clubb_mf'); @@ -4103,6 +4106,7 @@ if ($dyn =~ /se/) { se_kmax_jet se_molecular_diff se_pgf_formulation + se_dribble_in_rsplit_loop ); my %opts; diff --git a/bld/configure b/bld/configure index f77b822046..e2fb784495 100755 --- a/bld/configure +++ b/bld/configure @@ -2101,6 +2101,7 @@ sub write_fv3core_filepath my $camsrcdir = $cfg_ref->get('cam_dir'); my $CASEROOT = "$ENV{'CASEROOT'}"; print $fh "$CASEROOT/SourceMods/src.cam\n"; + print $fh "$camsrcdir/src/dynamics/fv3/src_override\n"; print $fh "$camsrcdir/src/dynamics/fv3/microphys\n"; print $fh "$camsrcdir/src/dynamics/fv3/atmos_cubed_sphere/model\n"; print $fh "$camsrcdir/src/dynamics/fv3/atmos_cubed_sphere/tools\n"; @@ -2168,7 +2169,7 @@ sub write_filepath # Weak scaling fix. This has to come before physics/cam and before dycores # It also has to come before utils (which is already near the end). - if ($dyn eq 'se' or $dyn eq 'mpas') { + if ($dyn eq 'se' or $dyn eq 'mpas' or $dyn eq 'fv3') { print $fh "$camsrcdir/src/infrastructure\n"; } @@ -2188,9 +2189,9 @@ sub write_filepath if ($chem_src_dir) { print $fh "$chem_src_dir\n"; } - + # GEOS-Chem must be prior to Mozart - if ($chem_pkg =~ 'geoschem') { + if ($chem_pkg =~ 'geoschem') { print $fh "$chem_src_dir/geoschem_src/GeosCore\n"; print $fh "$chem_src_dir/geoschem_src/GeosUtil\n"; print $fh "$chem_src_dir/geoschem_src/Headers\n"; @@ -2302,7 +2303,7 @@ sub write_filepath print $fh "$camsrcdir/src/physics/cam\n"; #Add the CCPP'ized subdirectories - print $fh "$camsrcdir/src/atmos_phys/zm\n"; + print $fh "$camsrcdir/src/atmos_phys/zhang_mcfarlane\n"; # Dynamics package and test utilities print $fh "$camsrcdir/src/dynamics/$dyn\n"; diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 93b7bb1101..c1eb426622 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -342,16 +342,11 @@ atm/cam/topo/se/ne3pg3_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230209.nc atm/cam/topo/se/ne5pg3_nc3000_Co360_Fi001_MulG_PF_nullRR_Nsw064_20170516.nc atm/cam/topo/se/ne16pg3_nc3000_Co120_Fi001_PF_nullRR_Nsw084_20171012.nc -atm/cam/topo/se/ne30pg3_gmted2010_modis_bedmachine_nc3000_Laplace0100_20230105.nc +atm/cam/topo/se/ne30pg3_gmted2010_modis_bedmachine_nc3000_Laplace0100_noleak_20240117.nc atm/cam/topo/se/ne60pg3_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171012.nc atm/cam/topo/se/ne120pg3_nc3000_Co015_Fi001_PF_nullRR_Nsw010_20171014.nc atm/cam/topo/se/ne240pg3_nc3000_Co008_Fi001_PF_nullRR_Nsw005_20171015.nc -atm/cam/topo/se/ne5pg4_nc3000_Co360_Fi001_MulG_PF_nullRR_Nsw060_20170707.nc -atm/cam/topo/se/ne30pg4_nc3000_Co060_Fi001_PF_nullRR_Nsw042_20171014.nc -atm/cam/topo/se/ne60pg4_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171018.nc -atm/cam/topo/se/ne120pg4_nc3000_Co015_Fi001_PF_nullRR_Nsw010_20171014.nc - atm/cam/topo/se/ne30x8_CONUS_nc3000_Co060_Fi001_MulG_PF_RR_Nsw042_c200428.nc atm/cam/topo/se/ne30x4_ARCTIC_nc3000_Co060_Fi001_MulG_PF_RR_Nsw042_c200428.nc atm/cam/topo/se/ne30x8_ARCTICGRIS_nc3000_Co060_Fi001_MulG_PF_RR_Nsw042_c200428.nc @@ -2157,6 +2152,7 @@ 2.4 + 5.0 1.0 1.0 0.7D0 @@ -2177,6 +2173,7 @@ 0.1 0.5 4.2 + 4.25 0.0 1.0 0.1 @@ -2212,12 +2209,20 @@ 0.04 0.1 .false. + .false. + .true. + .false. .true. + .false. .false. .false. + .false. + .false. .false. + .true. .false. .false. + .true. .false. .false. .false. @@ -2234,16 +2239,22 @@ .false. .false. .true. + .false. .false. + .false. .false. .false. .true. - .true. - .true. + .false. + .true. + .true. + .true. + .true. .true. .false. .false. .true. + .true. .false. .false. .false. @@ -2259,6 +2270,8 @@ 1 2.0 60.0 + 0.5 + 25.0 .false. .true. .true. @@ -2306,6 +2319,7 @@ .false. .false. + .false. .false. @@ -2376,7 +2390,6 @@ 1.D0 1.D0 - 0.375D0 1.D0 @@ -2516,7 +2529,7 @@ 0.45D0 0.45D0 0.35D0 -0.35D0 +1.30D0 0.30D0 0.30D0 0.45D0 @@ -2528,7 +2541,7 @@ 0.55D0 0.22D0 0.70D0 -0.80D0 +1.30D0 0.8D0 0.8D0 0.8D0 @@ -2800,7 +2813,6 @@ 1.0D0 1.e-7 -5.e-6 5.e-3 .false. @@ -2810,7 +2822,6 @@ .true. .false. -.true. 5.0e-6 @@ -3178,6 +3189,10 @@ 1 3 + + 0 + 1 + 2 .true. @@ -3187,15 +3202,21 @@ 3 2 4 - 4 + 9 + 8 + 2 + 3 3 1 - 1 - 20 - 4 - 2 - 4 + 1 + 3 + 2 + 4 + 20 + 4 + 2 + 4 1 2 @@ -3209,9 +3230,11 @@ 1.9 -1 +6.e15 5.e15 -1 +6.e15 10.e15 -1 @@ -3219,12 +3242,14 @@ 1.25e5 1.0e6 1.0e6 + 1.0e6 0.0 1.0 -1 -1 + 7.5 -1 1 @@ -3239,17 +3264,17 @@ 1 3 - 5 - 3 - 5 - 3 + 5 + 2 + 4 + 2 10 7 3 - 4 - 6 + 2 + 4 3 -1 diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 7e908911b8..6ff0f8d3ba 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -3771,6 +3771,11 @@ air is supersaturated with respect to ice. Plume widths for theta_l and rt + +E-folding parameter for mixed Brunt Vaisala Frequency + + Limiting value of C1 when skewness of w (vertical velocity) is small in @@ -4010,6 +4015,15 @@ Gaussian PDF, and also decreases the difference between the means of w from each Gaussian. + +Selected option for the two-component normal (double Gaussian) PDF type to use for the w, rt, +and theta-l (or w, chi, and eta) portion of CLUBB's multivariate, two-component PDF. +iiPDF_ADG1 = 1 (ADG1 PDF), iiPDF_ADG2 = 2 (ADG2 PDF), iiPDF_3D_Luhar = 3 (3D Luhar PDF), +iiPDF_new = 4 (new PDF), iiPDF_TSDADG = 5 (TSDADG PDF), iiPDF_LY93 = 6 (Lewellen and Yoh (1993)), +iiPDF_new_hybrid = 7 (new hybrid PDF) + + Option for the placement of the call to CLUBB's PDF closure. The options include: ipdf_pre_advance_fields (1) calls the PDF closure before advancing prognostic fields. ipdf_post_advance_fields (2) calls after advancing prognostic fields, and ipdf_pre_post_advance_fields (3) calls both before and after advancing prognostic fields. @@ -4033,6 +4047,22 @@ Flag to uses an alternate equation to calculate the Brunt-Vaisala frequency. This equation calculates an in-cloud Brunt-Vaisala frequency. + +Flag to use cloud fraction to adjust the value of the +turbulent dissipation coefficient, C2. + + + +Include the contribution of radiation to thlp2 + + + +Calculate the correlations between w and the hydrometeors + + Flag to call CLUBB's PDF closure at both thermodynamic and momentum vertical @@ -4040,6 +4070,11 @@ grid levels. When this flag is turned off, CLUBB's PDF closure is only called on thermodynamic grid levels. + +Use a constant cloud droplet conc. within cloud + + Flag to use a dissipation formula of -(2/3)*em/tau_zm, as in Bougeault (1981), @@ -4061,6 +4096,17 @@ is turned off, Lscale is calculated first, and then dissipation time-scale tau is calculated as tau = Lscale / sqrt(tke). + +Diagnose correlations instead of using fixed ones + + + +Implicit diffusion on moisture and temperature, implemented within CLUBB's +matrix equations for wprtp/rtm and wpthlp/thlm. + + Explicit diffusion on temperature and moisture by CLUBB, in addition to CLUBB's @@ -4077,6 +4123,11 @@ Flag to run CLUBB with E3SM settings. Flag to relax clipping on wpxp in xm_wpxp_clipping_and_stats. + +Use a fixed correlation for s and t Mellor(chi/eta) + + This flag determines whether we want to use an upwind differencing approximation @@ -4171,6 +4222,11 @@ horizontal winds um and vm. When this flag is turned off, upwp and vpwp are calculated by down-gradient diffusion. + +used in adj_low_res_nu. If .true., avg_deltaz = deltaz + + Flag to take any remaining supersaturation after CLUBB PDF call and add it to @@ -4180,6 +4236,11 @@ levels and the momentum grid levels and variables are interpolated between the two grid level types. + +Turn on (true) and off (false) rtm nudging. + + Flag to use smooth Heaviside 'Peskin' in computation of invrs_tau. @@ -4192,6 +4253,11 @@ Use the standard discretization for the turbulent advection terms. Setting to advance_wp2_wp3_module.F90 and in advance_xp2_xpyp_module.F90. + +Whether or not we want CLUBB to apply a stability correction Kh_N2_zm. + + Flag to use a stability corrected version of CLUBB's time scale (tau_zm). This @@ -4199,6 +4265,13 @@ creates a time scale that provides stronger damping at altitudes where Brunt-Vaisala frequency is large. + +Use anisotropic turbulent kinetic energy in the CLUBB higher order closure, i.e. +calculate TKE = 1/2 (u'^2 + v'^2 + w'^2). This improves the simulation of complex +turbulence but at a greater cost than running without. + + Flag that uses the trapezoidal rule to adjust fields calculated by CLUBB's PDF @@ -4215,6 +4288,13 @@ adjacent vertical grid level. The clubb_l_trapezoidal_rule_zt flag applies this adjustment to PDF fields calculated on thermodynamic vertical grid levels. + +This flag determines whether we want to use an upwind differencing approximation +rather than a centered differencing for turbulent or mean advection terms. It +affects rtm, thlm, sclrm, um and vm. + + Flag to use "upwind" discretization in the turbulent advection term in the @@ -4224,6 +4304,11 @@ potential temperature). When this flag is turned off, centered discretization is used. + +Turn on (true) or off (false) uv wind speed nudging. + + Flag to calculate the value of CLUBB's C11 based on Richardson number, where @@ -4246,6 +4331,13 @@ levels influence the amount of cloudiness and amount of cloud water in a grid box. + +Flag to use precipitation fraction in KK microphysics. The +precipitation fraction is automatically set to 1 when this +flag is turned off. + + Flag to use shear in the calculation of Richardson number. @@ -4331,6 +4423,16 @@ clubb_up2_sfc_coef increases the values of up2 and vp2 at the surface. CLUBB tunable parameter - Lscale threshold: damp C6 and C7 (units: m) + +Exponent for Richardson number in calculation of invrs_tau_wpxp term + + + +Displacement of log law profile above ground (units: m) + + @@ -8255,6 +8357,20 @@ Default: Set by build-namelist. Default: Set by build-namelist. + + + 0: physics tendencies will be added every vertical remapping time-step (dt_phys/se_nsplit) + for se_ftype=0,2 + + 1: physics tendencies will be added every dynamics time-step (dt_phys/se_nsplit*se_rsplit) + for se_ftype=0,2 + + If se_ftype=1 then se_dribble_in_rsplit_loop has no effect since physics tendencies are added as an adjustment + + Default: Set by build-namelist. + + diff --git a/bld/namelist_files/use_cases/sd_waccmx_ma_cam6.xml b/bld/namelist_files/use_cases/sd_waccmx_ma_cam6.xml index 6b56c46b17..f380c36d60 100644 --- a/bld/namelist_files/use_cases/sd_waccmx_ma_cam6.xml +++ b/bld/namelist_files/use_cases/sd_waccmx_ma_cam6.xml @@ -135,4 +135,9 @@ .false. .false. + + 'SolIonRate_Tot = jeuv_1 + jeuv_2 + jeuv_3 + jeuv_4 + jeuv_5 + jeuv_6 + jeuv_7 + jeuv_8 + jeuv_9 + jeuv_10 + jeuv_11 + jeuv_14 + jeuv_15 + jeuv_16 +', + 'jeuv_17 + jeuv_18 + jeuv_19 + jeuv_20 + jeuv_21 + jeuv_22 + jeuv_23', + + diff --git a/cime_config/SystemTests/sct.py b/cime_config/SystemTests/sct.py index bc11add267..23108fc3a5 100644 --- a/cime_config/SystemTests/sct.py +++ b/cime_config/SystemTests/sct.py @@ -79,3 +79,13 @@ def _component_compare_test(self, suffix1, suffix2, self._test_status.set_status("{}_{}_{}".format(COMPARE_PHASE, self._run_one_suffix, self._run_two_suffix), TEST_FAIL_STATUS) comments="QDIFF,TDIFF: Difference greater than round off." append_testlog(comments, self._orig_caseroot) + + def _case_two_custom_prerun_action(self): + """ On NCAR derecho system the mpibind script causes ESMF in the second job to think it is using 128 tasks when it should only use 1 + changing the env variable PBS_SELECT solves this issue + """ + machine = self._case2.get_value("MACH") + if "derecho" in machine: + os.environ["PBS_SELECT"] = "1:ncpus=1:mpiprocs=1:ompthreads=1:mem=230gb:Qlist=cpu:ngpus=0" + + diff --git a/cime_config/SystemTests/tmc.py b/cime_config/SystemTests/tmc.py index 9fb8a5f7ab..ba92070de9 100644 --- a/cime_config/SystemTests/tmc.py +++ b/cime_config/SystemTests/tmc.py @@ -25,7 +25,7 @@ def run_phase(self): self.run_indv() cpllog = ''.join(get_latest_cpl_logs(self._case)) atmlog = cpllog.replace("cpl.log","atm.log") - atmlog = atmlog.replace("drv.log","atm.log") + atmlog = atmlog.replace("med.log","atm.log") if '.gz' == atmlog[-3:]: fopen = gzip.open else: diff --git a/cime_config/buildlib b/cime_config/buildlib index 73db5db3dd..b8cc333601 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -6,7 +6,7 @@ create the cam library # pylint: disable=multiple-imports, wrong-import-position, wildcard-import # pylint: disable=unused-wildcard-import, bad-whitespace, too-many-locals # pylint: disable=invalid-name -import sys, os, filecmp, shutil, imp +import sys, os, filecmp, shutil _CIMEROOT = os.environ.get("CIMEROOT") @@ -19,11 +19,56 @@ sys.path.append(_LIBDIR) from standard_script_setup import * from CIME.case import Case from CIME.utils import run_sub_or_cmd, expect, run_cmd +from CIME.utils import import_from_file from CIME.buildlib import parse_input from CIME.build import get_standard_makefile_args logger = logging.getLogger(__name__) +############################################################################### +def _build_fms(caseroot, libroot, bldroot): + ############################################################################### + + with Case(caseroot) as case: + + # Only need FMS for fv3 dycore + cam_dycore = case.get_value("CAM_DYCORE") + srcroot = case.get_value("SRCROOT") + if cam_dycore == "fv3": + # first check for the external FMS library and build it + # Check to see if some other component built it already + fmsbuildlib = os.path.join(srcroot, "libraries", "FMS", "buildlib") + librootfms = os.path.join(libroot, "libfms.a") + if not os.path.exists(librootfms): + if case.get_value("DEBUG"): + strdebug = "debug" + else: + strdebug = "nodebug" + + if case.get_value("BUILD_THREADED"): + strthread = "threads" + else: + strthread = "nothreads" + + mpilib = case.get_value("MPILIB") + sharedpath = os.path.join(case.get_value("COMPILER"), mpilib, + strdebug, strthread, "nuopc") + slr = os.path.abspath(case.get_value("SHAREDLIBROOT")) + fmsbuildroot = os.path.join(slr, sharedpath) + fmsinstallpath = os.path.join(fmsbuildroot, "FMS") + install_libfms = os.path.join(fmsinstallpath, "libfms.a") + + if not os.path.exists(install_libfms): + if not os.path.exists(fmsbuildlib): + #todo: call checkout_externals to get this component + expect(False, "FMS external not found") + else: + stat, _, err = run_cmd(f"{fmsbuildlib} {fmsbuildroot} {fmsinstallpath} {caseroot}", verbose=True) + expect(stat==0, f"FMS build Failed {err}") + + if os.path.exists(install_libfms): + shutil.copy(install_libfms, libroot) + ############################################################################### def _build_cam(caseroot, libroot, bldroot): ############################################################################### @@ -41,10 +86,10 @@ def _build_cam(caseroot, libroot, bldroot): cmd = os.path.join(os.path.join(srcroot, "cime_config", "buildcpp")) logger.info(" ...calling cam buildcpp to set build time options") try: - mod = imp.load_source("buildcpp", cmd) - cam_cppdefs = mod.buildcpp(case) + buildcpp = import_from_file("buildcpp", cmd) + cam_cppdefs = buildcpp.buildcpp(case) except: - raise + raise RuntimeError("CAM's 'buildcpp' script failed to run properly.") with Case(caseroot) as case: @@ -63,12 +108,11 @@ def _build_cam(caseroot, libroot, bldroot): threaded = "threads" if case.get_value("BUILD_THREADED") or case.get_value("FORCE_BUILD_SMP") else "nothreads" comp_interface = case.get_value("COMP_INTERFACE") fmsbuilddir = os.path.join( - slr, compiler, mpilib, debug, threaded, comp_interface) + slr, compiler, mpilib, debug, threaded, comp_interface, "FMS") user_incldir = '"-I{} -I{} -I{}"'.format( os.path.join(srcroot, "libraries", "FMS", "src", "include"), os.path.join(srcroot, "libraries", "FMS", "src", "mpp", "include"), - fmsbuilddir, - ) + fmsbuilddir) # ------------------------------------------------------- # Filepath is created in caseroot/camconf by the call @@ -119,6 +163,7 @@ def _build_cam(caseroot, libroot, bldroot): def _main_func(): caseroot, libroot, bldroot = parse_input(sys.argv) + _build_fms(caseroot, libroot, bldroot) _build_cam(caseroot, libroot, bldroot) diff --git a/cime_config/buildnml b/cime_config/buildnml index 0af683719a..a077e13fcd 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -4,7 +4,7 @@ CAM namelist creator """ # pylint: disable=multiple-imports -import sys, os, shutil, filecmp, imp +import sys, os, shutil, filecmp _CIMEROOT = os.environ.get("CIMEROOT") if _CIMEROOT is None: @@ -19,7 +19,7 @@ from standard_script_setup import * from CIME.XML.standard_module_setup import * from CIME.buildnml import create_namelist_infile, parse_input from CIME.case import Case -from CIME.utils import expect, run_cmd +from CIME.utils import expect, run_cmd, import_from_file logger = logging.getLogger(__name__) @@ -75,10 +75,10 @@ def buildnml(case, caseroot, compname): cmd = os.path.join(os.path.join(srcroot,"cime_config","buildcpp")) logger.info(" ...calling cam buildcpp to set build time options") try: - mod = imp.load_source("buildcpp", cmd) - mod.buildcpp(case) + buildcpp = import_from_file("buildcpp", cmd) + _ = buildcpp.buildcpp(case) except: - raise + raise RuntimeError("CAM's 'buildcpp' script failed to run properly.") # Verify that we have a config_cache file (generated by the call to buildcpp) expect(os.path.isfile(filename), @@ -173,7 +173,7 @@ def buildnml(case, caseroot, compname): buildnl_opts += ["-inputdata", input_data_list] - CAM_NAMELIST_OPTS += " stream_ndep_year_first=" + stream_ndep_year_first + CAM_NAMELIST_OPTS += " stream_ndep_year_first=" + stream_ndep_year_first CAM_NAMELIST_OPTS += " stream_ndep_year_last=" + stream_ndep_year_last CAM_NAMELIST_OPTS += " stream_ndep_year_align=" + stream_ndep_year_align CAM_NAMELIST_OPTS += " stream_ndep_data_filename='" + stream_ndep_data_filename.strip() + "'" @@ -216,13 +216,15 @@ def buildnml(case, caseroot, compname): # copy geos-chem config files to rundir if using geos-chem chemistry # ----------------------------------------------------- - if os.path.isdir(rundir) and '-chem geoschem' in CAM_CONFIG_OPTS: - for fname in ['species_database.yml', 'geoschem_config.yml', - 'HISTORY.rc', 'HEMCO_Config.rc', 'HEMCO_Diagn.rc']: - file1 = os.path.join(caseroot, fname) - file2 = os.path.join(rundir, fname) - logger.info("GEOS-Chem config file copy: file1 %s file2 %s ", file1, file2) - shutil.copy(file1,file2) + if os.path.isdir(rundir) \ + and os.path.exists(os.path.join(caseroot, "species_database.yml"))\ + and '-chem geoschem' in CAM_CONFIG_OPTS: + for fname in ['species_database.yml', 'geoschem_config.yml', + 'HISTORY.rc', 'HEMCO_Config.rc', 'HEMCO_Diagn.rc']: + file1 = os.path.join(caseroot, fname) + file2 = os.path.join(rundir, fname) + logger.info("GEOS-Chem config file copy: file1 %s file2 %s ", file1, file2) + shutil.copy(file1,file2) ############################################################################### def _main_func(): diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml index 5b4bc10c5b..7c78c98599 100644 --- a/cime_config/config_pes.xml +++ b/cime_config/config_pes.xml @@ -1790,14 +1790,14 @@ none - 128 - 128 - 128 - 128 - 128 - 128 - 128 - 128 + -3 + -3 + -3 + -3 + -3 + -3 + -3 + -3 1 diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 62cd0af626..05983cca7b 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -5,7 +5,7 @@ - + @@ -17,7 +17,7 @@ - + @@ -25,7 +25,7 @@ - + @@ -33,7 +33,7 @@ - + @@ -42,7 +42,7 @@ - + @@ -50,7 +50,7 @@ - + @@ -58,7 +58,7 @@ - + @@ -67,7 +67,7 @@ - + @@ -77,7 +77,7 @@ - + @@ -87,7 +87,7 @@ - + @@ -97,7 +97,7 @@ - + @@ -109,7 +109,7 @@ - + @@ -123,7 +123,7 @@ - + @@ -131,7 +131,7 @@ - + @@ -139,7 +139,7 @@ - + @@ -148,7 +148,7 @@ - + @@ -158,7 +158,7 @@ - + @@ -168,7 +168,7 @@ - + @@ -181,7 +181,7 @@ - + @@ -191,7 +191,7 @@ - + @@ -199,7 +199,7 @@ - + @@ -207,7 +207,7 @@ - + @@ -224,7 +224,7 @@ - + @@ -232,7 +232,7 @@ - + @@ -240,7 +240,7 @@ - + @@ -248,13 +248,13 @@ - + - + @@ -262,17 +262,17 @@ - + - + - + @@ -280,7 +280,7 @@ - + @@ -288,7 +288,7 @@ - + @@ -297,16 +297,18 @@ - + + + - + @@ -314,7 +316,7 @@ - + @@ -325,7 +327,7 @@ - + @@ -335,7 +337,7 @@ - + @@ -345,9 +347,10 @@ - + + @@ -355,7 +358,7 @@ - + @@ -365,7 +368,7 @@ - + @@ -375,7 +378,7 @@ - + @@ -385,7 +388,7 @@ - + @@ -395,7 +398,7 @@ - + @@ -405,7 +408,7 @@ - + @@ -415,9 +418,10 @@ - + + @@ -425,7 +429,7 @@ - + @@ -435,7 +439,7 @@ - + @@ -445,7 +449,7 @@ - + @@ -455,7 +459,7 @@ - + @@ -465,7 +469,7 @@ - + @@ -475,7 +479,7 @@ - + @@ -485,7 +489,7 @@ - + @@ -495,9 +499,10 @@ - + + @@ -505,7 +510,7 @@ - + @@ -515,7 +520,7 @@ - + @@ -525,7 +530,7 @@ - + @@ -535,7 +540,7 @@ - + @@ -545,7 +550,7 @@ - + @@ -555,7 +560,7 @@ - + @@ -564,7 +569,7 @@ - + @@ -572,7 +577,7 @@ - + @@ -581,7 +586,7 @@ - + @@ -589,7 +594,7 @@ - + @@ -598,7 +603,7 @@ - + @@ -608,7 +613,7 @@ - + @@ -618,7 +623,7 @@ - + @@ -630,7 +635,7 @@ - + @@ -641,7 +646,7 @@ - + @@ -652,7 +657,7 @@ - + @@ -663,7 +668,7 @@ - + @@ -674,7 +679,7 @@ - + @@ -685,7 +690,7 @@ - + @@ -696,7 +701,7 @@ - + @@ -707,7 +712,7 @@ - + @@ -718,7 +723,7 @@ - + @@ -743,7 +748,7 @@ - + @@ -754,7 +759,7 @@ - + @@ -765,7 +770,7 @@ - + @@ -776,7 +781,7 @@ - + @@ -786,7 +791,7 @@ - + @@ -795,7 +800,7 @@ - + @@ -805,7 +810,7 @@ - + @@ -815,7 +820,7 @@ - + @@ -825,7 +830,7 @@ - + @@ -835,7 +840,7 @@ - + @@ -845,7 +850,7 @@ - + @@ -855,7 +860,7 @@ - + @@ -865,7 +870,7 @@ - + @@ -875,7 +880,7 @@ - + @@ -885,7 +890,7 @@ - + @@ -895,7 +900,7 @@ - + @@ -905,7 +910,7 @@ - + @@ -916,7 +921,7 @@ - + @@ -926,7 +931,7 @@ - + @@ -935,7 +940,7 @@ - + @@ -943,7 +948,7 @@ - + @@ -951,7 +956,7 @@ - + @@ -961,7 +966,7 @@ - + @@ -971,7 +976,7 @@ - + @@ -981,7 +986,7 @@ - + @@ -991,7 +996,7 @@ - + @@ -1001,7 +1006,7 @@ - + @@ -1011,7 +1016,7 @@ - + @@ -1021,7 +1026,7 @@ - + @@ -1031,7 +1036,7 @@ - + @@ -1041,7 +1046,7 @@ - + @@ -1051,7 +1056,7 @@ - + @@ -1061,7 +1066,7 @@ - + @@ -1071,7 +1076,7 @@ - + @@ -1081,7 +1086,7 @@ - + @@ -1091,7 +1096,7 @@ - + @@ -1101,7 +1106,7 @@ - + @@ -1111,7 +1116,7 @@ - + @@ -1121,7 +1126,7 @@ - + @@ -1131,7 +1136,7 @@ - + @@ -1141,7 +1146,7 @@ - + @@ -1151,7 +1156,7 @@ - + @@ -1161,7 +1166,7 @@ - + @@ -1170,7 +1175,7 @@ - + @@ -1180,7 +1185,7 @@ - + @@ -1190,7 +1195,7 @@ - + @@ -1200,7 +1205,7 @@ - + @@ -1210,7 +1215,7 @@ - + @@ -1220,7 +1225,7 @@ - + @@ -1231,7 +1236,7 @@ - + @@ -1240,7 +1245,7 @@ - + @@ -1249,7 +1254,7 @@ - + @@ -1259,7 +1264,7 @@ - + @@ -1269,7 +1274,7 @@ - + @@ -1279,7 +1284,7 @@ - + @@ -1289,7 +1294,7 @@ - + @@ -1298,7 +1303,7 @@ - + @@ -1306,7 +1311,7 @@ - + @@ -1315,7 +1320,7 @@ - + @@ -1325,7 +1330,7 @@ - + @@ -1335,7 +1340,7 @@ - + @@ -1345,9 +1350,10 @@ - + + @@ -1355,7 +1361,7 @@ - + @@ -1364,7 +1370,7 @@ - + @@ -1373,7 +1379,7 @@ - + @@ -1382,7 +1388,7 @@ - + @@ -1403,37 +1409,37 @@ - + - + - + - + - + - + - + @@ -1444,7 +1450,7 @@ - + @@ -1455,7 +1461,7 @@ - + @@ -1464,7 +1470,7 @@ - + @@ -1479,7 +1485,7 @@ - + @@ -1489,7 +1495,7 @@ - + @@ -1498,7 +1504,7 @@ - + @@ -1507,7 +1513,7 @@ - + @@ -1516,7 +1522,16 @@ - + + + + + + + + + + @@ -1526,7 +1541,7 @@ - + @@ -1544,17 +1559,17 @@ - + - + - + @@ -1563,7 +1578,7 @@ - + @@ -1572,7 +1587,7 @@ - + @@ -1581,7 +1596,7 @@ - + @@ -1590,7 +1605,7 @@ - + @@ -1599,7 +1614,7 @@ - + @@ -1607,7 +1622,7 @@ - + @@ -1615,7 +1630,7 @@ - + @@ -1623,7 +1638,7 @@ - + @@ -1631,7 +1646,7 @@ - + @@ -1639,7 +1654,7 @@ - + @@ -1647,7 +1662,7 @@ - + @@ -1655,7 +1670,7 @@ - + @@ -1664,7 +1679,7 @@ - + @@ -1673,7 +1688,7 @@ - + @@ -1683,7 +1698,7 @@ - + @@ -1694,7 +1709,7 @@ - + @@ -1704,7 +1719,7 @@ - + @@ -1714,7 +1729,7 @@ - + @@ -1724,7 +1739,7 @@ - + @@ -1734,7 +1749,7 @@ - + @@ -1745,7 +1760,7 @@ - + @@ -1755,7 +1770,7 @@ - + @@ -1764,7 +1779,7 @@ - + @@ -1773,7 +1788,7 @@ - + @@ -1836,7 +1851,7 @@ - + @@ -1845,7 +1860,7 @@ - + @@ -1854,7 +1869,7 @@ - + @@ -1862,7 +1877,7 @@ - + @@ -1871,7 +1886,7 @@ - + @@ -1880,7 +1895,7 @@ - + @@ -1889,12 +1904,12 @@ - + - + @@ -1903,23 +1918,23 @@ - + - + - + - + @@ -1928,12 +1943,12 @@ - + - + @@ -1952,7 +1967,7 @@ - + @@ -1962,7 +1977,7 @@ - + @@ -1972,17 +1987,17 @@ - + - + - + @@ -1993,7 +2008,7 @@ - + @@ -2003,7 +2018,7 @@ - + @@ -2012,7 +2027,7 @@ - + @@ -2024,13 +2039,13 @@ - + - + @@ -2039,7 +2054,7 @@ - + @@ -2047,7 +2062,7 @@ - + @@ -2055,17 +2070,17 @@ - + - + - + @@ -2074,7 +2089,7 @@ - + @@ -2083,7 +2098,7 @@ - + @@ -2092,12 +2107,12 @@ - + - + @@ -2107,7 +2122,7 @@ - + @@ -2117,7 +2132,7 @@ - + @@ -2125,7 +2140,7 @@ - + @@ -2133,7 +2148,7 @@ - + @@ -2142,7 +2157,7 @@ - + @@ -2151,7 +2166,7 @@ - + @@ -2160,7 +2175,7 @@ - + @@ -2170,7 +2185,7 @@ - + @@ -2178,7 +2193,7 @@ - + @@ -2187,7 +2202,7 @@ - + @@ -2197,17 +2212,17 @@ - + - + - + @@ -2216,7 +2231,7 @@ - + @@ -2225,7 +2240,7 @@ - + @@ -2235,7 +2250,7 @@ - + @@ -2244,12 +2259,12 @@ - + - + @@ -2258,7 +2273,7 @@ - + @@ -2268,7 +2283,7 @@ - + @@ -2277,7 +2292,7 @@ - + @@ -2287,7 +2302,7 @@ - + @@ -2296,7 +2311,7 @@ - + @@ -2305,7 +2320,7 @@ - + @@ -2314,7 +2329,7 @@ - + @@ -2323,7 +2338,7 @@ - + @@ -2331,7 +2346,7 @@ - + @@ -2339,7 +2354,7 @@ - + @@ -2347,7 +2362,7 @@ - + @@ -2355,7 +2370,7 @@ - + @@ -2364,12 +2379,12 @@ - + - + @@ -2378,7 +2393,7 @@ - + @@ -2387,7 +2402,7 @@ - + @@ -2395,7 +2410,7 @@ - + @@ -2403,7 +2418,7 @@ - + @@ -2412,7 +2427,7 @@ - + @@ -2420,7 +2435,7 @@ - + @@ -2429,7 +2444,7 @@ - + @@ -2438,7 +2453,7 @@ - + @@ -2452,12 +2467,12 @@ - + - + @@ -2466,22 +2481,22 @@ - + - + - + - + @@ -2490,12 +2505,12 @@ - + - + @@ -2503,7 +2518,7 @@ - + @@ -2511,22 +2526,22 @@ - + - + - + - + @@ -2534,7 +2549,7 @@ - + @@ -2542,7 +2557,7 @@ - + @@ -2550,7 +2565,7 @@ - + @@ -2559,7 +2574,7 @@ - + @@ -2567,7 +2582,7 @@ - + @@ -2575,32 +2590,32 @@ - + - + - + - + - + - + @@ -2610,7 +2625,7 @@ - + @@ -2618,7 +2633,7 @@ - + @@ -2627,7 +2642,7 @@ - + @@ -2635,7 +2650,7 @@ - + @@ -2644,7 +2659,7 @@ - + @@ -2652,7 +2667,7 @@ - + @@ -2661,22 +2676,22 @@ - + - + - + - + @@ -2685,17 +2700,17 @@ - + - + - + @@ -2704,7 +2719,7 @@ - + @@ -2713,12 +2728,12 @@ - + - + @@ -2727,7 +2742,7 @@ - + @@ -2737,7 +2752,7 @@ - + @@ -2746,13 +2761,13 @@ - + - + @@ -2761,17 +2776,17 @@ - + - + - + @@ -2789,7 +2804,7 @@ - + @@ -2797,13 +2812,13 @@ - + - + @@ -2813,7 +2828,7 @@ - + @@ -2823,7 +2838,7 @@ - + @@ -2833,7 +2848,7 @@ - + @@ -2843,7 +2858,7 @@ - + @@ -2852,13 +2867,13 @@ - + - + @@ -2867,7 +2882,7 @@ - + @@ -2887,20 +2902,20 @@ - + - + - + @@ -2914,7 +2929,7 @@ - + diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/shell_commands index dec26a5365..35e44ac120 100644 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/shell_commands +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/shell_commands @@ -2,5 +2,5 @@ ./xmlchange GLC_NCPL=\$ATM_NCPL ./xmlchange CAM_CONFIG_OPTS=' -microphys mg3' --append if [ "`./xmlquery ATM_GRID --value`" == "C96" ]; then - ./xmlchange NTASKS=-2 + ./xmlchange NTASKS=-3 fi diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/user_nl_cam index 8482082dce..a8572b28a8 100644 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/user_nl_cam +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/user_nl_cam @@ -2,3 +2,82 @@ mfilt=1,1,1,1,1,1 ndens=1,1,1,1,1,1 nhtfrq=9,9,9,9,9,9 inithist='ENDOFRUN' +clubb_history = .true. +clubb_rad_history = .false. +fincl1 = 'Q', 'RHW', 'QRS', 'QRL', 'HR', 'FDL', +'thlm', 'thvm', 'rtm', 'rcm', 'rvm', 'um', 'vm', 'um_ref','vm_ref','ug', 'vg', 'cloud_frac', 'cloud_cover', +'rcm_in_layer', 'rcm_in_cloud', 'p_in_Pa', 'exner', 'rho_ds_zt', 'thv_ds_zt', 'Lscale', 'Lscale_pert_1', +'Lscale_pert_2', 'T_in_K', 'rel_humidity', 'wp3', 'wpthlp2', 'wp2thlp', 'wprtp2', 'wp2rtp', 'Lscale_up', +'Lscale_down', 'tau_zt', 'Kh_zt', 'wp2thvp', 'wp2rcp', 'wprtpthlp', 'sigma_sqd_w_zt', 'rho', 'radht', +'radht_LW', 'radht_SW', 'Ncm', 'Nc_in_cloud', 'Nc_activated', 'snowslope', 'sed_rcm', 'rsat', 'rsati', +'diam', 'mass_ice_cryst', 'rcm_icedfs', 'u_T_cm', 'rtm_bt', 'rtm_ma', 'rtm_ta', 'rtm_mfl', 'thlm_tacl', +'thlm_cl', 'thlm_forcing', 'thlm_sdmp','thlm_mc', 'thlm_old', 'thlm_without_ta', 'thlm_mfl_min', +'thlm_mfl_max', 'thlm_enter_mfl', 'thlm_exit_mfl', 'rtm_old', 'rtm_without_ta', 'rtm_mfl_min', 'rtm_mfl_max', +'rtm_enter_mfl', 'rtm_exit_mfl', 'um_bt', 'um_ma', 'um_gf', 'um_cf', 'um_ta', 'um_f', 'um_sdmp', 'um_ndg', +'vm_bt', 'vm_ma', 'vm_gf', 'vm_cf', 'vm_ta', 'vm_f', 'vm_sdmp', 'vm_ndg', 'wp3_bt', 'wp3_ma', 'wp3_ta', +'wp3_tp', 'wp3_ac', 'wp3_bp1', 'wp3_pr_turb', 'wp3_pr_dfsn', 'wp3_pr1', 'wp3_pr2', 'wp3_dp1', 'wp3_cl', +'mixt_frac', 'w_1', 'w_2', 'varnce_w_1', 'varnce_w_2', 'thl_1', 'thl_2', 'varnce_thl_1', 'varnce_thl_2', +'rt_1', 'rt_2', 'varnce_rt_1', 'varnce_rt_2', 'rc_1', 'rc_2', 'rsatl_1', 'rsatl_2', 'cloud_frac_1', +'cloud_frac_2', 'a3_coef_zt', 'wp3_on_wp2_zt', 'chi_1', 'chi_2', 'stdev_chi_1', 'stdev_chi_2', +'stdev_eta_1', 'stdev_eta_2', 'covar_chi_eta_1', 'covar_chi_eta_2', 'corr_chi_eta_1', 'corr_chi_eta_2', +'corr_rt_thl_1', 'crt_1', 'crt_2', 'cthl_1', 'cthl_2', 'precip_frac', 'precip_frac_1', 'precip_frac_2', +'Ncnm', 'wp2_zt', 'thlp2_zt', 'wpthlp_zt', 'wprtp_zt', 'rtp2_zt', 'rtpthlp_zt', 'up2_zt', 'vp2_zt', +'upwp_zt', 'vpwp_zt', 'C11_Skw_fnc', 'wp2', 'rtp2', 'thlp2', 'rtpthlp', 'wprtp', 'wpthlp', 'wp4', 'up2', +'vp2', 'wpthvp', 'rtpthvp', 'thlpthvp', 'tau_zm', 'Kh_zm', 'wprcp', 'wm_zm', 'thlprcp', 'rtprcp', 'rcp2', +'upwp', 'vpwp', 'rho_zm', 'sigma_sqd_w', 'Skw_velocity', 'gamma_Skw_fnc', 'C6rt_Skw_fnc', 'C6thl_Skw_fnc', +'C7_Skw_fnc', 'C1_Skw_fnc', 'a3_coef', 'wp3_on_wp2', 'rcm_zm', 'rtm_zm', 'thlm_zm', 'cloud_frac_zm', +'rho_ds_zm', 'thv_ds_zm', 'em', 'mean_w_up', 'mean_w_down', 'shear', 'wp3_zm', 'Frad', 'Frad_LW', 'Frad_SW', +'Frad_LW_up', 'Frad_SW_up', 'Frad_LW_down', 'Frad_SW_down', 'Fprec', 'Fcsed', 'wp2_bt', 'wp2_ma', 'wp2_ta', +'wp2_ac', 'wp2_bp', 'wp2_pr1', 'wp2_pr2', 'wp2_pr3', 'wp2_dp1', 'wp2_dp2', 'wp2_cl', 'wp2_pd', 'wp2_sf', +'vp2_bt', 'vp2_ma', 'vp2_ta', 'vp2_tp', 'vp2_dp1', 'vp2_dp2', 'vp2_pr1', 'vp2_pr2', 'vp2_cl', 'vp2_pd', +'vp2_sf', 'up2_bt', 'up2_ma', 'up2_ta', 'up2_tp', 'up2_dp1', 'up2_dp2', 'up2_pr1', 'up2_pr2', 'up2_cl', +'up2_pd', 'up2_sf', 'wprtp_bt', 'wprtp_ma', 'wprtp_ta', 'wprtp_tp', 'wprtp_ac', 'wprtp_bp', 'wprtp_pr1', +'wprtp_pr2', 'wprtp_pr3', 'wprtp_dp1', 'wprtp_mfl', 'wprtp_cl', 'wprtp_sicl', 'wprtp_pd', 'wprtp_forcing', +'wprtp_mc', 'wpthlp_bt', 'wpthlp_ma', 'wpthlp_ta', 'wpthlp_tp', 'wpthlp_ac', 'wpthlp_bp', 'wpthlp_pr1', +'wpthlp_pr2', 'wpthlp_pr3', 'wpthlp_dp1', 'wpthlp_mfl', 'wpthlp_cl', 'wpthlp_sicl', 'wpthlp_forcing', +'wpthlp_mc', 'rtp2_bt', 'rtp2_ma', 'rtp2_ta', 'rtp2_tp', 'rtp2_dp1', 'rtp2_dp2', 'rtp2_cl', 'rtp2_pd', +'rtp2_sf', 'rtp2_forcing', 'rtp2_mc', 'thlp2_bt', 'thlp2_ma', 'thlp2_ta', 'thlp2_tp', 'thlp2_dp1', +'thlp2_dp2', 'thlp2_cl', 'thlp2_pd', 'thlp2_sf', 'thlp2_forcing', 'thlp2_mc', 'rtpthlp_bt', 'rtpthlp_ma', +'rtpthlp_ta', 'rtpthlp_tp1', 'rtpthlp_tp2', 'rtpthlp_dp1', 'rtpthlp_dp2', 'rtpthlp_cl', 'rtpthlp_sf', +'rtpthlp_forcing', 'rtpthlp_mc', 'wpthlp_enter_mfl', 'wpthlp_exit_mfl', 'wprtp_enter_mfl', 'wprtp_exit_mfl', +'wpthlp_mfl_min', 'wpthlp_mfl_max', 'wprtp_mfl_min', 'wprtp_mfl_max', 'shear_sqd' + +clubb_vars_zt ='thlm', 'thvm', 'rtm', 'rcm', 'rvm', 'um', 'vm', 'um_ref','vm_ref','ug', 'vg', 'cloud_frac', +'cloud_cover', 'rcm_in_layer', 'rcm_in_cloud', 'p_in_Pa', 'exner', 'rho_ds_zt', 'thv_ds_zt', 'Lscale', +'Lscale_pert_1', 'Lscale_pert_2', 'T_in_K', 'rel_humidity', 'wp3', 'wpthlp2', 'wp2thlp', 'wprtp2', 'wp2rtp', +'Lscale_up', 'Lscale_down', 'tau_zt', 'Kh_zt', 'wp2thvp', 'wp2rcp', 'wprtpthlp', 'sigma_sqd_w_zt', 'rho', +'radht', 'radht_LW', 'radht_SW', 'Ncm', 'Nc_in_cloud', 'Nc_activated', 'snowslope', 'sed_rcm', 'rsat', +'rsati', 'diam', 'mass_ice_cryst', 'rcm_icedfs', 'u_T_cm', 'rtm_bt', 'rtm_ma', 'rtm_ta', 'rtm_mfl', +'rtm_tacl', 'rtm_cl', 'rtm_forcing', 'rtm_sdmp','rtm_mc', 'rtm_pd', 'rvm_mc', 'rcm_mc', 'rcm_sd_mg_morr', +'thlm_bt', 'thlm_ma', 'thlm_ta', 'thlm_mfl', 'thlm_tacl', 'thlm_cl', 'thlm_forcing', 'thlm_sdmp','thlm_mc', +'thlm_old', 'thlm_without_ta', 'thlm_mfl_min', 'thlm_mfl_max', 'thlm_enter_mfl', 'thlm_exit_mfl', +'rtm_old', 'rtm_without_ta', 'rtm_mfl_min', 'rtm_mfl_max', 'rtm_enter_mfl', 'rtm_exit_mfl', 'um_bt', +'um_ma', 'um_gf', 'um_cf', 'um_ta', 'um_f', 'um_sdmp', 'um_ndg', 'vm_bt', 'vm_ma', 'vm_gf', 'vm_cf', +'vm_ta', 'vm_f', 'vm_sdmp', 'vm_ndg', 'wp3_bt', 'wp3_ma', 'wp3_ta', 'wp3_tp', 'wp3_ac', 'wp3_bp1', +'wp3_pr_turb', 'wp3_pr_dfsn', 'wp3_pr1', 'wp3_pr2', 'wp3_dp1', 'wp3_cl', 'mixt_frac', 'w_1', 'w_2', +'varnce_w_1', 'varnce_w_2', 'thl_1', 'thl_2', 'varnce_thl_1', 'varnce_thl_2', 'rt_1', +'rt_2', 'varnce_rt_1', 'varnce_rt_2', 'rc_1', 'rc_2', 'rsatl_1', 'rsatl_2', 'cloud_frac_1', 'cloud_frac_2', +'a3_coef_zt', 'wp3_on_wp2_zt', 'chi_1', 'chi_2', 'stdev_chi_1', 'stdev_chi_2', 'stdev_eta_1', 'stdev_eta_2', +'covar_chi_eta_1', 'covar_chi_eta_2', 'corr_chi_eta_1', 'corr_chi_eta_2', 'corr_rt_thl_1', 'crt_1', +'crt_2', 'cthl_1', 'cthl_2', 'precip_frac', 'precip_frac_1', 'precip_frac_2', 'Ncnm', 'wp2_zt', 'thlp2_zt', +'wpthlp_zt', 'wprtp_zt', 'rtp2_zt', 'rtpthlp_zt', 'up2_zt', 'vp2_zt', 'upwp_zt', 'vpwp_zt', 'C11_Skw_fnc' + +clubb_vars_zm= 'wp2', 'rtp2', 'thlp2', 'rtpthlp', 'wprtp', 'wpthlp', 'wp4', 'up2', 'vp2', 'wpthvp', +'rtpthvp', 'thlpthvp', 'tau_zm', 'Kh_zm', 'wprcp', 'wm_zm', 'thlprcp', 'rtprcp', 'rcp2', 'upwp', 'vpwp', +'rho_zm', 'sigma_sqd_w', 'Skw_velocity', 'gamma_Skw_fnc', 'C6rt_Skw_fnc', 'C6thl_Skw_fnc', 'C7_Skw_fnc', +'C1_Skw_fnc', 'a3_coef', 'wp3_on_wp2', 'rcm_zm', 'rtm_zm', 'thlm_zm', 'cloud_frac_zm', 'rho_ds_zm', +'thv_ds_zm', 'em', 'mean_w_up', 'mean_w_down', 'shear', 'wp3_zm', 'Frad', 'Frad_LW', 'Frad_SW', +'Frad_LW_up', 'Frad_SW_up', 'Frad_LW_down', 'Frad_SW_down', 'Fprec', 'Fcsed', 'wp2_bt', 'wp2_ma', 'wp2_ta', +'wp2_ac', 'wp2_bp', 'wp2_pr1', 'wp2_pr2', 'wp2_pr3', 'wp2_dp1', 'wp2_dp2', 'wp2_cl', 'wp2_pd', 'wp2_sf', +'vp2_bt', 'vp2_ma', 'vp2_ta', 'vp2_tp', 'vp2_dp1', 'vp2_dp2', 'vp2_pr1', 'vp2_pr2', 'vp2_cl', 'vp2_pd', 'vp2_sf', 'up2_bt', 'up2_ma', 'up2_ta', 'up2_tp', 'up2_dp1', 'up2_dp2', 'up2_pr1', 'up2_pr2', 'up2_cl', 'up2_pd', +'up2_sf', 'wprtp_bt', 'wprtp_ma', 'wprtp_ta', 'wprtp_tp', 'wprtp_ac', 'wprtp_bp', 'wprtp_pr1', 'wprtp_pr2', +'wprtp_pr3', 'wprtp_dp1', 'wprtp_mfl', 'wprtp_cl', 'wprtp_sicl', 'wprtp_pd', 'wprtp_forcing', 'wprtp_mc', +'wpthlp_bt', 'wpthlp_ma', 'wpthlp_ta', 'wpthlp_tp', 'wpthlp_ac', 'wpthlp_bp', 'wpthlp_pr1', 'wpthlp_pr2', +'wpthlp_pr3', 'wpthlp_dp1', 'wpthlp_mfl', 'wpthlp_cl', 'wpthlp_sicl', 'wpthlp_forcing', 'wpthlp_mc', +'rtp2_bt', 'rtp2_ma', 'rtp2_ta', 'rtp2_tp', 'rtp2_dp1', 'rtp2_dp2', 'rtp2_cl', 'rtp2_pd', 'rtp2_sf', +'rtp2_forcing', 'rtp2_mc', 'thlp2_bt', 'thlp2_ma', 'thlp2_ta', 'thlp2_tp', 'thlp2_dp1', 'thlp2_dp2', +'thlp2_cl', 'thlp2_pd', 'thlp2_sf', 'thlp2_forcing', 'thlp2_mc', 'rtpthlp_bt', 'rtpthlp_ma', 'rtpthlp_ta', +'rtpthlp_tp1', 'rtpthlp_tp2', 'rtpthlp_dp1', 'rtpthlp_dp2', 'rtpthlp_cl', 'rtpthlp_sf', 'rtpthlp_forcing', +'rtpthlp_mc', 'wpthlp_enter_mfl', 'wpthlp_exit_mfl', 'wprtp_enter_mfl', 'wprtp_exit_mfl', 'wpthlp_mfl_min', +'wpthlp_mfl_max', 'wprtp_mfl_min', 'wprtp_mfl_max', 'shear_sqd' + diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/shell_commands new file mode 100644 index 0000000000..d10bce4cdc --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/shell_commands @@ -0,0 +1,3 @@ +./xmlchange ROF_NCPL=\$ATM_NCPL +./xmlchange GLC_NCPL=\$ATM_NCPL +./xmlchange CAM_CONFIG_OPTS=' -microphys pumas' --append diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/user_nl_cam new file mode 100644 index 0000000000..936d79412d --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/user_nl_cam @@ -0,0 +1,5 @@ +mfilt=1,1,1,1,1,1 +ndens=1,1,1,1,1,1 +nhtfrq=9,9,9,9,9,9 +inithist='ENDOFRUN' +fincl1 = 'RBFRAC','RBFREQ','rbSZA' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/user_nl_clm new file mode 100644 index 0000000000..12d5a36d2b --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_pumas_rainbows/user_nl_clm @@ -0,0 +1,26 @@ +!---------------------------------------------------------------------------------- +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value +! +! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options +! are set in the CLM_NAMELIST_OPTS env variable. +! +! EXCEPTIONS: +! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting +! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting +! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting +! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting +! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting +! Set irrigate by the CLM_BLDNML_OPTS -irrig setting +! Set dtime with L_NCPL option +! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options +! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases +! (includes $inst_string for multi-ensemble cases) +! Set glc_grid with CISM_GRID option +! Set glc_smb with GLC_SMB option +! Set maxpatch_glcmec with GLC_NEC option +! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable +!---------------------------------------------------------------------------------- +hist_nhtfrq = 9 +hist_mfilt = 1 +hist_ndens = 1 diff --git a/cime_config/testdefs/testmods_dirs/cam/silhs/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/silhs/user_nl_cam index d322c3706a..13ceac46c1 100644 --- a/cime_config/testdefs/testmods_dirs/cam/silhs/user_nl_cam +++ b/cime_config/testdefs/testmods_dirs/cam/silhs/user_nl_cam @@ -46,7 +46,7 @@ fincl1 = 'U:A','PS:A','T:A','V:A','OMEGA:A','Z3:A','PRECT:A', 'rtp2_dp2', 'rtp2_cl', 'rtp2_pd', 'rtp2_sf', 'rtp2_forcing', 'rtp2_mc', 'thlp2_bt', 'thlp2_ma', 'thlp2_ta', 'thlp2_tp', 'thlp2_dp1', 'thlp2_dp2', 'thlp2_cl', 'thlp2_pd', 'thlp2_sf', 'thlp2_forcing', 'thlp2_mc', 'rtpthlp_bt', 'rtpthlp_ma', 'rtpthlp_ta', 'rtpthlp_tp1', 'rtpthlp_tp2', 'rtpthlp_dp1', 'rtpthlp_dp2', 'rtpthlp_cl', 'rtpthlp_sf', 'rtpthlp_forcing', 'rtpthlp_mc', 'wpthlp_enter_mfl', 'wpthlp_exit_mfl', 'wprtp_enter_mfl', 'wprtp_exit_mfl', 'wpthlp_mfl_min', -'wpthlp_mfl_max', 'wprtp_mfl_min', 'wprtp_mfl_max', 'Richardson_num', 'shear_sqd', +'wpthlp_mfl_max', 'wprtp_mfl_min', 'wprtp_mfl_max', 'shear_sqd' fincl2 = 'CLDTOT', 'CLDST','CDNUMC','CLDLIQ','CLDICE','FLUT', 'LWCF','SWCF','PRECT' clubb_history = .true. @@ -77,4 +77,4 @@ clubb_vars_zm= 'wp2', 'rtp2', 'thlp2', 'rtpthlp', 'wprtp', 'wpthlp', 'wp4', 'up2 'rtp2_dp2', 'rtp2_cl', 'rtp2_pd', 'rtp2_sf', 'rtp2_forcing', 'rtp2_mc', 'thlp2_bt', 'thlp2_ma', 'thlp2_ta', 'thlp2_tp', 'thlp2_dp1', 'thlp2_dp2', 'thlp2_cl', 'thlp2_pd', 'thlp2_sf', 'thlp2_forcing', 'thlp2_mc', 'rtpthlp_bt', 'rtpthlp_ma', 'rtpthlp_ta', 'rtpthlp_tp1', 'rtpthlp_tp2', 'rtpthlp_dp1', 'rtpthlp_dp2', 'rtpthlp_cl', 'rtpthlp_sf', 'rtpthlp_forcing', 'rtpthlp_mc', 'wpthlp_enter_mfl', 'wpthlp_exit_mfl', 'wprtp_enter_mfl', 'wprtp_exit_mfl', 'wpthlp_mfl_min', -'wpthlp_mfl_max', 'wprtp_mfl_min', 'wprtp_mfl_max', 'Richardson_num', 'shear_sqd' +'wpthlp_mfl_max', 'wprtp_mfl_min', 'wprtp_mfl_max', 'shear_sqd' diff --git a/cime_config/usermods_dirs/scam_mandatory/shell_commands b/cime_config/usermods_dirs/scam_mandatory/shell_commands index 5230507d8a..4fa8390aa5 100755 --- a/cime_config/usermods_dirs/scam_mandatory/shell_commands +++ b/cime_config/usermods_dirs/scam_mandatory/shell_commands @@ -10,6 +10,6 @@ # Note that clm cannot use initial conditions with SCAM -so will only use specified phenology # Only change if CLM_FORCE_COLDSTART exists. -if [ `./xmlquery --value CLM_FORCE_COLDSTART |& grep -c 'ERROR'` -eq 0 ]; then +if [ `./xmlquery --value CLM_FORCE_COLDSTART 2>&1 | grep -c 'ERROR'` -eq 0 ]; then ./xmlchange CLM_FORCE_COLDSTART='on' fi diff --git a/doc/ChangeLog b/doc/ChangeLog index 5ea328d2c8..9f4f0d348d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,1289 @@ + +=============================================================== + +Tag name: cam6_3_160 +Originator(s): cacraig, jedwards +Date: April 29, 2024 +One-line Summary: workaround so that sct works on derecho +Github PR URL: https://github.com/ESCOMP/CAM/pull/1019 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Newest ccs_config tag causes the derecho_intel SCT test to fail: https://github.com/ESCOMP/CAM/issues/1017 + + IMPORTANT NOTE: This tag breaks the SCT test on derecho (see below) as it does not bring in the update to ccs_config_cesm0.0.99 + The reason to do this is that this change will be available for the next CESM alpha tag starting today. + In order to not hold up the CESM alpha tag sequence, we do not have time to run the full regression test suite + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume, katec, cacraig + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: + M cime_config/SystemTests/sct.py + +TESTING NOTES: Due to time constraints, only the SCT tests were run + +derecho/intel/aux_cam: Only SCT test was run: + SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep - Did not even start up with this change when using the + - current ccs_config tag. Error reported in cime-test.o4308193 file: + File "/glade/u/apps/derecho/23.09/opt/._view/dmewvyohndr7lajyom5grftguonqfbdr/lib/python3.10/xml/etree/ElementTree.py", line 580, in parse + self._root = parser._parse_whole(source) + xml.etree.ElementTree.ParseError: not well-formed (invalid token): line 1, column 0 + + SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep (Overall: PASS) details: + - When ccs_config_cesm0.0.99 is used, this test PASSES and is BFB + + +izumi/nag/aux_cam: None run + +izumi/gnu/aux_cam: Only two SCT tests were run and they were BFB and ran fine + +=============================================================== +=============================================================== + +Tag name: cam6_3_159 +Originator(s): katetc, andrewgettelman, sjsprecious +Date: April 26, 2024 +One-line Summary: Diagnostic rainbows and new PUMAS external with fixed GPU directives +Github PR URL: https://github.com/ESCOMP/CAM/pull/702 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Add diagnostic rainbow calculation: https://github.com/ESCOMP/CAM/issues/683 + - Partially addresses Broken PUMAS GPU code and GPU regression test: https://github.com/ESCOMP/CAM/issues/1007 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: sjsprecious, andrewgettelman, cacraigucar, nusbaume + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M Externals_CAM.cgf + - Point to new PUMAS tag + +M cime_config/testdefs/testlist_cam.xml + - Add new test for rainbows output to aux_pumas suite + - Add SCT test to prealpha test suite to ensure it is not broken by the next ccs_config tags + +M cime_config/testdefs/testmods_dir/cam/outfrq9s_pumas_rainbows/shell_comands + cime_config/testdefs/testmods_dir/cam/outfrq9s_pumas_rainbows/user_nl_cam + cime_config/testdefs/testmods_dir/cam/outfrq9s_pumas_rainbows/user_nl_clm + - Added test to the aux_pumas suite to make sure rainbows functionality is maintained + +M src/physics/cam/micro_pumas_cam.F90 + src/physics/cam_dev/micro_pumas_cam.F90 + - Diagnostic rainbows parameterization added identically in both versions of the file. + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: all BFB, except: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failure + + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + FAIL SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d BASELINE /glade/campaign/cesm/community/amwg/cam_baselines/cam6_3_158: DIFF + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + FAIL SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h BASELINE /glade/campaign/cesm/community/amwg/cam_baselines/cam6_3_158: DIFF + - Unexpected baseline comparison failures. Documented in ESCOMP/cam issue #1018 + +izumi/nag/aux_cam: all B4B, except: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: all BFB + +Summarize any changes to answers: bit-for-bit unchanged except GEOS-Chem and HEMCO tests described in issue #1018 + +=============================================================== + +Tag name: cam6_3_158 +Originator(s): cacraig +Date: April 22, 2024 +One-line Summary: ZM clean up round 2 for CAM and cime update for GEOS-Chem +Github PR URL: https://github.com/ESCOMP/CAM/pull/992 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - change zm directory to be zhang_mcfarlane: https://github.com/ESCOMP/CAM/issues/965 + - Reimplement writing within ZM and remove pflx variable: https://github.com/ESCOMP/CAM/issues/978 + - ZM cleanup: https://github.com/ESCOMP/CAM/issues/984 + - Tag cam6_3_157 missing updated .gitignore: https://github.com/ESCOMP/CAM/issues/1012 + - GEOS-Chem compsets will fail due to bugs in CAM and CIME: https://github.com/ESCOMP/CAM/issues/1004 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M .gitignore + - Update FV3 listing + +M externals.cfg + - Update cime to bring in bug fix for GEOS-Chem + +M Externals_CAM.cfg + - Update atmospheric_physics external to bring in changes for ZM + +M bld/configure + - Change directory from zm to zhang-mcfarlane + +M src/physics/cam/cam_snapshot.F90 +M src/physics/cam/convect_deep.F90 +M src/physics/cam/physpkg.F90 +M src/physics/cam_dev/cam_snapshot.F90 +M src/physics/cam_dev/physpkg.F90 + - Remove pflx variable which is not used + +M src/physics/cam/zm_conv_intr.F90 + - Split winds into separate variable + - remove pflx + - reintroduce writing within ZM + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: all BFB, except: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failure + + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + - Answer change for HEMCO - approved by Francis and Lizzie due to HEMCO giving different answers when layout changes are made + + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + - no previous baseline + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: all BFB + +=============================================================== +=============================================================== + +Tag name: cam6_3_157 +Originator(s): jet +Date: Apr 17, 2024 +One-line Summary: Update FV3 FMS externals, added FV3_CAM interface external, now importing core FV3 from GFDL +Github PR URL: https://github.com/ESCOMP/CAM/pull/983 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Update FV3 to allow syncing FMS version with CESM + - Ditch NCAR fork of FV3 in favor of pulling in library code from GFDL + - Clean up FV3 makfile + - Closes issue #950 : FMS external version needs to match version used in CESM + +Describe any changes made to build system: + - Replace FV3 fork external with FV3_interface external that inturn imports FV3 from GFDL + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraig, nusbaume, jedwards + +List all files eliminated: + src/dynamics/fv3/dimensions_mod.F90 + src/dynamics/fv3/dp_coupling.F90 + src/dynamics/fv3/dycore_budget.F90 + src/dynamics/fv3/dycore.F90 + src/dynamics/fv3/dyn_comp.F90 + src/dynamics/fv3/dyn_grid.F90 + src/dynamics/fv3/interp_mod.F90 + src/dynamics/fv3/Makefile.in.fv3 + src/dynamics/fv3/pmgrid.F90 + src/dynamics/fv3/restart_dynamics.F90 + src/dynamics/fv3/spmd_dyn.F90 + src/dynamics/fv3/stepon.F90 + src/dynamics/fv3/microphys/gfdl_cloud_microphys.F90 + src/dynamics/fv3/microphys/module_mp_radar.F90 + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M Externals.cfg + - updated FMS tag +M Externals_CAM.cfg + - removed FV3 fork external and replace with FV3_CAM_INTERFACE external +M bld/configure + - add src_override directory for interfacing GFDL lib code to CAM +M cime_config/bldlib + - add bld_fms target to use common FMS library +M cime_config/config_pes.xml + - update FV3 default C96 PE's for Derecho +M cime_config/testdefs/testlist_cam.xml + - add izumi gnu fv3 test +M cime_config/testdefs/testmods_dirs/cam/outfrq9xs_mg3/shell_commands + - fix C96 PE default for derecho +M test/system/TR8.sh + - add ignore for src_override directory of new FV3_CAM_INTERFACE external + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +All (coupled) jobs had errors about MEMCOMP failing due to missing files - to +be fixed in upcoming CIME tag + +Many tests also had TPUTCOMP errors which are not reported here. The current +working assumption is that there is an error with the test itself not the CAM code. + +derecho/intel/aux_cam: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) details: + - pre-existing failures + + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + - FV3 diff failures are expected due to lack of a baseline file to compare against. + + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: All PASS + +=============================================================== + +Tag name: cam6_3_156 +Originator(s): fvitt +Date: 16 Apr 2024 +One-line Summary: Misc code clean up for WACCM +Github PR URL: https://github.com/ESCOMP/CAM/pull/1001 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + + Use supported lapack library routine to solve a matrix equation in WACCM physics + efield module (issue #999) + + Misc code clean up in calculations of effective cross section of O2 + + Fix for sd_waccmx_ma_cam6 use case file for waccm_mad_mam5 chemistry + + Minor change to APEX module needed for when NAG compiler '-nan' option is used + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraigucar nusbaume + +List all files eliminated: +D src/chemistry/mozart/sv_decomp.F90 + - remove deprecated matrix solve routines -- replaced by LAPACK DGESV routine + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M bld/namelist_files/use_cases/sd_waccmx_ma_cam6.xml + - fix for waccm_mad_mam5 chem + +M src/chemistry/mozart/mo_jshort.F90 + - code clean up in calculations of effective cross section of O2 + +M src/chemistry/utils/apex.F90 + - minor changes for NAG compiler '-nan' option is used + +M src/physics/waccm/efield.F90 + - use LAPACK DGESV routine to solve matrix equation + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + PEND ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 + FAIL SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d + - pre-existing failures + + FAIL ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s + - pre-existing failure -- should be fixed with an external cime update + +izumi/nag/aux_cam: + FAIL DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae + - pre-existing failure + +izumi/gnu/aux_cam: All PASS + +Summarize any changes to answers: bit-for-bit unchanged + +=============================================================== +=============================================================== + +Tag name: cam6_3_155 +Originator(s): katec,vlarson,bstephens82,huebleruwm,zarzycki,JulioTBacmeister +Date: April 12, 2024 +One-line Summary: Update CLUBB and SILHS to new UWM external +Github PR URL: https://github.com/ESCOMP/CAM/pull/960 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Update to new CLUBB external with some taus code modifications https://github.com/ESCOMP/CAM/issues/956 + - Convert CLUBB lat/lon crash remport from radians to degrees https://github.com/ESCOMP/CAM/issues/971 + - Parameter changes related to optimizing CLUBB's taus code for CESM3 https://github.com/ESCOMP/CAM/issues/953 + +Describe any changes made to build system: + - Modify a test to include threading ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s + - Add CLUBB stats output to an ERP or regular aux_cam test via outfrq9s_mg3 test mods + +Describe any changes made to the namelist: + - Add new fields clubb_bv_efold, clubb_wpxp_Ri_exp, clubb_z_displace to default list + - Add default values and namelist definition entries for many CLUBB namelist fields that were previously missing. + +List any changes to the defaults for the boundary datasets: None + +Describe any substantial timing or memory changes: None + +Code reviewed by: cacraig, adamrher, nusbaume, bstephens + +List all files eliminated: None + +List all files added and what they do: None + +List all existing files that have been modified, and describe the changes: +M Externals_CAM.cfg + - Point to new tag for CLUBB and SILHS externals + +M bld/build-namelist +M bld/namelist_files/namelist_defaults_cam.xml +M bld/namelist_files/namelist_definition.xml + - New namelist fields for CLUBB plus improved documentation and specified defaults for some older fields + +M cime_config/testdefs/testlist_cam.xml + - Change one test to be multithreaded + +M cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3/user_nl_cam + - Add CLUBB stats history to tests using these mods + +M cime_config/testdefs/testmods_dirs/cam/silhs/user_nl_cam + - Update CLUBB stats history to remove Richardson_num which is no longer output + +M cime_config/usermods_dirs/scam_mandatory/shell_commands + - Update shell redirects + +M src/physics/cam/clubb_intr.F90 +M src/physics/cam/subcol_SILHS.F90 + - Updates to support the new CLUBB and SILHS externals + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +Some tests have namelist changes due to changed stream_datafiles name in ice_in + +derecho/intel/aux_cam: + + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) details: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failures + + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) details: + - Current failure, but should be fixed when cime external is next updated + + SMS_Ld5.f09_f09_mg17.PC6.derecho_intel.cam-cam6_port_f09 (Overall: NLFAIL) details: + - New namelist fields for cam6 but CLUBB not used in Port compset + + ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details: + ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: + ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam_dev (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f19_f19.F2000dev.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: + SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - All tests using CLUBB will see small answer changes + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details: + SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: + - All tests using CLUBB will see small answer changes + +izumi/gnu/aux_cam: + SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp (Overall: NLFAIL) details: + - New namelist fields for cam6 but CLUBB not used in Port compset + + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.2000_CAM%DEV%GHGMAM4_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_SESP.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - All tests using CLUBB will see small answer changes + +CAM tag used for the baseline comparison tests if different than previous +tag: previous tag - cam6_3_154 + +Summarize any changes to answers, i.e., +- what code configurations: All configurations that use CLUBB will see answer changes (cam6 and cam_dev) +- what platforms/compilers: All platforms and compilers +- nature of change (roundoff; larger than roundoff but same climate; new +climate): Larger than roundoff but very similar climate (not verified by ECT) + +If this tag changes climate describe the run(s) done to evaluate the new +climate in enough detail that it(they) could be reproduced: +- Compare cam6_3_154 to development branch in a 1 year F2000dev f09_f09_mg17 case +- Diagnostics here: https://webext.cgd.ucar.edu/F2000climo/newCLUBBtesting/larson_tag_20231115.katemerge.011124-1252.F2000dev.f09_f09_mg17_1_2_vs_larson_tag_control.cam6_3_145.011124-1252.F2000dev.f09_f09_mg17_1_2/ + + +=============================================================== + +Tag name: cam6_3_154 +Originator(s): megandevlan, jedwards, cacraig +Date: April 4, 2024 +One-line Summary: Update U10 to be resolved wind; add variable for U10+gusts +Github PR URL: https://github.com/ESCOMP/CAM/pull/994 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Remove gustiness term from U10/add new variable with gustiness: https://github.com/ESCOMP/CAM/issues/991 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraig + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M Externals.cfg + - Bring in updated CMEPS and CDEPS to get U10 changes made in CMEPS + +M src/control/camsrfexch.F90 +M src/cpl/nuopc/atm_import_export.F90 +M src/physics/cam/cam_diagnostics.F90 + - Add U10 with gust variables + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +Some tests have namelist changes due to changed stream_datafiles name in ice_in + +derecho/intel/aux_cam: + + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) details: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failures + + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) details: + - Current failure, but should be fixed when cime external is next updated + + ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPMOZ.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPX2000.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC5HIST.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details: + ERI_D_Ln18.f45_f45_mg37.QPC41850.derecho_intel.cam-co2rmp_usecase (Overall: DIFF) details: + ERP_D_Ln9.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Lh12.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: + ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam_dev (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FSPCAMS.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep (Overall: DIFF) details: + SMS_D_Ld2.f19_f19_mg17.QPC5HIST.derecho_intel.cam-volc_usecase (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC5M7.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.QPX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f19_f19.F2000dev.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: + SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - Answer changes due to U10 output variable changes + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-carma_sea_salt (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_subcol (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QSPCAMS.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne16pg3_ne16pg3_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-outfrq3s_ttrac (Overall: DIFF) details: + ERC_D_Ln9.T5_T5_mg37.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERI_D_Ln18.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + SMS_D_Ln3.ne5pg3_ne5pg3_mg37.QPX2000.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + SMS_D_Ln6.ne5_ne5_mg37.QPWmaC4.izumi_nag.cam-outfrq3s_physgrid_tem (Overall: DIFF) details: + SMS_D_Ln7.T42_T42_mg17.QPSCAMC5.izumi_nag.cam-scmarm (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-rad_diag_mam (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details: + SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: + SUB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + - Answer changes due to U10 output variable changes + +izumi/gnu/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPC4.izumi_gnu.cam-outfrq3s_diags (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_gnu.cam-outfrq3s_unicon (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_gnu.cam-rad_diag (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPSPCAMM.izumi_gnu.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC4.izumi_gnu.cam-outfrq3s_nudging_ne5_L26 (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq3s_ba (Overall: DIFF) details: + ERI_D_Ln18.T5_T5_mg37.QPC4.izumi_gnu.cam-co2rmp (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal3 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC4.izumi_gnu.cam-scm_prep (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + SMS_D_Ln3.f10_f10_mg37.QPMOZ.izumi_gnu.cam-outfrq3s_chemproc (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.2000_CAM%DEV%GHGMAM4_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_SESP.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPWmaC4.izumi_gnu.cam-outfrq9s_apmee (Overall: DIFF) details: + SMS_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-outfrq3s_ttrac (Overall: DIFF) details: + SMS_P48x1_D_Ln9.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - Answer changes due to U10 output variable changes + +=============================================================== +=============================================================== + +Tag name: cam6_3_153 +Originator(s): cacraig, hannay, jedwards, lizziel +Date: March 26, 2023 +One-line Summary: Update namelist settings +Github PR URL: https://github.com/ESCOMP/CAM/pull/981 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Bring in namelist settings which Cecile is using for current testing: https://github.com/ESCOMP/CAM/issues/976 + - Remove README_EXTERNALS: https://github.com/ESCOMP/CAM/issues/954 + - fix so that all three flavors of intel compiler are recognized: https://github.com/ESCOMP/CAM/pull/990 + - CAM no longer builds with intel-oneapi compilers: https://github.com/ESCOMP/CAM/issues/988 + - GEOS-Chem compsets will fail due to bugs in CAM and CIME: https://github.com/ESCOMP/CAM/issues/1004 + - This fixes the CAM bug. The CIME bug will be addressed the next time externals are updated. + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: Just change default namelist settings as described below + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume, adamher + +List all files eliminated: +D README_EXTERNALS + - Remove obsolete file (discussed svn externals, which is no longer used) + +List all files added and what they do: + +List all existing files that have been modified, and describe the changes: +M bld/configure + - Fix from Jim to support selecting various intel compilers + +M bld/namelist_files/namelist_defaults_cam.xml + - Change namelist settings to mimic Cecile's settings for cam_dev runs + +M cime_config/buildnml + - Fix typo which prevented GEOS-Chem from finding yml file + + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: all BFB except: + + + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam_dev (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1.f19_f19.F2000dev.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + - Namelist and baseline differences for all cam_dev runs + + + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) details: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failures + + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) details: + - Current failure, but should be fixed when cime external is next updated + +izumi/nag/aux_cam: all BFB except + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: all BFB except: + SMS_D_Ln9.f10_f10_mg37.2000_CAM%DEV%GHGMAM4_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_SESP.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - Namelist and baseline differences for all cam_dev runs + +=============================================================== +=============================================================== +Tag name: cam6_3_152 +Originator(s): pel +Date: Jan 30, 2024 +One-line Summary: "science optimization" for SE-CSLAM and stabilize WACCM +Github PR URL: https://github.com/ESCOMP/CAM/pull/968 + +Increase computational throughput of the SE-CSLAM dynamical core by: + + - Reducing se_nsplit to 2 (from 3) in FMT: CSLAM now runs with ~30% longer time-step compared to baseline + - No double advection of thermodynamic active tracers when using CSLAM. Overwrite GLL values of Q, CLDLIQ, + etc. every vertical remapping time-step with CSLAM values (interpolated from physics grid to GLL grid) + - Vertical sponge layer diffusion in physics for WACCM and WACCM-x + - No increased hyperdiffusion in sponge for FLT and FMT + +Provide stable configuration for WACCM with spectral-elements (ne30-pg3 and ne16pg3): namelist changes + +Resolve qneg issue 864 +Resolve issue 552 (read in topo file on GLL grid if available) +Resolve issue 951 (remove namelist defaults for pg4 grids) +Resolve issue 970 (remove deprecated 'imp' module from buildnml and buildlib) + +Describe any changes made to build system: + + - added namelist variable + - modified 'buildnml' and 'buildlib' python scripts + to remove deprecated 'imp' python module. + +Describe any changes made to the namelist: + + - changed bnd_topo file for ne30-pg3 for reading in topography + on the GLL grid (if available) (issue #552) + - remove namelist defaults for pg4 topo files (issue #951) + - added namelist se_dribble_in_rsplit_loop to stabilize ne16pg3 WACCM + - change se_nsplit, se_rsplit and se_hypervis_subcycle for efficiency/stability + - se_hypervis_subcycle_sponge for efficiency/stability + - change se_nu, se_nu_div and se_sponge_del4_nu_div_fac to stabilize + ne16pg3 WACCM + + +List any changes to the defaults for the boundary datasets: + - new default topo file for ne30pg3 + +Describe any substantial timing or memory changes: + + - approximately 30% speed-up of entire CAM model using COMPSET FLTHIST or FMTHIST + +Code reviewed by: nusbaume, fvitt + +List all existing files that have been modified, and describe the changes: + +M bld/build-namelist + - add namelist variable + +M bld/namelist_files/namelist_defaults_cam.xml + - change defaults (see above) + +M bld/namelist_files/namelist_definition.xml + - add namelist variable + +M cime_config/buildlib +M cime_config/buildnml + - remove deprecated "imp" python module + +M cime_config/testdefs/testlist_cam.xml + - replace ne5pg4 FADIAB test with ne5pg3 test + +M src/dynamics/se/dp_coupling.F90 +M src/dynamics/se/dycore/control_mod.F90 +M src/dynamics/se/dycore/fvm_control_volume_mod.F90 +M src/dynamics/se/dycore/fvm_mapping.F90 +M src/dynamics/se/dycore/fvm_mod.F90 +M src/dynamics/se/dycore/fvm_reconstruction_mod.F90 +M src/dynamics/se/dycore/global_norms_mod.F90 +M src/dynamics/se/dycore/prim_advance_mod.F90 +M src/dynamics/se/dycore/prim_advection_mod.F90 +M src/dynamics/se/dycore/prim_driver_mod.F90 +M src/dynamics/se/dyn_comp.F90 +M src/dynamics/se/dyn_grid.F90 +M src/dynamics/se/dycore_budget.F90 + - implement SE dycore improvements + +M src/dynamics/se/gravity_waves_sources.F90 + - fix model top pressure bug + +M src/physics/cam/vertical_diffusion.F90 + - add vertical sponge layer diffusion + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) + - pre-existing failures + + ERC_D_Ln9.ne16_ne16_mg17.FADIAB.derecho_intel.cam-terminator (Overall: DIFF) + ERC_D_Ln9.ne16_ne16_mg17.QPC5HIST.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) + ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_intel.cam-outfrq9s (Overall: DIFF) + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) + ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) + ERS_Ln9.ne0TESTONLYne5x4_ne0TESTONLYne5x4_mg37.FADIAB.derecho_intel.cam-outfrq3s_refined (Overall: DIFF) + SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) + SMS_D_Ln9.ne16_ne16_mg17.QPX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) + SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: DIFF) + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) + - expected answer changes + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) + - pre-existing failure + + ERC_D_Ln9.ne16_ne16_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) + ERC_D_Ln9.ne16pg3_ne16pg3_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-outfrq3s_ttrac (Overall: DIFF) + ERI_D_Ln18.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s_bwic (Overall: DIFF) + ERI_D_Ln18.ne5pg3_ne5pg3_mg37.FADIAB.izumi_nag.cam-outfrq3s_bwic (Overall: DIFF) + ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) + ERS_Ln27.ne5pg3_ne5pg3_mg37.FKESSLER.izumi_nag.cam-outfrq9s (Overall: DIFF) + ERS_Ln9.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq9s (Overall: DIFF) + PEM_D_Ln9.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s (Overall: DIFF) + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) + SMS_D_Ln3.ne5pg3_ne5pg3_mg37.QPX2000.izumi_nag.cam-outfrq3s (Overall: DIFF) + SMS_D_Ln6.ne5_ne5_mg37.QPWmaC4.izumi_nag.cam-outfrq3s_physgrid_tem (Overall: DIFF) + SMS_D_Ln9_P1x1.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s (Overall: DIFF) + - expected answer changes + +izumi/gnu/aux_cam: + + ERC_D_Ln9.ne5_ne5_mg37.QPC4.izumi_gnu.cam-outfrq3s_nudging_ne5_L26 (Overall: DIFF) + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq3s_ba (Overall: DIFF) + ERC_D_Ln9.ne5pg2_ne5pg2_mg37.FADIAB.izumi_gnu.cam-outfrq3s (Overall: DIFF) + ERC_D_Ln9.ne5pg3_ne5pg3_mg37.FADIAB.izumi_gnu.cam-outfrq3s (Overall: DIFF) + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) + ERP_Ln9.ne5_ne5_mg37.FHS94.izumi_gnu.cam-outfrq9s (Overall: DIFF) + ERP_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq9s (Overall: DIFF) + PEM_D_Ln9.ne5pg3_ne5pg3_mg37.FADIAB.izumi_gnu.cam-outfrq3s (Overall: DIFF) + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal0 (Overall: DIFF) + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal1 (Overall: DIFF) + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal3 (Overall: DIFF) + SMS_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-outfrq3s_ttrac (Overall: DIFF) + - expected answer changes + +Summarize any changes to answers: +All spectral-element tests fail due to baseline differences. + + The SE-CSLAM tests fail because of no double-advection + change as well as default hyperviscosity change + The SE (not CSLAM) tests fail because default + hyperviscosity has changed + All WACCM tests fail due to added sponge layer + vertical diffusion + +=============================================================== +=============================================================== + +Tag name: cam6_3_151 +Originator(s): eaton +Date: Thu 21 Mar 2024 +One-line Summary: Bugfix to allow multiple monthly avg history files +Github PR URL: https://github.com/ESCOMP/CAM/pull/1003 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +#1000 - Output of more than 1 monthly average history file is broken. + +. resolves #1000 + +Describe any changes made to build system: none + +Describe any changes made to the namelist: none + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: none + +Code reviewed by: cacraigucar, peverwhee + +List all files eliminated: none + +List all files added and what they do: none + +List all existing files that have been modified, and describe the changes: + +src/control/cam_history.F90 +. subroutine wshist + - add new local variables to store the year, month, and day components of + the time interval midpoint date. + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +All tests have a MEMCOMP failure which we are ignoring. +Several tests have a TPUTCOMP failure which we are also ignoring. + +derecho/intel/aux_cam: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: FAIL) details: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + - pre-existing failures + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: + All PASS. + +TESTING NOTE: None of our regression tests use multiple monthly output +files. The fix was tested in a low res FHS94 compset that specified +monthly output for h0, h1, h2, and h3. The 'T' field was output in each +file. A 1 month test was run and all files had identical output. This is +the same configuration that I used to debug the problem. + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers: BFB + +=============================================================== +=============================================================== + +Tag name: cam6_3_150 +Originator(s): megandevlan, peverwhee +Date: Feb 23, 2024 +One-line Summary: Adding convective gustiness to U10: Add UGUST output to CAM +Github PR URL: https://github.com/ESCOMP/CAM/pull/943 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Update CMEPS external to bring in gustiness + - Add UGUST output to CAM + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: + - can now include 'UGUST' in fincl lists (default: Average flag) + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraigucar, peverwhee + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M Externals.cfg + - Update CMEPS tag to bring in gustiness + +M src/control/camsrfexch.F90 + - Add ugust to cam_in + +M src/cpl/nuopc/atm_import_export.F90 + - Set ugust + +M src/physics/cam/cam_diagnostics.F90 + - Add UGUST addfld/outfld calls + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +All (coupled) jobs had errors about MEMCOMP failing due to missing files - to +be fixed in upcoming CIME tag + +derecho/intel/aux_cam: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) details: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) details: + - pre-existing failures + + ERC_D_Ln9.ne16_ne16_mg17.FADIAB.derecho_intel.cam-terminator (Overall: NLFAIL) details: + ERC_D_Ln9.T42_T42_mg17.FDABIP04.derecho_intel.cam-outfrq3s_usecase (Overall: NLFAIL) details: + ERC_D_Ln9.T42_T42_mg17.FHS94.derecho_intel.cam-outfrq3s_usecase (Overall: NLFAIL) details: + ERS_Ln9.ne0TESTONLYne5x4_ne0TESTONLYne5x4_mg37.FADIAB.derecho_intel.cam-outfrq3s_refined (Overall: NLFAIL) details: + SMS_D_Ld5.f19_f19_mg17.PC4.derecho_intel.cam-cam4_port5d (Overall: NLFAIL) details: + SMS_Ld5.f09_f09_mg17.PC6.derecho_intel.cam-cam6_port_f09 (Overall: NLFAIL) details: + - add_gusts added to nuopc.runconfig + + ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPMOZ.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPX2000.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC5HIST.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details: + ERI_D_Ln18.f45_f45_mg37.QPC41850.derecho_intel.cam-co2rmp_usecase (Overall: DIFF) details: + ERP_D_Ln9.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Lh12.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: + ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam_dev (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FSPCAMS.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep (Overall: DIFF) details: + SMS_D_Ld2.f19_f19_mg17.QPC5HIST.derecho_intel.cam-volc_usecase (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC5M7.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.QPX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f19_f19.F2000dev.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: + SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - failures due to So_ugustOut in cpl.hi and answer changes for cam_dev tests + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + + ERC_D_Ln9.mpasa480z32_mpasa480.FHS94.izumi_nag.cam-outfrq3s_usecase (Overall: NLFAIL) details: + ERI_D_Ln18.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s_bwic (Overall: NLFAIL) details: + ERI_D_Ln18.ne5pg3_ne5pg3_mg37.FADIAB.izumi_nag.cam-outfrq3s_bwic (Overall: NLFAIL) details: + ERS_Ln27.ne5pg3_ne5pg3_mg37.FKESSLER.izumi_nag.cam-outfrq9s (Overall: NLFAIL) details: + ERS_Ln9.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq9s (Overall: NLFAIL) details: + PEM_D_Ln9.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s (Overall: NLFAIL) details: + SMS_D_Ld2.f45_f45_mg37.PC5.izumi_nag.cam-outfrq24h_port (Overall: NLFAIL) details: + SMS_D_Ln9_P1x1.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s (Overall: NLFAIL) details: + TMC_D.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: NLFAIL) details: + TMC_D.T5_T5_mg37.QPC5.izumi_nag.cam-ghgrmp_e8 (Overall: NLFAIL) details: + - add_gusts added to nuopc.runconfig + + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-carma_sea_salt (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_subcol (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QSPCAMS.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne16pg3_ne16pg3_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-outfrq3s_ttrac (Overall: DIFF) details: + ERC_D_Ln9.T5_T5_mg37.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERI_D_Ln18.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + SMS_D_Ln3.ne5pg3_ne5pg3_mg37.QPX2000.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + SMS_D_Ln6.ne5_ne5_mg37.QPWmaC4.izumi_nag.cam-outfrq3s_physgrid_tem (Overall: DIFF) details: + SMS_D_Ln7.T42_T42_mg17.QPSCAMC5.izumi_nag.cam-scmarm (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-rad_diag_mam (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details: + SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: + SUB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + - failures due to So_ugustOut in cpl.hi + +izumi/gnu/aux_cam: + ERC_D_Ln9.f10_f10_mg37.FADIAB.izumi_gnu.cam-terminator (Overall: NLFAIL) details: + ERC_D_Ln9.ne5pg2_ne5pg2_mg37.FADIAB.izumi_gnu.cam-outfrq3s (Overall: NLFAIL) details: + ERC_D_Ln9.ne5pg4_ne5pg4_mg37.FADIAB.izumi_gnu.cam-outfrq3s (Overall: NLFAIL) details: + ERP_Ln9.ne5_ne5_mg37.FHS94.izumi_gnu.cam-outfrq9s (Overall: NLFAIL) details: + PEM_D_Ln9.ne5pg3_ne5pg3_mg37.FADIAB.izumi_gnu.cam-outfrq3s (Overall: NLFAIL) details: + SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp (Overall: NLFAIL) details: + - add_gusts added to nuopc.runconfig + + ERC_D_Ln9.f10_f10_mg37.QPC4.izumi_gnu.cam-outfrq3s_diags (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_gnu.cam-outfrq3s_unicon (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_gnu.cam-rad_diag (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPSPCAMM.izumi_gnu.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC4.izumi_gnu.cam-outfrq3s_nudging_ne5_L26 (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq3s_ba (Overall: DIFF) details: + ERI_D_Ln18.T5_T5_mg37.QPC4.izumi_gnu.cam-co2rmp (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal3 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC4.izumi_gnu.cam-scm_prep (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + SMS_D_Ln3.f10_f10_mg37.QPMOZ.izumi_gnu.cam-outfrq3s_chemproc (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.2000_CAM%DEV%GHGMAM4_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_SESP.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPWmaC4.izumi_gnu.cam-outfrq9s_apmee (Overall: DIFF) details: + SMS_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-outfrq3s_ttrac (Overall: DIFF) details: + SMS_P48x1_D_Ln9.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - failures due to So_ugustOut in cpl.hi and answer changes for cam_dev tests + +=============================================================== +=============================================================== + +Tag name: cam6_3_149 +Originator(s): cacraig, fischer, jedwards +Date: Feb 22, 2024 +One-line Summary: Update externals to match cesm2_3_alpha17a +Github PR URL: https://github.com/ESCOMP/CAM/pull/977 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Update externals to match CESM alpha17a tag and the cime external needed to support GEOS-Chem + - Made changes to fix failing regression tests + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M Externals.cfg + - Update externals to match cesm2_3_alpha17a + - Update cime tag to newer one to support GEOS-Chem + +M cime_config/SystemTests/tmc.py + - Fix failing TMC test (due to changes in cime) + +M cime_config/buildnml + - Fix failing GEOS-Chem test (due to changes in externals) + +M cime_config/testdefs/testlist_cam.xml + - Remove obsolete _Vnuopc qualifier on tests + - Introduce a few test types to prealpha testing (they had previously been exclusively tested in aux_cam) + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +All jobs had errors about MEMCOMP and TPUTCOMP failing due to missing files (due to changes in externals now making these files) + +derecho/intel/aux_cam: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) details: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: FAIL) details: + - pre-existing failures + + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_D_Ln9_Vnuopc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3_Vnuopc.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Lh12_Vnuopc.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + ERP_Ln9_Vnuopc.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_Vnuopc.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_Vnuopc.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9_Vnuopc.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_Vnuopc.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_Vnuopc.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_Vnuopc.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_Vnuopc.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ld3_Vnuopc.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam_dev (Overall: DIFF) details: + ERS_Ln9_P288x1_Vnuopc.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + ERS_Ln9_P36x1_Vnuopc.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + ERS_Ln9_Vnuopc.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_Vnuopc.f19_f19_mg17.FSPCAMS.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_Vnuopc.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9_Vnuopc.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_Vnuopc.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_Vnuopc.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_Vnuopc.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9_Vnuopc_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_Vnuopc_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1_Vnuopc.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1_Vnuopc.f19_f19.F2000dev.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1_Vnuopc.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12_Vnuopc.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Lm13_Vnuopc.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + SMS_Ln9_Vnuopc.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9_Vnuopc.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9_Vnuopc.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: + SMS_Ln9_Vnuopc.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: + - Differences due to changed externals + +izumi/nag/aux_cam: All baselines PASS for nag + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: all BFB except: + FAIL SMS_D_Ln9.f10_f10_mg37.2000_CAM%DEV%GHGMAM4_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_SESP.izumi_gnu.cam-outfrq9s BASELINE /fs/cgd/csm/models/atm/cam/pretag_bl/cam6_3_148_gnu: DIFF + FAIL SMS_P48x1_D_Ln9_Vnuopc.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s BASELINE /fs/cgd/csm/models/atm/cam/pretag_bl/cam6_3_148_gnu: DIFF + - Differences due to changed externals + +=============================================================== =============================================================== Tag name: cam6_3_148 @@ -38,7 +1324,7 @@ src/physics/rrtmg/ebert_curry.F90 src/physics/rrtmg/oldcloud.F90 src/physics/rrtmg/slingo.F90 . these cloud optics files which can be shared by rrtmg and rrtmgp are - moved to src/physics/cam + moved to src/physics/cam List all files added and what they do: @@ -124,7 +1410,7 @@ src/physics/cam/aerosol_optics_cam.F90 src/physics/cam/phys_prop.F90 . add the public parameter nrh to this module. Was previously in - radconstants. + radconstants. . turn off old debug output to log file src/physics/cam/physpkg.F90 diff --git a/src/chemistry/mozart/mo_jshort.F90 b/src/chemistry/mozart/mo_jshort.F90 index aa47dffb31..97ec5f1375 100644 --- a/src/chemistry/mozart/mo_jshort.F90 +++ b/src/chemistry/mozart/mo_jshort.F90 @@ -71,6 +71,9 @@ module mo_jshort real(r8), allocatable :: xs_o3b(:) real(r8), allocatable :: xs_wl(:,:) + real(r8), parameter :: lno2_llimit = 38._r8 ! ln(NO2) lower limit + real(r8), parameter :: lno2_ulimit = 56._r8 ! ln(NO2) upper limit + contains subroutine jshort_init( xs_coef_file, xs_short_file, sht_indexer ) @@ -1492,13 +1495,13 @@ subroutine calc_o2srb( nlev, nid, o2col, tlev, tsrb, xscho2 ) do k = 1,nlev x = log( o2col(k) ) - if( x >= 38._r8 .and. x <= 56._r8 ) then + if( x >= lno2_llimit .and. x <= lno2_ulimit ) then call effxs( x, tlev(k), xs ) xscho2(k,:) = xs(:) - else if( x < 38._r8 ) then + else if( x < lno2_llimit ) then ktop1 = k-1 ktop = min( ktop1,ktop ) - else if( x > 56._r8 ) then + else if( x > lno2_ulimit ) then kbot = k end if end do @@ -1601,9 +1604,9 @@ subroutine effxs( x, t, xs ) ! method: ! ln(xs) = A(X)[T-220]+B(X) ! X = log of slant column of O2 -! A,B calculated from chebyshev polynomial coeffs -! AC and BC using NR routine chebev. Assume interval -! is 38lno2_ulimit) then + call endrun('mo_jshort::calc_params of O2 abs xs: x is not in the valid range. ') + end if + !------------------------------------------------------------- -! ... call chebyshev evaluation routine to calc a and b from -! set of 20 coeficients for each wavelength +! ... evaluate at each wavelength +! for a set of 20 Chebyshev coeficients !------------------------------------------------------------- do i = 1,nsrbtuv - a(i) = jchebev( 38._r8, 56._r8, ac(1,i), 20, x ) - b(i) = jchebev( 38._r8, 56._r8, bc(1,i), 20, x ) + a(i) = evalchebpoly( ac(:,i), x ) + b(i) = evalchebpoly( bc(:,i), x ) end do contains - function jchebev( a, b, c, m, x ) -!------------------------------------------------------------- -! Chebyshev evaluation algorithm -! See Numerical recipes p193 -!------------------------------------------------------------- + ! Use Clenshaw summation algorithm to evaluate Chebyshev polynomial at point + ! [pnt - (lno2_ulimit + lno2_llimit)/2]/[(lno2_ulimit - lno2_llimit)/2] + ! given coefficients coefs within limits lim1 and lim2 + pure function evalchebpoly( coefs, pnt ) result(cval) + real(r8), intent(in) :: coefs(:) + real(r8), intent(in) :: pnt -!------------------------------------------------------------- -! ... Dummy arguments -!------------------------------------------------------------- - integer, intent(in) :: m - real(r8), intent(in) :: a, b, x - real(r8), intent(in) :: c(m) + real(r8) :: cval + real(r8) :: fac(2) + real(r8) :: csum(2) ! Clenshaw summation + integer :: ndx + integer :: ncoef - real(r8) :: jchebev -!------------------------------------------------------------- -! ... Local variables -!------------------------------------------------------------- - integer :: j - real(r8) :: d, dd, sv, y, y2 + ncoef = size(coefs) - if( (x - a)*(x - b) > 0._r8 ) then - write(iulog,*) 'x not in range in chebev', x - jchebev = 0._r8 - return - end if + fac(1) = (2._r8*pnt-lno2_llimit-lno2_ulimit)/(lno2_ulimit-lno2_llimit) + fac(2) = 2._r8*fac(1) - d = 0._r8 - dd = 0._r8 - y = (2._r8*x - a - b)/(b - a) - y2 = 2._r8*y - do j = m,2,-1 - sv = d - d = y2*d - dd + c(j) - dd = sv - end do + ! Clenshaw recurrence summation + csum(:) = 0.0_r8 + do ndx = ncoef, 2, -1 + cval = csum(1) + csum(1) = fac(2)*csum(1) - csum(2) + coefs(ndx) + csum(2) = cval + end do - jchebev = y*d - dd + .5_r8*c(1) + cval = fac(1)*csum(1) - csum(2) + 0.5_r8*coefs(1) - end function jchebev + end function evalchebpoly end subroutine calc_params diff --git a/src/chemistry/mozart/sv_decomp.F90 b/src/chemistry/mozart/sv_decomp.F90 deleted file mode 100644 index 0540f1f575..0000000000 --- a/src/chemistry/mozart/sv_decomp.F90 +++ /dev/null @@ -1,364 +0,0 @@ -!------------------------------------------------------------------------- -! purpose: singular value decomposition -! -! method: -! given a matrix a(1:m,1:n), with physical dimensions mp by np, -! this routine computes its singular value decomposition, -! the matrix u replaces a on output. the -! diagonal matrix of singular values w is output as a vector -! w(1:n). the matrix v (not the transpose v^t) is output as -! v(1:n,1:n). -! -! author: a. maute dec 2003 -! (* copyright (c) 1985 numerical recipes software -- svdcmp *! -! from numerical recipes 1986 pp. 60 or can be find on web-sites -!------------------------------------------------------------------------- - - module sv_decomp - - use shr_kind_mod, only : r8 => shr_kind_r8 - - implicit none - - private - public :: svdcmp - public :: svbksb - - integer, parameter :: nmax = 1600 - - contains - - subroutine svdcmp( a, m, n, mp, np, w, v ) -!------------------------------------------------------------------------- -! ... dummy arguments -!------------------------------------------------------------------------- - integer, intent(in) :: m - integer, intent(in) :: n - integer, intent(in) :: mp - integer, intent(in) :: np - real(r8), intent(inout) :: a(mp,np) - real(r8), intent(out) :: v(np,np) - real(r8), intent(out) :: w(np) - -!------------------------------------------------------------------------- -! ... local variables -!------------------------------------------------------------------------- - integer :: i, its, j, k, l, nm - real(r8) :: anorm - real(r8) :: c - real(r8) :: f - real(r8) :: g - real(r8) :: h - real(r8) :: s - real(r8) :: scale - real(r8) :: x, y, z - real(r8) :: rv1(nmax) - logical :: cnd1 - logical :: cnd2 - - g = 0.0_r8 - scale = 0.0_r8 - anorm = 0.0_r8 - -loop1 : & - do i = 1,n - l = i + 1 - rv1(i) = scale*g - g = 0.0_r8 - s = 0.0_r8 - scale = 0.0_r8 - if( i <= m ) then - do k = i,m - scale = scale + abs(a(k,i)) - end do - if( scale /= 0.0_r8 ) then - do k = i,m - a(k,i) = a(k,i)/scale - s = s + a(k,i)*a(k,i) - end do - f = a(i,i) - g = -sign(sqrt(s),f) - h = f*g - s - a(i,i) = f - g - if( i /= n ) then - do j = l,n - s = 0.0_r8 - do k = i,m - s = s + a(k,i)*a(k,j) - end do - f = s/h - do k = i,m - a(k,j) = a(k,j) + f*a(k,i) - end do - end do - end if - do k = i,m - a(k,i) = scale*a(k,i) - end do - endif - endif - w(i) = scale *g - g = 0.0_r8 - s = 0.0_r8 - scale = 0.0_r8 - if( i <= m .and. i /= n ) then - do k = l,n - scale = scale + abs(a(i,k)) - end do - if( scale /= 0.0_r8 ) then - do k = l,n - a(i,k) = a(i,k)/scale - s = s + a(i,k)*a(i,k) - end do - f = a(i,l) - g = -sign(sqrt(s),f) - h = f*g - s - a(i,l) = f - g - do k = l,n - rv1(k) = a(i,k)/h - end do - if( i /= m ) then - do j = l,m - s = 0.0_r8 - do k = l,n - s = s + a(j,k)*a(i,k) - end do - do k = l,n - a(j,k) = a(j,k) + s*rv1(k) - end do - end do - end if - do k = l,n - a(i,k) = scale*a(i,k) - end do - end if - end if - anorm = max( anorm,(abs(w(i)) + abs(rv1(i))) ) - end do loop1 - - do i = n,1,-1 - if( i < n ) then - if( g /= 0.0_r8 ) then - do j = l,n - v(j,i) = (a(i,j)/a(i,l))/g - end do - do j = l,n - s = 0.0_r8 - do k = l,n - s = s + a(i,k)*v(k,j) - end do - do k = l,n - v(k,j) = v(k,j) + s*v(k,i) - end do - end do - end if - do j = l,n - v(i,j) = 0.0_r8 - v(j,i) = 0.0_r8 - end do - end if - v(i,i) = 1.0_r8 - g = rv1(i) - l = i - end do - - do i = n,1,-1 - l = i + 1 - g = w(i) - if( i < n ) then - do j = l,n - a(i,j) = 0.0_r8 - end do - end if - if( g /= 0.0_r8 ) then - g = 1.0_r8/g - if( i /= n ) then - do j = l,n - s = 0.0_r8 - do k = l,m - s = s + a(k,i)*a(k,j) - end do - f = (s/a(i,i))*g - do k = i,m - a(k,j) = a(k,j) + f*a(k,i) - end do - end do - end if - do j = i,m - a(j,i) = a(j,i)*g - end do - else - do j = i,m - a(j,i) = 0.0_r8 - end do - end if - a(i,i) = a(i,i) + 1.0_r8 - end do - - do k = n,1,-1 -loop2 : do its = 1,30 - do l = k,1,-1 - nm = l - 1 - cnd1 = abs( rv1(l) ) + anorm == anorm - if( cnd1 ) then - cnd2 = .false. - exit - end if - cnd2 = abs( w(nm) ) + anorm == anorm - if( cnd2 ) then - cnd1 = .true. - exit - else if( l == 1 ) then - cnd1 = .true. - cnd2 = .true. - end if - end do - - if( cnd2 ) then - c = 0.0_r8 - s = 1.0_r8 - do i = l,k - f = s*rv1(i) - if( (abs(f) + anorm) /= anorm ) then - g = w(i) - h = sqrt(f*f + g*g) - w(i) = h - h = 1.0_r8/h - c = (g*h) - s = -(f*h) - do j = 1,m - y = a(j,nm) - z = a(j,i) - a(j,nm) = (y*c) + (z*s) - a(j,i) = -(y*s) + (z*c) - end do - end if - end do - end if - - if( cnd1 ) then - z = w(k) - if( l == k ) then - if( z < 0.0_r8 ) then - w(k) = -z - do j = 1,n - v(j,k) = -v(j,k) - end do - end if - exit loop2 - end if - end if - - x = w(l) - nm = k - 1 - y = w(nm) - g = rv1(nm) - h = rv1(k) - f = ((y - z)*(y + z) + (g - h)*(g + h))/(2.0_r8*h*y) - g = sqrt( f*f + 1.0_r8 ) - f = ((x - z)*(x + z) + h*((y/(f + sign(g,f))) - h))/x - c = 1.0_r8 - s = 1.0_r8 - do j = l,nm - i = j + 1 - g = rv1(i) - y = w(i) - h = s*g - g = c*g - z = sqrt( f*f + h*h ) - rv1(j) = z - c = f/z - s = h/z - f = (x*c)+(g*s) - g = -(x*s)+(g*c) - h = y*s - y = y*c - do nm = 1,n - x = v(nm,j) - z = v(nm,i) - v(nm,j) = (x*c)+(z*s) - v(nm,i) = -(x*s)+(z*c) - end do - z = sqrt( f*f + h*h ) - w(j) = z - if( z /= 0.0_r8 ) then - z = 1.0_r8/z - c = f*z - s = h*z - end if - f = (c*g)+(s*y) - x = -(s*g)+(c*y) - do nm = 1,m - y = a(nm,j) - z = a(nm,i) - a(nm,j) = (y*c)+(z*s) - a(nm,i) = -(y*s)+(z*c) - end do - end do - rv1(l) = 0.0_r8 - rv1(k) = f - w(k) = x - end do loop2 - end do - - end subroutine svdcmp - -!------------------------------------------------------------------------- -! purpose: solves a*x = b -! -! method: -! solves a*x = b for a vector x, where a is specified by the arrays -! u,w,v as returned by svdcmp. m and n -! are the logical dimensions of a, and will be equal for square matrices. -! mp and np are the physical dimensions of a. b(1:m) is the input right-hand -! side. x(1:n) is the output solution vector. no input quantities are -! destroyed, so the routine may be called sequentially with different b -! -! author: a. maute dec 2002 -! (* copyright (c) 1985 numerical recipes software -- svbksb *! -! from numerical recipes 1986 pp. 57 or can be find on web-sites -!------------------------------------------------------------------------- - - subroutine svbksb( u, w, v, m, n, mp, np, b, x ) -!------------------------------------------------------------------------- -! ... dummy arguments -!------------------------------------------------------------------------- - integer, intent(in) :: m - integer, intent(in) :: n - integer, intent(in) :: mp - integer, intent(in) :: np - real(r8), intent(in) :: u(mp,np) - real(r8), intent(in) :: w(np) - real(r8), intent(in) :: v(np,np) - real(r8), intent(in) :: b(mp) - real(r8), intent(out) :: x(np) - -!------------------------------------------------------------------------- -! ... local variables -!------------------------------------------------------------------------- - integer :: i, j, jj - real(r8) :: s - real(r8) :: tmp(nmax) - - do j = 1,n - s = 0._r8 - if( w(j) /= 0._r8 ) then - do i = 1,m - s = s + u(i,j)*b(i) - end do - s = s/w(j) - endif - tmp(j) = s - end do - - do j = 1,n - s = 0._r8 - do jj = 1,n - s = s + v(j,jj)*tmp(jj) - end do - x(j) = s - end do - - end subroutine svbksb - - end module sv_decomp diff --git a/src/chemistry/utils/apex.F90 b/src/chemistry/utils/apex.F90 index d4b60af9b1..bb690a8b42 100644 --- a/src/chemistry/utils/apex.F90 +++ b/src/chemistry/utils/apex.F90 @@ -2015,8 +2015,8 @@ subroutine cofrm(date) ! Set outputs gb(ncoef) and gv(ncoef) ! These are module data above. ! - gb(1) = 0._r8 - gv(1) = 0._r8 + gb(:) = 0._r8 + gv(:) = 0._r8 f0 = -1.e-5_r8 do k=2,kmx if (n < m) then diff --git a/src/control/cam_history.F90 b/src/control/cam_history.F90 index 28e1d848f2..a0b35e5a1d 100644 --- a/src/control/cam_history.F90 +++ b/src/control/cam_history.F90 @@ -5516,6 +5516,7 @@ subroutine wshist (rgnht_in) #endif integer :: yr, mon, day ! year, month, and day components of a date + integer :: yr_mid, mon_mid, day_mid ! year, month, and day components of midpoint date integer :: nstep ! current timestep number integer :: ncdate(maxsplitfiles) ! current (or midpoint) date in integer format [yyyymmdd] integer :: ncsec(maxsplitfiles) ! current (or midpoint) time of day [seconds] @@ -5529,7 +5530,6 @@ subroutine wshist (rgnht_in) logical :: prev ! Label file with previous date rather than current logical :: duplicate ! Flag for duplicate file name integer :: ierr - integer :: ncsec_temp #if ( defined BFB_CAM_SCAM_IOP ) integer :: tsec ! day component of current time integer :: dtime ! seconds component of current time @@ -5583,6 +5583,7 @@ subroutine wshist (rgnht_in) end if end if end if + time = ndcur + nscur/86400._r8 if (is_initfile(file_index=t)) then tdata = time ! Inithist file is always instantanious data @@ -5590,10 +5591,12 @@ subroutine wshist (rgnht_in) tdata(1) = beg_time(t) tdata(2) = time end if + ! Set midpoint date/datesec for accumulated file - call set_date_from_time_float((tdata(1) + tdata(2)) / 2._r8, yr, mon, day, ncsec_temp) - ncsec(accumulated_file_index) = ncsec_temp - ncdate(accumulated_file_index) = yr*10000 + mon*100 + day + call set_date_from_time_float((tdata(1) + tdata(2)) / 2._r8, & + yr_mid, mon_mid, day_mid, ncsec(accumulated_file_index) ) + ncdate(accumulated_file_index) = yr_mid*10000 + mon_mid*100 + day_mid + if (hstwr(t) .or. (restart .and. rgnht(t))) then if(masterproc) then if(is_initfile(file_index=t)) then @@ -5609,7 +5612,7 @@ subroutine wshist (rgnht_in) if (f == instantaneous_file_index) then write(iulog,200) nfils(t),'instantaneous',t,yr,mon,day,ncsec(f) else - write(iulog,200) nfils(t),'accumulated',t,yr,mon,day,ncsec(f) + write(iulog,200) nfils(t),'accumulated',t,yr_mid,mon_mid,day_mid,ncsec(f) end if 200 format('WSHIST: writing time sample ',i3,' to ', a, ' h-file ', & i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) diff --git a/src/control/camsrfexch.F90 b/src/control/camsrfexch.F90 index de1ea4ce6e..0357ba3128 100644 --- a/src/control/camsrfexch.F90 +++ b/src/control/camsrfexch.F90 @@ -100,6 +100,8 @@ module camsrfexch real(r8) :: tref(pcols) ! ref height surface air temp real(r8) :: qref(pcols) ! ref height specific humidity real(r8) :: u10(pcols) ! 10m wind speed + real(r8) :: ugustOut(pcols) ! gustiness added + real(r8) :: u10withGusts(pcols) ! 10m wind speed with gusts added real(r8) :: ts(pcols) ! merged surface temp real(r8) :: sst(pcols) ! sea surface temp real(r8) :: snowhland(pcols) ! snow depth (liquid water equivalent) over land @@ -218,6 +220,8 @@ subroutine hub2atm_alloc( cam_in ) cam_in(c)%tref (:) = 0._r8 cam_in(c)%qref (:) = 0._r8 cam_in(c)%u10 (:) = 0._r8 + cam_in(c)%ugustOut (:) = 0._r8 + cam_in(c)%u10withGusts (:) = 0._r8 cam_in(c)%ts (:) = 0._r8 cam_in(c)%sst (:) = 0._r8 cam_in(c)%snowhland(:) = 0._r8 diff --git a/src/cpl/nuopc/atm_import_export.F90 b/src/cpl/nuopc/atm_import_export.F90 index baadd00865..c96a01eca4 100644 --- a/src/cpl/nuopc/atm_import_export.F90 +++ b/src/cpl/nuopc/atm_import_export.F90 @@ -245,6 +245,8 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_re' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ustar' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Sx_u10' ) + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_ugustOut') + call fldlist_add(fldsToAtm_num, fldsToAtm, 'So_u10withGust') call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_taux' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_tauy' ) call fldlist_add(fldsToAtm_num, fldsToAtm, 'Faxx_lat' ) @@ -767,6 +769,30 @@ subroutine import_fields( gcomp, cam_in, restart_init, rc) end do end if + call state_getfldptr(importState, 'So_ugustOut', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%ugustOut(i) = fldptr1d(g) + g = g + 1 + end do + end do + end if + + call state_getfldptr(importState, 'So_u10withGust', fldptr=fldptr1d, exists=exists, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (exists) then + g = 1 + do c = begchunk,endchunk + do i = 1,get_ncols_p(c) + cam_in(c)%u10withGusts(i) = fldptr1d(g) + g = g + 1 + end do + end do + end if + ! bgc scenarios call state_getfldptr(importState, 'Fall_fco2_lnd', fldptr=fldptr1d, exists=exists_fco2_lnd, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/src/dynamics/fv3/Makefile.in.fv3 b/src/dynamics/fv3/Makefile.in.fv3 deleted file mode 100644 index 1eb3370d3e..0000000000 --- a/src/dynamics/fv3/Makefile.in.fv3 +++ /dev/null @@ -1,175 +0,0 @@ -.SUFFIXES : .F .f .c .o .a .f90 .f95 -######################################################################## -# -# The Makefile for building the FV3 library is created by CAM's configure -# using this template and prepending the following macros: -# -# The macro CAM_BLD is also prepended. It is the build directory of the CAM -# code and it contains the abortutils.mod file. The abortutils module is -# referenced by FV3 code in order to perform an abort which is appropriate -# for the CESM system. -# -# The main customization required for the library to link with CAM is to -# use autopromotion of the default real type to real*8. This is required -# in most, though not all, of the FV3 files. Also, some compilers require -# special flags to specify fixed or free format source (rather than depend -# on filename extensions). Thus, the explicit rules at the end of this -# template for compiling FV3 files have been modified to allow different -# sets of flags for 1) files that cannot be compiled with autopromotion, -# and 2) files that use fixed format source. -# -# The generated Makefile will be used by a sub-Make issued from CAM's Make. -# The sub-Make will inherit the macros: -# -# FC name of Fortran90 compiler -# FC_FLAGS Fortran compiler flags -# -######################################################################## - -# Load dependency search path. -cpp_dirs := . -cpp_dirs += $(shell cat Filepath) - -# Create VPATH from Filepath file created by CAM configure -# Expand any tildes in directory names. Change spaces to colons. -VPATH := $(foreach dir,$(cpp_dirs),$(wildcard $(dir))) -VPATH := $(subst $(space),:,$(VPATH)) - -INCS := $(foreach dir,$(cpp_dirs),-I$(dir)) - -F90 := $(FC) -C90 := $(CC) -F90FLAGS := $(FREEFLAGS) $(FFLAGS) - -OBJS = a2b_edge.o boundary.o dyn_core.o external_ic.o \ - external_sst.o fv_arrays.o fv_cmp.o fv_control.o \ - fv_diagnostics.o fv_dynamics.o fv_eta.o fv_fill.o \ - fv_grid_tools.o fv_grid_utils.o fv_io.o fv_mapz.o \ - fv_mp_mod.o fv_nesting.o fv_nudge.o fv_regional_bc.o \ - fv_restart.o fv_sg.o fv_surf_map.o fv_timing.o \ - fv_tracer2d.o fv_treat_da_inc.o fv_update_phys.o gfdl_cloud_microphys.o \ - init_hydro.o module_mp_radar.o nh_core.o nh_utils.o sim_nc_mod.o \ - sorted_index.o sw_core.o test_cases.o tp_core.o - -complib: libfv3core.a - -libfv3core.a: $(OBJS) - ar cr libfv3core.a $(OBJS) - -db_files: - @echo " " - @echo "* VPATH := $(VPATH)" -db_flags: - @echo " " - @echo "* cc := $(CC) $(CFLAGS) $(INCLDIR) $(INCS)" - @echo "* .F.o := $(FC) $(F90FLAGS) $(INCLDIR) $(INCS)" - -#------------------------------------------------------------------------------- -# Rules for gnu specific compiler directives for FV3 library code -#------------------------------------------------------------------------------- - -ifeq ($(FC_TYPE), gnu) -fv_arrays.o: fv_arrays.F90 - $(F90) -c $(INCLDIR) $(INCS) $(F90FLAGS) -fno-range-check $< - -fv_regional_bc.o: fv_regional_bc.F90 - $(F90) -c $(INCLDIR) $(INCS) $(F90FLAGS) -fno-range-check $< - -gfdl_cloud_microphys.o: gfdl_cloud_microphys.F90 - $(F90) -c $(INCLDIR) $(INCS) $(F90FLAGS) -fdec $< - -module_mp_radar.o: module_mp_radar.F90 - $(F90) -c $(INCLDIR) $(INCS) $(F90FLAGS) -fdec $< -endif - -%.o: %.f90 - $(F90) $(F90FLAGS) $(INCLDIR) $(INCS) -c $< -%.o: %.F90 - $(F90) $(F90FLAGS) $(INCLDIR) $(INCS) -c $< -%.o: %.c - $(C90) $(CFLAGS) $(INCLDIR) $(INCS) -c $< - -# Dependencies (FV3 library) -# Declare all module files used to build each object. -a2b_edge.o : a2b_edge.F90 fv_arrays_mod.mod fv_grid_utils_mod.mod -boundary.o : boundary.F90 fv_arrays_mod.mod fv_timing_mod.mod fv_mp_mod.mod -dyn_core.o : dyn_core.F90 fv_update_phys_mod.mod a2b_edge_mod.mod fv_arrays_mod.mod fv_nwp_nudge_mod.mod fv_regional_mod.mod fv_mp_mod.mod nh_core_mod.mod test_cases_mod.mod boundary_mod.mod fv_timing_mod.mod fv_diagnostics_mod.mod sw_core_mod.mod tp_core_mod.mod -external_ic.o : external_ic.F90 fv_mapz_mod.mod fv_io_mod.mod fv_eta_mod.mod fv_arrays_mod.mod fv_regional_mod.mod sim_nc_mod.mod fv_surf_map_mod.mod boundary_mod.mod fv_grid_utils_mod.mod fv_fill_mod.mod fv_timing_mod.mod fv_diagnostics_mod.mod external_sst_mod.mod init_hydro_mod.mod fv_nwp_nudge_mod.mod fv_mp_mod.mod test_cases_mod.mod -external_sst.o : external_sst.F90 -fv_arrays.o : fv_arrays.F90 -fv_cmp.o : fv_cmp.F90 fv_arrays_mod.mod gfdl_cloud_microphys_mod.mod fv_mp_mod.mod -fv_control.o : fv_control.F90 fv_io_mod.mod fv_eta_mod.mod fv_arrays_mod.mod fv_grid_utils_mod.mod fv_diagnostics_mod.mod fv_timing_mod.mod fv_grid_tools_mod.mod fv_mp_mod.mod fv_restart_mod.mod test_cases_mod.mod -fv_diagnostics.o : fv_diagnostics.F90 fv_mapz_mod.mod fv_eta_mod.mod fv_arrays_mod.mod fv_sg_mod.mod fv_surf_map_mod.mod fv_grid_utils_mod.mod a2b_edge_mod.mod gfdl_cloud_microphys_mod.mod fv_mp_mod.mod -fv_dynamics.o : fv_dynamics.F90 fv_mapz_mod.mod fv_arrays_mod.mod fv_regional_mod.mod fv_sg_mod.mod boundary_mod.mod fv_grid_utils_mod.mod fv_diagnostics_mod.mod fv_timing_mod.mod fv_fill_mod.mod dyn_core_mod.mod fv_nesting_mod.mod fv_tracer2d_mod.mod fv_nwp_nudge_mod.mod fv_mp_mod.mod -fv_eta.o : fv_eta.F90 fv_mp_mod.mod -fv_fill.o : fv_fill.F90 -fv_grid_tools.o : fv_grid_tools.F90 fv_arrays_mod.mod fv_grid_utils_mod.mod fv_timing_mod.mod fv_mp_mod.mod sorted_index_mod.mod -fv_grid_utils.o : fv_grid_utils.F90 fv_eta_mod.mod fv_arrays_mod.mod fv_timing_mod.mod external_sst_mod.mod fv_mp_mod.mod -fv_io.o : fv_io.F90 fv_mapz_mod.mod fv_eta_mod.mod fv_arrays_mod.mod external_sst_mod.mod fv_mp_mod.mod -fv_mapz.o : fv_mapz.F90 fv_arrays_mod.mod fv_grid_utils_mod.mod fv_timing_mod.mod fv_fill_mod.mod fv_cmp_mod.mod fv_mp_mod.mod -fv_mp_mod.o : fv_mp_mod.F90 fv_arrays_mod.mod -fv_nesting.o : fv_nesting.F90 fv_mapz_mod.mod fv_arrays_mod.mod fv_sg_mod.mod boundary_mod.mod fv_grid_utils_mod.mod fv_diagnostics_mod.mod fv_timing_mod.mod init_hydro_mod.mod fv_mp_mod.mod fv_restart_mod.mod sw_core_mod.mod -fv_nudge.o : fv_nudge.F90 fv_mapz_mod.mod fv_arrays_mod.mod sim_nc_mod.mod fv_grid_utils_mod.mod fv_timing_mod.mod fv_diagnostics_mod.mod external_sst_mod.mod fv_mp_mod.mod tp_core_mod.mod -fv_regional_bc.o : fv_regional_bc.F90 fv_mapz_mod.mod fv_eta_mod.mod fv_arrays_mod.mod fv_grid_utils_mod.mod fv_fill_mod.mod fv_diagnostics_mod.mod fv_mp_mod.mod -fv_restart.o : fv_restart.F90 fv_io_mod.mod fv_eta_mod.mod fv_arrays_mod.mod fv_treat_da_inc_mod.mod external_ic_mod.mod fv_surf_map_mod.mod boundary_mod.mod fv_grid_utils_mod.mod fv_timing_mod.mod fv_diagnostics_mod.mod init_hydro_mod.mod fv_mp_mod.mod test_cases_mod.mod -fv_sg.o : fv_sg.F90 gfdl_cloud_microphys_mod.mod fv_mp_mod.mod -fv_surf_map.o : fv_surf_map.F90 fv_arrays_mod.mod fv_grid_utils_mod.mod fv_timing_mod.mod fv_mp_mod.mod -fv_timing.o : fv_timing.F90 fv_mp_mod.mod -fv_tracer2d.o : fv_tracer2d.F90 fv_arrays_mod.mod fv_regional_mod.mod boundary_mod.mod fv_timing_mod.mod fv_mp_mod.mod tp_core_mod.mod -fv_treat_da_inc.o : fv_treat_da_inc.F90 fv_arrays_mod.mod sim_nc_mod.mod fv_grid_utils_mod.mod fv_mp_mod.mod -fv_update_phys.o : fv_update_phys.F90 fv_mapz_mod.mod fv_eta_mod.mod fv_arrays_mod.mod boundary_mod.mod fv_grid_utils_mod.mod fv_diagnostics_mod.mod fv_timing_mod.mod fv_nwp_nudge_mod.mod fv_mp_mod.mod -gfdl_cloud_microphys.o : gfdl_cloud_microphys.F90 module_mp_radar.mod -init_hydro.o : init_hydro.F90 fv_arrays_mod.mod fv_grid_utils_mod.mod fv_mp_mod.mod -module_mp_radar.o : module_mp_radar.F90 -nh_core.o : nh_core.F90 nh_utils_mod.mod tp_core_mod.mod -nh_utils.o : nh_utils.F90 fv_arrays_mod.mod sw_core_mod.mod tp_core_mod.mod -sim_nc_mod.o : sim_nc_mod.F90 -sorted_index.o : sorted_index.F90 fv_arrays_mod.mod -sw_core.o : sw_core.F90 fv_arrays_mod.mod a2b_edge_mod.mod fv_mp_mod.mod test_cases_mod.mod tp_core_mod.mod -test_cases.o : test_cases.F90 fv_arrays_mod.mod fv_eta_mod.mod fv_sg_mod.mod fv_surf_map_mod.mod fv_grid_utils_mod.mod fv_diagnostics_mod.mod fv_grid_tools_mod.mod init_hydro_mod.mod fv_mp_mod.mod -tp_core.o : tp_core.F90 fv_arrays_mod.mod fv_grid_utils_mod.mod fv_mp_mod.mod - -# The following section relates each module to the corresponding file. - -a2b_edge_mod.mod : a2b_edge.o -boundary_mod.mod : boundary.o -dyn_core_mod.mod : dyn_core.o -external_ic_mod.mod : external_ic.o -external_sst_mod.mod : external_sst.o -fv_arrays_mod.mod : fv_arrays.o -fv_cmp_mod.mod : fv_cmp.o -fv_diagnostics_mod.mod : fv_diagnostics.o -fv_eta_mod.mod : fv_eta.o -fv_fill_mod.mod : fv_fill.o -fv_grid_tools_mod.mod : fv_grid_tools.o -fv_grid_utils_mod.mod : fv_grid_utils.o -fv_io_mod.mod : fv_io.o -fv_mapz_mod.mod : fv_mapz.o -fv_mp_mod.mod : fv_mp_mod.o -fv_nesting_mod.mod : fv_nesting.o -fv_nwp_nudge_mod.mod : fv_nudge.o -fv_regional_mod.mod : fv_regional_bc.o -fv_restart_mod.mod : fv_restart.o -fv_sg_mod.mod : fv_sg.o -fv_surf_map_mod.mod : fv_surf_map.o -fv_timing_mod.mod : fv_timing.o -fv_tracer2d_mod.mod : fv_tracer2d.o -fv_treat_da_inc_mod.mod : fv_treat_da_inc.o -fv_update_phys_mod.mod : fv_update_phys.o -gfdl_cloud_microphys_mod.mod : gfdl_cloud_microphys.o -init_hydro_mod.mod : init_hydro.o -module_mp_radar.mod : module_mp_radar.o -nh_core_mod.mod : nh_core.o -nh_utils_mod.mod : nh_utils.o -sim_nc_mod.mod : sim_nc_mod.o -sorted_index_mod.mod : sorted_index.o -sw_core_mod.mod : sw_core.o -test_cases_mod.mod : test_cases.o -tp_core_mod.mod : tp_core.o - -# -clean_objs: - rm -f $(OBJS) *.mod *.o - -clean: - rm -f libfv3core.a $(OBJS) *.mod *.o diff --git a/src/dynamics/fv3/dimensions_mod.F90 b/src/dynamics/fv3/dimensions_mod.F90 deleted file mode 100644 index a0cfa139b8..0000000000 --- a/src/dynamics/fv3/dimensions_mod.F90 +++ /dev/null @@ -1,35 +0,0 @@ -module dimensions_mod - use shr_kind_mod, only: r8=>shr_kind_r8 - - implicit none - private - - - !These are convenience variables for local use only, and are set to values in Atm% - integer, public :: npx, npy, ntiles - - integer, parameter, public :: nlev=PLEV - integer, parameter, public :: nlevp=nlev+1 - - ! - ! The variables below hold indices of water vapor and condensate loading tracers as well as - ! associated heat capacities (initialized in dyn_init): - ! - ! qsize_condensate_loading_idx = FV3 index of water tracers included in condensate loading according to FV3 dynamics - ! qsize_condensate_loading_idx_gll = CAM index of water tracers included in condensate loading terms given FV3 index - ! - integer, allocatable, public :: qsize_tracer_idx_cam2dyn(:) - character(len=16), allocatable, public :: cnst_name_ffsl(:) ! constituent names for FV3 tracers - character(len=128), allocatable, public :: cnst_longname_ffsl(:) ! long name of FV3 tracers - ! - !moist cp in energy conversion term - ! - ! .false.: force dycore to use cpd (cp dry) instead of moist cp - ! .true. : use moist cp in dycore - ! - logical , public :: fv3_lcp_moist = .false. - logical , public :: fv3_lcv_moist = .false. - logical , public :: fv3_scale_ttend = .false. - -end module dimensions_mod - diff --git a/src/dynamics/fv3/dp_coupling.F90 b/src/dynamics/fv3/dp_coupling.F90 deleted file mode 100644 index 3b7fcca69b..0000000000 --- a/src/dynamics/fv3/dp_coupling.F90 +++ /dev/null @@ -1,1087 +0,0 @@ -module dp_coupling - -!------------------------------------------------------------------------------- -! dynamics - physics coupling module -!------------------------------------------------------------------------------- - -use cam_abortutils, only: endrun -use cam_logfile, only: iulog -use constituents, only: pcnst -use dimensions_mod, only: npx,npy,nlev, & - cnst_name_ffsl, cnst_longname_ffsl,fv3_lcp_moist,fv3_lcv_moist, & - qsize_tracer_idx_cam2dyn,fv3_scale_ttend -use dyn_comp, only: dyn_export_t, dyn_import_t -use dyn_grid, only: get_gcol_block_d,mytile -use fv_grid_utils_mod, only: g_sum -use hycoef, only: hyam, hybm, hyai, hybi, ps0 -use mpp_domains_mod, only: mpp_update_domains, domain2D, DGRID_NE -use perf_mod, only: t_startf, t_stopf, t_barrierf -use physconst, only: cpair, gravit, rair, zvir, cappa -use air_composition, only: rairv -use phys_grid, only: get_ncols_p, get_gcol_all_p, block_to_chunk_send_pters, & - transpose_block_to_chunk, block_to_chunk_recv_pters, & - chunk_to_block_send_pters, transpose_chunk_to_block, & - chunk_to_block_recv_pters -use physics_types, only: physics_state, physics_tend -use ppgrid, only: begchunk, endchunk, pcols, pver, pverp -use shr_kind_mod, only: r8=>shr_kind_r8, i8 => shr_kind_i8 -use spmd_dyn, only: local_dp_map, block_buf_nrecs, chunk_buf_nrecs -use spmd_utils, only: mpicom, iam, npes,masterproc - -implicit none -private -public :: d_p_coupling, p_d_coupling - -!======================================================================= -contains -!======================================================================= - -subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) - - ! Convert the dynamics output state into the physics input state. - ! Note that all pressures and tracer mixing ratios coming from the FV3 dycore are based on - ! wet air mass. - - - use cam_abortutils, only: endrun - use fv_arrays_mod, only: fv_atmos_type - use fv_grid_utils_mod, only: cubed_to_latlon - use physics_buffer, only: physics_buffer_desc - - ! arguments - type (dyn_export_t), intent(inout) :: dyn_out ! dynamics export - type (physics_buffer_desc), pointer :: pbuf2d(:,:) - type (physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type (physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend - - ! LOCAL VARIABLES - - integer :: ib ! indices over elements - integer :: ioff - integer :: lchnk, icol, ilyr ! indices over chunks, columns, layers - integer :: m, m_ffsl, n, i, j, k - - integer :: cpter(pcols, 0:pver) ! offsets into chunk buffer for unpacking data - - integer :: pgcols(pcols), idmb1(1), idmb2(1), idmb3(1) - integer :: tsize ! amount of data per grid point passed to physics - type (fv_atmos_type), pointer :: Atm(:) - - integer :: is,ie,js,je - integer :: ncols - - ! LOCAL Allocatables - integer, allocatable, dimension(:,:) :: bpter !((ie-is+1)*(je-js+1),0:pver) ! packing data block buffer offset - real(r8), allocatable, dimension(:) :: bbuffer, cbuffer ! transpose buffers - real(r8), allocatable, dimension(:,:) :: phis_tmp !((ie-is+1)*(je-js+1), 1) ! temporary array to hold phis - real(r8), allocatable, dimension(:,:) :: ps_tmp !((ie-is+1)*(je-js+1), 1) ! temporary array to hold ps - real(r8), allocatable, dimension(:,:,:) :: T_tmp !((ie-is+1)*(je-js+1),pver,1) ! temporary array to hold T - real(r8), allocatable, dimension(:,:,:) :: omega_tmp!((ie-is+1)*(je-js+1),pver,1) ! temporary array to hold omega - real(r8), allocatable, dimension(:,:,:) :: pdel_tmp !((ie-is+1)*(je-js+1),pver,1) ! temporary array to hold pdel - real(r8), allocatable, dimension(:,:,:) :: u_tmp !((ie-is+1)*(je-js+1),pver,1) ! temp array to hold u - real(r8), allocatable, dimension(:,:,:) :: v_tmp !((ie-is+1)*(je-js+1),pver,1) ! temp array to hold v - real(r8), allocatable, dimension(:,:,:,:) :: q_tmp !((ie-is+1)*(je-js+1),pver,pcnst,1) ! temp to hold advected constituents - - !----------------------------------------------------------------------- - - Atm=>dyn_out%atm - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - ! Allocate temporary arrays to hold data for physics decomposition - allocate(ps_tmp ((ie-is+1)*(je-js+1), 1)) - allocate(phis_tmp ((ie-is+1)*(je-js+1), 1)) - allocate(T_tmp ((ie-is+1)*(je-js+1),pver, 1)) - allocate(u_tmp ((ie-is+1)*(je-js+1),pver, 1)) - allocate(v_tmp ((ie-is+1)*(je-js+1),pver, 1)) - allocate(omega_tmp((ie-is+1)*(je-js+1),pver, 1)) - allocate(pdel_tmp ((ie-is+1)*(je-js+1),pver, 1)) - allocate(Q_tmp ((ie-is+1)*(je-js+1),pver,pcnst, 1)) - - ps_tmp = 0._r8 - phis_tmp = 0._r8 - T_tmp = 0._r8 - u_tmp = 0._r8 - v_tmp = 0._r8 - omega_tmp= 0._r8 - pdel_tmp = 0._r8 - Q_tmp = 0._r8 - - n = 1 - do j = js, je - do i = is, ie - ps_tmp (n, 1) = Atm(mytile)%ps (i, j) - phis_tmp(n, 1) = Atm(mytile)%phis(i, j) - do k = 1, pver - T_tmp (n, k, 1) = Atm(mytile)%pt (i, j, k) - u_tmp (n, k, 1) = Atm(mytile)%ua (i, j, k) - v_tmp (n, k, 1) = Atm(mytile)%va (i, j, k) - omega_tmp(n, k, 1) = Atm(mytile)%omga(i, j, k) - pdel_tmp (n, k, 1) = Atm(mytile)%delp(i, j, k) - ! - ! The fv3 constituent array may be in a different order than the cam array, remap here. - ! - do m = 1, pcnst - m_ffsl=qsize_tracer_idx_cam2dyn(m) - Q_tmp(n, k, m, 1) = Atm(mytile)%q(i, j, k, m_ffsl) - end do - end do - n = n + 1 - end do - end do - - call t_startf('dpcopy') - if (local_dp_map) then - - !$omp parallel do private (lchnk, ncols, pgcols, icol, idmb1, idmb2, idmb3, ib, ioff, ilyr, m) - do lchnk = begchunk, endchunk - ncols = get_ncols_p(lchnk) - call get_gcol_all_p(lchnk, pcols, pgcols) - do icol = 1, ncols - call get_gcol_block_d(pgcols(icol), 1, idmb1, idmb2, idmb3) - ib = idmb3(1) - ioff = idmb2(1) - phys_state(lchnk)%ps(icol) = ps_tmp (ioff,ib) - phys_state(lchnk)%phis(icol) = phis_tmp(ioff,ib) - do ilyr = 1, pver - phys_state(lchnk)%t (icol,ilyr) = T_tmp (ioff,ilyr,ib) - phys_state(lchnk)%u (icol,ilyr) = u_tmp (ioff,ilyr,ib) - phys_state(lchnk)%v (icol,ilyr) = v_tmp (ioff,ilyr,ib) - phys_state(lchnk)%omega(icol,ilyr) = omega_tmp(ioff,ilyr,ib) - phys_state(lchnk)%pdel(icol,ilyr) = pdel_tmp (ioff,ilyr,ib) - do m = 1, pcnst - phys_state(lchnk)%q(icol,ilyr,m) = Q_tmp(ioff,ilyr,m,ib) - end do - end do - end do - - end do - - - else ! .not. local_dp_map - - tsize = 5 + pcnst - ib = 1 - - allocate(bbuffer(tsize*block_buf_nrecs)) - allocate(cbuffer(tsize*chunk_buf_nrecs)) - allocate(bpter((ie-is+1)*(je-js+1),0:pver)) - - if (iam < npes) then - call block_to_chunk_send_pters(iam+1, (ie-is+1)*(je-js+1), pver+1, tsize, bpter) - do icol = 1, (ie-is+1)*(je-js+1) - bbuffer(bpter(icol,0)+2:bpter(icol,0)+tsize-1) = 0.0_r8 - bbuffer(bpter(icol,0)) = ps_tmp (icol,ib) - bbuffer(bpter(icol,0)+1) = phis_tmp(icol,ib) - do ilyr = 1, pver - bbuffer(bpter(icol,ilyr)) = T_tmp(icol,ilyr,ib) - bbuffer(bpter(icol,ilyr)+1) = u_tmp(icol,ilyr,ib) - bbuffer(bpter(icol,ilyr)+2) = v_tmp(icol,ilyr,ib) - bbuffer(bpter(icol,ilyr)+3) = omega_tmp(icol,ilyr,ib) - bbuffer(bpter(icol,ilyr)+4) = pdel_tmp (icol,ilyr,ib) - do m = 1, pcnst - bbuffer(bpter(icol,ilyr)+tsize-pcnst-1+m) = Q_tmp(icol,ilyr,m,ib) - end do - end do - end do - else - bbuffer(:) = 0._r8 - end if - - call t_barrierf ('sync_blk_to_chk', mpicom) - call t_startf ('block_to_chunk') - call transpose_block_to_chunk(tsize, bbuffer, cbuffer) - call t_stopf ('block_to_chunk') - - do lchnk = begchunk,endchunk - ncols = phys_state(lchnk)%ncol - call block_to_chunk_recv_pters(lchnk, pcols, pver+1, tsize, cpter) - do icol = 1, ncols - phys_state(lchnk)%ps (icol) = cbuffer(cpter(icol,0)) - phys_state(lchnk)%phis (icol) = cbuffer(cpter(icol,0)+1) - do ilyr = 1, pver - phys_state(lchnk)%t (icol,ilyr) = cbuffer(cpter(icol,ilyr)) - phys_state(lchnk)%u (icol,ilyr) = cbuffer(cpter(icol,ilyr)+1) - phys_state(lchnk)%v (icol,ilyr) = cbuffer(cpter(icol,ilyr)+2) - phys_state(lchnk)%omega (icol,ilyr) = cbuffer(cpter(icol,ilyr)+3) - phys_state(lchnk)%pdel (icol,ilyr) = cbuffer(cpter(icol,ilyr)+4) - do m = 1, pcnst - phys_state(lchnk)%q (icol,ilyr,m) = cbuffer(cpter(icol,ilyr)+tsize-pcnst-1+m) - end do - end do - end do - end do - - deallocate( bbuffer ) - deallocate( cbuffer ) - deallocate( bpter ) - - end if - - deallocate(ps_tmp ) - deallocate(phis_tmp ) - deallocate(T_tmp ) - deallocate(u_tmp ) - deallocate(v_tmp ) - deallocate(omega_tmp) - deallocate(pdel_tmp ) - deallocate(Q_tmp ) - - call t_stopf('dpcopy') - - ! derive the physics state from the dynamics state converting to proper vapor loading - ! and setting dry mixing ratio variables based on cnst_type - no need to call wet_to_dry - ! since derived_phys_dry takes care of that. - - call t_startf('derived_phys_dry') - call derived_phys_dry(phys_state, phys_tend, pbuf2d) - call t_stopf('derived_phys_dry') - -end subroutine d_p_coupling - -!======================================================================= - -subroutine p_d_coupling(phys_state, phys_tend, dyn_in) - - ! Convert the physics output state into the dynamics input state. - - use cam_history, only: outfld - use constants_mod, only: cp_air, kappa - use dyn_comp, only: calc_tot_energy_dynamics - use fms_mod, only: set_domain - use fv_arrays_mod, only: fv_atmos_type - use fv_grid_utils_mod, only: cubed_to_latlon - use air_composition, only: thermodynamic_active_species_num,thermodynamic_active_species_idx_dycore - use air_composition, only: thermodynamic_active_species_cp,thermodynamic_active_species_cv,dry_air_species_num - use physics_types, only: set_state_pdry - use time_manager, only: get_step_size - - ! arguments - type (physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type (physics_tend), intent(inout), dimension(begchunk:endchunk) :: phys_tend - type (dyn_import_t), intent(inout) :: dyn_in - - ! LOCAL VARIABLES - - integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data - integer :: ib ! indices over elements - integer :: idim - integer :: ioff - integer :: is,isd,ie,ied,js,jsd,je,jed - integer :: lchnk, icol, ilyr ! indices over chunks, columns, layers - integer :: m, n, i, j, k,m_ffsl,nq - integer :: ncols - integer :: pgcols(pcols), idmb1(1), idmb2(1), idmb3(1) - integer :: tsize ! amount of data per grid point passed to physics - integer :: num_wet_species ! total number of wet species (first tracers in FV3 tracer array) - - integer, allocatable, dimension(:,:) :: bpter !((ie-is+1)*(je-js+1),0:pver) ! packing data block buffer offsets - real(r8), allocatable, dimension(:) :: bbuffer, cbuffer ! transpose buffers - - real (r8) :: dt - real (r8) :: fv3_totwatermass, fv3_airmass - real (r8) :: qall,cpfv3 - real (r8) :: tracermass(pcnst) - - type (fv_atmos_type), pointer :: Atm(:) - - real(r8), allocatable, dimension(:,:,:) :: delpdry ! temporary to hold tendencies - real(r8), allocatable, dimension(:,:,:) :: pdel_tmp ! temporary to hold - real(r8), allocatable, dimension(:,:,:) :: pdeldry_tmp ! temporary to hold - real(r8), allocatable, dimension(:,:,:) :: t_dt ! temporary to hold tendencies - real(r8), allocatable, dimension(:,:,:) :: t_dt_tmp ! temporary to hold tendencies - real(r8), allocatable, dimension(:,:,:) :: t_tendadj ! temporary array to temperature tendency adjustment - real(r8), allocatable, dimension(:,:,:) :: u_dt ! temporary to hold tendencies - real(r8), allocatable, dimension(:,:,:) :: u_dt_tmp ! temporary to hold tendencies - real(r8), allocatable, dimension(:,:,:) :: u_tmp ! temporary array to hold u and v - real(r8), allocatable, dimension(:,:,:) :: v_dt ! temporary to hold tendencies - real(r8), allocatable, dimension(:,:,:) :: v_dt_tmp ! temporary to hold tendencies - real(r8), allocatable, dimension(:,:,:) :: v_tmp ! temporary array to hold u and v - real(r8), allocatable, dimension(:,:,:,:) :: q_tmp ! temporary to hold - - !----------------------------------------------------------------------- - - Atm=>dyn_in%atm - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - isd = Atm(mytile)%bd%isd - ied = Atm(mytile)%bd%ied - jsd = Atm(mytile)%bd%jsd - jed = Atm(mytile)%bd%jed - - call set_domain ( Atm(mytile)%domain ) - - allocate(delpdry(isd:ied,jsd:jed,nlev)) - allocate(t_dt_tmp((ie-is+1)*(je-js+1),pver,1)) - allocate(u_dt_tmp((ie-is+1)*(je-js+1),pver,1)) - allocate(v_dt_tmp((ie-is+1)*(je-js+1),pver,1)) - allocate(pdel_tmp((ie-is+1)*(je-js+1),pver,1)) - allocate(pdeldry_tmp((ie-is+1)*(je-js+1),pver,1)) - allocate(U_tmp((ie-is+1)*(je-js+1),pver,1)) - allocate(V_tmp((ie-is+1)*(je-js+1),pver,1)) - allocate(Q_tmp((ie-is+1)*(je-js+1),pver,pcnst,1)) - allocate(u_dt(isd:ied,jsd:jed,nlev)) - allocate(v_dt(isd:ied,jsd:jed,nlev)) - allocate(t_dt(is:ie,js:je,nlev)) - allocate(t_tendadj(is:ie,js:je,nlev)) - - Atm=>dyn_in%atm - - if (local_dp_map) then -!$omp parallel do private (lchnk, ncols, pgcols, icol, idmb1, idmb2, idmb3, ib, ioff, ilyr, m) - do lchnk = begchunk, endchunk - ncols = get_ncols_p(lchnk) - call get_gcol_all_p(lchnk, pcols, pgcols) - call set_state_pdry(phys_state(lchnk)) ! First get dry pressure to use for this timestep - do icol = 1, ncols - call get_gcol_block_d(pgcols(icol), 1, idmb1, idmb2, idmb3) - ib = idmb3(1) - ioff = idmb2(1) - do ilyr = 1, pver - t_dt_tmp(ioff,ilyr,ib) = phys_tend(lchnk)%dtdt(icol,ilyr) - u_tmp(ioff,ilyr,ib) = phys_state(lchnk)%u(icol,ilyr) - v_tmp(ioff,ilyr,ib) = phys_state(lchnk)%v(icol,ilyr) - u_dt_tmp(ioff,ilyr,ib) = phys_tend(lchnk)%dudt(icol,ilyr) - v_dt_tmp(ioff,ilyr,ib) = phys_tend(lchnk)%dvdt(icol,ilyr) - pdel_tmp(ioff,ilyr,ib) = phys_state(lchnk)%pdel(icol,ilyr) - pdeldry_tmp(ioff,ilyr,ib) = phys_state(lchnk)%pdeldry(icol,ilyr) - do m=1, pcnst - Q_tmp(ioff,ilyr,m,ib) = phys_state(lchnk)%q(icol,ilyr,m) - end do - end do - end do - end do - - else - - tsize = 7 + pcnst - ib = 1 - - allocate(bbuffer(tsize*block_buf_nrecs)) - allocate(cbuffer(tsize*chunk_buf_nrecs)) - allocate(bpter((ie-is+1)*(je-js+1),0:pver)) ! offsets into block buffer for packing data - -!$omp parallel do private (lchnk, ncols, cpter, i, icol, ilyr, m) - do lchnk = begchunk, endchunk - - call set_state_pdry(phys_state(lchnk)) ! First get dry pressure to use for this timestep - ncols = get_ncols_p(lchnk) - - call chunk_to_block_send_pters(lchnk, pcols, pver+1, tsize, cpter) - - do i=1,ncols - cbuffer(cpter(i,0):cpter(i,0)+6+pcnst) = 0.0_r8 - end do - - do icol = 1, ncols - - do ilyr = 1, pver - cbuffer(cpter(icol,ilyr)) = phys_tend(lchnk)%dtdt(icol,ilyr) - cbuffer(cpter(icol,ilyr)+1) = phys_state(lchnk)%u(icol,ilyr) - cbuffer(cpter(icol,ilyr)+2) = phys_state(lchnk)%v(icol,ilyr) - cbuffer(cpter(icol,ilyr)+3) = phys_tend(lchnk)%dudt(icol,ilyr) - cbuffer(cpter(icol,ilyr)+4) = phys_tend(lchnk)%dvdt(icol,ilyr) - cbuffer(cpter(icol,ilyr)+5) = phys_state(lchnk)%pdel(icol,ilyr) - cbuffer(cpter(icol,ilyr)+6) = phys_state(lchnk)%pdeldry(icol,ilyr) - do m = 1, pcnst - cbuffer(cpter(icol,ilyr)+6+m) = phys_state(lchnk)%q(icol,ilyr,m) - end do - end do - - end do - - end do - - call t_barrierf('sync_chk_to_blk', mpicom) - call t_startf ('chunk_to_block') - call transpose_chunk_to_block(tsize, cbuffer, bbuffer) - call t_stopf ('chunk_to_block') - - if (iam < npes) then - - call chunk_to_block_recv_pters(iam+1, (ie-is+1)*(je-js+1), pver+1, tsize, bpter) - do icol = 1, (ie-is+1)*(je-js+1) - do ilyr = 1, pver - t_dt_tmp(icol,ilyr,ib) = bbuffer(bpter(icol,ilyr)) - u_tmp(icol,ilyr,ib) = bbuffer(bpter(icol,ilyr)+1) - v_tmp(icol,ilyr,ib) = bbuffer(bpter(icol,ilyr)+2) - u_dt_tmp(icol,ilyr,ib) = bbuffer(bpter(icol,ilyr)+3) - v_dt_tmp(icol,ilyr,ib) = bbuffer(bpter(icol,ilyr)+4) - pdel_tmp(icol,ilyr,ib) = bbuffer(bpter(icol,ilyr)+5) - pdeldry_tmp(icol,ilyr,ib) = bbuffer(bpter(icol,ilyr)+6) - do m = 1, pcnst - Q_tmp(icol,ilyr,m,ib) = bbuffer(bpter(icol,ilyr)+6+m) - end do - end do - end do - - end if - - deallocate(bbuffer) - deallocate(cbuffer) - deallocate(bpter) - - end if - - dt = get_step_size() - - idim=ie-is+1 - -! pt_dt is adjusted below. - n = 1 - do j = js, je - do i = is, ie - do k = 1, pver - t_dt(i, j, k) = t_dt_tmp (n, k, 1) - u_dt(i, j, k) = u_dt_tmp (n, k, 1) - v_dt(i, j, k) = v_dt_tmp (n, k, 1) - Atm(mytile)%ua(i, j, k) = Atm(mytile)%ua(i, j, k) + u_dt(i, j, k)*dt - Atm(mytile)%va(i, j, k) = Atm(mytile)%va(i, j, k) + v_dt(i, j, k)*dt - Atm(mytile)%delp(i, j, k) = pdel_tmp (n, k, 1) - delpdry(i, j, k) = pdeldry_tmp (n, k, 1) - do m = 1, pcnst - ! dynamics tracers may be in a different order from cam tracer array - m_ffsl=qsize_tracer_idx_cam2dyn(m) - Atm(mytile)%q(i, j, k, m_ffsl) = Q_tmp(n, k, m, 1) - end do - end do - n = n + 1 - end do - end do - - ! Update delp and mixing ratios to account for the difference between CAM and FV3 total air mass - ! CAM total air mass (pdel) = (dry + vapor) - ! FV3 total air mass (delp at beg of phys * mix ratio) = - ! drymass + (vapor + condensate [liq_wat,ice_wat,rainwat,snowwat,graupel])*mix ratio - ! FV3 tracer mixing ratios = tracer mass / FV3 total air mass - ! convert the (dry+vap) mixing ratios to be based off of FV3 condensate loaded airmass (dry+vap+cond). When - ! d_p_coupling/derive_phys_dry is called the mixing ratios are again parsed out into wet and - ! dry for physics. - num_wet_species=thermodynamic_active_species_num-dry_air_species_num - ! recalculate ps based on new delp - Atm(mytile)%ps(:,:)=hyai(1)*ps0 - do k=1,pver - do j = js,je - do i = is,ie - do m = 1,pcnst - tracermass(m)=Atm(mytile)%delp(i,j,k)*Atm(mytile)%q(i,j,k,m) - end do - fv3_totwatermass=sum(tracermass(thermodynamic_active_species_idx_dycore(1:num_wet_species))) - fv3_airmass = delpdry(i,j,k) + fv3_totwatermass - Atm(mytile)%delp(i,j,k) = fv3_airmass - Atm(mytile)%q(i,j,k,1:pcnst) = tracermass(1:pcnst)/fv3_airmass - Atm(mytile)%ps(i,j)=Atm(mytile)%ps(i,j)+Atm(mytile)%delp(i, j, k) - end do - end do - end do - - ! update dynamics temperature from physics tendency - ! if using fv3_lcv_moist adjust temperature tendency to conserve energy across phys/dynamics - ! interface accounting for differences in the moist/wet assumptions - - do k = 1, pver - do j = js, je - do i = is, ie - if (fv3_scale_ttend) then - qall=0._r8 - cpfv3=0._r8 - do nq=1,thermodynamic_active_species_num - m_ffsl = thermodynamic_active_species_idx_dycore(nq) - qall=qall+Atm(mytile)%q(i,j,k,m_ffsl) - if (fv3_lcp_moist) cpfv3 = cpfv3+thermodynamic_active_species_cp(nq)*Atm(mytile)%q(i,j,k,m_ffsl) - if (fv3_lcv_moist) cpfv3 = cpfv3+thermodynamic_active_species_cv(nq)*Atm(mytile)%q(i,j,k,m_ffsl) - end do - cpfv3=(1._r8-qall)*cp_air+cpfv3 - ! scale factor for t_dt so temperature tendency derived from CAM moist air (dry+vap - constant pressure) - ! can be applied to FV3 wet air (dry+vap+cond - constant volume) - - t_tendadj(i,j,k)=cp_air/cpfv3 - - if (.not.Atm(mytile)%flagstruct%hydrostatic) then - ! update to nonhydrostatic variable delz to account for phys temperature adjustment. - Atm(mytile)%delz(i, j, k) = Atm(mytile)%delz(i,j,k)/Atm(mytile)%pt(i, j, k) - Atm(mytile)%pt (i, j, k) = Atm(mytile)%pt (i, j, k) + t_dt(i, j, k)*dt*t_tendadj(i,j,k) - Atm(mytile)%delz(i, j, k) = Atm(mytile)%delz(i,j,k)*Atm(mytile)%pt (i, j, k) - else - Atm(mytile)%pt (i, j, k) = Atm(mytile)%pt (i, j, k) + t_dt(i, j, k)*dt*t_tendadj(i,j,k) - end if - else - Atm(mytile)%pt (i, j, k) = Atm(mytile)%pt (i, j, k) + t_dt(i, j, k)*dt - end if - end do - end do - end do - - !$omp parallel do private(i, j) - do j=js,je - do i=is,ie - Atm(mytile)%pe(i,1,j) = Atm(mytile)%ptop - Atm(mytile)%pk(i,j,1) = Atm(mytile)%ptop ** kappa - Atm(mytile)%peln(i,1,j) = log(Atm(mytile)%ptop ) - enddo - enddo - -!$omp parallel do private(i,j,k) - do j=js,je - do k=1,pver - do i=is,ie - Atm(mytile)%pe(i,k+1,j) = Atm(mytile)%pe(i,k,j) + Atm(mytile)%delp(i,j,k) - enddo - enddo - enddo - -!$omp parallel do private(i,j,k) - do j=js,je - do k=1,pver - do i=is,ie - Atm(mytile)%pk(i,j,k+1)= Atm(mytile)%pe(i,k+1,j) ** kappa - Atm(mytile)%peln(i,k+1,j) = log(Atm(mytile)%pe(i,k+1,j)) - Atm(mytile)%pkz(i,j,k) = (Atm(mytile)%pk(i,j,k+1)-Atm(mytile)%pk(i,j,k))/ & - (kappa*(Atm(mytile)%peln(i,k+1,j)-Atm(mytile)%peln(i,k,j))) - enddo - enddo - enddo - - do j = js, je - call outfld('FU', RESHAPE(u_dt(is:ie, j, :),(/idim,pver/)), idim, j) - call outfld('FV', RESHAPE(v_dt(is:ie, j, :),(/idim,pver/)), idim, j) - call outfld('FT', RESHAPE(t_dt(is:ie, j, :),(/idim,pver/)), idim, j) - end do - - call calc_tot_energy_dynamics(dyn_in%atm,'dAP') - - - !set the D-Grid winds from the physics A-grid winds/tendencies. - if ( Atm(mytile)%flagstruct%dwind_2d ) then - call endrun('dwind_2d update is not implemented') - else - call atend2dstate3d( u_dt, v_dt, Atm(mytile)%u ,Atm(mytile)%v, is, ie, js, je, & - isd, ied, jsd, jed, npx,npy, nlev, Atm(mytile)%gridstruct, Atm(mytile)%domain, dt) - endif - - ! Again we are rederiving the A winds from the Dwinds to give our energy dynamics a consistent wind. - call cubed_to_latlon(Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%gridstruct, & - npx, npy, nlev, 1, Atm(mytile)%gridstruct%grid_type, Atm(mytile)%domain, & - Atm(mytile)%gridstruct%nested, Atm(mytile)%flagstruct%c2l_ord, Atm(mytile)%bd) - - !$omp parallel do private(i, j) - do j=js,je - do i=is,ie - Atm(mytile)%u_srf=Atm(mytile)%ua(i,j,pver) - Atm(mytile)%v_srf=Atm(mytile)%va(i,j,pver) - enddo - enddo - - ! update halo regions - call mpp_update_domains( Atm(mytile)%delp, Atm(mytile)%domain ) - call mpp_update_domains( Atm(mytile)%ps, Atm(mytile)%domain ) - call mpp_update_domains( Atm(mytile)%phis, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%ps, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%u,atm(mytile)%v, Atm(mytile)%domain, gridtype=DGRID_NE, complete=.true. ) - call mpp_update_domains( atm(mytile)%pt, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%q, Atm(mytile)%domain ) - - deallocate(delpdry) - deallocate(t_dt_tmp) - deallocate(u_dt_tmp) - deallocate(v_dt_tmp) - deallocate(pdel_tmp) - deallocate(pdeldry_tmp) - deallocate(U_tmp) - deallocate(V_tmp) - deallocate(Q_tmp) - deallocate(u_dt) - deallocate(v_dt) - deallocate(t_dt) - deallocate(t_tendadj) - -end subroutine p_d_coupling - -!======================================================================= - -subroutine derived_phys_dry(phys_state, phys_tend, pbuf2d) - - use check_energy, only: check_energy_timestep_init - use constituents, only: qmin - use geopotential, only: geopotential_t - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk - use physics_types, only: set_wet_to_dry - use air_composition, only: thermodynamic_active_species_num,thermodynamic_active_species_idx_dycore - use air_composition, only: thermodynamic_active_species_idx,dry_air_species_num - use ppgrid, only: pver - use qneg_module, only: qneg3 - use shr_vmath_mod, only: shr_vmath_log - - ! arguments - type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local variables - - integer :: num_wet_species ! total number of wet species (first tracers in FV3 tracer array) - integer :: lchnk - integer :: m, i, k, ncol - - real(r8) :: cam_totwatermass, cam_airmass - real(r8), dimension(pcnst) :: tracermass - real(r8), dimension(pcols,pver) :: zvirv ! Local zvir array pointer - - !---------------------------------------------------------------------------- - - type(physics_buffer_desc), pointer :: pbuf_chnk(:) - - ! - ! Evaluate derived quantities - ! - ! At this point the phys_state has been filled in from dynamics, rearranging tracers to match CAM tracer order. - ! pdel is consistent with tracer array. - ! All tracer mixing rations at this point are calculated using dry+vap+condensates - we need to convert - ! to cam physics wet mixing ration based off of dry+vap. - ! Following this loop call wet_to_dry to convert CAM's dry constituents to their dry mixing ratio. - -!!! omp parallel do private (lchnk, ncol, k, i, zvirv, pbuf_chnk,m,cam_airmass,cam_totwatermass) - num_wet_species=thermodynamic_active_species_num-dry_air_species_num - do lchnk = begchunk,endchunk - ncol = get_ncols_p(lchnk) - do k=1,pver - do i=1,ncol - phys_state(lchnk)%pdeldry(i,k) = & - phys_state(lchnk)%pdel(i,k) * & - (1._r8-sum(phys_state(lchnk)%q(i,k,thermodynamic_active_species_idx(1:num_wet_species)))) - do m = 1,pcnst - tracermass(m)=phys_state(lchnk)%pdel(i,k)*phys_state(lchnk)%q(i,k,m) - end do - cam_totwatermass=tracermass(1) - cam_airmass = phys_state(lchnk)%pdeldry(i,k) + cam_totwatermass - phys_state(lchnk)%pdel(i,k) = cam_airmass - phys_state(lchnk)%q(i,k,1:pcnst) = tracermass(1:pcnst)/cam_airmass - end do - end do - -! Physics state now has CAM pdel (dry+vap) and pdeldry and all constituents are dry+vap -! Convert dry type constituents from moist to dry mixing ratio -! - call set_wet_to_dry(phys_state(lchnk)) ! Dynamics had moist, physics wants dry. - -! -! Derive the rest of the pressure variables using pdel and pdeldry -! - - do i = 1, ncol - phys_state(lchnk)%psdry(i) = hyai(1)*ps0 + sum(phys_state(lchnk)%pdeldry(i,:)) - end do - - do i = 1, ncol - phys_state(lchnk)%pintdry(i,1) = hyai(1)*ps0 - end do - call shr_vmath_log(phys_state(lchnk)%pintdry(1:ncol,1), & - phys_state(lchnk)%lnpintdry(1:ncol,1),ncol) - do k = 1, pver - do i = 1, ncol - phys_state(lchnk)%pintdry(i,k+1) = phys_state(lchnk)%pintdry(i,k) + & - phys_state(lchnk)%pdeldry(i,k) - end do - call shr_vmath_log(phys_state(lchnk)%pintdry(1:ncol,k+1),& - phys_state(lchnk)%lnpintdry(1:ncol,k+1),ncol) - end do - - do k=1,pver - do i=1,ncol - phys_state(lchnk)%rpdeldry(i,k) = 1._r8/phys_state(lchnk)%pdeldry(i,k) - phys_state(lchnk)%pmiddry (i,k) = 0.5_r8*(phys_state(lchnk)%pintdry(i,k+1) + & - phys_state(lchnk)%pintdry(i,k)) - end do - call shr_vmath_log(phys_state(lchnk)%pmiddry(1:ncol,k), & - phys_state(lchnk)%lnpmiddry(1:ncol,k),ncol) - end do - - ! initialize moist pressure variables - - do i=1,ncol - phys_state(lchnk)%ps(i) = phys_state(lchnk)%pintdry(i,1) - phys_state(lchnk)%pint(i,1) = phys_state(lchnk)%pintdry(i,1) - end do - do k = 1, pver - do i=1,ncol - phys_state(lchnk)%pint(i,k+1) = phys_state(lchnk)%pint(i,k)+phys_state(lchnk)%pdel(i,k) - phys_state(lchnk)%pmid(i,k) = (phys_state(lchnk)%pint(i,k+1)+phys_state(lchnk)%pint(i,k))/2._r8 - phys_state(lchnk)%ps (i) = phys_state(lchnk)%ps(i) + phys_state(lchnk)%pdel(i,k) - end do - call shr_vmath_log(phys_state(lchnk)%pint(1:ncol,k),phys_state(lchnk)%lnpint(1:ncol,k),ncol) - call shr_vmath_log(phys_state(lchnk)%pmid(1:ncol,k),phys_state(lchnk)%lnpmid(1:ncol,k),ncol) - end do - call shr_vmath_log(phys_state(lchnk)%pint(1:ncol,pverp),phys_state(lchnk)%lnpint(1:ncol,pverp),ncol) - - do k = 1, pver - do i = 1, ncol - phys_state(lchnk)%rpdel(i,k) = 1._r8/phys_state(lchnk)%pdel(i,k) - phys_state(lchnk)%exner (i,k) = (phys_state(lchnk)%pint(i,pver+1) & - / phys_state(lchnk)%pmid(i,k))**cappa - end do - end do - - ! fill zvirv 2D variables to be compatible with geopotential_t interface - zvirv(:,:) = zvir - - ! Compute initial geopotential heights - based on full pressure - call geopotential_t (phys_state(lchnk)%lnpint, phys_state(lchnk)%lnpmid , phys_state(lchnk)%pint , & - phys_state(lchnk)%pmid , phys_state(lchnk)%pdel , phys_state(lchnk)%rpdel , & - phys_state(lchnk)%t , phys_state(lchnk)%q(:,:,:), rairv(:,:,lchnk), gravit, zvirv , & - phys_state(lchnk)%zi , phys_state(lchnk)%zm , ncol ) - - ! Compute initial dry static energy, include surface geopotential - do k = 1, pver - do i = 1, ncol - phys_state(lchnk)%s(i,k) = cpair*phys_state(lchnk)%t(i,k) & - + gravit*phys_state(lchnk)%zm(i,k) + phys_state(lchnk)%phis(i) - end do - end do - ! Ensure tracers are all positive - call qneg3('D_P_COUPLING',lchnk ,ncol ,pcols ,pver , & - 1, pcnst, qmin ,phys_state(lchnk)%q) - - ! Compute energy and water integrals of input state - pbuf_chnk => pbuf_get_chunk(pbuf2d, lchnk) - call check_energy_timestep_init(phys_state(lchnk), phys_tend(lchnk), pbuf_chnk) - - end do ! lchnk - -end subroutine derived_phys_dry - -subroutine atend2dstate3d(u_dt, v_dt, u, v, is, ie, js, je, isd, ied, jsd, jed, npx,npy, nlev, gridstruct, domain, dt) -!---------------------------------------------------------------------------- -! This routine adds the a-grid wind tendencies returned by the physics to the d-state -! wind being sent to the dynamics. -!---------------------------------------------------------------------------- - - use fv_arrays_mod, only: fv_grid_type - use mpp_domains_mod, only: mpp_update_domains, DGRID_NE - - ! arguments - integer, intent(in) :: npx,npy, nlev - integer, intent(in) :: is, ie, js, je,& - isd, ied, jsd, jed - real(r8), intent(in) :: dt - real(r8), intent(inout), dimension(isd:ied,jsd:jed,nlev) :: u_dt, v_dt - real(r8), intent(inout), dimension(isd:ied, jsd:jed+1,nlev) :: u - real(r8), intent(inout), dimension(isd:ied+1,jsd:jed ,nlev) :: v - type(domain2d), intent(inout) :: domain - type(fv_grid_type), intent(in), target :: gridstruct - - ! local: - - integer i, j, k, im2, jm2 - real(r8) dt5 - real(r8), dimension(is-1:ie+1,js:je+1,3) :: ue ! 3D winds at edges - real(r8), dimension(is-1:ie+1,js-1:je+1,3) :: v3 - real(r8), dimension(is:ie+1,js-1:je+1, 3) :: ve ! 3D winds at edges - real(r8), dimension(is:ie) :: ut1, ut2, ut3 - real(r8), dimension(js:je) :: vt1, vt2, vt3 - real(r8), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n - real(r8), pointer, dimension(:,:,:) :: vlon, vlat - real(r8), pointer, dimension(:,:,:,:) :: es, ew - - !---------------------------------------------------------------------------- - - es => gridstruct%es - ew => gridstruct%ew - vlon => gridstruct%vlon - vlat => gridstruct%vlat - - edge_vect_w => gridstruct%edge_vect_w - edge_vect_e => gridstruct%edge_vect_e - edge_vect_s => gridstruct%edge_vect_s - edge_vect_n => gridstruct%edge_vect_n - - call mpp_update_domains(u_dt, domain, complete=.false.) - call mpp_update_domains(v_dt, domain, complete=.true.) - - dt5 = 0.5_r8 * dt - im2 = (npx-1)/2 - jm2 = (npy-1)/2 - -!$OMP parallel do default(none) shared(is,ie,js,je,nlev,gridstruct,u,dt5,u_dt,v,v_dt, & -!$OMP vlon,vlat,jm2,edge_vect_w,npx,edge_vect_e,im2, & -!$OMP edge_vect_s,npy,edge_vect_n,es,ew) & -!$OMP private(ut1, ut2, ut3, vt1, vt2, vt3, ue, ve, v3) - do k=1, nlev - - ! Compute 3D wind/tendency on A grid - do j=js-1,je+1 - do i=is-1,ie+1 - v3(i,j,1) = u_dt(i,j,k)*vlon(i,j,1) + v_dt(i,j,k)*vlat(i,j,1) - v3(i,j,2) = u_dt(i,j,k)*vlon(i,j,2) + v_dt(i,j,k)*vlat(i,j,2) - v3(i,j,3) = u_dt(i,j,k)*vlon(i,j,3) + v_dt(i,j,k)*vlat(i,j,3) - enddo - enddo - - ! Interpolate to cell edges - do j=js,je+1 - do i=is-1,ie+1 - ue(i,j,1) = v3(i,j-1,1) + v3(i,j,1) - ue(i,j,2) = v3(i,j-1,2) + v3(i,j,2) - ue(i,j,3) = v3(i,j-1,3) + v3(i,j,3) - enddo - enddo - - do j=js-1,je+1 - do i=is,ie+1 - ve(i,j,1) = v3(i-1,j,1) + v3(i,j,1) - ve(i,j,2) = v3(i-1,j,2) + v3(i,j,2) - ve(i,j,3) = v3(i-1,j,3) + v3(i,j,3) - enddo - enddo - - ! --- E_W edges (for v-wind): - if (.not. gridstruct%nested) then - if ( is==1) then - i = 1 - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_w(j)*ve(i,j-1,1)+(1._r8-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j-1,2)+(1._r8-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j-1,3)+(1._r8-edge_vect_w(j))*ve(i,j,3) - else - vt1(j) = edge_vect_w(j)*ve(i,j+1,1)+(1._r8-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j+1,2)+(1._r8-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j+1,3)+(1._r8-edge_vect_w(j))*ve(i,j,3) - endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif - - if ( (ie+1)==npx ) then - i = npx - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_e(j)*ve(i,j-1,1)+(1._r8-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j-1,2)+(1._r8-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j-1,3)+(1._r8-edge_vect_e(j))*ve(i,j,3) - else - vt1(j) = edge_vect_e(j)*ve(i,j+1,1)+(1._r8-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j+1,2)+(1._r8-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j+1,3)+(1._r8-edge_vect_e(j))*ve(i,j,3) - endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif - ! N-S edges (for u-wind): - if ( js==1) then - j = 1 - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_s(i)*ue(i-1,j,1)+(1._r8-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i-1,j,2)+(1._r8-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i-1,j,3)+(1._r8-edge_vect_s(i))*ue(i,j,3) - else - ut1(i) = edge_vect_s(i)*ue(i+1,j,1)+(1._r8-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i+1,j,2)+(1._r8-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i+1,j,3)+(1._r8-edge_vect_s(i))*ue(i,j,3) - endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - if ( (je+1)==npy ) then - j = npy - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_n(i)*ue(i-1,j,1)+(1._r8-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i-1,j,2)+(1._r8-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i-1,j,3)+(1._r8-edge_vect_n(i))*ue(i,j,3) - else - ut1(i) = edge_vect_n(i)*ue(i+1,j,1)+(1._r8-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i+1,j,2)+(1._r8-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i+1,j,3)+(1._r8-edge_vect_n(i))*ue(i,j,3) - endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - - endif ! .not. nested - - do j=js,je+1 - do i=is,ie - u(i,j,k) = u(i,j,k) + dt5*( ue(i,j,1)*es(1,i,j,1) + & - ue(i,j,2)*es(2,i,j,1) + & - ue(i,j,3)*es(3,i,j,1) ) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j,k) = v(i,j,k) + dt5*( ve(i,j,1)*ew(1,i,j,2) + & - ve(i,j,2)*ew(2,i,j,2) + & - ve(i,j,3)*ew(3,i,j,2) ) - enddo - enddo - enddo ! k-loop - - call mpp_update_domains(u, v, domain, gridtype=DGRID_NE) - -end subroutine atend2dstate3d - - -subroutine fv3_tracer_diags(atm) - - ! Dry/Wet surface pressure diagnostics - - use constituents, only: pcnst - use dimensions_mod, only: nlev,cnst_name_ffsl - use dyn_grid, only: mytile - use fv_arrays_mod, only: fv_atmos_type - use air_composition, only: thermodynamic_active_species_num,thermodynamic_active_species_idx_dycore, & - dry_air_species_num - - ! arguments - type (fv_atmos_type), intent(in), pointer :: Atm(:) - - ! Locals - integer :: i, j ,k, m,is,ie,js,je - integer :: num_wet_species ! total number of wet species - integer :: kstrat,ng - real(r8) :: global_ps,global_dryps - real(r8) :: qm_strat - real(r8) :: qtot(pcnst), psum - real(r8), allocatable, dimension(:,:,:) :: delpdry, psq - real(r8), allocatable, dimension(:,:) :: psdry, q_strat - - !---------------------------------------------------------------------------- - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - ng = Atm(mytile)%ng - - allocate(delpdry(is:ie,js:je,nlev)) - allocate(psdry(is:ie,js:je)) - allocate(psq(is:ie,js:je,pcnst)) - allocate(q_strat(is:ie,js:je)) - num_wet_species=thermodynamic_active_species_num-dry_air_species_num - do k=1,nlev - do j = js, je - do i = is, ie - delpdry(i,j,k) = Atm(mytile)%delp(i,j,k) * & - (1.0_r8-sum(Atm(mytile)%q(i,j,k,thermodynamic_active_species_idx_dycore(1:num_wet_species)))) - end do - end do - end do - ! - ! get psdry - ! - do j = js, je - do i = is, ie - psdry(i,j) = hyai(1)*ps0 + sum(delpdry(i,j,:)) - end do - end do - - global_ps = g_sum(Atm(mytile)%domain, Atm(mytile)%ps(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1) - global_dryps = g_sum(Atm(mytile)%domain, psdry(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1) -!------------------- -! Vertical mass sum for all tracers -!------------------- - psq(:,:,:) = 0._r8 - do m=1,pcnst - call z_sum(Atm,is,ie,js,je,nlev,Atm(mytile)%q(is:ie,js:je,1:nlev,m),psq(is:ie,js:je,m)) - end do -! Mean water vapor in the "stratosphere" (75 mb and above): - qm_strat = 0._r8 - if ( Atm(mytile)%idiag%phalf(2)< 75._r8 ) then - kstrat = 1 - do k=2,nlev - if ( Atm(mytile)%idiag%phalf(k+1) > 75._r8 ) exit - kstrat = k - enddo - call z_sum(Atm,is,ie,js,je, kstrat, Atm(mytile)%q(is:ie,js:je,1:kstrat,1 ), q_strat,psum) - qm_strat = g_sum(Atm(mytile)%domain, q_strat(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1) * 1.e6_r8 / psum - endif - - !------------------- - ! Get global mean mass for all tracers - !------------------- - do m=1,pcnst - qtot(m) = g_sum(Atm(mytile)%domain, psq(is,js,m), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1)/gravit - enddo - - if (masterproc) then - write(iulog,*)'Total Surface Pressure (mb) = ',global_ps/100.0_r8,"hPa" - write(iulog,*)'Mean Dry Surface Pressure (mb) = ',global_dryps/100.0_r8,"hPa" - write(iulog,*)'Mean specific humidity (mg/kg) above 75 mb = ',qm_strat - do m=1,pcnst - write(iulog,*)' Total '//cnst_name_ffsl(m)//' (kg/m**2) = ',qtot(m) - enddo - end if - - - deallocate(delpdry) - deallocate(psdry) - deallocate(psq) - deallocate(q_strat) -end subroutine fv3_tracer_diags - - -subroutine z_sum(atm,is,ie,js,je,km,q,msum,gpsum) - - ! vertical integral - - use fv_arrays_mod, only: fv_atmos_type - - ! arguments - - type (fv_atmos_type), intent(in), pointer :: Atm(:) - integer, intent(in) :: is, ie, js, je - integer, intent(in) :: km - real(r8), intent(in), dimension(is:ie, js:je, km) :: q - real(r8), intent(out), dimension(is:ie,js:je) :: msum - real(r8), intent(out), optional :: gpsum - - ! LOCAL VARIABLES - integer :: i,j,k - real(r8), dimension(is:ie,js:je) :: psum - !---------------------------------------------------------------------------- - msum=0._r8 - psum=0._r8 - do j=js,je - do i=is,ie - msum(i,j) = Atm(mytile)%delp(i,j,1)*q(i,j,1) - psum(i,j) = Atm(mytile)%delp(i,j,1) - enddo - do k=2,km - do i=is,ie - msum(i,j) = msum(i,j) + Atm(mytile)%delp(i,j,k)*q(i,j,k) - psum(i,j) = psum(i,j) + Atm(mytile)%delp(i,j,k) - enddo - enddo - enddo - if (present(gpsum)) then - gpsum = g_sum(Atm(mytile)%domain, psum, is, ie, js, je, Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1) - end if -end subroutine z_sum - -end module dp_coupling diff --git a/src/dynamics/fv3/dycore.F90 b/src/dynamics/fv3/dycore.F90 deleted file mode 100644 index eee3177587..0000000000 --- a/src/dynamics/fv3/dycore.F90 +++ /dev/null @@ -1,24 +0,0 @@ -module dycore - - implicit none - private - - public :: dycore_is - -!======================================================================= -contains -!======================================================================= - -logical function dycore_is(name) - - character(len=*) :: name - - dycore_is = .false. - if (name == 'unstructured' .or. name == 'UNSTRUCTURED' .or. name == 'fv3' .or. name == 'FV3') then - dycore_is = .true. - end if - - return -end function dycore_is - -end module dycore diff --git a/src/dynamics/fv3/dycore_budget.F90 b/src/dynamics/fv3/dycore_budget.F90 deleted file mode 100644 index 0645edb251..0000000000 --- a/src/dynamics/fv3/dycore_budget.F90 +++ /dev/null @@ -1,27 +0,0 @@ -module dycore_budget - -implicit none - -public :: print_budget - -!========================================================================================= -contains -!========================================================================================= - -subroutine print_budget(hstwr) - - use spmd_utils, only: masterproc - use cam_abortutils, only: endrun - use cam_budget, only: thermo_budget_histfile_num, thermo_budget_history - - ! arguments - logical, intent(in) :: hstwr(:) - character(len=*), parameter :: subname = 'dycore_budget:print_budgets:' - - !-------------------------------------------------------------------------------------- - - if (masterproc .and. thermo_budget_history .and. hstwr(thermo_budget_histfile_num)) then - call endrun(subname//' is not implemented for the FV3 dycore') - end if -end subroutine print_budget -end module dycore_budget diff --git a/src/dynamics/fv3/dyn_comp.F90 b/src/dynamics/fv3/dyn_comp.F90 deleted file mode 100644 index 941b2742b1..0000000000 --- a/src/dynamics/fv3/dyn_comp.F90 +++ /dev/null @@ -1,2227 +0,0 @@ -module dyn_comp -! CAM interfaces to the GFDL FV3 Dynamical Core - -!----------------------------------------------------------------------- -! Five prognostic state variables for the fv3 dynamics -!----------------------------------------------------------------------- -! dyn_state: -! D-grid prognostatic variables: u, v, and delp (and other scalars) -! -! o--------u(i,j+1)----------o -! | | | -! | | | -! v(i,j)------scalar(i,j)----v(i+1,j) -! | | | -! | | | -! o--------u(i,j)------------o -! -! The C grid component is "diagnostic" in that it is predicted every time step -! from the D grid variables. -!---------------------------------------------------------------------- -! hydrostatic state: -!---------------------------------------------------------------------- -! u ! D grid zonal wind (m/s) -! v ! D grid meridional wind (m/s) -! p ! temperature (K) -! delp ! pressure thickness (pascal) -! q ! specific humidity and prognostic constituents -! qdiag ! diagnostic tracers -!---------------------------------------------------------------------- -! additional non-hydrostatic state: -!---------------------------------------------------------------------- -! w ! cell center vertical wind (m/s) -! delz ! layer thickness (meters) -! ze0 ! height at layer edges for remapping -! q_con ! total condensates -! -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - - - - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use constants_mod, only: cp_air, kappa, rvgas, rdgas - use constituents, only: pcnst, cnst_name, cnst_longname, tottnam - use dimensions_mod, only: npx, npy, nlev, & - cnst_name_ffsl,cnst_longname_ffsl, & - fv3_lcp_moist,fv3_lcv_moist,qsize_tracer_idx_cam2dyn,fv3_scale_ttend - use dyn_grid, only: mytile, ini_grid_name - use field_manager_mod, only: MODEL_ATMOS - use fms_io_mod, only: set_domain, nullify_domain - use fv_arrays_mod, only: fv_atmos_type, fv_grid_bounds_type - use fv_grid_utils_mod,only: cubed_to_latlon, g_sum - use fv_nesting_mod, only: twoway_nesting - use infnan, only: isnan - use mpp_domains_mod, only: mpp_update_domains, domain2D, DGRID_NE - use mpp_mod, only: mpp_set_current_pelist,mpp_pe - use physconst, only: gravit, cpair, rearth, omega, pi - use ppgrid, only: pver - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4, i8 => shr_kind_i8 - use spmd_utils, only: masterproc, masterprocid, mpicom, npes,iam - use spmd_utils, only: mpi_integer, mpi_logical - use tracer_manager_mod, only: get_tracer_index - - implicit none - private - save - - public :: & - dyn_init, & - dyn_run, & - dyn_final, & - dyn_readnl, & - dyn_register, & - dyn_import_t, & - dyn_export_t - - public calc_tot_energy_dynamics - -type dyn_import_t - type (fv_atmos_type), pointer :: Atm(:) => null() - integer, pointer :: mygindex(:,:) => null() - integer, pointer :: mylindex(:,:) => null() -end type dyn_import_t - -type dyn_export_t - type (fv_atmos_type), pointer :: Atm(:) => null() -end type dyn_export_t - -! Private interfaces -interface read_dyn_var - module procedure read_dyn_field_2d - module procedure read_dyn_field_3d -end interface read_dyn_var - -real(r8), public, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt - -!These are convenience variables for local use only, and are set to values in Atm% -real(r8) :: zvir, dt_atmos_real - -integer :: ldof_size - -real(r8), allocatable,dimension(:,:,:) :: se_dyn,ke_dyn,wv_dyn,wl_dyn,wi_dyn, & - wr_dyn,ws_dyn,wg_dyn,tt_dyn,mo_dyn,mr_dyn - -real(r8), parameter :: rad2deg = 180.0_r8 / pi -real(r8), parameter :: deg2rad = pi / 180.0_r8 - -!======================================================================= -contains -!======================================================================= -subroutine dyn_readnl(nlfilename) - - ! Read dynamics namelist group from atm_in and write to fv3 input.nml file - use namelist_utils, only: find_group_name - use constituents, only: pcnst - - ! args - character(len=*), intent(in) :: nlfilename - - ! Local variables - integer :: unitn,unito, ierr,i,ios - - ! FV3 Namelist variables - integer :: fv3_npes - - ! fv_core namelist variables - these namelist variables defined in fv3 library without fv3_ - - integer :: fv3_consv_te, fv3_dnats, fv3_fv_sg_adj, fv3_grid_type, & - fv3_hord_dp, fv3_hord_mt, fv3_hord_tm, fv3_hord_tr, fv3_hord_vt, & - fv3_io_layout(2), fv3_k_split, fv3_kord_mt, fv3_kord_tm, fv3_kord_tr, & - fv3_kord_wz, fv3_layout(2), fv3_n_split, fv3_n_sponge, fv3_na_init, & - fv3_ncnst, fv3_nord, fv3_npx, fv3_npy, fv3_npz, fv3_ntiles, & - fv3_nwat, fv3_print_freq - - real(r8) :: fv3_beta, fv3_d2_bg, fv3_d2_bg_k1, fv3_d2_bg_k2, fv3_d4_bg, & - fv3_d_con, fv3_d_ext, fv3_dddmp, fv3_delt_max, fv3_ke_bg, & - fv3_rf_cutoff, fv3_tau, fv3_vtdm4 - - logical :: fv3_adjust_dry_mass, fv3_consv_am, fv3_do_sat_adj, fv3_do_vort_damp, & - fv3_dwind_2d, fv3_fill, fv3_fv_debug, fv3_fv_diag, fv3_hydrostatic, & - fv3_make_nh, fv3_no_dycore, fv3_range_warn - - ! fms_nml namelist variables - these namelist variables defined in fv3 library without fv3_ - - character(len=256) :: fv3_clock_grain - integer :: fv3_domains_stack_size - integer :: fv3_stack_size - logical :: fv3_print_memory_usage - - character(len=256) :: inrec ! first 80 characters of input record - character(len=256) :: inrec2 ! left adjusted input record - - character(len = 20), dimension(5) :: group_names = (/ & - "main_nml ", & - "fv_core_nml ", & - "surf_map_nml ", & - "test_case_nml ", & - "fms_nml "/) - - namelist /fms_nml/ & - fv3_clock_grain, & - fv3_domains_stack_size, & - fv3_print_memory_usage, & - fv3_stack_size - - namelist /dyn_fv3_inparm/ & - fv3_scale_ttend, & - fv3_lcp_moist, & - fv3_lcv_moist, & - fv3_npes - - namelist /fv_core_nml/ & - fv3_adjust_dry_mass,fv3_beta,fv3_consv_am,fv3_consv_te,fv3_d2_bg, & - fv3_d2_bg_k1,fv3_d2_bg_k2,fv3_d4_bg,fv3_d_con,fv3_d_ext,fv3_dddmp, & - fv3_delt_max,fv3_dnats,fv3_do_sat_adj,fv3_do_vort_damp,fv3_dwind_2d, & - fv3_fill,fv3_fv_debug,fv3_fv_diag,fv3_fv_sg_adj,fv3_grid_type, & - fv3_hord_dp,fv3_hord_mt,fv3_hord_tm,fv3_hord_tr,fv3_hord_vt, & - fv3_hydrostatic,fv3_io_layout,fv3_k_split,fv3_ke_bg,fv3_kord_mt, & - fv3_kord_tm,fv3_kord_tr,fv3_kord_wz,fv3_layout,fv3_make_nh, & - fv3_n_split,fv3_n_sponge,fv3_na_init,fv3_ncnst,fv3_no_dycore, & - fv3_nord,fv3_npx,fv3_npy,fv3_npz,fv3_ntiles,fv3_nwat, & - fv3_print_freq,fv3_range_warn,fv3_rf_cutoff,fv3_tau, & - fv3_vtdm4 - !-------------------------------------------------------------------------- - - ! defaults for namelist variables not set by build-namelist - fv3_npes = npes - - if (masterproc) then - ! Read the namelist (dyn_fv3_inparm) - open( newunit=unitn, file=trim(NLFileName), status='old' ) - call find_group_name(unitn, 'dyn_fv3_inparm', status=ierr) - if (ierr == 0) then - read(unitn, dyn_fv3_inparm, iostat=ierr) - if (ierr /= 0) then - call endrun('dyn_readnl: ERROR reading dyn_fv3_inparm namelist') - end if - end if - close(unitn) - ! Read the namelist (fms_nml) - open( newunit=unitn, file=trim(NLFileName), status='old' ) - call find_group_name(unitn, 'fms_nml', status=ierr) - if (ierr == 0) then - read(unitn, fms_nml, iostat=ierr) - if (ierr /= 0) then - call endrun('dyn_readnl: ERROR reading fms_nml namelist') - end if - end if - close(unitn) - ! Read the namelist (fv_core_nml) - open( newunit=unitn, file=trim(NLFileName), status='old' ) - call find_group_name(unitn, 'fv_core_nml', status=ierr) - if (ierr == 0) then - read(unitn, fv_core_nml, iostat=ierr) - if (ierr /= 0) then - call endrun('dyn_readnl: ERROR reading fv_core_nml namelist') - end if - end if - close(unitn) - end if - - ! Broadcast namelist values to all PEs - call MPI_bcast(fv3_npes, 1, mpi_integer, masterprocid, mpicom, ierr) - call MPI_bcast(fv3_scale_ttend, 1, mpi_logical, masterprocid, mpicom, ierr) - call MPI_bcast(fv3_lcv_moist, 1, mpi_logical, masterprocid, mpicom, ierr) - call MPI_bcast(fv3_lcp_moist, 1, mpi_logical, masterprocid, mpicom, ierr) - - if ((fv3_lcp_moist.eqv.fv3_lcv_moist) .and. (fv3_lcv_moist.eqv..true.)) then - call endrun('dyn_readnl: fv3_lcp_moist and fv3_lcv_moist can not both be true') - endif - - if (fv3_npes <= 0) then - call endrun('dyn_readnl: ERROR: fv3_npes must be > 0') - end if - - ! - ! write fv3 dycore namelist options to log - ! - if (masterproc) then - write (iulog,*) 'FV3 dycore Options: ' - write (iulog,*) ' fv3_adjust_dry_mass = ',fv3_adjust_dry_mass - write (iulog,*) ' fv3_beta = ',fv3_beta - write (iulog,*) ' fv3_clock_grain = ',trim(fv3_clock_grain) - write (iulog,*) ' fv3_consv_am = ',fv3_consv_am - write (iulog,*) ' fv3_consv_te = ',fv3_consv_te - write (iulog,*) ' fv3_d2_bg = ',fv3_d2_bg - write (iulog,*) ' fv3_d2_bg_k1 = ',fv3_d2_bg_k1 - write (iulog,*) ' fv3_d2_bg_k2 = ',fv3_d2_bg_k2 - write (iulog,*) ' fv3_d4_bg = ',fv3_d4_bg - write (iulog,*) ' fv3_d_con = ',fv3_d_con - write (iulog,*) ' fv3_d_ext = ',fv3_d_ext - write (iulog,*) ' fv3_dddmp = ',fv3_dddmp - write (iulog,*) ' fv3_delt_max = ',fv3_delt_max - write (iulog,*) ' fv3_dnats = ',fv3_dnats - write (iulog,*) ' fv3_do_sat_adj = ',fv3_do_sat_adj - write (iulog,*) ' fv3_do_vort_damp = ',fv3_do_vort_damp - write (iulog,*) ' fv3_dwind_2d = ',fv3_dwind_2d - write (iulog,*) ' fv3_fill = ',fv3_fill - write (iulog,*) ' fv3_fv_debug = ',fv3_fv_debug - write (iulog,*) ' fv3_fv_diag = ',fv3_fv_diag - write (iulog,*) ' fv3_fv_sg_adj = ',fv3_fv_sg_adj - write (iulog,*) ' fv3_grid_type = ',fv3_grid_type - write (iulog,*) ' fv3_hord_dp = ',fv3_hord_dp - write (iulog,*) ' fv3_hord_mt = ',fv3_hord_mt - write (iulog,*) ' fv3_hord_tm = ',fv3_hord_tm - write (iulog,*) ' fv3_hord_tr = ',fv3_hord_tr - write (iulog,*) ' fv3_hord_vt = ',fv3_hord_vt - write (iulog,*) ' fv3_hydrostatic = ',fv3_hydrostatic - write (iulog,*) ' fv3_io_layout = ',fv3_io_layout - write (iulog,*) ' fv3_k_split = ',fv3_k_split - write (iulog,*) ' fv3_ke_bg = ',fv3_ke_bg - write (iulog,*) ' fv3_kord_mt = ',fv3_kord_mt - write (iulog,*) ' fv3_kord_tm = ',fv3_kord_tm - write (iulog,*) ' fv3_kord_tr = ',fv3_kord_tr - write (iulog,*) ' fv3_kord_wz = ',fv3_kord_wz - write (iulog,*) ' fv3_layout = ',fv3_layout - write (iulog,*) ' fv3_lcp_moist = ',fv3_lcp_moist - write (iulog,*) ' fv3_lcv_moist = ',fv3_lcv_moist - write (iulog,*) ' fv3_make_nh = ',fv3_make_nh - write (iulog,*) ' fv3_n_split = ',fv3_n_split - write (iulog,*) ' fv3_n_sponge = ',fv3_n_sponge - write (iulog,*) ' fv3_na_init = ',fv3_na_init - write (iulog,*) ' fv3_ncnst = ',fv3_ncnst - write (iulog,*) ' fv3_no_dycore = ',fv3_no_dycore - write (iulog,*) ' fv3_nord = ',fv3_nord - write (iulog,*) ' fv3_npx = ',fv3_npx - write (iulog,*) ' fv3_npy = ',fv3_npy - write (iulog,*) ' fv3_npz = ',fv3_npz - write (iulog,*) ' fv3_ntiles = ',fv3_ntiles - write (iulog,*) ' fv3_nwat = ',fv3_nwat - write (iulog,*) ' fv3_print_freq = ',fv3_print_freq - write (iulog,*) ' fv3_domains_stack_size = ',fv3_domains_stack_size - write (iulog,*) ' fv3_range_warn = ',fv3_range_warn - write (iulog,*) ' fv3_rf_cutoff = ',fv3_rf_cutoff - write (iulog,*) ' fv3_scale_ttend = ',fv3_scale_ttend - write (iulog,*) ' fv3_stack_size = ',fv3_stack_size - write (iulog,*) ' fv3_tau = ',fv3_tau - write (iulog,*) ' fv3_vtdm4 = ',fv3_vtdm4 - end if - - ! Create the input.nml namelist needed by the fv3dycore. - ! Read strings one at a time from the fv3 namelist groups, - ! strip off the leading 'fv3_' from the variable names and write to input.nml. - ! This could be replaced by also by writing to the internal namelist file - - if (masterproc) then - - write(iulog,*) 'Creating fv3 input.nml file from atm_in fv3_xxx namelist parameters' - ! Read the namelist (main_nml) - ! open the file input.nml - ! overwrite file if it exists. - open( newunit=unito, file='input.nml', status='replace' ) - - open( newunit=unitn, file=trim(NLFileName), status='old' ) - - do i=1,SIZE(group_names(:)) - rewind(unitn) - call find_group_name(unitn, trim(group_names(i)), status=ierr) - - if (ierr == 0) then ! Found it. Copy each line to input.nml until '/' is encountered. - - ! write group name to input.nml - read(unitn, '(a)', iostat=ios, end=100) inrec - if (ios /= 0) call endrun('ERROR: dyn_readnl - error reading fv3 namelist') - write(unito,'(a)') trim(inrec) - - ios = 0 - do while (ios <= 0) - - read(unitn, '(a)', iostat=ios, end=100) inrec - - if (ios <= 0) then ! ios < 0 indicates an end of record condition - - ! remove leading blanks and check for leading '/' - inrec2 = adjustl(inrec) - if (inrec2(1:4) == 'fv3_') then - inrec2(1:4) = ' ' - end if - write(unito,'(a)') trim(inrec2) - if (inrec2(1:1) == '/') exit - end if - end do - end if - end do - close(unitn) - close(unito) - end if - return -100 continue - call endrun('ERROR: dyn_readnl: End of file encountered while reading fv3 namelist groups') - -end subroutine dyn_readnl - -!============================================================================================= - -subroutine dyn_register() - - ! These fields are computed by the dycore and passed to the physics via the - ! physics buffer. - -end subroutine dyn_register - -!============================================================================================= - -subroutine dyn_init(dyn_in, dyn_out) - - ! DESCRIPTION: Initialize the FV dynamical core - - ! Initialize FV dynamical core state variables - - - use cam_control_mod, only: initial_run - use cam_history, only: addfld, horiz_only - use cam_history, only: register_vector_field - use cam_pio_utils, only: clean_iodesc_list - use dyn_grid, only: Atm,mygindex,mylindex - use fv_diagnostics_mod, only: fv_diag_init - use fv_mp_mod, only: fill_corners, YDir, switch_current_Atm - use infnan, only: inf, assignment(=) - use physconst, only: cpwv, cpliq, cpice, rair, cpair - use air_composition, only: thermodynamic_active_species_num, dry_air_species_num, thermodynamic_active_species_idx - use air_composition, only: thermodynamic_active_species_idx_dycore - use tracer_manager_mod, only: register_tracers - use dyn_tests_utils, only: vc_dycore, vc_moist_pressure, string_vc, vc_str_lgth - ! arguments: - type (dyn_import_t), intent(out) :: dyn_in - type (dyn_export_t), intent(out) :: dyn_out - - ! Locals - character(len=*), parameter :: subname='dyn_init' - real(r8) :: alpha - - - real(r8), pointer, dimension(:,:) :: fC,f0 ! Coriolis parameters - real(r8), pointer, dimension(:,:,:) :: grid,agrid,delp - logical, pointer :: cubed_sphere - type(domain2d), pointer :: domain - integer :: i,j,m - - ! variables for initializing energy and axial angular momentum diagnostics - character (len = 3), dimension(8) :: stage = (/"dED","dAP","dBD","dAT","dAF","dAD","dAR","dBF"/) - character (len = 70),dimension(8) :: stage_txt = (/& - " end of previous dynamics ",& !dED - " after physics increment on A-grid ",& !dAP - " state after applying CAM forcing ",& !dBD - state after applyCAMforcing - " state after top of atmosphere damping (Rayleigh) ",& !dAT - " from previous remapping or state passed to dynamics",& !dAF - state in beginning of ksplit loop - " before vertical remapping ",& !dAD - state before vertical remapping - " after vertical remapping ",& !dAR - state at end of nsplit loop - " state passed to parameterizations " & !dBF - /) - character (len = 2) , dimension(11) :: vars = (/"WV","WL","WI","WR","WS","WG","SE","KE","MR","MO","TT"/) - character (len = 70), dimension(11) :: vars_descriptor = (/& - "Total column water vapor ",& - "Total column cloud water ",& - "Total column cloud ice ",& - "Total column rain ",& - "Total column snow ",& - "Total column graupel ",& - "Total column dry static energy ",& - "Total column kinetic energy ",& - "Total column wind axial angular momentum",& - "Total column mass axial angular momentum",& - "Total column test tracer "/) - character (len = 14), dimension(11) :: & - vars_unit = (/& - "kg/m2 ","kg/m2 ","kg/m2 ", & - "kg/m2 ","kg/m2 ","kg/m2 ","J/m2 ",& - "J/m2 ","kg*m2/s*rad2 ","kg*m2/s*rad2 ","kg/m2 "/) - - integer :: istage, ivars - character (len=108) :: str1, str2, str3 - character (len=vc_str_lgth) :: vc_str - integer :: is,isd,ie,ied,js,jsd,je,jed - integer :: fv3idx,idx - - integer :: unito - integer, parameter :: ndiag = 5 - integer :: ncnst, pnats, num_family, nt_prog - character(len=128) :: errmsg - logical :: wet_thermo_species - !----------------------------------------------------------------------- - vc_dycore = vc_moist_pressure - if (masterproc) then - call string_vc(vc_dycore,vc_str) - write(iulog,*) subname//': vertical coordinate dycore : ',trim(vc_str) - end if - ! Setup the condensate loading arrays and fv3/cam tracer mapping and - ! finish initializing fv3 by allocating the tracer arrays in the fv3 atm structure - - allocate(qsize_tracer_idx_cam2dyn(pcnst)) - qsize_tracer_idx_cam2dyn(:)=-1 - allocate(cnst_name_ffsl(pcnst)) ! constituent names for ffsl tracers - allocate(cnst_longname_ffsl(pcnst)) ! long name of constituents for ffsl tracers - - - ! set up the condensate loading array - if (thermodynamic_active_species_num - dry_air_species_num > 6) then - call endrun(subname//': fv3_thermodynamic_active_species_num is limited to 6 wet condensates') - end if - - !For FV3 Q must be the first species in the fv3 tracer array followed by wet constituents - idx=1 - do m=1,pcnst - if ( trim(cnst_name(m)) == 'Q'.or.& - trim(cnst_name(m)) == 'CLDLIQ'.or.& - trim(cnst_name(m)) == 'CLDICE'.or.& - trim(cnst_name(m)) == 'RAINQM'.or.& - trim(cnst_name(m)) == 'SNOWQM'.or.& - trim(cnst_name(m)) == 'GRAUQM') then - idx=idx+1 - wet_thermo_species=any(thermodynamic_active_species_idx(dry_air_species_num+1:thermodynamic_active_species_num)==m) - select case ( trim(cnst_name(m)) ) - case ( 'Q' ) - idx=idx-1 - cnst_name_ffsl(1)='sphum' - cnst_longname_ffsl(1) = cnst_longname(m) - qsize_tracer_idx_cam2dyn(m) = 1 - if (wet_thermo_species) thermodynamic_active_species_idx_dycore(1)=1 - case ( 'CLDLIQ' ) - cnst_name_ffsl(idx)='liq_wat' - case ( 'CLDICE' ) - cnst_name_ffsl(idx)='ice_wat' - case ( 'RAINQM' ) - cnst_name_ffsl(idx)='rainwat' - case ( 'SNOWQM' ) - cnst_name_ffsl(idx)='snowwat' - case ( 'GRAUQM' ) - cnst_name_ffsl(idx)='graupel' - end select - - if (trim(cnst_name(m))/='Q') then - if (wet_thermo_species) thermodynamic_active_species_idx_dycore(idx)=idx - cnst_longname_ffsl(idx) = cnst_longname(m) - qsize_tracer_idx_cam2dyn(m) = idx - end if - end if - end do - - do m=1,pcnst - if ( trim(cnst_name(m)) /= 'Q'.and.& - trim(cnst_name(m)) /= 'CLDLIQ'.and.& - trim(cnst_name(m)) /= 'CLDICE'.and.& - trim(cnst_name(m)) /= 'RAINQM'.and.& - trim(cnst_name(m)) /= 'SNOWQM'.and.& - trim(cnst_name(m)) /= 'GRAUQM') then - idx=idx+1 - cnst_name_ffsl(idx)=cnst_name(m) - cnst_longname_ffsl(idx) = cnst_longname(m) - qsize_tracer_idx_cam2dyn(m) = idx - end if - end do - - if (masterproc) then - - write(iulog,*) subname//': Creating field_table file to load tracer fields into fv3' - ! overwrite file if it exists. - open( newunit=unito, file='field_table', status='replace' ) - do i=1,pcnst - write(unito, '(a,a,a)') '"tracer" "atmos_mod" "'//trim(cnst_name_ffsl(i))//'" /' - end do - close(unito) - end if - !---------must make sure the field_table file is written before reading across processors - call mpibarrier (mpicom) - call register_tracers (MODEL_ATMOS, ncnst, nt_prog, pnats, num_family) - if (ncnst /= pcnst) then - call endrun(subname//': ERROR: FMS tracer Manager has inconsistent tracer numbers') - endif - - do m=1,pcnst - ! just check condensate loading tracers as they are mapped above - if(qsize_tracer_idx_cam2dyn(m) <= thermodynamic_active_species_num-dry_air_species_num) then - fv3idx = get_tracer_index (MODEL_ATMOS, cnst_name_ffsl(qsize_tracer_idx_cam2dyn(m)) ) - if (fv3idx /= qsize_tracer_idx_cam2dyn(m)) then - write(errmsg,*) subname//': Physics index ',m,'and FV3 tracer index',fv3idx,' are inconsistent' - call endrun(errmsg) - end if - end if - end do - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - isd = Atm(mytile)%bd%isd - ied = Atm(mytile)%bd%ied - jsd = Atm(mytile)%bd%jsd - jed = Atm(mytile)%bd%jed - - ! Data initialization - dyn_in%Atm => Atm - dyn_in%mygindex => mygindex - dyn_in%mylindex => mylindex - dyn_out%Atm => Atm - - allocate(u_dt(isd:ied,jsd:jed,nlev)) - allocate(v_dt(isd:ied,jsd:jed,nlev)) - allocate(t_dt(isd:ied,jsd:jed,nlev)) - u_dt(:,:,:) = 0._r8 - v_dt(:,:,:) = 0._r8 - t_dt(:,:,:) = 0._r8 - - fC => atm(mytile)%gridstruct%fC - f0 => atm(mytile)%gridstruct%f0 - grid => atm(mytile)%gridstruct%grid_64 - agrid => atm(mytile)%gridstruct%agrid_64 - domain=> Atm(mytile)%domain - cubed_sphere => atm(mytile)%gridstruct%cubed_sphere - delp => Atm(mytile)%delp - - ! initialize Coriolis parameters which are used in sw_core. - f0(:,:) = inf - fC(:,:) = inf - alpha = 0._r8 - - do j=jsd,jed+1 - do i=isd,ied+1 - fC(i,j) = 2._r8*omega*( -1._r8*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + & - sin(grid(i,j,2))*cos(alpha) ) - enddo - enddo - do j=jsd,jed - do i=isd,ied - f0(i,j) = 2._r8*omega*( -1._r8*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + & - sin(agrid(i,j,2))*cos(alpha) ) - enddo - enddo - call mpp_update_domains( f0, domain ) - if (cubed_sphere) call fill_corners(f0, npx, npy, YDir) - - delp(isd:is-1,jsd:js-1,1:nlev)=0._r8 - delp(isd:is-1,je+1:jed,1:nlev)=0._r8 - delp(ie+1:ied,jsd:js-1,1:nlev)=0._r8 - delp(ie+1:ied,je+1:jed,1:nlev)=0._r8 - - if (initial_run) then - - ! Read in initial data - call read_inidat(dyn_in) - call clean_iodesc_list() - - end if - - call switch_current_Atm(Atm(mytile)) - call set_domain ( Atm(mytile)%domain ) - - ! Forcing from physics on the FFSL grid - call addfld ('FU', (/ 'lev' /), 'A', 'm/s2', 'Zonal wind forcing term on FFSL grid', gridname='FFSLHIST') - call addfld ('FV', (/ 'lev' /), 'A', 'm/s2', 'Meridional wind forcing term on FFSL grid',gridname='FFSLHIST') - call register_vector_field('FU', 'FV') - call addfld ('FT', (/ 'lev' /), 'A', 'K/s', 'Temperature forcing term on FFSL grid',gridname='FFSLHIST') - - do m = 1, pcnst - call addfld ('F'//trim(cnst_name_ffsl(m))//'_ffsl', (/ 'lev' /), 'I', 'kg/kg/s', & - trim(cnst_longname(m))//' mixing ratio forcing term (q_new-q_old) on FFSL grid', gridname='FFSLHIST') - call addfld(tottnam(m),(/ 'lev' /),'A','kg/kg/s', & - trim(cnst_name_ffsl(m))//' horz + vert + fixer tendency ', & - gridname='FFSLHIST') - end do - - ! Energy diagnostics and axial angular momentum diagnostics - do istage = 1,SIZE(stage) - do ivars=1,SIZE(vars) - write(str1,*) TRIM(ADJUSTL(vars(ivars))),TRIM(ADJUSTL("_")),TRIM(ADJUSTL(stage(istage))) - write(str2,*) TRIM(ADJUSTL(vars_descriptor(ivars))),& - TRIM(ADJUSTL(" ")),TRIM(ADJUSTL(stage_txt(istage))) - write(str3,*) TRIM(ADJUSTL(vars_unit(ivars))) - call addfld (TRIM(ADJUSTL(str1)),horiz_only,'A',TRIM(ADJUSTL(str3)),TRIM(ADJUSTL(str2)), & - gridname='FFSLHIST') - end do - end do - - allocate(se_dyn(is:ie,js:je,ndiag)) - allocate(ke_dyn(is:ie,js:je,ndiag)) - allocate(wv_dyn(is:ie,js:je,ndiag)) - allocate(wl_dyn(is:ie,js:je,ndiag)) - allocate(wi_dyn(is:ie,js:je,ndiag)) - allocate(wr_dyn(is:ie,js:je,ndiag)) - allocate(ws_dyn(is:ie,js:je,ndiag)) - allocate(wg_dyn(is:ie,js:je,ndiag)) - allocate(tt_dyn(is:ie,js:je,ndiag)) - allocate(mr_dyn(is:ie,js:je,ndiag)) - allocate(mo_dyn(is:ie,js:je,ndiag)) - - -end subroutine dyn_init - -!======================================================================= - -subroutine dyn_run(dyn_state) - - ! DESCRIPTION: Driver for the NASA finite-volume dynamical core - - - use dimensions_mod, only: nlev - use dyn_grid, only: p_split,grids_on_this_pe - use fv_control_mod, only: ngrids - use fv_dynamics_mod, only: fv_dynamics - use fv_sg_mod, only: fv_subgrid_z - use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx_dycore, & - thermodynamic_active_species_cp,thermodynamic_active_species_cv,dry_air_species_num - use time_manager, only: get_step_size - use tracer_manager_mod, only: get_tracer_index, NO_TRACER - - ! Arguments - type (dyn_export_t), intent(inout) :: dyn_state - - ! Locals - integer :: psc,idim - integer :: w_diff, nt_dyn - type(fv_atmos_type), pointer :: Atm(:) - integer :: is,isc,isd,ie,iec,ied,js,jsc,jsd,je,jec,jed - - !---- Call FV dynamics ----- - - Atm => dyn_state%Atm - - !----------------------------------------------------------------------- - - call mpp_set_current_pelist(Atm(mytile)%pelist, no_sync=.TRUE.) - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - isc = Atm(mytile)%bd%isc - iec = Atm(mytile)%bd%iec - jsc = Atm(mytile)%bd%jsc - jec = Atm(mytile)%bd%jec - isd = Atm(mytile)%bd%isd - ied = Atm(mytile)%bd%ied - jsd = Atm(mytile)%bd%jsd - jed = Atm(mytile)%bd%jed - - idim=ie-is+1 - - dt_atmos_real=get_step_size() - - se_dyn = 0._r8 - ke_dyn = 0._r8 - wv_dyn = 0._r8 - wl_dyn = 0._r8 - wi_dyn = 0._r8 - wr_dyn = 0._r8 - ws_dyn = 0._r8 - wg_dyn = 0._r8 - tt_dyn = 0._r8 - mo_dyn = 0._r8 - mr_dyn = 0._r8 - - zvir = rvgas/rdgas - 1._r8 - - Atm(mytile)%parent_grid => Atm(mytile) - - do psc=1,abs(p_split) - - call fv_dynamics(npx, npy, nlev, pcnst, Atm(mytile)%ng, dt_atmos_real/real(abs(p_split), r8),& - Atm(mytile)%flagstruct%consv_te, Atm(mytile)%flagstruct%fill, & - Atm(mytile)%flagstruct%reproduce_sum, kappa, cp_air, zvir,& - Atm(mytile)%ptop, Atm(mytile)%ks, pcnst, & - Atm(mytile)%flagstruct%n_split, Atm(mytile)%flagstruct%q_split,& - Atm(mytile)%u, Atm(mytile)%v, Atm(mytile)%w, Atm(mytile)%delz, & - Atm(mytile)%flagstruct%hydrostatic, & - Atm(mytile)%pt, Atm(mytile)%delp, Atm(mytile)%q, Atm(mytile)%ps, & - Atm(mytile)%pe, Atm(mytile)%pk, Atm(mytile)%peln, & - Atm(mytile)%pkz, Atm(mytile)%phis, Atm(mytile)%q_con, & - Atm(mytile)%omga, Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%uc, & - Atm(mytile)%vc, Atm(mytile)%ak, Atm(mytile)%bk, Atm(mytile)%mfx, & - Atm(mytile)%mfy, Atm(mytile)%cx, Atm(mytile)%cy, Atm(mytile)%ze0, & - Atm(mytile)%flagstruct%hybrid_z, & - Atm(mytile)%gridstruct, Atm(mytile)%flagstruct, & - Atm(mytile)%neststruct, Atm(mytile)%idiag, Atm(mytile)%bd, & - Atm(mytile)%parent_grid, Atm(mytile)%domain, & -#if ( defined CALC_ENERGY ) - Atm(mytile)%diss_est, & - pcnst,thermodynamic_active_species_num,dry_air_species_num, & - thermodynamic_active_species_idx_dycore, qsize_tracer_idx_cam2dyn, & - thermodynamic_active_species_cp,thermodynamic_active_species_cv, se_dyn, ke_dyn, wv_dyn,wl_dyn, & - wi_dyn,wr_dyn,ws_dyn,wg_dyn,tt_dyn,mo_dyn,mr_dyn,gravit,cpair,rearth,omega,fv3_lcp_moist,& - fv3_lcv_moist) -#else - Atm(mytile)%diss_est) -#endif - - if (ngrids > 1 .and. (psc < p_split .or. p_split < 0)) then - call twoway_nesting(Atm, ngrids, grids_on_this_pe, zvir) - endif - - end do !p_split -#if ( defined CALC_ENERGY ) - call write_dyn_var(se_dyn(is:ie,js:je,1),'SE_dAF',Atm(mytile)%bd) - call write_dyn_var(ke_dyn(is:ie,js:je,1),'KE_dAF',Atm(mytile)%bd) - call write_dyn_var(wv_dyn(is:ie,js:je,1),'WV_dAF',Atm(mytile)%bd) - call write_dyn_var(wl_dyn(is:ie,js:je,1),'WL_dAF',Atm(mytile)%bd) - call write_dyn_var(wi_dyn(is:ie,js:je,1),'WI_dAF',Atm(mytile)%bd) - call write_dyn_var(wr_dyn(is:ie,js:je,1),'WR_dAF',Atm(mytile)%bd) - call write_dyn_var(ws_dyn(is:ie,js:je,1),'WS_dAF',Atm(mytile)%bd) - call write_dyn_var(wg_dyn(is:ie,js:je,1),'WG_dAF',Atm(mytile)%bd) - call write_dyn_var(tt_dyn(is:ie,js:je,1),'TT_dAF',Atm(mytile)%bd) - call write_dyn_var(mo_dyn(is:ie,js:je,1),'MO_dAF',Atm(mytile)%bd) - call write_dyn_var(mr_dyn(is:ie,js:je,1),'MR_dAF',Atm(mytile)%bd) - - call write_dyn_var(se_dyn(is:ie,js:je,2),'SE_dAD',Atm(mytile)%bd) - call write_dyn_var(ke_dyn(is:ie,js:je,2),'KE_dAD',Atm(mytile)%bd) - call write_dyn_var(wv_dyn(is:ie,js:je,2),'WV_dAD',Atm(mytile)%bd) - call write_dyn_var(wl_dyn(is:ie,js:je,2),'WL_dAD',Atm(mytile)%bd) - call write_dyn_var(wi_dyn(is:ie,js:je,2),'WI_dAD',Atm(mytile)%bd) - call write_dyn_var(wr_dyn(is:ie,js:je,2),'WR_dAD',Atm(mytile)%bd) - call write_dyn_var(ws_dyn(is:ie,js:je,2),'WS_dAD',Atm(mytile)%bd) - call write_dyn_var(wg_dyn(is:ie,js:je,2),'WG_dAD',Atm(mytile)%bd) - call write_dyn_var(tt_dyn(is:ie,js:je,2),'TT_dAD',Atm(mytile)%bd) - call write_dyn_var(mo_dyn(is:ie,js:je,2),'MO_dAD',Atm(mytile)%bd) - call write_dyn_var(mr_dyn(is:ie,js:je,2),'MR_dAD',Atm(mytile)%bd) - - call write_dyn_var(se_dyn(is:ie,js:je,3),'SE_dAR',Atm(mytile)%bd) - call write_dyn_var(ke_dyn(is:ie,js:je,3),'KE_dAR',Atm(mytile)%bd) - call write_dyn_var(wv_dyn(is:ie,js:je,3),'WV_dAR',Atm(mytile)%bd) - call write_dyn_var(wl_dyn(is:ie,js:je,3),'WL_dAR',Atm(mytile)%bd) - call write_dyn_var(wi_dyn(is:ie,js:je,3),'WI_dAR',Atm(mytile)%bd) - call write_dyn_var(wr_dyn(is:ie,js:je,3),'WR_dAR',Atm(mytile)%bd) - call write_dyn_var(ws_dyn(is:ie,js:je,3),'WS_dAR',Atm(mytile)%bd) - call write_dyn_var(wg_dyn(is:ie,js:je,3),'WG_dAR',Atm(mytile)%bd) - call write_dyn_var(tt_dyn(is:ie,js:je,3),'TT_dAR',Atm(mytile)%bd) - call write_dyn_var(mo_dyn(is:ie,js:je,3),'MO_dAR',Atm(mytile)%bd) - call write_dyn_var(mr_dyn(is:ie,js:je,3),'MR_dAR',Atm(mytile)%bd) - - call write_dyn_var(se_dyn(is:ie,js:je,4),'SE_dAT',Atm(mytile)%bd) - call write_dyn_var(ke_dyn(is:ie,js:je,4),'KE_dAT',Atm(mytile)%bd) - call write_dyn_var(wv_dyn(is:ie,js:je,4),'WV_dAT',Atm(mytile)%bd) - call write_dyn_var(wl_dyn(is:ie,js:je,4),'WL_dAT',Atm(mytile)%bd) - call write_dyn_var(wi_dyn(is:ie,js:je,4),'WI_dAT',Atm(mytile)%bd) - call write_dyn_var(wr_dyn(is:ie,js:je,4),'WR_dAT',Atm(mytile)%bd) - call write_dyn_var(ws_dyn(is:ie,js:je,4),'WS_dAT',Atm(mytile)%bd) - call write_dyn_var(wg_dyn(is:ie,js:je,4),'WG_dAT',Atm(mytile)%bd) - call write_dyn_var(tt_dyn(is:ie,js:je,4),'TT_dAT',Atm(mytile)%bd) - call write_dyn_var(mo_dyn(is:ie,js:je,4),'MO_dAT',Atm(mytile)%bd) - call write_dyn_var(mr_dyn(is:ie,js:je,4),'MR_dAT',Atm(mytile)%bd) -#endif - - !----------------------------------------------------- - !--- COMPUTE SUBGRID Z - !----------------------------------------------------- - !--- zero out tendencies - u_dt(:,:,:) = 0._r8 - v_dt(:,:,:) = 0._r8 - t_dt(:,:,:) = 0._r8 - - w_diff = get_tracer_index (MODEL_ATMOS, 'w_diff' ) - - ! Perform grid-scale dry adjustment if fv_sg_adj > 0 - if ( Atm(mytile)%flagstruct%fv_sg_adj > 0 ) then - nt_dyn = pcnst - if ( w_diff /= NO_TRACER ) then - nt_dyn = pcnst - 1 - endif - call fv_subgrid_z(isd, ied, jsd, jed, isc, iec, jsc, jec, nlev, & - nt_dyn, dt_atmos_real, Atm(mytile)%flagstruct%fv_sg_adj, & - Atm(mytile)%flagstruct%nwat, Atm(mytile)%delp, Atm(mytile)%pe, & - Atm(mytile)%peln, Atm(mytile)%pkz, Atm(mytile)%pt, Atm(mytile)%q, & - Atm(mytile)%ua, Atm(mytile)%va, Atm(mytile)%flagstruct%hydrostatic,& - Atm(mytile)%w, Atm(mytile)%delz, u_dt, v_dt, t_dt, Atm(mytile)%flagstruct%n_sponge) - endif - -#if ( defined CALC_ENERGY ) - call calc_tot_energy_dynamics(atm,'dBF') -#endif - -end subroutine dyn_run - -!======================================================================= - -subroutine dyn_final(dyn_in, dyn_out, restart_file) - - ! Arguments - type (dyn_import_t), intent(inout) :: dyn_in - type (dyn_export_t), intent(inout) :: dyn_out - character(len=*),optional,intent(in) :: restart_file - - !---------------------------------------------------------------------------- - - deallocate( u_dt, v_dt, t_dt) - -end subroutine dyn_final - -!============================================================================================= -! Private routines -!============================================================================================= - -subroutine read_inidat(dyn_in) - - use cam_control_mod, only: simple_phys - use inic_analytic, only: analytic_ic_active, analytic_ic_set_ic - use dyn_tests_utils, only: vc_moist_pressure,vc_dry_pressure - use dimensions_mod, only: nlev - use constituents, only: pcnst, cnst_is_a_water_species - use air_composition, only: thermodynamic_active_species_num, dry_air_species_num, thermodynamic_active_species_idx_dycore - use pio, only: file_desc_t, pio_seterrorhandling, pio_bcast_error - use ppgrid, only: pver - use cam_abortutils, only: endrun - use constituents, only: pcnst, cnst_name, cnst_read_iv,qmin, cnst_type - use const_init, only: cnst_init_default - use cam_initfiles, only: initial_file_get_id, topo_file_get_id, pertlim - use cam_grid_support, only: cam_grid_id, cam_grid_get_gcid, iMap, & - cam_grid_get_latvals, cam_grid_get_lonvals - use cam_history_support, only: max_fieldname_len - use hycoef, only: hyai, hybi, ps0 - use cam_initfiles, only: scale_dry_air_mass - - ! Arguments: - type (dyn_import_t), target, intent(inout) :: dyn_in ! dynamics import - - ! Locals: - logical :: found - - character(len = 40) :: fieldname,fieldname2 - - integer :: i, j, k, m, n - - type(file_desc_t), pointer :: fh_topo => null() - type(fv_atmos_type), pointer :: Atm(:) => null() - integer, pointer :: mylindex(:,:) => null() - integer, pointer :: mygindex(:,:) => null() - type(file_desc_t) :: fh_ini - - - character(len=*), parameter :: subname='READ_INIDAT' - - ! Variables for analytic initial conditions - integer, allocatable, dimension(:) :: glob_ind, m_ind,rndm_seed - integer :: is,ie,js,je,isd,ied,jsd,jed - integer :: blksize - integer :: indx - integer :: err_handling - integer :: m_cnst,m_cnst_ffsl - integer :: m_ffsl - integer :: ilen,jlen - integer :: num_wet_species! (wet species are first tracers in FV3 tracer array) - integer :: pio_errtype - integer :: rndm_seed_sz - integer :: vcoord - real(r8), pointer, dimension(:) :: latvals_deg(:) - real(r8), pointer, dimension(:) :: lonvals_deg(:) - real(r8), allocatable, dimension(:) :: latvals_rad, lonvals_rad - real(r8), allocatable, dimension(:,:) :: dbuf2 - real(r8), allocatable, dimension(:,:) :: pstmp - real(r8), allocatable, dimension(:,:) :: phis_tmp, var2d - real(r8), allocatable, dimension(:,:,:) :: dbuf3, var3d - real(r8), allocatable, dimension(:,:,:,:) :: dbuf4 - real(r8), pointer, dimension(:,:,:) :: agrid,grid - real(r8) :: pertval - real(r8) :: tracermass(pcnst),delpdry - real(r8) :: fv3_totwatermass, fv3_airmass - real(r8) :: reldif - logical :: inic_wet !initial condition is based on wet pressure and water species - - !----------------------------------------------------------------------- - - Atm => dyn_in%Atm - grid => Atm(mytile)%gridstruct%grid_64 - agrid => Atm(mytile)%gridstruct%agrid_64 - mylindex => dyn_in%mylindex - mygindex => dyn_in%mygindex - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - isd = Atm(mytile)%bd%isd - ied = Atm(mytile)%bd%ied - jsd = Atm(mytile)%bd%jsd - jed = Atm(mytile)%bd%jed - - fh_topo => topo_file_get_id() - fh_ini = initial_file_get_id() - - - ! Set mask to indicate which columns are active - ldof_size=(je-js+1)*(ie-is+1) - allocate(phis_tmp(ldof_size,1)) - phis_tmp(:,:)=0._r8 - - latvals_deg => cam_grid_get_latvals(cam_grid_id('FFSL')) - lonvals_deg => cam_grid_get_lonvals(cam_grid_id('FFSL')) - blksize=(ie-is+1)*(je-js+1) - - ! consistency check - if (blksize /= SIZE(latvals_deg)) then - call endrun(trim(subname)//': number of latitude values is inconsistent with dynamics block size.') - end if - - allocate(latvals_rad(blksize)) - allocate(lonvals_rad(blksize)) - latvals_rad(:) = latvals_deg(:)*deg2rad - lonvals_rad(:) = lonvals_deg(:)*deg2rad - - allocate(glob_ind(blksize)) - do j = js, je - do i = is, ie - n=mylindex(i,j) - glob_ind(n) = mygindex(i,j) - end do - end do - - ! Set ICs. Either from analytic expressions or read from file. - - if (analytic_ic_active()) then - vcoord = vc_moist_pressure - inic_wet = .true. - ! First, initialize all the variables, then assign - allocate(dbuf2(blksize,1)) - allocate(dbuf3(blksize,nlev,1)) - allocate(dbuf4(blksize,nlev, 1,pcnst)) - dbuf2 = 0.0_r8 - dbuf3 = 0.0_r8 - dbuf4 = 0.0_r8 - - allocate(m_ind(pcnst)) - do m_cnst = 1, pcnst - m_ind(m_cnst) = m_cnst - end do - - call analytic_ic_set_ic(vcoord, latvals_rad, lonvals_rad, glob_ind,PS=dbuf2) - do j = js, je - do i = is, ie - ! PS - n=mylindex(i,j) - atm(mytile)%ps(i,j) = dbuf2(n, 1) - end do - end do - - call analytic_ic_set_ic(vcoord, latvals_rad, lonvals_rad, glob_ind , & - PHIS_OUT=phis_tmp(:,:)) - - call analytic_ic_set_ic(vcoord, latvals_rad, lonvals_rad, glob_ind, & - T=dbuf3(:,:,:)) - - do j = js, je - do i = is, ie - ! T - n=mylindex(i,j) - atm(mytile)%pt(i,j,:) = dbuf3(n, :, 1) - end do - end do - - - dbuf3=0._r8 - call analytic_ic_set_ic(vcoord, latvals_rad, lonvals_rad, glob_ind, & - U=dbuf3(:,:,:)) - - do j = js, je - do i = is, ie - ! U a-grid - n=mylindex(i,j) - atm(mytile)%ua(i,j,:) = dbuf3(n, :, 1) - end do - end do - - dbuf3=0._r8 - call analytic_ic_set_ic(vcoord, latvals_rad, lonvals_rad, glob_ind, & - V=dbuf3(:,:,:)) - - do j = js, je - do i = is, ie - ! V a-grid - n=mylindex(i,j) - atm(mytile)%va(i,j,:) = dbuf3(n, :, 1) - end do - end do - - call analytic_ic_set_ic(vcoord, latvals_rad, lonvals_rad, glob_ind, & - Q=dbuf4(:,:,:,1:pcnst), m_cnst=m_ind) - - ! Tracers to be advected on FFSL grid. - do m_cnst = 1, pcnst - m_cnst_ffsl=qsize_tracer_idx_cam2dyn(m_cnst) - Atm(mytile)%q(:,:,:,m_cnst_ffsl) = 0.0_r8 - do j = js, je - do i = is, ie - indx=mylindex(i,j) - Atm(mytile)%q(i,j,:,m_cnst_ffsl) = dbuf4(indx, :, 1, m_cnst) - end do - end do - end do - - !----------------------------------------------------------------------- - call a2d3djt(atm(mytile)%ua, atm(mytile)%va, atm(mytile)%u, atm(mytile)%v, is, ie, js, je, & - isd, ied, jsd, jed, npx,npy, nlev, atm(mytile)%gridstruct, atm(mytile)%domain) - - deallocate(dbuf2) - deallocate(dbuf3) - deallocate(dbuf4) - deallocate(m_ind) - - else - ! Read ICs from file. - - allocate(dbuf3(blksize,nlev,1)) - allocate(var2d(is:ie,js:je)) - allocate(var3d(is:ie,js:je,nlev)) - - call pio_seterrorhandling(fh_ini, pio_bcast_error, err_handling) - ! PSDRY is unambiguous so use that field first if it exists and reset mixing ratios to - ! wet for FV3. PS (inic_wet) is assumed to be DRY+All wet condensates but could also be - ! DRY+Q (CAM physics) - fieldname = 'PSDRY' - fieldname2 = 'PS' - if (dyn_field_exists(fh_ini, trim(fieldname), required=.false.)) then - inic_wet = .false. - call read_dyn_var(trim(fieldname), fh_ini, 'ncol', var2d) - elseif (dyn_field_exists(fh_ini, trim(fieldname2), required=.false.)) then - inic_wet = .true. - call read_dyn_var(trim(fieldname2), fh_ini, 'ncol', var2d) - else - call endrun(trim(subname)//': PS or PSDRY must be on ncdata') - end if - atm(mytile)%ps(is:ie,js:je) = var2d - - ilen = ie-is+1 - jlen = je-js+1 - - ! T - if (dyn_field_exists(fh_ini, 'T')) then - call read_dyn_var('T', fh_ini, 'ncol', var3d) - atm(mytile)%pt(is:ie,js:je,1:nlev)=var3d(is:ie,js:je,1:nlev) - else - call endrun(trim(subname)//': T not found') - end if - - if (pertlim /= 0.0_r8) then - if(masterproc) then - write(iulog,*) trim(subname), ': Adding random perturbation bounded', & - 'by +/- ', pertlim, ' to initial temperature field' - end if - - call random_seed(size=rndm_seed_sz) - allocate(rndm_seed(rndm_seed_sz)) - - do i=is,ie - do j=js,je - indx=mylindex(i,j) - rndm_seed = glob_ind(indx) - call random_seed(put=rndm_seed) - do k=1,nlev - call random_number(pertval) - pertval = 2.0_r8*pertlim*(0.5_r8 - pertval) - atm(mytile)%pt(i,j,k) = atm(mytile)%pt(i,j,k)*(1.0_r8 + pertval) - end do - end do - end do - deallocate(rndm_seed) - end if - - ! V - if (dyn_field_exists(fh_ini, 'V')) then - call read_dyn_var('V', fh_ini, 'ncol', var3d) - atm(mytile)%va(is:ie,js:je,1:nlev)=var3d(is:ie,js:je,1:nlev) - else - call endrun(trim(subname)//': V not found') - end if - - if (dyn_field_exists(fh_ini, 'U')) then - call read_dyn_var('U', fh_ini, 'ncol', var3d) - atm(mytile)%ua(is:ie,js:je,1:nlev) =var3d(is:ie,js:je,1:nlev) - else - call endrun(trim(subname)//': U not found') - end if - - m_cnst=1 - if (dyn_field_exists(fh_ini, 'Q')) then - call read_dyn_var('Q', fh_ini, 'ncol', var3d) - atm(mytile)%q(is:ie,js:je,1:nlev,m_cnst) = var3d(is:ie,js:je,1:nlev) - else - call endrun(trim(subname)//': Q not found') - end if - - ! Read in or cold-initialize all the tracer fields - ! Copy tracers defined on unstructured grid onto distributed FFSL grid - ! Make sure tracers have at least minimum value - - do m_cnst = 2, pcnst - m_cnst_ffsl=qsize_tracer_idx_cam2dyn(m_cnst) - found = .false. - - if(cnst_read_iv(m_cnst)) then - found = dyn_field_exists(fh_ini, trim(cnst_name(m_cnst)), & - required=.false.) - end if - - if(found) then - call read_dyn_var(trim(cnst_name(m_cnst)), fh_ini, 'ncol', var3d) - atm(mytile)%q(is:ie,js:je,1:nlev,m_cnst_ffsl) = var3d(is:ie,js:je,1:nlev) - else - dbuf3=0._r8 - if (masterproc) write(iulog,*)'Missing ',trim(cnst_name(m_cnst)),' constituent number', & - m_cnst,size(latvals_rad),size(dbuf3) - if (masterproc) write(iulog,*)'Initializing ',trim(cnst_name(m_cnst)),'fv3 constituent number ',& - m_cnst_ffsl,' to default' - call cnst_init_default(m_cnst, latvals_rad, lonvals_rad, dbuf3) - do k=1, nlev - indx = 1 - do j = js, je - do i = is, ie - indx=mylindex(i,j) - atm(mytile)%q(i,j, k, m_cnst_ffsl) = max(qmin(m_cnst),dbuf3(indx,k,1)) - end do - end do - end do - end if - - end do ! pcnst - - call a2d3djt(atm(mytile)%ua, atm(mytile)%va, atm(mytile)%u, atm(mytile)%v, is, ie, js, je, & - isd, ied, jsd, jed, npx,npy, nlev, atm(mytile)%gridstruct, atm(mytile)%domain) - - ! Put the error handling back the way it was - call pio_seterrorhandling(fh_ini, err_handling) - - deallocate(dbuf3) - deallocate(var2d) - deallocate(var3d) - - end if ! analytic_ic_active - - deallocate(latvals_rad) - deallocate(lonvals_rad) - deallocate(glob_ind) - - ! If analytic ICs are being used, we allow constituents in an initial - ! file to overwrite mixing ratios set by the default constituent initialization - ! except for the water species. - - call pio_seterrorhandling(fh_ini, pio_bcast_error, err_handling) - allocate(var3d(is:ie,js:je,nlev)) - do m_cnst = 1, pcnst - m_cnst_ffsl=qsize_tracer_idx_cam2dyn(m_cnst) - - if (analytic_ic_active() .and. cnst_is_a_water_species(cnst_name(m_cnst))) cycle - - found = .false. - - if(cnst_read_iv(m_cnst)) then - found = dyn_field_exists(fh_ini, trim(cnst_name(m_cnst)), & - required=.false.) - end if - - if(found) then - call read_dyn_var(trim(cnst_name(m_cnst)), fh_ini, 'ncol', var3d) - atm(mytile)%q(is:ie,js:je,1:nlev,m_cnst_ffsl) = var3d(is:ie,js:je,1:nlev) - end if - end do - deallocate(var3d) - ! Put the error handling back the way it was - call pio_seterrorhandling(fh_ini, err_handling) - - ! If a topo file is specified use it. This will overwrite the PHIS set by the - ! analytic IC option. - ! - ! If using the physics grid then the topo file will be on that grid since its - ! contents are primarily for the physics parameterizations, and the values of - ! PHIS should be consistent with the values of sub-grid variability (e.g., SGH) - ! which are computed on the physics grid. - if (associated(fh_topo)) then - - ! We need to be able to see the PIO return values - call pio_seterrorhandling(fh_topo, PIO_BCAST_ERROR, pio_errtype) - - fieldname = 'PHIS' - if (dyn_field_exists(fh_topo, trim(fieldname))) then - call read_dyn_var(trim(fieldname), fh_topo, 'ncol', phis_tmp) - else - call endrun(trim(subname)//': ERROR: Could not find PHIS field on input datafile') - end if - - ! Put the error handling back the way it was - call pio_seterrorhandling(fh_topo, pio_errtype) - end if - - ! Process phis_tmp - atm(mytile)%phis = 0.0_r8 - do j = js, je - do i = is, ie - indx = mylindex(i,j) - atm(mytile)%phis(i,j) = phis_tmp(indx,1) - end do - end do - ! - ! initialize delp (and possibly mixing ratios) from IC fields. - ! - if (inic_wet) then - ! - ! /delp/mix ratios/ps consistent with fv3 airmass (dry+all wet tracers) assuming IC is CAM phys airmass (dry+q only) - ! - allocate(pstmp(isd:ied,jsd:jed)) - pstmp(:,:) = atm(mytile)%ps(:,:) - atm(mytile)%ps(:,:)=hyai(1)*ps0 - num_wet_species=thermodynamic_active_species_num-dry_air_species_num - do k=1,pver - do j = js, je - do i = is, ie - ! this delp is (dry+vap) using the moist ps read in. - Atm(mytile)%delp(i, j, k) = (((hyai(k+1) - hyai(k))*ps0) + & - ((hybi(k+1) - hybi(k))*pstmp(i,j))) - delpdry=Atm(mytile)%delp(i,j,k)*(1.0_r8-Atm(mytile)%q(i,j,k,1)) - do m=1,pcnst - m_ffsl=qsize_tracer_idx_cam2dyn(m) - if (cnst_type(m) == 'wet') then - tracermass(m_ffsl)=Atm(mytile)%delp(i,j,k)*Atm(mytile)%q(i,j,k,m_ffsl) - else - tracermass(m_ffsl)=delpdry*Atm(mytile)%q(i,j,k,m_ffsl) - end if - end do - fv3_totwatermass=sum(tracermass(thermodynamic_active_species_idx_dycore(1:num_wet_species))) - fv3_airmass = delpdry + fv3_totwatermass - Atm(mytile)%delp(i,j,k) = fv3_airmass - Atm(mytile)%q(i,j,k,1:pcnst) = tracermass(1:pcnst)/fv3_airmass - Atm(mytile)%ps(i,j)=Atm(mytile)%ps(i,j)+Atm(mytile)%delp(i, j, k) - end do - end do - end do - deallocate(pstmp) - else - ! - ! Make delp/mix ratios/ps consistent with fv3 airmass (dry+all wet constituents) assuming IC based off dry airmass - ! - allocate(pstmp(isd:ied,jsd:jed)) - pstmp(:,:) = atm(mytile)%ps(:,:) - atm(mytile)%ps(:,:)=hyai(1)*ps0 - num_wet_species=thermodynamic_active_species_num-dry_air_species_num - do k=1,pver - do j = js, je - do i = is, ie - ! this delp is assumed dry. - delpdry = (((hyai(k+1) - hyai(k))*ps0) + & - ((hybi(k+1) - hybi(k))*pstmp(i,j))) - do m=1,pcnst - tracermass(m)=delpdry*Atm(mytile)%q(i,j,k,m) - end do - fv3_totwatermass=sum(tracermass(thermodynamic_active_species_idx_dycore(1:num_wet_species))) - fv3_airmass = delpdry + fv3_totwatermass - Atm(mytile)%delp(i,j,k) = fv3_airmass - Atm(mytile)%q(i,j,k,1:pcnst) = tracermass(1:pcnst)/fv3_airmass - Atm(mytile)%ps(i,j)=Atm(mytile)%ps(i,j)+Atm(mytile)%delp(i, j, k) - ! check new tracermass - do m=1,pcnst - m_ffsl=qsize_tracer_idx_cam2dyn(m) - reldif=(Atm(mytile)%delp(i,j,k)*Atm(mytile)%q(i,j,k,m_ffsl)-tracermass(m_ffsl))/ & - tracermass(m_ffsl) - if (reldif > abs(1.0e-15_r8)) & - write(iulog,*)'mass inconsistency new, old, relative error=',iam,cnst_name(m), & - Atm(mytile)%delp(i,j,k)*Atm(mytile)%q(i,j,k,m_ffsl),tracermass(m_ffsl),reldif - end do - end do - end do - end do - deallocate(pstmp) - end if - ! - ! If scale_dry_air_mass > 0.0 then scale dry air mass to scale_dry_air_mass global average dry pressure - ! If scale_dry_air_mass = 0.0 don't scale - if (scale_dry_air_mass > 0.0_r8) then - call set_dry_mass(Atm, scale_dry_air_mass) - end if - - - !$omp parallel do private(i, j) - do j=js,je - do i=is,ie - Atm(mytile)%pe(i,1,j) = Atm(mytile)%ptop - Atm(mytile)%pk(i,j,1) = Atm(mytile)%ptop ** kappa - Atm(mytile)%peln(i,1,j) = log(Atm(mytile)%ptop ) - enddo - enddo - -!$omp parallel do private(i,j,k) - do j=js,je - do k=1,pver - do i=is,ie - Atm(mytile)%pe(i,k+1,j) = Atm(mytile)%pe(i,k,j) + Atm(mytile)%delp(i,j,k) - enddo - enddo - enddo - -!$omp parallel do private(i,j,k) - do j=js,je - do k=1,pver - do i=is,ie - Atm(mytile)%pk(i,j,k+1)= Atm(mytile)%pe(i,k+1,j) ** kappa - Atm(mytile)%peln(i,k+1,j) = log(Atm(mytile)%pe(i,k+1,j)) - Atm(mytile)%pkz(i,j,k) = (Atm(mytile)%pk(i,j,k+1)-Atm(mytile)%pk(i,j,k)) / & - (kappa*(Atm(mytile)%peln(i,k+1,j)-Atm(mytile)%peln(i,k,j))) - enddo - enddo - enddo -!! Initialize non hydrostatic variables if needed - if (.not. Atm(mytile)%flagstruct%hydrostatic) then - do k=1,nlev - do j=js,je - do i=is,ie - Atm(mytile)%w ( i,j,k ) = 0._r8 - Atm(mytile)%delz ( i,j,k ) = -rdgas/gravit*Atm(mytile)%pt( i,j,k ) * & - ( Atm(mytile)%peln( i,k+1,j ) - Atm(mytile)%peln( i,k,j ) ) - enddo - enddo - enddo - end if - - ! once we've read or initialized all the fields we call update_domains to - ! update the halo regions - - call mpp_update_domains( Atm(mytile)%phis, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%ps, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%u,atm(mytile)%v,Atm(mytile)%domain,gridtype=DGRID_NE,complete=.true. ) - call mpp_update_domains( atm(mytile)%pt, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%delp, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%q, Atm(mytile)%domain ) - - ! Cleanup - deallocate(phis_tmp) - -end subroutine read_inidat - -!======================================================================= - - subroutine calc_tot_energy_dynamics(atm,suffix) - use physconst, only: gravit, cpair, rearth, omega - use air_composition, only: thermodynamic_active_species_num,thermodynamic_active_species_idx_dycore - use air_composition, only: thermodynamic_active_species_cp,thermodynamic_active_species_cv,dry_air_species_num - use cam_history, only: outfld, hist_fld_active - use constituents, only: cnst_get_ind - use dimensions_mod, only: nlev - use fv_mp_mod, only: ng - !------------------------------Arguments-------------------------------- - - type(fv_atmos_type), pointer, intent(in) :: Atm(:) - character(len=*) , intent(in) :: suffix ! suffix for "outfld" names - - !---------------------------Local storage------------------------------- - - real(kind=r8), allocatable, dimension(:,:) :: se, &! Dry Static energy (J/m2) - ke, &! kinetic energy (J/m2) - ps_local ! ps temp based on CAM or FV3 airmass - real(kind=r8), allocatable, dimension(:,:) :: wv,wl,wi,wr,ws,wg ! col integ constiuents(kg/m2) - real(kind=r8), allocatable, dimension(:,:) :: tt ! column integrated test tracer (kg/m2) - real(kind=r8), allocatable, dimension(:,:,:) :: dp,delpograv - real(kind=r8) :: se_tmp, dpdry - real(kind=r8) :: ke_tmp - real(kind=r8) :: wv_tmp,wl_tmp,wi_tmp,wr_tmp,ws_tmp,wg_tmp - real(kind=r8) :: tt_tmp - - ! - ! global axial angular momentum (AAM) can be separated into one part (mr) - ! associated with the relative motion of the atmosphere with respect to the planet surface - ! (also known as wind AAM) and another part (mo) associated with the angular velocity OMEGA - ! (2*pi/d, where d is the length of the day) of the planet (also known as mass AAM) - ! - real(kind=r8), allocatable, dimension(:,:) :: mr ! wind AAM - real(kind=r8), allocatable, dimension(:,:) :: mo ! mass AAM - real(kind=r8) :: mr_cnst, mo_cnst, cos_lat, mr_tmp, mo_tmp - - real(kind=r8) :: se_glob, ke_glob, wv_glob, wl_glob, wi_glob, & - wr_glob, ws_glob, wg_glob, tt_glob, mr_glob, mo_glob - - integer :: i,j,k,nq,idim,m_cnst_ffsl - integer :: ixcldice, ixcldliq, ixtt,ixcldliq_ffsl,ixcldice_ffsl ! CLDICE, CLDLIQ and test tracer indices - integer :: ixrain, ixsnow, ixgraupel,ixrain_ffsl, ixsnow_ffsl, ixgraupel_ffsl - character(len=16) :: se_name,ke_name,wv_name,wl_name, & - wi_name,wr_name,ws_name,wg_name,tt_name,mo_name,mr_name - - integer :: is,ie,js,je,isd,ied,jsd,jed - logical :: printglobals = .false. - !----------------------------------------------------------------------- - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - isd = Atm(mytile)%bd%isd - ied = Atm(mytile)%bd%ied - jsd = Atm(mytile)%bd%jsd - jed = Atm(mytile)%bd%jed - - se_glob = 0._r8 - ke_glob = 0._r8 - wv_glob = 0._r8 - wl_glob = 0._r8 - wi_glob = 0._r8 - wr_glob = 0._r8 - ws_glob = 0._r8 - wg_glob = 0._r8 - tt_glob = 0._r8 - mr_glob = 0._r8 - mo_glob = 0._r8 - - allocate(se(is:ie,js:je)) - allocate(ke(is:ie,js:je)) - allocate(wv(is:ie,js:je)) - allocate(wl(is:ie,js:je)) - allocate(wi(is:ie,js:je)) - allocate(wr(is:ie,js:je)) - allocate(ws(is:ie,js:je)) - allocate(wg(is:ie,js:je)) - allocate(tt(is:ie,js:je)) - allocate(mr(is:ie,js:je)) - allocate(mo(is:ie,js:je)) - allocate(dp(is:ie,js:je,nlev)) - allocate(delpograv(is:ie,js:je,nlev)) - allocate(ps_local(is:ie,js:je)) - - se_name = 'SE_' //trim(suffix) - ke_name = 'KE_' //trim(suffix) - wv_name = 'WV_' //trim(suffix) - wl_name = 'WL_' //trim(suffix) - wi_name = 'WI_' //trim(suffix) - wr_name = 'WR_' //trim(suffix) - ws_name = 'WS_' //trim(suffix) - wg_name = 'WG_' //trim(suffix) - tt_name = 'TT_' //trim(suffix) - - - if ( hist_fld_active(se_name).or.hist_fld_active(ke_name).or. & - hist_fld_active(wv_name).or.hist_fld_active(wl_name).or. & - hist_fld_active(wi_name).or.hist_fld_active(wr_name).or. & - hist_fld_active(ws_name).or.hist_fld_active(wg_name).or. & - hist_fld_active(tt_name)) then - if (thermodynamic_active_species_num-dry_air_species_num > 1) then - call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) - call cnst_get_ind('CLDICE', ixcldice, abort=.false.) - call cnst_get_ind('RAINQM', ixrain, abort=.false.) - call cnst_get_ind('SNOWQM', ixsnow, abort=.false.) - call cnst_get_ind('GRAUQM', ixgraupel, abort=.false.) - else - ixcldliq = -1 - ixcldice = -1 - ixrain = -1 - ixsnow = -1 - ixgraupel = -1 - end if - - call cnst_get_ind('TT_LW', ixtt, abort=.false.) - - ! - ! Compute frozen static energy in 3 parts: KE, SE, and energy associated with vapor and liquid - ! - - se = 0.0_r8 - ke = 0.0_r8 - wv = 0.0_r8 - wl = 0.0_r8 - wi = 0.0_r8 - wr = 0.0_r8 - ws = 0.0_r8 - wg = 0.0_r8 - tt = 0.0_r8 - - delpograv(is:ie,js:je,1:nlev) = Atm(mytile)%delp(is:ie,js:je,1:nlev)/gravit ! temporary - - ! - ! Calculate Energy, CAM or FV3 based on fv3_lcp_moist and fv3_lcv_moist - ! - - - do k = 1, nlev - do j=js,je - do i = is, ie - ! initialize dp with delp - dp(i,j,k) = Atm(mytile)%delp(i,j,k) - ! - ! if neither fv3_lcp_moist and fv3_lcv_moist is set then - ! use cam definition of internal energy - ! adjust dp to be consistent with CAM physics air mass (only water vapor and dry air in pressure) - if ((.not.fv3_lcp_moist).and.(.not.fv3_lcv_moist)) then - if (thermodynamic_active_species_num-dry_air_species_num > 1) then - ! adjust dp to include just dry + vap to use below - do nq=2,thermodynamic_active_species_num-dry_air_species_num - m_cnst_ffsl=thermodynamic_active_species_idx_dycore(nq) - dp(i,j,k) = dp(i,j,k) - & - Atm(mytile)%delp(i,j,k)*Atm(mytile)%q(i,j,k,m_cnst_ffsl) - end do - end if - se_tmp = cpair*Atm(mytile)%pt(i,j,k)*dp(i,j,k)/gravit - else - ! if either fv3_lcp_moist or fv3_lcv_moist is set then - ! use all condensates in calculation of energy and dp - ! Start with energy of dry air and add energy of condensates - dpdry = Atm(mytile)%delp(i,j,k) - do nq=1,thermodynamic_active_species_num-dry_air_species_num - m_cnst_ffsl=thermodynamic_active_species_idx_dycore(nq) - dpdry = dpdry - Atm(mytile)%delp(i,j,k)*Atm(mytile)%q(i,j,k,nq) - end do - se_tmp = cpair*dpdry - do nq=1,thermodynamic_active_species_num-dry_air_species_num - m_cnst_ffsl=thermodynamic_active_species_idx_dycore(nq) - if (fv3_lcp_moist) then - se_tmp = se_tmp + & - thermodynamic_active_species_cp(nq)*Atm(mytile)%q(i,j,k,m_cnst_ffsl) * & - Atm(mytile)%delp(i,j,k) - end if - if (fv3_lcv_moist) then - se_tmp = se_tmp + & - thermodynamic_active_species_cv(nq)*Atm(mytile)%q(i,j,k,m_cnst_ffsl) * & - Atm(mytile)%delp(i,j,k) - end if - end do - se_tmp = se_tmp*Atm(mytile)%pt(i,j,k)/gravit - end if - ke_tmp = 0.5_r8*(Atm(mytile)%va(i,j,k)**2+ Atm(mytile)%ua(i,j,k)**2)*dp(i,j,k)/gravit - wv_tmp = Atm(mytile)%q(i,j,k,1)*delpograv(i,j,k) - - se(i,j) = se(i,j) + se_tmp - ke(i,j) = ke(i,j) + ke_tmp - wv(i,j) = wv(i,j) + wv_tmp - end do - end do - end do - - do j=js,je - do i = is,ie - ps_local(i,j) = Atm(mytile)%ptop+sum(dp(i,j,:)) - end do - end do - - do j=js,je - do i = is,ie - se(i,j) = se(i,j) + Atm(mytile)%phis(i,j)*ps_local(i,j)/gravit - end do - end do - - ! Don't require cloud liq/ice to be present. Allows for adiabatic/ideal phys. - - if (ixcldliq > 1) then - ixcldliq_ffsl = qsize_tracer_idx_cam2dyn(ixcldliq) - do k = 1, nlev - do j = js, je - do i = is, ie - wl_tmp = Atm(mytile)%q(i,j,k,ixcldliq_ffsl)*delpograv(i,j,k) - wl (i,j) = wl(i,j) + wl_tmp - end do - end do - end do - end if - - if (ixcldice > 1) then - ixcldice_ffsl = qsize_tracer_idx_cam2dyn(ixcldice) - do k = 1, nlev - do j = js, je - do i = is, ie - wi_tmp = Atm(mytile)%q(i,j,k,ixcldice_ffsl)*delpograv(i,j,k) - wi(i,j) = wi(i,j) + wi_tmp - end do - end do - end do - end if - - if (ixrain > 1) then - ixrain_ffsl = qsize_tracer_idx_cam2dyn(ixrain) - do k = 1, nlev - do j = js, je - do i = is, ie - wr_tmp = Atm(mytile)%q(i,j,k,ixrain_ffsl)*delpograv(i,j,k) - wr (i,j) = wr(i,j) + wr_tmp - end do - end do - end do - end if - - if (ixsnow > 1) then - ixsnow_ffsl = qsize_tracer_idx_cam2dyn(ixsnow) - do k = 1, nlev - do j = js, je - do i = is, ie - ws_tmp = Atm(mytile)%q(i,j,k,ixsnow_ffsl)*delpograv(i,j,k) - ws(i,j) = ws(i,j) + ws_tmp - end do - end do - end do - end if - - if (ixgraupel > 1) then - ixgraupel_ffsl = qsize_tracer_idx_cam2dyn(ixgraupel) - do k = 1, nlev - do j = js, je - do i = is, ie - wg_tmp = Atm(mytile)%q(i,j,k,ixgraupel_ffsl)*delpograv(i,j,k) - wg(i,j) = wg(i,j) + wg_tmp - end do - end do - end do - end if - - - if (ixtt > 1) then - do k = 1, nlev - do j = js, je - do i = is, ie - tt_tmp = Atm(mytile)%q(i,j,k,ixtt)*delpograv(i,j,k) - tt (i,j) = tt(i,j) + tt_tmp - end do - end do - end do - end if - idim=ie-is+1 - do j=js,je - ! Output energy diagnostics - call outfld(se_name ,se(:,j) ,idim, j) - call outfld(ke_name ,ke(:,j) ,idim, j) - call outfld(wv_name ,wv(:,j) ,idim, j) - call outfld(wl_name ,wl(:,j) ,idim, j) - call outfld(wi_name ,wi(:,j) ,idim, j) - call outfld(wr_name ,wr(:,j) ,idim, j) - call outfld(ws_name ,ws(:,j) ,idim, j) - call outfld(wg_name ,wg(:,j) ,idim, j) - if (ixtt > 1) call outfld(tt_name ,tt(:,j) ,idim, j) - end do - - if (printglobals) then - se_glob=g_sum(Atm(mytile)%domain, se(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - ke_glob=g_sum(Atm(mytile)%domain, ke(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - wv_glob=g_sum(Atm(mytile)%domain, wv(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - wl_glob=g_sum(Atm(mytile)%domain, wl(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - wi_glob=g_sum(Atm(mytile)%domain, wi(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - wr_glob=g_sum(Atm(mytile)%domain, wr(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - ws_glob=g_sum(Atm(mytile)%domain, ws(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - wg_glob=g_sum(Atm(mytile)%domain, wg(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - if (ixtt > 1) & - tt_glob=g_sum(Atm(mytile)%domain, tt(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - if (masterproc) then - - write(iulog, '(a,e25.17)') 'static energy se_'//trim(suffix)//') = ',se_glob - write(iulog, '(a,e25.17)') 'kinetic energy ke_'//trim(suffix)//') = ',ke_glob - write(iulog, '(a,e25.17)') 'total energy se_plus_ke_'//trim(suffix)//') = ',(ke_glob+se_glob) - write(iulog, '(a,e25.17)') 'integrated vapor wv_'//trim(suffix)//' = ',wv_glob - write(iulog, '(a,e25.17)') 'integrated liquid wl_'//trim(suffix)//' = ',wl_glob - write(iulog, '(a,e25.17)') 'integrated ice wi_'//trim(suffix)//' = ',wi_glob - write(iulog, '(a,e25.17)') 'integrated liquid rain wr_'//trim(suffix)//' = ',wr_glob - write(iulog, '(a,e25.17)') 'integrated liquid snow ws_'//trim(suffix)//' = ',ws_glob - write(iulog, '(a,e25.17)') 'integrated graupel wg_'//trim(suffix)//' = ',wg_glob - if (ixtt > 1) write(iulog, '(a,e25.17)') & - 'global column integrated test tracer tt_'//trim(suffix)//' = ',tt_glob - end if - end if - end if - - ! - ! Axial angular momentum diagnostics - ! - ! Code follows - ! - ! Lauritzen et al., (2014): Held-Suarez simulations with the Community Atmosphere Model - ! Spectral Element (CAM-SE) dynamical core: A global axial angularmomentum analysis using Eulerian - ! and floating Lagrangian vertical coordinates. J. Adv. Model. Earth Syst. 6,129-140, - ! doi:10.1002/2013MS000268 - ! - ! MR is equation (6) without \Delta A and sum over areas (areas are in units of radians**2) - ! MO is equation (7) without \Delta A and sum over areas (areas are in units of radians**2) - ! - mr_name = 'MR_' //trim(suffix) - mo_name = 'MO_' //trim(suffix) - - if ( hist_fld_active(mr_name).or.hist_fld_active(mo_name)) then - - - - mr_cnst = rearth**3/gravit - mo_cnst = omega*rearth**4/gravit - mr = 0.0_r8 - mo = 0.0_r8 - do k = 1, nlev - do j=js,je - do i = is,ie - cos_lat = cos(Atm(mytile)%gridstruct%agrid_64(i,j,2)) - mr_tmp = mr_cnst*Atm(mytile)%ua(i,j,k)*Atm(mytile)%delp(i,j,k)*cos_lat - mo_tmp = mo_cnst*Atm(mytile)%delp(i,j,k)*cos_lat**2 - - mr (i,j) = mr(i,j) + mr_tmp - mo (i,j) = mo(i,j) + mo_tmp - end do - end do - end do - do j=js,je - call outfld(mr_name ,mr(is:ie,j) ,idim,j) - call outfld(mo_name ,mo(is:ie,j) ,idim,j) - end do - - if (printglobals) then - mr_glob=g_sum(Atm(mytile)%domain, mr(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - mo_glob=g_sum(Atm(mytile)%domain, mo(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - if (masterproc) then - write(iulog, '(a,e25.17)') 'integrated wind AAM '//trim(mr_name)//' = ',mr_glob - write(iulog, '(a,e25.17)') 'integrated mass AAM '//trim(mo_name)//' = ',mo_glob - end if - end if - end if - - deallocate(ps_local) - deallocate(dp) - deallocate(delpograv) - deallocate(se) - deallocate(ke) - deallocate(wv) - deallocate(wl) - deallocate(wi) - deallocate(wr) - deallocate(ws) - deallocate(wg) - deallocate(tt) - deallocate(mr) - deallocate(mo) - end subroutine calc_tot_energy_dynamics - -!======================================================================================== - -logical function dyn_field_exists(fh, fieldname, required) - - use pio, only: file_desc_t, var_desc_t, PIO_inq_varid - use pio, only: PIO_NOERR - - ! Arguments - type(file_desc_t), intent(in) :: fh - character(len=*), intent(in) :: fieldname - logical, optional, intent(in) :: required - - ! Local variables - logical :: found - logical :: field_required - integer :: ret - type(var_desc_t) :: varid - character(len=128) :: errormsg - !-------------------------------------------------------------------------- - - if (present(required)) then - field_required = required - else - field_required = .true. - end if - - ret = PIO_inq_varid(fh, trim(fieldname), varid) - found = (ret == PIO_NOERR) - if (.not. found) then - if (field_required) then - write(errormsg, *) trim(fieldname),' was not present in the input file.' - call endrun('DYN_FIELD_EXISTS: '//errormsg) - end if - end if - - dyn_field_exists = found - -end function dyn_field_exists - -!======================================================================================== - - subroutine read_dyn_field_2d(fieldname, fh, dimname, buffer) - use pio, only: file_desc_t - use ncdio_atm, only: infld - - ! Dummy arguments - character(len=*), intent(in) :: fieldname - type(file_desc_t), intent(inout) :: fh - character(len=*), intent(in) :: dimname - real(r8), intent(inout) :: buffer(:, :) - - ! Local variables - logical :: found - !-------------------------------------------------------------------------- - - buffer = 0.0_r8 - call infld(trim(fieldname), fh, dimname, 1, ldof_size, 1, 1, buffer, & - found, gridname=ini_grid_name) - if(.not. found) then - call endrun('READ_DYN_FIELD_2D: Could not find '//trim(fieldname)//' field on input datafile') - end if - - ! This code allows use of compiler option to set uninitialized values - ! to NaN. In that case infld can return NaNs where the element ini_grid_name points - ! are not "unique columns" - where (isnan(buffer)) buffer = 0.0_r8 - - end subroutine read_dyn_field_2d - -!======================================================================================== - - subroutine read_dyn_field_3d(fieldname, fh, dimname, buffer) - use pio, only: file_desc_t - use ncdio_atm, only: infld - - ! Dummy arguments - character(len=*), intent(in) :: fieldname - type(file_desc_t), intent(inout) :: fh - character(len=*), intent(in) :: dimname - real(r8), intent(inout) :: buffer(:,:,:) - - ! Local variables - logical :: found - !-------------------------------------------------------------------------- - - buffer = 0.0_r8 - call infld(fieldname, fh,dimname, 'lev', 1, ldof_size, 1, pver, & - 1, 1, buffer, found, gridname=ini_grid_name) - if(.not. found) then - call endrun('READ_DYN_FIELD_3D: Could not find '//trim(fieldname)//' field on input datafile') - end if - - ! This code allows use of compiler option to set uninitialized values - ! to NaN. In that case infld can return NaNs where the element ini_grid_name points - ! are not "unique columns" - where (isnan(buffer)) buffer = 0.0_r8 - - end subroutine read_dyn_field_3d - -!========================================================================================= - -subroutine write_dyn_var(field,outfld_name,bd) - - use cam_history, only: outfld - - ! Arguments - type(fv_grid_bounds_type), intent(in) :: bd - real(r8), intent(in) :: field(bd%is:bd%ie,bd%js:bd%je) - character(len=*) , intent(in) :: outfld_name ! suffix for "outfld" names - - ! local variables - integer :: idim, j - - !---------------------------------------------------------------------------- - idim=bd%ie-bd%is+1 - do j=bd%js,bd%je - ! Output energy diagnostics - call outfld(trim(outfld_name) ,field(bd%is:bd%ie,j) ,idim, j) - end do - -end subroutine write_dyn_var - -!========================================================================================= - -subroutine set_dry_mass(atm,fixed_global_ave_dry_ps) - - !---------------------------------------------------------------------------- - - use constituents, only: pcnst, qmin - use cam_logfile, only: iulog - use hycoef, only: hyai, hybi, ps0 - use dimensions_mod, only: nlev - use dyn_grid, only: mytile - use air_composition, only: thermodynamic_active_species_num,thermodynamic_active_species_idx_dycore,dry_air_species_num - - ! Arguments - type (fv_atmos_type), intent(in), pointer :: Atm(:) - real (kind=r8), intent(in) :: fixed_global_ave_dry_ps - - ! local - real (kind=r8) :: global_ave_ps_inic,global_ave_dryps_inic,global_ave_dryps_scaled, & - global_ave_ps_new,global_ave_dryps_new - real (r8), allocatable, dimension(:,:) :: psdry, psdry_scaled, psdry_new - real (r8), allocatable, dimension(:,:,:) :: factor, delpwet, delpdry, newdelp - integer :: i, j ,k, m,is,ie,js,je - integer :: num_wet_species ! first tracers in FV3 tracer array - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - allocate(factor(is:ie,js:je,nlev)) - allocate(delpdry(is:ie,js:je,nlev)) - allocate(delpwet(is:ie,js:je,nlev)) - allocate(newdelp(is:ie,js:je,nlev)) - allocate(psdry(is:ie,js:je)) - allocate(psdry_scaled(is:ie,js:je)) - allocate(psdry_new(is:ie,js:je)) - - - if (fixed_global_ave_dry_ps == 0) return; - - ! get_global_ave_surface_pressure - must use bitwise sum (reproducable) - global_ave_ps_inic=g_sum(Atm(mytile)%domain, Atm(mytile)%ps(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - - num_wet_species=thermodynamic_active_species_num-dry_air_species_num - do k=1,pver - do j = js, je - do i = is, ie - delpdry(i,j,k)=Atm(mytile)%delp(i,j,k) * (1.0_r8 - & - sum(Atm(mytile)%q(i,j,k,thermodynamic_active_species_idx_dycore(1:num_wet_species)))) - delpwet(i,j,k)=Atm(mytile)%delp(i,j,k)-delpdry(i,j,k) - end do - end do - end do - ! - ! get psdry and scale it - ! - do j = js, je - do i = is, ie - psdry(i,j) = hyai(1)*ps0 + sum(delpdry(i,j,:)) - end do - end do - - global_ave_dryps_inic=g_sum(Atm(mytile)%domain, psdry(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - - psdry_scaled = psdry*(fixed_global_ave_dry_ps/global_ave_dryps_inic) - - global_ave_dryps_scaled=g_sum(Atm(mytile)%domain, psdry_scaled(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - - !use adjusted psdry to calculate new dp_dry throughout atmosphere - do k=1,pver - do j = js, je - do i = is, ie - delpdry(i,j,k)=(hyai(k+1)-hyai(k))*ps0+& - (hybi(k+1)-hybi(k))*psdry_scaled(i,j) - ! new dp is adjusted dp + total watermass - newdelp(i,j,k)=(delpdry(i,j,k)+delpwet(i,j,k)) - ! factor to conserve mass once using the new dp - factor(i,j,k)=Atm(mytile)%delp(i,j,k)/newdelp(i,j,k) - Atm(mytile)%delp(i,j,k)=newdelp(i,j,k) - end do - end do - end do - ! - ! all tracers wet in fv3 so conserve initial condition mass of 'wet' tracers (following se prim_set_dry) - ! - do m=1,pcnst - do k=1,pver - do j = js, je - do i = is, ie - Atm(mytile)%q(i,j,k,m)=Atm(mytile)%q(i,j,k,m)*factor(i,j,k) - Atm(mytile)%q(i,j,k,m)=max(qmin(m),Atm(mytile)%q(i,j,k,m)) - end do - end do - end do - end do - - do j = js, je - do i = is, ie - Atm(mytile)%ps(i,j)=hyai(1)*ps0+sum(Atm(mytile)%delp(i, j, :)) - psdry_new(i,j)=hyai(1)*ps0+sum(delpdry(i, j, :)) - end do - end do - global_ave_ps_new= g_sum(Atm(mytile)%domain, Atm(mytile)%ps(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - global_ave_dryps_new=g_sum(Atm(mytile)%domain, psdry_new(is:ie,js:je), is, ie, js, je, & - Atm(mytile)%ng, Atm(mytile)%gridstruct%area_64, 1, .true.) - - if (masterproc) then - write (iulog,*) "-------------------------- set_dry_mass---------------------------------------------" - write (iulog,*) "Scaling dry surface pressure to global average of = ",& - fixed_global_ave_dry_ps/100.0_r8,"hPa" - write (iulog,*) "Average surface pressure in initial condition = ", & - global_ave_ps_inic/100.0_r8,"hPa" - write (iulog,*) "Average dry surface pressure in initial condition = ",& - global_ave_dryps_inic/100.0_r8,"hPa" - write (iulog,*) "Average surface pressure after scaling = ",global_ave_ps_new/100.0_r8,"hPa" - write (iulog,*) "Average dry surface pressure after scaling = ",global_ave_dryps_new/100.0_r8,"hPa" - write (iulog,*) "Change in surface pressure = ",& - global_ave_ps_new-global_ave_ps_inic,"Pa" - write (iulog,*) "Change in dry surface pressure = ",& - global_ave_dryps_new-global_ave_dryps_inic,"Pa" - write (iulog,*) "Mixing ratios have been scaled so that total mass of tracer is conserved" - write (iulog,*) "Total precipitable water before scaling = ", & - (global_ave_ps_inic-global_ave_dryps_inic)/gravit, '(kg/m**2)' - write (iulog,*) "Total precipitable water after scaling = ", & - (global_ave_ps_new-global_ave_dryps_new)/gravit, '(kg/m**2)' - endif - - deallocate(factor) - deallocate(delpdry) - deallocate(delpwet) - deallocate(newdelp) - deallocate(psdry) - deallocate(psdry_scaled) - deallocate(psdry_new) - -end subroutine set_dry_mass -!========================================================================================= - -subroutine a2d3djt(ua, va, u, v, is, ie, js, je, isd, ied, jsd, jed, npx,npy, nlev, gridstruct, domain) - -! This routine interpolates cell centered a-grid winds to d-grid (cell edges) - - use mpp_domains_mod, only: mpp_update_domains, DGRID_NE - use fv_arrays_mod, only: fv_grid_type - - ! arguments - integer, intent(in) :: is, ie, js, je - integer, intent(in) :: isd, ied, jsd, jed - integer, intent(in) :: npx,npy, nlev - real(r8), intent(inout), dimension(isd:ied, jsd:jed+1,nlev) :: u - real(r8), intent(inout), dimension(isd:ied+1,jsd:jed ,nlev) :: v - real(r8), intent(inout), dimension(isd:ied,jsd:jed,nlev) :: ua, va - type(fv_grid_type), intent(in), target :: gridstruct - type(domain2d), intent(inout) :: domain - - ! local: - real(r8), dimension(is-1:ie+1,js-1:je+1,3) :: v3 - real(r8), dimension(is-1:ie+1,js:je+1,3) :: ue ! 3D winds at edges - real(r8), dimension(is:ie+1,js-1:je+1, 3) :: ve ! 3D winds at edges - real(r8), dimension(is:ie) :: ut1, ut2, ut3 - real(r8), dimension(js:je) :: vt1, vt2, vt3 - integer :: i, j, k, im2, jm2 - - real(r8), pointer, dimension(:,:,:) :: vlon, vlat - real(r8), pointer, dimension(:,:,:,:) :: es, ew - real(r8), pointer, dimension(:) :: edge_vect_w, edge_vect_e, edge_vect_s, edge_vect_n - - es => gridstruct%es - ew => gridstruct%ew - vlon => gridstruct%vlon - vlat => gridstruct%vlat - - edge_vect_w => gridstruct%edge_vect_w - edge_vect_e => gridstruct%edge_vect_e - edge_vect_s => gridstruct%edge_vect_s - edge_vect_n => gridstruct%edge_vect_n - - call mpp_update_domains(ua, domain, complete=.false.) - call mpp_update_domains(va, domain, complete=.true.) - - im2 = (npx-1)/2 - jm2 = (npy-1)/2 - -!$OMP parallel do default(none) shared(is,ie,js,je,nlev,gridstruct,u,ua,v,va, & -!$OMP vlon,vlat,jm2,edge_vect_w,npx,edge_vect_e,im2, & -!$OMP edge_vect_s,npy,edge_vect_n,es,ew) & -!$OMP private(i,j,k,ut1, ut2, ut3, vt1, vt2, vt3, ue, ve, v3) - do k=1, nlev - - ! Compute 3D wind/tendency on A grid - do j=js-1,je+1 - do i=is-1,ie+1 - v3(i,j,1) = ua(i,j,k)*vlon(i,j,1) + va(i,j,k)*vlat(i,j,1) - v3(i,j,2) = ua(i,j,k)*vlon(i,j,2) + va(i,j,k)*vlat(i,j,2) - v3(i,j,3) = ua(i,j,k)*vlon(i,j,3) + va(i,j,k)*vlat(i,j,3) - enddo - enddo - - ! Interpolate to cell edges - do j=js,je+1 - do i=is-1,ie+1 - ue(i,j,1) = 0.5_r8*(v3(i,j-1,1) + v3(i,j,1)) - ue(i,j,2) = 0.5_r8*(v3(i,j-1,2) + v3(i,j,2)) - ue(i,j,3) = 0.5_r8*(v3(i,j-1,3) + v3(i,j,3)) - enddo - enddo - - do j=js-1,je+1 - do i=is,ie+1 - ve(i,j,1) = 0.5_r8*(v3(i-1,j,1) + v3(i,j,1)) - ve(i,j,2) = 0.5_r8*(v3(i-1,j,2) + v3(i,j,2)) - ve(i,j,3) = 0.5_r8*(v3(i-1,j,3) + v3(i,j,3)) - enddo - enddo - - ! --- E_W edges (for v-wind): - if (.not. gridstruct%nested) then - if ( is==1) then - i = 1 - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_w(j)*ve(i,j-1,1)+(1._r8-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j-1,2)+(1._r8-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j-1,3)+(1._r8-edge_vect_w(j))*ve(i,j,3) - else - vt1(j) = edge_vect_w(j)*ve(i,j+1,1)+(1._r8-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j+1,2)+(1._r8-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j+1,3)+(1._r8-edge_vect_w(j))*ve(i,j,3) - endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif - - if ( (ie+1)==npx ) then - i = npx - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_e(j)*ve(i,j-1,1)+(1._r8-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j-1,2)+(1._r8-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j-1,3)+(1._r8-edge_vect_e(j))*ve(i,j,3) - else - vt1(j) = edge_vect_e(j)*ve(i,j+1,1)+(1._r8-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j+1,2)+(1._r8-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j+1,3)+(1._r8-edge_vect_e(j))*ve(i,j,3) - endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif - ! N-S edges (for u-wind): - if ( js==1) then - j = 1 - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_s(i)*ue(i-1,j,1)+(1._r8-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i-1,j,2)+(1._r8-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i-1,j,3)+(1._r8-edge_vect_s(i))*ue(i,j,3) - else - ut1(i) = edge_vect_s(i)*ue(i+1,j,1)+(1._r8-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i+1,j,2)+(1._r8-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i+1,j,3)+(1._r8-edge_vect_s(i))*ue(i,j,3) - endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - if ( (je+1)==npy ) then - j = npy - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_n(i)*ue(i-1,j,1)+(1._r8-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i-1,j,2)+(1._r8-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i-1,j,3)+(1._r8-edge_vect_n(i))*ue(i,j,3) - else - ut1(i) = edge_vect_n(i)*ue(i+1,j,1)+(1._r8-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i+1,j,2)+(1._r8-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i+1,j,3)+(1._r8-edge_vect_n(i))*ue(i,j,3) - endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - - endif ! .not. nested - - do j=js,je+1 - do i=is,ie - u(i,j,k) = ue(i,j,1)*es(1,i,j,1) + & - ue(i,j,2)*es(2,i,j,1) + & - ue(i,j,3)*es(3,i,j,1) - enddo - enddo - do j=js,je - do i=is,ie+1 - v(i,j,k) = ve(i,j,1)*ew(1,i,j,2) + & - ve(i,j,2)*ew(2,i,j,2) + & - ve(i,j,3)*ew(3,i,j,2) - enddo - enddo - enddo ! k-loop - - call mpp_update_domains(u, v, domain, gridtype=DGRID_NE) - -end subroutine a2d3djt - -end module dyn_comp diff --git a/src/dynamics/fv3/dyn_grid.F90 b/src/dynamics/fv3/dyn_grid.F90 deleted file mode 100644 index 263c04ac3b..0000000000 --- a/src/dynamics/fv3/dyn_grid.F90 +++ /dev/null @@ -1,1108 +0,0 @@ -module dyn_grid -!------------------------------------------------------------------------------- -! Define FV3 computational grids on the dynamics decomposition. -! -! The grid used by the FV3 dynamics is called the FSSL grid and is a -! gnomonic cubed sphere consisting of 6 tiled faces. Each tile consists -! of an array of cells whose coordinates are great circles. The grid -! nomenclature (C96, C384, etc.) describes the number of cells along -! the top and side of a tile face (square). All prognostic variables -! are 3-D cell-mean values (cell center), except for the horizontal winds, -! which are 2-D face-mean values located on the cell walls (D-Grid winds). -! Each tile can be decomposed into a number of subdomains (consisting of -! one or more cells) which correspond to "blocks" in the physics/dynamics -! coupler terminology. The namelist variable "layout" consists of 2 integers -! and determines the size/shape of the blocks by dividing the tile into a -! number of horizonal and vertical sections. The total number of blocks in -! the global domain is therefore layout(1)*layout(2)*ntiles. The decomposition -! and communication infrastructure is provided by the GFDL FMS library. -! -! Module responsibilities: -! -! . Provide the physics/dynamics coupler (in module phys_grid) with data for the -! physics grid on the dynamics decomposition. -! -! . Create CAM grid objects that are used by the I/O functionality to read -! data from an unstructured grid format to the dynamics data structures, and -! to write from the dynamics data structures to unstructured grid format. The -! global column ordering for the unstructured grid is determined by the FV3 dycore. -! -!------------------------------------------------------------------------------- - - use cam_abortutils, only: endrun - use cam_grid_support, only: iMap - use cam_logfile, only: iulog - use dimensions_mod, only: npx, npy, ntiles - use fms_mod, only: fms_init, write_version_number - use fv_arrays_mod, only: fv_atmos_type - use fv_control_mod, only: ngrids,fv_init - use fv_mp_mod, only: mp_bcst - use mpp_mod, only: mpp_pe, mpp_root_pe - use physconst, only: rearth,pi - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: mpicom, masterproc - - implicit none - private - save - - ! The FV3 dynamics grids and initial file ncol grid - integer, parameter :: dyn_decomp = 101 - integer, parameter :: dyn_decomp_ew = 102 - integer, parameter :: dyn_decomp_ns = 103 - integer, parameter :: dyn_decomp_hist = 104 - integer, parameter :: dyn_decomp_hist_ew = 105 - integer, parameter :: dyn_decomp_hist_ns = 106 - integer, parameter :: ini_decomp = 107 - - character(len=3), protected :: ini_grid_name = 'INI' - - integer, parameter :: ptimelevels = 2 ! number of time levels in the dycore - - integer :: mytile = 1 - integer :: p_split = 1 - integer, allocatable :: pelist(:) - - real(r8), parameter :: rad2deg = 180._r8/pi - - logical, allocatable :: grids_on_this_pe(:) - type(fv_atmos_type), allocatable, target :: Atm(:) - - -public :: & - dyn_decomp, & - ini_grid_name, & - p_split, & - grids_on_this_pe, & - ptimelevels - -!----------------------------------------------------------------------- -! Calculate Global Index - -integer, allocatable, target, dimension(:,:) :: mygindex -integer, allocatable, target, dimension(:,:) :: mylindex -integer, allocatable, target, dimension(:,:) :: myblkidx -real(r8), allocatable, target, dimension(:,:,:) :: locidx_g -real(r8), allocatable, target, dimension(:,:,:) :: blkidx_g -real(r8), allocatable, target, dimension(:,:,:) :: gindex_g - -real(r8), allocatable :: block_extents_g(:,:) - -integer :: uniqpts_glob = 0 ! number of dynamics columns -integer :: uniqpts_glob_ew = 0 ! number of dynamics columns for D grid ew -integer :: uniqpts_glob_ns = 0 ! number of dynamics columns for D grid ns - -real(r8), pointer, dimension(:,:,:) :: grid_ew, grid_ns - -public :: mygindex -public :: mylindex -!----------------------------------------------------------------------- -public :: & - dyn_grid_init, & - get_block_bounds_d, & ! get first and last indices in global block ordering - get_block_gcol_d, & ! get column indices for given block - get_block_gcol_cnt_d, & ! get number of columns in given block - get_block_lvl_cnt_d, & ! get number of vertical levels in column - get_block_levels_d, & ! get vertical levels in column - get_block_owner_d, & ! get process "owning" given block - get_gcol_block_d, & ! get global block indices and local columns - ! index for given global column index - get_gcol_block_cnt_d, & ! get number of blocks containing data - ! from a given global column index - get_horiz_grid_dim_d, & - get_horiz_grid_d, & ! get horizontal grid coordinates - get_dyn_grid_parm, & - get_dyn_grid_parm_real1d, & - dyn_grid_get_elem_coords, & ! get coordinates of a specified block element - dyn_grid_get_colndx, & ! get element block/column and MPI process indices - ! corresponding to a specified global column index - physgrid_copy_attributes_d - -public Atm, mytile - -!======================================================================= -contains -!======================================================================= - -subroutine dyn_grid_init() - - ! Initialize FV grid, decomposition - - use block_control_mod, only: block_control_type, define_blocks_packed - use cam_initfiles, only: initial_file_get_id - use constants_mod, only: constants_init - use fv_mp_mod, only: switch_current_Atm,mp_gather, mp_bcst - use hycoef, only: hycoef_init, hyai, hybi, hypi, hypm, nprlev - use mpp_mod, only: mpp_init, mpp_npes, mpp_get_current_pelist,mpp_gather - use pmgrid, only: plev - use ref_pres, only: ref_pres_init - use time_manager, only: get_step_size - use pio, only: file_desc_t - - ! Local variables - - type(file_desc_t), pointer :: fh_ini - - character(len=*), parameter :: sub='dyn_grid_init' - character(len=128) :: version = '$Id$' - character(len=128) :: tagname = '$Name$' - - real(r8) :: dt_atmos_real = 0._r8 - - integer :: i, j, k, tile - integer :: is,ie,js,je,n,nx,ny - character(len=128) :: errmsg - - !----------------------------------------------------------------------- - ! from couple_main initialize atm structure - initializes fv3 grid - !----------------------------------------------------------------------- - - call fms_init(mpicom) - call mpp_init() - call constants_init - -!----------------------------------------------------------------------- -! initialize atmospheric model ----- - - allocate(pelist(mpp_npes())) - call mpp_get_current_pelist(pelist) - -!---- compute physics/atmos time step in seconds ---- - - dt_atmos_real = get_step_size() - -!----- initialize FV dynamical core ----- - - call fv_init( Atm, dt_atmos_real, grids_on_this_pe, p_split) ! allocates Atm components - - do n=1,ngrids - if (grids_on_this_pe(n)) mytile = n - enddo - -!----- write version and namelist to log file ----- - call write_version_number ( version, tagname ) - - call switch_current_Atm(Atm(mytile)) - -!! set up dimensions_mod convenience variables. - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - npx = Atm(mytile)%flagstruct%npx - npy = Atm(mytile)%flagstruct%npy - ntiles = Atm(mytile)%gridstruct%ntiles_g - tile = Atm(mytile)%tile - - if (Atm(mytile)%flagstruct%npz /= plev) then - write(errmsg,*) 'FV3 dycore levels (npz),',Atm(mytile)%flagstruct%npz,' do not match model levels (plev)',plev - call endrun(sub//':'//errmsg) - end if - - ! Get file handle for initial file - fh_ini => initial_file_get_id() - - ! Initialize hybrid coordinate arrays - call hycoef_init(fh_ini) - - ! Initialize reference pressures - call ref_pres_init(hypi, hypm, nprlev) - - ! Hybrid coordinate info for FV grid object - Atm(mytile)%ks = plev - do k = 1, plev+1 - Atm(mytile)%ak(k) = hyai(k) * 1.e5_r8 - Atm(mytile)%bk(k) = hybi(k) - if ( Atm(mytile)%bk(k) == 0._r8) Atm(mytile)%ks = k-1 - end do - Atm(mytile)%ptop = Atm(mytile)%ak(1) - - ! Define the CAM grids - call define_cam_grids(Atm) - - ! Define block index arrays that are part of dyn_in and - ! global array for mapping columns to block decompositions - - allocate(mygindex(is:ie,js:je)) - allocate(mylindex(is:ie,js:je)) - - nx=npx-1 - ny=npy-1 - - n = 1 - do j = js, je - do i = is, ie - mygindex(i,j)=((j-1)*(npx-1)+i)+((npx-1)*(npy-1)*(tile-1)) - mylindex(i,j)=n - n = n + 1 - end do - end do - - ! create globalID index on block decomp - allocate(gindex_g(nx,ny,ntiles)) - if (masterproc) write(iulog, *) 'INFO: Non-scalable action: Allocating global blocks in FV3 dycore.(gindex_g)' - gindex_g(is:ie,js:je,tile)=mygindex(is:ie,js:je) - call mp_gather(gindex_g, is, ie, js, je, nx, ny, ntiles) - call mp_bcst(gindex_g, nx, ny, ntiles) - - ! create global blockID index on block decomp - if (masterproc) write(iulog, *) 'INFO: Non-scalable action: Allocating global blocks in FV3 dycore.(blkidx_g)' - allocate(blkidx_g(nx,ny,ntiles)) - blkidx_g(is:ie,js:je,tile)= mpp_pe() + 1 - call mp_gather(blkidx_g, is, ie, js, je, nx ,ny, ntiles) - call mp_bcst(blkidx_g, nx, ny, ntiles) - - ! create global block index on block decomp - if (masterproc) write(iulog, *) 'INFO: Non-scalable action: Allocating global blocks in FV3 dycore.(locidx_g)' - allocate(locidx_g(nx,ny,ntiles)) - locidx_g(is:ie,js:je,tile)= mylindex(is:ie,js:je) - call mp_gather(locidx_g, is, ie, js, je, nx ,ny, ntiles) - call mp_bcst(locidx_g, nx, ny, ntiles) - -end subroutine dyn_grid_init - -!======================================================================= - -subroutine get_block_bounds_d(block_first, block_last) - - ! Return first and last indices used in global block ordering - - use spmd_utils, only : npes - - ! arguments - integer, intent(out) :: block_first ! first (global) index used for blocks - integer, intent(out) :: block_last ! last (global) index used for blocks - !---------------------------------------------------------------------------- - - block_first = 1 - block_last = npes - -end subroutine get_block_bounds_d - -!======================================================================= - -subroutine get_block_gcol_d(blockid, size, cdex) - - ! Return number of dynamics columns in indicated block - - use fv_mp_mod, only: mp_bcst - use mpp_mod, only: mpp_npes, mpp_gather - - ! arguments - integer, intent(in) :: blockid ! global block id - integer, intent(in) :: size ! array size - integer, intent(out):: cdex(size) ! global column indices - - ! Local variables - integer, parameter :: be_arrlen = 5 - - real(r8),allocatable :: rtmp(:) - real(r8) :: block_extents(be_arrlen) - integer, allocatable :: be_size(:) - integer :: i, j, n,is,ie,js,je,tile,npes - !---------------------------------------------------------------------------- - !--- get block extents for each task/pe - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - if (.not. allocated(block_extents_g)) then - npes=mpp_npes() - allocate(block_extents_g(be_arrlen,npes)) - allocate(rtmp(be_arrlen*npes)) - allocate(be_size(npes)) - be_size(:)=be_arrlen - block_extents(1)=is - block_extents(2)=ie - block_extents(3)=js - block_extents(4)=je - block_extents(5)=Atm(mytile)%tile - - call mpp_gather(block_extents,be_arrlen,rtmp,be_size) - call mp_bcst(rtmp,be_arrlen*npes) - block_extents_g=reshape(rtmp,(/be_arrlen,npes/)) - - deallocate(rtmp) - deallocate(be_size) - end if - - is=block_extents_g(1,blockid) - ie=block_extents_g(2,blockid) - js=block_extents_g(3,blockid) - je=block_extents_g(4,blockid) - tile=block_extents_g(5,blockid) - - if (size .ne. (ie - is + 1) * (je - js + 1)) then - call endrun ('get_block_gcol_d: block sizes are not consistent.') - end if - ! the following algorithm for cdex calculates global ids for a block - ! given the tile,and i,j column locations on tile. - n=1 - do j = js, je - do i = is, ie - cdex(n)= ((j-1)*(npx-1)+i)+((npx-1)*(npy-1)*(tile-1)) - n=n+1 - end do - end do - -end subroutine get_block_gcol_d - -!======================================================================= - -integer function get_block_gcol_cnt_d(blockid) - - ! Return number of dynamics columns in indicated block - - ! arguments - integer, intent(in) :: blockid - !---------------------------------------------------------------------------- - - get_block_gcol_cnt_d=count(blkidx_g == blockid) - -end function get_block_gcol_cnt_d - -!======================================================================= - -integer function get_block_lvl_cnt_d(blockid, bcid) - - ! Return number of levels in indicated column. If column - ! includes surface fields, then it is defined to also - ! include level 0. - - use pmgrid, only: plevp - - ! arguments - integer, intent(in) :: blockid ! global block id - integer, intent(in) :: bcid ! column index within block - !---------------------------------------------------------------------------- - - get_block_lvl_cnt_d = plevp - -end function get_block_lvl_cnt_d - -!======================================================================= - -subroutine get_block_levels_d(blockid, bcid, lvlsiz, levels) - - use pmgrid, only: plev - - ! Return level indices in indicated column. If column - ! includes surface fields, then it is defined to also - ! include level 0. - - ! arguments - integer, intent(in) :: blockid ! global block id - integer, intent(in) :: bcid ! column index within block - integer, intent(in) :: lvlsiz ! dimension of levels array - integer, intent(out) :: levels(lvlsiz) ! levels indices for block - - ! local variables - integer :: k - character(len=128) :: errmsg - !--------------------------------------------------------------------------- - - if (lvlsiz < plev + 1) then - write(errmsg,*) 'levels array not large enough (', lvlsiz,' < ',plev + 1,')' - call endrun('GET_BLOCK_LEVELS_D: '//trim(errmsg)) - else - do k = 0, plev - levels(k+1) = k - enddo - do k = plev + 2, lvlsiz - levels(k) = -1 - enddo - end if - -end subroutine get_block_levels_d - -!======================================================================= - -integer function get_block_owner_d(blockid) - - ! Return id of processor that "owns" the indicated block - - ! arguments - integer, intent(in) :: blockid ! global block id - - get_block_owner_d = blockid - 1 - -end function get_block_owner_d - -!======================================================================= - -subroutine get_gcol_block_d(gcol, cnt, blockid, bcid, localblockid) - - ! Return global block index and local column index for given global column index. - ! - ! The FV3 dycore assigns each global column to a singe element. So cnt is assumed - ! to be 1. - - use dimensions_mod, only: npx, npy - use fv_mp_mod, only: mp_gather, mp_bcst - - ! arguments - integer, intent(in) :: gcol ! global column index - integer, intent(in) :: cnt ! size of blockid and bcid arrays - integer, intent(out) :: blockid(cnt) ! block index - integer, intent(out) :: bcid(cnt) ! column index within block - integer, intent(out), optional :: localblockid(cnt) - - ! local variables - integer :: tot - integer :: ijk(3) - !---------------------------------------------------------------------------- - - if (cnt /= 1) then - call endrun ('get_gcol_block_d: cnt is not equal to 1:.') - end if - tot=(npx-1)*(npy-1)*6 - if (gcol < 1.or.gcol > tot) then - call endrun ('get_gcol_block_d: global column number is out of bounds') - else - - ijk=maxloc(blkidx_g,mask=gindex_g == gcol) - blockid(1) = blkidx_g(ijk(1),ijk(2),ijk(3)) - - ijk=maxloc(locidx_g,mask=gindex_g == gcol) - bcid(1) = locidx_g(ijk(1),ijk(2),ijk(3)) - end if - - if (present(localblockid)) then - localblockid(cnt) = 1 - end if - -end subroutine get_gcol_block_d - -!======================================================================= - -integer function get_gcol_block_cnt_d(gcol) - - ! Return number of blocks containg data for the vertical column with the - ! given global column index. - - ! For FV3 dycore each column is contained in a single block, so this routine - ! always returns 1. - - ! arguments - integer, intent(in) :: gcol ! global column index - !---------------------------------------------------------------------------- - - get_gcol_block_cnt_d = 1 - -end function get_gcol_block_cnt_d - -!======================================================================= - -subroutine get_horiz_grid_d(nxy, clat_d_out, clon_d_out, area_d_out, wght_d_out, lat_d_out, lon_d_out) - - ! Return global arrays of latitude and longitude (in radians), column - ! surface area (in radians squared) and surface integration weights for - ! global column indices that will be passed to/from physics - - ! arguments - integer, intent(in) :: nxy ! array sizes - real(r8), intent(out), optional :: clat_d_out(:) ! column latitudes - real(r8), intent(out), optional :: clon_d_out(:) ! column longitudes - real(r8), intent(out), optional :: area_d_out(:) ! column surface area - real(r8), intent(out), optional :: wght_d_out(:) ! column integration - real(r8), intent(out), optional :: lat_d_out(:) ! column degree latitudes - real(r8), intent(out), optional :: lon_d_out(:) ! column degree longitudes - - ! local variables - character(len=*), parameter :: sub = 'get_horiz_grid_d' - real(r8), allocatable :: tmparr(:,:) - real(r8), pointer :: area(:,:) - real(r8), pointer :: agrid(:,:,:) - integer :: is,ie,js,je - !---------------------------------------------------------------------------- - - area => Atm(mytile)%gridstruct%area_64 - agrid => Atm(mytile)%gridstruct%agrid_64 - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - if (present(clon_d_out)) then - if (size(clon_d_out) /= nxy) call endrun(sub//': bad clon_d_out array size') - call create_global(is,ie,js,je,agrid(is:ie,js:je,1), clon_d_out) - end if - if (present(clat_d_out)) then - if (size(clat_d_out) /= nxy) call endrun(sub//': bad clat_d_out array size') - call create_global(is,ie,js,je,agrid(is:ie,js:je,2), clat_d_out) - end if - if (present(area_d_out).or.present(wght_d_out)) then - allocate(tmparr(is:ie,js:je)) - tmparr(is:ie,js:je) = area (is:ie,js:je) / (rearth * rearth) - if (present(area_d_out)) then - if (size(area_d_out) /= nxy) call endrun(sub//': bad area_d_out array size') - call create_global(is,ie,js,je,tmparr, area_d_out) - end if - if (present(wght_d_out)) then - if (size(wght_d_out) /= nxy) call endrun(sub//': bad wght_d_out array size') - call create_global(is,ie,js,je,tmparr, wght_d_out) - end if - deallocate(tmparr) - end if - if (present(lon_d_out)) then - if (size(lon_d_out) /= nxy) call endrun(sub//': bad clon_d_out array size') - call create_global(is,ie,js,je,agrid(is:ie,js:je,1), lon_d_out) - lon_d_out=lon_d_out*rad2deg - end if - if (present(lat_d_out)) then - if (size(lat_d_out) /= nxy) call endrun(sub//': bad clat_d_out array size') - call create_global(is,ie,js,je,agrid(is:ie,js:je,2), lat_d_out) - lat_d_out=lat_d_out*rad2deg - end if - - end subroutine get_horiz_grid_d - -!======================================================================= - -subroutine get_horiz_grid_dim_d(hdim1_d, hdim2_d) - - ! Returns declared horizontal dimensions of computational grid. - ! For non-lon/lat grids, declare grid to be one-dimensional, - - use dimensions_mod, only: npx,npy,ntiles - - ! arguments - integer, intent(out) :: hdim1_d ! first horizontal dimension - integer, intent(out), optional :: hdim2_d ! second horizontal dimension - !----------------------------------------------------------------------- - - hdim1_d = (npx-1)*(npy-1)*ntiles - if (present(hdim2_d)) hdim2_d = 1 - -end subroutine get_horiz_grid_dim_d - -!======================================================================= - -subroutine define_cam_grids(Atm) - - ! Create grid objects on the dynamics decomposition for grids used by - ! the dycore. The decomposed grid object contains data for the elements - ! in each task and information to map that data to the global grid. - ! - ! Notes on dynamic memory management: - ! - ! . Coordinate values and the map passed to the horiz_coord_create - ! method are copied to the object. The memory may be deallocated - ! after the object is created. - ! - ! . The area values passed to cam_grid_attribute_register are only pointed - ! to by the attribute object, so that memory cannot be deallocated. But the - ! map is copied. - ! - ! . The grid_map passed to cam_grid_register is just pointed to. - ! Cannot be deallocated. - - use cam_grid_support, only: horiz_coord_t, horiz_coord_create - use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register - use fv_grid_utils_mod, only: mid_pt_sphere - use mpp_mod, only: mpp_pe - use physconst, only: rearth - - ! arguments - type(fv_atmos_type), target, intent(in) :: Atm(:) - - ! local variables - type(horiz_coord_t), pointer :: lat_coord - type(horiz_coord_t), pointer :: lon_coord - - integer(iMap), pointer :: grid_map(:,:) - - integer, allocatable, target, dimension(:,:) :: mygid, mygid_ew,mygid_ns - integer :: mybindex - integer :: i, j, mapind,is,ie,js,je,isd,ied,jsd,jed,tile - real(r8), pointer, dimension(:,:,:) :: agrid - real(r8), pointer, dimension(:,:,:) :: grid - real(r8), pointer, dimension(:,:) :: area - real(r8), pointer :: area_ffsl(:) !fv3 cell centered grid area in sq radians - real(r8), pointer :: pelon_deg(:) - real(r8), pointer :: pelat_deg(:) - real(r8), pointer :: pelon_deg_ew(:) - real(r8), pointer :: pelat_deg_ew(:) - real(r8), pointer :: pelon_deg_ns(:) - real(r8), pointer :: pelat_deg_ns(:) - real(r8) :: lonrad,latrad - integer(iMap), pointer :: pemap(:) - integer(iMap), pointer :: pemap_ew(:) - integer(iMap), pointer :: pemap_ns(:) - integer :: iend, jend - - !----------------------------------------------------------------------- - - area => Atm(mytile)%gridstruct%area_64 - agrid => Atm(mytile)%gridstruct%agrid_64 - grid => Atm(mytile)%gridstruct%grid_64 - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - isd = Atm(mytile)%bd%isd - ied = Atm(mytile)%bd%ied - jsd = Atm(mytile)%bd%jsd - jed = Atm(mytile)%bd%jed - tile = Atm(mytile)%tile - - allocate(area_ffsl((ie-is+1)*(je-js+1))) - allocate(grid_ew(isd:ied+1,jsd:jed,2)) - allocate(grid_ns(isd:ied,jsd:jed+1,2)) - allocate(pelon_deg((ie-is+1)*(je-js+1))) - allocate(pelon_deg_ns((ie-is+1)*(je-js+2))) - allocate(pelon_deg_ew((ie-is+2)*(je-js+1))) - allocate(pelat_deg((ie-is+1)*(je-js+1))) - allocate(pelat_deg_ew((ie-is+2)*(je-js+1))) - allocate(pelat_deg_ns((ie-is+1)*(je-js+2))) - allocate(pemap((ie-is+1)*(je-js+1))) - allocate(pemap_ew((ie-is+2)*(je-js+1))) - allocate(pemap_ns((ie-is+1)*(je-js+2))) - - do j=jsd,jed - do i=isd,ied+1 - call mid_pt_sphere(grid(i, j,1:2), grid(i, j+1,1:2), grid_ew(i,j,:)) - end do - end do - - do j=jsd,jed+1 - do i=isd,ied - call mid_pt_sphere(grid(i,j ,1:2), grid(i+1,j ,1:2), grid_ns(i,j,:)) - end do - end do - - allocate(mygid(is:ie,js:je)) - allocate(mygid_ew(is:ie+1,js:je)) - allocate(mygid_ns(is:ie,js:je+1)) - - mygid=0 - - mybindex = mpp_pe() + 1 - - do j = js, je - do i = is, ie - mygid(i,j)=((j-1)*(npx-1)+i)+((npx-1)*(npy-1)*(tile-1)) - end do - end do - - ! calculate local portion of global NS index array - ! unique global indexing bottom left to top right of each tile consecutively. Dups reported as 0 - ! North tile edges of 2,4,6 are duplicates of south edge of 3,5,1 and are reported as 0 in mygid array - mygid_ns=0 - if (je+1 == npy) then - jend = je+mod(tile,2) - else - jend = je+1 - end if - do j = js, jend - do i = is, ie - mygid_ns(i,j)=(i-1)*(npy-(mod(tile-1,2))) + j + (int((tile-1)/2)*(npx-1)*(npy-1)) + (int(tile/2)*(npx-1)*(npy)) - end do - end do - ! appropriate tile boundaries already 0'd need to - ! zero inner tile je+1 boundaries (These are also repeated points between tasks in ns direction)) - if (je+1 /= npy) mygid_ns(is:ie,je+1)=0 - - ! calculate local portion of global EW index array - ! unique global indexing bottom left to top right of each tile consecutively. Dups reported as 0 - ! East tile edges of 1,3,5 are duplicates of west edge of 2,4,6 and are reported as 0 in mygid array - mygid_ew=0 - if (ie+1 == npx) then - iend=ie+mod(tile-1,2) - else - iend=ie+1 - end if - do j = js, je - do i = is, iend - mygid_ew(i,j)=(j-1)*(npx-(mod(tile,2))) + i + (int(tile/2)*(npx-1)*(npy-1)) + (int((tile-1)/2)*(npx)*(npy-1)) - end do - end do - - ! appropriate east tile boundaries already 0'd from above need to - ! zero inner tile ie+1 boundaries on appropriate processors - ! (These are also repeated points between tasks in ew direction) - if (ie+1 /= npx) mygid_ew(ie+1,js:je)=0 - - !----------------------- - ! Create FFSL grid object - !----------------------- - - ! Calculate the mapping between FFSL points and file order (tile1 thru tile6) - mapind = 1 - do j = js, je - do i = is, ie - pelon_deg(mapind) = agrid(i,j,1) * rad2deg - pelat_deg(mapind) = agrid(i,j,2) * rad2deg - area_ffsl(mapind) = area(i,j)/(rearth*rearth) - pemap(mapind) = mygid(i,j) - mapind = mapind + 1 - end do - end do - - mapind = 1 - do j = js, je - do i = is, ie+1 - lonrad=grid_ew(i,j,1) - latrad=grid_ew(i,j,2) - pelon_deg_ew(mapind) = lonrad * rad2deg - pelat_deg_ew(mapind) = latrad * rad2deg - pemap_ew(mapind) = mygid_ew(i,j) - mapind = mapind + 1 - end do - end do - - mapind = 1 - do j = js, je+1 - do i = is, ie - lonrad=grid_ns(i,j,1) - latrad=grid_ns(i,j,2) - pelon_deg_ns(mapind) = lonrad * rad2deg - pelat_deg_ns(mapind) = latrad * rad2deg - pemap_ns(mapind) = mygid_ns(i,j) - mapind = mapind + 1 - end do - end do - - allocate(grid_map(3, (ie-is+1)*(je-js+1))) - grid_map = 0 - mapind = 1 - do j = js, je - do i = is, ie - grid_map(1, mapind) = i - grid_map(2, mapind) = j - grid_map(3, mapind) = pemap(mapind) - mapind = mapind + 1 - end do - end do - - ! output local and global uniq points - uniqpts_glob=(npx-1)*(npy-1)*6 - - ! with FV3 if the initial file uses the horizontal dimension 'ncol' rather than - ! 'ncol_d' then we need a grid object with the names ncol,lat,lon to read it. - ! Create that grid object here. - - lat_coord => horiz_coord_create('lat', 'ncol', uniqpts_glob, 'latitude', & - 'degrees_north', 1, size(pelat_deg), pelat_deg, map=pemap) - lon_coord => horiz_coord_create('lon', 'ncol', uniqpts_glob, 'longitude', & - 'degrees_east', 1, size(pelon_deg), pelon_deg, map=pemap) - - ! register physics cell-center/A-grid - call cam_grid_register(ini_grid_name, ini_decomp, lat_coord, lon_coord, & - grid_map, block_indexed=.false., unstruct=.true.) - call cam_grid_attribute_register(ini_grid_name, 'cell', '', 1) - call cam_grid_attribute_register(ini_grid_name, 'area', 'cam cell center areas', & - 'ncol', area_ffsl, map=pemap) - nullify(lat_coord) - nullify(lon_coord) - - ! create and register dynamic A-grid, src_in(/1,2/) allows ilev,jlev,nlev ordering for restart IO - lat_coord => horiz_coord_create('lat_d', 'ncol_d', uniqpts_glob, 'latitude', & - 'degrees_north', 1, size(pelat_deg), pelat_deg, map=pemap) - lon_coord => horiz_coord_create('lon_d', 'ncol_d', uniqpts_glob, 'longitude', & - 'degrees_east', 1, size(pelon_deg), pelon_deg, map=pemap) - - call cam_grid_register('FFSL', dyn_decomp, lat_coord, lon_coord, & - grid_map, block_indexed=.false., unstruct=.true.,src_in=(/1,2/)) - call cam_grid_attribute_register('FFSL', 'cell', '', 1) - call cam_grid_attribute_register('FFSL', 'area_d', 'FFSL grid areas', & - 'ncol_d', area_ffsl, map=pemap) - - ! register grid for writing dynamics A-Grid fields in history files - call cam_grid_register('FFSLHIST', dyn_decomp_hist, lat_coord, lon_coord, & - grid_map, block_indexed=.false., unstruct=.true.) - call cam_grid_attribute_register('FFSLHIST', 'cell', '', 1) - call cam_grid_attribute_register('FFSLHIST', 'area_d', 'FFSLHIST grid areas', & - 'ncol_d', area_ffsl, map=pemap) - - ! grid_map cannot be deallocated as the cam_filemap_t object just points - ! to it. It can be nullified. - nullify(grid_map) - ! lat_coord and lon_coord belong to grid so can't be deleted. It can be nullified - nullify(lat_coord) - nullify(lon_coord) - ! area_ffsl cannot be deallocated as the attribute object is just pointing - ! to that memory. It can be nullified since the attribute object has - ! the reference. - nullify(area_ffsl) - - - ! global EW uniq points - uniqpts_glob_ew=((2*npx)-1)*(npy-1)*3 - - lat_coord => horiz_coord_create('lat_d_ew', 'ncol_d_ew', uniqpts_glob_ew, 'latitude', & - 'degrees_north', 1, size(pelat_deg_ew), pelat_deg_ew, map=pemap_ew) - lon_coord => horiz_coord_create('lon_d_ew', 'ncol_d_ew', uniqpts_glob_ew, 'longitude', & - 'degrees_east', 1, size(pelon_deg_ew), pelon_deg_ew, map=pemap_ew) - - allocate(grid_map(3, (ie-is+2)*(je-js+1))) - grid_map = 0 - mapind = 1 - do j = js, je - do i = is, ie+1 - grid_map(1, mapind) = i - grid_map(2, mapind) = j - grid_map(3, mapind) = pemap_ew(mapind) - mapind = mapind + 1 - end do - end do - - ! register dynamic D-grid, src_in(/1,2/) allows ilev,jlev,nlev ordering for restart IO - call cam_grid_register('FFSL_EW', dyn_decomp_ew, lat_coord, lon_coord, & - grid_map, block_indexed=.false., unstruct=.true.,src_in=(/1,2/)) - call cam_grid_attribute_register('FFSL_EW', 'cell', '', 1) - - ! register grid for writing dynamics D-Grid fields in history files - call cam_grid_register('FFSLHIST_EW', dyn_decomp_hist_ew, lat_coord, lon_coord, & - grid_map, block_indexed=.false., unstruct=.true.) - call cam_grid_attribute_register('FFSLHIST_EW', 'cell', '', 1) - - ! grid_map cannot be deallocated as the cam_filemap_t object just points - ! to it. It can be nullified. - nullify(grid_map) - ! lat_coord and lon_coord belong to grid so can't be deleted. It can be nullified - nullify(lat_coord) ! Belongs to grid - nullify(lon_coord) ! Belongs to grid - - - ! output local and global uniq points - uniqpts_glob_ns=((2*npy)-1)*(npx-1)*3 - - lat_coord => horiz_coord_create('lat_d_ns', 'ncol_d_ns', uniqpts_glob_ns, 'latitude', & - 'degrees_north', 1, size(pelat_deg_ns), pelat_deg_ns, map=pemap_ns) - lon_coord => horiz_coord_create('lon_d_ns', 'ncol_d_ns', uniqpts_glob_ns, 'longitude', & - 'degrees_east', 1, size(pelon_deg_ns), pelon_deg_ns, map=pemap_ns) - - allocate(grid_map(3, (ie-is+1)*(je-js+2))) - grid_map = 0 - mapind = 1 - do j = js, je+1 - do i = is, ie - grid_map(1, mapind) = i - grid_map(2, mapind) = j - grid_map(3, mapind) = pemap_ns(mapind) - mapind = mapind + 1 - end do - end do - - ! register dynamic D-grid, src_in(/1,2/) allows ilev,jlev,nlev ordering for restart IO - call cam_grid_register('FFSL_NS', dyn_decomp_ns, lat_coord, lon_coord, & - grid_map, block_indexed=.false., unstruct=.true.,src_in=(/1,2/)) - call cam_grid_attribute_register('FFSL_NS', 'cell', '', 1) - - ! register grid for writing dynamics D-Grid fields in history files - call cam_grid_register('FFSLHIST_NS', dyn_decomp_hist_ns, lat_coord, lon_coord, & - grid_map, block_indexed=.false., unstruct=.true.) - call cam_grid_attribute_register('FFSLHIST_NS', 'cell', '', 1) - - ! grid_map cannot be deallocated as the cam_filemap_t object just points - ! to it. It can be nullified. - nullify(grid_map) - ! lat_coord and lon_coord belong to grid so can't be deleted. It can be nullified - nullify(lat_coord) ! Belongs to grid - nullify(lon_coord) ! Belongs to grid - - deallocate(pelon_deg) - deallocate(pelat_deg) - deallocate(pelon_deg_ns) - deallocate(pelat_deg_ns) - deallocate(pelon_deg_ew) - deallocate(pelat_deg_ew) - deallocate(pemap) - deallocate(pemap_ew) - deallocate(pemap_ns) - deallocate(mygid) - deallocate(mygid_ew) - deallocate(mygid_ns) - -end subroutine define_cam_grids - -!========================================================================================= - -subroutine physgrid_copy_attributes_d(gridname, grid_attribute_names) - - ! create list of attributes for the physics grid that should be copied - ! from the corresponding grid object on the dynamics decomposition - - use cam_grid_support, only: max_hcoordname_len - - ! arguments - character(len=max_hcoordname_len), intent(out) :: gridname - character(len=max_hcoordname_len), pointer, intent(out) :: grid_attribute_names(:) - !----------------------------------------------------------------------- - - gridname = 'FFSL' - allocate(grid_attribute_names(1)) - ! For standard CAM-FV3, we need to copy the area attribute. - ! For physgrid, the physics grid will create area - grid_attribute_names(1) = 'cell' - -end subroutine physgrid_copy_attributes_d - -!======================================================================= - -integer function get_dyn_grid_parm(name) result(ival) - - ! This function is in the process of being deprecated, but is still needed - ! as a dummy interface to satisfy external references from some chemistry routines. - - use pmgrid, only: plon, plev, plat, plevp - - character(len=*), intent(in) :: name - integer is,ie,js,je - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - if (name == 'plat') then - ival = plat - else if (name == 'plon') then - ival = (je-js+1)*(ie-is+1) - else if (name == 'plev') then - ival = plev - else if (name == 'plevp') then - ival = plevp - else - call endrun('get_dyn_grid_parm: undefined name: '//adjustl(trim(name))) - end if - -end function get_dyn_grid_parm - -!======================================================================= - -function get_dyn_grid_parm_real1d(name) result(rval) - - ! This routine is not used for FV3, but still needed as a dummy interface to satisfy - ! references from mo_synoz.F90 and phys_gmean.F90 - - ! arguments - character(len=*), intent(in) :: name - real(r8), pointer :: rval(:) - !---------------------------------------------------------------------------- - - if(name == 'w') then - call endrun('get_dyn_grid_parm_real1d: w not defined') - else if(name == 'clat') then - call endrun('get_dyn_grid_parm_real1d: clat not supported, use get_horiz_grid_d') - else if(name == 'latdeg') then - call endrun('get_dyn_grid_parm_real1d: latdeg not defined') - else - nullify(rval) - end if - -end function get_dyn_grid_parm_real1d - -!========================================================================================= - -subroutine dyn_grid_get_colndx( igcol, ncols, owners, indx, jndx) - use spmd_utils, only: iam - - ! For each global column index return the owning task. If the column is owned - ! by this task, then also return the MPI process indicies for that column - - - ! arguments - integer, intent(in) :: ncols - integer, intent(in) :: igcol(ncols) - integer, intent(out) :: owners(ncols) - integer, intent(out) :: indx(ncols) - integer, intent(out) :: jndx(ncols) - - ! local variables - integer :: i,is,ie,js,je - integer :: blockid(1), bcid(1), lclblockid(1), ind(2) - !---------------------------------------------------------------------------- - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - do i = 1,ncols - - call get_gcol_block_d( igcol(i), 1, blockid, bcid, lclblockid ) - owners(i) = get_block_owner_d(blockid(1)) - - if ( iam == owners(i) ) then - if (minval(abs(bcid(1)-mylindex)) == 0) then - ind = minloc(abs(bcid(1)-mylindex)) - indx(i) = is+ind(1)-1 - jndx(i) = js+ind(2)-1 - end if - else - indx(i) = -1 - jndx(i) = -1 - endif - - end do - -end subroutine dyn_grid_get_colndx - -!======================================================================= - -subroutine dyn_grid_get_elem_coords(ie, rlon, rlat, cdex) - - ! Returns coordinates of a specified block element of the dyn grid - ! - - ! arguments - integer, intent(in) :: ie ! block element index - real(r8),optional, intent(out) :: rlon(:) ! longitudes of the columns in the element - real(r8),optional, intent(out) :: rlat(:) ! latitudes of the columns in the element - integer, optional, intent(out) :: cdex(:) ! global column index - !---------------------------------------------------------------------------- - - call endrun('dyn_grid_get_elem_coords: currently not avaliable.') - -end subroutine dyn_grid_get_elem_coords - -!========================================================================================= - -subroutine create_global(is,ie,js,je,arr_d, global_out) - - ! Gather global array of columns for the physics grid, - ! reorder to global column order, then broadcast it to all tasks. - - use fv_mp_mod, only: mp_gather, mp_bcst - - ! arguments - integer, intent(in) :: is, ie, js, je - real(r8), intent(in) :: arr_d(is:ie,js:je) ! input array - real(r8), intent(out) :: global_out(:) ! global output in block order - - ! local variables - integer :: i, j, k - integer :: tile - real(r8), allocatable :: globid(:,:,:) - real(r8), allocatable :: globarr_tmp(:,:,:) - !---------------------------------------------------------------------------- - - tile = Atm(mytile)%tile - - if (.not. allocated(globarr_tmp)) then - if (masterproc) write(iulog, *) 'INFO: Non-scalable action: Allocating global blocks in FV3 dycore.(globarr_tmp)' - allocate(globarr_tmp(npx-1, npy-1, ntiles)) - end if - - globarr_tmp(is:ie,js:je,tile)=arr_d(is:ie,js:je) - call mp_gather(globarr_tmp, is, ie, js, je, npx-1, npy-1, ntiles) - if (masterproc) then - do k = 1, ntiles - do j = 1, npy-1 - do i = 1, npx-1 - global_out(gindex_g(i,j,k)) = globarr_tmp(i,j,k) - end do - end do - end do - end if - call mp_bcst(global_out, (npx-1)*(npy-1)*ntiles) - deallocate(globarr_tmp) - -end subroutine create_global - -end module dyn_grid diff --git a/src/dynamics/fv3/interp_mod.F90 b/src/dynamics/fv3/interp_mod.F90 deleted file mode 100644 index e517031ea8..0000000000 --- a/src/dynamics/fv3/interp_mod.F90 +++ /dev/null @@ -1,67 +0,0 @@ -module interp_mod - ! inline interpolation routines not implemented yet - use shr_kind_mod, only : r8=>shr_kind_r8 - use cam_abortutils, only : endrun - - implicit none - private - save - - public :: setup_history_interpolation - public :: set_interp_hfile - public :: write_interpolated - - interface write_interpolated - module procedure write_interpolated_scalar - module procedure write_interpolated_vector - end interface - integer, parameter :: nlat=0, nlon=0 -contains - - subroutine setup_history_interpolation(interp_ok, mtapes, interp_output, & - interp_info) - use cam_history_support, only: interp_info_t - - ! Dummy arguments - logical, intent(inout) :: interp_ok - integer, intent(in) :: mtapes - logical, intent(in) :: interp_output(:) - type(interp_info_t), intent(inout) :: interp_info(:) - - interp_ok = .false. - - end subroutine setup_history_interpolation - - subroutine set_interp_hfile(hfilenum, interp_info) - use cam_history_support, only: interp_info_t - - ! Dummy arguments - integer, intent(in) :: hfilenum - type(interp_info_t), intent(inout) :: interp_info(:) - call endrun('ERROR:set_interp_hfile - This routine is a stub, you shouldnt get here') - end subroutine set_interp_hfile - - subroutine write_interpolated_scalar(File, varid, fld, numlev, data_type, decomp_type) - use pio, only : file_desc_t, var_desc_t - use shr_kind_mod, only : r8=>shr_kind_r8 - - type(file_desc_t), intent(inout) :: File - type(var_desc_t), intent(inout) :: varid - real(r8), intent(in) :: fld(:,:,:) - integer, intent(in) :: numlev, data_type, decomp_type - call endrun('ERROR:write_interpolated_scalar - This routine is a stub, you shouldnt get here') - - end subroutine write_interpolated_scalar - - subroutine write_interpolated_vector(File, varidu, varidv, fldu, fldv, numlev, data_type, decomp_type) - use pio, only : file_desc_t, var_desc_t - - type(file_desc_t), intent(inout) :: File - type(var_desc_t), intent(inout) :: varidu, varidv - real(r8), intent(in) :: fldu(:,:,:), fldv(:,:,:) - integer, intent(in) :: numlev, data_type, decomp_type - call endrun('ERROR:write_interpolated_vector - This routine is a stub, you shouldnt get here') - - end subroutine write_interpolated_vector - -end module interp_mod diff --git a/src/dynamics/fv3/microphys/gfdl_cloud_microphys.F90 b/src/dynamics/fv3/microphys/gfdl_cloud_microphys.F90 deleted file mode 100644 index 9a18204651..0000000000 --- a/src/dynamics/fv3/microphys/gfdl_cloud_microphys.F90 +++ /dev/null @@ -1,4975 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Cloud Microphysics. -!* -!* The GFDL Cloud Microphysics is free software: you can -!* redistribute it and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the GFDL Cloud Microphysics. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud -!! microphysics (Chen and Lin 2013) \cite chen2013seasonal and (Zhou et al. 2019) \cite zhou2019toward. -!>@details The module is paired with 'fv_cmp', which performs the "fast" -!! processes -!>author Shian-Jiann Lin, Linjiong Zhou - -! ======================================================================= -! cloud micro - physics package for gfdl global cloud resolving model -! the algorithms are originally derived from lin et al 1983. most of the -! key elements have been simplified / improved. this code at this stage -! bears little to no similarity to the original lin mp in zetac. -! therefore, it is best to be called gfdl micro - physics (gfdl mp) . -! developer: Shian-Jiann lin, Linjiong Zhou -! ======================================================================= - -module gfdl_cloud_microphys_mod - USE module_mp_radar - ! use diag_manager_mod, only: register_diag_field, send_data - ! use time_manager_mod, only: time_type, get_time - ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - implicit none - - private - - public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb - public cloud_diagnosis - - real :: missing_value = - 1.e10 - - logical :: module_is_initialized = .false. - logical :: qsmith_tables_initialized = .false. - - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' - - real, parameter :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real, parameter :: rhos = 0.1e3, rhog = 0.4e3 - real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity - real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air - real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor - real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure - real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation - real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion - real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - - ! real, parameter :: rdgas = 287.04 ! gfdl: gas constant for dry air - - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure - real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value - real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value - real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c - - real, parameter :: eps = rdgas / rvgas ! 0.6219934995 - real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 - - real, parameter :: t_ice = 273.16 !< freezing temperature - real, parameter :: table_ice = 273.16 !< freezing point for qs table - - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c - real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - - real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling - real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling - - real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 - real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel - - real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k - - real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - - real, parameter :: qrmin = 1.e-8 ! min value for ??? - real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) - real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - - real, parameter :: vr_min = 1.e-3 !< min fall speed for rain - real, parameter :: vf_min = 1.e-5 !< min fall speed for cloud ice, snow, graupel - - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height - - real, parameter :: sfcrho = 1.2 !< surface air density - real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - - real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions - real :: acco (3, 4) !< constants for accretions - real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) - - real :: es0, ces0 - real :: pie, rgrav, fac_rc - real :: c_air, c_vap - - real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk - - real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap - - ! cloud microphysics switchers - - integer :: icloud_f = 0 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .true. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .true. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_qa = .true. !< do inline cloud fraction - logical :: rad_snow = .true. !< consider snow in cloud fraciton calculation - logical :: rad_graupel = .true. !< consider graupel in cloud fraction calculation - logical :: rad_rain = .true. !< consider rain in cloud fraction calculation - logical :: fix_negative = .false. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters - logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density - - real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) - real, allocatable :: des (:), des2 (:), des3 (:), desw (:) - - logical :: tables_are_initialized = .false. - - ! logical :: master - ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, & - ! id_ice, id_prec, id_cond, id_var, id_droplets - real, parameter :: dt_fr = 8. !< homogeneous freezing of all cloud water at t_wfr - dt_fr - ! minimum temperature water can exist (moore & molinero nov. 2011, nature) - ! dt_fr can be considered as the error bar - - real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - - ! slj, the following parameters are for cloud - resolving resolution: 1 - 5 km - - ! qi0_crt = 0.8e-4 - ! qs0_crt = 0.6e-3 - ! c_psaci = 0.1 - ! c_pgacs = 0.1 - - ! ----------------------------------------------------------------------- - !> namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: t_min = 178. !< min temp to freeze - dry all water vapor - real :: t_sub = 184. !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - real :: rh_inc = 0.25 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.25 !< rh increment for minimum evaporation of rain - real :: rh_ins = 0.25 !< rh increment for sublimation of snow - - ! conversion time scale - - real :: tau_r2g = 900. !< rain freezing during fast_sat - real :: tau_smlt = 900. !< snow melting - real :: tau_g2r = 600. !< graupel melting to rain - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion - real :: tau_l2r = 900. !< cloud water to rain auto - conversion - real :: tau_v2l = 150. !< water vapor to cloud water (condensation) - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - - ! horizontal subgrid variability - - real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 90. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 270. !< ccn over land (cm^ - 3) - - real :: rthresh = 10.0e-6 !< critical cloud drop radius (micro m) - - ! ----------------------------------------------------------------------- - ! wrf / wsm6 scheme: qi_gen = 4.92e-11 * (1.e3 * exp (0.1 * tmp)) ** 1.33 - ! optimized: qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - ! qi_gen ~ 4.808e-7 at 0 c; 1.818e-6 at - 10 c, 9.82679e-5 at - 40c - ! the following value is constructed such that qc_crt = 0 at zero c and @ - 10c matches - ! wrf / wsm6 ice initiation scheme; qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den - ! ----------------------------------------------------------------------- - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - real :: ql_gen = 1.0e-3 !< max cloud water generation during remapping step if fast_sat_adj = .t. - real :: qi_gen = 1.82e-6 !< max cloud ice generation during remapping step - - ! cloud condensate upper bounds: "safety valves" for ql & qi - - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) - - real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) - !! qi0_crt is highly dependent on horizontal resolution - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 1.0e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 0.55 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - real :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.0 !< accretion: rain to ice: - real :: c_cracw = 0.9 !< rain accretion efficiency - real :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) - - ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) - - real :: alin = 842.0 !< "a" in lin1983 - real :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! good values: - - real :: vi_fac = 1. !< if const_vi: 1 / 3 - real :: vs_fac = 1. !< if const_vs: 1. - real :: vg_fac = 1. !< if const_vg: 2. - real :: vr_fac = 1. !< if const_vr: 4. - - ! upper bounds of fall speed (with variable speed option) - - real :: vi_max = 0.5 !< max fall speed for ice - real :: vs_max = 5.0 !< max fall speed for snow - real :: vg_max = 8.0 !< max fall speed for graupel - real :: vr_max = 12. !< max fall speed for rain - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions - logical :: use_ccn = .false. !< must be true when prog_ccn is false - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - - ! real :: global_area = - 1. - - real :: log_10, tice0, t_wfr - - integer :: reiflag = 1 - ! 1: Heymsfield and Mcfarquhar, 1996 - ! 2: Wyser, 1998 - - logical :: tintqs = .false. !< use temperature in the saturation mixing in PDF - - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 10.0, rermax = 10000.0 - real :: resmin = 150.0, resmax = 10000.0 - real :: regmin = 300.0, regmax = 10000.0 - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & - mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & - resmin, resmax, regmin, regmax, tintqs - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & - mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & - resmin, resmax, regmin, regmax, tintqs - -contains - -! ----------------------------------------------------------------------- -! the driver of the gfdl cloud microphysics -! ----------------------------------------------------------------------- - -!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL -!! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & - uin, vin, udt, vdt, dz, delp, area, dt_in, land, rain, snow, ice, & - graupel, hydrostatic, phys_hydrostatic, iis, iie, jjs, jje, kks, & - kke, ktop, kbot, seconds,p,lradar,refl_10cm,reset) - implicit none - - logical, intent (in) :: hydrostatic, phys_hydrostatic,lradar - integer, intent (in) :: iis, iie, jjs, jje !< physics window - integer, intent (in) :: kks, kke !< vertical dimension - integer, intent (in) :: ktop, kbot !< vertical compute domain - integer, intent (in) :: seconds - logical, intent (in) :: reset - - real, intent (in) :: dt_in !< physics time step - - real, intent (in), dimension (:, :) :: area !< cell area - real, intent (in), dimension (:, :) :: land !< land fraction - - real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin, p - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (:, :, :) :: qi, qs - real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w - real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt - real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt - - real, intent (out), dimension (:, :, :) :: refl_10cm - real, intent (out), dimension (:, :) :: rain, snow, ice, graupel - - logical :: melti = .false. - ! logical :: used - - real :: mpdt, rdt, dts, convt, tot_prec - - integer :: i, j, k - integer :: is, ie, js, je !< physics window - integer :: ks, ke !< vertical dimension - integer :: days, ntimes, kflip - - real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, dimension (size (pt, 1), size (pt, 3)) :: m2_rain, m2_sol - - real :: allmax -!+---+-----------------------------------------------------------------+ -!For 3D reflectivity calculations - REAL, DIMENSION(ktop:kbot):: qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ -!+---+-----------------------------------------------------------------+ - - is = 1 - js = 1 - ks = 1 - ie = iie - iis + 1 - je = jje - jjs + 1 - ke = kke - kks + 1 - ! call mpp_clock_begin (gfdl_mp_clock) - - ! ----------------------------------------------------------------------- - ! define heat capacity of dry air and water vapor based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (phys_hydrostatic .or. hydrostatic) then - c_air = cp_air - c_vap = cp_vap - p_nonhydro = .false. - else - c_air = cv_air - c_vap = cv_vap - p_nonhydro = .true. - endif - d0_vap = c_vap - c_liq - lv00 = hlv0 - d0_vap * t_ice - - if (hydrostatic) do_sedi_w = .false. - - ! ----------------------------------------------------------------------- - ! define latent heat coefficient used in wet bulb and bigg mechanism - ! ----------------------------------------------------------------------- - - latv = hlv - lati = hlf - lats = latv + lati - lat2 = lats * lats - - lcp = latv / cp_air - icp = lati / cp_air - tcp = (latv + lati) / cp_air - - ! tendency zero out for am moist processes should be done outside the driver - - ! ----------------------------------------------------------------------- - ! define cloud microphysics sub time step - ! ----------------------------------------------------------------------- - - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in - ntimes = nint (dt_in / mpdt) - - ! small time step: - dts = dt_in / real (ntimes) - - ! call get_time (time, seconds, days) - - ! ----------------------------------------------------------------------- - ! initialize precipitation - ! ----------------------------------------------------------------------- - - do j = js, je - do i = is, ie - graupel (i, j) = 0. - rain (i, j) = 0. - snow (i, j) = 0. - ice (i, j) = 0. - cond (i, j) = 0. - enddo - enddo - - ! ----------------------------------------------------------------------- - ! major cloud microphysics - ! ----------------------------------------------------------------------- - - do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - m2_sol, cond (:, j), area (:, j), land (:, j), udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & - vt_s, vt_g, vt_i, qn2) - enddo - - ! ----------------------------------------------------------------------- - ! no clouds allowed above ktop - ! ----------------------------------------------------------------------- - - if (ks < ktop) then - do k = ks, ktop - if (do_qa) then - do j = js, je - do i = is, ie - qa_dt (i, j, k) = 0. - enddo - enddo - else - do j = js, je - do i = is, ie - ! qa_dt (i, j, k) = - qa (i, j, k) * rdt - qa_dt (i, j, k) = 0. ! gfs - enddo - enddo - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! diagnostic output - ! ----------------------------------------------------------------------- - - ! if (id_vtr > 0) then - ! used = send_data (id_vtr, vt_r, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vts > 0) then - ! used = send_data (id_vts, vt_s, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vtg > 0) then - ! used = send_data (id_vtg, vt_g, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vti > 0) then - ! used = send_data (id_vti, vt_i, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_droplets > 0) then - ! used = send_data (id_droplets, qn2, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_var > 0) then - ! used = send_data (id_var, w_var, time, is_in = iis, js_in = jjs) - ! endif - - ! convert to mm / day - - convt = 86400. * rdt * rgrav - do j = js, je - do i = is, ie - rain (i, j) = rain (i, j) * convt - snow (i, j) = snow (i, j) * convt - ice (i, j) = ice (i, j) * convt - graupel (i, j) = graupel (i, j) * convt - prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) - enddo - enddo - - ! if (id_cond > 0) then - ! do j = js, je - ! do i = is, ie - ! cond (i, j) = cond (i, j) * rgrav - ! enddo - ! enddo - ! used = send_data (id_cond, cond, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_snow > 0) then - ! used = send_data (id_snow, snow, time, iis, jjs) - ! used = send_data (id_snow, snow, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (snow, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean snow = ', tot_prec - ! endif - ! endif - ! - ! if (id_graupel > 0) then - ! used = send_data (id_graupel, graupel, time, iis, jjs) - ! used = send_data (id_graupel, graupel, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (graupel, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean graupel = ', tot_prec - ! endif - ! endif - ! - ! if (id_ice > 0) then - ! used = send_data (id_ice, ice, time, iis, jjs) - ! used = send_data (id_ice, ice, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (ice, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean ice_mp = ', tot_prec - ! endif - ! endif - ! - ! if (id_rain > 0) then - ! used = send_data (id_rain, rain, time, iis, jjs) - ! used = send_data (id_rain, rain, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (rain, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'mean rain = ', tot_prec - ! endif - ! endif - ! - ! if (id_rh > 0) then !not used? - ! used = send_data (id_rh, rh0, time, iis, jjs) - ! used = send_data (id_rh, rh0, time, is_in = iis, js_in = jjs) - ! endif - ! - ! - ! if (id_prec > 0) then - ! used = send_data (id_prec, prec_mp, time, iis, jjs) - ! used = send_data (id_prec, prec_mp, time, is_in = iis, js_in = jjs) - ! endif - - ! if (mp_print) then - ! prec1 (:, :) = prec1 (:, :) + prec_mp (:, :) - ! if (seconds == 0) then - ! prec1 (:, :) = prec1 (:, :) * dt_in / 86400. - ! tot_prec = g_sum (prec1, is, ie, js, je, area, 1) - ! if (master) write (*, *) 'daily prec_mp = ', tot_prec - ! prec1 (:, :) = 0. - ! endif - ! endif - - ! call mpp_clock_end (gfdl_mp_clock) - if(lradar) then - ! Only set melti to true at the output times - if (reset) then - melti = .true. - else - melti = .false. - endif - do j = js, je - do i = is, ie - do k = ktop,kbot - kflip = kbot-ktop+1-k+1 - t1d(k) = pt(i,j,kflip) - p1d(k) = p(i,j,kflip) - qv1d(k) = qv(i,j,kflip)/(1-qv(i,j,kflip)) - qr1d(k) = qr(i,j,kflip) - qs1d(k) = qs(i,j,kflip) - qg1d(k) = qg(i,j,kflip) - enddo - call refl10cm_gfdl (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, ktop, kbot, i,j, melti) - do k = ktop,kbot - kflip = kbot-ktop+1-k+1 - refl_10cm(i,j,kflip) = MAX(-35., dBZ(k)) - enddo - enddo - enddo - endif - - -end subroutine gfdl_cloud_microphys_driver - -! ----------------------------------------------------------------------- -!>@brief gfdl cloud microphysics, major program -!>@details lin et al., 1983, jam, 1065 - 1092, and -!! rutledge and hobbs, 1984, jas, 2949 - 2972 -!! terminal fall is handled lagrangianly by conservative fv algorithm -!>@param pt: temperature (k) -!>@param 6 water species: -!>@param 1) qv: water vapor (kg / kg) -!>@param 2) ql: cloud water (kg / kg) -!>@param 3) qr: rain (kg / kg) -!>@param 4) qi: cloud ice (kg / kg) -!>@param 5) qs: snow (kg / kg) -!>@param 6) qg: graupel (kg / kg) -! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & - w_var, vt_r, vt_s, vt_g, vt_i, qn2) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: j, is, ie, js, je, ks, ke - integer, intent (in) :: ntimes, ktop, kbot - - real, intent (in) :: dt_in - - real, intent (in), dimension (is:) :: area1, land - - real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (is:, js:, ks:) :: qi, qs - real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt - real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt - - real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond - - real, intent (out), dimension (is:, js:) :: w_var - - real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, intent (out), dimension (is:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz - real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz - real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 - real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 - real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1 - real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - - real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 - real :: dt_rain, dts - real :: s_leng, t_land, t_ocean, h_var - real :: cvm, tmp, omq - real :: dqi, qio, qin - - integer :: i, k, n - - dts = dt_in / real (ntimes) - dt_rain = dts * 0.5 - rdt = 1. / dt_in - - ! ----------------------------------------------------------------------- - ! use local variables - ! ----------------------------------------------------------------------- - - do i = is, ie - - do k = ktop, kbot - qiz (k) = qi (i, j, k) - qsz (k) = qs (i, j, k) - enddo - - ! ----------------------------------------------------------------------- - ! this is to prevent excessive build - up of cloud ice from external sources - ! ----------------------------------------------------------------------- - - if (de_ice) then - do k = ktop, kbot - qio = qiz (k) - dt_in * qi_dt (i, j, k) ! original qi before phys - qin = max (qio, qi0_max) ! adjusted value - if (qiz (k) > qin) then - qsz (k) = qsz (k) + qiz (k) - qin - qiz (k) = qin - dqi = (qin - qio) * rdt ! modified qi tendency - qs_dt (i, j, k) = qs_dt (i, j, k) + qi_dt (i, j, k) - dqi - qi_dt (i, j, k) = dqi - qi (i, j, k) = qiz (k) - qs (i, j, k) = qsz (k) - endif - enddo - endif - - do k = ktop, kbot - - t0 (k) = pt (i, j, k) - tz (k) = t0 (k) - dp1 (k) = delp (i, j, k) - dp0 (k) = dp1 (k) ! moist air mass * grav - - ! ----------------------------------------------------------------------- - ! convert moist mixing ratios to dry mixing ratios - ! ----------------------------------------------------------------------- - - qvz (k) = qv (i, j, k) - qlz (k) = ql (i, j, k) - qrz (k) = qr (i, j, k) - qgz (k) = qg (i, j, k) - - ! dp1: dry air_mass - ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) - dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs - omq = dp0 (k) / dp1 (k) - - qvz (k) = qvz (k) * omq - qlz (k) = qlz (k) * omq - qrz (k) = qrz (k) * omq - qiz (k) = qiz (k) * omq - qsz (k) = qsz (k) * omq - qgz (k) = qgz (k) * omq - - qa0 (k) = qa (i, j, k) - qaz (k) = 0. - dz0 (k) = dz (i, j, k) - - den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air - p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure - - ! ----------------------------------------------------------------------- - ! save a copy of old value for computing tendencies - ! ----------------------------------------------------------------------- - - qv0 (k) = qvz (k) - ql0 (k) = qlz (k) - qr0 (k) = qrz (k) - qi0 (k) = qiz (k) - qs0 (k) = qsz (k) - qg0 (k) = qgz (k) - - ! ----------------------------------------------------------------------- - ! for sedi_momentum - ! ----------------------------------------------------------------------- - - m1 (k) = 0. - u0 (k) = uin (i, j, k) - v0 (k) = vin (i, j, k) - u1 (k) = u0 (k) - v1 (k) = v0 (k) - - enddo - - if (do_sedi_w) then - do k = ktop, kbot - w1 (k) = w (i, j, k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate cloud condensation nuclei (ccn) - ! the following is based on klein eq. 15 - ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - if (prog_ccn) then - do k = ktop, kbot - ! convert # / cc to # / m^3 - ccn (k) = qn (i, j, k) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - use_ccn = .false. - else - ccn0 = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - if (use_ccn) then - ! ----------------------------------------------------------------------- - ! ccn is formulted as ccn = ccn_surface * (den / den_surface) - ! ----------------------------------------------------------------------- - ccn0 = ccn0 * rdgas * tz (kbot) / p1 (kbot) - endif - tmp = cpaut * (ccn0 * rhor) ** (- 1. / 3.) - do k = ktop, kbot - c_praut (k) = tmp - ccn (k) = ccn0 - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate horizontal subgrid variability - ! total water subgrid deviation in horizontal direction - ! default area dependent form: use dx ~ 100 km as the base - ! ----------------------------------------------------------------------- - - s_leng = sqrt (sqrt (area1 (i) / 1.e10)) - t_land = dw_land * s_leng - t_ocean = dw_ocean * s_leng - h_var = t_land * land (i) + t_ocean * (1. - land (i)) - h_var = min (0.20, max (0.01, h_var)) - ! if (id_var > 0) w_var (i, j) = h_var - - ! ----------------------------------------------------------------------- - ! relative humidity increment - ! ----------------------------------------------------------------------- - - rh_adj = 1. - h_var - rh_inc - rh_rain = max (0.35, rh_adj - rh_inr) ! rh_inr = 0.25 - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - m2_rain (i, :) = 0. - m2_sol (i, :) = 0. - - do n = 1, ntimes - - ! ----------------------------------------------------------------------- - ! define air density based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (p_nonhydro) then - do k = ktop, kbot - dz1 (k) = dz0 (k) - den (k) = den0 (k) ! dry air density remains the same - denfac (k) = sqrt (sfcrho / den (k)) - enddo - else - do k = ktop, kbot - dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance - den (k) = den0 (k) * dz0 (k) / dz1 (k) - denfac (k) = sqrt (sfcrho / den (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! time - split warm rain processes: 1st pass - ! ----------------------------------------------------------------------- - - call warm_rain (dt_rain, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - m2_rain (i, k) = m2_rain (i, k) + m1_rain (k) - m1 (k) = m1 (k) + m1_rain (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation of cloud ice, snow, and graupel - ! ----------------------------------------------------------------------- - - call fall_speed (ktop, kbot, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) - - call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & - dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) - - rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground - snow (i) = snow (i) + s1 - graupel (i) = graupel (i) + g1 - ice (i) = ice (i) + i1 - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & - qsz, qgz, c_ice) - - ! ----------------------------------------------------------------------- - ! time - split warm rain processes: 2nd pass - ! ----------------------------------------------------------------------- - - call warm_rain (dt_rain, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, den, denfac, ccn, c_praut, rh_rain, vtrz, r1, m1_rain, w1, h_var) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - m2_rain (i, k) = m2_rain (i, k) + m1_rain (k) - m2_sol (i, k) = m2_sol (i, k) + m1_sol (k) - m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) - enddo - - ! ----------------------------------------------------------------------- - ! ice - phase microphysics - ! ----------------------------------------------------------------------- - - call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & - denfac, vtsz, vtgz, vtrz, qaz, rh_adj, rh_rain, dts, h_var) - - enddo - - ! convert units from Pa*kg/kg to kg/m^2/s - m2_rain (i, :) = m2_rain (i, :) * rdt * rgrav - m2_sol (i, :) = m2_sol (i, :) * rdt * rgrav - - ! ----------------------------------------------------------------------- - ! momentum transportation during sedimentation - ! note: dp1 is dry mass; dp0 is the old moist (total) mass - ! ----------------------------------------------------------------------- - - if (sedi_transport) then - do k = ktop + 1, kbot - u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt - v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - w (i, j, k) = w1 (k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! update moist air mass (actually hydrostatic pressure) - ! convert to dry mixing ratios - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - omq = dp1 (k) / dp0 (k) - qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq - ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq - qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq - qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq - qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq - qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq - cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice - pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air - enddo - - ! ----------------------------------------------------------------------- - ! update cloud fraction tendency - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (do_qa) then - qa_dt (i, j, k) = 0. - else - qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * (qaz (k) / real (ntimes) - qa0 (k)) - endif - enddo - - ! ----------------------------------------------------------------------- - ! fms diagnostics: - ! ----------------------------------------------------------------------- - - ! if (id_cond > 0) then - ! do k = ktop, kbot ! total condensate - ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) - ! enddo - ! endif - ! - ! if (id_vtr > 0) then - ! do k = ktop, kbot - ! vt_r (i, j, k) = vtrz (k) - ! enddo - ! endif - ! - ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_s (i, j, k) = vtsz (k) - ! enddo - ! endif - ! - ! if (id_vtg > 0) then - ! do k = ktop, kbot - ! vt_g (i, j, k) = vtgz (k) - ! enddo - ! endif - ! - ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_i (i, j, k) = vtiz (k) - ! enddo - ! endif - ! - ! if (id_droplets > 0) then - ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) - ! enddo - ! endif - - enddo - -end subroutine mpdrv - -! ----------------------------------------------------------------------- -!> sedimentation of heat -! ----------------------------------------------------------------------- - -subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - - implicit none - - ! input q fields are dry mixing ratios, and dm is dry air mass - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - - real, intent (inout), dimension (ktop:kbot) :: tz - - real, intent (in) :: cw ! heat capacity - - real, dimension (ktop:kbot) :: dgz, cvn - - real :: tmp - - integer :: k - - do k = ktop, kbot - dgz (k) = - 0.5 * grav * dz (k) ! > 0 - cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & - c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) - enddo - - ! ----------------------------------------------------------------------- - ! sjl, july 2014 - ! assumption: the ke in the falling condensates is negligible compared to the potential energy - ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed - ! into internal energy (to heat the whole grid box) - ! backward time - implicit upwind transport scheme: - ! dm here is dry air mass - ! ----------------------------------------------------------------------- - - k = ktop - tmp = cvn (k) + m1 (k) * cw - tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp - - ! ----------------------------------------------------------------------- - ! implicit algorithm: can't be vectorized - ! needs an inner i - loop for vectorization - ! ----------------------------------------------------------------------- - - do k = ktop + 1, kbot - tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & - cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) - enddo - -end subroutine sedi_heat - -! ----------------------------------------------------------------------- -!> warm rain cloud microphysics -! ----------------------------------------------------------------------- - -subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, & - den, denfac, ccn, c_praut, rh_rain, vtr, r1, m1_rain, w1, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt !< time step (s) - real, intent (in) :: rh_rain, h_var - - real, intent (in), dimension (ktop:kbot) :: dp, dz, den - real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut - - real, intent (inout), dimension (ktop:kbot) :: tz, vtr - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg - real, intent (inout), dimension (ktop:kbot) :: m1_rain, w1 - - real, intent (out) :: r1 - - real, parameter :: so3 = 7. / 3. - - real, dimension (ktop:kbot) :: dl, dm - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: sink, dq, qc0, qc - real :: qden - real :: zs = 0. - real :: dt5 - - integer :: k - - ! fall velocity constants: - - real, parameter :: vconr = 2503.23638966667 - real, parameter :: normr = 25132741228.7183 - real, parameter :: thr = 1.e-8 - - logical :: no_fall - - dt5 = 0.5 * dt - - ! ----------------------------------------------------------------------- - ! terminal speed of rain - ! ----------------------------------------------------------------------- - - m1_rain (:) = 0. - - call check_column (ktop, kbot, qr, no_fall) - - if (no_fall) then - vtr (:) = vf_min - r1 = 0. - else - - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (const_vr) then - vtr (:) = vr_fac ! ifs_2016: 4.0 - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - ! if (.not. fast_sat_adj) & - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var) - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vtr (k - 1) + vtr (k)) - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var) - - endif - - ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qc0 = fac_rc * ccn (k) - if (tz (k) > t_wfr) then - if (use_ccn) then - ! ----------------------------------------------------------------------- - ! ccn is formulted as ccn = ccn_surface * (den / den_surface) - ! ----------------------------------------------------------------------- - qc = qc0 - else - qc = qc0 / den (k) - endif - dq = ql (k) - qc - if (dq > 0.) then - sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid varaibility - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - qc0 = fac_rc * ccn (k) - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (1.e-6, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - if (use_ccn) then - ! -------------------------------------------------------------------- - ! ccn is formulted as ccn = ccn_surface * (den / den_surface) - ! -------------------------------------------------------------------- - qc = qc0 - else - qc = qc0 / den (k) - endif - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - endif - enddo - endif - -end subroutine warm_rain - -! ----------------------------------------------------------------------- -!> evaporation of rain -! ----------------------------------------------------------------------- - -subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt ! time step (s) - real, intent (in) :: rh_rain, h_var - - real, intent (in), dimension (ktop:kbot) :: den, denfac - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg - - real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk - - real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink - real :: qpz, dq, dqh, tin - - integer :: k - - do k = ktop, kbot - - if (tz (k) > t_wfr .and. qr (k) > qrmin) then - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the gird box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! ----------------------------------------------------------------------- - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (k) * den (k) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & - exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) - evap = min (qr (k), dt * evap, dqv / (1. + lcpk (k) * dqsdt)) - ! ----------------------------------------------------------------------- - ! alternative minimum evap in dry environmental air - ! sink = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqsdt)) - ! evap = max (evap, sink) - ! ----------------------------------------------------------------------- - qr (k) = qr (k) - evap - qv (k) = qv (k) + evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - ! if (qr (k) > qrmin .and. ql (k) > 1.e-7 .and. qsat < q_plus) then - if (qr (k) > qrmin .and. ql (k) > 1.e-6 .and. qsat < q_minus) then - sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - - endif ! warm - rain - enddo - -end subroutine revap_racc - -! ----------------------------------------------------------------------- -!> definition of vertical subgrid variability -!! used for cloud ice and cloud water autoconversion -!! qi -- > ql & ql -- > qr -!! edges: qe == qbar + / - dm -! ----------------------------------------------------------------------- - -subroutine linear_prof (km, q, dm, z_var, h_var) - - implicit none - - integer, intent (in) :: km - - real, intent (in) :: q (km), h_var - - real, intent (out) :: dm (km) - - logical, intent (in) :: z_var - - real :: dq (km) - - integer :: k - - if (z_var) then - do k = 2, km - dq (k) = 0.5 * (q (k) - q (k - 1)) - enddo - dm (1) = 0. - - ! ----------------------------------------------------------------------- - ! use twice the strength of the positive definiteness limiter (lin et al 1994) - ! ----------------------------------------------------------------------- - - do k = 2, km - 1 - dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) - if (dq (k) * dq (k + 1) <= 0.) then - if (dq (k) > 0.) then ! local max - dm (k) = min (dm (k), dq (k), - dq (k + 1)) - else - dm (k) = 0. - endif - endif - enddo - dm (km) = 0. - - ! ----------------------------------------------------------------------- - ! impose a presumed background horizontal variability that is proportional to the value itself - ! ----------------------------------------------------------------------- - - do k = 1, km - dm (k) = max (dm (k), qvmin, h_var * q (k)) - enddo - else - do k = 1, km - dm (k) = max (qvmin, h_var * q (k)) - enddo - endif - -end subroutine linear_prof - -! ======================================================================= -!> ice cloud microphysics processes -!! bulk cloud micro - physics; processes splitting -!! with some un - split sub - grouping -!! time implicit (when possible) accretion and autoconversion -!>@author: Shian-Jiann lin, gfdl -! ======================================================================= - -subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, rh_adj, rh_rain, dts, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - - real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak - - real, intent (in) :: rh_adj, rh_rain, dts, h_var - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - - real :: rdts, fac_g2v, fac_v2g, fac_i2s, fac_imlt - real :: tz, qv, ql, qr, qi, qs, qg, melt - real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci - real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub - real :: tc, tsq, dqs0, qden, qim, qsm - real :: dt5, factor, sink, qi_crt - real :: tmp, qsw, qsi, dqsdt, dq - real :: dtmp, qc, q_plus, q_minus - - integer :: k - - dt5 = 0.5 * dts - - rdts = 1. / dts - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - - fac_imlt = 1. - exp (- dt5 / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhi (k) = li00 + dc_ice * tzk (k) - q_liq (k) = qlk (k) + qrk (k) - q_sol (k) = qik (k) + qsk (k) + qgk (k) - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! sources of cloud ice: pihom, cold rain, and the sat_adj - ! (initiation plus deposition) - ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) - ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (tzk (k) > tice .and. qik (k) > qcmin) then - - ! ----------------------------------------------------------------------- - ! pimlt: instant melting of cloud ice - ! ----------------------------------------------------------------------- - - melt = min (qik (k), fac_imlt * (tzk (k) - tice) / icpk (k)) - tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount - qlk (k) = qlk (k) + tmp - qrk (k) = qrk (k) + melt - tmp - qik (k) = qik (k) - melt - q_liq (k) = q_liq (k) + melt - q_sol (k) = q_sol (k) - melt - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - - elseif (tzk (k) < t_wfr .and. qlk (k) > qcmin) then - - ! ----------------------------------------------------------------------- - ! pihom: homogeneous freezing of cloud water into cloud ice - ! this is the 1st occurance of liquid water freezing in the split mp process - ! ----------------------------------------------------------------------- - - dtmp = t_wfr - tzk (k) - factor = min (1., dtmp / dt_fr) - sink = min (qlk (k) * factor, dtmp / icpk (k)) - qi_crt = qi_gen * min (qi_lim, 0.1 * (tice - tzk (k))) / den (k) - tmp = min (sink, dim (qi_crt, qik (k))) - qlk (k) = qlk (k) - sink - qsk (k) = qsk (k) + sink - tmp - qik (k) = qik (k) + tmp - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + sink * lhi (k) / cvm (k) - - endif - enddo - - ! ----------------------------------------------------------------------- - ! vertical subgrid variability - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tzk (k) - lhi (k) = li00 + dc_ice * tzk (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! do nothing above p_min - ! ----------------------------------------------------------------------- - - if (p1 (k) < p_min) cycle - - tz = tzk (k) - qv = qvk (k) - ql = qlk (k) - qi = qik (k) - qr = qrk (k) - qs = qsk (k) - qg = qgk (k) - - pgacr = 0. - pgacw = 0. - tc = tz - tice - - if (tc .ge. 0.) then - - ! ----------------------------------------------------------------------- - ! melting of snow - ! ----------------------------------------------------------------------- - - dqs0 = ces0 / p1 (k) - qv - - if (qs > qcmin) then - - ! ----------------------------------------------------------------------- - ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. - ! ----------------------------------------------------------------------- - - if (ql > qrmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate - else - psacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! psacr: accretion of rain by melted snow - ! pracs: accretion of snow by rain - ! ----------------------------------------------------------------------- - - if (qr > qrmin) then - psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & - den (k)), qr * rdts) - pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) - else - psacr = 0. - pracs = 0. - endif - - ! ----------------------------------------------------------------------- - ! total snow sink: - ! psmlt: snow melt (due to rain accretion) - ! ----------------------------------------------------------------------- - - psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & - den (k), denfac (k))) - sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) - qs = qs - sink - ! sjl, 20170321: - tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - ql = ql + tmp - qr = qr + sink - tmp - ! qr = qr + sink - ! sjl, 20170321: - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! melting of graupel - ! ----------------------------------------------------------------------- - - if (qg > qcmin .and. tc > 0.) then - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qrmin) & - pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), rdts * qr) - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - qden = qg * den (k) - if (ql > qrmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate - endif - - ! ----------------------------------------------------------------------- - ! pgmlt: graupel melt - ! ----------------------------------------------------------------------- - - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) - pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) - qg = qg - pgmlt - qr = qr + pgmlt - q_liq (k) = q_liq (k) + pgmlt - q_sol (k) = q_sol (k) - pgmlt - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - pgmlt * lhi (k) / cvm (k) - - endif - - else - - ! ----------------------------------------------------------------------- - ! cloud ice proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psaci: accretion of cloud ice by snow - ! ----------------------------------------------------------------------- - - if (qi > 3.e-7) then ! cloud ice sink terms - - if (qs > 1.e-7) then - ! ----------------------------------------------------------------------- - ! sjl added (following lin eq. 23) the temperature dependency - ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 - ! ----------------------------------------------------------------------- - factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi - else - psaci = 0. - endif - - ! ----------------------------------------------------------------------- - ! pasut: autoconversion: cloud ice -- > snow - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4 - ! ----------------------------------------------------------------------- - - qim = qi0_crt / den (k) - - ! ----------------------------------------------------------------------- - ! assuming linear subgrid vertical distribution of cloud ice - ! the mismatch computation following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - - di (k) = max (di (k), qrmin) - q_plus = qi + di (k) - if (q_plus > (qim + qrmin)) then - if (qim > (qi - di (k))) then - dq = (0.25 * (q_plus - qim) ** 2) / di (k) - else - dq = qi - qim - endif - psaut = tmp * dq - else - psaut = 0. - endif - ! ----------------------------------------------------------------------- - ! sink is no greater than 75% of qi - ! ----------------------------------------------------------------------- - sink = min (0.75 * qi, psaci + psaut) - qi = qi - sink - qs = qs + sink - - ! ----------------------------------------------------------------------- - ! pgaci: accretion of cloud ice by graupel - ! ----------------------------------------------------------------------- - - if (qg > 1.e-6) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi - qi = qi - pgaci - qg = qg + pgaci - endif - - endif - - ! ----------------------------------------------------------------------- - ! cold - rain proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain to ice, snow, graupel processes: - ! ----------------------------------------------------------------------- - - tc = tz - tice - - if (qr > 1.e-7 .and. tc < 0.) then - - ! ----------------------------------------------------------------------- - ! * sink * terms to qr: psacr + pgfr - ! source terms to qs: psacr - ! source terms to qg: pgfr - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psacr accretion of rain by snow - ! ----------------------------------------------------------------------- - - if (qs > 1.e-7) then ! if snow exists - psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) - else - psacr = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgfr: rain freezing -- > graupel - ! ----------------------------------------------------------------------- - - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp (1.75 * log (qr * den (k))) - - ! ----------------------------------------------------------------------- - ! total sink to qr - ! ----------------------------------------------------------------------- - - sink = psacr + pgfr - factor = min (sink, qr, - tc / icpk (k)) / max (sink, qrmin) - - psacr = factor * psacr - pgfr = factor * pgfr - - sink = psacr + pgfr - qr = qr - sink - qs = qs + psacr - qg = qg + pgfr - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! graupel production terms: - ! ----------------------------------------------------------------------- - - if (qs > 1.e-7) then - - ! ----------------------------------------------------------------------- - ! accretion: snow -- > graupel - ! ----------------------------------------------------------------------- - - if (qg > qrmin) then - sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) - else - sink = 0. - endif - - ! ----------------------------------------------------------------------- - ! autoconversion snow -- > graupel - ! ----------------------------------------------------------------------- - - qsm = qs0_crt / den (k) - if (qs > qsm) then - factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) - endif - sink = min (qs, sink) - qs = qs - sink - qg = qg + sink - - endif ! snow existed - - if (qg > 1.e-7 .and. tz < tice0) then - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - if (ql > 1.e-6) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql - else - pgacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > 1.e-6) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), qr) - else - pgacr = 0. - endif - - sink = pgacr + pgacw - factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qrmin) - pgacr = factor * pgacr - pgacw = factor * pgacw - - sink = pgacr + pgacw - qg = qg + sink - qr = qr - pgacr - ql = ql - pgacw - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - endif - - tzk (k) = tz - qvk (k) = qv - qlk (k) = ql - qik (k) = qi - qrk (k) = qr - qsk (k) = qs - qgk (k) = qg - - enddo - - ! ----------------------------------------------------------------------- - ! subgrid cloud microphysics - ! ----------------------------------------------------------------------- - - call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, h_var, rh_rain) - -end subroutine icloud - -! ======================================================================= -!>temperature sentive high vertical resolution processes -! ======================================================================= - -subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, rh_adj, tz, qv, & - ql, qr, qi, qs, qg, qa, h_var, rh_rain) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - - real, intent (in) :: dts, rh_adj, h_var, rh_rain - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - - real :: fac_v2l, fac_l2v - - real :: pidep, qi_crt - - ! ----------------------------------------------------------------------- - ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty - ! must not be too large to allow psc - ! ----------------------------------------------------------------------- - - real :: rh, rqi, tin, qsw, qsi, qpz, qstar - real :: dqsdt, dwsdt, dq, dq0, factor, tmp - real :: q_plus, q_minus, dt_evap, dt_pisub - real :: evap, sink, tc, pisub, q_adj, dtmp - real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g - - integer :: k - - if (fast_sat_adj) then - dt_evap = 0.5 * dts - else - dt_evap = dts - endif - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_v2l = 1. - exp (- dt_evap / tau_v2l) - fac_l2v = 1. - exp (- dt_evap / tau_l2v) - - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - enddo - - do k = ktop, kbot - - if (p1 (k) < p_min) cycle - - ! ----------------------------------------------------------------------- - ! instant deposit all water vapor to cloud ice when temperature is super low - ! ----------------------------------------------------------------------- - - if (tz (k) < t_min) then - sink = dim (qv (k), 1.e-7) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - if (.not. do_qa) qa (k) = qa (k) + 1. ! air fully saturated; 100 % cloud cover - cycle - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - - ! ----------------------------------------------------------------------- - ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free - ! ----------------------------------------------------------------------- - - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - if (tin > t_sub + 6.) then - rh = qpz / iqs1 (tin, den (k)) - if (rh < rh_adj) then ! qpz / rh_adj < qs - tz (k) = tin - qv (k) = qpz - ql (k) = 0. - qi (k) = 0. - cycle ! cloud free - endif - endif - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: - ! ----------------------------------------------------------------------- - - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > 0.) then - ! SJL 20170703 added ql factor to prevent the situation of high ql and low RH - ! factor = min (1., fac_l2v * sqrt (max (0., ql (k)) / 1.e-5) * 10. * dq0 / qsw) - ! factor = fac_l2v - ! factor = 1 - factor = min (1., fac_l2v * (10. * dq0 / qsw)) ! the rh dependent factor = 1 at 90% - evap = min (ql (k), factor * dq0 / (1. + tcp3 (k) * dwsdt)) - else ! condensate all excess vapor into cloud water - ! ----------------------------------------------------------------------- - ! evap = fac_v2l * dq0 / (1. + tcp3 (k) * dwsdt) - ! sjl, 20161108 - ! ----------------------------------------------------------------------- - evap = dq0 / (1. + tcp3 (k) * dwsdt) - endif - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! enforce complete freezing below - 48 c - ! ----------------------------------------------------------------------- - - dtmp = t_wfr - tz (k) ! [ - 40, - 48] - if (dtmp > 0. .and. ql (k) > qcmin) then - sink = min (ql (k), ql (k) * dtmp * 0.125, dtmp / icpk (k)) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! bigg mechanism - ! ----------------------------------------------------------------------- - - if (fast_sat_adj) then - dt_pisub = 0.5 * dts - else - dt_pisub = dts - tc = tice - tz (k) - if (ql (k) > qrmin .and. tc > 0.) then - sink = 3.3333e-10 * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) - sink = min (ql (k), tc / icpk (k), sink) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif ! significant ql existed - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of ice - ! ----------------------------------------------------------------------- - - if (tz (k) < tice) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = qv (k) - qsi - sink = dq / (1. + tcpk (k) * dqsdt) - if (qi (k) > qrmin) then - ! eq 9, hong et al. 2004, mwr - ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) - pidep = dt_pisub * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & - / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) - else - pidep = 0. - endif - if (dq > 0.) then ! vapor - > ice - tmp = tice - tz (k) - ! 20160912: the following should produce more ice at higher altitude - ! qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) / den (k) - qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den (k) - sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) - else ! ice -- > vapor - pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) - sink = max (pidep, sink, - qi (k)) - endif - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of snow - ! this process happens for all temp rage - ! ----------------------------------------------------------------------- - - if (qs (k) > qrmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - qden = qs (k) * den (k) - tmp = exp (0.65625 * log (qden)) - tsq = tz (k) * tz (k) - dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) - pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & - sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) - pssub = (qsi - qv (k)) * dts * pssub - if (pssub > 0.) then ! qs -- > qv, sublimation - pssub = min (pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) - else - if (tz (k) > tice) then - pssub = 0. ! no deposition - else - pssub = max (pssub, dq, (tz (k) - tice) / tcpk (k)) - endif - endif - qs (k) = qs (k) - pssub - qv (k) = qv (k) + pssub - q_sol (k) = q_sol (k) - pssub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! simplified 2 - way grapuel sublimation - deposition mechanism - ! ----------------------------------------------------------------------- - - if (qg (k) > qrmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) - pgsub = (qv (k) / qsi - 1.) * qg (k) - if (pgsub > 0.) then ! deposition - if (tz (k) > tice) then - pgsub = 0. ! no deposition - else - pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & - (tice - tz (k)) / tcpk (k)) - endif - else ! submilation - pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) - endif - qg (k) = qg (k) + pgsub - qv (k) = qv (k) - pgsub - q_sol (k) = q_sol (k) + pgsub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) - endif - -#ifdef USE_MIN_EVAP - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! * minimum evap of rain in dry environmental air - ! ----------------------------------------------------------------------- - - if (qr (k) > qcmin) then - qsw = wqs2 (tz (k), den (k), dqsdt) - sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) - qv (k) = qv (k) + sink - qr (k) = qr (k) - sink - q_liq (k) = q_liq (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhl (k) / cvm (k) - endif -#endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! compute cloud fraction - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! combine water species - ! ----------------------------------------------------------------------- - - if (do_qa) cycle - - if (rad_snow) then - q_sol (k) = qi (k) + qs (k) - else - q_sol (k) = qi (k) - endif - if (rad_rain) then - q_liq (k) = ql (k) + qr (k) - else - q_liq (k) = ql (k) - endif - q_cond (k) = q_liq (k) + q_sol (k) - - qpz = qv (k) + q_cond (k) ! qpz is conserved - - ! ----------------------------------------------------------------------- - ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - ! ----------------------------------------------------------------------- - - tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature - ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & - ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - - ! ----------------------------------------------------------------------- - ! determine saturated specific humidity - ! ----------------------------------------------------------------------- - - if (tin <= t_wfr) then - ! ice phase: - qstar = iqs1 (tin, den (k)) - elseif (tin >= tice) then - ! liquid phase: - qstar = wqs1 (tin, den (k)) - else - ! mixed phase: - qsi = iqs1 (tin, den (k)) - qsw = wqs1 (tin, den (k)) - if (q_cond (k) > 3.e-6) then - rqi = q_sol (k) / q_cond (k) - else - ! ----------------------------------------------------------------------- - ! mostly liquid water q_cond (k) at initial cloud development stage - ! ----------------------------------------------------------------------- - rqi = (tice - tin) / (tice - t_wfr) - endif - qstar = rqi * qsi + (1. - rqi) * qsw - endif - - ! ----------------------------------------------------------------------- - ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the - ! binary cloud scheme - ! ----------------------------------------------------------------------- - - if (qpz > qrmin) then - ! partial cloudiness by pdf: - dq = max (qcmin, h_var * qpz) - q_plus = qpz + dq ! cloud free if qstar > q_plus - q_minus = qpz - dq - if (qstar < q_minus) then - qa (k) = qa (k) + 1. ! air fully saturated; 100 % cloud cover - elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then - qa (k) = qa (k) + (q_plus - qstar) / (dq + dq) ! partial cloud cover - ! qa (k) = sqrt (qa (k) + (q_plus - qstar) / (dq + dq)) - endif - endif - - enddo - -end subroutine subgrid_z_proc - -! ======================================================================= -!> rain evaporation -! ======================================================================= - -subroutine revap_rac1 (hydrostatic, is, ie, dt, tz, qv, ql, qr, qi, qs, qg, den, hvar) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: is, ie - - real, intent (in) :: dt ! time step (s) - - real, intent (in), dimension (is:ie) :: den, hvar, qi, qs, qg - - real, intent (inout), dimension (is:ie) :: tz, qv, qr, ql - - real, dimension (is:ie) :: lcp2, denfac, q_liq, q_sol, cvm, lhl - - real :: dqv, qsat, dqsdt, evap, qden, q_plus, q_minus, sink - real :: tin, t2, qpz, dq, dqh - - integer :: i - - ! ----------------------------------------------------------------------- - ! define latend heat coefficient - ! ----------------------------------------------------------------------- - - do i = is, ie - lhl (i) = lv00 + d0_vap * tz (i) - q_liq (i) = ql (i) + qr (i) - q_sol (i) = qi (i) + qs (i) + qg (i) - cvm (i) = c_air + qv (i) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice - lcp2 (i) = lhl (i) / cvm (i) - ! denfac (i) = sqrt (sfcrho / den (i)) - enddo - - do i = is, ie - if (qr (i) > qrmin .and. tz (i) > t_wfr) then - qpz = qv (i) + ql (i) - tin = tz (i) - lcp2 (i) * ql (i) ! presence of clouds suppresses the rain evap - qsat = wqs2 (tin, den (i), dqsdt) - dqh = max (ql (i), hvar (i) * max (qpz, qcmin)) - dqv = qsat - qv (i) - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (i) * den (i) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * exp (0.725 * log (qden))) & - / (crevp (4) * t2 + crevp (5) * qsat * den (i)) - evap = min (qr (i), dt * evap, dqv / (1. + lcp2 (i) * dqsdt)) - qr (i) = qr (i) - evap - qv (i) = qv (i) + evap - q_liq (i) = q_liq (i) - evap - cvm (i) = c_air + qv (i) * c_vap + q_liq (i) * c_liq + q_sol (i) * c_ice - tz (i) = tz (i) - evap * lhl (i) / cvm (i) - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - if (qr (i) > qrmin .and. ql (i) > 1.e-8 .and. qsat < q_plus) then - denfac (i) = sqrt (sfcrho / den (i)) - sink = dt * denfac (i) * cracw * exp (0.95 * log (qr (i) * den (i))) - sink = sink / (1. + sink) * ql (i) - ql (i) = ql (i) - sink - qr (i) = qr (i) + sink - endif - endif - enddo - -end subroutine revap_rac1 - -! ======================================================================= -!>@brief The subroutine 'terminal_fall' computes terminal fall speed. -!>@details It considers cloud ice, snow, and graupel's melting during fall. -! ======================================================================= - -subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & - den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dtm ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz - - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 - - real, intent (out) :: r1, g1, s1, i1 - - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: qsat, dqsdt, dt5, evap, dtime - real :: factor, frac - real :: tmp, precip, tc, sink - - real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi - real, dimension (ktop:kbot) :: m1, dm - - real :: zs = 0. - real :: fac_imlt - - integer :: k, k0, m - - logical :: no_fall - - dt5 = 0.5 * dtm - fac_imlt = 1. - exp (- dt5 / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - m1_sol (k) = 0. - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! find significant melting level - ! ----------------------------------------------------------------------- - - k0 = kbot - do k = ktop, kbot - 1 - if (tz (k) > tice) then - k0 = k - exit - endif - enddo - - ! ----------------------------------------------------------------------- - ! melting of cloud_ice (before fall) : - ! ----------------------------------------------------------------------- - - do k = k0, kbot - tc = tz (k) - tice - if (qi (k) > qcmin .and. tc > 0.) then - sink = min (qi (k), fac_imlt * tc / icpk (k)) - tmp = min (sink, dim (ql_mlt, ql (k))) - ql (k) = ql (k) + tmp - qr (k) = qr (k) + sink - tmp - qi (k) = qi (k) - sink - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhi (k) / cvm (k) - tc = tz (k) - tice - endif - enddo - - ! ----------------------------------------------------------------------- - ! turn off melting when cloud microphysics time step is small - ! ----------------------------------------------------------------------- - - if (dtm < 60.) k0 = kbot - - ! sjl, turn off melting of falling cloud ice, snow and graupel - k0 = kbot - ! sjl, turn off melting of falling cloud ice, snow and graupel - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - zt (ktop) = ze (ktop) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = k0, kbot - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! melting of falling cloud ice into rain - ! ----------------------------------------------------------------------- - - call check_column (ktop, kbot, qi, no_fall) - - if (vi_fac < 1.e-5 .or. no_fall) then - i1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vti (k - 1) + vti (k)) - enddo - zt (kbot + 1) = zs - dtm * vti (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qi (k) > qrmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vr_min, vti (k)) * tau_imlt)) - sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tmp = min (sink, dim (ql_mlt, ql (m))) - ql (m) = ql (m) + tmp - qr (m) = qr (m) - tmp + sink - tz (m) = tz (m) - sink * icpk (m) - qi (k) = qi (k) - sink * dp (m) / dp (k) - endif - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) - endif - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & - / (dm (k) + m1_sol (k - 1) - m1_sol (k)) - enddo - endif - - endif - - ! ----------------------------------------------------------------------- - ! melting of falling snow into rain - ! ----------------------------------------------------------------------- - - r1 = 0. - - call check_column (ktop, kbot, qs, no_fall) - - if (no_fall) then - s1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vts (k - 1) + vts (k)) - enddo - zt (kbot + 1) = zs - dtm * vts (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qs (k) > qrmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vr_min + vts (k))) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, dtime / tau_smlt) - sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qs (k) = qs (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) ! precip as rain - else - ! qr source here will fall next time step (therefore, can evap) - qr (m) = qr (m) + sink - endif - endif - if (qs (k) < qrmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - - ! ---------------------------------------------- - ! melting of falling graupel into rain - ! ---------------------------------------------- - - call check_column (ktop, kbot, qg, no_fall) - - if (no_fall) then - g1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dt5 * (vtg (k - 1) + vtg (k)) - enddo - zt (kbot + 1) = zs - dtm * vtg (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qg (k) > qrmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) - sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qg (k) = qg (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) - else - qr (m) = qr (m) + sink - endif - endif - if (qg (k) < qrmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - -end subroutine terminal_fall - -! ======================================================================= -!>@brief The subroutine 'check_column' checks -!! if the water species is large enough to fall. -! ======================================================================= - -subroutine check_column (ktop, kbot, q, no_fall) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: q (ktop:kbot) - - logical, intent (out) :: no_fall - - integer :: k - - no_fall = .true. - - do k = ktop, kbot - if (q (k) > qrmin) then - no_fall = .false. - exit - endif - enddo - -end subroutine check_column - -! ======================================================================= -!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic -!! scheme. -!>@author Shian-Jiann Lin, 2016 -! ======================================================================= - -subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt - - real, intent (in), dimension (ktop:kbot + 1) :: ze - - real, intent (in), dimension (ktop:kbot) :: vt, dp - - real, intent (inout), dimension (ktop:kbot) :: q - - real, intent (out), dimension (ktop:kbot) :: m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: dz, qm, dd - - integer :: k - - do k = ktop, kbot - dz (k) = ze (k) - ze (k + 1) - dd (k) = dt * vt (k) - q (k) = q (k) * dp (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation: non - vectorizable loop - ! ----------------------------------------------------------------------- - - qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) - do k = ktop + 1, kbot - qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) - enddo - - ! ----------------------------------------------------------------------- - ! qm is density at this stage - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qm (k) = qm (k) * dz (k) - enddo - - ! ----------------------------------------------------------------------- - ! output mass fluxes: non - vectorizable loop - ! ----------------------------------------------------------------------- - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! ----------------------------------------------------------------------- - ! update: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine implicit_fall - -! ======================================================================= -!> lagrangian scheme -! developed by sj lin, ???? -! ======================================================================= - -subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: zs - - logical, intent (in) :: mono - - real, intent (in), dimension (ktop:kbot + 1) :: ze, zt - - real, intent (in), dimension (ktop:kbot) :: dp - - ! m1: flux - real, intent (inout), dimension (ktop:kbot) :: q, m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: qm, dz - - real :: a4 (4, ktop:kbot) - - real :: pl, pr, delz, esl - - integer :: k, k0, n, m - - real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - - ! ----------------------------------------------------------------------- - ! density: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - dz (k) = zt (k) - zt (k + 1) ! note: dz is positive - q (k) = q (k) * dp (k) - a4 (1, k) = q (k) / dz (k) - qm (k) = 0. - enddo - - ! ----------------------------------------------------------------------- - ! construct vertical profile with zt as coordinate - ! ----------------------------------------------------------------------- - - call cs_profile (a4 (1, ktop), dz (ktop), kbot - ktop + 1, mono) - - k0 = ktop - do k = ktop, kbot - do n = k0, kbot - if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then - pl = (zt (n) - ze (k)) / dz (n) - if (zt (n + 1) <= ze (k + 1)) then - ! entire new grid is within the original grid - pr = (zt (n) - ze (k + 1)) / dz (n) - qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & - a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) - qm (k) = qm (k) * (ze (k) - ze (k + 1)) - k0 = n - goto 555 - else - qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & - a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) - if (n < kbot) then - do m = n + 1, kbot - ! locate the bottom edge: ze (k + 1) - if (ze (k + 1) < zt (m + 1)) then - qm (k) = qm (k) + q (m) - else - delz = zt (m) - ze (k + 1) - esl = delz / dz (m) - qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & - (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) - k0 = m - goto 555 - endif - enddo - endif - goto 555 - endif - endif - enddo - 555 continue - enddo - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! convert back to * dry * mixing ratio: - ! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) . - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine lagrangian_fall_ppm - -subroutine cs_profile (a4, del, km, do_mono) - - implicit none - - integer, intent (in) :: km !< vertical dimension - - real, intent (in) :: del (km) - - logical, intent (in) :: do_mono - - real, intent (inout) :: a4 (4, km) - - real, parameter :: qp_min = 1.e-6 - - real :: gam (km) - real :: q (km + 1) - real :: d4, bet, a_bot, grat, pmp, lac - real :: pmp_1, lac_1, pmp_2, lac_2 - real :: da1, da2, a6da - - integer :: k - - logical extm (km) - - grat = del (2) / del (1) ! grid ratio - bet = grat * (grat + 0.5) - q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet - gam (1) = (1. + grat * (grat + 1.5)) / bet - - do k = 2, km - d4 = del (k - 1) / del (k) - bet = 2. + 2. * d4 - gam (k - 1) - q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet - gam (k) = d4 / bet - enddo - - a_bot = 1. + d4 * (d4 + 1.5) - q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) & - / (d4 * (d4 + 0.5) - a_bot * gam (km)) - - do k = km, 1, - 1 - q (k) = q (k) - gam (k) * q (k + 1) - enddo - - ! ----------------------------------------------------------------------- - ! apply constraints - ! ----------------------------------------------------------------------- - - do k = 2, km - gam (k) = a4 (1, k) - a4 (1, k - 1) - enddo - - ! ----------------------------------------------------------------------- - ! apply large - scale constraints to all fields if not local max / min - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! top: - ! ----------------------------------------------------------------------- - - q (1) = max (q (1), 0.) - q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2))) - q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.) - - ! ----------------------------------------------------------------------- - ! interior: - ! ----------------------------------------------------------------------- - - do k = 3, km - 1 - if (gam (k - 1) * gam (k + 1) > 0.) then - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - if (gam (k - 1) > 0.) then - ! there exists a local max - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - ! there exists a local min - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), 0.0) - endif - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom : - ! ----------------------------------------------------------------------- - - q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km))) - q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.) - ! q (km + 1) = max (q (km + 1), 0.) - - ! ----------------------------------------------------------------------- - ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) - ! ----------------------------------------------------------------------- - - do k = 1, km - 1 - a4 (2, k) = q (k) - a4 (3, k) = q (k + 1) - enddo - - do k = 2, km - 1 - if (gam (k) * gam (k + 1) > 0.0) then - extm (k) = .false. - else - extm (k) = .true. - endif - enddo - - if (do_mono) then - do k = 3, km - 2 - if (extm (k)) then - ! positive definite constraint only if true local extrema - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - else - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then - ! check within the smooth region if subgrid profile is non - monotonic - pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) - lac_1 = pmp_1 + 1.5 * gam (k + 2) - a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & - max (a4 (1, k), pmp_1, lac_1)) - pmp_2 = a4 (1, k) + 2.0 * gam (k) - lac_2 = pmp_2 - 1.5 * gam (k - 1) - a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & - max (a4 (1, k), pmp_2, lac_2)) - endif - endif - enddo - else - do k = 3, km - 2 - if (extm (k)) then - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - endif - enddo - endif - - do k = 1, km - 1 - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - enddo - - k = km - 1 - if (extm (k)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - a4 (4, k) = 0. - else - da1 = a4 (3, k) - a4 (2, k) - da2 = da1 ** 2 - a6da = a4 (4, k) * da1 - if (a6da < - da2) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - elseif (a6da > da2) then - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - - call cs_limiters (km - 1, a4) - - ! ----------------------------------------------------------------------- - ! bottom layer: - ! ----------------------------------------------------------------------- - - a4 (2, km) = a4 (1, km) - a4 (3, km) = a4 (1, km) - a4 (4, km) = 0. - -end subroutine cs_profile - -subroutine cs_limiters (km, a4) - - implicit none - - integer, intent (in) :: km - - real, intent (inout) :: a4 (4, km) !< ppm array - - real, parameter :: r12 = 1. / 12. - - integer :: k - - ! ----------------------------------------------------------------------- - ! positive definite constraint - ! ----------------------------------------------------------------------- - - do k = 1, km - if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then - if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then - if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then - a4 (3, k) = a4 (1, k) - a4 (2, k) = a4 (1, k) - a4 (4, k) = 0. - elseif (a4 (3, k) > a4 (2, k)) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - else - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - endif - enddo - -end subroutine cs_limiters - -! ======================================================================= -!>@brief The subroutine 'fall_speed' calculates vertical fall speed. -! ======================================================================= - -subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: den, qs, qi, qg, ql, tk - real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg - - ! fall velocity constants: - - real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall - real, parameter :: thg = 1.0e-8 - real, parameter :: ths = 1.0e-8 - - real, parameter :: aa = - 4.14122e-5 - real, parameter :: bb = - 0.00538922 - real, parameter :: cc = - 0.0516344 - real, parameter :: dd = 0.00216078 - real, parameter :: ee = 1.9714 - - ! marshall - palmer constants - - real, parameter :: vcons = 6.6280504 - real, parameter :: vcong = 87.2382675 - real, parameter :: norms = 942477796.076938 - real, parameter :: normg = 5026548245.74367 - - real, dimension (ktop:kbot) :: qden, tc, rhof - - real :: vi0 - - integer :: k - - ! ----------------------------------------------------------------------- - ! marshall - palmer formula - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! try the local air density -- for global model; the true value could be - ! much smaller than sfcrho over high mountains - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - rhof (k) = sqrt (min (10., sfcrho / den (k))) - enddo - - ! ----------------------------------------------------------------------- - ! ice: - ! ----------------------------------------------------------------------- - - if (const_vi) then - vti (:) = vi_fac - else - ! ----------------------------------------------------------------------- - ! use deng and mace (2008, grl), which gives smaller fall speed than hd90 formula - ! ----------------------------------------------------------------------- - vi0 = 0.01 * vi_fac - do k = ktop, kbot - if (qi (k) < thi) then ! this is needed as the fall - speed maybe problematic for small qi - vti (k) = vf_min - else - tc (k) = tk (k) - tice - vti (k) = (3. + log10 (qi (k) * den (k))) * (tc (k) * (aa * tc (k) + bb) + cc) + dd * tc (k) + ee - vti (k) = vi0 * exp (log_10 * vti (k)) * 0.8 - vti (k) = min (vi_max, max (vf_min, vti (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! snow: - ! ----------------------------------------------------------------------- - - if (const_vs) then - vts (:) = vs_fac ! 1. ifs_2016 - else - do k = ktop, kbot - if (qs (k) < ths) then - vts (k) = vf_min - else - vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vf_min, vts (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! graupel: - ! ----------------------------------------------------------------------- - - if (const_vg) then - vtg (:) = vg_fac ! 2. - else - do k = ktop, kbot - if (qg (k) < thg) then - vtg (k) = vf_min - else - vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vf_min, vtg (k))) - endif - enddo - endif - -end subroutine fall_speed - -! ======================================================================= -!>@brief The subroutine 'setup'm' sets up -!! gfdl cloud microphysics parameters. -! ======================================================================= - -subroutine setupm - - implicit none - - real :: gcon, cd, scm3, pisq, act (8) - real :: vdifu, tcond - real :: visk - real :: ch2o, hltf - real :: hlts, hltc, ri50 - - real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & - gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & - gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & - gam625 = 184.860962, gam680 = 496.604067 - - ! intercept parameters - - real, parameter :: rnzr = 8.0e6 ! lin83 - real, parameter :: rnzs = 3.0e6 ! lin83 - real, parameter :: rnzg = 4.0e6 ! rh84 - - ! density parameters - -! real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) -! real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) - real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) - - real den_rc - - integer :: i, k - - pie = 4. * atan (1.0) - - ! s. klein's formular (eq 16) from am2 - - fac_rc = (4. / 3.) * pie * rhor * rthresh ** 3 - - if (prog_ccn) then - ! if (master) write (*, *) 'prog_ccn option is .t.' - else - den_rc = fac_rc * ccn_o * 1.e6 - ! if (master) write (*, *) 'mp: for ccn_o = ', ccn_o, 'ql_rc = ', den_rc - den_rc = fac_rc * ccn_l * 1.e6 - ! if (master) write (*, *) 'mp: for ccn_l = ', ccn_l, 'ql_rc = ', den_rc - endif - - vdifu = 2.11e-5 - tcond = 2.36e-2 - - visk = 1.259e-5 - hlts = 2.8336e6 - hltc = 2.5e6 - hltf = 3.336e5 - - ch2o = 4.1855e3 - ri50 = 1.e-4 - - pisq = pie * pie - scm3 = (visk / vdifu) ** (1. / 3.) - - cracs = pisq * rnzr * rnzs * rhos - csacr = pisq * rnzr * rnzs * rhor - cgacr = pisq * rnzr * rnzg * rhor - cgacs = pisq * rnzg * rnzs * rhos - cgacs = cgacs * c_pgacs - - ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ; - ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g) - - act (1) = pie * rnzs * rhos - act (2) = pie * rnzr * rhor - act (6) = pie * rnzg * rhog - act (3) = act (2) - act (4) = act (1) - act (5) = act (2) - act (7) = act (1) - act (8) = act (6) - - do i = 1, 3 - do k = 1, 4 - acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) - enddo - enddo - - gcon = 40.74 * sqrt (sfcrho) ! 44.628 - - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - ! decreasing csacw to reduce cloud water --- > snow - - craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - csaci = csacw * c_psaci - - cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875) - ! cgaci = cgacw * 0.1 - - ! sjl, may 28, 2012 - cgaci = cgacw * 0.05 - ! sjl, may 28, 2012 - - cracw = craci ! cracw = 3.27206196043822 - cracw = c_cracw * cracw - - ! subl and revp: five constants for three separate processes - - cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs - cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg - crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr - cssub (2) = 0.78 / sqrt (act (1)) - cgsub (2) = 0.78 / sqrt (act (6)) - crevp (2) = 0.78 / sqrt (act (2)) - cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 - cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 - crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 - cssub (4) = tcond * rvgas - cssub (5) = hlts ** 2 * vdifu - cgsub (4) = cssub (4) - crevp (4) = cssub (4) - cgsub (5) = cssub (5) - crevp (5) = hltc ** 2 * vdifu - - cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 - cgfr (2) = 0.66 - - ! smlt: five constants (lin et al. 1983) - - csmlt (1) = 2. * pie * tcond * rnzs / hltf - csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf - csmlt (3) = cssub (2) - csmlt (4) = cssub (3) - csmlt (5) = ch2o / hltf - - ! gmlt: five constants - - cgmlt (1) = 2. * pie * tcond * rnzg / hltf - cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf - cgmlt (3) = cgsub (2) - cgmlt (4) = cgsub (3) - cgmlt (5) = ch2o / hltf - - es0 = 6.107799961e2 ! ~6.1 mb - ces0 = eps * es0 - -end subroutine setupm - -! ======================================================================= -! initialization of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_init (me, master, nlunit, input_nml_file, logunit, fn_nml) - - implicit none - - integer, intent (in) :: me - integer, intent (in) :: master - integer, intent (in) :: nlunit - integer, intent (in) :: logunit - - character (len = 64), intent (in) :: fn_nml - character (len = *), intent (in) :: input_nml_file(:) - - integer :: ios - logical :: exists - - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - ! master = (mpp_pe () .eq.mpp_root_pe ()) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop - else - open (unit = nlunit, file = fn_nml, readonly, status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = gfdl_cloud_microphysics_nml) - close (nlunit) -#endif - - ! write version number and namelist to log file - if (me == master) then - write (logunit, *) " ================================================================== " - write (logunit, *) "gfdl_cloud_microphys_mod" - write (logunit, nml = gfdl_cloud_microphysics_nml) - endif - - if (do_setup) then - call setup_con - call setupm - do_setup = .false. - endif - - log_10 = log (10.) - - tice0 = tice - 0.01 - t_wfr = tice - 40.0 ! supercooled water can exist down to - 48 c, which is the "absolute" - - ! if (master) write (logunit, nml = gfdl_cloud_microphys_nml) - ! - ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & - ! 'rain fall speed', 'm / s', missing_value = missing_value) - ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & - ! 'snow fall speed', 'm / s', missing_value = missing_value) - ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & - ! 'graupel fall speed', 'm / s', missing_value = missing_value) - ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & - ! 'ice fall speed', 'm / s', missing_value = missing_value) - - ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & - ! 'droplet number concentration', '# / m3', missing_value = missing_value) - ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & - ! 'relative humidity', 'n / a', missing_value = missing_value) - - ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & - ! 'rain_lin', 'mm / day', missing_value = missing_value) - ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & - ! 'snow_lin', 'mm / day', missing_value = missing_value) - ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & - ! 'graupel_lin', 'mm / day', missing_value = missing_value) - ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & - ! 'ice_lin', 'mm / day', missing_value = missing_value) - ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & - ! 'prec_lin', 'mm / day', missing_value = missing_value) - - ! if (master) write (*, *) 'prec_lin diagnostics initialized.', id_prec - - ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & - ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) - ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & - ! 'subgrid variance', 'n / a', missing_value = missing_value) - - ! call qsmith_init - - ! testing the water vapor tables - - ! if (mp_debug .and. master) then - ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' - ! tmp = tice - 90. - ! do k = 1, 25 - ! q1 = wqsat_moist (tmp, 0., 1.e5) - ! q2 = qs1d_m (tmp, 0., 1.e5) - ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 - ! tmp = tmp + 5. - ! enddo - ! endif - - ! if (master) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' - - module_is_initialized = .true. - -!+---+-----------------------------------------------------------------+ -!..Set these variables needed for computing radar reflectivity. These -!.. get used within radar_init to create other variables used in the -!.. radar module. - - xam_r = pi*rhor/6. - xbm_r = 3. - xmu_r = 0. - xam_s = pi*rhos/6. - xbm_s = 3. - xmu_s = 0. - xam_g = pi*rhog/6. - xbm_g = 3. - xmu_g = 0. - - call radar_init - -end subroutine gfdl_cloud_microphys_init - -! ======================================================================= -! end of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_end - - implicit none - - deallocate (table) - deallocate (table2) - deallocate (table3) - deallocate (tablew) - deallocate (des) - deallocate (des2) - deallocate (des3) - deallocate (desw) - - tables_are_initialized = .false. - -end subroutine gfdl_cloud_microphys_end - -! ======================================================================= -! qsmith table initialization -!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. -! ======================================================================= - -subroutine setup_con - - implicit none - - ! master = (mpp_pe () .eq.mpp_root_pe ()) - - rgrav = 1. / grav - - if (.not. qsmith_tables_initialized) call qsmith_init - - qsmith_tables_initialized = .true. - -end subroutine setup_con - -! ======================================================================= -!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) -! ======================================================================= - -real function acr3d (v1, v2, q1, q2, c, cac, rho) - - implicit none - - real, intent (in) :: v1, v2, c, rho - real, intent (in) :: q1, q2 ! mixing ratio!!! - real, intent (in) :: cac (3) - - real :: t1, s1, s2 - - ! integer :: k - ! - ! real :: a - ! - ! a = 0.0 - ! do k = 1, 3 - ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) - ! enddo - ! acr3d = c * abs (v1 - v2) * a / rho - - ! optimized - - t1 = sqrt (q1 * rho) - s1 = sqrt (q2 * rho) - s2 = sqrt (s1) ! s1 = s2 ** 2 - acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) - -end function acr3d - -! ======================================================================= -!> melting of snow function (lin et al. 1983) -! note: psacw and psacr must be calc before smlt is called -! ======================================================================= - -real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) - - implicit none - - real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac - - smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & - c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) - -end function smlt - -! ======================================================================= -!> melting of graupel function (lin et al. 1983) -! note: pgacw and pgacr must be calc before gmlt is called -! ======================================================================= - -real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) - - implicit none - - real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho - - gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & - c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) - -end function gmlt - -! ======================================================================= -! initialization -! prepare saturation water vapor pressure tables -! ======================================================================= -!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation -!! water vapor pressure for the following utility routines that are designed -!! to return qs consistent with the assumptions in FV3. -!>@details The calculations are highly accurate values based on the Clausius-Clapeyron -!! equation. -! ======================================================================= -subroutine qsmith_init - - implicit none - - integer, parameter :: length = 2621 - - integer :: i - - if (.not. tables_are_initialized) then - - ! master = (mpp_pe () .eq. mpp_root_pe ()) - ! if (master) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - - ! generate es table (dt = 0.1 deg. c) - - allocate (table (length)) - allocate (table2 (length)) - allocate (table3 (length)) - allocate (tablew (length)) - allocate (des (length)) - allocate (des2 (length)) - allocate (des3 (length)) - allocate (desw (length)) - - call qs_table (length) - call qs_table2 (length) - call qs_table3 (length) - call qs_tablew (length) - - do i = 1, length - 1 - des (i) = max (0., table (i + 1) - table (i)) - des2 (i) = max (0., table2 (i + 1) - table2 (i)) - des3 (i) = max (0., table3 (i + 1) - table3 (i)) - desw (i) = max (0., tablew (i + 1) - tablew (i)) - enddo - des (length) = des (length - 1) - des2 (length) = des2 (length - 1) - des3 (length) = des3 (length - 1) - desw (length) = desw (length - 1) - - tables_are_initialized = .true. - - endif - -end subroutine qsmith_init - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqs1' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density. -! ======================================================================= - -real function wqs1 (ta, den) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs1 = es / (rvgas * ta * den) - -end function wqs1 - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqs2' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density, as well as the -!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. -! ======================================================================= - -real function wqs2 (ta, den, dqdt) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - - if (.not. tables_are_initialized) call qsmith_init - - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - ! finite diff, del_t = 0.1: - dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) - -end function wqs2 - -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - -! ======================================================================= -!>@brief The function 'iqs1' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function iqs1 (ta, den) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs1 = es / (rvgas * ta * den) - -end function iqs1 - -! ======================================================================= -!>@brief The function 'iqs2' computes the gradient of saturated specific -!! humidity for table iii -! ======================================================================= - -real function iqs2 (ta, den, dqdt) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) - -end function iqs2 - -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - -! ======================================================================= -!>@brief saturation water vapor pressure table ii -! 1 - phase table -! ======================================================================= - -subroutine qs_tablew (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem, fac0, fac1, fac2 - - integer :: i - - tmin = table_ice - 160. - - ! ----------------------------------------------------------------------- - ! compute es over water - ! ----------------------------------------------------------------------- - - do i = 1, n - tem = tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - tablew (i) = e00 * exp (fac2) - enddo - -end subroutine qs_tablew - -! ======================================================================= -!>@brief saturation water vapor pressure table iii -! 2 - phase table -! ======================================================================= - -subroutine qs_table2 (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem0, tem1, fac0, fac1, fac2 - - integer :: i, i0, i1 - - tmin = table_ice - 160. - - do i = 1, n - tem0 = tmin + delt * real (i - 1) - fac0 = (tem0 - t_ice) / (tem0 * t_ice) - if (i <= 1600) then - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas - else - ! ----------------------------------------------------------------------- - ! compute es over water between 0 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas - endif - table2 (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! smoother around 0 deg c - ! ----------------------------------------------------------------------- - - i0 = 1600 - i1 = 1601 - tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) - tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) - table2 (i0) = tem0 - table2 (i1) = tem1 - -end subroutine qs_table2 - -! ======================================================================= -!>@brief saturation water vapor pressure table iv -! 2 - phase table with " - 2 c" as the transition point -! ======================================================================= - -subroutine qs_table3 (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e - real :: tem0, tem1 - - integer :: i, i0, i1 - - esbasw = 1013246.0 - tbasw = table_ice + 100. - esbasi = 6107.1 - tmin = table_ice - 160. - - do i = 1, n - tem = tmin + delt * real (i - 1) - ! if (i <= 1600) then - if (i <= 1580) then ! change to - 2 c - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 9.09718 * (table_ice / tem - 1.) - b = - 3.56654 * alog10 (table_ice / tem) - c = 0.876793 * (1. - tem / table_ice) - e = alog10 (esbasi) - table3 (i) = 0.1 * 10 ** (aa + b + c + e) - else - ! ----------------------------------------------------------------------- - ! compute es over water between - 2 deg c and 102 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 7.90298 * (tbasw / tem - 1.) - b = 5.02808 * alog10 (tbasw / tem) - c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) - d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) - e = alog10 (esbasw) - table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) - endif - enddo - - ! ----------------------------------------------------------------------- - ! smoother around - 2 deg c - ! ----------------------------------------------------------------------- - - i0 = 1580 - i1 = 1581 - tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) - tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) - table3 (i0) = tem0 - table3 (i1) = tem1 - -end subroutine qs_table3 - -! ======================================================================= -! compute the saturated specific humidity for table -! note: this routine is based on "moist" mixing ratio -!>@brief The function 'qs_blend' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature. -! ======================================================================= - -real function qs_blend (t, p, q) - - implicit none - - real, intent (in) :: t, p, q - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (t, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table (it) + (ap1 - it) * des (it) - qs_blend = eps * es * (1. + zvir * q) / p - -end function qs_blend - -! ======================================================================= -!>@brief saturation water vapor pressure table i -! 3 - phase table -! ======================================================================= - -subroutine qs_table (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem, esh20 - real :: wice, wh2o, fac0, fac1, fac2 - real :: esupc (200) - - integer :: i - - tmin = table_ice - 160. - - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1600 - tem = tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas - table (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! compute es over water between - 20 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1221 - tem = 253.16 + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - esh20 = e00 * exp (fac2) - if (i <= 200) then - esupc (i) = esh20 - else - table (i + 1400) = esh20 - endif - enddo - - ! ----------------------------------------------------------------------- - ! derive blended es over ice and supercooled water between - 20 deg c and 0 deg c - ! ----------------------------------------------------------------------- - - do i = 1, 200 - tem = 253.16 + delt * real (i - 1) - wice = 0.05 * (table_ice - tem) - wh2o = 0.05 * (tem - 253.16) - table (i + 1400) = wice * table (i + 1400) + wh2o * esupc (i) - enddo - -end subroutine qs_table - -! ======================================================================= -! compute the saturated specific humidity and the gradient of saturated specific humidity -! input t in deg k, p in pa; p = rho rdry tv, moist pressure -!>@brief The function 'qsmith' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature in 3D. -!@details It als oincludes the option for computing des/dT. -! ======================================================================= - -subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) - - implicit none - - integer, intent (in) :: im, km, ks - - real, intent (in), dimension (im, km) :: t, p, q - - real, intent (out), dimension (im, km) :: qs - - real, intent (out), dimension (im, km), optional :: dqdt - - real :: eps10, ap1, tmin - - real, dimension (im, km) :: es - - integer :: i, k, it - - tmin = table_ice - 160. - eps10 = 10. * eps - - if (.not. tables_are_initialized) then - call qsmith_init - endif - - do k = ks, km - do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i, k) = table (it) + (ap1 - it) * des (it) - qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - - if (present (dqdt)) then - do k = ks, km - do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - 0.5 - it = ap1 - dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - endif - -end subroutine qsmith - -! ======================================================================= -!>@brief The subroutine 'neg_adj' fixes negative water species. -!>@details This is designed for 6-class micro-physics schemes. -! ======================================================================= - -subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dp - - real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg - - real, dimension (ktop:kbot) :: lcpk, icpk - - real :: dq, cvm - - integer :: k - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice - lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm - icpk (k) = (li00 + dc_ice * pt (k)) / cvm - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! ice phase: - ! ----------------------------------------------------------------------- - - ! if cloud ice < 0, borrow from snow - if (qi (k) < 0.) then - qs (k) = qs (k) + qi (k) - qi (k) = 0. - endif - ! if snow < 0, borrow from graupel - if (qs (k) < 0.) then - qg (k) = qg (k) + qs (k) - qs (k) = 0. - endif - ! if graupel < 0, borrow from rain - if (qg (k) < 0.) then - qr (k) = qr (k) + qg (k) - pt (k) = pt (k) - qg (k) * icpk (k) ! heating - qg (k) = 0. - endif - - ! ----------------------------------------------------------------------- - ! liquid phase: - ! ----------------------------------------------------------------------- - - ! if rain < 0, borrow from cloud water - if (qr (k) < 0.) then - ql (k) = ql (k) + qr (k) - qr (k) = 0. - endif - ! if cloud water < 0, borrow from water vapor - if (ql (k) < 0.) then - qv (k) = qv (k) + ql (k) - pt (k) = pt (k) - ql (k) * lcpk (k) ! heating - ql (k) = 0. - endif - - enddo - - ! ----------------------------------------------------------------------- - ! fix water vapor; borrow from below - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - 1 - if (qv (k) < 0.) then - qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) - qv (k) = 0. - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom layer; borrow from above - ! ----------------------------------------------------------------------- - - if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then - dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) - qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) - qv (kbot) = qv (kbot) + dq / dp (kbot) - endif - -end subroutine neg_adj - -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - -! ========================================================================== -!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. -! ========================================================================== - -subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) - - implicit none - - integer, intent (in) :: is, ie, js, je, km - - real, intent (in), dimension (is:ie, js:je, km) :: a3 - - real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) - - real, intent (in) :: zl - - real, intent (out), dimension (is:ie, js:je) :: a2 - - real, dimension (km) :: zm !< middle layer height - - integer :: i, j, k - - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - - do j = js, je - do i = is, ie - do k = 1, km - zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) - enddo - if (zl >= zm (1)) then - a2 (i, j) = a3 (i, j, 1) - elseif (zl <= zm (km)) then - a2 (i, j) = a3 (i, j, km) - else - do k = 1, km - 1 - if (zl <= zm (k) .and. zl >= zm (k + 1)) then - a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) - exit - endif - enddo - endif - enddo - enddo - -end subroutine interpolate_z - -! ======================================================================= -!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud -!! species. -!>author Linjiong Zhoum, Shian-Jiann Lin -! ======================================================================= - -subroutine cloud_diagnosis (is, ie, ks, ke, den, delp, lsm, qmw, qmi, qmr, qms, qmg, t, & - rew, rei, rer, res, reg) - - implicit none - - integer, intent (in) :: is, ie, ks, ke - integer, intent (in), dimension (is:ie) :: lsm ! land sea mask, 0: ocean, 1: land, 2: sea ice - - real, intent (in), dimension (is:ie, ks:ke) :: den, delp, t - real, intent (in), dimension (is:ie, ks:ke) :: qmw, qmi, qmr, qms, qmg !< units: kg / kg - - real, intent (out), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg !< units: micron - - real, dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg !< units: g / m^2 - - integer :: i, k - - real :: lambdar, lambdas, lambdag - real :: dpg, rei_fac, mask, ccn, bw - real, parameter :: rho_0 = 50.e-3 - - real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 - real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 - real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 - real :: qmin = 1.0e-12, beta = 1.22 - - do k = ks, ke - do i = is, ie - - dpg = abs (delp (i, k)) / grav - mask = min (max (real(lsm (i)), 0.0), 2.0) - - ! ----------------------------------------------------------------------- - ! cloud water (Martin et al., 1994) - ! ----------------------------------------------------------------------- - - ccn = 0.80 * (- 1.15e-3 * (ccn_o ** 2) + 0.963 * ccn_o + 5.30) * abs (mask - 1.0) + & - 0.67 * (- 2.10e-4 * (ccn_l ** 2) + 0.568 * ccn_l - 27.9) * (1.0 - abs (mask - 1.0)) - - if (qmw (i, k) .gt. qmin) then - qcw (i, k) = dpg * qmw (i, k) * 1.0e3 - rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * den (i, k) * qmw (i, k)) / (4.0 * pi * rhow * ccn))) * 1.0e4 - rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) - else - qcw (i, k) = 0.0 - rew (i, k) = rewmin - endif - - if (reiflag .eq. 1) then - - ! ----------------------------------------------------------------------- - ! cloud ice (Heymsfield and Mcfarquhar, 1996) - ! ----------------------------------------------------------------------- - - if (qmi (i, k) .gt. qmin) then - qci (i, k) = dpg * qmi (i, k) * 1.0e3 - rei_fac = log (1.0e3 * qmi (i, k) * den (i, k)) - if (t (i, k) - tice .lt. - 50) then - rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3 - elseif (t (i, k) - tice .lt. - 40) then - rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3 - elseif (t (i, k) - tice .lt. - 30) then - rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3 - else - rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3 - endif - rei (i, k) = max (reimin, min (reimax, rei (i, k))) - else - qci (i, k) = 0.0 - rei (i, k) = reimin - endif - - endif - - if (reiflag .eq. 2) then - - ! ----------------------------------------------------------------------- - ! cloud ice (Wyser, 1998) - ! ----------------------------------------------------------------------- - - if (qmi (i, k) .gt. qmin) then - qci (i, k) = dpg * qmi (i, k) * 1.0e3 - bw = - 2. + 1.e-3 * log10 (den (i, k) * qmi (i, k) / rho_0) * max (0.0, tice - t (i, k)) ** 1.5 - rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw)) - rei (i, k) = max (reimin, min (reimax, rei (i, k))) - else - qci (i, k) = 0.0 - rei (i, k) = reimin - endif - - endif - - ! ----------------------------------------------------------------------- - ! rain (Lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qmr (i, k) .gt. qmin) then - qcr (i, k) = dpg * qmr (i, k) * 1.0e3 - lambdar = exp (0.25 * log (pi * rhor * n0r / qmr (i, k) / den (i, k))) - rer (i, k) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, k) = max (rermin, min (rermax, rer (i, k))) - else - qcr (i, k) = 0.0 - rer (i, k) = rermin - endif - - ! ----------------------------------------------------------------------- - ! snow (Lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qms (i, k) .gt. qmin) then - qcs (i, k) = dpg * qms (i, k) * 1.0e3 - lambdas = exp (0.25 * log (pi * rhos * n0s / qms (i, k) / den (i, k))) - res (i, k) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, k) = max (resmin, min (resmax, res (i, k))) - else - qcs (i, k) = 0.0 - res (i, k) = resmin - endif - - ! ----------------------------------------------------------------------- - ! graupel (Lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qmg (i, k) .gt. qmin) then - qcg (i, k) = dpg * qmg (i, k) * 1.0e3 - lambdag = exp (0.25 * log (pi * rhog * n0g / qmg (i, k) / den (i, k))) - reg (i, k) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, k) = max (regmin, min (regmax, reg (i, k))) - else - qcg (i, k) = 0.0 - reg (i, k) = regmin - endif - - enddo - enddo - -end subroutine cloud_diagnosis - -!+---+-----------------------------------------------------------------+ - - subroutine refl10cm_gfdl (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, ii,jj, melti) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii,jj - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ - -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho - REAL, DIMENSION(kts:kte):: rr, rs, rg -! REAL:: temp_C - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilams, ilamg - DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_s, N0_g - DOUBLE PRECISION:: lamr, lams, lamg - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0, kbot, n - LOGICAL, INTENT(IN):: melti - DOUBLE PRECISION:: cback, x, eta, f_d -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) -! temp_C = min(-0.001, temp(K)-273.15) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(rdgas*temp(k)*(qv(k)+0.622)) - - if (qr1d(k) .gt. 1.E-9) then - rr(k) = qr1d(k)*rho(k) - N0_r(k) = n0r - lamr = (xam_r*xcrg(3)*N0_r(k)/rr(k))**(1./xcre(1)) - ilamr(k) = 1./lamr - L_qr(k) = .true. - else - rr(k) = 1.E-12 - L_qr(k) = .false. - endif - - if (qs1d(k) .gt. 1.E-9) then - rs(k) = qs1d(k)*rho(k) - N0_s(k) = n0s - lams = (xam_s*xcsg(3)*N0_s(k)/rs(k))**(1./xcse(1)) - ilams(k) = 1./lams - L_qs(k) = .true. - else - rs(k) = 1.E-12 - L_qs(k) = .false. - endif - - if (qg1d(k) .gt. 1.E-9) then - rg(k) = qg1d(k)*rho(k) - N0_g(k) = n0g - lamg = (xam_g*xcgg(3)*N0_g(k)/rg(k))**(1./xcge(1)) - ilamg(k) = 1./lamg - L_qg(k) = .true. - else - rg(k) = 1.E-12 - L_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - k_0 = kts - K_LOOP:do k = kte-1, kts, -1 - if ( melti .and. (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - EXIT K_LOOP - endif - enddo K_LOOP -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_s/900.0)*(xam_s/900.0) & - * N0_s(k)*xcsg(4)*ilams(k)**xcse(4) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_g/900.0)*(xam_g/900.0) & - * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4) - enddo - - -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ - - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 - -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - lams = 1./ilams(k) - do n = 1, nrbins - x = xam_s * xxDs(n)**xbm_s - call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n)) - eta = eta + f_d * CBACK * simpson(n) * xdts(n) - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - -!..Reflectivity contributed by melting graupel - - if (L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = xam_g * xxDg(n)**xbm_g - call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n)) - eta = eta + f_d * CBACK * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine refl10cm_gfdl -!+---+-----------------------------------------------------------------+ - -end module gfdl_cloud_microphys_mod diff --git a/src/dynamics/fv3/microphys/module_mp_radar.F90 b/src/dynamics/fv3/microphys/module_mp_radar.F90 deleted file mode 100644 index 8a16c98260..0000000000 --- a/src/dynamics/fv3/microphys/module_mp_radar.F90 +++ /dev/null @@ -1,614 +0,0 @@ -!+---+-----------------------------------------------------------------+ -!..This set of routines facilitates computing radar reflectivity. -!.. This module is more library code whereas the individual microphysics -!.. schemes contains specific details needed for the final computation, -!.. so refer to location within each schemes calling the routine named -!.. rayleigh_soak_wetgraupel. -!.. The bulk of this code originated from Ulrich Blahak (Germany) and -!.. was adapted to WRF by G. Thompson. This version of code is only -!.. intended for use when Rayleigh scattering principles dominate and -!.. is not intended for wavelengths in which Mie scattering is a -!.. significant portion. Therefore, it is well-suited to use with -!.. 5 or 10 cm wavelength like USA NEXRAD radars. -!.. This code makes some rather simple assumptions about water -!.. coating on outside of frozen species (snow/graupel). Fraction of -!.. meltwater is simply the ratio of mixing ratio below melting level -!.. divided by mixing ratio at level just above highest T>0C. Also, -!.. immediately 90% of the melted water exists on the ice's surface -!.. and 10% is embedded within ice. No water is "shed" at all in these -!.. assumptions. The code is quite slow because it does the reflectivity -!.. calculations based on 50 individual size bins of the distributions. -!+---+-----------------------------------------------------------------+ - - MODULE module_mp_radar - - PUBLIC :: rayleigh_soak_wetgraupel - PUBLIC :: radar_init - PRIVATE :: m_complex_water_ray - PRIVATE :: m_complex_ice_maetzler - PRIVATE :: m_complex_maxwellgarnett - PRIVATE :: get_m_mix_nested - PRIVATE :: get_m_mix - PRIVATE :: WGAMMA - PRIVATE :: GAMMLN - - - INTEGER, PARAMETER, PUBLIC:: nrbins = 50 - DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: xxDx - DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDs,xdts,xxDg,xdtg - DOUBLE PRECISION, PARAMETER, PUBLIC:: lamda_radar = 0.10 ! in meters - DOUBLE PRECISION, PUBLIC:: K_w, PI5, lamda4 - COMPLEX*16, PUBLIC:: m_w_0, m_i_0 - DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: simpson - DOUBLE PRECISION, DIMENSION(3), PARAMETER, PUBLIC:: basis = & - (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) - REAL, DIMENSION(4), PUBLIC:: xcre, xcse, xcge, xcrg, xcsg, xcgg - REAL, PUBLIC:: xam_r, xbm_r, xmu_r, xobmr - REAL, PUBLIC:: xam_s, xbm_s, xmu_s, xoams, xobms, xocms - REAL, PUBLIC:: xam_g, xbm_g, xmu_g, xoamg, xobmg, xocmg - REAL, PUBLIC:: xorg2, xosg2, xogg2 - - INTEGER, PARAMETER, PUBLIC:: slen = 20 - CHARACTER(len=slen), PUBLIC:: & - mixingrulestring_s, matrixstring_s, inclusionstring_s, & - hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & - mixingrulestring_g, matrixstring_g, inclusionstring_g, & - hoststring_g, hostmatrixstring_g, hostinclusionstring_g - -!..Single melting snow/graupel particle 90% meltwater on external sfc - DOUBLE PRECISION, PARAMETER:: melt_outside_s = 0.9d0 - DOUBLE PRECISION, PARAMETER:: melt_outside_g = 0.9d0 - - CHARACTER*256:: radar_debug - - CONTAINS - -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ - - subroutine radar_init - - IMPLICIT NONE - INTEGER:: n - PI5 = 3.14159*3.14159*3.14159*3.14159*3.14159 - lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar - m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0) - m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0) - K_w = (ABS( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2 - - do n = 1, nrbins+1 - simpson(n) = 0.0d0 - enddo - do n = 1, nrbins-1, 2 - simpson(n) = simpson(n) + basis(1) - simpson(n+1) = simpson(n+1) + basis(2) - simpson(n+2) = simpson(n+2) + basis(3) - enddo - - do n = 1, slen - mixingrulestring_s(n:n) = char(0) - matrixstring_s(n:n) = char(0) - inclusionstring_s(n:n) = char(0) - hoststring_s(n:n) = char(0) - hostmatrixstring_s(n:n) = char(0) - hostinclusionstring_s(n:n) = char(0) - mixingrulestring_g(n:n) = char(0) - matrixstring_g(n:n) = char(0) - inclusionstring_g(n:n) = char(0) - hoststring_g(n:n) = char(0) - hostmatrixstring_g(n:n) = char(0) - hostinclusionstring_g(n:n) = char(0) - enddo - - mixingrulestring_s = 'maxwellgarnett' - hoststring_s = 'air' - matrixstring_s = 'water' - inclusionstring_s = 'spheroidal' - hostmatrixstring_s = 'icewater' - hostinclusionstring_s = 'spheroidal' - - mixingrulestring_g = 'maxwellgarnett' - hoststring_g = 'air' - matrixstring_g = 'water' - inclusionstring_g = 'spheroidal' - hostmatrixstring_g = 'icewater' - hostinclusionstring_g = 'spheroidal' - -!..Create bins of snow (from 100 microns up to 2 cm). - xxDx(1) = 100.D-6 - xxDx(nrbins+1) = 0.02d0 - do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & - *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) - enddo - do n = 1, nrbins - xxDs(n) = DSQRT(xxDx(n)*xxDx(n+1)) - xdts(n) = xxDx(n+1) - xxDx(n) - enddo - -!..Create bins of graupel (from 100 microns up to 5 cm). - xxDx(1) = 100.D-6 - xxDx(nrbins+1) = 0.05d0 - do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & - *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) - enddo - do n = 1, nrbins - xxDg(n) = DSQRT(xxDx(n)*xxDx(n+1)) - xdtg(n) = xxDx(n+1) - xxDx(n) - enddo - - -!..The calling program must set the m(D) relations and gamma shape -!.. parameter mu for rain, snow, and graupel. Easily add other types -!.. based on the template here. For majority of schemes with simpler -!.. exponential number distribution, mu=0. - - xcre(1) = 1. + xbm_r - xcre(2) = 1. + xmu_r - xcre(3) = 1. + xbm_r + xmu_r - xcre(4) = 1. + 2.*xbm_r + xmu_r - do n = 1, 4 - xcrg(n) = WGAMMA(xcre(n)) - enddo - xorg2 = 1./xcrg(2) - - xcse(1) = 1. + xbm_s - xcse(2) = 1. + xmu_s - xcse(3) = 1. + xbm_s + xmu_s - xcse(4) = 1. + 2.*xbm_s + xmu_s - do n = 1, 4 - xcsg(n) = WGAMMA(xcse(n)) - enddo - xosg2 = 1./xcsg(2) - - xcge(1) = 1. + xbm_g - xcge(2) = 1. + xmu_g - xcge(3) = 1. + xbm_g + xmu_g - xcge(4) = 1. + 2.*xbm_g + xmu_g - do n = 1, 4 - xcgg(n) = WGAMMA(xcge(n)) - enddo - xogg2 = 1./xcgg(2) - - xobmr = 1./xbm_r - xoams = 1./xam_s - xobms = 1./xbm_s - xocms = xoams**xobms - xoamg = 1./xam_g - xobmg = 1./xbm_g - xocmg = xoamg**xobmg - - - end subroutine radar_init - -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T) - -! Complex refractive Index of Water as function of Temperature T -! [deg C] and radar wavelength lambda [m]; valid for -! lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C -! after Ray (1972) - - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN):: T,lambda - DOUBLE PRECISION:: epsinf,epss,epsr,epsi - DOUBLE PRECISION:: alpha,lambdas,sigma,nenner - COMPLEX*16, PARAMETER:: i = (0d0,1d0) - DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0 - - epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T - epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) & - + 1.190d-5 * (T - 25.0)*(T - 25.0) & - - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0)) - alpha = -16.8129d0/(T+273.16) + 0.0609265d0 - lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2 - - nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) & - + (lambdas/lambda)**(2d0-2d0*alpha) - epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * sin(alpha*PIx*0.5)+1d0)) / nenner - epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * cos(alpha*PIx*0.5)+0d0)) / nenner & - + lambda*1.25664/1.88496 - - m_complex_water_ray = SQRT(CMPLX(epsr,-epsi)) - - END FUNCTION m_complex_water_ray - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_ice_maetzler(lambda,T) - -! complex refractive index of ice as function of Temperature T -! [deg C] and radar wavelength lambda [m]; valid for -! lambda in [0.0001,30] m; T in [-250.0,0.0] C -! Original comment from the Matlab-routine of Prof. Maetzler: -! Function for calculating the relative permittivity of pure ice in -! the microwave region, according to C. Maetzler, "Microwave -! properties of ice and snow", in B. Schmitt et al. (eds.) Solar -! System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer -! Academic Publishers, Dordrecht, pp. 241-257 (1998). Input: -! TK = temperature (K), range 20 to 273.15 -! f = frequency in GHz, range 0.01 to 3000 - - IMPLICIT NONE - DOUBLE PRECISION, INTENT(IN):: T,lambda - DOUBLE PRECISION:: f,c,TK,B1,B2,b,deltabeta,betam,beta,theta,alfa - - c = 2.99d8 - TK = T + 273.16 - f = c / lambda * 1d-9 - - B1 = 0.0207 - B2 = 1.16d-11 - b = 335.0d0 - deltabeta = EXP(-10.02 + 0.0364*(TK-273.16)) - betam = (B1/TK) * ( EXP(b/TK) / ((EXP(b/TK)-1)**2) ) + B2*f*f - beta = betam + deltabeta - theta = 300. / TK - 1. - alfa = (0.00504d0 + 0.0062d0*theta) * EXP(-22.1d0*theta) - m_complex_ice_maetzler = 3.1884 + 9.1e-4*(TK-273.16) - m_complex_ice_maetzler = m_complex_ice_maetzler & - + CMPLX(0.0d0, (alfa/f + beta*f)) - m_complex_ice_maetzler = SQRT(CONJG(m_complex_ice_maetzler)) - - END FUNCTION m_complex_ice_maetzler - -!+---+-----------------------------------------------------------------+ - - subroutine rayleigh_soak_wetgraupel (x_g, a_geo, b_geo, fmelt, & - meltratio_outside, m_w, m_i, lambda, C_back, & - mixingrule,matrix,inclusion, & - host,hostmatrix,hostinclusion) - - IMPLICIT NONE - - DOUBLE PRECISION, INTENT(in):: x_g, a_geo, b_geo, fmelt, lambda, & - meltratio_outside - DOUBLE PRECISION, INTENT(out):: C_back - COMPLEX*16, INTENT(in):: m_w, m_i - CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion, & - host, hostmatrix, hostinclusion - - COMPLEX*16:: m_core, m_air - DOUBLE PRECISION:: D_large, D_g, rhog, x_w, xw_a, fm, fmgrenz, & - volg, vg, volair, volice, volwater, & - meltratio_outside_grenz, mra - INTEGER:: error - DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0 - -! refractive index of air: - m_air = (1.0d0,0.0d0) - -! Limiting the degree of melting --- for safety: - fm = DMAX1(DMIN1(fmelt, 1.0d0), 0.0d0) -! Limiting the ratio of (melting on outside)/(melting on inside): - mra = DMAX1(DMIN1(meltratio_outside, 1.0d0), 0.0d0) - -! ! The relative portion of meltwater melting at outside should increase -! ! from the given input value (between 0 and 1) -! ! to 1 as the degree of melting approaches 1, -! ! so that the melting particle "converges" to a water drop. -! ! Simplest assumption is linear: - mra = mra + (1.0d0-mra)*fm - - x_w = x_g * fm - - D_g = a_geo * x_g**b_geo - - if (D_g .ge. 1d-12) then - - vg = PIx/6. * D_g**3 - rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0) - vg = x_g / rhog - - meltratio_outside_grenz = 1.0d0 - rhog / 1000. - - if (mra .le. meltratio_outside_grenz) then - !..In this case, it cannot happen that, during melting, all the - !.. air inclusions within the ice particle get filled with - !.. meltwater. This only happens at the end of all melting. - volg = vg * (1.0d0 - mra * fm) - - else - !..In this case, at some melting degree fm, all the air - !.. inclusions get filled with meltwater. - fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.) - - if (fm .le. fmgrenz) then - !.. not all air pockets are filled: - volg = (1.0 - mra * fm) * vg - else - !..all air pockets are filled with meltwater, now the - !.. entire ice sceleton melts homogeneously: - volg = (x_g - x_w) / 900.0 + x_w / 1000. - endif - - endif - - D_large = (6.0 / PIx * volg) ** (1./3.) - volice = (x_g - x_w) / (volg * 900.0) - volwater = x_w / (1000. * volg) - volair = 1.0 - volice - volwater - - !..complex index of refraction for the ice-air-water mixture - !.. of the particle: - m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, & - volwater, mixingrule, host, matrix, inclusion, & - hostmatrix, hostinclusion, error) - if (error .ne. 0) then - C_back = 0.0d0 - return - endif - - !..Rayleigh-backscattering coefficient of melting particle: - C_back = (ABS((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 & - * PI5 * D_large**6 / lamda4 - - else - C_back = 0.0d0 - endif - - end subroutine rayleigh_soak_wetgraupel - -!+---+-----------------------------------------------------------------+ - - complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, & - volice, volwater, mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion, cumulerror) - - IMPLICIT NONE - - DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w - CHARACTER(len=*), INTENT(in):: mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion - INTEGER, INTENT(out):: cumulerror - - DOUBLE PRECISION:: vol1, vol2 - COMPLEX*16:: mtmp - INTEGER:: error - - !..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be - !.. air, ice, or water - - cumulerror = 0 - get_m_mix_nested = CMPLX(1.0d0,0.0d0) - - if (host .eq. 'air') then - - if (matrix .eq. 'air') then - write(*,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - cumulerror = cumulerror + 1 - else - vol1 = volice / MAX(volice+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'air') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'icewater') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(*,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'ice') then - - if (matrix .eq. 'ice') then - write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volair+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'ice') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airwater') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - 'air', hostinclusion, error) - cumulerror = cumulerror + error - else - write(*,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'water') then - - if (matrix .eq. 'water') then - write(*,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volice+volair,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'water') then - get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airice') then - get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(*,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'none') then - - get_m_mix_nested = get_m_mix (m_a, m_i, m_w, & - volair, volice, volwater, mixingrule, & - matrix, inclusion, error) - cumulerror = cumulerror + error - - else - write(*,*) 'GET_M_MIX_NESTED: unknown matrix: ', host - cumulerror = cumulerror + 1 - endif - - IF (cumulerror .ne. 0) THEN - write(*,*) 'GET_M_MIX_NESTED: error encountered' - get_m_mix_nested = CMPLX(1.0d0,0.0d0) - endif - - end function get_m_mix_nested - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, & - volwater, mixingrule, matrix, inclusion, error) - - IMPLICIT NONE - - DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w - CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion - INTEGER, INTENT(out):: error - - error = 0 - get_m_mix = CMPLX(1.0d0,0.0d0) - - if (mixingrule .eq. 'maxwellgarnett') then - if (matrix .eq. 'ice') then - get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, & - m_i, m_a, m_w, inclusion, error) - elseif (matrix .eq. 'water') then - get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, & - m_w, m_a, m_i, inclusion, error) - elseif (matrix .eq. 'air') then - get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, & - m_a, m_w, m_i, inclusion, error) - else - write(*,*) 'GET_M_MIX: unknown matrix: ', matrix - error = 1 - endif - - else - write(*,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule - error = 2 - endif - - if (error .ne. 0) then - write(*,*) 'GET_M_MIX: error encountered' - endif - - END FUNCTION get_m_mix - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & - m1, m2, m3, inclusion, error) - - IMPLICIT NONE - - COMPLEX*16 :: m1, m2, m3 - DOUBLE PRECISION :: vol1, vol2, vol3 - CHARACTER(len=*) :: inclusion - - COMPLEX*16 :: beta2, beta3, m1t, m2t, m3t - INTEGER, INTENT(out) :: error - - error = 0 - - if (DABS(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then - write(*,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & - 'partial volume fractions is not 1...ERROR' - m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0) - error = 1 - return - endif - - m1t = m1**2 - m2t = m2**2 - m3t = m3**2 - - if (inclusion .eq. 'spherical') then - beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t) - beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t) - elseif (inclusion .eq. 'spheroidal') then - beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0) - beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) - else - write(*,*) 'M_COMPLEX_MAXWELLGARNETT: ', & - 'unknown inclusion: ', inclusion - m_complex_maxwellgarnett=DCMPLX(-999.99d0,-999.99d0) - error = 1 - return - endif - - m_complex_maxwellgarnett = & - SQRT(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / & - (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3)) - - END FUNCTION m_complex_maxwellgarnett - -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMLN(XX) -! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. - IMPLICIT NONE - REAL, INTENT(IN):: XX - DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 - DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & - COF = (/76.18009172947146D0, -86.50532032941677D0, & - 24.01409824083091D0, -1.231739572450155D0, & - .1208650973866179D-2, -.5395239384953D-5/) - DOUBLE PRECISION:: SER,TMP,X,Y - INTEGER:: J - - X=XX - Y=X - TMP=X+5.5D0 - TMP=(X+0.5D0)*LOG(TMP)-TMP - SER=1.000000000190015D0 - DO 11 J=1,6 - Y=Y+1.D0 - SER=SER+COF(J)/Y -11 CONTINUE - GAMMLN=TMP+LOG(STP*SER/X) - END FUNCTION GAMMLN -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION WGAMMA(y) - - IMPLICIT NONE - REAL, INTENT(IN):: y - - WGAMMA = EXP(GAMMLN(y)) - - END FUNCTION WGAMMA - -!+---+-----------------------------------------------------------------+ - END MODULE module_mp_radar -!+---+-----------------------------------------------------------------+ diff --git a/src/dynamics/fv3/pmgrid.F90 b/src/dynamics/fv3/pmgrid.F90 deleted file mode 100644 index fff3dbce18..0000000000 --- a/src/dynamics/fv3/pmgrid.F90 +++ /dev/null @@ -1,15 +0,0 @@ -module pmgrid - -! PLON and PLAT do not correspond to the number of latitudes and longitudes in -! this version of dynamics. - -implicit none -save - -integer, parameter :: plev = PLEV ! number of vertical levels -integer, parameter :: plevp = plev + 1 - -integer, parameter :: plon = 1 -integer, parameter :: plat = 1 - -end module pmgrid diff --git a/src/dynamics/fv3/restart_dynamics.F90 b/src/dynamics/fv3/restart_dynamics.F90 deleted file mode 100644 index 8679f30c95..0000000000 --- a/src/dynamics/fv3/restart_dynamics.F90 +++ /dev/null @@ -1,447 +0,0 @@ -module restart_dynamics - -! Write and read dynamics fields from the restart file. For exact restart -! it is necessary to write all element data, including duplicate columns, -! to the file. - - use cam_abortutils, only: endrun - use cam_grid_support, only: cam_grid_header_info_t, cam_grid_id, cam_grid_write_attr, & - cam_grid_write_var, cam_grid_get_decomp, cam_grid_dimensions, max_hcoordname_len - use cam_logfile, only: iulog - use cam_pio_utils, only: cam_pio_handle_error - use dyn_comp, only: dyn_import_t, dyn_export_t - use dyn_grid, only: mytile - use fv_arrays_mod, only: fv_atmos_type - use pio, only: file_desc_t, var_desc_t - use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8 - use spmd_utils, only: masterproc - - implicit none - private - - public :: init_restart_dynamics, write_restart_dynamics, read_restart_dynamics - - type(var_desc_t) :: udesc, vdesc, tdesc, psdesc, phisdesc, usdesc,vsdesc,delpdesc,omegadesc - - integer :: ncol_d_dimid, ncol_d_ew_dimid, ncol_d_ns_dimid, nlev_dimid, nlevp_dimid - type(var_desc_t), allocatable :: qdesc(:) - integer :: is,ie,js,je - - -!======================================================================= -contains -!======================================================================= - -subroutine init_restart_dynamics(File, dyn_out) - - use constituents, only: cnst_name, pcnst - use hycoef, only: init_restart_hycoef - use pio, only: pio_unlimited, pio_double, pio_def_dim, & - pio_seterrorhandling, pio_bcast_error, & - pio_def_var, & - pio_inq_dimid - - ! arguments - type(file_desc_t), intent(inout) :: file - type(dyn_export_t), intent(in) :: dyn_out - - ! local variables - integer :: vdimids(2) - integer :: ierr, i, err_handling - integer :: time_dimid - integer :: is,ie,js,je - type (fv_atmos_type), pointer :: Atm(:) - - integer :: grid_id,grid_id_ns,grid_id_ew - type(cam_grid_header_info_t) :: info,info_ew,info_ns - - !--------------------------------------------------------------------------- - - Atm=>dyn_out%atm - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - call init_restart_hycoef(File, vdimids) - - call pio_seterrorhandling(File, pio_bcast_error, err_handling) - - ierr = PIO_Def_Dim(File, 'time', PIO_UNLIMITED, time_dimid) - - grid_id = cam_grid_id('FFSL') - call cam_grid_write_attr(File, grid_id, info) - ncol_d_dimid = info%get_hdimid(1) - - grid_id_ew = cam_grid_id('FFSL_EW') - call cam_grid_write_attr(File, grid_id_ew, info_ew) - ncol_d_ew_dimid = info_ew%get_hdimid(1) - - grid_id_ns = cam_grid_id('FFSL_NS') - call cam_grid_write_attr(File, grid_id_ns, info_ns) - ncol_d_ns_dimid = info_ns%get_hdimid(1) - - nlev_dimid = vdimids(1) - - ierr = PIO_Def_Var(File, 'U', pio_double, (/ncol_d_dimid, nlev_dimid/), Udesc) - ierr = PIO_Def_Var(File, 'V', pio_double, (/ncol_d_dimid, nlev_dimid/), Vdesc) - ierr = PIO_Def_Var(File, 'US', pio_double, (/ncol_d_ns_dimid, nlev_dimid/), USdesc) - ierr = PIO_Def_Var(File, 'VS', pio_double, (/ncol_d_ew_dimid, nlev_dimid/), VSdesc) - ierr = PIO_Def_Var(File, 'T', pio_double, (/ncol_d_dimid, nlev_dimid/), Tdesc) - ierr = PIO_Def_Var(File, 'OMEGA', pio_double, (/ncol_d_dimid, nlev_dimid/), omegadesc) - ierr = PIO_Def_Var(File, 'DELP', pio_double, (/ncol_d_dimid, nlev_dimid/), delpdesc) - ierr = PIO_Def_Var(File, 'PS', pio_double, (/ncol_d_dimid/), PSdesc) - ierr = PIO_Def_Var(File, 'PHIS', pio_double, (/ncol_d_dimid/), phisdesc) - - allocate(Qdesc(pcnst)) - - do i = 1, pcnst - ierr = PIO_Def_Var(File, cnst_name(i), pio_double, (/ncol_d_dimid, nlev_dimid/), Qdesc(i)) - end do - - call pio_seterrorhandling(File, err_handling) - -end subroutine init_restart_dynamics - -!======================================================================= - -subroutine write_restart_dynamics(File, dyn_out) - - use hycoef, only: write_restart_hycoef - use constituents, only: pcnst - use dimensions_mod, only: nlev - use pio, only: pio_offset_kind, io_desc_t, pio_double, pio_write_darray - use time_manager, only: get_curr_time, get_curr_date - - ! arguments - type(file_desc_t), intent(inout) :: File - type(dyn_export_t), intent(in) :: dyn_out - - ! local variables - integer(pio_offset_kind), parameter :: t_idx = 1 - type (fv_atmos_type), pointer :: Atm(:) - - type(io_desc_t),pointer :: iodesc3d,iodesc3d_ns,iodesc3d_ew,iodesc - integer :: m, ierr - integer :: array_lens_3d(3), array_lens_2d(2) - integer :: file_lens_2d(2), file_lens_1d(1) - integer :: grid_id,grid_id_ns,grid_id_ew - integer :: grid_dimlens(2),grid_dimlens_ew(2),grid_dimlens_ns(2) - integer :: ilen,jlen - - !--------------------------------------------------------------------------- - - call write_restart_hycoef(File) - - Atm=>dyn_out%atm - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - grid_id = cam_grid_id('FFSL') - grid_id_ew = cam_grid_id('FFSL_EW') - grid_id_ns = cam_grid_id('FFSL_NS') - - ! write coordinate variables for unstructured FFSL, NS and EW restart grid - ! (restart grids have tile based global indicies with duplicate edge points - ! being given uniq indicies. All duplicate point written out to restart file) - ! - io overhead = 6 tile edges are duplicated and read from the file - ! instead of mpi gathers to fill in duplicates. - - call cam_grid_write_var(File, grid_id) - call cam_grid_write_var(File, grid_id_ew) - call cam_grid_write_var(File, grid_id_ns) - - ! create map for distributed write - call cam_grid_dimensions(grid_id, grid_dimlens) - call cam_grid_dimensions(grid_id_ew, grid_dimlens_ew) - call cam_grid_dimensions(grid_id_ns, grid_dimlens_ns) - - ilen=ie-is+1 - jlen=je-js+1 - - ! create map for distributed write of 2D fields - array_lens_2d = (/ilen,jlen/) - file_lens_1d = (/grid_dimlens(1)/) - call cam_grid_get_decomp(grid_id, array_lens_2d, file_lens_1d, pio_double, iodesc) - ! Write PHIS - call PIO_Write_Darray(File, phisdesc, iodesc, Atm(mytile)%phis(is:ie,js:je), ierr) - ! Write PS - call PIO_Write_Darray(File, psdesc, iodesc, Atm(mytile)%ps(is:ie,js:je), ierr) - - array_lens_3d = (/ilen,jlen,nlev/) - file_lens_2d = (/grid_dimlens(1), nlev/) - call cam_grid_get_decomp(grid_id, array_lens_3d, file_lens_2d, pio_double, iodesc3d) - ! Write U a-grid - call PIO_Write_Darray(File, Udesc, iodesc3d, Atm(mytile)%ua(is:ie,js:je,1:nlev), ierr) - ! Write V a-grid - call PIO_Write_Darray(File, Vdesc, iodesc3d, Atm(mytile)%va(is:ie,js:je,1:nlev) , ierr) - ! Write OMEGA a-grid - call PIO_Write_Darray(File, Omegadesc, iodesc3d, Atm(mytile)%omga(is:ie,js:je,1:nlev), ierr) - ! Write DELP a-grid - call PIO_Write_Darray(File, delpdesc, iodesc3d, Atm(mytile)%delp(is:ie,js:je,1:nlev), ierr) - ! Write PT a-grid - call PIO_Write_Darray(File, Tdesc, iodesc3d, Atm(mytile)%pt(is:ie,js:je,1:nlev), ierr) - ! Write Tracers a-grid - do m = 1, pcnst - call PIO_Write_Darray(File, Qdesc(m), iodesc3d, Atm(mytile)%q(is:ie,js:je,1:nlev,m), ierr) - end do - - deallocate(qdesc) - - ! create map for distributed write of 3D NS fields - array_lens_3d = (/ilen ,(jlen+1), nlev/) - file_lens_2d = (/grid_dimlens_ns(1), nlev/) - call cam_grid_get_decomp(grid_id_ns, array_lens_3d, file_lens_2d, pio_double, iodesc3d_ns) - - !WRITE US - call PIO_Write_Darray(File, USdesc, iodesc3d_ns, Atm(mytile)%u(is:ie,js:je+1,1:nlev), ierr) - - ! create map for distributed write of 3D EW fields - array_lens_3d = (/(ilen+1), jlen, nlev /) - file_lens_2d = (/grid_dimlens_ew(1), nlev/) - call cam_grid_get_decomp(grid_id_ew, array_lens_3d, file_lens_2d, pio_double, iodesc3d_ew) - - !WRITE VS - call PIO_Write_Darray(File, VSdesc, iodesc3d_ew, Atm(mytile)%v(is:ie+1,js:je,1:nlev), ierr) - -end subroutine write_restart_dynamics - -!======================================================================= - -subroutine read_restart_dynamics(File, dyn_in, dyn_out) - - use cam_history_support, only: max_fieldname_len - use constituents, only: cnst_name, pcnst - use dimensions_mod,only: npy,npx,nlev - use dyn_comp, only: dyn_init - use dyn_grid, only: Atm - use mpp_domains_mod, only: mpp_update_domains, DGRID_NE, mpp_get_boundary - use pio, only: file_desc_t, pio_double, & - pio_inq_dimid, pio_inq_dimlen, pio_inq_varid, & - pio_read_darray, file_desc_t, io_desc_t, pio_double,pio_offset_kind,& - pio_seterrorhandling, pio_bcast_error - - ! arguments - type(File_desc_t), intent(inout) :: File - type(dyn_import_t), intent(out) :: dyn_in - type(dyn_export_t), intent(out) :: dyn_out - - ! local variables - integer(pio_offset_kind), parameter :: t_idx = 1 - - integer :: tl - integer :: i, k, m, j - integer :: ierr, err_handling - integer :: fnlev - integer :: ncols_d_ns, ncols_d_ew, ncols_d - - integer :: ncol_d_dimid - integer :: ncol_d_ns_dimid - integer :: ncol_d_ew_dimid - - type(var_desc_t) :: omegadesc - type(var_desc_t) :: delpdesc - type(var_desc_t) :: udesc - type(var_desc_t) :: vdesc - type(var_desc_t) :: usdesc - type(var_desc_t) :: vsdesc - type(var_desc_t) :: tdesc - type(var_desc_t) :: psdesc - type(var_desc_t) :: phisdesc - type(var_desc_t), allocatable :: qdesc(:) - type(io_desc_t),pointer :: iodesc2d, iodesc3d,iodesc3d_ns,iodesc3d_ew - integer :: array_lens_3d(3), array_lens_2d(2) - integer :: file_lens_2d(2), file_lens_1d(1) - integer :: grid_id,grid_id_ns,grid_id_ew,ilen,jlen - integer :: grid_dimlens(2),grid_dimlens_ns(2),grid_dimlens_ew(2) - - real(r8), allocatable :: ebuffer(:,:) - real(r8), allocatable :: nbuffer(:,:) - - character(len=*), parameter :: sub = 'read_restart_dynamics' - character(len=256) :: errormsg - !---------------------------------------------------------------------------- - - ! Note1: the hybrid coefficients are read from the same location as for an - ! initial run (e.g., dyn_grid_init). - - ! Note2: the dyn_in and dyn_out objects are not associated with the Atm dynamics - ! object until dyn_init is called. Until the restart is better integrated - ! into dyn_init we just access Atm directly from the dyn_grid - ! module. FV3 dyn_init calls an fv3 diagnostic init routine that tries to access - ! surface pressure in the Atm structure and at the top of read_restart PS hasn't - ! been read in yet. - - tl = 1 - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - call pio_seterrorhandling(File, pio_bcast_error, err_handling) - - ierr = PIO_Inq_DimID(File, 'lev', nlev_dimid) - ierr = PIO_Inq_dimlen(File, nlev_dimid, fnlev) - if (nlev /= fnlev) then - write(errormsg, *) ': Restart file nlev dimension does not match model levels:',& - 'file nlev=',fnlev,', model nlev=',nlev - call endrun(sub//trim(errormsg)) - end if - - ! variable descriptors of required dynamics fields - ierr = PIO_Inq_varid(File, 'DELP', delpdesc) - call cam_pio_handle_error(ierr, sub//': cannot find DELP') - ierr = PIO_Inq_varid(File, 'OMEGA', omegadesc) - call cam_pio_handle_error(ierr, sub//': cannot find OMEGA') - ierr = PIO_Inq_varid(File, 'U', udesc) - call cam_pio_handle_error(ierr, sub//': cannot find UA') - ierr = PIO_Inq_varid(File, 'V', Vdesc) - call cam_pio_handle_error(ierr, sub//': cannot find VA') - ierr = PIO_Inq_varid(File, 'US', usdesc) - call cam_pio_handle_error(ierr, sub//': cannot find US') - ierr = PIO_Inq_varid(File, 'VS', Vsdesc) - call cam_pio_handle_error(ierr, sub//': cannot find VS') - ierr = PIO_Inq_varid(File, 'T', tdesc) - call cam_pio_handle_error(ierr, sub//': cannot find T') - ierr = PIO_Inq_varid(File, 'PS', psdesc) - call cam_pio_handle_error(ierr, sub//': cannot find PS') - ierr = PIO_Inq_varid(File, 'PHIS', phisdesc) - call cam_pio_handle_error(ierr, sub//': cannot find PHIS') - allocate(qdesc(pcnst)) - do m = 1, pcnst - ierr = PIO_Inq_varid(File, trim(cnst_name(m)), Qdesc(m)) - call cam_pio_handle_error(ierr, sub//': cannot find '//trim(cnst_name(m))) - end do - - ! check whether the restart fields on the GLL grid contain unique columns - ! or the fv3 task structure (ncol_d_ns = (ie-is+1)*(je-js+2)+npes columns) - ! or the fv3 task structure (ncol_d_ew = (ie-is+2)*(je-js+1)+npes columns) - - ierr = PIO_Inq_DimID(File, 'ncol_d', ncol_d_dimid) - call cam_pio_handle_error(ierr, sub//': cannot find ncol_d') - ierr = PIO_Inq_dimlen(File, ncol_d_dimid, ncols_d) - - ierr = PIO_Inq_DimID(File, 'ncol_d_ns', ncol_d_ns_dimid) - call cam_pio_handle_error(ierr, sub//': cannot find ncol_d_ns') - ierr = PIO_Inq_dimlen(File, ncol_d_ns_dimid, ncols_d_ns) - - ierr = PIO_Inq_DimID(File, 'ncol_d_ew', ncol_d_ew_dimid) - call cam_pio_handle_error(ierr, sub//': cannot find ncol_d_ew') - ierr = PIO_Inq_dimlen(File, ncol_d_ew_dimid, ncols_d_ew) - - grid_id = cam_grid_id('FFSL') - grid_id_ns = cam_grid_id('FFSL_NS') - grid_id_ew = cam_grid_id('FFSL_EW') - call cam_grid_dimensions(grid_id, grid_dimlens) - call cam_grid_dimensions(grid_id_ew, grid_dimlens_ew) - call cam_grid_dimensions(grid_id_ns, grid_dimlens_ns) - - if (ncols_d /= grid_dimlens(1)) then - write(errormsg, *) ':Restart file ncol_d dimension does not match number of model A-Grid columns',& - 'Restart ncols_d=',ncols_d,', A-Grid ncols=',grid_dimlens(1) - call endrun(sub//trim(errormsg)) - end if - - if (ncols_d_ns /= grid_dimlens_ns(1)) then - write(errormsg, *) ':Restart file ncol_d dimension does not match number of model D-Grid ns columns',& - 'Restart ncols_d_ns=',ncols_d_ns,', D-Grid ns ncols=',grid_dimlens_ns(1) - call endrun(sub//trim(errormsg)) - end if - - if (ncols_d_ew /= grid_dimlens_ew(1)) then - write(errormsg, *) ':Restart file ncol_d dimension does not match number of model D-Grid ew columns',& - 'Restart ncols_d_ew=',ncols_d_ew,', D-Grid ew ncols=',grid_dimlens_ew(1) - call endrun(sub//trim(errormsg)) - end if - - ilen = ie-is+1 - jlen = je-js+1 - ! create map for distributed write of 2D fields - array_lens_2d = (/ilen,jlen/) - file_lens_1d = (/grid_dimlens(1)/) - call cam_grid_get_decomp(grid_id, array_lens_2d, file_lens_1d, pio_double, iodesc2d) - - ! create map for distributed write of 3D fields - array_lens_3d = (/ilen, jlen,nlev/) - file_lens_2d = (/grid_dimlens(1), nlev/) - call cam_grid_get_decomp(grid_id, array_lens_3d, file_lens_2d, pio_double, iodesc3d) - - ! create map for distributed write of 3D NS fields - array_lens_3d = (/ilen, jlen+1, nlev/) - file_lens_2d = (/grid_dimlens_ns(1), nlev/) - call cam_grid_get_decomp(grid_id_ns, array_lens_3d, file_lens_2d, pio_double, iodesc3d_ns) - - ! create map for distributed write of 3D EW fields - array_lens_3d = (/ilen+1, jlen, nlev/) - file_lens_2d = (/grid_dimlens_ew(1), nlev/) - call cam_grid_get_decomp(grid_id_ew, array_lens_3d, file_lens_2d, pio_double, iodesc3d_ew) - - ! PS - call PIO_Read_Darray(File, psdesc, iodesc2d,atm(mytile)%ps(is:ie,js:je), ierr) - ! PHIS - call PIO_Read_Darray(File, phisdesc, iodesc2d, atm(mytile)%phis(is:ie,js:je), ierr) - ! OMEGA - call PIO_Read_Darray(File, omegadesc, iodesc3d,Atm(mytile)%omga(is:ie,js:je,1:nlev), ierr) - ! DELP - call PIO_Read_Darray(File, delpdesc, iodesc3d, atm(mytile)%delp(is:ie,js:je,1:nlev), ierr) - ! T - call PIO_Read_Darray(File, Tdesc, iodesc3d,atm(mytile)%pt(is:ie,js:je,1:nlev) , ierr) - ! V - call PIO_Read_Darray(File, Vdesc, iodesc3d, atm(mytile)%va(is:ie,js:je,1:nlev), ierr) - ! U - call PIO_Read_Darray(File, Udesc, iodesc3d, atm(mytile)%ua(is:ie,js:je,1:nlev), ierr) - ! tracers - do m = 1, pcnst - call PIO_Read_Darray(File, Qdesc(m), iodesc3d, atm(mytile)%q(is:ie,js:je,1:nlev,m), ierr) - end do - - deallocate(qdesc) - - ! US and VS After reading unique points on D grid call get_boundary routine to fill - ! missing points on the north and east block boundaries which are duplicated between - ! adjacent blocks. - - allocate(ebuffer(npy+2,nlev)) - allocate(nbuffer(npx+2,nlev)) - nbuffer = 0._r8 - ebuffer = 0._r8 - ! US - call PIO_Read_Darray(File, USdesc, iodesc3d_ns, atm(mytile)%u(is:ie,js:je+1,1:nlev), ierr) - ! VS - call PIO_Read_Darray(File, VSdesc, iodesc3d_ew, atm(mytile)%v(is:ie+1,js:je,1:nlev), ierr) - ! US/VS duplicates - call mpp_get_boundary(atm(mytile)%u, atm(mytile)%v, atm(mytile)%domain, ebuffery=ebuffer, & - nbufferx=nbuffer, gridtype=DGRID_NE ) - do k=1,nlev - do i=is,ie - atm(mytile)%u(i,je+1,k) = nbuffer(i-is+1,k) - enddo - do j=js,je - atm(mytile)%v(ie+1,j,k) = ebuffer(j-js+1,k) - enddo - enddo - deallocate(ebuffer) - deallocate(nbuffer) - - ! Update halo points on each processor - - call mpp_update_domains( Atm(mytile)%phis, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%ps, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%u,atm(mytile)%v, Atm(mytile)%domain, gridtype=DGRID_NE, complete=.true. ) - call mpp_update_domains( atm(mytile)%pt, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%delp, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%omga, Atm(mytile)%domain ) - call mpp_update_domains( atm(mytile)%q, Atm(mytile)%domain ) - - call dyn_init(dyn_in, dyn_out) - - call pio_seterrorhandling(File, err_handling) - - - end subroutine read_restart_dynamics - -end module restart_dynamics diff --git a/src/dynamics/fv3/spmd_dyn.F90 b/src/dynamics/fv3/spmd_dyn.F90 deleted file mode 100644 index d1634d7f9d..0000000000 --- a/src/dynamics/fv3/spmd_dyn.F90 +++ /dev/null @@ -1,18 +0,0 @@ -module spmd_dyn - - ! Purpose: SPMD implementation of CAM FV3 dynamics. - - implicit none - private - - ! These variables are not used locally, but are set and used in phys_grid. - ! They probably should be moved there. - logical, public :: local_dp_map=.true. ! flag indicates that mapping between dynamics - ! and physics decompositions does not require - ! interprocess communication - integer, public :: block_buf_nrecs ! number of local grid points (lon,lat,lev) - ! in dynamics decomposition (including level 0) - integer, public :: chunk_buf_nrecs ! number of local grid points (lon,lat,lev) - ! in physics decomposition (including level 0) - ! assigned in phys_grid.F90 -end module spmd_dyn diff --git a/src/dynamics/fv3/stepon.F90 b/src/dynamics/fv3/stepon.F90 deleted file mode 100644 index 3dea958877..0000000000 --- a/src/dynamics/fv3/stepon.F90 +++ /dev/null @@ -1,334 +0,0 @@ -module stepon - - ! MODULE: stepon -- FV3 Dynamics specific time-stepping - - use shr_kind_mod, only: r8 => shr_kind_r8 - use physics_types, only: physics_state, physics_tend - use ppgrid, only: begchunk, endchunk - use perf_mod, only: t_startf, t_stopf, t_barrierf - use spmd_utils, only: iam, masterproc, mpicom - use dyn_comp, only: dyn_import_t, dyn_export_t - use dyn_grid, only: mytile - use time_manager, only: get_step_size - use dimensions_mod, only: qsize_tracer_idx_cam2dyn - - use aerosol_properties_mod, only: aerosol_properties - use aerosol_state_mod, only: aerosol_state - use microp_aero, only: aerosol_state_object, aerosol_properties_object - - implicit none - private - - public stepon_init ! Initialization - public stepon_run1 ! run method phase 1 - public stepon_run2 ! run method phase 2 - public stepon_run3 ! run method phase 3 - public stepon_final ! Finalization - - class(aerosol_properties), pointer :: aero_props_obj => null() - logical :: aerosols_transported = .false. - -!======================================================================= -contains -!======================================================================= - -subroutine stepon_init(dyn_in, dyn_out) - - ! ROUTINE: stepon_init -- Time stepping initialization - - use cam_history, only: addfld, add_default, horiz_only - use constituents, only: pcnst, cnst_name, cnst_longname - - type (dyn_import_t), intent(inout) :: dyn_in ! Dynamics import container - type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container - - ! local variables - integer :: m_cnst,m_cnst_ffsl - !---------------------------------------------------------------------------- - ! These fields on dynamics grid are output before the call to d_p_coupling. - do m_cnst = 1, pcnst - m_cnst_ffsl=qsize_tracer_idx_cam2dyn(m_cnst) - call addfld(trim(cnst_name(m_cnst))//'_ffsl', (/ 'lev' /), 'I', 'kg/kg', & - trim(cnst_longname(m_cnst)), gridname='FFSLHIST') - call addfld(trim(cnst_name(m_cnst))//'_mass_ffsl', (/ 'lev' /), 'I', 'kg/kg', & - trim(cnst_longname(m_cnst))//'*dp', gridname='FFSLHIST') - end do - call addfld('U_ffsl' ,(/ 'lev' /), 'I', 'm/s ','U wind on A grid after dynamics',gridname='FFSLHIST') - call addfld('V_ffsl' ,(/ 'lev' /), 'I', 'm/s ','V wind on A grid after dynamics',gridname='FFSLHIST') - call addfld('U_ffsl_ns' ,(/ 'lev' /), 'I', 'm/s ','U wind on NS grid after dynamics',gridname='FFSLHIST_NS') - call addfld('V_ffsl_ew' ,(/ 'lev' /), 'I', 'm/s ','V wind on EW grid after dynamics',gridname='FFSLHIST_EW') - call addfld('T_ffsl' ,(/ 'lev' /), 'I', 'K ' ,'T on A grid grid after dynamics' ,gridname='FFSLHIST') - call addfld('PS_ffsl', horiz_only, 'I', 'Pa', 'Surface pressure on A grid after dynamics',gridname='FFSLHIST') - call addfld('PHIS_ffsl', horiz_only, 'I', 'Pa', 'Geopotential height on A grid after dynamics',gridname='FFSLHIST') - - - ! Fields for initial condition files - call addfld('U&IC', (/ 'lev' /), 'I', 'm/s', 'Zonal wind', gridname='FFSLHIST' ) - call addfld('V&IC', (/ 'lev' /), 'I', 'm/s', 'Meridional wind',gridname='FFSLHIST' ) - ! Don't need to register U&IC V&IC as vector components since we don't interpolate IC files - call add_default('U&IC',0, 'I') - call add_default('V&IC',0, 'I') - - call addfld('PS&IC', horiz_only, 'I', 'Pa', 'Surface pressure',gridname='FFSLHIST') - call addfld('PHIS&IC', horiz_only, 'I', 'Pa', 'PHIS on ffsl grid',gridname='FFSLHIST') - call addfld('T&IC', (/ 'lev' /), 'I', 'K', 'Temperature', gridname='FFSLHIST') - call add_default('PS&IC',0, 'I') - call add_default('PHIS&IC',0, 'I') - call add_default('T&IC ',0, 'I') - - do m_cnst = 1,pcnst - call addfld(trim(cnst_name(m_cnst))//'&IC', (/ 'lev' /), 'I', 'kg/kg', & - trim(cnst_longname(m_cnst)), gridname='FFSLHIST') - call add_default(trim(cnst_name(m_cnst))//'&IC', 0, 'I') - end do - - ! get aerosol properties - aero_props_obj => aerosol_properties_object() - - if (associated(aero_props_obj)) then - ! determine if there are transported aerosol contistuents - aerosols_transported = aero_props_obj%number_transported()>0 - end if - -end subroutine stepon_init - -!======================================================================= - -subroutine stepon_run1(dtime_out, phys_state, phys_tend, pbuf2d, dyn_in, dyn_out) - - ! ROUTINE: stepon_run1 -- Phase 1 of dynamics run method. - - use physics_buffer, only: physics_buffer_desc - use dp_coupling, only: d_p_coupling - - real(r8), intent(out) :: dtime_out ! Time-step - type (physics_state), intent(inout) :: phys_state(begchunk:endchunk) - type (physics_tend), intent(inout) :: phys_tend(begchunk:endchunk) - type (physics_buffer_desc), pointer :: pbuf2d(:,:) - type (dyn_import_t), intent(inout) :: dyn_in ! Dynamics import container - type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container - - integer :: c - class(aerosol_state), pointer :: aero_state_obj - nullify(aero_state_obj) - - dtime_out = get_step_size() - - call diag_dyn_out(dyn_out,'') - - !---------------------------------------------------------- - ! Move data into phys_state structure. - !---------------------------------------------------------- - - call t_barrierf('sync_d_p_coupling', mpicom) - call t_startf('d_p_coupling') - call d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) - call t_stopf('d_p_coupling') - - !---------------------------------------------------------- - ! update aerosol state object from CAM physics state constituents - !---------------------------------------------------------- - if (aerosols_transported) then - - do c = begchunk,endchunk - aero_state_obj => aerosol_state_object(c) - ! pass number mass or number mixing ratios of aerosol constituents - ! to aerosol state object - call aero_state_obj%set_transported(phys_state(c)%q) - end do - - end if - -end subroutine stepon_run1 - -!======================================================================= - -subroutine stepon_run2(phys_state, phys_tend, dyn_in, dyn_out) - - ! ROUTINE: stepon_run2 -- second phase run method - - use dp_coupling, only: p_d_coupling - use dyn_comp, only: calc_tot_energy_dynamics - - type (physics_state), intent(inout) :: phys_state(begchunk:endchunk) - type (physics_tend), intent(inout) :: phys_tend(begchunk:endchunk) - type (dyn_import_t), intent(inout) :: dyn_in ! Dynamics import container - type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container - - integer :: c - class(aerosol_state), pointer :: aero_state_obj - - ! copy from phys structures -> dynamics structures - - !---------------------------------------------------------- - ! update physics state with aerosol constituents - !---------------------------------------------------------- - nullify(aero_state_obj) - - if (aerosols_transported) then - do c = begchunk,endchunk - aero_state_obj => aerosol_state_object(c) - ! get mass or number mixing ratios of aerosol constituents - call aero_state_obj%get_transported(phys_state(c)%q) - end do - end if - - call t_barrierf('sync_p_d_coupling', mpicom) -#if ( defined CALC_ENERGY ) - call calc_tot_energy_dynamics(dyn_in%atm, 'dED') -#endif - call t_startf('p_d_coupling') - call p_d_coupling(phys_state, phys_tend, dyn_in) - call t_stopf('p_d_coupling') - -#if ( defined CALC_ENERGY ) - call calc_tot_energy_dynamics(dyn_in%atm, 'dBD') -#endif -end subroutine stepon_run2 - -!======================================================================= - -subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) - - use camsrfexch, only: cam_out_t - use dyn_comp, only: dyn_run - - real(r8), intent(in) :: dtime ! Time-step - type (physics_state), intent(in):: phys_state(begchunk:endchunk) - type (dyn_import_t), intent(inout) :: dyn_in ! Dynamics import container - type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container - type (cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) - - call t_barrierf('sync_dyn_run', mpicom) - call t_startf('dyn_run') - call dyn_run(dyn_out) - call t_stopf('dyn_run') - -end subroutine stepon_run3 - -!======================================================================= - -subroutine stepon_final(dyn_in, dyn_out) - - ! ROUTINE: stepon_final -- Dynamics finalization - - use dyn_comp, only: dyn_final - - type (dyn_import_t), intent(inout) :: dyn_in ! Dynamics import container - type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container - - call t_startf('dyn_final') - call dyn_final(dyn_in, dyn_out) - call t_stopf('dyn_final') - -end subroutine stepon_final - -!======================================================================= - -subroutine diag_dyn_out(dyn_in,suffx) - - use cam_history, only: write_inithist, outfld, hist_fld_active, fieldname_len - use constituents, only: cnst_name, pcnst - use dyn_grid, only: mytile - use fv_arrays_mod, only: fv_atmos_type - use dimensions_mod, only: nlev - - type (dyn_export_t), intent(in) :: dyn_in - character*(*) , intent(in) :: suffx ! suffix for "outfld" names - - - ! local variables - integer :: is,ie,js,je, j, m_cnst,m_cnst_ffsl - integer :: idim - character(len=fieldname_len) :: tfname - - type (fv_atmos_type), pointer :: Atm(:) - - !---------------------------------------------------------------------------- - - Atm=>dyn_in%atm - - is = Atm(mytile)%bd%is - ie = Atm(mytile)%bd%ie - js = Atm(mytile)%bd%js - je = Atm(mytile)%bd%je - - idim=ie-is+1 - ! Output tracer fields for analysis of advection schemes - do m_cnst = 1, pcnst - m_cnst_ffsl=qsize_tracer_idx_cam2dyn(m_cnst) - tfname = trim(cnst_name(m_cnst))//'_ffsl'//trim(suffx) - if (hist_fld_active(tfname)) then - do j = js, je - call outfld(tfname, RESHAPE(Atm(mytile)%q(is:ie, j, :, m_cnst_ffsl),(/idim,nlev/)), idim, j) - end do - end if - end do - - ! Output tracer fields for analysis of advection schemes - do m_cnst = 1, pcnst - m_cnst_ffsl=qsize_tracer_idx_cam2dyn(m_cnst) - tfname = trim(cnst_name(m_cnst))//'_mass_ffsl'//trim(suffx) - if (hist_fld_active(tfname)) then - do j = js, je - call outfld(tfname,RESHAPE((Atm(mytile)%q(is:ie,j,:,m_cnst_ffsl)*Atm(mytile)%delp(is:ie,j,:)),(/idim,nlev/)),idim, j) - end do - end if - end do - - if (hist_fld_active('U_ffsl'//trim(suffx)) .or. hist_fld_active('V_ffsl'//trim(suffx))) then - do j = js, je - call outfld('U_ffsl'//trim(suffx), RESHAPE(Atm(mytile)%ua(is:ie, j, :),(/idim,nlev/)), idim, j) - call outfld('V_ffsl'//trim(suffx), RESHAPE(Atm(mytile)%va(is:ie, j, :),(/idim,nlev/)), idim, j) - end do - end if - - if (hist_fld_active('U_ffsl_ns'//trim(suffx))) then - do j = js, je+1 - call outfld('U_ffsl_ns'//trim(suffx), RESHAPE(Atm(mytile)%u(is:ie, j, :),(/idim,nlev/)), idim, j) - end do - end if - - if (hist_fld_active('V_ffsl_ew'//trim(suffx))) then - do j = js, je - call outfld('V_ffsl_ew'//trim(suffx), RESHAPE(Atm(mytile)%v(is:ie+1, j, :),(/idim+1,nlev/)), idim+1, j) - end do - end if - - if (hist_fld_active('T_ffsl'//trim(suffx))) then - do j = js, je - call outfld('T_ffsl'//trim(suffx), RESHAPE(Atm(mytile)%pt(is:ie, j, :),(/idim,nlev/)), idim, j) - end do - end if - - if (hist_fld_active('PS_ffsl'//trim(suffx))) then - do j = js, je - call outfld('PS_ffsl'//trim(suffx), Atm(mytile)%ps(is:ie, j), idim, j) - end do - end if - - if (hist_fld_active('PHIS_ffsl'//trim(suffx))) then - do j = js, je - call outfld('PHIS_ffsl'//trim(suffx), Atm(mytile)%phis(is:ie, j), idim, j) - end do - end if - - if (write_inithist()) then - - do j = js, je - call outfld('T&IC', RESHAPE(Atm(mytile)%pt(is:ie, j, :),(/idim,nlev/)), idim, j) - call outfld('U&IC', RESHAPE(Atm(mytile)%ua(is:ie, j, :),(/idim,nlev/)), idim, j) - call outfld('V&IC', RESHAPE(Atm(mytile)%va(is:ie, j, :),(/idim,nlev/)), idim, j) - call outfld('PS&IC', Atm(mytile)%ps(is:ie, j), idim, j) - call outfld('PHIS&IC', Atm(mytile)%phis(is:ie, j), idim, j) - - do m_cnst = 1, pcnst - m_cnst_ffsl=qsize_tracer_idx_cam2dyn(m_cnst) - call outfld(trim(cnst_name(m_cnst))//'&IC', RESHAPE(Atm(mytile)%q(is:ie, j, :, m_cnst_ffsl),(/idim,nlev/)), idim, j) - end do - end do - end if ! if (write_inithist) - -end subroutine diag_dyn_out - -end module stepon diff --git a/src/dynamics/se/dp_coupling.F90 b/src/dynamics/se/dp_coupling.F90 index 61b7fc54e9..beba3d3611 100644 --- a/src/dynamics/se/dp_coupling.F90 +++ b/src/dynamics/se/dp_coupling.F90 @@ -312,7 +312,7 @@ subroutine p_d_coupling(phys_state, phys_tend, dyn_in, tl_f, tl_qdp) use fvm_mapping, only: phys2dyn_forcings_fvm use test_fvm_mapping, only: test_mapping_overwrite_tendencies use test_fvm_mapping, only: test_mapping_output_mapped_tendencies - + use dimensions_mod, only: use_cslam ! arguments type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state type(physics_tend), intent(inout), dimension(begchunk:endchunk) :: phys_tend @@ -427,8 +427,9 @@ subroutine p_d_coupling(phys_state, phys_tend, dyn_in, tl_f, tl_qdp) !JMD hybrid = config_thread_region(par,'horizontal') hybrid = config_thread_region(par,'serial') call get_loop_ranges(hybrid,ibeg=nets,iend=nete) - - ! high-order mapping of ft and fm (and fq if no cslam) using fvm technology + ! + ! high-order mapping of ft and fm using fvm technology + ! call t_startf('phys2dyn') call phys2dyn_forcings_fvm(elem, dyn_in%fvm, hybrid,nets,nete,ntrac==0, tl_f, tl_qdp) call t_stopf('phys2dyn') @@ -474,19 +475,20 @@ subroutine p_d_coupling(phys_state, phys_tend, dyn_in, tl_f, tl_qdp) dyn_in%elem(ie)%derived%FT(:,:,k) = & dyn_in%elem(ie)%derived%FT(:,:,k) * & dyn_in%elem(ie)%spheremp(:,:) - do m = 1, qsize - dyn_in%elem(ie)%derived%FQ(:,:,k,m) = & - dyn_in%elem(ie)%derived%FQ(:,:,k,m) * & - dyn_in%elem(ie)%spheremp(:,:) - end do end do end if kptr = 0 call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FM(:,:,:,:), 2*nlev, kptr, ie) kptr = kptr + 2*nlev call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FT(:,:,:), nlev, kptr, ie) - kptr = kptr + nlev - call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) + if (.not. use_cslam) then + ! + ! if using CSLAM qdp is being overwritten with CSLAM values in the dynamics + ! so no need to do boundary exchange of tracer tendency on GLL grid here + ! + kptr = kptr + nlev + call edgeVpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) + end if end do if (iam < par%nprocs) then @@ -499,7 +501,9 @@ subroutine p_d_coupling(phys_state, phys_tend, dyn_in, tl_f, tl_qdp) kptr = kptr + 2*nlev call edgeVunpack(edgebuf, dyn_in%elem(ie)%derived%FT(:,:,:), nlev, kptr, ie) kptr = kptr + nlev - call edgeVunpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) + if (.not. use_cslam) then + call edgeVunpack(edgebuf, dyn_in%elem(ie)%derived%FQ(:,:,:,:), nlev*qsize, kptr, ie) + end if if (fv_nphys > 0) then do k = 1, nlev dyn_in%elem(ie)%derived%FM(:,:,1,k) = & @@ -511,11 +515,6 @@ subroutine p_d_coupling(phys_state, phys_tend, dyn_in, tl_f, tl_qdp) dyn_in%elem(ie)%derived%FT(:,:,k) = & dyn_in%elem(ie)%derived%FT(:,:,k) * & dyn_in%elem(ie)%rspheremp(:,:) - do m = 1, qsize - dyn_in%elem(ie)%derived%FQ(:,:,k,m) = & - dyn_in%elem(ie)%derived%FQ(:,:,k,m) * & - dyn_in%elem(ie)%rspheremp(:,:) - end do end do end if end do @@ -691,23 +690,21 @@ subroutine derived_phys_dry(phys_state, phys_tend, pbuf2d) end if end do + ! Ensure tracers are all positive + call qneg3('D_P_COUPLING',lchnk ,ncol ,pcols ,pver , & + 1, pcnst, qmin ,phys_state(lchnk)%q) + ! Compute initial geopotential heights - based on full pressure call geopotential_t(phys_state(lchnk)%lnpint, phys_state(lchnk)%lnpmid , phys_state(lchnk)%pint, & phys_state(lchnk)%pmid , phys_state(lchnk)%pdel , phys_state(lchnk)%rpdel , & phys_state(lchnk)%t , phys_state(lchnk)%q(:,:,:), rairv(:,:,lchnk), gravit, zvirv , & phys_state(lchnk)%zi , phys_state(lchnk)%zm , ncol) - ! Compute initial dry static energy, include surface geopotential call update_dry_static_energy_run(pver, gravit, phys_state(lchnk)%t(1:ncol,:), & phys_state(lchnk)%zm(1:ncol,:), & phys_state(lchnk)%phis(1:ncol), & phys_state(lchnk)%s(1:ncol,:), & cpairv(1:ncol,:,lchnk), errflg, errmsg) - - ! Ensure tracers are all positive - call qneg3('D_P_COUPLING',lchnk ,ncol ,pcols ,pver , & - 1, pcnst, qmin ,phys_state(lchnk)%q) - ! Compute energy and water integrals of input state pbuf_chnk => pbuf_get_chunk(pbuf2d, lchnk) call check_energy_timestep_init(phys_state(lchnk), phys_tend(lchnk), pbuf_chnk) diff --git a/src/dynamics/se/dycore/control_mod.F90 b/src/dynamics/se/dycore/control_mod.F90 index 053f478c6a..6d92e66d7d 100644 --- a/src/dynamics/se/dycore/control_mod.F90 +++ b/src/dynamics/se/dycore/control_mod.F90 @@ -16,6 +16,7 @@ module control_mod integer, public :: rk_stage_user = 0 ! number of RK stages to use integer, public :: ftype = 2 ! Forcing Type integer, public :: ftype_conserve = 1 !conserve momentum (dp*u) + integer, public :: dribble_in_rsplit_loop = 0 integer, public :: statediag_numtrac = 3 integer, public :: qsplit = 1 ! ratio of dynamics tsteps to tracer tsteps diff --git a/src/dynamics/se/dycore/element_mod.F90 b/src/dynamics/se/dycore/element_mod.F90 index 6ba2b36e02..2e758727db 100644 --- a/src/dynamics/se/dycore/element_mod.F90 +++ b/src/dynamics/se/dycore/element_mod.F90 @@ -25,9 +25,8 @@ module element_mod real (kind=r8) :: T (np,np,nlev,timelevels) ! temperature real (kind=r8) :: dp3d (np,np,nlev,timelevels) ! dry delta p on levels real (kind=r8) :: psdry (np,np) ! dry surface pressure - real (kind=r8) :: phis (np,np) ! surface geopotential (prescribed) - real (kind=r8) :: Qdp (np,np,nlev,qsize_d,2) ! Tracer mass - + real (kind=r8) :: phis (np,np) ! surface geopotential (prescribed) + real (kind=r8), allocatable :: Qdp(:,:,:,:,:) ! Tracer mass end type elem_state_t !___________________________________________________________________ @@ -43,20 +42,16 @@ module element_mod real (kind=r8) :: phi(np,np,nlev) ! geopotential real (kind=r8) :: omega(np,np,nlev) ! vertical velocity - ! semi-implicit diagnostics: computed in explict-component, reused in Helmholtz-component. - real (kind=r8) :: zeta(np,np,nlev) ! relative vorticity - real (kind=r8) :: div(np,np,nlev,timelevels) ! divergence - ! tracer advection fields used for consistency and limiters real (kind=r8) :: dp(np,np,nlev) ! for dp_tracers at physics timestep - real (kind=r8) :: divdp(np,np,nlev) ! divergence of dp - real (kind=r8) :: divdp_proj(np,np,nlev) ! DSSed divdp + real (kind=r8), allocatable :: divdp(:,:,:) ! divergence of dp + real (kind=r8), allocatable :: divdp_proj(:,:,:) ! DSSed divdp real (kind=r8) :: mass(MAX(qsize_d,ntrac_d)+9) ! total tracer mass for diagnostics ! forcing terms for CAM - real (kind=r8) :: FQ(np,np,nlev,qsize_d) ! tracer forcing + real (kind=r8), allocatable :: FQ(:,:,:,:) ! tracer forcing real (kind=r8) :: FM(np,np,2,nlev) ! momentum forcing - real (kind=r8) :: FDP(np,np,nlev) ! save full updated dp right after physics + real (kind=r8), allocatable :: FDP(:,:,:) ! save full updated dp right after physics real (kind=r8) :: FT(np,np,nlev) ! temperature forcing real (kind=r8) :: etadot_prescribed(np,np,nlevp) ! prescribed vertical tendency real (kind=r8) :: u_met(np,np,nlev) ! zonal component of prescribed meteorology winds diff --git a/src/dynamics/se/dycore/fvm_control_volume_mod.F90 b/src/dynamics/se/dycore/fvm_control_volume_mod.F90 index c1b3c6fc15..e3208c86cd 100644 --- a/src/dynamics/se/dycore/fvm_control_volume_mod.F90 +++ b/src/dynamics/se/dycore/fvm_control_volume_mod.F90 @@ -128,7 +128,6 @@ module fvm_control_volume_mod ! !****************************************** ! - real (kind=r8) , allocatable :: phis_physgrid(:,:) real (kind=r8) , allocatable :: vtx_cart_physgrid(:,:,:,:) real (kind=r8) , allocatable :: flux_orient_physgrid(:,:,:) integer , allocatable :: ifct_physgrid(:,:) @@ -280,7 +279,6 @@ subroutine allocate_physgrid_vars(fvm,par) end if do ie=1,nelemd - allocate(fvm(ie)%phis_physgrid (fv_nphys,fv_nphys)) allocate(fvm(ie)%vtx_cart_physgrid (4,2,1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys)) allocate(fvm(ie)%flux_orient_physgrid (2,1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys)) allocate(fvm(ie)%ifct_physgrid (1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys)) diff --git a/src/dynamics/se/dycore/fvm_mapping.F90 b/src/dynamics/se/dycore/fvm_mapping.F90 index f52d961be5..0f090ebe9e 100644 --- a/src/dynamics/se/dycore/fvm_mapping.F90 +++ b/src/dynamics/se/dycore/fvm_mapping.F90 @@ -18,13 +18,14 @@ module fvm_mapping use dimensions_mod, only: irecons_tracer use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct - use perf_mod, only: t_startf, t_stopf - + use perf_mod, only: t_startf, t_stopf + use cam_abortutils, only: endrun + use cam_logfile, only: iulog implicit none private public :: phys2dyn_forcings_fvm, dyn2phys, dyn2phys_vector, dyn2phys_all_vars,dyn2fvm_mass_vars - public :: phys2dyn,fvm2dyn,dyn2fvm + public :: phys2dyn,fvm2dyn,dyn2fvm,cslam2gll save integer :: save_max_overlap real(kind=r8), allocatable, dimension(:,:,:,:,:) :: save_air_mass_overlap @@ -48,7 +49,6 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ use dimensions_mod, only: np, nc,nlev use dimensions_mod, only: fv_nphys, nhc_phys,ntrac,nhc,ksponge_end, nu_scale_top use hybrid_mod, only: hybrid_t - use cam_abortutils, only: endrun use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx type (element_t), intent(inout):: elem(:) type(fvm_struct), intent(inout):: fvm(:) @@ -58,8 +58,7 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ integer, intent(in) :: nets, nete, tl_f, tl_qdp integer :: ie,i,j,k,m_cnst,nq - real (kind=r8), dimension(:,:,:,:,:) , allocatable :: fld_phys, fld_gll, fld_fvm - real (kind=r8), allocatable, dimension(:,:,:,:,:) :: qgll + real (kind=r8), dimension(:,:,:,:,:) , allocatable :: fld_phys, fld_gll real (kind=r8) :: element_ave ! ! for tensor product Lagrange interpolation @@ -67,13 +66,7 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ integer :: nflds logical, allocatable :: llimiter(:) - allocate(qgll(np,np,nlev,thermodynamic_active_species_num,nets:nete)) - - do ie=nets,nete - do nq=1,thermodynamic_active_species_num - qgll(:,:,:,nq,ie) = elem(ie)%state%Qdp(:,:,:,nq,tl_qdp)/elem(ie)%state%dp3d(:,:,:,tl_f) - end do - end do + integer :: ierr if (no_cslam) then call endrun("phys2dyn_forcings_fvm: no cslam case: NOT SUPPORTED") @@ -87,9 +80,21 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ ! call t_startf('p2d-pg2:copying') nflds = 4+ntrac - allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete)) - allocate(fld_gll(np,np,nlev,3,nets:nete)) - allocate(llimiter(nflds)) + allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'phys2dyn_forcings_fvm: fld_phys allocation error = ',ierr + call endrun('phys2dyn_forcings_fvm: failed to allocate fld_phys array') + end if + allocate(fld_gll(np,np,nlev,3,nets:nete), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'phys2dyn_forcings_fvm: fld_gll allocation error = ',ierr + call endrun('phys2dyn_forcings_fvm: failed to allocate fld_gll array') + end if + allocate(llimiter(3), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'phys2dyn_forcings_fvm: llimiter allocation error = ',ierr + call endrun('phys2dyn_forcings_fvm: failed to allocate llimiter array') + end if fld_phys = -9.99E99_r8!xxx necessary? llimiter = .false. @@ -113,7 +118,8 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ ! ! do mapping of fu,fv,ft ! - call phys2dyn(hybrid,elem,fld_phys(:,:,:,1:3,:),fld_gll(:,:,:,1:3,:),nets,nete,nlev,3,fvm,llimiter(1:3),2,.true.) + call phys2dyn(hybrid,elem,fld_phys(:,:,:,1:3,:),fld_gll,nets,nete,nlev,3,fvm,llimiter, & + istart_vector=2,halo_filled=.true.) do ie=nets,nete elem(ie)%derived%fT(:,:,:) = fld_gll(:,:,:,1,ie) elem(ie)%derived%fM(:,:,1,:) = fld_gll(:,:,:,2,ie) @@ -134,38 +140,7 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ end do end do call t_stopf('p2d-pg2:phys2fvm') - - ! - ! overwrite SE Q with cslam Q - ! - nflds = thermodynamic_active_species_num - allocate(fld_gll(np,np,nlev,nflds,nets:nete)) - allocate(fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,nflds,nets:nete)) - do ie=nets,nete - ! - ! compute cslam updated Q value - do m_cnst=1,thermodynamic_active_species_num - fld_fvm(1:nc,1:nc,:,m_cnst,ie) = fvm(ie)%c(1:nc,1:nc,:,thermodynamic_active_species_idx(m_cnst))+& - fvm(ie)%fc(1:nc,1:nc,:,thermodynamic_active_species_idx(m_cnst))/fvm(ie)%dp_fvm(1:nc,1:nc,:) - enddo - end do - call t_startf('p2d-pg2:fvm2dyn') - llimiter(1:nflds) = .false. - call fvm2dyn(fld_fvm,fld_gll(:,:,:,1:nflds,:),hybrid,nets,nete,nlev,nflds,fvm,llimiter(1:nflds)) - call t_stopf('p2d-pg2:fvm2dyn') - ! - ! fld_gll now holds q cslam value on gll grid - ! - ! convert fld_gll to increment (q_new-q_old) - ! - do ie=nets,nete - do m_cnst=1,thermodynamic_active_species_num - elem(ie)%derived%fq(:,:,:,m_cnst) =& - fld_gll(:,:,:,m_cnst,ie)-qgll(:,:,:,m_cnst,ie) - end do - end do - deallocate(fld_fvm) - !deallocate arrays allocated in dyn2phys_all_vars + !deallocate arrays allocated in dyn2phys_all_vars deallocate(save_air_mass_overlap,save_q_phys,save_q_overlap,& save_overlap_area,save_num_overlap,save_overlap_idx,save_dp_phys) else @@ -178,7 +153,7 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ !***************************************************************************************** ! ! nflds is ft, fu, fv, + thermo species - nflds = 3+thermodynamic_active_species_num + nflds = 3 allocate(fld_phys(1-nhc_phys:fv_nphys+nhc_phys,1-nhc_phys:fv_nphys+nhc_phys,nlev,nflds,nets:nete)) allocate(fld_gll(np,np,nlev,nflds,nets:nete)) allocate(llimiter(nflds)) @@ -190,18 +165,8 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ fld_phys(1:fv_nphys,1:fv_nphys,:,1,ie) = fvm(ie)%ft(1:fv_nphys,1:fv_nphys,:) fld_phys(1:fv_nphys,1:fv_nphys,:,2,ie) = fvm(ie)%fm(1:fv_nphys,1:fv_nphys,1,:) fld_phys(1:fv_nphys,1:fv_nphys,:,3,ie) = fvm(ie)%fm(1:fv_nphys,1:fv_nphys,2,:) - ! - ! compute cslam mixing ratio with physics update - ! - do m_cnst=1,thermodynamic_active_species_num - do k=1,nlev - fld_phys(1:fv_nphys,1:fv_nphys,k,m_cnst+3,ie) = & - fvm(ie)%c(1:fv_nphys,1:fv_nphys,k,thermodynamic_active_species_idx(m_cnst))+& - fvm(ie)%fc_phys(1:fv_nphys,1:fv_nphys,k,thermodynamic_active_species_idx(m_cnst)) - end do - end do - end do - ! + end do + ! ! do mapping ! call phys2dyn(hybrid,elem,fld_phys,fld_gll,nets,nete,nlev,nflds,fvm,llimiter,2) @@ -210,24 +175,18 @@ subroutine phys2dyn_forcings_fvm(elem, fvm, hybrid,nets,nete,no_cslam, tl_f, tl_ elem(ie)%derived%fM(:,:,1,:) = fld_gll(:,:,:,2,ie) elem(ie)%derived%fM(:,:,2,:) = fld_gll(:,:,:,3,ie) end do + deallocate(fld_gll) do ie=nets,nete - do m_cnst=1,thermodynamic_active_species_num - ! - ! convert fq so that it will effectively overwrite SE q with CSLAM q - ! - elem(ie)%derived%fq(:,:,:,m_cnst) = fld_gll(:,:,:,m_cnst+3,ie)-& - qgll(:,:,:,m_cnst,ie) - end do do m_cnst = 1,ntrac fvm(ie)%fc(1:nc,1:nc,:,m_cnst) = fvm(ie)%fc_phys(1:nc,1:nc,:,m_cnst)*fvm(ie)%dp_fvm(1:nc,1:nc,:) end do end do end if - deallocate(fld_phys,llimiter,fld_gll,qgll) + deallocate(fld_phys,llimiter) end subroutine phys2dyn_forcings_fvm ! for multiple fields - subroutine fvm2dyntn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimiter) + subroutine fvm2dyntn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimiter,halo_filled) use dimensions_mod, only: np, nhc, nc use hybrid_mod , only: hybrid_t use bndry_mod , only: ghost_exchange @@ -240,7 +199,10 @@ subroutine fvm2dyntn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimit type (hybrid_t) , intent(in) :: hybrid type(fvm_struct) , intent(in) :: fvm(nets:nete) logical , intent(in) :: llimiter(num_flds) + logical, optional , intent(in) :: halo_filled !optional if boundary exchange for fld_fvm has already been called + integer :: ie, iwidth + logical :: fill_halo ! !********************************************* ! @@ -248,13 +210,20 @@ subroutine fvm2dyntn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimit ! !********************************************* ! - do ie=nets,nete - call ghostpack(ghostBufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) - end do - call ghost_exchange(hybrid,ghostbufQnhc_s,location='fvm2dyntn') - do ie=nets,nete - call ghostunpack(ghostbufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) - end do + fill_halo = .true. + if (present(halo_filled)) then + fill_halo = .not. halo_filled + end if + + if (fill_halo) then + do ie=nets,nete + call ghostpack(ghostBufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) + end do + call ghost_exchange(hybrid,ghostbufQnhc_s,location='fvm2dyntn') + do ie=nets,nete + call ghostunpack(ghostbufQnhc_s, fld_fvm(:,:,:,:,ie),numlev*num_flds,0,ie) + end do + end if ! ! mapping ! @@ -267,7 +236,7 @@ subroutine fvm2dyntn(fld_fvm,fld_gll,hybrid,nets,nete,numlev,num_flds,fvm,llimit end subroutine fvm2dyntn ! for single field - subroutine fvm2dynt1(fld_fvm,fld_gll,hybrid,nets,nete,numlev,fvm,llimiter) + subroutine fvm2dynt1(fld_fvm,fld_gll,hybrid,nets,nete,numlev,fvm,llimiter,halo_filled) use dimensions_mod, only: np, nhc, nc use hybrid_mod , only: hybrid_t use bndry_mod , only: ghost_exchange @@ -280,7 +249,10 @@ subroutine fvm2dynt1(fld_fvm,fld_gll,hybrid,nets,nete,numlev,fvm,llimiter) type (hybrid_t) , intent(in) :: hybrid type(fvm_struct) , intent(in) :: fvm(nets:nete) logical , intent(in) :: llimiter(1) + logical, optional , intent(in) :: halo_filled!optional if boundary exchange for fld_fvm has already been called + integer :: ie, iwidth + logical :: fill_halo ! !********************************************* ! @@ -288,13 +260,20 @@ subroutine fvm2dynt1(fld_fvm,fld_gll,hybrid,nets,nete,numlev,fvm,llimiter) ! !********************************************* ! - do ie=nets,nete - call ghostpack(ghostBufQnhc_t1, fld_fvm(:,:,:,1,ie),numlev,0,ie) - end do - call ghost_exchange(hybrid,ghostbufQnhc_t1,location='fvm2dynt1') - do ie=nets,nete - call ghostunpack(ghostbufQnhc_t1, fld_fvm(:,:,:,1,ie),numlev,0,ie) - end do + fill_halo = .true. + if (present(halo_filled)) then + fill_halo = .not. halo_filled + end if + + if (fill_halo) then + do ie=nets,nete + call ghostpack(ghostBufQnhc_t1, fld_fvm(:,:,:,1,ie),numlev,0,ie) + end do + call ghost_exchange(hybrid,ghostbufQnhc_t1,location='fvm2dynt1') + do ie=nets,nete + call ghostunpack(ghostbufQnhc_t1, fld_fvm(:,:,:,1,ie),numlev,0,ie) + end do + end if ! ! mapping ! @@ -305,7 +284,6 @@ subroutine fvm2dynt1(fld_fvm,fld_gll,hybrid,nets,nete,numlev,fvm,llimiter) end do end subroutine fvm2dynt1 - subroutine fill_halo_phys(fld_phys,hybrid,nets,nete,num_lev,num_flds) use dimensions_mod, only: nhc_phys, fv_nphys use hybrid_mod , only: hybrid_t @@ -354,7 +332,7 @@ subroutine phys2dyn(hybrid,elem,fld_phys,fld_gll,nets,nete,num_lev,num_flds,fvm, type(fvm_struct) , intent(in) :: fvm(:) integer, optional , intent(in) :: istart_vector logical , intent(in) :: llimiter(num_flds) - logical, optional , intent(in) :: halo_filled + logical, optional , intent(in) :: halo_filled!optional if boundary exchange for fld_fvm has already been called integer :: i, j, ie, k, iwidth real (kind=r8) :: v1,v2 @@ -503,7 +481,6 @@ subroutine dyn2phys_all_vars(nets,nete,elem,fvm,& do k=1,nlev inv_darea_dp_fvm = dyn2fvm(elem(ie)%state%dp3d(:,:,k,tl),elem(ie)%metdet(:,:)) inv_darea_dp_fvm = 1.0_r8/inv_darea_dp_fvm - T_phys(:,k,ie) = RESHAPE(dyn2phys(elem(ie)%state%T(:,:,k,tl),elem(ie)%metdet(:,:),inv_area),SHAPE(T_phys(:,k,ie))) Omega_phys(:,k,ie) = RESHAPE(dyn2phys(elem(ie)%derived%omega(:,:,k),elem(ie)%metdet(:,:),inv_area), & SHAPE(Omega_phys(:,k,ie))) @@ -1317,6 +1294,87 @@ subroutine get_q_overlap_save(ie,k,fvm,q_fvm,num_trac,q_phys) save_q_phys(:,:,k,m_cnst,ie) = q_phys(:,:,m_cnst) end do end subroutine get_q_overlap_save + ! + ! Routine to overwrite thermodynamic active tracers on the GLL grid with CSLAM values + ! by Lagrange interpolation from 3x3 CSLAM grid to GLL grid. + ! + subroutine cslam2gll(elem, fvm, hybrid,nets,nete, tl_f, tl_qdp) + use dimensions_mod, only: nc,nlev,np,nhc + use hybrid_mod, only: hybrid_t + use air_composition, only: thermodynamic_active_species_num, thermodynamic_active_species_idx + use fvm_mod, only: ghostBuf_cslam2gll + use bndry_mod, only: ghost_exchange + use edge_mod, only: ghostpack,ghostunpack + + type (element_t), intent(inout):: elem(:) + type(fvm_struct), intent(inout):: fvm(:) + + type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) + integer, intent(in) :: nets, nete, tl_f, tl_qdp + + integer :: ie,i,j,k,m_cnst,nq,ierr + real (kind=r8), dimension(:,:,:,:,:) , allocatable :: fld_fvm, fld_gll + ! + ! for tensor product Lagrange interpolation + ! + integer :: nflds + logical, allocatable :: llimiter(:) + call t_startf('cslam2gll') + nflds = thermodynamic_active_species_num + + !Allocate variables + !------------------ + allocate(fld_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,nlev,nflds,nets:nete), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'cslam2gll: fld_fvm allocation error = ', ierr + call endrun('cslam2gll: failed to allocate fld_fvm array') + end if + + allocate(fld_gll(np,np,nlev,thermodynamic_active_species_num,nets:nete),stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'cslam2gll: fld_gll allocation error = ', ierr + call endrun('cslam2gll: failed to allocate fld_gll array') + end if + allocate(llimiter(nflds), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'cslam2gll: llimiter allocation error = ', ierr + call endrun('cslam2gll: failed to allocate llimiter array') + end if + !------------------ + llimiter(1:nflds) = .false. + do ie=nets,nete + do m_cnst=1,thermodynamic_active_species_num + do k=1,nlev + fld_fvm(1:nc,1:nc,k,m_cnst,ie) = & + fvm(ie)%c(1:nc,1:nc,k,thermodynamic_active_species_idx(m_cnst)) + end do + end do + end do + call t_startf('fvm:fill_halo_cslam2gll') + do ie=nets,nete + call ghostpack(ghostBuf_cslam2gll, fld_fvm(:,:,:,:,ie),nlev*nflds,0,ie) + end do + + call ghost_exchange(hybrid,ghostBuf_cslam2gll,location='cslam2gll') + + do ie=nets,nete + call ghostunpack(ghostBuf_cslam2gll, fld_fvm(:,:,:,:,ie),nlev*nflds,0,ie) + end do + call t_stopf('fvm:fill_halo_cslam2gll') + ! + ! do mapping + ! + call fvm2dyn(fld_fvm,fld_gll,hybrid,nets,nete,nlev,nflds,fvm,llimiter,halo_filled=.true.) + + do ie=nets,nete + do m_cnst=1,thermodynamic_active_species_num + elem(ie)%state%qdp(:,:,:,m_cnst,tl_qdp) = fld_gll(:,:,:,m_cnst,ie)*& + elem(ie)%state%dp3d(:,:,:,tl_f) + end do + end do + deallocate(fld_fvm, fld_gll, llimiter) + call t_stopf('cslam2gll') + end subroutine cslam2gll end module fvm_mapping diff --git a/src/dynamics/se/dycore/fvm_mod.F90 b/src/dynamics/se/dycore/fvm_mod.F90 index 309a101ba2..e2f311ee81 100644 --- a/src/dynamics/se/dycore/fvm_mod.F90 +++ b/src/dynamics/se/dycore/fvm_mod.F90 @@ -36,6 +36,7 @@ module fvm_mod type (EdgeBuffer_t), public :: ghostBufQnhcJet_h type (EdgeBuffer_t), public :: ghostBufFluxJet_h type (EdgeBuffer_t), public :: ghostBufPG_s + type (EdgeBuffer_t), public :: ghostBuf_cslam2gll interface fill_halo_fvm module procedure fill_halo_fvm_noprealloc @@ -496,13 +497,14 @@ subroutine fvm_init2(elem,fvm,hybrid,nets,nete) call initghostbuffer(hybrid%par,ghostBufQ1_vh,elem,klev*(ntrac+1),1,nc,nthreads=vert_num_threads*horz_num_threads) ! call initghostbuffer(hybrid%par,ghostBufFlux_h,elem,4*nlev,nhe,nc,nthreads=horz_num_threads) call initghostbuffer(hybrid%par,ghostBufFlux_vh,elem,4*nlev,nhe,nc,nthreads=vert_num_threads*horz_num_threads) + call initghostbuffer(hybrid%par,ghostBuf_cslam2gll,elem,nlev*thermodynamic_active_species_num,nhc,nc,nthreads=1) ! ! preallocate buffers for physics-dynamics coupling ! if (fv_nphys.ne.nc) then call initghostbuffer(hybrid%par,ghostBufPG_s,elem,nlev*(4+ntrac),nhc_phys,fv_nphys,nthreads=1) else - call initghostbuffer(hybrid%par,ghostBufPG_s,elem,nlev*(3+thermodynamic_active_species_num),nhc_phys,fv_nphys,nthreads=1) + call initghostbuffer(hybrid%par,ghostBufPG_s,elem,nlev*3,nhc_phys,fv_nphys,nthreads=1) end if if (fvm_supercycling.ne.fvm_supercycling_jet) then diff --git a/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 b/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 index b7310ad477..b4708dfd3b 100644 --- a/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 +++ b/src/dynamics/se/dycore/fvm_reconstruction_mod.F90 @@ -105,7 +105,6 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& if(FVM_TIMERS) call t_startf('FVM:reconstruction:part#1') if (nhe>0) then do itr=1,ntrac_in - ! f=-9e9_r8 call extend_panel_interpolate(nc,nhc,nhr,nht,ns,nh,& fcube(:,:,k_in,itr),cubeboundary,halo_interp_weight,ibase,f(:,:,1),f(:,:,2:3)) call get_gradients(f(:,:,:),jx,jy,irecons,recons(:,:,:,itr),& @@ -113,8 +112,6 @@ subroutine reconstruction(fcube,nlev_in,k_in,recons,irecons,llimiter,ntrac_in,& end do else do itr=1,ntrac_in - ! f=-9e9_r8!to avoid floating point exception for uninitialized variables - ! !in non-existent cells (corners of cube) call extend_panel_interpolate(nc,nhc,nhr,nht,ns,nh,& fcube(:,:,k_in,itr),cubeboundary,halo_interp_weight,ibase,f(:,:,1)) call get_gradients(f(:,:,:),jx,jy,irecons,recons(:,:,:,itr),& diff --git a/src/dynamics/se/dycore/global_norms_mod.F90 b/src/dynamics/se/dycore/global_norms_mod.F90 index 17e773d99c..5290017c8e 100644 --- a/src/dynamics/se/dycore/global_norms_mod.F90 +++ b/src/dynamics/se/dycore/global_norms_mod.F90 @@ -577,7 +577,7 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& deallocate(gp%weights) call automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min_dx,nu_p ,1.0_r8 ,'_p ') - call automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min_dx,nu ,0.5_r8,' ') + call automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min_dx,nu ,1.0_r8,' ') call automatically_set_viscosity_coefficients(hybrid,ne,max_min_dx,min_min_dx,nu_div,2.5_r8 ,'_div') if (nu_q<0) nu_q = nu_p ! necessary for consistency @@ -600,29 +600,34 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& lev_set = sponge_del4_lev < 0 if (ptop>1000.0_r8) then ! - ! low top (~1000 Pa) + ! low top; usually idealized test cases ! top_000_032km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_000_032km" else if (ptop>100.0_r8) then ! - ! CAM6 top (~225 Pa) + ! CAM6 top (~225 Pa) or CAM7 low top ! top_032_042km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_032_042km" else if (ptop>1e-1_r8) then ! ! CAM7 top (~4.35e-1 Pa) ! top_042_090km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_042_090km" else if (ptop>1E-4_r8) then ! ! WACCM top (~4.5e-4 Pa) ! top_090_140km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_090_140km" else ! ! WACCM-x - geospace (~4e-7 Pa) ! top_140_600km = .true. + if (hybrid%masterthread) write(iulog,* )"Model top damping configuration: top_140_600km" end if ! ! Logging text for sponge layer configuration @@ -634,28 +639,24 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& ! ! if user or namelist is not specifying sponge del4 settings here are best guesses (empirically determined) ! - if (top_000_032km) then + if (top_090_140km.or.top_140_600km) then ! defaults for waccm(x) + if (sponge_del4_lev <0) sponge_del4_lev = 20 + if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 5.0_r8 + if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 10.0_r8 + else if (sponge_del4_lev <0) sponge_del4_lev = 1 if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 1.0_r8 if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 1.0_r8 end if - if (top_032_042km) then - if (sponge_del4_lev <0) sponge_del4_lev = 3 - if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 1.0_r8 - if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 4.5_r8 - end if - + ! set max wind speed for diagnostics + umax = 120.0_r8 if (top_042_090km) then - if (sponge_del4_lev <0) sponge_del4_lev = 3 - if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 5.0_r8 - if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 7.5_r8 - end if - - if (top_090_140km.or.top_140_600km) then - if (sponge_del4_lev <0) sponge_del4_lev = 10 - if (sponge_del4_nu_fac <0) sponge_del4_nu_fac = 5.0_r8 - if (sponge_del4_nu_div_fac<0) sponge_del4_nu_div_fac = 7.5_r8 + umax = 240._r8 + else if (top_090_140km) then + umax = 300._r8 + else if (top_140_600km) then + umax = 800._r8 end if ! ! Log sponge layer configuration @@ -672,7 +673,6 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& if (lev_set) then write(iulog, '(a,i0)') ' sponge_del4_lev = ',sponge_del4_lev end if - write(iulog,* )"" end if @@ -689,6 +689,7 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& nu_t_lev(k) = (1.0_r8-scale1)*nu_p +scale1*nu_max end if end do + if (hybrid%masterthread)then write(iulog,*) "z computed from barometric formula (using US std atmosphere)" call std_atm_height(pmid(:),z(:)) @@ -696,8 +697,16 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& do k=1,nlev write(iulog,'(i3,5e11.4)') k,pmid(k),z(k),nu_lev(k),nu_t_lev(k),nu_div_lev(k) end do - end if + if (nu_top>0) then + write(iulog,*) ": ksponge_end = ",ksponge_end + write(iulog,*) ": sponge layer Laplacian damping" + write(iulog,*) "k, p, z, nu_scale_top, nu (actual Laplacian damping coefficient)" + do k=1,ksponge_end + write(iulog,'(i3,4e11.4)') k,pmid(k),z(k),nu_scale_top(k),nu_scale_top(k)*nu_top + end do + end if + end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -732,16 +741,6 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& S_laplacian = 2.0_r8 !using forward Euler for sponge diffusion S_hypervis = 2.0_r8 !using forward Euler for hyperviscosity S_rk_tracer = 2.0_r8 - ! - ! estimate max winds - ! - if (ptop>100.0_r8) then - umax = 120.0_r8 - else if (ptop>10.0_r8) then - umax = 400.0_r8 - else - umax = 800.0_r8 - end if ugw = 342.0_r8 !max gravity wave speed @@ -778,13 +777,14 @@ subroutine print_cfl(elem,hybrid,nets,nete,dtnu,ptop,pmid,& write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_dyn_vis (hyperviscosity) ; u,v,T,dM) < ',dt_max_hypervis,& 's ',dt_dyn_visco_actual,'s' if (dt_dyn_visco_actual>dt_max_hypervis) write(iulog,*) 'WARNING: dt_dyn_vis theoretically unstable' - write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_se (time-stepping tracers ; q ) < ',dt_max_tracer_se,'s ',& + if (.not.use_cslam) then + write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_se (time-stepping tracers ; q ) < ',dt_max_tracer_se,'s ',& dt_tracer_se_actual,'s' - if (dt_tracer_se_actual>dt_max_tracer_se) write(iulog,*) 'WARNING: dt_tracer_se theoretically unstable' - write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_vis (hyperviscosity tracers; q ) < ',dt_max_hypervis_tracer,'s',& - dt_tracer_visco_actual,'s' - if (dt_tracer_visco_actual>dt_max_hypervis_tracer) write(iulog,*) 'WARNING: dt_tracer_hypervis theoretically unstable' - + if (dt_tracer_se_actual>dt_max_tracer_se) write(iulog,*) 'WARNING: dt_tracer_se theoretically unstable' + write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_vis (hyperviscosity tracers; q ) < ',dt_max_hypervis_tracer,'s',& + dt_tracer_visco_actual,'s' + if (dt_tracer_visco_actual>dt_max_hypervis_tracer) write(iulog,*) 'WARNING: dt_tracer_hypervis theoretically unstable' + end if if (use_cslam) then write(iulog,'(a,f10.2,a,f10.2,a)') '* dt_tracer_fvm (time-stepping tracers ; q ) < ',dt_max_tracer_fvm,& 's ',dt_tracer_fvm_actual diff --git a/src/dynamics/se/dycore/prim_advance_mod.F90 b/src/dynamics/se/dycore/prim_advance_mod.F90 index ed7a627ec4..b9b6b746e0 100644 --- a/src/dynamics/se/dycore/prim_advance_mod.F90 +++ b/src/dynamics/se/dycore/prim_advance_mod.F90 @@ -14,7 +14,6 @@ module prim_advance_mod type (EdgeBuffer_t) :: edge3,edgeOmega,edgeSponge real (kind=r8), allocatable :: ur_weights(:) - contains subroutine prim_advance_init(par, elem) @@ -28,7 +27,9 @@ subroutine prim_advance_init(par, elem) integer :: i call initEdgeBuffer(par,edge3 ,elem,4*nlev ,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) - call initEdgeBuffer(par,edgeSponge,elem,4*ksponge_end,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) + if (ksponge_end>0) then + call initEdgeBuffer(par,edgeSponge,elem,4*ksponge_end,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) + end if call initEdgeBuffer(par,edgeOmega ,elem,nlev ,bndry_type=HME_BNDRY_P2P, nthreads=horz_num_threads) if(.not. allocated(ur_weights)) allocate(ur_weights(qsplit)) @@ -112,6 +113,7 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net ! ================================== ! Take timestep ! ================================== + call t_startf('prim_adv_prep') do nq=1,thermodynamic_active_species_num qidx(nq) = nq end do @@ -134,7 +136,7 @@ subroutine prim_advance_exp(elem, fvm, deriv, hvcoord, hybrid,dt, tl, nets, net do ie=nets,nete call get_kappa_dry(qwater(:,:,:,:,ie), qidx, kappa(:,:,:,ie)) end do - + call t_stopf('prim_adv_prep') dt_vis = dt @@ -280,7 +282,7 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu real (kind=r8) :: pdel(np,np,nlev) real (kind=r8), allocatable :: ftmp_fvm(:,:,:,:,:) !diagnostics - + call t_startf('applyCAMforc') if (use_cslam) allocate(ftmp_fvm(nc,nc,nlev,ntrac,nets:nete)) if (ftype==0) then @@ -333,7 +335,7 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu ! ! tracers ! - if (qsize>0.and.dt_local_tracer>0) then + if (.not.use_cslam.and.dt_local_tracer>0) then #if (defined COLUMN_OPENMP) !$omp parallel do num_threads(tracer_num_threads) private(q,k,i,j,v1) #endif @@ -389,7 +391,7 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu if (use_cslam) ftmp_fvm(:,:,:,:,ie) = 0.0_r8 end if - if (ftype_conserve==1) then + if (ftype_conserve==1.and..not.use_cslam) then call get_dp(elem(ie)%state%Qdp(:,:,:,1:qsize,np1_qdp), MASS_MIXING_RATIO, & thermodynamic_active_species_idx_dycore, elem(ie)%state%dp3d(:,:,:,np1), pdel) do k=1,nlev @@ -422,6 +424,7 @@ subroutine applyCAMforcing(elem,fvm,np1,np1_qdp,dt_dribble,dt_phys,nets,nete,nsu end if if (ftype==1.and.nsubstep==1) call tot_energy_dyn(elem,fvm,nets,nete,np1,np1_qdp,'p2d') if (use_cslam) deallocate(ftmp_fvm) + call t_stopf('applyCAMforc') end subroutine applyCAMforcing diff --git a/src/dynamics/se/dycore/prim_advection_mod.F90 b/src/dynamics/se/dycore/prim_advection_mod.F90 index 17ad85ba61..6ee6d2586c 100644 --- a/src/dynamics/se/dycore/prim_advection_mod.F90 +++ b/src/dynamics/se/dycore/prim_advection_mod.F90 @@ -45,7 +45,7 @@ module prim_advection_mod public :: prim_advec_tracers_fvm public :: vertical_remap - type (EdgeBuffer_t) :: edgeAdv, edgeAdvp1, edgeAdvQminmax, edgeAdv1, edgeveloc + type (EdgeBuffer_t) :: edgeAdv, edgeAdvp1, edgeAdvQminmax, edgeveloc integer,parameter :: DSSeta = 1 integer,parameter :: DSSomega = 2 @@ -63,7 +63,7 @@ module prim_advection_mod subroutine Prim_Advec_Init1(par, elem) - use dimensions_mod, only: nlev, qsize, nelemd,ntrac + use dimensions_mod, only: nlev, qsize, nelemd,ntrac,use_cslam use parallel_mod, only: parallel_t, boundaryCommMethod type(parallel_t) :: par type (element_t) :: elem(:) @@ -80,7 +80,7 @@ subroutine Prim_Advec_Init1(par, elem) ! ! Set the number of threads used in the subroutine Prim_Advec_tracers_remap() ! - if (ntrac>0) then + if (use_cslam) then advec_remap_num_threads = 1 else advec_remap_num_threads = tracer_num_threads @@ -89,17 +89,17 @@ subroutine Prim_Advec_Init1(par, elem) ! allocate largest one first ! Currently this is never freed. If it was, only this first one should ! be freed, as only it knows the true size of the buffer. - call initEdgeBuffer(par,edgeAdvp1,elem,qsize*nlev + nlev,bndry_type=boundaryCommMethod,& - nthreads=horz_num_threads*advec_remap_num_threads) - call initEdgeBuffer(par,edgeAdv,elem,qsize*nlev,bndry_type=boundaryCommMethod, & - nthreads=horz_num_threads*advec_remap_num_threads) - ! This is a different type of buffer pointer allocation - ! used for determine the minimum and maximum value from - ! neighboring elements - call initEdgeSBuffer(par,edgeAdvQminmax,elem,qsize*nlev*2,bndry_type=boundaryCommMethod, & - nthreads=horz_num_threads*advec_remap_num_threads) - - call initEdgeBuffer(par,edgeAdv1,elem,nlev,bndry_type=boundaryCommMethod) + if (.not.use_cslam) then + call initEdgeBuffer(par,edgeAdvp1,elem,qsize*nlev + nlev,bndry_type=boundaryCommMethod,& + nthreads=horz_num_threads*advec_remap_num_threads) + call initEdgeBuffer(par,edgeAdv,elem,qsize*nlev,bndry_type=boundaryCommMethod, & + nthreads=horz_num_threads*advec_remap_num_threads) + ! This is a different type of buffer pointer allocation + ! used for determine the minimum and maximum value from + ! neighboring elements + call initEdgeSBuffer(par,edgeAdvQminmax,elem,qsize*nlev*2,bndry_type=boundaryCommMethod, & + nthreads=horz_num_threads*advec_remap_num_threads) + end if call initEdgeBuffer(par,edgeveloc,elem,2*nlev,bndry_type=boundaryCommMethod) diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index 6cfb52e356..dc012e2d12 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -19,7 +19,6 @@ module prim_driver_mod private public :: prim_init2, prim_run_subcycle, prim_finalize public :: prim_set_dry_mass - contains !=============================================================================! @@ -61,9 +60,10 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) ! variables used to calculate CFL real (kind=r8) :: dtnu ! timestep*viscosity parameter - real (kind=r8) :: dt_dyn_vis ! viscosity timestep used in dynamics - real (kind=r8) :: dt_dyn_del2_sponge, dt_remap + real (kind=r8) :: dt_dyn_del2_sponge real (kind=r8) :: dt_tracer_vis ! viscosity timestep used in tracers + real (kind=r8) :: dt_dyn_vis ! viscosity timestep + real (kind=r8) :: dt_remap ! remapping timestep real (kind=r8) :: dp,dp0,T1,T0,pmid_ref(np,np) real (kind=r8) :: ps_ref(np,np,nets:nete) @@ -219,7 +219,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst ! use hybvcoord_mod, only : hvcoord_t use se_dyn_time_mod, only: TimeLevel_t, timelevel_update, timelevel_qdp, nsplit - use control_mod, only: statefreq,qsplit, rsplit, variable_nsplit + use control_mod, only: statefreq,qsplit, rsplit, variable_nsplit, dribble_in_rsplit_loop use prim_advance_mod, only: applycamforcing use prim_advance_mod, only: tot_energy_dyn,compute_omega use prim_state_mod, only: prim_printstate, adjust_nsplit @@ -227,8 +227,8 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst use thread_mod, only: omp_get_thread_num use perf_mod , only: t_startf, t_stopf use fvm_mod , only: fill_halo_fvm, ghostBufQnhc_h - use dimensions_mod, only: use_cslam,fv_nphys, ksponge_end - + use dimensions_mod, only: use_cslam,fv_nphys + use fvm_mapping, only: cslam2gll type (element_t) , intent(inout) :: elem(:) type(fvm_struct), intent(inout) :: fvm(:) type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) @@ -245,7 +245,6 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst real (kind=r8) :: dp_np1(np,np) real (kind=r8) :: dp_start(np,np,nlev+1,nets:nete),dp_end(np,np,nlev,nets:nete) logical :: compute_diagnostics - ! =================================== ! Main timestepping loop ! =================================== @@ -282,12 +281,33 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst call TimeLevel_Qdp( tl, qsplit, n0_qdp) - call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') - call ApplyCAMForcing(elem,fvm,tl%n0,n0_qdp,dt_remap,dt_phys,nets,nete,nsubstep) - call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + if (dribble_in_rsplit_loop==0) then + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') + call ApplyCAMForcing(elem,fvm,tl%n0,n0_qdp,dt_remap,dt_phys,nets,nete,nsubstep) + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + end if do r=1,rsplit if (r.ne.1) call TimeLevel_update(tl,"leapfrog") - call prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) + ! + ! if nsplit==1 and physics time-step is long then there will be noise in the + ! pressure field; hence "dripple" in tendencies + ! + if (dribble_in_rsplit_loop==1) then + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') + call ApplyCAMForcing(elem,fvm,tl%n0,n0_qdp,dt,dt_phys,nets,nete,MAX(nsubstep,r)) + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + end if + ! + ! right after physics overwrite Qdp with CSLAM values + ! + if (use_cslam.and.nsubstep==1.and.r==1) then + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') + call cslam2gll(elem, fvm, hybrid,nets,nete, tl%n0, n0_qdp) + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + end if + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBL') + call prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r,nsubstep==nsplit,dt_remap) + call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,n0_qdp,'dAL') enddo @@ -363,7 +383,6 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst end do end do end do - if (nsubstep==nsplit.and.variable_nsplit) then call t_startf('adjust_nsplit') call adjust_nsplit(elem, tl, hybrid,nets,nete, fvm, omega_cn) @@ -389,7 +408,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst end subroutine prim_run_subcycle - subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) + subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep, last_step,dt_remap) ! ! Take qsplit dynamics steps and one tracer step ! for vertically lagrangian option, this subroutine does only the horizontal step @@ -418,7 +437,8 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) use dimensions_mod, only: kmin_jet, kmax_jet use fvm_mod, only: ghostBufQnhc_vh,ghostBufQ1_vh, ghostBufFlux_vh use fvm_mod, only: ghostBufQ1_h,ghostBufQnhcJet_h, ghostBufFluxJet_h - + use se_dyn_time_mod, only: timelevel_qdp + use fvm_mapping, only: cslam2gll #ifdef waccm_debug use cam_history, only: outfld #endif @@ -433,6 +453,8 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) real(kind=r8), intent(in) :: dt ! "timestep dependent" timestep type (TimeLevel_t), intent(inout) :: tl integer, intent(in) :: rstep ! vertical remap subcycling step + logical, intent(in) :: last_step! last step before d_p_coupling + real(kind=r8), intent(in) :: dt_remap type (hybrid_t):: hybridnew,hybridnew2 real(kind=r8) :: st, st1, dp, dt_q @@ -440,6 +462,7 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) integer :: ithr integer :: region_num_threads integer :: kbeg,kend + integer :: n0_qdp, np1_qdp real (kind=r8) :: tempdp3d(np,np), x real (kind=r8) :: tempmass(nc,nc) @@ -517,7 +540,6 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) end do end if #endif - ! current dynamics state variables: ! derived%dp = dp at start of timestep ! derived%vn0 = mean horiz. flux: U*dp @@ -537,32 +559,19 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! special case in CAM: if CSLAM tracers are turned on , qsize=1 but this tracer should ! not be advected. This will be cleaned up when the physgrid is merged into CAM trunk ! Currently advecting all species - if (qsize > 0) then - + if (.not.use_cslam) then call t_startf('prim_advec_tracers_remap') - if(use_cslam) then - ! Deactivate threading in the tracer dimension if this is a CSLAM run - region_num_threads = 1 - else - region_num_threads=tracer_num_threads - endif + region_num_threads=tracer_num_threads call omp_set_nested(.true.) !$OMP PARALLEL NUM_THREADS(region_num_threads), DEFAULT(SHARED), PRIVATE(hybridnew) - if(use_cslam) then - ! Deactivate threading in the tracer dimension if this is a CSLAM run - hybridnew = config_thread_region(hybrid,'serial') - else - hybridnew = config_thread_region(hybrid,'tracer') - endif + hybridnew = config_thread_region(hybrid,'tracer') call Prim_Advec_Tracers_remap(elem, deriv,hvcoord,hybridnew,dt_q,tl,nets,nete) !$OMP END PARALLEL call omp_set_nested(.false.) call t_stopf('prim_advec_tracers_remap') - end if - ! - ! only run fvm transport every fvm_supercycling rstep - ! - if (use_cslam) then + else + ! + ! only run fvm transport every fvm_supercycling rstep ! ! FVM transport ! @@ -594,7 +603,9 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) fvm(ie)%psc(i,j) = sum(fvm(ie)%dp_fvm(i,j,:)) + hvcoord%hyai(1)*hvcoord%ps0 end do end do - end do + end do + call TimeLevel_Qdp( tl, qsplit, n0_qdp, np1_qdp) + if (.not.last_step) call cslam2gll(elem, fvm, hybrid,nets,nete, tl%np1, np1_qdp) else if ((mod(rstep,fvm_supercycling_jet) == 0)) then ! ! shorter fvm time-step in jet region @@ -609,7 +620,7 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) (/nc*nc,nlev/)), nc*nc, ie) end do #endif - endif + endif end subroutine prim_step diff --git a/src/dynamics/se/dycore/prim_init.F90 b/src/dynamics/se/dycore/prim_init.F90 index 42a336f65c..930b887107 100644 --- a/src/dynamics/se/dycore/prim_init.F90 +++ b/src/dynamics/se/dycore/prim_init.F90 @@ -1,7 +1,7 @@ module prim_init use shr_kind_mod, only: r8=>shr_kind_r8 - use dimensions_mod, only: nc + use dimensions_mod, only: nc, use_cslam use reduction_mod, only: reductionbuffer_ordered_1d_t use quadrature_mod, only: quadrature_t, gausslobatto @@ -22,7 +22,7 @@ subroutine prim_init1(elem, fvm, par, Tl) use cam_logfile, only: iulog use shr_sys_mod, only: shr_sys_flush use thread_mod, only: max_num_threads - use dimensions_mod, only: np, nlev, nelem, nelemd, nelemdmax + use dimensions_mod, only: np, nlev, nelem, nelemd, nelemdmax, qsize_d use dimensions_mod, only: GlobalUniqueCols, fv_nphys,irecons_tracer use control_mod, only: topology, partmethod use element_mod, only: element_t, allocate_element_desc @@ -56,6 +56,7 @@ subroutine prim_init1(elem, fvm, par, Tl) use shr_reprosum_mod, only: repro_sum => shr_reprosum_calc use fvm_analytic_mod, only: compute_basic_coordinate_vars use fvm_control_volume_mod, only: fvm_struct, allocate_physgrid_vars + use air_composition, only: thermodynamic_active_species_num type(element_t), pointer :: elem(:) type(fvm_struct), pointer :: fvm(:) @@ -70,7 +71,7 @@ subroutine prim_init1(elem, fvm, par, Tl) integer :: ie integer :: nets, nete integer :: nelem_edge - integer :: ierr, j + integer :: ierr=0, j logical, parameter :: Debug = .FALSE. real(r8), allocatable :: aratio(:,:) @@ -165,9 +166,49 @@ subroutine prim_init1(elem, fvm, par, Tl) end if call mpi_allreduce(nelemd, nelemdmax, 1, MPI_INTEGER, MPI_MAX, par%comm, ierr) + !Allocate elements: if (nelemd > 0) then - allocate(elem(nelemd)) - call allocate_element_desc(elem) + allocate(elem(nelemd)) + call allocate_element_desc(elem) + !Allocate Qdp and derived FQ arrays: + if(fv_nphys > 0) then !SE-CSLAM + do ie=1,nelemd + allocate(elem(ie)%state%Qdp(np,np,nlev,thermodynamic_active_species_num,1), stat=ierr) + if( ierr /= 0 ) then + call endrun('prim_init1: failed to allocate Qdp array') + end if + allocate(elem(ie)%derived%FQ(np,np,nlev,thermodynamic_active_species_num), stat=ierr) + if( ierr /= 0 ) then + call endrun('prim_init1: failed to allocate fq array') + end if + end do + else !Regular SE + do ie=1,nelemd + allocate(elem(ie)%state%Qdp(np,np,nlev,qsize_d,2), stat=ierr) + if( ierr /= 0 ) then + call endrun('prim_init1: failed to allocate Qdp array') + end if + allocate(elem(ie)%derived%FQ(np,np,nlev,qsize_d), stat=ierr) + if( ierr /= 0 ) then + call endrun('prim_init1: failed to allocate fq array') + end if + end do + end if + !Allocate remaining derived quantity arrays: + do ie=1,nelemd + allocate(elem(ie)%derived%FDP(np,np,nlev), stat=ierr) + if( ierr /= 0 ) then + call endrun('prim_init1: failed to allocate fdp array') + end if + allocate(elem(ie)%derived%divdp(np,np,nlev), stat=ierr) + if( ierr /= 0 ) then + call endrun('prim_init1: failed to allocate divdp array') + end if + allocate(elem(ie)%derived%divdp_proj(np,np,nlev), stat=ierr) + if( ierr /= 0 ) then + call endrun('prim_init1: failed to allocate divdp_proj array') + end if + end do end if if (fv_nphys > 0) then @@ -306,7 +347,7 @@ subroutine prim_init1(elem, fvm, par, Tl) elem(ie)%derived%FM=0.0_r8 elem(ie)%derived%FQ=0.0_r8 elem(ie)%derived%FT=0.0_r8 - elem(ie)%derived%FDP=0.0_r8 + elem(ie)%derived%FDP=0.0_r8 elem(ie)%derived%pecnd=0.0_r8 elem(ie)%derived%Omega=0 diff --git a/src/dynamics/se/dycore/se_dyn_time_mod.F90 b/src/dynamics/se/dycore/se_dyn_time_mod.F90 index 4dfd981661..cfe7ad2323 100644 --- a/src/dynamics/se/dycore/se_dyn_time_mod.F90 +++ b/src/dynamics/se/dycore/se_dyn_time_mod.F90 @@ -80,6 +80,7 @@ end subroutine TimeLevel_init_specific !locations for nm1 and n0 for Qdp - because !it only has 2 levels for storage subroutine TimeLevel_Qdp(tl, qsplit, n0, np1) + use dimensions_mod, only: use_cslam type (TimeLevel_t) :: tl integer, intent(in) :: qsplit integer, intent(inout) :: n0 @@ -87,22 +88,26 @@ subroutine TimeLevel_Qdp(tl, qsplit, n0, np1) integer :: i_temp - i_temp = tl%nstep/qsplit - - if (mod(i_temp,2) ==0) then + if (use_cslam) then n0 = 1 - if (present(np1)) then - np1 = 2 - endif + if (present(np1)) np1 = 1 else - n0 = 2 - if (present(np1)) then - np1 = 1 - end if - endif + i_temp = tl%nstep/qsplit + + if (mod(i_temp,2) ==0) then + n0 = 1 + if (present(np1)) then + np1 = 2 + endif + else + n0 = 2 + if (present(np1)) then + np1 = 1 + end if + endif !print * ,'nstep = ', tl%nstep, 'qsplit= ', qsplit, 'i_temp = ', i_temp, 'n0 = ', n0 - + endif end subroutine TimeLevel_Qdp subroutine TimeLevel_update(tl,uptype) diff --git a/src/dynamics/se/dycore_budget.F90 b/src/dynamics/se/dycore_budget.F90 index d2bfe0fceb..14f1d65167 100644 --- a/src/dynamics/se/dycore_budget.F90 +++ b/src/dynamics/se/dycore_budget.F90 @@ -63,7 +63,7 @@ subroutine print_budget(hstwr) ! ! mass budgets dynamics ! - real(r8) :: dMdt_floating_dyn ! mass tendency floating dynamics (dAD-dBD) + real(r8) :: dMdt_floating_dyn ! mass tendency floating dynamics (dAL-dBL) real(r8) :: dMdt_vert_remap ! mass tendency vertical remapping (dAR-dAD) real(r8) :: dMdt_del4_fric_heat ! mass tendency del4 frictional heating (dAH-dCH) real(r8) :: dMdt_del4_tot ! mass tendency del4 + del4 frictional heating (dAH-dBH) @@ -73,7 +73,7 @@ subroutine print_budget(hstwr) ! ! energy budgets dynamics ! - real(r8) :: dEdt_floating_dyn ! dE/dt floating dynamics (dAD-dBD) + real(r8) :: dEdt_floating_dyn ! dE/dt floating dynamics (dAL-dBL) real(r8) :: dEdt_vert_remap ! dE/dt vertical remapping (dAR-dAD) real(r8) :: dEdt_del4 ! dE/dt del4 (dCH-dBH) real(r8) :: dEdt_del4_fric_heat ! dE/dt del4 frictional heating (dAH-dCH) @@ -132,7 +132,7 @@ subroutine print_budget(hstwr) call cam_budget_get_global('dBF' ,idx(i),E_dBF(i)) !state passed to physics end do - call cam_budget_get_global('dAD-dBD',teidx,dEdt_floating_dyn) + call cam_budget_get_global('dAL-dBL',teidx,dEdt_floating_dyn) call cam_budget_get_global('dAR-dAD',teidx,dEdt_vert_remap) dEdt_dycore_dyn = dEdt_floating_dyn+dEdt_vert_remap @@ -459,7 +459,7 @@ subroutine print_budget(hstwr) ! detailed mass budget in dynamical core ! if (is_cam_budget('dAD').and.is_cam_budget('dBD').and.is_cam_budget('dAR').and.is_cam_budget('dCH')) then - call cam_budget_get_global('dAD-dBD',m_cnst,dMdt_floating_dyn) + call cam_budget_get_global('dAL-dBL',m_cnst,dMdt_floating_dyn) call cam_budget_get_global('dAR-dAD',m_cnst,dMdt_vert_remap) tmp = dMdt_floating_dyn+dMdt_vert_remap diff = abs_diff(tmp,0.0_r8,pf=pf) @@ -472,7 +472,7 @@ subroutine print_budget(hstwr) write(iulog,*) "Error: mass non-conservation in dynamical core" write(iulog,*) "(detailed budget below)" write(iulog,*) " " - write(iulog,*)"dMASS/dt 2D dynamics (dAD-dBD) ",dMdt_floating_dyn," Pa/m^2/s" + write(iulog,*)"dMASS/dt 2D dynamics (dAL-dBL) ",dMdt_floating_dyn," Pa/m^2/s" write(iulog,*)"dE/dt vertical remapping (dAR-dAD) ",dMdt_vert_remap write(iulog,*)" " write(iulog,*)"Breakdown of 2D dynamics:" diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 312349eb44..5dcffe7347 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -110,7 +110,7 @@ subroutine dyn_readnl(NLFileName) use control_mod, only: topology, variable_nsplit use control_mod, only: fine_ne, hypervis_power, hypervis_scaling use control_mod, only: max_hypervis_courant, statediag_numtrac,refined_mesh - use control_mod, only: molecular_diff, pgf_formulation + use control_mod, only: molecular_diff, pgf_formulation, dribble_in_rsplit_loop use control_mod, only: sponge_del4_nu_div_fac, sponge_del4_nu_fac, sponge_del4_lev use dimensions_mod, only: ne, npart use dimensions_mod, only: large_Courant_incr @@ -168,7 +168,7 @@ subroutine dyn_readnl(NLFileName) integer :: se_kmax_jet real(r8) :: se_molecular_diff integer :: se_pgf_formulation - + integer :: se_dribble_in_rsplit_loop namelist /dyn_se_inparm/ & se_fine_ne, & ! For refined meshes se_ftype, & ! forcing type @@ -213,8 +213,8 @@ subroutine dyn_readnl(NLFileName) se_kmin_jet, & se_kmax_jet, & se_molecular_diff, & - se_pgf_formulation - + se_pgf_formulation, & + se_dribble_in_rsplit_loop !-------------------------------------------------------------------------- ! defaults for variables not set by build-namelist @@ -288,7 +288,7 @@ subroutine dyn_readnl(NLFileName) call MPI_bcast(se_kmax_jet, 1, mpi_integer, masterprocid, mpicom, ierr) call MPI_bcast(se_molecular_diff, 1, mpi_real8, masterprocid, mpicom, ierr) call MPI_bcast(se_pgf_formulation, 1, mpi_integer, masterprocid, mpicom, ierr) - + call MPI_bcast(se_dribble_in_rsplit_loop, 1, mpi_integer, masterprocid, mpicom, ierr) if (se_npes <= 0) then call endrun('dyn_readnl: ERROR: se_npes must be > 0') end if @@ -356,7 +356,7 @@ subroutine dyn_readnl(NLFileName) variable_nsplit = .false. molecular_diff = se_molecular_diff pgf_formulation = se_pgf_formulation - + dribble_in_rsplit_loop = se_dribble_in_rsplit_loop if (fv_nphys > 0) then ! Use finite volume physics grid and CSLAM for tracer advection nphys_pts = fv_nphys*fv_nphys @@ -472,7 +472,7 @@ subroutine dyn_readnl(NLFileName) end if end if - if (fv_nphys > 0) then + if (use_cslam) then write(iulog, '(a)') 'dyn_readnl: physics will run on FVM points; advection by CSLAM' write(iulog,'(a,i0)') 'dyn_readnl: se_fv_nphys = ', fv_nphys else @@ -618,12 +618,14 @@ subroutine dyn_init(dyn_in, dyn_out) integer :: m_cnst, m ! variables for initializing energy and axial angular momentum diagnostics - integer, parameter :: num_stages = 12 - character (len = 4), dimension(num_stages) :: stage = (/"dED","dAF","dBD","dAD","dAR","dBF","dBH","dCH","dAH","dBS","dAS","p2d"/) + integer, parameter :: num_stages = 14 + character (len = 4), dimension(num_stages) :: stage = (/"dED","dAF","dBD","dBL","dAL","dAD","dAR","dBF","dBH","dCH","dAH","dBS","dAS","p2d"/) character (len = 70),dimension(num_stages) :: stage_txt = (/& " end of previous dynamics ",& !dED " from previous remapping or state passed to dynamics",& !dAF - state in beginning of nsplit loop " state after applying CAM forcing ",& !dBD - state after applyCAMforcing + " before floating dynamics ",& !dBL + " after floating dynamics ",& !dAL " before vertical remapping ",& !dAD - state before vertical remapping " after vertical remapping ",& !dAR - state at end of nsplit loop " state passed to parameterizations ",& !dBF @@ -799,28 +801,49 @@ subroutine dyn_init(dyn_in, dyn_out) ! nu_scale_top(:) = 0.0_r8 if (nu_top>0) then - ptop = hvcoord%hyai(1)*hvcoord%ps0 - if (ptop>300.0_r8) then - ! - ! for low tops the tanh formulae below makes the sponge excessively deep - ! - nu_scale_top(1) = 4.0_r8 - nu_scale_top(2) = 2.0_r8 - nu_scale_top(3) = 1.0_r8 - ksponge_end = 3 - else - do k=1,nlev - press = hvcoord%hyam(k)*hvcoord%ps0+hvcoord%hybm(k)*pstd - nu_scale_top(k) = 8.0_r8*(1.0_r8+tanh(1.0_r8*log(ptop/press(1)))) ! tau will be maximum 8 at model top - if (nu_scale_top(k).ge.0.15_r8) then - ksponge_end = k - else - nu_scale_top(k) = 0.0_r8 - end if - end do - end if + ptop = hvcoord%hyai(1)*hvcoord%ps0 + if (ptop>300.0_r8) then + ! + ! for low tops the tanh formulae below makes the sponge excessively deep + ! + nu_scale_top(1) = 4.0_r8 + nu_scale_top(2) = 2.0_r8 + nu_scale_top(3) = 1.0_r8 + ksponge_end = 3 + else if (ptop>100.0_r8) then + ! + ! CAM6 top (~225 Pa) or CAM7 low top + ! + ! For backwards compatibility numbers below match tanh profile + ! used in FV + ! + nu_scale_top(1) = 4.4_r8 + nu_scale_top(2) = 1.3_r8 + nu_scale_top(3) = 3.9_r8 + ksponge_end = 3 + else if (ptop>1e-1_r8) then + ! + ! CAM7 FMT + ! + nu_scale_top(1) = 3.0_r8 + nu_scale_top(2) = 1.0_r8 + nu_scale_top(3) = 0.1_r8 + nu_scale_top(4) = 0.05_r8 + ksponge_end = 4 + else if (ptop>1e-4_r8) then + ! + ! WACCM and WACCM-x + ! + nu_scale_top(1) = 5.0_r8 + nu_scale_top(2) = 5.0_r8 + nu_scale_top(3) = 5.0_r8 + nu_scale_top(4) = 2.0_r8 + nu_scale_top(5) = 1.0_r8 + nu_scale_top(6) = 0.1_r8 + ksponge_end = 6 + end if else - ksponge_end = 0 + ksponge_end = 0 end if ksponge_end = MAX(MAX(ksponge_end,1),kmol_end) if (masterproc) then @@ -906,8 +929,8 @@ subroutine dyn_init(dyn_in, dyn_out) ! ! Register tendency (difference) budgets ! - call cam_budget_em_register('dEdt_floating_dyn' ,'dAD','dBD','dyn','dif', & - longname="dE/dt floating dynamics (dAD-dBD)" ) + call cam_budget_em_register('dEdt_floating_dyn' ,'dAL','dBL','dyn','dif', & + longname="dE/dt floating dynamics (dAL-dBL)" ) call cam_budget_em_register('dEdt_vert_remap' ,'dAR','dAD','dyn','dif', & longname="dE/dt vertical remapping (dAR-dAD)" ) call cam_budget_em_register('dEdt_phys_tot_in_dyn','dBD','dAF','dyn','dif', & @@ -963,11 +986,10 @@ subroutine dyn_run(dyn_state) use air_composition, only: thermodynamic_active_species_idx_dycore use prim_driver_mod, only: prim_run_subcycle use dimensions_mod, only: cnst_name_gll - use se_dyn_time_mod, only: tstep, nsplit, timelevel_qdp + use se_dyn_time_mod, only: tstep, nsplit, timelevel_qdp, tevolve use hybrid_mod, only: config_thread_region, get_loop_ranges use control_mod, only: qsplit, rsplit, ftype_conserve use thread_mod, only: horz_num_threads - use se_dyn_time_mod, only: tevolve type(dyn_export_t), intent(inout) :: dyn_state @@ -1042,24 +1064,23 @@ subroutine dyn_run(dyn_state) end if end do - - ! convert elem(ie)%derived%fq to mass tendency - do ie = nets, nete - do m = 1, qsize + if (.not.use_cslam) then + do ie = nets, nete + do m = 1, qsize do k = 1, nlev - do j = 1, np - do i = 1, np - dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & - rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) - end do - end do + do j = 1, np + do i = 1, np + dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & + rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) + end do + end do end do - end do - end do - + end do + end do + end if - if (ftype_conserve>0) then + if (ftype_conserve>0.and..not.use_cslam) then do ie = nets, nete do k=1,nlev do j=1,np @@ -1076,7 +1097,6 @@ subroutine dyn_run(dyn_state) end do end if - if (use_cslam) then do ie = nets, nete do m = 1, ntrac @@ -1795,6 +1815,7 @@ subroutine set_phis(dyn_in) integer :: ierr, pio_errtype character(len=max_fieldname_len) :: fieldname + character(len=max_fieldname_len) :: fieldname_gll character(len=max_hcoordname_len):: grid_name integer :: dims(2) integer :: dyn_cols @@ -1828,7 +1849,7 @@ subroutine set_phis(dyn_in) allocate(phis_tmp(npsq,nelemd)) phis_tmp = 0.0_r8 - if (fv_nphys > 0) then + if (use_cslam) then allocate(phis_phys_tmp(fv_nphys**2,nelemd)) phis_phys_tmp = 0.0_r8 do ie=1,nelemd @@ -1853,7 +1874,7 @@ subroutine set_phis(dyn_in) ! Set name of grid object which will be used to read data from file ! into internal data structure via PIO. - if (fv_nphys == 0) then + if (.not.use_cslam) then grid_name = 'GLL' else grid_name = 'physgrid_d' @@ -1878,13 +1899,38 @@ subroutine set_phis(dyn_in) end if fieldname = 'PHIS' - if (dyn_field_exists(fh_topo, trim(fieldname))) then - if (fv_nphys == 0) then - call read_dyn_var(fieldname, fh_topo, 'ncol', phis_tmp) + fieldname_gll = 'PHIS_gll' + if (use_cslam.and.dyn_field_exists(fh_topo, trim(fieldname_gll),required=.false.)) then + ! + ! If physgrid it is recommended to read in PHIS on the GLL grid and then + ! map to the physgrid in d_p_coupling + ! + ! This requires a topo file with PHIS_gll on it ... + ! + if (masterproc) then + write(iulog, *) "Reading in PHIS on GLL grid (mapped to physgrid in d_p_coupling)" + end if + call read_dyn_var(fieldname_gll, fh_topo, 'ncol_gll', phis_tmp) + else if (dyn_field_exists(fh_topo, trim(fieldname))) then + if (.not.use_cslam) then + if (masterproc) then + write(iulog, *) "Reading in PHIS" + end if + call read_dyn_var(fieldname, fh_topo, 'ncol', phis_tmp) else - call read_phys_field_2d(fieldname, fh_topo, 'ncol', phis_phys_tmp) - call map_phis_from_physgrid_to_gll(dyn_in%fvm, elem, phis_phys_tmp, & - phis_tmp, pmask) + ! + ! For backwards compatibility we allow reading in PHIS on the physgrid + ! which is then mapped to the GLL grid and back to the physgrid in d_p_coupling + ! (the latter is to avoid noise in derived quantities such as PSL) + ! + if (masterproc) then + write(iulog, *) "Reading in PHIS on physgrid" + write(iulog, *) "Recommended to read in PHIS on GLL grid" + end if + call read_phys_field_2d(fieldname, fh_topo, 'ncol', phis_phys_tmp) + call map_phis_from_physgrid_to_gll(dyn_in%fvm, elem, phis_phys_tmp, & + phis_tmp, pmask) + deallocate(phis_phys_tmp) end if else call endrun(sub//': Could not find PHIS field on input datafile') @@ -1916,44 +1962,6 @@ subroutine set_phis(dyn_in) PHIS_OUT=phis_tmp, mask=pmask(:)) deallocate(glob_ind) - if (fv_nphys > 0) then - - ! initialize PHIS on physgrid - allocate(latvals_phys(fv_nphys*fv_nphys*nelemd)) - allocate(lonvals_phys(fv_nphys*fv_nphys*nelemd)) - indx = 1 - do ie = 1, nelemd - do j = 1, fv_nphys - do i = 1, fv_nphys - latvals_phys(indx) = dyn_in%fvm(ie)%center_cart_physgrid(i,j)%lat - lonvals_phys(indx) = dyn_in%fvm(ie)%center_cart_physgrid(i,j)%lon - indx = indx + 1 - end do - end do - end do - - allocate(pmask_phys(fv_nphys*fv_nphys*nelemd)) - pmask_phys(:) = .true. - allocate(glob_ind(fv_nphys*fv_nphys*nelemd)) - - j = 1 - do ie = 1, nelemd - do i = 1, fv_nphys*fv_nphys - ! Create a global(ish) column index - glob_ind(j) = elem(ie)%GlobalId - j = j + 1 - end do - end do - - call analytic_ic_set_ic(vcoord, latvals_phys, lonvals_phys, glob_ind, & - PHIS_OUT=phis_phys_tmp, mask=pmask_phys) - - deallocate(latvals_phys) - deallocate(lonvals_phys) - deallocate(pmask_phys) - deallocate(glob_ind) - end if - end if deallocate(pmask) @@ -1969,16 +1977,7 @@ subroutine set_phis(dyn_in) end do end do end do - if (fv_nphys > 0) then - do ie = 1, nelemd - dyn_in%fvm(ie)%phis_physgrid = RESHAPE(phis_phys_tmp(:,ie),(/fv_nphys,fv_nphys/)) - end do - end if - deallocate(phis_tmp) - if (fv_nphys > 0) then - deallocate(phis_phys_tmp) - end if ! boundary exchange to update the redundent columns in the element objects do ie = 1, nelemd diff --git a/src/dynamics/se/dyn_grid.F90 b/src/dynamics/se/dyn_grid.F90 index 293f7402dd..aa3ec8027a 100644 --- a/src/dynamics/se/dyn_grid.F90 +++ b/src/dynamics/se/dyn_grid.F90 @@ -177,12 +177,12 @@ subroutine dyn_grid_init() if (iam < par%nprocs) then call prim_init1(elem, fvm, par, TimeLevel) - if (fv_nphys > 0) then + if (use_cslam) then call dp_init(elem, fvm) end if if (fv_nphys > 0) then - qsize_local = thermodynamic_active_species_num + 3 + qsize_local = 3 else qsize_local = pcnst + 3 end if diff --git a/src/dynamics/se/gravity_waves_sources.F90 b/src/dynamics/se/gravity_waves_sources.F90 index 9adffc001b..a19733b465 100644 --- a/src/dynamics/se/gravity_waves_sources.F90 +++ b/src/dynamics/se/gravity_waves_sources.F90 @@ -141,7 +141,7 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, do ie=nets,nete ! pressure at model top - pint(:,:) = hvcoord%hyai(1) + pint(:,:) = hvcoord%hyai(1)*hvcoord%ps0 do k=1,nlev ! moist pressure at mid points sum_water(:,:) = 1.0_r8 diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 392c7a285c..9c16325357 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -501,6 +501,8 @@ subroutine diag_init_moist(pbuf2d) call addfld ('TREFHTMX', horiz_only, 'X','K','Maximum reference height temperature over output period') call addfld ('QREFHT', horiz_only, 'A', 'kg/kg','Reference height humidity') call addfld ('U10', horiz_only, 'A', 'm/s','10m wind speed') + call addfld ('UGUST', horiz_only, 'A', 'm/s','Gustiness term added to U10') + call addfld ('U10WITHGUSTS',horiz_only, 'A', 'm/s','10m wind speed with gustiness added') call addfld ('RHREFHT', horiz_only, 'A', 'fraction','Reference height relative humidity') call addfld ('LANDFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by land') @@ -1785,6 +1787,9 @@ subroutine diag_surf (cam_in, cam_out, state, pbuf) call outfld('TREFHTMN', cam_in%tref, pcols, lchnk) call outfld('QREFHT', cam_in%qref, pcols, lchnk) call outfld('U10', cam_in%u10, pcols, lchnk) + call outfld('UGUST', cam_in%ugustOut, pcols, lchnk) + call outfld('U10WITHGUSTS',cam_in%u10withGusts, pcols, lchnk) + ! ! Calculate and output reference height RH (RHREFHT) call qsat(cam_in%tref(1:ncol), state%ps(1:ncol), tem2(1:ncol), ftem(1:ncol), ncol) diff --git a/src/physics/cam/cam_snapshot.F90 b/src/physics/cam/cam_snapshot.F90 index 92f25d775c..7e7d83e9ef 100644 --- a/src/physics/cam/cam_snapshot.F90 +++ b/src/physics/cam/cam_snapshot.F90 @@ -58,7 +58,7 @@ subroutine cam_snapshot_init(cam_in_arr, cam_out_arr, pbuf, index) call phys_getopts(cam_snapshot_before_num_out = cam_snapshot_before_num, & cam_snapshot_after_num_out = cam_snapshot_after_num) - + ! Return if not turned on if (cam_snapshot_before_num <= 0 .and. cam_snapshot_after_num <= 0) return ! No snapshot files are being requested @@ -76,7 +76,7 @@ subroutine cam_snapshot_init(cam_in_arr, cam_out_arr, pbuf, index) end subroutine cam_snapshot_init subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_out, pbuf, flx_heat, cmfmc, cmfcme, & - pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) use time_manager, only: is_first_step, is_first_restart_step @@ -95,7 +95,6 @@ subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_ou real(r8), intent(in) :: flx_heat(:) ! Heat flux for check_energy_chng. real(r8), intent(in) :: cmfmc(:,:) ! convective mass flux real(r8), intent(in) :: cmfcme(:,:) ! cmf condensation - evaporation - real(r8), intent(in) :: pflx(:,:) ! convective rain flux throughout bottom of level real(r8), intent(in) :: zdu(:,:) ! detraining mass flux from deep convection real(r8), intent(in) :: rliq(:) ! vertical integral of liquid not yet in q(ixcldliq) real(r8), intent(in) :: rice(:) ! vertical integral of ice not yet in q(ixcldice) @@ -111,7 +110,7 @@ subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_ou ! Return if the first timestep as not all fields may be filled in and this will cause a core dump if (is_first_step().or. is_first_restart_step()) return - ! Return if not turned on + ! Return if not turned on if (cam_snapshot_before_num <= 0 .and. cam_snapshot_after_num <= 0) return ! No snapshot files are being requested lchnk = state%lchnk @@ -119,7 +118,6 @@ subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_ou call outfld('tphysbc_flx_heat', flx_heat, pcols, lchnk) call outfld('tphysbc_cmfmc', cmfmc, pcols, lchnk) call outfld('tphysbc_cmfcme', cmfcme, pcols, lchnk) - call outfld('tphysbc_pflx', pflx, pcols, lchnk) call outfld('tphysbc_zdu', zdu, pcols, lchnk) call outfld('tphysbc_rliq', rliq, pcols, lchnk) call outfld('tphysbc_rice', rice, pcols, lchnk) @@ -160,7 +158,7 @@ subroutine cam_snapshot_all_outfld_tphysac(file_num, state, tend, cam_in, cam_ou ! Return if the first timestep as not all fields may be filled in and this will cause a core dump if (is_first_step()) return - ! Return if not turned on + ! Return if not turned on if (cam_snapshot_before_num <= 0 .and. cam_snapshot_after_num <= 0) return ! No snapshot files are being requested lchnk = state%lchnk @@ -182,7 +180,7 @@ subroutine cam_tphysbc_snapshot_init(cam_snapshot_before_num, cam_snapshot_after !-------------------------------------------------------- integer,intent(in) :: cam_snapshot_before_num, cam_snapshot_after_num - + ntphysbc_var = 0 !-------------------------------------------------------- @@ -199,9 +197,6 @@ subroutine cam_tphysbc_snapshot_init(cam_snapshot_before_num, cam_snapshot_after call snapshot_addfld( ntphysbc_var, tphysbc_snapshot, cam_snapshot_before_num, cam_snapshot_after_num, & 'cmfcme', 'tphysbc_cmfcme', 'unset', 'lev') - call snapshot_addfld( ntphysbc_var, tphysbc_snapshot, cam_snapshot_before_num, cam_snapshot_after_num, & - 'pflx', 'tphysbc_pflx', 'unset', 'lev') - call snapshot_addfld( ntphysbc_var, tphysbc_snapshot, cam_snapshot_before_num, cam_snapshot_after_num, & 'zdu', 'tphysbc_zdu', 'unset', 'lev') @@ -240,7 +235,7 @@ subroutine cam_tphysac_snapshot_init(cam_snapshot_before_num, cam_snapshot_after !-------------------------------------------------------- integer,intent(in) :: cam_snapshot_before_num, cam_snapshot_after_num - + ntphysac_var = 0 !-------------------------------------------------------- diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index 1432be7327..c5bdcd71ce 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -20,7 +20,7 @@ module clubb_intr use shr_kind_mod, only: r8=>shr_kind_r8 use ppgrid, only: pver, pverp, pcols, begchunk, endchunk use phys_control, only: phys_getopts - use physconst, only: cpair, gravit, rga, latvap, latice, zvir, rh2o + use physconst, only: cpair, gravit, rga, latvap, latice, zvir, rh2o, karman, pi use air_composition, only: rairv, cpairv use cam_history_support, only: max_fieldname_len @@ -28,9 +28,11 @@ module clubb_intr use constituents, only: pcnst, cnst_add use pbl_utils, only: calc_ustar, calc_obklen use ref_pres, only: top_lev => trop_cloud_top_lev + #ifdef CLUBB_SGS use clubb_api_module, only: pdf_parameter, implicit_coefs_terms - use clubb_api_module, only: clubb_config_flags_type, grid, stats, nu_vertical_res_dep + use clubb_api_module, only: clubb_config_flags_type, grid, stats, & + nu_vertical_res_dep, stats_metadata_type use clubb_api_module, only: nparams use clubb_mf, only: do_clubb_mf, do_clubb_mf_diag use cloud_fraction, only: dp1, dp2 @@ -46,7 +48,9 @@ module clubb_intr stats_rad_zm(pcols), & ! stats_rad_zm grid stats_sfc(pcols) ! stats_sfc -!$omp threadprivate(stats_zt, stats_zm, stats_rad_zt, stats_rad_zm, stats_sfc) + type (stats_metadata_type) :: & + stats_metadata + #endif @@ -61,6 +65,7 @@ module clubb_intr #ifdef CLUBB_SGS ! This utilizes CLUBB specific variables in its interface stats_init_clubb, & + stats_metadata, & stats_zt, stats_zm, stats_sfc, & stats_rad_zt, stats_rad_zm, & stats_end_timestep_clubb, & @@ -76,6 +81,7 @@ module clubb_intr logical, public :: do_cldcool logical :: clubb_do_icesuper + #ifdef CLUBB_SGS type(clubb_config_flags_type), public :: clubb_config_flags real(r8), dimension(nparams), public :: clubb_params ! Adjustable CLUBB parameters (C1, C2 ...) @@ -177,7 +183,10 @@ module clubb_intr real(r8) :: clubb_detliq_rad = unset_r8 real(r8) :: clubb_detice_rad = unset_r8 real(r8) :: clubb_detphase_lowtemp = unset_r8 - + real(r8) :: clubb_bv_efold = unset_r8 + real(r8) :: clubb_wpxp_Ri_exp = unset_r8 + real(r8) :: clubb_z_displace = unset_r8 + integer :: & clubb_iiPDF_type, & ! Selected option for the two-component normal ! (double Gaussian) PDF type to use for the w, rt, @@ -290,7 +299,9 @@ module clubb_intr ! Looking at issue #905 on the clubb repo clubb_l_use_tke_in_wp3_pr_turb_term,& ! Use TKE formulation for wp3 pr_turb term clubb_l_use_tke_in_wp2_wp3_K_dfsn, & ! Use TKE in eddy diffusion for wp2 and wp3 + clubb_l_use_wp3_lim_with_smth_Heaviside, & ! Flag to activate mods on wp3 limiters for conv test clubb_l_smooth_Heaviside_tau_wpxp, & ! Use smooth Heaviside 'Peskin' in computation of invrs_tau + clubb_l_modify_limiters_for_cnvg_test, & ! Flag to activate mods on limiters for conv test clubb_l_enable_relaxed_clipping, & ! Flag to relax clipping on wpxp in xm_wpxp_clipping_and_stats clubb_l_linearize_pbl_winds, & ! Flag to turn on code to linearize PBL winds clubb_l_single_C2_Skw, & ! Use a single Skewness dependent C2 for rtp2, thlp2, and @@ -304,7 +315,7 @@ module clubb_intr clubb_l_mono_flux_lim_vm, & ! Flag to turn on monotonic flux limiter for vm clubb_l_mono_flux_lim_spikefix, & ! Flag to implement monotonic flux limiter code that ! eliminates spurious drying tendencies at model top - clubb_l_intr_sfc_flux_smooth = .false.! Add a locally calculated roughness to upwp and vpwp sfc fluxes + clubb_l_intr_sfc_flux_smooth = .false. ! Add a locally calculated roughness to upwp and vpwp sfc fluxes ! Constant parameters logical, parameter, private :: & @@ -697,8 +708,7 @@ subroutine clubb_readnl(nlfile) use clubb_api_module, only: & set_default_clubb_config_flags_api, & ! Procedure(s) - initialize_clubb_config_flags_type_api, & - l_stats, l_output_rad_files + initialize_clubb_config_flags_type_api #endif character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input @@ -717,6 +727,7 @@ subroutine clubb_readnl(nlfile) clubb_do_adv, clubb_timestep, & clubb_rnevap_effic,clubb_do_icesuper namelist /clubb_params_nl/ clubb_beta, & + clubb_bv_efold, & clubb_c1, & clubb_c1b, & clubb_c11, & @@ -761,17 +772,25 @@ subroutine clubb_readnl(nlfile) clubb_do_liqsupersat, & clubb_gamma_coef, & clubb_gamma_coefb, & + clubb_iiPDF_type, & clubb_ipdf_call_placement, & clubb_lambda0_stability_coef, & clubb_lmin_coef, & clubb_l_brunt_vaisala_freq_moist, & + clubb_l_C2_cloud_frac, & + clubb_l_calc_thlp2_rad, & + clubb_l_calc_w_corr, & clubb_l_call_pdf_closure_twice, & + clubb_l_const_Nc_in_cloud, & clubb_l_damp_wp2_using_em, & clubb_l_damp_wp3_Skw_squared, & clubb_l_diag_Lscale_from_tau, & + clubb_l_diagnose_correlations, & + clubb_l_diffuse_rtm_and_thlm, & clubb_l_do_expldiff_rtm_thlm, & clubb_l_e3sm_config, & clubb_l_enable_relaxed_clipping, & + clubb_l_fix_w_chi_eta_correlations, & clubb_l_godunov_upwind_wpxp_ta, & clubb_l_godunov_upwind_xpyp_ta, & clubb_l_intr_sfc_flux_smooth, & @@ -779,6 +798,7 @@ subroutine clubb_readnl(nlfile) clubb_l_lscale_plume_centered, & clubb_l_min_wp2_from_corr_wx, & clubb_l_min_xp2_from_corr_wx, & + clubb_l_modify_limiters_for_cnvg_test, & clubb_l_mono_flux_lim_rtm, & clubb_l_mono_flux_lim_spikefix, & clubb_l_mono_flux_lim_thlm, & @@ -786,20 +806,28 @@ subroutine clubb_readnl(nlfile) clubb_l_mono_flux_lim_vm, & clubb_l_partial_upwind_wp3, & clubb_l_predict_upwp_vpwp, & + clubb_l_prescribed_avg_deltaz, & clubb_l_rcm_supersat_adj, & + clubb_l_rtm_nudge, & clubb_l_smooth_Heaviside_tau_wpxp, & + clubb_l_stability_correct_Kh_N2_zm, & clubb_l_stability_correct_tau_zm, & clubb_l_standard_term_ta, & + clubb_l_tke_aniso, & clubb_l_trapezoidal_rule_zm, & clubb_l_trapezoidal_rule_zt, & + clubb_l_upwind_xm_ma, & clubb_l_upwind_xpyp_ta, & clubb_l_use_C11_Richardson, & clubb_l_use_C7_Richardson, & clubb_l_use_cloud_cover, & + clubb_l_use_precip_frac, & clubb_l_use_shear_Richardson, & clubb_l_use_thvm_in_bv_freq, & clubb_l_use_tke_in_wp2_wp3_K_dfsn, & clubb_l_use_tke_in_wp3_pr_turb_term, & + clubb_l_use_wp3_lim_with_smth_Heaviside, & + clubb_l_uv_nudge, & clubb_l_vary_convect_depth, & clubb_l_vert_avg_closure, & clubb_mult_coef, & @@ -810,16 +838,18 @@ subroutine clubb_readnl(nlfile) clubb_skw_max_mag, & clubb_tridiag_solve_method, & clubb_up2_sfc_coef, & - clubb_wpxp_L_thresh + clubb_wpxp_L_thresh, & + clubb_wpxp_Ri_exp, & + clubb_z_displace !----- 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 + ! Determine if we want clubb_history to be output + clubb_history = .false. ! Initialize to false + stats_metadata%l_stats = .false. ! Initialize to false + stats_metadata%l_output_rad_files = .false. ! Initialize to false + do_cldcool = .false. ! Initialize to false + do_rainturb = .false. ! Initialize to false ! Initialize namelist variables to clubb defaults call set_default_clubb_config_flags_api( clubb_iiPDF_type, & ! Out @@ -870,7 +900,9 @@ subroutine clubb_readnl(nlfile) clubb_l_vary_convect_depth, & ! Out clubb_l_use_tke_in_wp3_pr_turb_term, & ! Out clubb_l_use_tke_in_wp2_wp3_K_dfsn, & ! Out + clubb_l_use_wp3_lim_with_smth_Heaviside, & ! Out clubb_l_smooth_Heaviside_tau_wpxp, & ! Out + clubb_l_modify_limiters_for_cnvg_test, & ! Out clubb_l_enable_relaxed_clipping, & ! Out clubb_l_linearize_pbl_winds, & ! Out clubb_l_mono_flux_lim_thlm, & ! Out @@ -1007,6 +1039,12 @@ subroutine clubb_readnl(nlfile) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_nu9") call mpi_bcast(clubb_C_wp2_splat, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_C_wp2_splat") + call mpi_bcast(clubb_bv_efold, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_bv_efold") + call mpi_bcast(clubb_wpxp_Ri_exp, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_wpxp_Ri_exp") + call mpi_bcast(clubb_z_displace, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_z_displace") call mpi_bcast(clubb_lambda0_stability_coef, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_lambda0_stability_coef") call mpi_bcast(clubb_l_lscale_plume_centered,1, mpi_logical, mstrid, mpicom, ierr) @@ -1047,6 +1085,8 @@ subroutine clubb_readnl(nlfile) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_detice_rad") call mpi_bcast(clubb_detphase_lowtemp, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_detphase_lowtemp") + call mpi_bcast(clubb_iiPDF_type, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_iiPDF_type") call mpi_bcast(clubb_l_use_C7_Richardson, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_use_C7_Richardson") @@ -1100,8 +1140,12 @@ subroutine clubb_readnl(nlfile) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_use_tke_in_wp3_pr_turb_term") call mpi_bcast(clubb_l_use_tke_in_wp2_wp3_K_dfsn, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_use_tke_in_wp2_wp3_K_dfsn") + call mpi_bcast(clubb_l_use_wp3_lim_with_smth_Heaviside, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_use_wp3_lim_with_smth_Heaviside") call mpi_bcast(clubb_l_smooth_Heaviside_tau_wpxp, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_smooth_Heaviside_tau_wpxp") + call mpi_bcast(clubb_l_modify_limiters_for_cnvg_test, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_modify_limiters_for_cnvg_test") call mpi_bcast(clubb_ipdf_call_placement, 1, mpi_integer, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_ipdf_call_placement") call mpi_bcast(clubb_l_mono_flux_lim_thlm, 1, mpi_logical, mstrid, mpicom, ierr) @@ -1126,10 +1170,38 @@ subroutine clubb_readnl(nlfile) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_standard_term_ta") call mpi_bcast(clubb_l_partial_upwind_wp3, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_partial_upwind_wp3") + call mpi_bcast(clubb_l_C2_cloud_frac, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_C2_cloud_frac") + call mpi_bcast(clubb_l_calc_thlp2_rad, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_calc_thlp2_rad") + call mpi_bcast(clubb_l_calc_w_corr, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_calc_w_corr") + call mpi_bcast(clubb_l_const_Nc_in_cloud, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_const_Nc_in_cloud") + call mpi_bcast(clubb_l_diagnose_correlations, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_diagnose_correlations") + call mpi_bcast(clubb_l_diffuse_rtm_and_thlm, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_diffuse_rtm_and_thlm") + call mpi_bcast(clubb_l_fix_w_chi_eta_correlations, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_fix_w_chi_eta_correlations") + call mpi_bcast(clubb_l_prescribed_avg_deltaz, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_prescribed_avg_deltaz") + call mpi_bcast(clubb_l_rtm_nudge, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_rtm_nudge") + call mpi_bcast(clubb_l_stability_correct_Kh_N2_zm, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_stability_correct_Kh_N2_zm") + call mpi_bcast(clubb_l_tke_aniso, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_tke_aniso") + call mpi_bcast(clubb_l_upwind_xm_ma, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_upwind_xm_ma") + call mpi_bcast(clubb_l_use_precip_frac, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_use_precip_frac") + call mpi_bcast(clubb_l_uv_nudge, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_uv_nudge") ! Overwrite defaults if they are true - if (clubb_history) l_stats = .true. - if (clubb_rad_history) l_output_rad_files = .true. + if (clubb_history) stats_metadata%l_stats = .true. + if (clubb_rad_history) stats_metadata%l_output_rad_files = .true. if (clubb_cloudtop_cooling) do_cldcool = .true. if (clubb_rainevap_turb) do_rainturb = .true. @@ -1185,7 +1257,10 @@ subroutine clubb_readnl(nlfile) if(clubb_Skw_denom_coef == unset_r8) call endrun(sub//": FATAL: clubb_Skw_denom_coef is not set") if(clubb_skw_max_mag == unset_r8) call endrun(sub//": FATAL: clubb_skw_max_mag is not set") if(clubb_up2_sfc_coef == unset_r8) call endrun(sub//": FATAL: clubb_up2_sfc_coef is not set") - if(clubb_C_wp2_splat == unset_r8) call endrun(sub//": FATAL: clubb_C_wp2_splatis not set") + if(clubb_C_wp2_splat == unset_r8) call endrun(sub//": FATAL: clubb_C_wp2_splat is not set") + if(clubb_bv_efold == unset_r8) call endrun(sub//": FATAL: clubb_bv_efold is not set") + if(clubb_wpxp_Ri_exp == unset_r8) call endrun(sub//": FATAL: clubb_wpxp_Ri_exp is not set") + if(clubb_z_displace == unset_r8) call endrun(sub//": FATAL: clubb_z_displace is not set") if(clubb_detliq_rad == unset_r8) call endrun(sub//": FATAL: clubb_detliq_rad not set") if(clubb_detice_rad == unset_r8) call endrun(sub//": FATAL: clubb_detice_rad not set") if(clubb_ipdf_call_placement == unset_i) call endrun(sub//": FATAL: clubb_ipdf_call_placement not set") @@ -1243,7 +1318,9 @@ subroutine clubb_readnl(nlfile) clubb_l_vary_convect_depth, & ! In clubb_l_use_tke_in_wp3_pr_turb_term, & ! In clubb_l_use_tke_in_wp2_wp3_K_dfsn, & ! In + clubb_l_use_wp3_lim_with_smth_Heaviside, & ! In clubb_l_smooth_Heaviside_tau_wpxp, & ! In + clubb_l_modify_limiters_for_cnvg_test, & ! In clubb_l_enable_relaxed_clipping, & ! In clubb_l_linearize_pbl_winds, & ! In clubb_l_mono_flux_lim_thlm, & ! In @@ -1289,8 +1366,10 @@ subroutine clubb_ini_cam(pbuf2d) iC14, iC_wp3_pr_turb, igamma_coef, igamma_coefb, imult_coef, ilmin_coef, & iSkw_denom_coef, ibeta, iskw_max_mag, & iC_invrs_tau_bkgnd,iC_invrs_tau_sfc,iC_invrs_tau_shear,iC_invrs_tau_N2,iC_invrs_tau_N2_wp2, & - iC_invrs_tau_N2_xp2,iC_invrs_tau_N2_wpxp,iC_invrs_tau_N2_clear_wp3,iC_uu_shr,iC_uu_buoy, & - iC2rt, iC2thl, iC2rtthl, ic_K1, ic_K2, inu2, ic_K8, ic_K9, inu9, iC_wp2_splat, params_list + iC_invrs_tau_N2_xp2,iC_invrs_tau_N2_wpxp,iC_invrs_tau_N2_clear_wp3, & + iC2rt, iC2thl, iC2rtthl, ic_K1, ic_K2, inu2, ic_K8, ic_K9, inu9, iC_wp2_splat, ibv_efold, & + iwpxp_Ri_exp, iz_displace, & + params_list use clubb_api_module, only: & print_clubb_config_flags_api, & @@ -1303,9 +1382,6 @@ subroutine clubb_ini_cam(pbuf2d) nparams, & set_default_parameters_api, & read_parameters_api, & - l_stats, & - l_stats_samp, & - l_grads, & w_tol_sqd, & rt_tol, & thl_tol @@ -1348,7 +1424,7 @@ subroutine clubb_ini_cam(pbuf2d) logical, parameter :: l_input_fields = .false. ! Always false for CAM-CLUBB. logical, parameter :: l_update_pressure = .false. ! Always false for CAM-CLUBB. - integer :: nlev + integer :: nlev, ierr=0 real(r8) :: & C1, C1b, C1c, C2rt, C2thl, C2rtthl, & @@ -1371,7 +1447,8 @@ subroutine clubb_ini_cam(pbuf2d) C_invrs_tau_shear, C_invrs_tau_N2, C_invrs_tau_N2_wp2, & C_invrs_tau_N2_xp2, C_invrs_tau_N2_wpxp, C_invrs_tau_N2_clear_wp3, & C_invrs_tau_wpxp_Ri, C_invrs_tau_wpxp_N2_thresh, & - Cx_min, Cx_max, Richardson_num_min, Richardson_num_max, a3_coef_min + Cx_min, Cx_max, Richardson_num_min, Richardson_num_max, wpxp_Ri_exp, & + a3_coef_min, a_const, bv_efold, z_displace !----- Begin Code ----- @@ -1385,7 +1462,8 @@ subroutine clubb_ini_cam(pbuf2d) allocate( & pdf_params_chnk(begchunk:endchunk), & pdf_params_zm_chnk(begchunk:endchunk), & - pdf_implicit_coefs_terms_chnk(begchunk:endchunk) ) + pdf_implicit_coefs_terms_chnk(begchunk:endchunk), stat=ierr ) + if( ierr /= 0 ) call endrun(' clubb_ini_cam: failed to allocate pdf_params') ! ----------------------------------------------------------------- ! ! Determine how many constituents CLUBB will transport. Note that @@ -1448,11 +1526,11 @@ subroutine clubb_ini_cam(pbuf2d) ! Defaults - l_stats_samp = .false. - l_grads = .false. + stats_metadata%l_stats_samp = .false. + stats_metadata%l_grads = .false. - ! Overwrite defaults if needbe - if (l_stats) l_stats_samp = .true. + ! Overwrite defaults if needbe + if (stats_metadata%l_stats) stats_metadata%l_stats_samp = .true. ! Define physics buffers indexes cld_idx = pbuf_get_index('CLD') ! Cloud fraction @@ -1519,8 +1597,8 @@ subroutine clubb_ini_cam(pbuf2d) C_invrs_tau_N2_wp2, C_invrs_tau_N2_xp2, & C_invrs_tau_N2_wpxp, C_invrs_tau_N2_clear_wp3, & C_invrs_tau_wpxp_Ri, C_invrs_tau_wpxp_N2_thresh, & - Cx_min, Cx_max, Richardson_num_min, & - Richardson_num_max, a3_coef_min ) + Cx_min, Cx_max, Richardson_num_min, Richardson_num_max, & + wpxp_Ri_exp, a3_coef_min, a_const, bv_efold, z_displace ) call read_parameters_api( -99, "", & C1, C1b, C1c, C2rt, C2thl, C2rtthl, & @@ -1545,8 +1623,8 @@ subroutine clubb_ini_cam(pbuf2d) C_invrs_tau_N2_wp2, C_invrs_tau_N2_xp2, & C_invrs_tau_N2_wpxp, C_invrs_tau_N2_clear_wp3, & C_invrs_tau_wpxp_Ri, C_invrs_tau_wpxp_N2_thresh, & - Cx_min, Cx_max, Richardson_num_min, & - Richardson_num_max, a3_coef_min, & + Cx_min, Cx_max, Richardson_num_min, Richardson_num_max, & + wpxp_Ri_exp, a3_coef_min, a_const, bv_efold, z_displace, & clubb_params ) clubb_params(iC2rtthl) = clubb_C2rtthl @@ -1598,29 +1676,24 @@ subroutine clubb_ini_cam(pbuf2d) clubb_params(iC_invrs_tau_N2_xp2) = clubb_C_invrs_tau_N2_xp2 clubb_params(iC_invrs_tau_N2_wpxp) = clubb_C_invrs_tau_N2_wpxp clubb_params(iC_invrs_tau_N2_clear_wp3) = clubb_C_invrs_tau_N2_clear_wp3 - + clubb_params(ibv_efold) = clubb_bv_efold + clubb_params(iwpxp_Ri_exp) = clubb_wpxp_Ri_exp + clubb_params(iz_displace) = clubb_z_displace + ! Set up CLUBB core. Note that some of these inputs are overwritten ! when clubb_tend_cam is called. The reason is that heights can change ! at each time step, which is why dummy arrays are read in here for heights ! as they are immediately overwrote. !$OMP PARALLEL - call setup_clubb_core_api & - ( nlev+1, theta0, ts_nudge, & ! In - hydromet_dim, sclr_dim, & ! In - sclr_tol, edsclr_dim, clubb_params, & ! In - l_host_applies_sfc_fluxes, & ! In - saturation_equation, & ! In - l_input_fields, & ! In - clubb_config_flags%iiPDF_type, & ! In - clubb_config_flags%ipdf_call_placement, & ! In - clubb_config_flags%l_predict_upwp_vpwp, & ! In - clubb_config_flags%l_min_xp2_from_corr_wx, & ! In - clubb_config_flags%l_prescribed_avg_deltaz, & ! In - clubb_config_flags%l_damp_wp2_using_em, & ! In - clubb_config_flags%l_stability_correct_tau_zm, & ! In - clubb_config_flags%l_enable_relaxed_clipping, & ! In - clubb_config_flags%l_diag_Lscale_from_tau, & ! In - err_code ) ! Out + call setup_clubb_core_api( & + nlev+1, theta0, ts_nudge, & ! In + hydromet_dim, sclr_dim, & ! In + sclr_tol, edsclr_dim, clubb_params, & ! In + l_host_applies_sfc_fluxes, & ! In + saturation_equation, & ! In + l_input_fields, & ! In + clubb_config_flags, & ! In + err_code ) ! Out if ( err_code == clubb_fatal_error ) then call endrun('clubb_ini_cam: FATAL ERROR CALLING SETUP_CLUBB_CORE') @@ -1742,21 +1815,27 @@ subroutine clubb_ini_cam(pbuf2d) dum2 = 1200._r8 dum3 = 300._r8 - if (l_stats) then - do i=1, pcols - call stats_init_clubb( .true., dum1, dum2, & - nlev+1, nlev+1, nlev+1, dum3, & - stats_zt(i), stats_zm(i), stats_sfc(i), & - stats_rad_zt(i), stats_rad_zm(i)) - end do + if (stats_metadata%l_stats) then - allocate(out_zt(pcols,pverp,stats_zt(1)%num_output_fields)) - allocate(out_zm(pcols,pverp,stats_zm(1)%num_output_fields)) - allocate(out_sfc(pcols,1,stats_sfc(1)%num_output_fields)) + call stats_init_clubb( .true., dum1, dum2, & + nlev+1, nlev+1, nlev+1, dum3, & + stats_zt(:), stats_zm(:), stats_sfc(:), & + stats_rad_zt(:), stats_rad_zm(:)) - allocate(out_radzt(pcols,pverp,stats_rad_zt(1)%num_output_fields)) - allocate(out_radzm(pcols,pverp,stats_rad_zm(1)%num_output_fields)) + allocate(out_zt(pcols,pverp,stats_zt(1)%num_output_fields), stat=ierr) + if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate out_zt' ) + allocate(out_zm(pcols,pverp,stats_zm(1)%num_output_fields), stat=ierr) + if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate out_zm' ) + allocate(out_sfc(pcols,1,stats_sfc(1)%num_output_fields), stat=ierr) + if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate out_sfc' ) + + if ( stats_metadata%l_output_rad_files ) then + allocate(out_radzt(pcols,pverp,stats_rad_zt(1)%num_output_fields), stat=ierr) + if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate out_radzt' ) + allocate(out_radzm(pcols,pverp,stats_rad_zm(1)%num_output_fields), stat=ierr) + if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate out_radzm' ) + end if endif @@ -1951,6 +2030,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & use cam_logfile, only: iulog use tropopause, only: tropopause_findChemTrop use time_manager, only: get_nstep, is_first_restart_step + #ifdef CLUBB_SGS use hb_diff, only: pblintd use scamMOD, only: single_column,scm_clubb_iop_name @@ -1965,10 +2045,6 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & w_tol_sqd, & rt_tol, & thl_tol, & - l_stats, & - stats_tsamp, & - stats_tout, & - l_output_rad_files, & stats_begin_timestep_api, & hydromet_dim, calculate_thlp2_rad_api, update_xp2_mc_api, & sat_mixrat_liq_api, & @@ -2059,6 +2135,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & real(r8) :: zo(pcols) ! roughness height [m] real(r8) :: dz_g(pcols,pver) ! thickness of layer [m] real(r8) :: relvarmax + real(r8) :: se_upper_a(pcols), se_upper_b(pcols), se_upper_diss(pcols) + real(r8) :: tw_upper_a(pcols), tw_upper_b(pcols), tw_upper_diss(pcols) ! Local CLUBB variables dimensioned as NCOL (only useful columns) to be sent into the clubb run api ! NOTE: THESE VARIABLS SHOULD NOT BE USED IN PBUF OR OUTFLD (HISTORY) SUBROUTINES @@ -2259,6 +2337,10 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & real(kind=time_precision) :: time_elapsed ! time keep track of stats [s] integer :: stats_nsamp, stats_nout ! Stats sampling and output intervals for CLUBB [timestep] + real(r8) :: rtm_integral_vtend(pcols), & + rtm_integral_ltend(pcols) + + real(r8) :: rtm_integral_1, rtm_integral_update, rtm_integral_forcing ! ---------------------------------------------------- ! @@ -2405,10 +2487,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & intrinsic :: max character(len=*), parameter :: subr='clubb_tend_cam' - + real(r8), parameter :: rad2deg=180.0_r8/pi + real(r8) :: tmp_lon1, tmp_lonN + type(grid) :: gr - integer :: begin_height, end_height - + type(nu_vertical_res_dep) :: nu_vert_res_dep ! Vertical resolution dependent nu values real(r8) :: lmin @@ -2419,7 +2502,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & #ifdef CLUBB_SGS !-----------------------------------------------------------------------------------! - ! MAIN COMPUTATION BEGINS HERE ! ! + ! MAIN COMPUTATION BEGINS HERE ! !-----------------------------------------------------------------------------------! call t_startf("clubb_tend_cam") @@ -2945,15 +3028,15 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end do ! Set stats output and increment equal to CLUBB and host dt - stats_tsamp = dtime - stats_tout = hdtime - - stats_nsamp = nint(stats_tsamp/dtime) - stats_nout = nint(stats_tout/dtime) - - ! Heights need to be set at each timestep. Therefore, recall - ! setup_grid and setup_parameters for this. - + stats_metadata%stats_tsamp = dtime + stats_metadata%stats_tout = hdtime + + stats_nsamp = nint(stats_metadata%stats_tsamp/dtime) + stats_nout = nint(stats_metadata%stats_tout/dtime) + + ! Heights need to be set at each timestep. Therefore, recall + ! setup_grid and setup_parameters for this. + ! Set-up CLUBB core at each CLUBB call because heights can change ! Important note: do not make any calls that use CLUBB grid-height ! operators (such as zt2zm_api, etc.) until AFTER the @@ -2961,12 +3044,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call setup_grid_api( nlev+1, ncol, sfc_elevation, l_implemented, & ! intent(in) grid_type, zi_g(:,2), zi_g(:,1), zi_g(:,nlev+1), & ! intent(in) zi_g, zt_g, & ! intent(in) - gr, begin_height, end_height ) ! intent(out) + gr ) ! intent(out) - call setup_parameters_api( zi_g(:,2), clubb_params, nlev+1, ncol, grid_type, & ! intent(in) - zi_g, zt_g, & ! intent(in) - clubb_config_flags%l_prescribed_avg_deltaz, & ! intent(in) - lmin, nu_vert_res_dep, err_code ) ! intent(out) + call setup_parameters_api( zi_g(:,2), clubb_params, gr, ncol, grid_type, & ! intent(in) + clubb_config_flags%l_prescribed_avg_deltaz, & ! intent(in) + lmin, nu_vert_res_dep, err_code ) ! intent(out) if ( err_code == clubb_fatal_error ) then call endrun(subr//': Fatal error in CLUBB setup_parameters') end if @@ -3251,10 +3333,11 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & 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 - call stats_begin_timestep_api(t, stats_nsamp, stats_nout) + + ! Increment the statistics then begin stats timestep + if (stats_metadata%l_stats) then + call stats_begin_timestep_api( t, stats_nsamp, stats_nout, & + stats_metadata ) endif !####################################################################### @@ -3333,6 +3416,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & grid_dx, grid_dy, & clubb_params, nu_vert_res_dep, lmin, & clubb_config_flags, & + stats_metadata, & stats_zt(:ncol), stats_zm(:ncol), stats_sfc(:ncol), & um_in, vm_in, upwp_in, vpwp_in, up2_in, vp2_in, up3_in, vp3_in, & thlm_in, rtm_in, wprtp_in, wpthlp_in, & @@ -3360,8 +3444,13 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! one value only for the entire chunk if ( err_code == clubb_fatal_error ) then write(fstderr,*) "Fatal error in CLUBB: at timestep ", get_nstep() - write(fstderr,*) "LAT Range: ", state1%lat(1), " -- ", state1%lat(ncol) - write(fstderr,*) "LON: Range:", state1%lon(1), " -- ", state1%lon(ncol) + write(fstderr,*) "LAT Range: ", state1%lat(1)*rad2deg, & + " -- ", state1%lat(ncol)*rad2deg + tmp_lon1 = state1%lon(1)*rad2deg + tmp_lon1 = state1%lon(ncol)*rad2deg + if(tmp_lon1.gt.180.0_r8) tmp_lon1=tmp_lon1-360.0_r8 + if(tmp_lonN.gt.180.0_r8) tmp_lonN=tmp_lonN-360.0_r8 + write(fstderr,*) "LON: Range:", tmp_lon1, " -- ", tmp_lonN call endrun(subr//': Fatal error in CLUBB library') end if @@ -3415,7 +3504,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! 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) then + if (stats_metadata%l_stats) then do i=1, ncol call stats_end_timestep_clubb(i, stats_zt(i), stats_zm(i), stats_rad_zt(i), stats_rad_zm(i), stats_sfc(i), & out_zt, out_zm, out_radzt, out_radzm, out_sfc) @@ -3699,6 +3788,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! 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 + rtm_integral_vtend(:) = 0._r8 + rtm_integral_ltend(:) = 0._r8 + do k=1, pver do i=1, ncol @@ -3708,10 +3800,15 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & 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(i,k) - state1%s(i,k)) / hdtime ! Tendency of static energy - end do - end do + rtm_integral_ltend(i) = rtm_integral_ltend(i) + ptend_loc%q(i,k,ixcldliq)*state1%pdel(i,k) + rtm_integral_vtend(i) = rtm_integral_vtend(i) + ptend_loc%q(i,k,ixq)*state1%pdel(i,k) + end do + end do + rtm_integral_ltend(:) = rtm_integral_ltend(:)/gravit + rtm_integral_vtend(:) = rtm_integral_vtend(:)/gravit + if (clubb_do_adv) then if (macmic_it == cld_macmic_num_steps) then @@ -4273,8 +4370,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & end if ! Output CLUBB history here - if (l_stats) then - + if (stats_metadata%l_stats) then + do j=1,stats_zt(1)%num_output_fields temp1 = trim(stats_zt(1)%file%grid_avg_var(j)%name) @@ -4293,7 +4390,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & call outfld(trim(sub),out_zm(:,:,j), pcols, lchnk) enddo - if (l_output_rad_files) then + if (stats_metadata%l_output_rad_files) then do j=1,stats_rad_zt(1)%num_output_fields call outfld(trim(stats_rad_zt(1)%file%grid_avg_var(j)%name), out_radzt(:,:,j), pcols, lchnk) enddo @@ -4523,57 +4620,6 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & !----------------------------------------------------------------------- - - use clubb_api_module, only: & - ztscr01, & - ztscr02, & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - use clubb_api_module, only: & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & - l_stats, & - l_output_rad_files, & - stats_tsamp, & - stats_tout, & - l_stats_samp, & - l_stats_last, & - l_netcdf, & - l_grads - use clubb_api_module, only: time_precision, & ! nvarmax_zm, stats_init_zm_api, & ! nvarmax_zt, stats_init_zt_api, & ! @@ -4589,7 +4635,7 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & implicit none - ! Input Variables + !----------------------- Input Variables ----------------------- logical, intent(in) :: l_stats_in ! Stats on? T/F @@ -4603,15 +4649,16 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & real(kind=time_precision), intent(in) :: delt ! Timestep (dtmain in CLUBB) [s] - ! Output Variables - type (stats), intent(out) :: stats_zt, & ! stats_zt grid - stats_zm, & ! stats_zm grid - stats_rad_zt, & ! stats_rad_zt grid - stats_rad_zm, & ! stats_rad_zm grid - stats_sfc ! stats_sfc + !----------------------- Output Variables ----------------------- + type (stats), intent(out), dimension(pcols) :: & + stats_zt, & ! stats_zt grid + stats_zm, & ! stats_zm grid + stats_rad_zt, & ! stats_rad_zt grid + stats_rad_zm, & ! stats_rad_zm grid + stats_sfc ! stats_sfc - ! Local Variables + !----------------------- Local Variables ----------------------- ! Namelist Variables @@ -4630,28 +4677,27 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & clubb_vars_rad_zm, & clubb_vars_sfc - ! Local Variables - - logical :: l_error, & - first_call = .false. + logical :: l_error character(len=200) :: temp1, sub - integer :: i, ntot, read_status + integer :: i, ntot, read_status, j integer :: iunit, ierr + !----------------------- Begin Code ----------------------- + ! Initialize l_error = .false. ! Set stats_variables variables with inputs from calling subroutine - l_stats = l_stats_in + stats_metadata%l_stats = l_stats_in - stats_tsamp = stats_tsamp_in - stats_tout = stats_tout_in + stats_metadata%stats_tsamp = stats_tsamp_in + stats_metadata%stats_tout = stats_tout_in - if ( .not. l_stats ) then - l_stats_samp = .false. - l_stats_last = .false. + if ( .not. stats_metadata%l_stats ) then + stats_metadata%l_stats_samp = .false. + stats_metadata%l_stats_last = .false. return end if @@ -4690,296 +4736,223 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & call mpi_bcast(clubb_vars_sfc, var_length*nvarmax_sfc, mpi_character, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(subr//": FATAL: mpi_bcast: clubb_vars_sfc") + ! Hardcode these for use in CAM-CLUBB, don't want either - l_netcdf = .false. - l_grads = .false. + stats_metadata%l_netcdf = .false. + stats_metadata%l_grads = .false. ! Check sampling and output frequencies + do j = 1, pcols + + ! The model time step length, delt (which is dtmain), should multiply + ! evenly into the statistical sampling time step length, stats_tsamp. + if ( abs( stats_metadata%stats_tsamp/delt - floor(stats_metadata%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 ', & + 'the clubb time step (delt below)' + write(fstderr,*) 'stats_tsamp = ', stats_metadata%stats_tsamp + write(fstderr,*) 'delt = ', delt + call endrun ("stats_init_clubb: CLUBB stats_tsamp must be an even multiple of the timestep") + endif - ! 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 - 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 ) - 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 - call endrun ("stats_init_clubb: number of zt statistical variables exceeds limit") - endif - - stats_zt%num_output_fields = ntot - stats_zt%kk = nnzp - - allocate( stats_zt%z( stats_zt%kk ) ) - - 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( stats_zt%file%grid_avg_var( stats_zt%num_output_fields ) ) - allocate( stats_zt%file%z( stats_zt%kk ) ) - - first_call = (.not. allocated(ztscr01)) - - ! Allocate scratch space - if (first_call) allocate( ztscr01(stats_zt%kk) ) - if (first_call) allocate( ztscr02(stats_zt%kk) ) - if (first_call) allocate( ztscr03(stats_zt%kk) ) - if (first_call) allocate( ztscr04(stats_zt%kk) ) - if (first_call) allocate( ztscr05(stats_zt%kk) ) - if (first_call) allocate( ztscr06(stats_zt%kk) ) - if (first_call) allocate( ztscr07(stats_zt%kk) ) - if (first_call) allocate( ztscr08(stats_zt%kk) ) - if (first_call) allocate( ztscr09(stats_zt%kk) ) - if (first_call) allocate( ztscr10(stats_zt%kk) ) - if (first_call) allocate( ztscr11(stats_zt%kk) ) - if (first_call) allocate( ztscr12(stats_zt%kk) ) - if (first_call) allocate( ztscr13(stats_zt%kk) ) - if (first_call) allocate( ztscr14(stats_zt%kk) ) - if (first_call) allocate( ztscr15(stats_zt%kk) ) - if (first_call) allocate( ztscr16(stats_zt%kk) ) - if (first_call) allocate( ztscr17(stats_zt%kk) ) - if (first_call) allocate( ztscr18(stats_zt%kk) ) - if (first_call) allocate( ztscr19(stats_zt%kk) ) - if (first_call) allocate( ztscr20(stats_zt%kk) ) - if (first_call) allocate( ztscr21(stats_zt%kk) ) - - ztscr01 = 0.0_r8 - ztscr02 = 0.0_r8 - ztscr03 = 0.0_r8 - ztscr04 = 0.0_r8 - ztscr05 = 0.0_r8 - ztscr06 = 0.0_r8 - ztscr07 = 0.0_r8 - ztscr08 = 0.0_r8 - ztscr09 = 0.0_r8 - ztscr10 = 0.0_r8 - ztscr11 = 0.0_r8 - ztscr12 = 0.0_r8 - ztscr13 = 0.0_r8 - ztscr14 = 0.0_r8 - ztscr15 = 0.0_r8 - ztscr16 = 0.0_r8 - ztscr17 = 0.0_r8 - ztscr18 = 0.0_r8 - ztscr19 = 0.0_r8 - ztscr20 = 0.0_r8 - ztscr21 = 0.0_r8 - - ! Default initialization for array indices for zt - if (first_call) then - call stats_init_zt_api( clubb_vars_zt, l_error, & - stats_zt ) - end if - - ! 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 - 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 - call endrun ("stats_init_clubb: number of zm statistical variables exceeds limit") - endif - - stats_zm%num_output_fields = ntot - stats_zm%kk = nnzp - - allocate( stats_zm%z( stats_zm%kk ) ) - - 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( stats_zm%file%grid_avg_var( stats_zm%num_output_fields ) ) - allocate( stats_zm%file%z( stats_zm%kk ) ) - - ! Allocate scratch space - - if (first_call) allocate( zmscr01(stats_zm%kk) ) - if (first_call) allocate( zmscr02(stats_zm%kk) ) - if (first_call) allocate( zmscr03(stats_zm%kk) ) - if (first_call) allocate( zmscr04(stats_zm%kk) ) - if (first_call) allocate( zmscr05(stats_zm%kk) ) - if (first_call) allocate( zmscr06(stats_zm%kk) ) - if (first_call) allocate( zmscr07(stats_zm%kk) ) - if (first_call) allocate( zmscr08(stats_zm%kk) ) - if (first_call) allocate( zmscr09(stats_zm%kk) ) - if (first_call) allocate( zmscr10(stats_zm%kk) ) - if (first_call) allocate( zmscr11(stats_zm%kk) ) - if (first_call) allocate( zmscr12(stats_zm%kk) ) - if (first_call) allocate( zmscr13(stats_zm%kk) ) - if (first_call) allocate( zmscr14(stats_zm%kk) ) - if (first_call) allocate( zmscr15(stats_zm%kk) ) - if (first_call) allocate( zmscr16(stats_zm%kk) ) - if (first_call) allocate( zmscr17(stats_zm%kk) ) - - zmscr01 = 0.0_r8 - zmscr02 = 0.0_r8 - zmscr03 = 0.0_r8 - zmscr04 = 0.0_r8 - zmscr05 = 0.0_r8 - zmscr06 = 0.0_r8 - zmscr07 = 0.0_r8 - zmscr08 = 0.0_r8 - zmscr09 = 0.0_r8 - zmscr10 = 0.0_r8 - zmscr11 = 0.0_r8 - zmscr12 = 0.0_r8 - zmscr13 = 0.0_r8 - zmscr14 = 0.0_r8 - zmscr15 = 0.0_r8 - zmscr16 = 0.0_r8 - zmscr17 = 0.0_r8 - - if (first_call) then - call stats_init_zm_api( clubb_vars_zm, l_error, & - stats_zm ) - end if - - ! Initialize rad_zt (radiation points) - - 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 - call endrun ("stats_init_clubb: number of rad_zt statistical variables exceeds limit") - endif - - stats_rad_zt%num_output_fields = ntot - stats_rad_zt%kk = nnrad_zt - - allocate( stats_rad_zt%z( stats_rad_zt%kk ) ) - - 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 ) ) - - 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 ) - - allocate( stats_rad_zt%file%grid_avg_var( stats_rad_zt%num_output_fields ) ) - allocate( stats_rad_zt%file%z( stats_rad_zt%kk ) ) - - call stats_init_rad_zt_api( clubb_vars_rad_zt, l_error, & - stats_rad_zt ) - - ! 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 + ! Initialize zt (mass points) - stats_rad_zm%num_output_fields = ntot - stats_rad_zm%kk = nnrad_zm + i = 1 + 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 + l_error = .true. + 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 - allocate( stats_rad_zm%z( stats_rad_zm%kk ) ) + stats_zt(j)%num_output_fields = ntot + stats_zt(j)%kk = nnzp + + allocate( stats_zt(j)%z( stats_zt(j)%kk ), stat=ierr ) + if( ierr /= 0 ) call endrun("stats_init_clubb: Failed to allocate stats_zt%z") + + allocate( stats_zt(j)%accum_field_values( 1, 1, stats_zt(j)%kk, stats_zt(j)%num_output_fields ), stat=ierr ) + if( ierr /= 0 ) call endrun("stats_init_clubb: Failed to allocate stats_zt%accum_field_values") + allocate( stats_zt(j)%accum_num_samples( 1, 1, stats_zt(j)%kk, stats_zt(j)%num_output_fields ), stat=ierr ) + if( ierr /= 0 ) call endrun("stats_init_clubb: Failed to allocate stats_zt%accum_num_samples") + allocate( stats_zt(j)%l_in_update( 1, 1, stats_zt(j)%kk, stats_zt(j)%num_output_fields ), stat=ierr ) + if( ierr /= 0 ) call endrun("stats_init_clubb: Failed to allocate stats_zt%l_in_update") + call stats_zero( stats_zt(j)%kk, stats_zt(j)%num_output_fields, stats_zt(j)%accum_field_values, & + stats_zt(j)%accum_num_samples, stats_zt(j)%l_in_update ) + + allocate( stats_zt(j)%file%grid_avg_var( stats_zt(j)%num_output_fields ), stat=ierr ) + if( ierr /= 0 ) call endrun("stats_init_clubb: Failed to allocate stats_zt%file%grid_avg_var") + allocate( stats_zt(j)%file%z( stats_zt(j)%kk ), stat=ierr ) + if( ierr /= 0 ) call endrun("stats_init_clubb: Failed to allocate stats_zt%file%z") + + ! Default initialization for array indices for zt + call stats_init_zt_api( clubb_vars_zt, & + l_error, & + stats_metadata, stats_zt(j) ) + + ! 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 + end do + ntot = i - 1 + if ( ntot == nvarmax_zm ) then + l_error = .true. ! This will cause the run to stop. + 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 - 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 ) ) + stats_zm(j)%num_output_fields = ntot + stats_zm(j)%kk = nnzp + + allocate( stats_zm(j)%z( stats_zm(j)%kk ) ) + + allocate( stats_zm(j)%accum_field_values( 1, 1, stats_zm(j)%kk, stats_zm(j)%num_output_fields ) ) + allocate( stats_zm(j)%accum_num_samples( 1, 1, stats_zm(j)%kk, stats_zm(j)%num_output_fields ) ) + allocate( stats_zm(j)%l_in_update( 1, 1, stats_zm(j)%kk, stats_zm(j)%num_output_fields ) ) + call stats_zero( stats_zm(j)%kk, stats_zm(j)%num_output_fields, stats_zm(j)%accum_field_values, & + stats_zm(j)%accum_num_samples, stats_zm(j)%l_in_update ) + + allocate( stats_zm(j)%file%grid_avg_var( stats_zm(j)%num_output_fields ) ) + allocate( stats_zm(j)%file%z( stats_zm(j)%kk ) ) + + call stats_init_zm_api( clubb_vars_zm, & + l_error, & + stats_metadata, stats_zm(j) ) + + ! Initialize rad_zt (radiation points) + + if (stats_metadata%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 + call endrun ("stats_init_clubb: number of rad_zt statistical variables exceeds limit") + endif + + stats_rad_zt(j)%num_output_fields = ntot + stats_rad_zt(j)%kk = nnrad_zt + + allocate( stats_rad_zt(j)%z( stats_rad_zt(j)%kk ) ) + + allocate( stats_rad_zt(j)%accum_field_values( 1, 1, stats_rad_zt(j)%kk, stats_rad_zt(j)%num_output_fields ) ) + allocate( stats_rad_zt(j)%accum_num_samples( 1, 1, stats_rad_zt(j)%kk, stats_rad_zt(j)%num_output_fields ) ) + allocate( stats_rad_zt(j)%l_in_update( 1, 1, stats_rad_zt(j)%kk, stats_rad_zt(j)%num_output_fields ) ) + + call stats_zero( stats_rad_zt(j)%kk, stats_rad_zt(j)%num_output_fields, stats_rad_zt(j)%accum_field_values, & + stats_rad_zt(j)%accum_num_samples, stats_rad_zt(j)%l_in_update ) + + allocate( stats_rad_zt(j)%file%grid_avg_var( stats_rad_zt(j)%num_output_fields ) ) + allocate( stats_rad_zt(j)%file%z( stats_rad_zt(j)%kk ) ) + + call stats_init_rad_zt_api( clubb_vars_rad_zt, & + l_error, & + stats_metadata, stats_rad_zt(j) ) + + ! 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 + l_error = .true. ! This will cause the run to stop. + 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 + + stats_rad_zm(j)%num_output_fields = ntot + stats_rad_zm(j)%kk = nnrad_zm + + allocate( stats_rad_zm(j)%z( stats_rad_zm(j)%kk ) ) + + allocate( stats_rad_zm(j)%accum_field_values( 1, 1, stats_rad_zm(j)%kk, stats_rad_zm(j)%num_output_fields ) ) + allocate( stats_rad_zm(j)%accum_num_samples( 1, 1, stats_rad_zm(j)%kk, stats_rad_zm(j)%num_output_fields ) ) + allocate( stats_rad_zm(j)%l_in_update( 1, 1, stats_rad_zm(j)%kk, stats_rad_zm(j)%num_output_fields ) ) + + call stats_zero( stats_rad_zm(j)%kk, stats_rad_zm(j)%num_output_fields, stats_rad_zm(j)%accum_field_values, & + stats_rad_zm(j)%accum_num_samples, stats_rad_zm(j)%l_in_update ) + + allocate( stats_rad_zm(j)%file%grid_avg_var( stats_rad_zm(j)%num_output_fields ) ) + allocate( stats_rad_zm(j)%file%z( stats_rad_zm(j)%kk ) ) + + call stats_init_rad_zm_api( clubb_vars_rad_zm, & + l_error, & + stats_metadata, stats_rad_zm(j) ) + 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 + end do + ntot = i - 1 + if ( ntot == nvarmax_sfc ) then + l_error = .true. ! This will cause the run to stop. + 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 - 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 ) + stats_sfc(j)%num_output_fields = ntot + stats_sfc(j)%kk = 1 - allocate( stats_rad_zm%file%grid_avg_var( stats_rad_zm%num_output_fields ) ) - allocate( stats_rad_zm%file%z( stats_rad_zm%kk ) ) + allocate( stats_sfc(j)%z( stats_sfc(j)%kk ) ) - call stats_init_rad_zm_api( clubb_vars_rad_zm, l_error, & - stats_rad_zm ) - end if ! l_output_rad_files + allocate( stats_sfc(j)%accum_field_values( 1, 1, stats_sfc(j)%kk, stats_sfc(j)%num_output_fields ) ) + allocate( stats_sfc(j)%accum_num_samples( 1, 1, stats_sfc(j)%kk, stats_sfc(j)%num_output_fields ) ) + allocate( stats_sfc(j)%l_in_update( 1, 1, stats_sfc(j)%kk, stats_sfc(j)%num_output_fields ) ) + call stats_zero( stats_sfc(j)%kk, stats_sfc(j)%num_output_fields, stats_sfc(j)%accum_field_values, & + stats_sfc(j)%accum_num_samples, stats_sfc(j)%l_in_update ) - ! Initialize sfc (surface point) + allocate( stats_sfc(j)%file%grid_avg_var( stats_sfc(j)%num_output_fields ) ) + allocate( stats_sfc(j)%file%z( stats_sfc(j)%kk ) ) - 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 + call stats_init_sfc_api( clubb_vars_sfc, & + l_error, & + stats_metadata, stats_sfc(j) ) 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 - call endrun ("stats_init_clubb: number of sfc statistical variables exceeds limit") - endif - - stats_sfc%num_output_fields = ntot - stats_sfc%kk = 1 - - allocate( stats_sfc%z( stats_sfc%kk ) ) - - 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( 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%grid_avg_var( stats_sfc%num_output_fields ) ) - allocate( stats_sfc%file%z( stats_sfc%kk ) ) - - if (first_call) then - call stats_init_sfc_api( clubb_vars_sfc, l_error, & - stats_sfc ) - end if ! Check for errors @@ -4987,48 +4960,60 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & call endrun ('stats_init: errors found') endif -! Now call add fields - if (first_call) then - - do i = 1, stats_zt%num_output_fields - - temp1 = trim(stats_zt%file%grid_avg_var(i)%name) - sub = temp1 - if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) - - call addfld(trim(sub),(/ 'ilev' /),& - 'A',trim(stats_zt%file%grid_avg_var(i)%units),trim(stats_zt%file%grid_avg_var(i)%description)) - enddo - - do i = 1, stats_zm%num_output_fields - - temp1 = trim(stats_zm%file%grid_avg_var(i)%name) - sub = temp1 - if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) - - call addfld(trim(sub),(/ 'ilev' /),& - 'A',trim(stats_zm%file%grid_avg_var(i)%units),trim(stats_zm%file%grid_avg_var(i)%description)) - enddo - - if (l_output_rad_files) then - - do i = 1, stats_rad_zt%num_output_fields - call addfld(trim(stats_rad_zt%file%grid_avg_var(i)%name),(/ 'ilev' /),& - 'A',trim(stats_rad_zt%file%grid_avg_var(i)%units),trim(stats_rad_zt%file%grid_avg_var(i)%description)) - enddo + ! Now call add fields + + do i = 1, stats_zt(1)%num_output_fields + + temp1 = trim(stats_zt(1)%file%grid_avg_var(i)%name) + sub = temp1 + if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) + + call addfld( trim(sub), (/ 'ilev' /), 'A', & + trim(stats_zt(1)%file%grid_avg_var(i)%units), & + trim(stats_zt(1)%file%grid_avg_var(i)%description) ) + enddo + + do i = 1, stats_zm(1)%num_output_fields + + temp1 = trim(stats_zm(1)%file%grid_avg_var(i)%name) + sub = temp1 + if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) + + call addfld( trim(sub), (/ 'ilev' /), 'A', & + trim(stats_zm(1)%file%grid_avg_var(i)%units), & + trim(stats_zm(1)%file%grid_avg_var(i)%description) ) + enddo - do i = 1, stats_rad_zm%num_output_fields - call addfld(trim(stats_rad_zm%file%grid_avg_var(i)%name),(/ 'ilev' /),& - 'A',trim(stats_rad_zm%file%grid_avg_var(i)%units),trim(stats_rad_zm%file%grid_avg_var(i)%description)) - enddo - endif + if (stats_metadata%l_output_rad_files) then - do i = 1, stats_sfc%num_output_fields - call addfld(trim(stats_sfc%file%grid_avg_var(i)%name),horiz_only,& - 'A',trim(stats_sfc%file%grid_avg_var(i)%units),trim(stats_sfc%file%grid_avg_var(i)%description)) - enddo - - end if + do i = 1, stats_rad_zt(1)%num_output_fields + temp1 = trim(stats_rad_zt(1)%file%grid_avg_var(i)%name) + sub = temp1 + if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) + call addfld( trim(sub), (/ 'ilev' /), 'A', & + trim(stats_rad_zt(1)%file%grid_avg_var(i)%units), & + trim(stats_rad_zt(1)%file%grid_avg_var(i)%description) ) + enddo + + do i = 1, stats_rad_zm(1)%num_output_fields + temp1 = trim(stats_rad_zm(1)%file%grid_avg_var(i)%name) + sub = temp1 + if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) + call addfld( trim(sub), (/ 'ilev' /), 'A', & + trim(stats_rad_zm(1)%file%grid_avg_var(i)%units), & + trim(stats_rad_zm(1)%file%grid_avg_var(i)%description) ) + enddo + endif + + do i = 1, stats_sfc(1)%num_output_fields + temp1 = trim(stats_sfc(1)%file%grid_avg_var(i)%name) + sub = temp1 + if (len(temp1) > max_fieldname_len) sub = temp1(1:max_fieldname_len) + call addfld( trim(sub), horiz_only, 'A', & + trim(stats_sfc(1)%file%grid_avg_var(i)%units), & + trim(stats_sfc(1)%file%grid_avg_var(i)%description) ) + enddo + return @@ -5055,10 +5040,6 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st use clubb_api_module, only: & fstderr, & ! Constant(s) - l_stats_last, & - stats_tsamp, & - stats_tout, & - l_output_rad_files, & clubb_at_least_debug_level_api ! Procedure(s) use cam_abortutils, only: endrun @@ -5088,7 +5069,7 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st ! Check if it is time to write to file - if ( .not. l_stats_last ) return + if ( .not. stats_metadata%l_stats_last ) return ! Initialize l_error = .false. @@ -5096,7 +5077,7 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st ! Compute averages 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 + if (stats_metadata%l_output_rad_files) then 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, & @@ -5121,7 +5102,7 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st enddo enddo - if (l_output_rad_files) then + if (stats_metadata%l_output_rad_files) then do i = 1, stats_rad_zt%num_output_fields do k = 1, stats_rad_zt%kk out_radzt(thecol,pverp-k+1,i) = stats_rad_zt%accum_field_values(1,1,k,i) @@ -5154,7 +5135,7 @@ subroutine stats_end_timestep_clubb(thecol, stats_zt, stats_zm, stats_rad_zt, st 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 + if (stats_metadata%l_output_rad_files) then 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, & diff --git a/src/physics/cam/convect_deep.F90 b/src/physics/cam/convect_deep.F90 index edd2043623..ebba3ba9fa 100644 --- a/src/physics/cam/convect_deep.F90 +++ b/src/physics/cam/convect_deep.F90 @@ -5,7 +5,7 @@ module convect_deep ! ! CAM interface to several deep convection interfaces. Currently includes: ! Zhang-McFarlane (default) -! Kerry Emanuel +! Kerry Emanuel ! ! ! Author: D.B. Coleman, Sep 2004 @@ -28,34 +28,34 @@ module convect_deep convect_deep_tend, &! return tendencies convect_deep_tend_2, &! return tendencies deep_scheme_does_scav_trans ! = .t. if scheme does scavenging and conv. transport - + ! Private module data character(len=16) :: deep_scheme ! default set in phys_control.F90, use namelist to change -! Physics buffer indices - integer :: icwmrdp_idx = 0 - integer :: rprddp_idx = 0 - integer :: nevapr_dpcu_idx = 0 - integer :: cldtop_idx = 0 - integer :: cldbot_idx = 0 - integer :: cld_idx = 0 - integer :: fracis_idx = 0 - - integer :: pblh_idx = 0 - integer :: tpert_idx = 0 +! Physics buffer indices + integer :: icwmrdp_idx = 0 + integer :: rprddp_idx = 0 + integer :: nevapr_dpcu_idx = 0 + integer :: cldtop_idx = 0 + integer :: cldbot_idx = 0 + integer :: cld_idx = 0 + integer :: fracis_idx = 0 + + integer :: pblh_idx = 0 + integer :: tpert_idx = 0 integer :: prec_dp_idx = 0 integer :: snow_dp_idx = 0 integer :: ttend_dp_idx = 0 !========================================================================================= - contains + contains !========================================================================================= function deep_scheme_does_scav_trans() ! ! Function called by tphysbc to determine if it needs to do scavenging and convective transport ! or if those have been done by the deep convection scheme. Each scheme could have its own -! identical query function for a less-knowledgable interface but for now, we know that KE +! identical query function for a less-knowledgable interface but for now, we know that KE ! does scavenging & transport, and ZM doesn't ! @@ -76,7 +76,7 @@ subroutine convect_deep_register ! Purpose: register fields with the physics buffer !---------------------------------------- - + use physics_buffer, only : pbuf_add_field, dtype_r8 use zm_conv_intr, only: zm_conv_register use phys_control, only: phys_getopts, use_gw_convect_dp @@ -118,12 +118,12 @@ subroutine convect_deep_init(pref_edge) ! Purpose: declare output fields, initialize variables needed by convection !---------------------------------------- - use cam_history, only: addfld + use cam_history, only: addfld use pmgrid, only: plevp use spmd_utils, only: masterproc use zm_conv_intr, only: zm_conv_init use cam_abortutils, only: endrun - + use physics_buffer, only: physics_buffer_desc, pbuf_get_index implicit none @@ -169,14 +169,14 @@ end subroutine convect_deep_init subroutine convect_deep_tend( & mcon ,cme , & - pflx ,zdu , & + zdu , & rliq ,rice , & ztodt , & state ,ptend ,landfrac ,pbuf) use physics_types, only: physics_state, physics_ptend, physics_tend, physics_ptend_init - + use cam_history, only: outfld use constituents, only: pcnst use zm_conv_intr, only: zm_conv_tend @@ -187,15 +187,14 @@ subroutine convect_deep_tend( & ! Arguments type(physics_state), intent(in ) :: state ! Physics state variables type(physics_ptend), intent(out) :: ptend ! individual parameterization tendencies - + type(physics_buffer_desc), pointer :: pbuf(:) real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) real(r8), intent(in) :: landfrac(pcols) ! Land fraction - + real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c - real(r8), intent(out) :: pflx(pcols,pverp) ! scattered precip flux at each level real(r8), intent(out) :: cme(pcols,pver) ! cmf condensation - evaporation real(r8), intent(out) :: zdu(pcols,pver) ! detraining mass flux @@ -203,11 +202,11 @@ subroutine convect_deep_tend( & real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldice) for energy integrals real(r8), pointer :: prec(:) ! total precipitation - real(r8), pointer :: snow(:) ! snow from ZM convection + real(r8), pointer :: snow(:) ! snow from ZM convection real(r8), pointer, dimension(:) :: jctop real(r8), pointer, dimension(:) :: jcbot - real(r8), pointer, dimension(:,:,:) :: cld + real(r8), pointer, dimension(:,:,:) :: cld real(r8), pointer, dimension(:,:) :: ql ! wg grid slice of cloud liquid water. real(r8), pointer, dimension(:,:) :: rprd ! rain production rate real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble @@ -230,9 +229,8 @@ subroutine convect_deep_tend( & select case ( deep_scheme ) case('off', 'UNICON', 'CLUBB_SGS') ! in UNICON case the run method is called from convect_shallow_tend - zero = 0 + zero = 0 mcon = 0 - pflx = 0 cme = 0 zdu = 0 rliq = 0 @@ -244,7 +242,7 @@ subroutine convect_deep_tend( & ! Associate pointers with physics buffer fields ! - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1/), kount=(/pcols,pver/) ) + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1/), kount=(/pcols,pver/) ) call pbuf_get_field(pbuf, rprddp_idx, rprd ) call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) @@ -267,7 +265,7 @@ subroutine convect_deep_tend( & call pbuf_get_field(pbuf, tpert_idx, tpert) call zm_conv_tend( pblh ,mcon ,cme , & - tpert ,pflx ,zdu , & + tpert ,zdu , & rliq ,rice , & ztodt , & jctop, jcbot , & @@ -291,7 +289,7 @@ end subroutine convect_deep_tend subroutine convect_deep_tend_2( state, ptend, ztodt, pbuf) use physics_types, only: physics_state, physics_ptend, physics_ptend_init - + use physics_buffer, only: physics_buffer_desc use constituents, only: pcnst use zm_conv_intr, only: zm_conv_tend_2 @@ -299,14 +297,14 @@ subroutine convect_deep_tend_2( state, ptend, ztodt, pbuf) ! Arguments type(physics_state), intent(in ) :: state ! Physics state variables type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - + type(physics_buffer_desc), pointer :: pbuf(:) real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) if ( deep_scheme .eq. 'ZM' ) then ! Zhang-McFarlane - call zm_conv_tend_2( state, ptend, ztodt, pbuf) + call zm_conv_tend_2( state, ptend, ztodt, pbuf) else call physics_ptend_init(ptend, state%psetcols, 'convect_deep') end if diff --git a/src/physics/cam/micro_pumas_cam.F90 b/src/physics/cam/micro_pumas_cam.F90 index fe516c84ea..dae867f9dc 100644 --- a/src/physics/cam/micro_pumas_cam.F90 +++ b/src/physics/cam/micro_pumas_cam.F90 @@ -12,8 +12,11 @@ module micro_pumas_cam use physconst, only: gravit, rair, tmelt, cpair, rh2o, rhoh2o, & latvap, latice, mwh2o use phys_control, only: phys_getopts, use_hetfrz_classnuc - - +use shr_const_mod, only: pi => shr_const_pi +use time_manager, only: get_curr_date, get_curr_calday +use phys_grid, only: get_rlat_all_p, get_rlon_all_p +use orbit, only: zenith + use physics_types, only: physics_state, physics_ptend, & physics_ptend_init, physics_state_copy, & physics_update, physics_state_dealloc, & @@ -197,6 +200,8 @@ module micro_pumas_cam ast_idx = -1, & cld_idx = -1, & concld_idx = -1, & + prec_dp_idx = -1, & + prec_sh_idx = -1, & qsatfac_idx = -1 ! Pbuf fields needed for subcol_SILHS @@ -1019,6 +1024,10 @@ subroutine micro_pumas_cam_init(pbuf2d) end if + call addfld ('RBFRAC', horiz_only, 'A', 'Fraction', 'Fraction of sky covered by a potential rainbow' ) + call addfld ('RBFREQ', horiz_only, 'A', 'Frequency', 'Potential rainbow frequency' ) + call addfld( 'rbSZA', horiz_only, 'I', 'degrees', 'solar zenith angle' ) + ! History variables for CAM5 microphysics call addfld ('MPDT', (/ 'lev' /), 'A', 'W/kg', 'Heating tendency - Morrison microphysics' ) call addfld ('MPDQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Q tendency - Morrison microphysics' ) @@ -1274,6 +1283,8 @@ subroutine micro_pumas_cam_init(pbuf2d) ast_idx = pbuf_get_index('AST') cld_idx = pbuf_get_index('CLD') concld_idx = pbuf_get_index('CONCLD') + prec_dp_idx = pbuf_get_index('PREC_DP') + prec_sh_idx = pbuf_get_index('PREC_SH') naai_idx = pbuf_get_index('NAAI') naai_hom_idx = pbuf_get_index('NAAI_HOM') @@ -1603,7 +1614,10 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) 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 :: prec_dp(:) ! Deep Convective precip + real(r8), pointer :: prec_sh(:) ! Shallow Convective precip + + 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 @@ -1834,6 +1848,34 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) real(r8), parameter :: mucon = 5.3_r8 ! Convective size distribution shape parameter real(r8), parameter :: deicon = 50._r8 ! Convective ice effective diameter (meters) + ! Rainbows: solar zenith angle (SZA) + real(r8) :: zen_angle(state%psetcols) ! Daytime solar zenith angles (radians) + real(r8) :: rlats(state%psetcols), rlons(state%psetcols) ! chunk latitudes and longitudes (radains) + real(r8) :: sza(state%psetcols) ! solar zenith angles (degrees) + real(r8), parameter :: rad2deg = 180._r8/pi ! radians to degrees conversion factor + real(r8) :: calday !current calendar day + + real(r8) :: precc(state%psetcols) ! convective precip rate + +! Rainbow frequency and fraction for output + + real(r8) :: rbfreq(state%psetcols) + real(r8) :: rbfrac(state%psetcols) + +!Rainbows: parameters + + real(r8), parameter :: rb_rmin =1.e-6_r8 ! Strat Rain threshold (mixing ratio) + real(r8), parameter :: rb_rcmin = 5._r8/(86400._r8*1000._r8) ! Conv Rain Threshold (mm/d--> m/s) + real(r8), parameter :: rb_pmin =85000._r8 ! Minimum pressure for surface layer + real(r8), parameter :: deg2rad = pi/180._r8 ! Conversion factor + integer :: top_idx !Index for top level below rb_pmin + real(r8) :: convmx + real(r8) :: cldmx + real(r8) :: frlow + real(r8) :: cldtot + real(r8) :: rmax + logical :: rval + !------------------------------------------------------------------------------- lchnk = state%lchnk @@ -1871,6 +1913,29 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) 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) + ! Get convective precip + if (prec_dp_idx > 0) then + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp, col_type=col_type, copy_if_needed=use_subcol_microp) + else + nullify(prec_dp) + end if + if (prec_sh_idx > 0) then + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh, col_type=col_type, copy_if_needed=use_subcol_microp) + else + nullify(prec_sh) + end if + +! Merge Precipitation rates (multi-process) + if (associated(prec_dp) .and. associated(prec_sh)) then + precc(:ncol) = prec_dp(:ncol) + prec_sh(:ncol) + else if (associated(prec_dp)) then + precc(:ncol) = prec_dp(:ncol) + else if (associated(prec_sh)) then + precc(:ncol) = prec_sh(:ncol) + else + precc(:ncol) = 0._r8 + end if + if (.not. do_cldice) then ! If we are NOT prognosing ice and snow tendencies, then get them from the Pbuf call pbuf_get_field(pbuf, tnd_qsnow_idx, tnd_qsnow, col_type=col_type, copy_if_needed=use_subcol_microp) @@ -2043,6 +2108,26 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) call pbuf_get_field(pbuf, evpsnow_st_idx, evpsnow_st_grid) call pbuf_get_field(pbuf, am_evp_st_idx, am_evp_st_grid) + !----------------------------------------------------------------------- + ! ... Calculate cosine of zenith angle + ! then cast back to angle (radians) + !----------------------------------------------------------------------- + zen_angle(:) = 0.0_r8 + rlats(:) = 0.0_r8 + rlons(:) = 0.0_r8 + calday = get_curr_calday() + call get_rlat_all_p( lchnk, ncol, rlats ) + call get_rlon_all_p( lchnk, ncol, rlons ) + call zenith( calday, rlats, rlons, zen_angle, ncol ) + where (zen_angle(:) <= 1.0_r8 .and. zen_angle(:) >= -1.0_r8) + zen_angle(:) = acos( zen_angle(:) ) + elsewhere + zen_angle(:) = 0.0_r8 + end where + + sza(:) = zen_angle(:) * rad2deg + call outfld( 'rbSZA', sza, ncol, lchnk ) + !------------------------------------------------------------------------------------- ! Microphysics assumes 'liquid stratus frac = ice stratus frac ! = max( liquid stratus frac, ice stratus frac )'. @@ -2134,6 +2219,10 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) state_loc_numgraup(:ncol,:) = 0._r8 end if + ! Zero out diagnostic rainbow arrays + rbfreq = 0._r8 + rbfrac = 0._r8 + ! Zero out values above top_lev before passing into _tend for some pbuf variables that are inputs naai(:ncol,:top_lev-1) = 0._r8 npccn(:ncol,:top_lev-1) = 0._r8 @@ -3123,6 +3212,63 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) racau_grid = min(racau_grid, 1.e10_r8) +!----------------------------------------------------------------------- +! Diagnostic Rainbow Calculation. Seriously. +!----------------------------------------------------------------------- + +! Rainbows currently calculated on the grid, not subcolumn specific + do i = 1, ngrdcol + + top_idx = pver + convmx = 0._r8 + frlow = 0._r8 + cldmx = 0._r8 + cldtot = maxval(ast(i,top_lev:)) + +! Find levels in surface layer + do k = top_lev, pver + if (state%pmid(i,k) > rb_pmin) then + top_idx = min(k,top_idx) + end if + end do + +!For all fractional precip calculated below, use maximum in surface layer. +!For convective precip, base on convective cloud area + convmx = maxval(concld(i,top_idx:)) +!For stratiform precip, base on precip fraction + cldmx= maxval(freqr(i,top_idx:)) +! Combine and use maximum of strat or conv fraction + frlow= max(cldmx,convmx) + +!max precip + rmax=maxval(qrout_grid(i,top_idx:)) + +! Stratiform precip mixing ratio OR some convective precip +! (rval = true if any sig precip) + + rval = ((precc(i) > rb_rcmin) .or. (rmax > rb_rmin)) + +!Now can find conditions for a rainbow: +! Maximum cloud cover (CLDTOT) < 0.5 +! 48 < SZA < 90 +! freqr (below rb_pmin) > 0.25 +! Some rain (liquid > 1.e-6 kg/kg, convective precip > 1.e-7 m/s + + if ((cldtot < 0.5_r8) .and. (sza(i) > 48._r8) .and. (sza(i) < 90._r8) .and. rval) then + +!Rainbow 'probability' (area) derived from solid angle theory +!as the fraction of the hemisphere for a spherical cap with angle phi=sza-48. +! This is only valid between 48 < sza < 90 (controlled for above). + + rbfrac(i) = max(0._r8,(1._r8-COS((sza(i)-48._r8)*deg2rad))/2._r8) * frlow + rbfreq(i) = 1.0_r8 + end if + + end do ! end column loop for rainbows + + call outfld('RBFRAC', rbfrac, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('RBFREQ', rbfreq, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + ! --------------------- ! ! History Output Fields ! ! --------------------- ! diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index a439f84423..cb7322254f 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -2126,7 +2126,6 @@ subroutine tphysbc (ztodt, state, & real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev real(r8) rtdt ! 1./ztodt integer lchnk ! chunk identifier @@ -2327,7 +2326,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "dadadj_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call dadadj_tend(ztodt, state, ptend) @@ -2340,7 +2339,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "dadadj_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call t_stopf('dry_adjustment') @@ -2354,12 +2353,12 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "convect_deep_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call convect_deep_tend( & cmfmc, cmfcme, & - pflx, zdu, & + zdu, & rliq, rice, & ztodt, & state, ptend, cam_in%landfrac, pbuf) @@ -2379,7 +2378,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "convect_deep_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call t_stopf('convect_deep_tend') @@ -2420,7 +2419,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "convect_shallow_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call convect_shallow_tend (ztodt , cmfmc, & @@ -2442,7 +2441,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "convect_shallow_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if flx_cnd(:ncol) = prec_sh(:ncol) + rliq2(:ncol) @@ -2540,7 +2539,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "macrop_driver_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call macrop_driver_tend( & @@ -2571,7 +2570,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "macrop_driver_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, & @@ -2587,7 +2586,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "clubb_tend_cam") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& @@ -2617,7 +2616,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "clubb_tend_cam") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code @@ -2654,7 +2653,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "microp_section") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call t_startf('microp_aero_run') @@ -2667,7 +2666,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "microp_driver_tend_subcol") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) @@ -2719,7 +2718,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & @@ -2751,7 +2750,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "microp_section") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & @@ -2806,7 +2805,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "aero_model_wetdep") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) @@ -2818,7 +2817,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "aero_model_wetdep") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if if (carma_do_wetdep) then @@ -2873,7 +2872,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "radiation_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call radiation_tend( & @@ -2892,7 +2891,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "radiation_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + flx_heat, cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) diff --git a/src/physics/cam/subcol_SILHS.F90 b/src/physics/cam/subcol_SILHS.F90 index e7fe38637a..e941889e50 100644 --- a/src/physics/cam/subcol_SILHS.F90 +++ b/src/physics/cam/subcol_SILHS.F90 @@ -20,6 +20,7 @@ module subcol_SILHS use clubb_intr, only: & clubb_config_flags, & clubb_params, & + stats_metadata, & stats_zt, stats_zm, stats_sfc, & pdf_params_chnk @@ -473,7 +474,7 @@ subroutine subcol_init_SILHS(pbuf2d) corr_file_path_below = trim( subcol_SILHS_corr_file_path )//trim( subcol_SILHS_corr_file_name )//below_file_ext call setup_corr_varnce_array_api( corr_file_path_cloud, corr_file_path_below, & - getnewunit(iunit), & + newunit(iunit), & clubb_config_flags%l_fix_w_chi_eta_correlations ) !------------------------------- @@ -603,8 +604,6 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) setup_pdf_parameters_api, & - l_stats_samp, & - hydromet_pdf_parameter, & zm2zt_api, setup_grid_heights_api, & @@ -664,7 +663,6 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) real(r8), parameter :: qsmall = 1.0e-18_r8 ! Microphysics cut-off for cloud integer :: i, j, k, ngrdcol, ncol, lchnk, stncol - integer :: begin_height, end_height ! Output from setup_grid call real(r8) :: sfc_elevation(state%ngrdcol) ! Surface elevation real(r8), dimension(state%ngrdcol,pverp-top_lev+1) :: zt_g, zi_g ! Thermo & Momentum grids for clubb @@ -957,7 +955,7 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) call setup_grid_api( pverp+1-top_lev, ncol, sfc_elevation(1:ncol), l_implemented, & ! intent(in) grid_type, zi_g(1:ncol,2), zi_g(1:ncol,1), zi_g(1:ncol,pverp+1-top_lev), & ! intent(in) zi_g(1:ncol,:), zt_g(1:ncol,:), & ! intent(in) - gr, begin_height, end_height ) + gr ) ! Calculate the distance between grid levels on the host model grid, ! using host model grid indices. @@ -1135,7 +1133,7 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) Nc_in_cloud, cld_frac_in, khzm, & ! In ice_supersat_frac_in, hydromet, wphydrometp, & ! In corr_array_n_cloud, corr_array_n_below, & ! In - pdf_params_chnk(lchnk), l_stats_samp, & ! In + pdf_params_chnk(lchnk), & ! In clubb_params, & ! In clubb_config_flags%iiPDF_type, & ! In clubb_config_flags%l_use_precip_frac, & ! In @@ -1144,6 +1142,7 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) clubb_config_flags%l_calc_w_corr, & ! In clubb_config_flags%l_const_Nc_in_cloud, & ! In clubb_config_flags%l_fix_w_chi_eta_correlations, & ! In + stats_metadata, & ! In stats_zt, stats_zm, stats_sfc, & ! In hydrometp2, & ! Inout mu_x_1, mu_x_2, & ! Out @@ -1231,7 +1230,8 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) clubb_config_flags%l_tke_aniso, & ! In clubb_config_flags%l_standard_term_ta, & ! In vert_decorr_coef, & ! In - stats_lh_zt, stats_lh_sfc, & ! intent(inout) + stats_metadata, & ! In + stats_lh_zt, stats_lh_sfc, & ! InOut X_nl_all_levs, X_mixt_comp_all_levs, & ! Out lh_sample_point_weights) ! Out @@ -4125,12 +4125,12 @@ end subroutine subcol_SILHS_hydromet_conc_tend_lim ! small function to get an unused stream identifier to send to setup_corr_varnce_array_api ! or any other silhs/clubb functions that require a unit number argument ! This comes directly from the Fortran wiki - integer function getnewunit(unit) + integer function newunit(unit) integer, intent(out), optional :: unit integer, parameter :: LUN_MIN=10, LUN_MAX=1000 logical :: opened - integer :: lun, newunit + integer :: lun newunit=-1 do lun=LUN_MIN,LUN_MAX @@ -4141,6 +4141,6 @@ integer function getnewunit(unit) end if end do if (present(unit)) unit=newunit - end function getnewunit + end function newunit end module subcol_SILHS diff --git a/src/physics/cam/vertical_diffusion.F90 b/src/physics/cam/vertical_diffusion.F90 index 224d87e3a0..12c50b4234 100644 --- a/src/physics/cam/vertical_diffusion.F90 +++ b/src/physics/cam/vertical_diffusion.F90 @@ -141,6 +141,8 @@ module vertical_diffusion logical :: waccmx_mode = .false. logical :: do_hb_above_clubb = .false. +real(r8),allocatable :: kvm_sponge(:) + contains ! =============================================================================== ! @@ -280,6 +282,7 @@ subroutine vertical_diffusion_init(pbuf2d) use beljaars_drag_cam, only : beljaars_drag_init use upper_bc, only : ubc_init use phys_control, only : waccmx_is, fv_am_correction + use ref_pres, only : ptop_ref type(physics_buffer_desc), pointer :: pbuf2d(:,:) character(128) :: errstring ! Error status for init_vdiff @@ -289,7 +292,7 @@ subroutine vertical_diffusion_init(pbuf2d) real(r8), parameter :: ntop_eddy_pres = 1.e-7_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) - integer :: im, l, m, nmodes, nspec + integer :: im, l, m, nmodes, nspec, ierr logical :: history_amwg ! output the variables used by the AMWG diag package logical :: history_eddy ! output the eddy variables @@ -297,10 +300,48 @@ subroutine vertical_diffusion_init(pbuf2d) integer :: history_budget_histfile_num ! output history file number for budget fields logical :: history_waccm ! output variables of interest for WACCM runs - ! ----------------------------------------------------------------- ! + ! + ! add sponge layer vertical diffusion + ! + if (ptop_ref>1e-1_r8.and.ptop_ref<100.0_r8) then + ! + ! CAM7 FMT (but not CAM6 top (~225 Pa) or CAM7 low top or lower) + ! + allocate(kvm_sponge(4), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'vertical_diffusion_init: kvm_sponge allocation error = ',ierr + call endrun('vertical_diffusion_init: failed to allocate kvm_sponge array') + end if + kvm_sponge(1) = 2E6_r8 + kvm_sponge(2) = 2E6_r8 + kvm_sponge(3) = 0.5E6_r8 + kvm_sponge(4) = 0.1E6_r8 + else if (ptop_ref>1e-4_r8) then + ! + ! WACCM and WACCM-x + ! + allocate(kvm_sponge(6), stat=ierr) + if( ierr /= 0 ) then + write(iulog,*) 'vertical_diffusion_init: kvm_sponge allocation error = ',ierr + call endrun('vertical_diffusion_init: failed to allocate kvm_sponge array') + end if + kvm_sponge(1) = 2E6_r8 + kvm_sponge(2) = 2E6_r8 + kvm_sponge(3) = 1.5E6_r8 + kvm_sponge(4) = 1.0E6_r8 + kvm_sponge(5) = 0.5E6_r8 + kvm_sponge(6) = 0.1E6_r8 + end if if (masterproc) then write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' + if (allocated(kvm_sponge)) then + write(iulog,*)'Artificial sponge layer vertical diffusion added:' + do k=1,size(kvm_sponge(:),1) + write(iulog,'(a44,i2,a17,e7.2,a8)') 'vertical diffusion coefficient at interface',k,' is increased by ', & + kvm_sponge(k),' m2 s-2' + end do + end if !allocated end if ! Check to see if WACCM-X is on (currently we don't care whether the @@ -633,7 +674,6 @@ subroutine vertical_diffusion_init(pbuf2d) call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) end if end if - end subroutine vertical_diffusion_init ! =============================================================================== ! @@ -695,6 +735,7 @@ subroutine vertical_diffusion_tend( & use upper_bc, only : ubc_get_flxs use coords_1d, only : Coords1D use phys_control, only : cam_physpkg_is + use ref_pres, only : ptop_ref ! --------------- ! ! Input Arguments ! @@ -1067,6 +1108,14 @@ subroutine vertical_diffusion_tend( & call outfld( 'ustar', ustar(:), pcols, lchnk ) call outfld( 'obklen', obklen(:), pcols, lchnk ) + ! + ! add sponge layer vertical diffusion + ! + if (allocated(kvm_sponge)) then + do k=1,size(kvm_sponge(:),1) + kvm(:ncol,1) = kvm(:ncol,1)+kvm_sponge(k) + end do + end if ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff ! on the next timestep. It is not updated by the compute_vdiff call below. diff --git a/src/physics/cam/zm_conv_intr.F90 b/src/physics/cam/zm_conv_intr.F90 index d559ce4be4..febf576443 100644 --- a/src/physics/cam/zm_conv_intr.F90 +++ b/src/physics/cam/zm_conv_intr.F90 @@ -357,7 +357,8 @@ subroutine zm_conv_init(pref_edge) limcnv,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & zmconv_momcu, zmconv_momcd, zmconv_num_cin, zmconv_org, & no_deep_pbl, zmconv_tiedke_add, & - zmconv_capelmt, zmconv_dmpdz,zmconv_parcel_pbl, zmconv_tau, errmsg, errflg) + zmconv_capelmt, zmconv_dmpdz,zmconv_parcel_pbl, zmconv_tau, & + masterproc, iulog, errmsg, errflg) cld_idx = pbuf_get_index('CLD') fracis_idx = pbuf_get_index('FRACIS') @@ -367,7 +368,7 @@ end subroutine zm_conv_init !subroutine zm_conv_tend(state, ptend, tdt) subroutine zm_conv_tend(pblh ,mcon ,cme , & - tpert ,pflx ,zdu , & + tpert ,zdu , & rliq ,rice ,ztodt , & jctop ,jcbot , & state ,ptend_all ,landfrac, pbuf) @@ -399,7 +400,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c - real(r8), intent(out) :: pflx(pcols,pverp) ! scattered precip flux at each level real(r8), intent(out) :: cme(pcols,pver) ! cmf condensation - evaporation real(r8), intent(out) :: zdu(pcols,pver) ! detraining mass flux @@ -474,12 +474,14 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & real(r8) :: md_out(pcols,pver) ! used in momentum transport calculation - real(r8) :: winds(pcols, pver, 2) - real(r8) :: wind_tends(pcols, pver, 2) - real(r8) :: pguall(pcols, pver, 2) - real(r8) :: pgdall(pcols, pver, 2) - real(r8) :: icwu(pcols,pver, 2) - real(r8) :: icwd(pcols,pver, 2) + real(r8) :: pguallu(pcols, pver) + real(r8) :: pguallv(pcols, pver) + real(r8) :: pgdallu(pcols, pver) + real(r8) :: pgdallv(pcols, pver) + real(r8) :: icwuu(pcols,pver) + real(r8) :: icwuv(pcols,pver) + real(r8) :: icwdu(pcols,pver) + real(r8) :: icwdv(pcols,pver) real(r8) :: seten(pcols, pver) logical :: l_windt(2) real(r8) :: tfinal1, tfinal2 @@ -503,7 +505,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ftem = 0._r8 mu_out(:,:) = 0._r8 md_out(:,:) = 0._r8 - wind_tends(:ncol,:pver,:) = 0.0_r8 call physics_state_copy(state,state1) ! copy state to local state1. @@ -561,7 +562,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ptend_loc%s(:,:) = 0._r8 mcon(:,:) = 0._r8 dlf(:,:) = 0._r8 - pflx(:,:) = 0._r8 cme(:,:) = 0._r8 cape(:) = 0._r8 zdu(:,:) = 0._r8 @@ -587,18 +587,19 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & !CACNOTE - Need to check errflg and report errors call zm_convr_run(ncol, pver, & pverp, gravit, latice, cpwv, cpliq, rh2o, & - state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), jctop(:ncol), jcbot(:ncol), & - pblh(:ncol), state%zm(:ncol,:), state%phis, state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & + state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), & + pblh(:ncol), state%zm(:ncol,:), state%phis(:ncol), state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & ptend_loc%s(:ncol,:), state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & .5_r8*ztodt, mcon(:ncol,:), cme(:ncol,:), cape(:ncol), & - tpert(:ncol), dlf(:ncol,:), pflx(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & + tpert(:ncol), dlf(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & mu(:ncol,:), md(:ncol,:), du(:ncol,:), eu(:ncol,:), ed(:ncol,:), & dp(:ncol,:), dsubcld(:ncol), jt(:ncol), maxg(:ncol), ideep(:ncol), & ql(:ncol,:), rliq(:ncol), landfrac(:ncol), & - org_ncol(:,:), orgt_ncol(:,:), zm_org2d_ncol(:,:), & + org_ncol(:ncol,:), orgt_ncol(:ncol,:), zm_org2d_ncol(:ncol,:), & dif(:ncol,:), dnlf(:ncol,:), dnif(:ncol,:), & rice(:ncol), errmsg, errflg) + if (zmconv_org) then ptend_loc%q(:,:,ixorg)=orgt_ncol(:ncol,:) zm_org2d(:ncol,:) = zm_org2d_ncol(:ncol,:) @@ -607,6 +608,13 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & lengath = count(ideep > 0) if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake + jctop(:) = real(pver,r8) + jcbot(:) = 1._r8 + do i = 1,lengath + jctop(ideep(i)) = real(jt(i), r8) + jcbot(ideep(i)) = real(maxg(i), r8) + end do + call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output ! ! Output fractional occurance of ZM convection @@ -746,33 +754,34 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_momtran_run', ls=.true., lu=.true., lv=.true.) - winds(:ncol,:pver,1) = state1%u(:ncol,:pver) - winds(:ncol,:pver,2) = state1%v(:ncol,:pver) - l_windt(1) = .true. l_windt(2) = .true. +!REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + ptend_loc%s(:,:) = 0._r8 + ptend_loc%u(:,:) = 0._r8 + ptend_loc%v(:,:) = 0._r8 +!REMOVECAM_END call t_startf ('zm_conv_momtran_run') -!REMOVECAM - no longer need this when CAM is retired and pcols no longer exists - wind_tends(:,:,:) = 0._r8 -!REMOVECAM_END - call zm_conv_momtran_run (ncol, pver, pverp, & - l_windt,winds(:ncol,:,:), 2, mu(:ncol,:), md(:ncol,:), & + l_windt,state1%u(:ncol,:), state1%v(:ncol,:), 2, mu(:ncol,:), md(:ncol,:), & zmconv_momcu, zmconv_momcd, & du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, wind_tends(:ncol,:,:), pguall(:ncol,:,:), pgdall(:ncol,:,:), & - icwu(:ncol,:,:), icwd(:ncol,:,:), ztodt, seten(:ncol,:) ) + nstep, ptend_loc%u(:ncol,:), ptend_loc%v(:ncol,:),& + pguallu(:ncol,:), pguallv(:ncol,:), pgdallu(:ncol,:), pgdallv(:ncol,:), & + icwuu(:ncol,:), icwuv(:ncol,:), icwdu(:ncol,:), icwdv(:ncol,:), ztodt, seten(:ncol,:) ) call t_stopf ('zm_conv_momtran_run') - ptend_loc%u(:ncol,:pver) = wind_tends(:ncol,:pver,1) - ptend_loc%v(:ncol,:pver) = wind_tends(:ncol,:pver,2) ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) call physics_ptend_sum(ptend_loc,ptend_all, ncol) + ! Output ptend variables before they are set to zero with physics_update + call outfld('ZMMTU', ptend_loc%u, pcols, lchnk) + call outfld('ZMMTV', ptend_loc%v, pcols, lchnk) + ! update physics state type state1 with ptend_loc call physics_update(state1, ptend_loc, ztodt) @@ -782,20 +791,18 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call outfld('ZM_ORG2D', zm_org2d, pcols, lchnk) endif call outfld('ZMMTT', ftem , pcols, lchnk) - call outfld('ZMMTU', wind_tends(1,1,1), pcols, lchnk) - call outfld('ZMMTV', wind_tends(1,1,2), pcols, lchnk) ! Output apparent force from pressure gradient - call outfld('ZMUPGU', pguall(1,1,1), pcols, lchnk) - call outfld('ZMUPGD', pgdall(1,1,1), pcols, lchnk) - call outfld('ZMVPGU', pguall(1,1,2), pcols, lchnk) - call outfld('ZMVPGD', pgdall(1,1,2), pcols, lchnk) + call outfld('ZMUPGU', pguallu, pcols, lchnk) + call outfld('ZMUPGD', pgdallu, pcols, lchnk) + call outfld('ZMVPGU', pguallv, pcols, lchnk) + call outfld('ZMVPGD', pgdallv, pcols, lchnk) ! Output in-cloud winds - call outfld('ZMICUU', icwu(1,1,1), pcols, lchnk) - call outfld('ZMICUD', icwd(1,1,1), pcols, lchnk) - call outfld('ZMICVU', icwu(1,1,2), pcols, lchnk) - call outfld('ZMICVD', icwd(1,1,2), pcols, lchnk) + call outfld('ZMICUU', icwuu, pcols, lchnk) + call outfld('ZMICUD', icwdu, pcols, lchnk) + call outfld('ZMICVU', icwuv, pcols, lchnk) + call outfld('ZMICVD', icwdv, pcols, lchnk) end if diff --git a/src/physics/cam_dev/cam_snapshot.F90 b/src/physics/cam_dev/cam_snapshot.F90 index 898bcbf151..360516bd49 100644 --- a/src/physics/cam_dev/cam_snapshot.F90 +++ b/src/physics/cam_dev/cam_snapshot.F90 @@ -21,7 +21,7 @@ module cam_snapshot use cam_snapshot_common, only: snapshot_type, cam_snapshot_deactivate, cam_snapshot_all_outfld, cam_snapshot_ptend_outfld use cam_snapshot_common, only: snapshot_type, cam_state_snapshot_init, cam_cnst_snapshot_init, cam_tend_snapshot_init use cam_snapshot_common, only: cam_ptend_snapshot_init, cam_in_snapshot_init, cam_out_snapshot_init -use cam_snapshot_common, only: cam_pbuf_snapshot_init, snapshot_addfld +use cam_snapshot_common, only: cam_pbuf_snapshot_init, snapshot_addfld implicit none @@ -58,7 +58,7 @@ subroutine cam_snapshot_init(cam_in_arr, cam_out_arr, pbuf, index) call phys_getopts(cam_snapshot_before_num_out = cam_snapshot_before_num, & cam_snapshot_after_num_out = cam_snapshot_after_num) - + ! Return if not turned on if (cam_snapshot_before_num <= 0 .and. cam_snapshot_after_num <= 0) return ! No snapshot files are being requested @@ -76,7 +76,7 @@ subroutine cam_snapshot_init(cam_in_arr, cam_out_arr, pbuf, index) end subroutine cam_snapshot_init subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_out, pbuf, cmfmc, cmfcme, & - pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) use time_manager, only: is_first_step, is_first_restart_step @@ -94,7 +94,6 @@ subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_ou type(physics_buffer_desc), pointer, intent(in) :: pbuf(:) real(r8), intent(in) :: cmfmc(:,:) ! convective mass flux real(r8), intent(in) :: cmfcme(:,:) ! cmf condensation - evaporation - real(r8), intent(in) :: pflx(:,:) ! convective rain flux throughout bottom of level real(r8), intent(in) :: zdu(:,:) ! detraining mass flux from deep convection real(r8), intent(in) :: rliq(:) ! vertical integral of liquid not yet in q(ixcldliq) real(r8), intent(in) :: rice(:) ! vertical integral of ice not yet in q(ixcldice) @@ -108,14 +107,13 @@ subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_ou ! Return if the first timestep as not all fields may be filled in and this will cause a core dump if (is_first_step().or. is_first_restart_step()) return - ! Return if not turned on + ! Return if not turned on if (cam_snapshot_before_num <= 0 .and. cam_snapshot_after_num <= 0) return ! No snapshot files are being requested lchnk = state%lchnk call outfld('tphysbc_cmfmc', cmfmc, pcols, lchnk) call outfld('tphysbc_cmfcme', cmfcme, pcols, lchnk) - call outfld('tphysbc_pflx', pflx, pcols, lchnk) call outfld('tphysbc_zdu', zdu, pcols, lchnk) call outfld('tphysbc_rliq', rliq, pcols, lchnk) call outfld('tphysbc_rice', rice, pcols, lchnk) @@ -160,7 +158,7 @@ subroutine cam_snapshot_all_outfld_tphysac(file_num, state, tend, cam_in, cam_ou ! Return if the first timestep as not all fields may be filled in and this will cause a core dump if (is_first_step()) return - ! Return if not turned on + ! Return if not turned on if (cam_snapshot_before_num <= 0 .and. cam_snapshot_after_num <= 0) return ! No snapshot files are being requested lchnk = state%lchnk @@ -187,7 +185,7 @@ subroutine cam_tphysbc_snapshot_init(cam_snapshot_before_num, cam_snapshot_after !-------------------------------------------------------- integer,intent(in) :: cam_snapshot_before_num, cam_snapshot_after_num - + ntphysbc_var = 0 !-------------------------------------------------------- @@ -204,9 +202,6 @@ subroutine cam_tphysbc_snapshot_init(cam_snapshot_before_num, cam_snapshot_after call snapshot_addfld( ntphysbc_var, tphysbc_snapshot, cam_snapshot_before_num, cam_snapshot_after_num, & 'cmfcme', 'tphysbc_cmfcme', 'unset', 'lev') - call snapshot_addfld( ntphysbc_var, tphysbc_snapshot, cam_snapshot_before_num, cam_snapshot_after_num, & - 'pflx', 'tphysbc_pflx', 'unset', 'lev') - call snapshot_addfld( ntphysbc_var, tphysbc_snapshot, cam_snapshot_before_num, cam_snapshot_after_num, & 'zdu', 'tphysbc_zdu', 'unset', 'lev') @@ -239,7 +234,7 @@ subroutine cam_tphysac_snapshot_init(cam_snapshot_before_num, cam_snapshot_after !-------------------------------------------------------- integer,intent(in) :: cam_snapshot_before_num, cam_snapshot_after_num - + ntphysac_var = 0 !-------------------------------------------------------- diff --git a/src/physics/cam_dev/micro_pumas_cam.F90 b/src/physics/cam_dev/micro_pumas_cam.F90 index 7c38333e95..f38eda2ade 100644 --- a/src/physics/cam_dev/micro_pumas_cam.F90 +++ b/src/physics/cam_dev/micro_pumas_cam.F90 @@ -14,6 +14,10 @@ module micro_pumas_cam latvap, latice, mwh2o use phys_control, only: phys_getopts, use_hetfrz_classnuc +use shr_const_mod, only: pi => shr_const_pi +use time_manager, only: get_curr_date, get_curr_calday +use phys_grid, only: get_rlat_all_p, get_rlon_all_p +use orbit, only: zenith use physics_types, only: physics_state, physics_ptend, & physics_ptend_init, physics_state_copy, & @@ -206,6 +210,8 @@ module micro_pumas_cam ast_idx = -1, & cld_idx = -1, & concld_idx = -1, & + prec_dp_idx = -1, & + prec_sh_idx = -1, & qsatfac_idx = -1 ! Pbuf fields needed for subcol_SILHS @@ -1085,6 +1091,10 @@ subroutine micro_pumas_cam_init(pbuf2d) end if + call addfld ('RBFRAC', horiz_only, 'A', 'Fraction', 'Fraction of sky covered by a potential rainbow' ) + call addfld ('RBFREQ', horiz_only, 'A', 'Frequency', 'Potential rainbow frequency' ) + call addfld( 'rbSZA', horiz_only, 'I', 'degrees', 'solar zenith angle' ) + ! History variables for CAM5 microphysics call addfld ('MPDT', (/ 'lev' /), 'A', 'W/kg', 'Heating tendency - Morrison microphysics' ) call addfld ('MPDQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Q tendency - Morrison microphysics' ) @@ -1366,6 +1376,8 @@ subroutine micro_pumas_cam_init(pbuf2d) ast_idx = pbuf_get_index('AST') cld_idx = pbuf_get_index('CLD') concld_idx = pbuf_get_index('CONCLD') + prec_dp_idx = pbuf_get_index('PREC_DP') + prec_sh_idx = pbuf_get_index('PREC_SH') naai_idx = pbuf_get_index('NAAI') naai_hom_idx = pbuf_get_index('NAAI_HOM') @@ -1653,6 +1665,9 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) real(r8), pointer :: cld(:,:) ! Total cloud fraction real(r8), pointer :: concld(:,:) ! Convective cloud fraction + real(r8), pointer :: prec_dp(:) ! Deep Convective precip + real(r8), pointer :: prec_sh(:) ! Shallow Convective precip + 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 @@ -1884,6 +1899,34 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) real(r8), parameter :: mucon = 5.3_r8 ! Convective size distribution shape parameter real(r8), parameter :: deicon = 50._r8 ! Convective ice effective diameter (meters) +! Rainbows: SZA + real(r8) :: zen_angle(state%psetcols) ! Daytime solar zenith angles (radians) + real(r8) :: rlats(state%psetcols), rlons(state%psetcols) ! chunk latitudes and longitudes (radians) + real(r8) :: sza(state%psetcols) ! solar zenith angles (degrees) + real(r8), parameter :: rad2deg = 180._r8/pi ! radians to degrees conversion factor + real(r8) :: calday !current calendar day + + real(r8) :: precc(state%psetcols) ! convective precip rate + +! Rainbow frequency and fraction for output + + real(r8) :: rbfreq(state%psetcols) + real(r8) :: rbfrac(state%psetcols) + +!Rainbows: parameters + + real(r8), parameter :: rb_rmin =1.e-6_r8 ! Strat Rain threshold (mixing ratio) + real(r8), parameter :: rb_rcmin = 5._r8/(86400._r8*1000._r8) ! Conv Rain Threshold (mm/d--> m/s) + real(r8), parameter :: rb_pmin =85000._r8 ! Minimum pressure for surface layer + real(r8), parameter :: deg2rad = pi/180._r8 ! Conversion factor + integer :: top_idx !Index for top level below rb_pmin + real(r8) :: convmx + real(r8) :: cldmx + real(r8) :: frlow + real(r8) :: cldtot + real(r8) :: rmax + logical :: rval + !------------------------------------------------------------------------------- lchnk = state%lchnk @@ -1931,6 +1974,29 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) 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) + ! Get convective precip for rainbows + if (prec_dp_idx > 0) then + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp, col_type=col_type, copy_if_needed=use_subcol_microp) + else + nullify(prec_dp) + end if + if (prec_sh_idx > 0) then + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh, col_type=col_type, copy_if_needed=use_subcol_microp) + else + nullify(prec_sh) + end if + +! Merge Precipitation rates (multi-process) + if (associated(prec_dp) .and. associated(prec_sh)) then + precc(:ncol) = prec_dp(:ncol) + prec_sh(:ncol) + else if (associated(prec_dp)) then + precc(:ncol) = prec_dp(:ncol) + else if (associated(prec_sh)) then + precc(:ncol) = prec_sh(:ncol) + else + precc(:ncol) = 0._r8 + end if + if (.not. do_cldice) then ! If we are NOT prognosing ice and snow tendencies, then get them from the Pbuf call pbuf_get_field(pbuf, tnd_qsnow_idx, tnd_qsnow, col_type=col_type, copy_if_needed=use_subcol_microp) @@ -2109,6 +2175,27 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) call pbuf_get_field(pbuf, evpsnow_st_idx, evpsnow_st_grid) call pbuf_get_field(pbuf, am_evp_st_idx, am_evp_st_grid) + !----------------------------------------------------------------------- + ! ... Calculate cosine of zenith angle + ! then cast back to angle (radians) + !----------------------------------------------------------------------- + + zen_angle(:) = 0.0_r8 + rlats(:) = 0.0_r8 + rlons(:) = 0.0_r8 + calday = get_curr_calday() + call get_rlat_all_p( lchnk, ncol, rlats ) + call get_rlon_all_p( lchnk, ncol, rlons ) + call zenith( calday, rlats, rlons, zen_angle, ncol ) + where (zen_angle(:) <= 1.0_r8 .and. zen_angle(:) >= -1.0_r8) + zen_angle(:) = acos( zen_angle(:) ) + elsewhere + zen_angle(:) = 0.0_r8 + end where + + sza(:) = zen_angle(:) * rad2deg + call outfld( 'rbSZA', sza, ncol, lchnk ) + !------------------------------------------------------------------------------------- ! Microphysics assumes 'liquid stratus frac = ice stratus frac ! = max( liquid stratus frac, ice stratus frac )'. @@ -2198,6 +2285,10 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) state_loc_numgraup(:ncol,:) = 0._r8 end if + ! Zero out diagnostic rainbow arrays + rbfreq = 0._r8 + rbfrac = 0._r8 + ! Zero out values above top_lev before passing into _tend for some pbuf variables that are inputs naai(:ncol,:top_lev-1) = 0._r8 npccn(:ncol,:top_lev-1) = 0._r8 @@ -3090,6 +3181,63 @@ subroutine micro_pumas_cam_tend(state, ptend, dtime, pbuf) racau_grid = min(racau_grid, 1.e10_r8) +!----------------------------------------------------------------------- +! Diagnostic Rainbow Calculation. Seriously. +!----------------------------------------------------------------------- + + do i = 1, ngrdcol + + top_idx = pver + convmx = 0._r8 + frlow = 0._r8 + cldmx = 0._r8 + cldtot = maxval(ast(i,top_lev:)) + +! Find levels in surface layer + do k = top_lev, pver + if (state%pmid(i,k) > rb_pmin) then + top_idx = min(k,top_idx) + end if + end do + +!For all fractional precip calculated below, use maximum in surface layer. +!For convective precip, base on convective cloud area + convmx = maxval(concld(i,top_idx:)) +!For stratiform precip, base on precip fraction + cldmx= maxval(freqr(i,top_idx:)) +! Combine and use maximum of strat or conv fraction + frlow= max(cldmx,convmx) + +!max precip + rmax=maxval(qrout_grid(i,top_idx:)) + +! Stratiform precip mixing ratio OR some convective precip +! (rval = true if any sig precip) + + rval = ((precc(i) > rb_rcmin) .or. (rmax > rb_rmin)) + +!Now can find conditions for a rainbow: +! Maximum cloud cover (CLDTOT) < 0.5 +! 48 < SZA < 90 +! freqr (below rb_pmin) > 0.25 +! Some rain (liquid > 1.e-6 kg/kg, convective precip > 1.e-7 m/s + + if ((cldtot < 0.5_r8) .and. (sza(i) > 48._r8) .and. (sza(i) < 90._r8) .and. rval) then + +!Rainbow 'probability' (area) derived from solid angle theory +!as the fraction of the hemisphere for a spherical cap with angle phi=sza-48. +! This is only valid between 48 < sza < 90 (controlled for above). + + rbfrac(i) = max(0._r8,(1._r8-COS((sza(i)-48._r8)*deg2rad))/2._r8) * frlow + rbfreq(i) = 1.0_r8 + end if + + end do ! end column loop for rainbows + + call outfld('RBFRAC', rbfrac, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('RBFREQ', rbfreq, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + + ! --------------------- ! ! History Output Fields ! ! --------------------- ! diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam_dev/physpkg.F90 index 46805c150e..aef997716f 100644 --- a/src/physics/cam_dev/physpkg.F90 +++ b/src/physics/cam_dev/physpkg.F90 @@ -2543,7 +2543,6 @@ subroutine tphysbc (ztodt, state, & real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev real(r8) rtdt ! 1./ztodt integer lchnk ! chunk identifier @@ -2735,7 +2734,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "dadadj_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) end if call dadadj_tend(ztodt, state, ptend) @@ -2748,7 +2747,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "dadadj_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) end if call t_stopf('dry_adjustment') @@ -2762,12 +2761,12 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "convect_deep_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) end if call convect_deep_tend( & cmfmc, cmfcme, & - pflx, zdu, & + zdu, & rliq, rice, & ztodt, & state, ptend, cam_in%landfrac, pbuf) @@ -2787,7 +2786,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_after) == "convect_deep_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) end if call t_stopf('convect_deep_tend') @@ -2828,7 +2827,7 @@ subroutine tphysbc (ztodt, state, & if (trim(cam_take_snapshot_before) == "convect_diagnostics_calc") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + cmfmc, cmfcme, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) end if call convect_diagnostics_calc (ztodt , cmfmc, & dlf , dlf2 , rliq , rliq2, & diff --git a/src/physics/waccm/efield.F90 b/src/physics/waccm/efield.F90 index 3ad30a970a..90508549b2 100644 --- a/src/physics/waccm/efield.F90 +++ b/src/physics/waccm/efield.F90 @@ -81,7 +81,7 @@ module efield integer, parameter :: & nmlon1f = nmlon/4, & ! 1 fourth mlon nmlon2f = nmlon/2, & ! 2 fourths mlon - nmlon3f = 3*nmlon/4 ! 3 fourths mlon + nmlon3f = 3*nmlon/4 ! 3 fourths mlon real(r8) :: & ylatm(0:nmlat), & ! magnetic latitudes (deg) @@ -1194,7 +1194,7 @@ subroutine bnd_sinus( ihlat_bnd, itrans_width ) ! Author: A. Maute Nov 2003 am 11/20/03 !---------------------------------------------------------------------------- - use sv_decomp, only : svdcmp, svbksb + external DGESV ! LAPACK routine to solve matrix eq !---------------------------------------------------------------------------- ! ... dummy arguments @@ -1216,6 +1216,11 @@ subroutine bnd_sinus( ihlat_bnd, itrans_width ) real(r8) :: w(nmax_a,nmax_a) real(r8) :: f(-nmax_sin:nmax_sin,0:nmlon) + real(r8) :: x(nmax_a) + integer :: ipiv(nmax_a), info + + character(len=120) :: msg + !---------------------------------------------------------------------------- ! Sinusoidal Boundary calculation !---------------------------------------------------------------------------- @@ -1224,6 +1229,7 @@ subroutine bnd_sinus( ihlat_bnd, itrans_width ) u(:,:) = 0._r8 v(:,:) = 0._r8 w(:,:) = 0._r8 + ipiv(:) = 0 do ilon = 0,nmlon ! long. bnd = nmlath - ihlat_bnd(ilon) ! switch from pole=0 to pole =90 @@ -1238,19 +1244,18 @@ subroutine bnd_sinus( ihlat_bnd, itrans_width ) end do end do end do - -! if (debug) write(iulog,*) ' Single Value Decomposition' - call svdcmp( u, nmax_a, nmax_a, nmax_a, nmax_a, w, v ) - -! if (debug) write(iulog,*) ' Solving' - call svbksb( u, w, v, nmax_a, nmax_a, nmax_a, nmax_a, rhs, lsg ) +! + x(:) = rhs(:) + call DGESV( nmax_a, 1, u, nmax_a, ipiv, x, nmax_a, info) + if (info/=0) then + write(msg,'(a,i4)') 'bnd_sinus -- LAPACK DGESV return error code: ',info + if (masterproc) write(iulog,*) trim(msg) + call endrun(trim(msg)) + end if + lsg(:) = x(:) ! do ilon = 0,nmlon ! long. -! sum = 0._r8 sum = dot_product( lsg(-nmax_sin+ishf:nmax_sin+ishf),f(-nmax_sin:nmax_sin,ilon) ) -! do i = -nmax_sin,nmax_sin -! sum = sum + lsg(i+ishf)*f(i,ilon) -! end do ihlat_bnd(ilon) = nmlath - int( sum + .5_r8 ) ! closest point itrans_width(ilon) = int( 8._r8 - 2._r8*cos( ylonm(ilon)*dtr ) + .5_r8 )/dlatm ! 6 to 10 deg. end do diff --git a/test/system/TR8.sh b/test/system/TR8.sh index 4366d63c84..498c9bb57f 100755 --- a/test/system/TR8.sh +++ b/test/system/TR8.sh @@ -71,7 +71,7 @@ fi #Check Dynamics if [ -d "${CAM_ROOT}/components/cam" ]; then -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/fv3 -s atmos_cubed_sphere,microphys +ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/fv3 -s atmos_cubed_sphere,microphys,src_override rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/se rc=`expr $? + $rc` @@ -84,7 +84,7 @@ rc=`expr $? + $rc` else -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/fv3 -s atmos_cubed_sphere,microphys +ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/fv3 -s atmos_cubed_sphere,microphys,src_override rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/se rc=`expr $? + $rc`