From d902259009980c7637442aee5b214323a9585673 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 29 Feb 2024 12:44:37 -0700 Subject: [PATCH 1/5] fv3 updates to bring in more current fms tag. Created fv3 interface directory brought in as an external which points back to GFDL to get the fv3 library code --- Externals.cfg | 3 +- Externals_CAM.cfg | 9 +- bld/configure | 3 +- cime_config/buildlib | 48 +- cime_config/config_pes.xml | 16 +- cime_config/testdefs/testlist_cam.xml | 1 + .../cam/outfrq9s_mg3/shell_commands | 2 +- src/dynamics/fv3/Makefile.in.fv3 | 175 - src/dynamics/fv3/dimensions_mod.F90 | 35 - src/dynamics/fv3/dp_coupling.F90 | 1087 ---- src/dynamics/fv3/dycore.F90 | 24 - src/dynamics/fv3/dycore_budget.F90 | 27 - src/dynamics/fv3/dyn_comp.F90 | 2227 -------- src/dynamics/fv3/dyn_grid.F90 | 1108 ---- src/dynamics/fv3/interp_mod.F90 | 67 - .../fv3/microphys/gfdl_cloud_microphys.F90 | 4975 ----------------- .../fv3/microphys/module_mp_radar.F90 | 614 -- src/dynamics/fv3/pmgrid.F90 | 15 - src/dynamics/fv3/restart_dynamics.F90 | 447 -- src/dynamics/fv3/spmd_dyn.F90 | 18 - src/dynamics/fv3/stepon.F90 | 334 -- test/system/TR8.sh | 4 +- 22 files changed, 65 insertions(+), 11174 deletions(-) delete mode 100644 src/dynamics/fv3/Makefile.in.fv3 delete mode 100644 src/dynamics/fv3/dimensions_mod.F90 delete mode 100644 src/dynamics/fv3/dp_coupling.F90 delete mode 100644 src/dynamics/fv3/dycore.F90 delete mode 100644 src/dynamics/fv3/dycore_budget.F90 delete mode 100644 src/dynamics/fv3/dyn_comp.F90 delete mode 100644 src/dynamics/fv3/dyn_grid.F90 delete mode 100644 src/dynamics/fv3/interp_mod.F90 delete mode 100644 src/dynamics/fv3/microphys/gfdl_cloud_microphys.F90 delete mode 100644 src/dynamics/fv3/microphys/module_mp_radar.F90 delete mode 100644 src/dynamics/fv3/pmgrid.F90 delete mode 100644 src/dynamics/fv3/restart_dynamics.F90 delete mode 100644 src/dynamics/fv3/spmd_dyn.F90 delete mode 100644 src/dynamics/fv3/stepon.F90 diff --git a/Externals.cfg b/Externals.cfg index 270dbcb3b5..8ab632bb03 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -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 debf4c613e..3d970b3375 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -56,11 +56,12 @@ 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/bld/configure b/bld/configure index 974c30dc5e..6633bb4c4c 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"; } diff --git a/cime_config/buildlib b/cime_config/buildlib index 73db5db3dd..90bbbd5985 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -24,6 +24,48 @@ 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") + if cam_dycore == "fv3": + # first check for the external FMS library and build it + # Check to see if some other component built it already + 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("{} {} {} {}".format(fmsbuildlib, fmsbuildroot, fmsinstallpath, caseroot), verbose=True) + expect(stat==0, "FMS build Failed {}".format(err)) + + if os.path.exists(install_libfms): + shutil.copy(install_libfms, libroot) + ############################################################################### def _build_cam(caseroot, libroot, bldroot): ############################################################################### @@ -63,12 +105,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 +160,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/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 0061d5c9ce..b04f09811a 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -301,6 +301,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/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/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` From 7959ffe864c294ab7ac6c3c21993d73a8cfe0079 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 29 Feb 2024 13:55:49 -0700 Subject: [PATCH 2/5] ChangeLog updates --- doc/ChangeLog | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 109 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 676bcae485..bf45019139 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,114 @@ =============================================================== +Tag name: cam6_3_XXX +Originator(s): jet +Date: Feb 29, 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 + +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: + +List all files eliminated: + dimensions_mod.F90 + dp_coupling.F90 + dycore_budget.F90 + dycore.F90 + dyn_comp.F90 + dyn_grid.F90 + interp_mod.F90 + Makefile.in.fv3 + microphys + pmgrid.F90 + restart_dynamics.F90 + spmd_dyn.F90 + stepon.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 src/dynamics/fv3/Makefile.in.fv3 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/dimensions_mod.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/dp_coupling.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/dycore.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/dycore_budget.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/dyn_comp.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/dyn_grid.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/interp_mod.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/microphys/gfdl_cloud_microphys.F90 + - removed this from CAM unneeded +M src/dynamics/fv3/microphys/module_mp_radar.F90 + - removed this from CAM unneeded +M src/dynamics/fv3/pmgrid.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/restart_dynamics.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +M src/dynamics/fv3/stepon.F90 + - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external +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 + +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 + + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: + +=============================================================== + Tag name: cam6_3_150 Originator(s): megandevlan, peverwhee Date: Feb 23, 2024 From 5310c6ee3ca5acdff5d4b3bf453c5378a95fbfa2 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 16 Apr 2024 10:43:17 -0600 Subject: [PATCH 3/5] PR requested updates --- cime_config/buildlib | 6 ++- cime_config/testdefs/testlist_cam.xml | 1 + doc/ChangeLog | 60 +++++++-------------------- 3 files changed, 21 insertions(+), 46 deletions(-) diff --git a/cime_config/buildlib b/cime_config/buildlib index 90bbbd5985..86883850e7 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -32,9 +32,11 @@ def _build_fms(caseroot, libroot, bldroot): # 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"): @@ -60,8 +62,8 @@ def _build_fms(caseroot, libroot, bldroot): #todo: call checkout_externals to get this component expect(False, "FMS external not found") else: - stat, _, err = run_cmd("{} {} {} {}".format(fmsbuildlib, fmsbuildroot, fmsinstallpath, caseroot), verbose=True) - expect(stat==0, "FMS build Failed {}".format(err)) + 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) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index b04f09811a..8fb275f51f 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -304,6 +304,7 @@ + diff --git a/doc/ChangeLog b/doc/ChangeLog index bf45019139..eac5406ca9 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,7 +2,7 @@ Tag name: cam6_3_XXX Originator(s): jet -Date: Feb 29, 2024 +Date: Apr 19, 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 @@ -10,7 +10,7 @@ Purpose of changes (include the issue number and title text for each relevant Gi - 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 + - 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 @@ -24,19 +24,20 @@ Describe any substantial timing or memory changes: N/A Code reviewed by: List all files eliminated: - dimensions_mod.F90 - dp_coupling.F90 - dycore_budget.F90 - dycore.F90 - dyn_comp.F90 - dyn_grid.F90 - interp_mod.F90 - Makefile.in.fv3 - microphys - pmgrid.F90 - restart_dynamics.F90 - spmd_dyn.F90 - stepon.F90 + 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 @@ -55,37 +56,9 @@ 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 src/dynamics/fv3/Makefile.in.fv3 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/dimensions_mod.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/dp_coupling.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/dycore.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/dycore_budget.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/dyn_comp.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/dyn_grid.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/interp_mod.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/microphys/gfdl_cloud_microphys.F90 - - removed this from CAM unneeded -M src/dynamics/fv3/microphys/module_mp_radar.F90 - - removed this from CAM unneeded -M src/dynamics/fv3/pmgrid.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/restart_dynamics.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external -M src/dynamics/fv3/stepon.F90 - - removed this from CAM and moved new fv3 Makefile to FV3_CAM_INTERFACE external 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 @@ -95,7 +68,6 @@ 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 From faa4c3bb62481c483701a2c215a7b1f39fe2485e Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 16 Apr 2024 14:37:14 -0600 Subject: [PATCH 4/5] small correction in comment --- cime_config/testdefs/testlist_cam.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 5f7e410855..702d105aef 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -304,7 +304,7 @@ - + From 5e4cf3374d59d3544e8523300dcf444018847b28 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Wed, 17 Apr 2024 12:16:17 -0600 Subject: [PATCH 5/5] [ 50 character, one line summary ] Update ChangeLog [ Description of the changes in this commit. It should be enough information for someone not following this development to understand. Lines should be wrapped at about 72 characters. ] Test suite: Test baseline: Test namelist changes: Test status: [bit for bit, roundoff, climate changing] Fixes: [CIME Github issue #] User interface changes?: [Yes (describe what changes), No] Code review: --- doc/ChangeLog | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 83409c55c7..ce4af05dfd 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,8 +1,8 @@ =============================================================== -Tag name: cam6_3_XXX +Tag name: cam6_3_157 Originator(s): jet -Date: Apr 19, 2024 +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 @@ -67,17 +67,23 @@ 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: +izumi/gnu/aux_cam: All PASS ===============================================================