From 41fff2cbcbda43a8108de14af05f176a936732bf Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Wed, 29 Jul 2026 14:43:32 +0100
Subject: [PATCH 1/9] Import 3DTE scheme (UM source codes are just copies of
um@vn14.2).
---
.../lfric_atm/example/configuration.nml | 1 +
.../lfric_atm/metadata/field_def_diags.xml | 19 +-
.../lfric_atm/metadata/lfric_dictionary.xml | 5 +
.../um-boundary_layer/HEAD/rose-meta.conf | 241 +++
.../rose-meta/um-boundary_layer/versions.py | 25 +
.../source/algorithm/bl_exp1a_alg_mod.x90 | 473 +++++
.../init_turbulence_fields_alg_mod.x90 | 48 +-
.../source/diagnostics/bl_exp1a_diags_mod.f90 | 203 +++
.../source/kernel/bl_exp1a_du_kernel_mod.F90 | 246 +++
.../source/kernel/bl_exp1a_kernel_mod.F90 | 1235 +++++++++++++
.../source/kernel/bl_imp_du_kernel_mod.F90 | 7 +-
.../source/kernel/interp_edge_kernel_mod.F90 | 127 ++
.../source/support/um_physics_init_mod.f90 | 378 ++--
.../check_global_variables/file/dirtylist.txt | 6 +
.../lfric-gungho/HEAD/rose-meta.conf | 43 +-
.../physics/slow_physics_alg_mod.X90 | 29 +-
.../driver/create_physics_prognostics_mod.F90 | 67 +-
.../leonard_term_kl_kernel_mod_test.pf | 9 +-
.../momentum_viscosity_kernel_mod_test.pf | 1 -
...tracer_smagorinsky_diff_kernel_mod_test.pf | 10 +-
.../tracer_viscosity_kernel_mod_test.pf | 1 -
.../source/boundary_layer/bdy_expl2_1a.F90 | 1596 +++++++++++++++++
.../source/boundary_layer/ddf_ctl.F90 | 842 +++++++++
.../source/boundary_layer/ddf_initialize.F90 | 261 +++
.../source/boundary_layer/ddf_mix_length.F90 | 206 +++
.../source/boundary_layer/mym_calcphi.F90 | 146 ++
.../boundary_layer/mym_condensation.F90 | 518 ++++++
.../source/boundary_layer/mym_const_mod.F90 | 140 ++
.../source/boundary_layer/mym_const_set.F90 | 134 ++
.../source/boundary_layer/mym_ctl.F90 | 655 +++++++
.../boundary_layer/mym_diff_matcoef.F90 | 203 +++
.../source/boundary_layer/mym_errfunc.F90 | 126 ++
.../source/boundary_layer/mym_ex_flux_tq.F90 | 187 ++
.../source/boundary_layer/mym_ex_flux_uv.F90 | 138 ++
.../source/boundary_layer/mym_implic.F90 | 98 +
.../source/boundary_layer/mym_initialize.F90 | 497 +++++
.../source/boundary_layer/mym_length.F90 | 218 +++
.../source/boundary_layer/mym_level2.F90 | 135 ++
.../source/boundary_layer/mym_shcu_buoy.F90 | 972 ++++++++++
.../boundary_layer/mym_simeq_ilud2_decmp.F90 | 244 +++
.../boundary_layer/mym_simeq_matrix_prod.F90 | 125 ++
.../source/boundary_layer/mym_solve_simeq.F90 | 208 +++
.../mym_solve_simeq_bcgstab.F90 | 350 ++++
.../boundary_layer/mym_solve_simeq_ilud2.F90 | 289 +++
.../boundary_layer/mym_solve_simeq_lud.F90 | 177 ++
.../source/boundary_layer/mym_turbulence.F90 | 1377 ++++++++++++++
.../boundary_layer/mym_update_covariance.F90 | 263 +++
.../boundary_layer/mym_update_fields.F90 | 117 ++
48 files changed, 13234 insertions(+), 162 deletions(-)
create mode 100644 interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90
create mode 100644 interfaces/physics_schemes_interface/source/diagnostics/bl_exp1a_diags_mod.f90
create mode 100644 interfaces/physics_schemes_interface/source/kernel/bl_exp1a_du_kernel_mod.F90
create mode 100644 interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90
create mode 100644 interfaces/physics_schemes_interface/source/kernel/interp_edge_kernel_mod.F90
create mode 100644 science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
create mode 100644 science/physics_schemes/source/boundary_layer/ddf_ctl.F90
create mode 100644 science/physics_schemes/source/boundary_layer/ddf_initialize.F90
create mode 100644 science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_calcphi.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_condensation.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_const_mod.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_const_set.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_ctl.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_errfunc.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_implic.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_initialize.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_length.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_level2.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_turbulence.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_update_fields.F90
diff --git a/applications/lfric_atm/example/configuration.nml b/applications/lfric_atm/example/configuration.nml
index 1e117100ae..d1519a88fa 100644
--- a/applications/lfric_atm/example/configuration.nml
+++ b/applications/lfric_atm/example/configuration.nml
@@ -8,6 +8,7 @@ prime_mesh_name='dynamics',
topology='fully_periodic',
/
&blayer
+bl_scheme='9c',
a_ent_2=0.056,
a_ent_shr=1.6,
bl_levels=50,
diff --git a/applications/lfric_atm/metadata/field_def_diags.xml b/applications/lfric_atm/metadata/field_def_diags.xml
index a2e35f72c0..ba0b3569e9 100644
--- a/applications/lfric_atm/metadata/field_def_diags.xml
+++ b/applications/lfric_atm/metadata/field_def_diags.xml
@@ -664,7 +664,6 @@
-
@@ -673,6 +672,7 @@
zoomed__rib
+
@@ -685,6 +685,23 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/applications/lfric_atm/metadata/lfric_dictionary.xml b/applications/lfric_atm/metadata/lfric_dictionary.xml
index e866da1d00..3363e10a97 100644
--- a/applications/lfric_atm/metadata/lfric_dictionary.xml
+++ b/applications/lfric_atm/metadata/lfric_dictionary.xml
@@ -269,7 +269,12 @@
+
+
+
+
+
diff --git a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
index 4947c61cfe..0716e0b909 100644
--- a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
+++ b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
@@ -36,6 +36,38 @@ range=0.0:10.0
sort-key=Panel-A08
type=real
+[namelist:blayer=adv_turb_field]
+compulsory=true
+description=Advect prognostic variables in TKE scheme
+help=If this switch is turned on,
+ =the prognostic variables are advected through the Semi-Lagrangian scheme.
+ =Suggested .TRUE.
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=logical
+
+[namelist:blayer=bdy_tke]
+compulsory=true
+description=Type of TKE closure model
+!enumeration=true
+help=The 1A TKE schemes consists of the following three models.
+ =* The first order eddy-diffusive model based on Deardorff (1980)
+ =* The Mellor-Yamada level 2.5 model
+ =* The Mellor-Yamada level 3 model
+ =The detailed formulations and implementations can be found in UMDP
+ =025. Note that the level 3 scheme may need a shorter timestep than
+ =usual. It is able to complete 12km and UKV standard jobs. For global
+ =model 12min (L70) is too long to run without computational instability,
+ =but it can run with a 5min timestep.
+!kind=default
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+trigger=namelist:blayer=my_prod_adj: 'my3' ;
+value-titles=The first order eddy-diffusive model based on Deardorff (1980),
+ =The Mellor-Yamada level 2.5 model,
+ =The Mellor-Yamada level 3 model
+values='deardorff','my25','my3'
+
[namelist:blayer=bl_levels]
description=Number of boundary layer levels
help=Typically only the levels in the lowest few kilometres of the
@@ -79,6 +111,63 @@ value-titles=None,Use a cosine flux profile,
=Use a target theta_vl profile
values='off','cosine_inv_flux','target_inv_profile'
+[namelist:blayer=bl_scheme]
+compulsory=true
+description=Boundary layer scheme version
+!enumeration=true
+fail-if=(this == "'1a'") and (namelist:microphysics=turb_gen_mixph==".true.");
+ =# turb_gen_mixph cannot be used with this boundary layer scheme.
+ =(this == "'1a'") and (namelist:cloud=scheme=="'bimodal'");
+ =(this == "'1a'") and (namelist:cloud=pc2_init_method=="'bimodal'");
+ =# bimodal scheme cannot be used with this boundary layer scheme.
+ =(this == "'1a'") and (namelist:cloud=scheme=="'pc2'");
+ =# pc2 scheme cannot be used with this boundary layer scheme.
+ =(this == "'1a'") and (namelist:cloud=rh_crit_opt=="'tke'");
+ =# TKE based RHc cannot be used with this boundary layer scheme.
+ =(this == "'1a'") and (namelist:convection=cv_scheme=="'comorph'");
+ =# Comorph scheme cannot be used with this boundary layer scheme
+help=Version 9 is the long-standing "diagnostic K-profile" scheme,
+ =that uses the resolved state of the atmosphere and surface
+ =to specify directly the turbulent diffusivities that are used
+ =to calculated the turbulent fluxes.
+ =
+ =The 1A scheme calculates the diffusivities from prognostic equations
+ =for the higher order moments of the turbulence,
+ =including the turbulence kinetic energy (TKE).
+!kind=default
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A08a
+trigger=namelist:blayer=a_ent_2: '9c' ;
+ =namelist:blayer=a_ent_shr: '9c' ;
+ =namelist:blayer=bl_res_inv: '9c' ;
+ =namelist:blayer=dec_thres_cloud: '9c' ;
+ =namelist:blayer=dec_thres_cu: '9c' ;
+ =namelist:blayer=dyn_diag: '9c' ;
+ =namelist:blayer=near_neut_z_on_l: '9c' ;
+ =namelist:blayer=dzrad_disc_opt: '9c' ;
+ =namelist:blayer=entr_smooth_dec: '9c' ;
+ =namelist:blayer=interp_local: '9c' ;
+ =namelist:blayer=kprof_cu: '9c' ;
+ =namelist:blayer=l_converge_ga: '9c' ;
+ =namelist:blayer=l_use_sml_dsc_fixes: '9c' ;
+ =namelist:blayer=new_kcloudtop: '9c' ;
+ =namelist:blayer=ng_stress: '9c' ;
+ =namelist:blayer=num_sweeps_bflux: '9c' ;
+ =namelist:blayer=sc_diag_opt: '9c' ;
+ =namelist:blayer=bl_mix_w: '9c' ;
+ =namelist:blayer=tke_levels: '1a' ;
+ =namelist:blayer=bdy_tke: '1a' ;
+ =namelist:blayer=adv_turb_field: '1a' ;
+ =namelist:blayer=my_condense: '1a' ;
+ =namelist:blayer=shcu_buoy: '1a' ;
+ =namelist:blayer=local_above_tkelvs: '1a' ;
+ =namelist:blayer=my_force_initialize: '1a' ;
+ =namelist:blayer=my_ini_dbdz_min: '1a' ;
+ =namelist:blayer=my_lowest_pd_surf: '1a' ;
+value-titles=9C: Revised entrainment fluxes plus new scalar,
+ =1A: Prognostic TKE-based turbulent closure
+values='9c','1a'
+
[namelist:blayer=c_gust]
compulsory=true
description=Constant in the wind gust diagnostic
@@ -411,6 +500,111 @@ ns=namelist/Science/UM Boundary layer
sort-key=Panel-A10
type=logical
+[namelist:blayer=local_above_tkelvs]
+compulsory=true
+description=Use the local scheme above TKE levels
+help=Diffusion coefficients between TKE_LEVELS + 1 and BL_LEVELS are not
+ =calculated by default. If this option is turned on,
+ =these diffusion coefficients are obtained through the local
+ =BL scheme. This is compatible to the original UM BL scheme
+ =with Z_NL_BL_LEVELS different from BL_LEVELS.
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=logical
+
+[namelist:blayer=my_condense]
+compulsory=true
+description=Use buoyancy parameters calculated from turbulent covariances
+help=If this option is selected,
+ =the buoyancy parameters are calculated based on the assumption of
+ =the bi-normal distribution function for fluctuation of heat and
+ =moisture. To evaluate the standard deviation of the distribution function,
+ =the predicted (in level 3) or diagnosed (level 2.5) covariances are used.
+ =
+ =If this option is not selected,
+ =buoyancy parameters calculated in the large scale cloud scheme
+ =(Smith or PC2) will be used in the TKE scheme. Suggested .TRUE.
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=logical
+
+[namelist:blayer=my_force_initialize]
+compulsory=true
+description=Force initialisation of the prognostic variables
+help=By default, the initial values of the turbulent prognostic variables
+ =are diagnosed by assuming balance between production and dissipation term
+ =in a normal run. And they are obtained from checkpoint file in a
+ =continuation run.
+ =
+ =But when this switch is turned on, the initial fields are diagnosed
+ =in any case, including continuation run.
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=logical
+
+[namelist:blayer=my_ini_dbdz_min]
+compulsory=true
+description=Minimum limit of the buoyancy gradient at initialisation
+help=If the initial fields have negative or close-to-neutral vertical
+ =buoyancy gradient in the upper levels,
+ =the initialised prognostic variables tend to be much larger,
+ =and this sometimes leads to computational instability. To avoid this,
+ =the minimum limit of the vertical buoyancy gradient (in s^(-2)) is
+ =imposed in the initialisation.
+ =Suggested value 1.0e-5.
+ns=namelist/Science/UM Boundary layer
+range=1.0e-10:1.0e+10
+sort-key=Panel-A10a
+type=real
+
+[namelist:blayer=my_lowest_pd_surf]
+compulsory=true
+description=Method for calculating production terms at the lowest level
+!enumeration=true
+help=The production terms of the prognostic variables at the lowest level
+ =can be calculated with surface related quantities.
+ =* Without surface fluxes and related quantities
+ =The production terms at the lowest levels are evaluated in the
+ =same way as the other levels (i.e. with vertical gradients in
+ =the atmosphere).
+ =* With gradient functions by Businger(1971)
+ =* With gradient functions by Beljaars and Holtslag(1991)
+ =If either of these is selected,
+ =the production term at the lowest level is calculated using surface
+ =fluxes and gradient functions. It is usually recommended. However,
+ =if the lowest level is close to the surface (like L70 in UKV),
+ =the production term could be too large because it is in inverse
+ =proportion to the height of the lowest layer. This can also happen if
+ ="effective roughness" (see LAND_SURF panel) is used because
+ =the production term at the lowest level is proportional
+ =to the cube of the friction velocity,
+ =which can be large with effective roughness lengths. In that case,
+ =it could be better to try either another option for the
+ =roughness length or turn this option off.
+ =Suggested Belijaars and Holtslag (1991).
+!kind=default
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+value-titles=Not use surface fluxes,
+ =With gradient functions by Businger(1971),
+ =With gradient functions by Beljaars and Holtslag(1991)
+values='off','businger', 'bh91'
+
+[namelist:blayer=my_prod_adj]
+compulsory=true
+description=Adjust production terms for computational stability on each level
+help=This option is highly recommended to turn on,
+ =especially when the timestep is large. A smaller factor
+ =makes the adjustment activate more often,
+ =but too strong adjustment might adversely affect the accuracy of
+ =forecasts. With the value 0.225,
+ =sufficient computational stability is secured in NAE and UKV.
+ =The factors can be set on each level. Sometimes smaller values
+ =at the lower layer could be better to ensure computational stability.
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=logical
+
[namelist:blayer=near_neut_z_on_l]
compulsory=true
description=Threshold value of z/l below which to diagnose shear-driven BL
@@ -589,6 +783,53 @@ sort-key=Panel-A07
value-titles=None,Subgrid shear plus enhanced mixing lengths
values='none','shear_plus_lambda'
+[namelist:blayer=shcu_buoy]
+compulsory=true
+description=Use non-gradient buoyancy flux associated with skewness
+ = in shallow convection
+help=If this switch is activated,
+ =non-gradient buoyancy flux suggested by Lock and Mailhot (2006)
+ =is added to the production term of TKE. The main purpose of adding
+ =this flux is to represent shallow convection. Therefore,
+ =if the convection scheme is turned on,
+ =conflicts between the convection scheme and this flux could occur.
+ =Suggested .TRUE.
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+trigger=namelist:blayer=shcu_levels: .true.;
+type=logical
+
+[namelist:blayer=shcu_levels]
+compulsory=true
+description=Levels at which to apply the non-gradient buoyancy flux
+help=The maximum level to calculate and add the non-gradient buoyancy flux
+ =can be set. It should correspond to a height of 3 to 5km.
+ =Suggested -1 to set to TKE levels.
+!kind=default
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=integer
+
+[namelist:blayer=tke_levels]
+compulsory=true
+description=Number of TKE levels
+help="TKE_LEVELS" is similar to "Z_NL_BL_LEVELS" in the original UM boundary
+ =layer scheme. Usually the prognostic variables related to the turbulent
+ =schemes have the same number of levels as BL_LEVELS because these
+ =schemes have been designed for turbulence in boundary layer. However,
+ =the top of BL_LEVELS is sometimes set near the top of the model (e.g.
+ =UKV). If the same formulation is applied to the upper troposphere or
+ =stratosphere,
+ =where wind velocity and its shear
+ =are much larger than those in boundary layer,
+ =computational instabilities may arise.
+ =It is recommended to use a level around 6km over the sea (e.g. 30
+ =in the current global L70 model). -1 will default to bl_levels.
+!kind=default
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=integer
+
[namelist:blayer=zhloc_depth_fac]
compulsory=true
description=Fractional cloud height reached by local BL depth calculation
diff --git a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
index 01e65a2b91..f19b17c64a 100644
--- a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
+++ b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
@@ -31,3 +31,28 @@ def upgrade(self, config, meta_config=None):
# Add settings
return config, self.reports
"""
+
+class vn32_t46(MacroUpgrade):
+ """Upgrade macro for ticket #46 by Shusuke Nishimoto."""
+
+ BEFORE_TAG = "vn3.2"
+ AFTER_TAG = "vn3.2_t46"
+
+ def upgrade(self, config, meta_config=None):
+ # Commands From: rose-meta/um-boundary_layer
+ boundary_layer = self.get_setting_value(
+ config, ["namelist:section_choice", "boundary_layer"]
+ )
+ mixing_method = self.get_setting_value(
+ config, ["namelist:mixing", "method"]
+ )
+ self.remove_setting(config, ["namelist:mixing", "method"])
+ if boundary_layer == "'um'":
+ self.add_setting(
+ config, ["namelist:blayer", "bl_scheme"], "'9c'"
+ )
+ self.add_setting(
+ config, ["namelist:mixing", "method_9c"], mixing_method
+ )
+
+ return config, self.reports
diff --git a/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90 b/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90
new file mode 100644
index 0000000000..1cc937e841
--- /dev/null
+++ b/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90
@@ -0,0 +1,473 @@
+!-------------------------------------------------------------------------------
+! (C) Crown copyright Met Office. All rights reserved.
+! The file LICENCE, distributed with this code, contains details of the terms
+! under which the code may be used.
+!-------------------------------------------------------------------------------
+!> @brief Interface to the UM High Order Turbulence Closure Scheme.
+
+module bl_exp1a_alg_mod
+
+ use config_mod, only: config_type
+ use constants_mod, only: i_def, r_def, l_def
+ use field_mod, only: field_type
+ use integer_field_mod, only: integer_field_type
+ use integer_field_mod, only: integer_field_type
+ use field_collection_mod, only: field_collection_type
+ use mr_indices_mod, only: nummr, imr_v, imr_cl, imr_ci, imr_s
+
+ use function_space_mod, only: function_space_type
+ use function_space_collection_mod, only: function_space_collection
+ use sci_fem_constants_mod, only: get_rmultiplicity_fv
+ use fs_continuity_mod, only: W2, W3, Wtheta
+ use sci_geometric_constants_mod, only: get_height_fv, get_da_at_w2, &
+ get_delta_at_wtheta, &
+ get_dz_at_wtheta, &
+ get_face_selector_ew, &
+ get_face_selector_ns
+ use physics_constants_mod, only: get_max_diff, get_rdz_fd1, &
+ get_rdz_w3, get_dtrdz_wth
+ use map_fd_to_prognostics_alg_mod, only: set_wind
+ use jules_surface_config_mod, only: formdrag_dist_drag
+ use jules_control_init_mod, only: n_surf_interp
+ use blayer_config_mod, only: bdy_tke_deardorff
+ use nlsizes_namelist_mod, only: bl_levels
+ use bl_option_mod, only: l_calc_tau_at_p
+ use um_sizes_init_mod, only: um_sizes_init
+
+ use timing_mod, only: start_timing, stop_timing, tik, LPROF
+ use log_mod, only: log_event, LOG_LEVEL_DEBUG
+ use mesh_mod, only: mesh_type
+ use model_clock_mod, only: model_clock_type
+ use print_field_stats_alg_mod, only: print_field_stats_alg
+
+ ! xios output
+ use bl_exp1a_diags_mod, only: initialise_diags_for_bl_exp1a, &
+ output_diags_for_bl_exp1a
+
+ implicit none
+
+ private
+ public bl_exp1a_alg
+
+contains
+
+ !>@brief Run the UM High Order Turbulence Closure Scheme.
+ !>@details The UM Boundary Layer scheme does:
+ !> vertical mixing of heat, momentum and moisture,
+ !> as documented in UMDP25
+ !> NB This version uses winds in w3 space (i.e. A-grid)
+ !>@param[in] config Application namelist configuration object
+ !>@param[in] theta Theta in its native (wth) space
+ !>@param[in] rho Dry density in its native (w3) space
+ !>@param[in] exner Exner Pressure in the w3 space
+ !>@param[in] mr_n Mixing ratios at time level n
+ !>@param[in] derived_fields Group of derived fields
+ !>@param[in] microphysics_fields Fields for mphys scheme
+ !>@param[in] orography_fields Fields for orog drag scheme
+ !>@param[in,out] turbulence_fields Fields for turbulence scheme
+ !>@param[in,out] convection_fields Fields for convection scheme
+ !>@param[in] cloud_fields Fields for cloud scheme
+ !>@param[in,out] surface_fields Fields for surface scheme
+ !>@param[in] model_clock Time in the model
+ subroutine bl_exp1a_alg(config, theta, rho, exner, mr_n, &
+ derived_fields, &
+ microphysics_fields, orography_fields, &
+ turbulence_fields, convection_fields, &
+ cloud_fields, surface_fields, &
+ model_clock)
+
+ use bl_exp1a_kernel_mod, only: bl_exp1a_kernel_type
+ use interp_edge_kernel_mod, only: interp_edge_kernel_type
+ use bl_exp1a_du_kernel_mod, only: bl_exp1a_du_kernel_type
+ implicit none
+
+ type(config_type), intent(in) :: config
+
+ type( field_type ), intent( in ) :: theta, exner, rho, mr_n(nummr)
+
+ type( field_collection_type ), intent(in) :: derived_fields
+ type( field_collection_type ), intent(in) :: microphysics_fields
+ type( field_collection_type ), intent(in) :: orography_fields
+ type( field_collection_type ), intent(in) :: turbulence_fields
+ type( field_collection_type ), intent(in) :: convection_fields
+ type( field_collection_type ), intent(in) :: cloud_fields
+ type( field_collection_type ), intent(in) :: surface_fields
+
+ class( model_clock_type ), intent(in) :: model_clock
+
+ ! Temporary fields unpacked fields from collections
+ type( field_type ), pointer :: exner_in_wth
+ type( field_type ), pointer :: rho_in_wth
+ type( field_type ), pointer :: wetrho_in_wth
+ type( field_type ), pointer :: wetrho_in_w3
+ type( field_type ), pointer :: wetrho_in_w2
+ type( field_type ), pointer :: u_in_w3
+ type( field_type ), pointer :: v_in_w3
+ type( field_type ), pointer :: w_in_wth
+ type( field_type ), pointer :: shear
+ type( field_type ), pointer :: visc_h
+ type( field_type ), pointer :: visc_m
+ type( field_type ), pointer :: u_physics
+ type( field_type ), pointer :: sea_u_current_ptr
+ type( field_type ), pointer :: sea_v_current_ptr
+ type( field_type ), pointer :: sea_current_w2_ptr
+
+ type( field_type ), pointer :: zh
+ type( integer_field_type ), pointer :: ntml
+ type( integer_field_type ), pointer :: cumulus
+ type( integer_field_type ), pointer :: bl_type_ind
+ type( field_type ), pointer :: zhpar_shcu
+ type( field_type ), pointer :: z_lcl
+ type( field_type ), pointer :: inv_depth
+ type( field_type ), pointer :: qcl_at_inv_top
+ type( field_type ), pointer :: rhokh_bl
+ type( field_type ), pointer :: tke_bl
+ type( field_type ), pointer :: tsq_bl
+ type( field_type ), pointer :: qsq_bl
+ type( field_type ), pointer :: cov_bl
+ type( field_type ), pointer :: bq_bl
+ type( field_type ), pointer :: bt_bl
+ type( field_type ), pointer :: moist_flux_bl
+ type( field_type ), pointer :: heat_flux_bl
+ type( field_type ), pointer :: dtrdz_tq_bl
+ type( field_type ), pointer :: dw_bl
+ type( field_type ), pointer :: gradrinr
+ type( field_type ), pointer :: rhokm_w2
+ type( field_type ), pointer :: tau_w2
+ type( field_type ), pointer :: taux
+ type( field_type ), pointer :: tauy
+ type( field_type ), pointer :: rhokm_bl
+
+ type( integer_field_type ), pointer :: shallow_flag
+ type( field_type ), pointer :: uw0_flux
+ type( field_type ), pointer :: vw0_flux
+ type( field_type ), pointer :: lcl_height
+ type( field_type ), pointer :: parcel_top
+ type( integer_field_type ), pointer :: level_parcel_top
+ type( field_type ), pointer :: wstar
+ type( field_type ), pointer :: thv_flux
+ type( field_type ), pointer :: parcel_buoyancy
+ type( field_type ), pointer :: qsat_at_lcl
+
+ type( field_type ), pointer :: cf_bulk
+ type( field_type ), pointer :: cf_liquid
+
+ type( field_type ), pointer :: tnuc
+ type( field_type ), pointer :: tnuc_nlcl
+
+ type( field_type ), pointer :: tile_fraction
+ type( field_type ), pointer :: tile_temperature
+ type( field_type ), pointer :: z0m_eff
+ type( field_type ), pointer :: ustar
+ type( field_type ), pointer :: surf_interp_w2
+ type( field_type ), pointer :: surf_interp
+ type( field_type ), pointer :: tau_land_w2
+ type( field_type ), pointer :: tau_ssi_w2
+
+ type( field_type ), pointer :: sd_orog
+ type( field_type ), pointer :: peak_to_trough_orog
+ type( field_type ), pointer :: silhouette_area_orog
+
+ type( field_type ), pointer :: height_w3
+ type( field_type ), pointer :: height_wth
+ type( field_type ), pointer :: delta
+ type( field_type ), pointer :: max_diff_smag
+ type( field_type ), pointer :: dA
+ type( field_type ), pointer :: rdz_fd1
+ type( field_type ), pointer :: rdz_w3
+ type( field_type ), pointer :: dtrdz_wth
+ type( field_type ), pointer :: w2_rmultiplicity
+ type( field_type ), pointer :: dz_wth
+
+ type( integer_field_type ), pointer :: face_selector_ew
+ type( integer_field_type ), pointer :: face_selector_ns
+
+ ! local variables
+ type(mesh_type), pointer :: mesh
+ type( field_type ) :: rhogam_w2, rhogamu_w3, rhogamv_w3, rhogamw_wth, &
+ fd_tau_w2, fd_taux, fd_tauy, fd_tauz, &
+ master_length, &
+ rhogamu_bl, rhogamv_bl, rhogamt_bl, rhogamq_bl, &
+ tke_shr_prod, tke_boy_prod, tke_dissp, &
+ sm25, sh25, dbdz, dvdzm
+ type( field_type) :: rdz_wth, taux_land, tauy_land, taux_ssi, tauy_ssi
+ type( field_type ) :: mr_ice
+
+ integer(i_def) :: ncells
+ integer(tik) :: id
+ logical(l_def), parameter :: sw_off = .false.
+ logical(l_def), parameter :: sw_on = .true.
+
+ if ( LPROF ) call start_timing( id, 'bl.explicit' )
+
+ nullify(exner_in_wth, rho_in_wth, wetrho_in_wth, wetrho_in_w3, &
+ wetrho_in_w2, u_in_w3, v_in_w3, w_in_wth, shear, visc_h, visc_m, &
+ u_physics, sea_u_current_ptr, sea_v_current_ptr, &
+ sea_current_w2_ptr, zh, ntml, cumulus, bl_type_ind, &
+ zhpar_shcu, z_lcl, inv_depth, qcl_at_inv_top, rhokh_bl, tke_bl, &
+ tsq_bl, qsq_bl, cov_bl, bq_bl, bt_bl, moist_flux_bl, heat_flux_bl, &
+ dtrdz_tq_bl, dw_bl, gradrinr, rhokm_w2, tau_w2, taux, tauy, &
+ rhokm_bl, &
+ shallow_flag, uw0_flux, vw0_flux, lcl_height, parcel_top, &
+ level_parcel_top, wstar, thv_flux, parcel_buoyancy, qsat_at_lcl, &
+ cf_bulk, cf_liquid, tnuc, tnuc_nlcl, tile_fraction, &
+ tile_temperature, z0m_eff, ustar, surf_interp_w2, surf_interp, &
+ tau_land_w2, tau_ssi_w2, sd_orog, peak_to_trough_orog, &
+ silhouette_area_orog, height_w3, height_wth, delta, max_diff_smag, &
+ dA, rdz_fd1, rdz_w3, dtrdz_wth, w2_rmultiplicity, dz_wth, mesh)
+
+ call log_event( 'slow_physics: Running explicit Boundary layer', &
+ LOG_LEVEL_DEBUG )
+
+ ! Unpack derived fields
+ call derived_fields%get_field('exner_in_wth', exner_in_wth)
+ call derived_fields%get_field('rho_in_wth', rho_in_wth)
+ call derived_fields%get_field('wetrho_in_wth', wetrho_in_wth)
+ call derived_fields%get_field('wetrho_in_w3', wetrho_in_w3)
+ call derived_fields%get_field('wetrho_in_w2', wetrho_in_w2)
+ call derived_fields%get_field('u_in_w3', u_in_w3)
+ call derived_fields%get_field('v_in_w3', v_in_w3)
+ call derived_fields%get_field('w_in_wth', w_in_wth)
+ call derived_fields%get_field('shear', shear)
+ call derived_fields%get_field('visc_h', visc_h)
+ call derived_fields%get_field('visc_m', visc_m)
+ call derived_fields%get_field('u_physics', u_physics)
+
+ ! Unpack turbulence fields
+ call turbulence_fields%get_field('zh', zh)
+ call turbulence_fields%get_field('ntml', ntml)
+ call turbulence_fields%get_field('cumulus', cumulus)
+ call turbulence_fields%get_field('zhpar_shcu', zhpar_shcu)
+ call turbulence_fields%get_field('z_lcl', z_lcl)
+ call turbulence_fields%get_field('inv_depth', inv_depth)
+ call turbulence_fields%get_field('qcl_at_inv_top', qcl_at_inv_top)
+ call turbulence_fields%get_field('bl_type_ind', bl_type_ind)
+ call turbulence_fields%get_field('rhokh_bl', rhokh_bl)
+ call turbulence_fields%get_field('tke_bl', tke_bl)
+ call turbulence_fields%get_field('tsq_bl', tsq_bl)
+ call turbulence_fields%get_field('qsq_bl', qsq_bl)
+ call turbulence_fields%get_field('cov_bl', cov_bl)
+ call turbulence_fields%get_field('bq_bl', bq_bl)
+ call turbulence_fields%get_field('bt_bl', bt_bl)
+ call turbulence_fields%get_field('moist_flux_bl', moist_flux_bl)
+ call turbulence_fields%get_field('heat_flux_bl', heat_flux_bl)
+ call turbulence_fields%get_field('dtrdz_tq_bl', dtrdz_tq_bl)
+ call turbulence_fields%get_field('dw_bl', dw_bl)
+ call turbulence_fields%get_field('gradrinr', gradrinr)
+ call turbulence_fields%get_field('rhokm_w2', rhokm_w2)
+ call turbulence_fields%get_field('rhokm_bl', rhokm_bl)
+ call turbulence_fields%get_field('tau_w2', tau_w2)
+
+ ! Convection fields
+ call convection_fields%get_field('shallow_flag', shallow_flag)
+ call convection_fields%get_field('uw0_flux', uw0_flux)
+ call convection_fields%get_field('vw0_flux', vw0_flux)
+ call convection_fields%get_field('lcl_height', lcl_height)
+ call convection_fields%get_field('parcel_top', parcel_top)
+ call convection_fields%get_field('level_parcel_top', level_parcel_top)
+ call convection_fields%get_field('wstar', wstar)
+ call convection_fields%get_field('thv_flux', thv_flux)
+ call convection_fields%get_field('parcel_buoyancy', parcel_buoyancy)
+ call convection_fields%get_field('qsat_at_lcl', qsat_at_lcl)
+
+ ! Unpack cloud fields
+ call cloud_fields%get_field('bulk_fraction', cf_bulk)
+ call cloud_fields%get_field('liquid_fraction', cf_liquid)
+
+ ! Unpack the microphysics fields
+ call microphysics_fields%get_field('tnuc', tnuc)
+ call microphysics_fields%get_field('tnuc_nlcl', tnuc_nlcl)
+
+ ! Orography fields
+ call orography_fields%get_field('sd_orog', sd_orog)
+ call orography_fields%get_field('peak_to_trough_orog', peak_to_trough_orog)
+ call orography_fields%get_field('silhouette_area_orog', silhouette_area_orog)
+
+ ! Surface fields
+ call surface_fields%get_field('tile_fraction', tile_fraction)
+ call surface_fields%get_field('tile_temperature', tile_temperature)
+ call surface_fields%get_field('z0m_eff', z0m_eff)
+ call surface_fields%get_field('ustar', ustar)
+ call surface_fields%get_field('surf_interp_w2', surf_interp_w2)
+ call surface_fields%get_field('surf_interp', surf_interp)
+ call surface_fields%get_field('tau_land_w2', tau_land_w2)
+ call surface_fields%get_field('tau_ssi_w2', tau_ssi_w2)
+ call surface_fields%get_field('sea_current_w2',sea_current_w2_ptr)
+ call surface_fields%get_field('sea_u_current',sea_u_current_ptr)
+ call surface_fields%get_field('sea_v_current',sea_v_current_ptr)
+
+ mesh => theta%get_mesh()
+
+ height_wth => get_height_fv(config, mesh, Wtheta)
+ height_w3 => get_height_fv(config, mesh, W3)
+
+ face_selector_ew => get_face_selector_ew(mesh)
+ face_selector_ns => get_face_selector_ns(mesh)
+
+ ! delta is calculated in sci_calc_delta_at_wtheta_kernel_mod.F90
+ ! in lfric core as the mininum of the cell horizontal edge lengths
+ delta => get_delta_at_wtheta(mesh)
+ max_diff_smag => get_max_diff(config, mesh%get_id(), model_clock)
+ dA => get_da_at_w2(mesh)
+ rdz_fd1 => get_rdz_fd1(config, mesh%get_id())
+ rdz_w3 => get_rdz_w3(config, mesh%get_id())
+ dtrdz_wth => get_dtrdz_wth(config, mesh%get_id(), model_clock)
+ w2_rmultiplicity => get_rmultiplicity_fv( W2, mesh%get_id() )
+ dz_wth => get_dz_at_wtheta(config, mesh)
+
+ ! Initialise diagnostics
+ call initialise_diags_for_bl_exp1a( master_length, &
+ rhogamu_bl, rhogamv_bl, &
+ rhogamt_bl, rhogamq_bl, &
+ tke_shr_prod, tke_boy_prod, tke_dissp, &
+ sm25, sh25, dbdz, dvdzm )
+
+ ! Fields for interpolation to cell faces
+ call u_physics%copy_field_properties(rhogam_w2)
+ call u_physics%copy_field_properties(fd_tau_w2)
+ call exner%copy_field_properties(rhogamu_w3)
+ call exner%copy_field_properties(rhogamv_w3)
+ call theta%copy_field_properties(rhogamw_wth)
+ call rho%copy_field_properties(fd_taux)
+ call rho%copy_field_properties(fd_tauy)
+
+ ncells = mesh%get_last_edge_cell()
+
+ ! Calculate total ice field
+ call mr_n(imr_s)%copy_field_properties(mr_ice)
+ call invoke(setval_X(mr_ice, mr_n(imr_s)))
+ if (config%microphysics%microphysics_casim()) then
+ call invoke(inc_X_plus_Y(mr_ice, mr_n(imr_ci)))
+ end if
+
+ ! Switch UM to running i-first on whole domain
+ call um_sizes_init(ncells)
+ ! Call explicit BL scheme
+ call invoke(bl_exp1a_kernel_type( theta, rho, rho_in_wth, wetrho_in_wth, &
+ exner, exner_in_wth, u_in_w3, v_in_w3, &
+ w_in_wth, mr_n(imr_v), &
+ mr_n(imr_cl), mr_ice, height_w3, &
+ height_wth, dz_wth, rdz_w3, dtrdz_wth, &
+ shear, delta, zh, ntml, &
+ cumulus, tile_fraction, sd_orog, &
+ peak_to_trough_orog, &
+ silhouette_area_orog, &
+ tile_temperature, &
+ cf_bulk, cf_liquid, &
+ tnuc, tnuc_nlcl, &
+ visc_m, visc_h, &
+ dw_bl, rhokm_bl, surf_interp, rhokh_bl, &
+ tke_bl, tsq_bl, qsq_bl, cov_bl, &
+ zhpar_shcu, &
+ rhogamu_w3, rhogamv_w3, &
+ bq_bl, bt_bl, &
+ moist_flux_bl, heat_flux_bl, dtrdz_tq_bl,&
+ fd_taux, fd_tauy, sea_u_current_ptr, &
+ sea_v_current_ptr, master_length, &
+ gradrinr, rhogamu_bl, rhogamv_bl, &
+ rhogamt_bl, rhogamq_bl, &
+ tke_shr_prod, tke_boy_prod, tke_dissp, &
+ sm25, sh25, dbdz, dvdzm, &
+ z0m_eff, ustar, z_lcl, &
+ inv_depth, qcl_at_inv_top, shallow_flag, &
+ uw0_flux, vw0_flux, lcl_height, &
+ parcel_top, level_parcel_top, wstar, &
+ thv_flux, parcel_buoyancy, qsat_at_lcl, &
+ bl_type_ind), &
+ ! Interpolate scalar variables from cell center to cell face
+ setval_c(rhokm_w2, 0.0_r_def), &
+ interp_edge_kernel_type(sw_off, bl_levels, &
+ rhokm_bl, rhokm_w2, &
+ w2_rmultiplicity), &
+ setval_c(wetrho_in_w2, 0.0_r_def), &
+ interp_edge_kernel_type(sw_off, bl_levels, &
+ wetrho_in_w3, wetrho_in_w2, &
+ w2_rmultiplicity), &
+ setval_c(surf_interp_w2, 0.0_r_def), &
+ interp_edge_kernel_type(sw_on, n_surf_interp, &
+ surf_interp, surf_interp_w2, &
+ w2_rmultiplicity), &
+ setval_c(tau_w2, 0.0_r_def), &
+ setval_c(rhogamw_wth, 0.0_r_def) )
+
+ ! Re-grid vector variable into W2 fields
+ call set_wind(config, rhogam_w2, rhogamu_w3, rhogamv_w3, rhogamw_wth)
+ call invoke(inc_X_divideby_Y(rhogam_w2, dA))
+
+ ! Switch UM back to columns
+ call um_sizes_init(1_i_def)
+
+ if (config%jules_surface%formdrag() == formdrag_dist_drag) then
+ if ( LPROF ) call stop_timing( id, 'bl.explicit' )
+ call theta%copy_field_properties(fd_tauz)
+ call invoke(setval_c(fd_tauz, 0.0_r_def))
+ ! Calculate form drag stress in w2
+ call set_wind(config,fd_tau_w2,fd_taux,fd_tauy,fd_tauz)
+ call invoke(inc_X_divideby_Y(fd_tau_w2, dA))
+ if ( LPROF ) call start_timing( id, 'bl.explicit' )
+ end if
+
+ call invoke(bl_exp1a_du_kernel_type(4_i_def, &
+ tau_w2, tau_land_w2, tau_ssi_w2, &
+ rhokm_w2, rdz_fd1, u_physics, &
+ surf_interp_w2, rhogam_w2, fd_tau_w2, &
+ sea_current_w2_ptr, &
+ face_selector_ew, face_selector_ns) )
+
+ if (l_calc_tau_at_p) then
+ call dz_wth%copy_field_properties(rdz_wth)
+ call zh%copy_field_properties(taux_land)
+ call zh%copy_field_properties(tauy_land)
+ call zh%copy_field_properties(taux_ssi)
+ call zh%copy_field_properties(tauy_ssi)
+ call turbulence_fields%get_field('taux', taux)
+ call turbulence_fields%get_field('tauy', tauy)
+ call invoke(setval_X(rdz_wth, dz_wth), &
+ inc_X_powint_n(rdz_wth, (-1_i_def)), &
+ setval_c(taux, 0.0_r_def), &
+ setval_c(tauy, 0.0_r_def), &
+ ! Calculate explicit momentum diffusion at cell centres
+ bl_exp1a_du_kernel_type(1_i_def, &
+ taux, taux_land, taux_ssi, &
+ rhokm_bl, rdz_wth, u_in_w3, &
+ surf_interp, rhogamu_w3, fd_taux, &
+ sea_u_current_ptr, &
+ face_selector_ew, face_selector_ns), &
+ bl_exp1a_du_kernel_type(1_i_def, &
+ tauy, tauy_land, tauy_ssi, &
+ rhokm_bl, rdz_wth, v_in_w3, &
+ surf_interp, rhogamv_w3, fd_tauy, &
+ sea_v_current_ptr, &
+ face_selector_ew, face_selector_ns) )
+ end if
+
+ if ( LPROF ) call stop_timing( id, 'bl.explicit' )
+
+ call print_field_stats_alg(config, tke_bl, LOG_LEVEL_DEBUG, name="tke_bl")
+ if ( config%blayer%bdy_tke() /= bdy_tke_deardorff ) then
+ call print_field_stats_alg(config, tsq_bl, LOG_LEVEL_DEBUG, name="tsq_bl")
+ call print_field_stats_alg(config, qsq_bl, LOG_LEVEL_DEBUG, name="qsq_bl")
+ call print_field_stats_alg(config, cov_bl, LOG_LEVEL_DEBUG, name="cov_bl")
+ end if
+
+ ! output BL diagnostics
+ if (config%io%write_diag() .and. config%io%use_xios_io()) then
+
+ call output_diags_for_bl_exp1a(ntml, cumulus, bl_type_ind, &
+ tke_bl, tsq_bl, qsq_bl, cov_bl, &
+ master_length, gradrinr, &
+ rhokm_bl, rhokh_bl, &
+ rhogamu_bl, rhogamv_bl, &
+ rhogamt_bl, rhogamq_bl, &
+ tke_shr_prod, tke_boy_prod, tke_dissp, &
+ sm25, sh25, dbdz, dvdzm, &
+ dtrdz_tq_bl, rdz_w3 &
+ )
+
+ end if
+
+ nullify( mesh )
+
+ end subroutine bl_exp1a_alg
+
+end module bl_exp1a_alg_mod
diff --git a/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90 b/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90
index 312ca40d02..d2c417495c 100644
--- a/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90
+++ b/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90
@@ -27,6 +27,9 @@ contains
!> @param[in,out] turbulence_fields Collection of fields for turbulence scheme
subroutine init_turbulence_fields_alg(turbulence_fields)
+ use blayer_config_mod, only: bl_scheme, bl_scheme_9c, bl_scheme_1a, &
+ bdy_tke, bdy_tke_deardorff, shcu_buoy
+
implicit none
! Arguments
@@ -41,6 +44,11 @@ contains
type( field_type ), pointer :: heat_flux_bl => null()
type( field_type ), pointer :: moist_flux_bl => null()
type( field_type ), pointer :: tke_bl => null()
+ type( field_type ), pointer :: tsq_bl => null()
+ type( field_type ), pointer :: qsq_bl => null()
+ type( field_type ), pointer :: cov_bl => null()
+ type( field_type ), pointer :: zhpar_shcu => null()
+ type( field_type ), pointer :: rhokm_bl => null()
type( field_type ), pointer :: rhokh_bl => null()
type( field_type ), pointer :: dtrdz_tq_bl => null()
type( field_type ), pointer :: zhsc => null()
@@ -60,12 +68,12 @@ contains
call turbulence_fields%get_field('z_lcl', z_lcl)
call turbulence_fields%get_field('ntml', ntml)
call turbulence_fields%get_field('cumulus', cumulus)
- call turbulence_fields%get_field('wvar', wvar)
call turbulence_fields%get_field('heat_flux_bl', heat_flux_bl)
call turbulence_fields%get_field('moist_flux_bl', moist_flux_bl)
call turbulence_fields%get_field('tke_bl', tke_bl)
call turbulence_fields%get_field('rhokh_bl', rhokh_bl)
call turbulence_fields%get_field('dtrdz_tq_bl', dtrdz_tq_bl)
+ call turbulence_fields%get_field('gradrinr', gradrinr)
call turbulence_fields%get_field('zhsc', zhsc)
call turbulence_fields%get_field('level_ent', level_ent)
call turbulence_fields%get_field('level_ent_dsc', level_ent_dsc)
@@ -75,9 +83,22 @@ contains
call turbulence_fields%get_field('ent_we_lim_dsc', ent_we_lim_dsc)
call turbulence_fields%get_field('ent_t_frac_dsc', ent_t_frac_dsc)
call turbulence_fields%get_field('ent_zrzi_dsc', ent_zrzi_dsc)
- call turbulence_fields%get_field('dsldzm', dsldzm)
- call turbulence_fields%get_field('mix_len_bm', mix_len_bm)
- call turbulence_fields%get_field('gradrinr', gradrinr)
+
+ if (bl_scheme == bl_scheme_9c) then
+ call turbulence_fields%get_field('wvar', wvar)
+ call turbulence_fields%get_field('dsldzm', dsldzm)
+ call turbulence_fields%get_field('mix_len_bm', mix_len_bm)
+ else if (bl_scheme == bl_scheme_1a) then
+ call turbulence_fields%get_field('rhokm_bl', rhokm_bl)
+ if (bdy_tke /= bdy_tke_deardorff) then
+ call turbulence_fields%get_field('tsq_bl', tsq_bl)
+ call turbulence_fields%get_field('qsq_bl', qsq_bl)
+ call turbulence_fields%get_field('cov_bl', cov_bl)
+ end if
+ if (shcu_buoy) then
+ call turbulence_fields%get_field('zhpar_shcu', zhpar_shcu)
+ end if
+ end if
! Set turbulence fields to fixed values for use in SCM testing
! or when no values is provided by the um2lfric dump
@@ -85,7 +106,6 @@ contains
setval_c(z_lcl, 0.0_r_def), &
int_setval_c(ntml, 1_i_def), &
int_setval_c(cumulus, 0_i_def), &
- setval_c(wvar, 0.0_r_def), &
setval_c(heat_flux_bl, 0.0_r_def), &
setval_c(moist_flux_bl, 0.0_r_def), &
setval_c(tke_bl, 0.0_r_def), &
@@ -100,9 +120,23 @@ contains
setval_c(ent_we_lim_dsc, 0.0_r_def), &
setval_c(ent_t_frac_dsc, 0.0_r_def), &
setval_c(ent_zrzi_dsc, 0.0_r_def), &
- setval_c(dsldzm, 0.0_r_def), &
- setval_c(mix_len_bm, 0.0_r_def), &
setval_c(gradrinr, 0.0_r_def) )
+
+ if (bl_scheme == bl_scheme_9c) then
+ call invoke( setval_c(wvar, 0.0_r_def), &
+ setval_c(dsldzm, 0.0_r_def), &
+ setval_c(mix_len_bm, 0.0_r_def) )
+ else if (bl_scheme == bl_scheme_1a) then
+ call invoke( setval_c(rhokm_bl, 0.0_r_def) )
+ if (bdy_tke /= bdy_tke_deardorff) then
+ call invoke( setval_c(tsq_bl, 0.0_r_def), &
+ setval_c(qsq_bl, 0.0_r_def), &
+ setval_c(cov_bl, 0.0_r_def) )
+ end if
+ if (shcu_buoy) then
+ call invoke( setval_c(zhpar_shcu, 0.0_r_def) )
+ end if
+ end if
end subroutine init_turbulence_fields_alg
diff --git a/interfaces/physics_schemes_interface/source/diagnostics/bl_exp1a_diags_mod.f90 b/interfaces/physics_schemes_interface/source/diagnostics/bl_exp1a_diags_mod.f90
new file mode 100644
index 0000000000..c2dba8c7fe
--- /dev/null
+++ b/interfaces/physics_schemes_interface/source/diagnostics/bl_exp1a_diags_mod.f90
@@ -0,0 +1,203 @@
+!-------------------------------------------------------------------------------
+! (C) Crown copyright Met Office. All rights reserved.
+! The file LICENCE, distributed with this code, contains details of the terms
+! under which the code may be used.
+!-------------------------------------------------------------------------------
+!> @brief Processes diagnostics for bl_exp1a_alg
+
+module bl_exp1a_diags_mod
+
+ use constants_mod, only: l_def
+ use field_mod, only: field_type
+ use integer_field_mod, only: integer_field_type
+ use timing_mod, only: start_timing, stop_timing, tik, LPROF
+ use initialise_diagnostics_mod, only : init_diag => init_diagnostic_field
+
+ implicit none
+
+ private
+
+ ! Logical indicating whether diagnostics are requested
+ logical( l_def ) :: master_length_flag
+ logical( l_def ) :: rhogamu_bl_flag
+ logical( l_def ) :: rhogamv_bl_flag
+ logical( l_def ) :: rhogamt_bl_flag
+ logical( l_def ) :: rhogamq_bl_flag
+ logical( l_def ) :: tke_shr_prod_flag
+ logical( l_def ) :: tke_boy_prod_flag
+ logical( l_def ) :: tke_dissp_flag
+ logical( l_def ) :: sm25_flag
+ logical( l_def ) :: sh25_flag
+ logical( l_def ) :: dbdz_flag
+ logical( l_def ) :: dvdzm_flag
+
+ public :: initialise_diags_for_bl_exp1a
+ public :: output_diags_for_bl_exp1a
+
+contains
+
+ !> @brief Initialise fields for locally-computed diagnostics
+ !> @param[in,out] master_length Turbulent length scale
+ !> @param[in,out] rhokm_bl Momentum eddy diffusivity on BL levels
+ !> @param[in,out] rhokh_bl Heat eddy diffusivity on BL levels
+ !> @param[in,out] rhogamu_bl Counter Gradient Flux Term for U
+ !> @param[in,out] rhogamv_bl Counter Gradient Flux Term for V
+ !> @param[in,out] rhogamt_bl Counter Gradient Flux Term for tl
+ !> @param[in,out] rhogamq_bl Counter Gradient Flux Term for qt
+ !> @param[in,out] tke_shr_prod Production rate of TKE by shear
+ !> @param[in,out] tke_boy_prod Production rate of TKE by buoyancy
+ !> @param[in,out] tke_dissp Dissipation rate of TKE
+ !> @param[in,out] sm25 Stability function for momentum
+ !> @param[in,out] sh25 Stability function for scalar
+ !> @param[in,out] dbdz Vertical gradient of buoyancy
+ !> @param[in,out] dvdzm Modulus of wind shear
+ subroutine initialise_diags_for_bl_exp1a( master_length, &
+ rhogamu_bl, rhogamv_bl, &
+ rhogamt_bl, rhogamq_bl, &
+ tke_shr_prod, tke_boy_prod, &
+ tke_dissp, sm25, sh25, dbdz, dvdzm )
+
+ implicit none
+
+ type( field_type ), intent(inout) :: master_length
+ type( field_type ), intent(inout) :: rhogamu_bl
+ type( field_type ), intent(inout) :: rhogamv_bl
+ type( field_type ), intent(inout) :: rhogamt_bl
+ type( field_type ), intent(inout) :: rhogamq_bl
+ type( field_type ), intent(inout) :: tke_shr_prod
+ type( field_type ), intent(inout) :: tke_boy_prod
+ type( field_type ), intent(inout) :: tke_dissp
+ type( field_type ), intent(inout) :: sm25
+ type( field_type ), intent(inout) :: sh25
+ type( field_type ), intent(inout) :: dbdz
+ type( field_type ), intent(inout) :: dvdzm
+
+ integer( tik ) :: id
+
+ if ( LPROF ) call start_timing( id, 'diags.bl_exp' )
+
+ master_length_flag = init_diag(master_length, 'turbulence__master_length')
+ rhogamu_bl_flag = init_diag(rhogamu_bl, 'turbulence__rhogamu')
+ rhogamv_bl_flag = init_diag(rhogamv_bl, 'turbulence__rhogamv')
+ rhogamt_bl_flag = init_diag(rhogamt_bl, 'turbulence__rhogamt')
+ rhogamq_bl_flag = init_diag(rhogamq_bl, 'turbulence__rhogamq')
+ tke_shr_prod_flag = init_diag(tke_shr_prod, 'turbulence__tke_shr_prod')
+ tke_boy_prod_flag = init_diag(tke_boy_prod, 'turbulence__tke_boy_prod')
+ tke_dissp_flag = init_diag(tke_dissp, 'turbulence__tke_dissp')
+ sm25_flag = init_diag(sm25, 'turbulence__sm25')
+ sh25_flag = init_diag(sh25, 'turbulence__sh25')
+ dbdz_flag = init_diag(dbdz, 'turbulence__dbdz')
+ dvdzm_flag = init_diag(dvdzm, 'turbulence__dvdzm')
+
+ if ( LPROF ) call stop_timing( id, 'diags.bl_exp' )
+
+ end subroutine initialise_diags_for_bl_exp1a
+
+ !> @brief Output diagnostics from bl_exp1a_alg
+ !> @param[in] ntml Number of turbulently mixed levels
+ !> @param[in] cumulus Cumulus flag (true/false)
+ !> @param[in] bl_type_ind Diagnosed BL types
+ !> @param[in] tke_bl Turbulent kinetic energy (m2 s-2)
+ !> @param[in] tsq_bl Self covariant of tl'
+ !> @param[in] qsq_bl Self covariant of qw'
+ !> @param[in] cov_bl Correlation between tl' and qw'
+ !> @param[in] master_length Turbulent length scale
+ !> @param[in] gradrinr Gradient Richardson number in wth
+ !> @param[in] rhokm_bl Momentum eddy diffusivity on BL levels
+ !> @param[in] rhokh_bl Heat eddy diffusivity on BL levels
+ !> @param[in] rhogamu_bl Counter Gradient Flux Term for U
+ !> @param[in] rhogamv_bl Counter Gradient Flux Term for V
+ !> @param[in] rhogamt_bl Counter Gradient Flux Term for tl
+ !> @param[in] rhogamq_bl Counter Gradient Flux Term for qt
+ !> @param[in] tke_shr_prod Production rate of TKE by shear
+ !> @param[in] tke_boy_prod Production rate of TKE by buoyancy
+ !> @param[in] tke_dissp Dissipation rate of TKE
+ !> @param[in] sm25 Stability function for momentum
+ !> @param[in] sh25 Stability function for scalar
+ !> @param[in] dbdz Vertical gradient of buoyancy
+ !> @param[in] dvdzm Modulus of wind shear
+ !> @param[in] dtrdz_tq_bl dt/(rho*r*r*dz) in wth
+ !> @param[in] rdz_tq_bl 1/dz in w3
+ subroutine output_diags_for_bl_exp1a(ntml, cumulus, bl_type_ind, &
+ tke_bl, tsq_bl, qsq_bl, cov_bl, &
+ master_length, gradrinr, &
+ rhokm_bl, rhokh_bl, &
+ rhogamu_bl, rhogamv_bl, &
+ rhogamt_bl, rhogamq_bl, &
+ tke_shr_prod, tke_boy_prod, tke_dissp, &
+ sm25, sh25, dbdz, dvdzm, &
+ dtrdz_tq_bl, rdz_tq_bl)
+
+ implicit none
+
+ ! Prognostic fields to output
+ type( field_type ), intent(in) :: tke_bl, tsq_bl, qsq_bl, cov_bl, &
+ master_length, gradrinr, &
+ rhokm_bl, rhokh_bl, &
+ rhogamu_bl, rhogamv_bl, &
+ rhogamt_bl, rhogamq_bl, &
+ tke_shr_prod, tke_boy_prod, &
+ tke_dissp, &
+ sm25, sh25, dbdz, dvdzm, &
+ dtrdz_tq_bl, rdz_tq_bl
+ type(integer_field_type), intent(in) :: ntml, cumulus, bl_type_ind
+
+ integer( tik ) :: id
+
+ if ( LPROF ) call start_timing( id, 'diags.bl_exp' )
+
+ ! Prognostic fields from turbulence collection
+ call ntml%write_field('turbulence__ntml')
+ call cumulus%write_field('turbulence__cumulus')
+ call bl_type_ind%write_field('turbulence__bl_type_ind')
+ call tke_bl%write_field('turbulence__tke')
+ call tsq_bl%write_field('turbulence__tsq')
+ call qsq_bl%write_field('turbulence__qsq')
+ call cov_bl%write_field('turbulence__cov')
+ call gradrinr%write_field('turbulence__gradrinr')
+ call rhokm_bl%write_field('turbulence__rhokm')
+ call rhokh_bl%write_field('turbulence__rhokh')
+ call dtrdz_tq_bl%write_field('turbulence__dtrdz_tq')
+ call rdz_tq_bl%write_field('turbulence__rdz_tq')
+
+ if (master_length_flag) then
+ call master_length%write_field('turbulence__master_length')
+ end if
+ if (rhogamu_bl_flag) then
+ call rhogamu_bl%write_field('turbulence__rhogamu')
+ end if
+ if (rhogamv_bl_flag) then
+ call rhogamv_bl%write_field('turbulence__rhogamv')
+ end if
+ if (rhogamt_bl_flag) then
+ call rhogamt_bl%write_field('turbulence__rhogamt')
+ end if
+ if (rhogamq_bl_flag) then
+ call rhogamq_bl%write_field('turbulence__rhogamq')
+ end if
+ if (tke_shr_prod_flag) then
+ call tke_shr_prod%write_field('turbulence__tke_shr_prod')
+ end if
+ if (tke_boy_prod_flag) then
+ call tke_boy_prod%write_field('turbulence__tke_boy_prod')
+ end if
+ if (tke_dissp_flag) then
+ call tke_dissp%write_field('turbulence__tke_dissp')
+ end if
+ if (sm25_flag) then
+ call sm25%write_field('turbulence__sm25')
+ end if
+ if (sh25_flag) then
+ call sh25%write_field('turbulence__sh25')
+ end if
+ if (dbdz_flag) then
+ call dbdz%write_field('turbulence__dbdz')
+ end if
+ if (dvdzm_flag) then
+ call dvdzm%write_field('turbulence__dvdzm')
+ end if
+
+ if ( LPROF ) call stop_timing( id, 'diags.bl_exp' )
+
+ end subroutine output_diags_for_bl_exp1a
+end module bl_exp1a_diags_mod
diff --git a/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_du_kernel_mod.F90 b/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_du_kernel_mod.F90
new file mode 100644
index 0000000000..750c2c50f0
--- /dev/null
+++ b/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_du_kernel_mod.F90
@@ -0,0 +1,246 @@
+!-----------------------------------------------------------------------------
+! (C) Crown copyright Met Office. All rights reserved.
+! The file LICENCE, distributed with this code, contains details of the terms
+! under which the code may be used.
+!-----------------------------------------------------------------------------
+!> @brief Calculate explicit estimate of turbulent momentum diffusion
+
+module bl_exp1a_du_kernel_mod
+
+ use kernel_mod, only: kernel_type
+ use argument_mod, only: arg_type, func_type, &
+ GH_FIELD, GH_READ, CELL_COLUMN, &
+ ANY_SPACE_1, ANY_SPACE_2, &
+ ANY_SPACE_3, ANY_SPACE_4, &
+ ANY_SPACE_5, ANY_SPACE_6, &
+ ANY_DISCONTINUOUS_SPACE_3, &
+ GH_REAL, GH_WRITE, &
+ GH_SCALAR, GH_INTEGER
+ use constants_mod, only: r_def, i_def, r_bl
+ use fs_continuity_mod, only: W1, W2
+ use kernel_mod, only: kernel_type
+ use nlsizes_namelist_mod, only: bl_levels
+ use jules_surface_config_mod, only: formdrag, formdrag_dist_drag
+ use sci_face_selector_support_mod, only: face_from_face_selector
+
+ implicit none
+
+ private
+
+ !----------------------------------------------------------------------------
+ ! Public types
+ !----------------------------------------------------------------------------
+ !> Kernel metadata type.
+ type, public, extends(kernel_type) :: bl_exp1a_du_kernel_type
+ private
+ type(arg_type) :: meta_args(13) = (/ &
+ arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! nfaces
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), &! tau w3/w2
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_2), &! tau_land 2d w3/w2
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_2), &! tau_ssi 2d w3/w2
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_SPACE_3), &! rhokm wth/w2
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_SPACE_4), &! rdz wth/fd1
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_SPACE_1), &! u_physics w3/w2
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_SPACE_5), &! surf_interp mult w3/w2
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_SPACE_1), &! rhogam w3/w2
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_SPACE_1), &! fd_tau w3/w2
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_SPACE_6), &! sea_current mix w3/w2
+ arg_type(GH_FIELD, GH_INTEGER, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! face_selector_ew
+ arg_type(GH_FIELD, GH_INTEGER, GH_READ, ANY_DISCONTINUOUS_SPACE_3) &! face_selector_ns
+ /)
+ integer :: operates_on = CELL_COLUMN
+ contains
+ procedure, nopass :: bl_exp1a_du_code
+ end type bl_exp1a_du_kernel_type
+
+ !----------------------------------------------------------------------------
+ ! Contained functions/subroutines
+ !----------------------------------------------------------------------------
+ public bl_exp1a_du_code
+
+contains
+
+ !> @brief Code based on the same underlying science as the UM BL scheme
+ !> but designed for cell faces
+ !> @param[in] nlayers The number of layers in a column
+ !> @param[in] nfaces The number of faces to calculate
+ !> @param[in,out] tau Turbulent stress
+ !> @param[in,out] tau_land Wind stress over land
+ !> @param[in,out] tau_ssi Wind stress over sea and sea-ice
+ !> @param[in] rhokm Momentum eddy diffusivity
+ !> @param[in] rdz 1/dz
+ !> @param[in] u_physics Wind in native space at time n
+ !> @param[in] surf_interp Surface variables which need interpolating
+ !> @param[in] rhogam Counter Gradient Term for U or V
+ !> @param[in] fd_tau Stress from turbulent form-drag
+ !> @param[in] sea_current Ocean surface current
+ !> @param[in] face_selector_ew 2D field indicating which W/E faces
+ !! to loop over in this column
+ !> @param[in] face_selector_ns 2D field indicating which N/S faces
+ !! to loop over in this column
+ !> @param[in] ndf_half Number of DOFs per cell for half levels
+ !> @param[in] undf_half Number of unique DOFs for half levels
+ !> @param[in] map_half Dofmap for the cell at the base of the column
+ !> @param[in] ndf_2d Number of DOFs per cell for the 2D space
+ !> @param[in] undf_2d Number of unique DOFs for 2D space
+ !> @param[in] map_2d Dofmap for the cell at the base of the column
+ !> @param[in] ndf_full Number of DOFs per cell for full levels
+ !> @param[in] undf_full Number of unique DOFs for full levels
+ !> @param[in] map_full Dofmap for the cell at the base of the column
+ !> @param[in] ndf_rdz Number of DOFs per cell for rdz space
+ !> @param[in] undf_rdz Number of unique DOFs for rdz space
+ !> @param[in] map_rdz Dofmap for the cell at the base of the column
+ !> @param[in] ndf_surf Number of DOFs per cell for surface space
+ !> @param[in] undf_surf Number of unique DOFs for surface space
+ !> @param[in] map_surf Dofmap for the cell at the base of the column
+ !> @param[in] ndf_curr Number of DOFs per cell for current space
+ !> @param[in] undf_curr Number of unique DOFs for current space
+ !> @param[in] map_curr Dofmap for the cell at the base of the column
+ !> @param[in] ndf_w3_2d Num of DoFs for 2D W3 per cell
+ !> @param[in] undf_w3_2d Num of DoFs for this partition for 2D W3
+ !> @param[in] map_w3_2d Map for 2D W3
+ subroutine bl_exp1a_du_code(nlayers, &
+ nfaces, &
+ tau, &
+ tau_land, &
+ tau_ssi, &
+ rhokm, &
+ rdz, &
+ u_physics, &
+ surf_interp, &
+ rhogam, &
+ fd_tau, &
+ sea_current, &
+ face_selector_ew, &
+ face_selector_ns, &
+ ndf_half, &
+ undf_half, &
+ map_half, &
+ ndf_2d, &
+ undf_2d, &
+ map_2d, &
+ ndf_full, &
+ undf_full, &
+ map_full, &
+ ndf_rdz, &
+ undf_rdz, &
+ map_rdz, &
+ ndf_surf, &
+ undf_surf, &
+ map_surf, &
+ ndf_curr, &
+ undf_curr, &
+ map_curr, &
+ ndf_w3_2d, &
+ undf_w3_2d, &
+ map_w3_2d )
+
+ !---------------------------------------
+ ! UM modules containing switches or global constants
+ !---------------------------------------
+ use mym_ex_flux_uv_mod, only: mym_ex_flux_uv
+ use atm_fields_bounds_mod, only: pdims
+
+ implicit none
+
+ ! Arguments
+ integer, intent(in) :: nlayers, nfaces
+
+ integer(kind=i_def), intent(in) :: ndf_half, undf_half
+ integer(kind=i_def), intent(in) :: map_half(ndf_half)
+ integer(kind=i_def), intent(in) :: ndf_2d, undf_2d
+ integer(kind=i_def), intent(in) :: map_2d(ndf_2d)
+ integer(kind=i_def), intent(in) :: ndf_curr, undf_curr
+ integer(kind=i_def), intent(in) :: map_curr(ndf_curr)
+ integer(kind=i_def), intent(in) :: ndf_rdz, undf_rdz
+ integer(kind=i_def), intent(in) :: map_rdz(ndf_rdz)
+ integer(kind=i_def), intent(in) :: ndf_full, undf_full
+ integer(kind=i_def), intent(in) :: map_full(ndf_full)
+ integer(kind=i_def), intent(in) :: ndf_surf, undf_surf
+ integer(kind=i_def), intent(in) :: map_surf(ndf_surf)
+ integer(kind=i_def), intent(in) :: ndf_w3_2d, undf_w3_2d
+ integer(kind=i_def), intent(in) :: map_w3_2d(ndf_w3_2d)
+
+ real(kind=r_def), dimension(undf_half), intent(inout) :: tau
+ real(kind=r_def), dimension(undf_2d), intent(inout) :: tau_land, tau_ssi
+
+ real(kind=r_def), dimension(undf_half), intent(in) :: u_physics, fd_tau, &
+ rhogam
+ real(kind=r_def), dimension(undf_full), intent(in) :: rhokm
+ real(kind=r_def), dimension(undf_rdz), intent(in) :: rdz
+ real(kind=r_def), dimension(undf_surf), intent(in) :: surf_interp
+ real(kind=r_def), dimension(undf_curr), intent(in) :: sea_current
+
+ integer(kind=i_def), dimension(undf_w3_2d), intent(in) :: face_selector_ew
+ integer(kind=i_def), dimension(undf_w3_2d), intent(in) :: face_selector_ns
+
+ ! Internal variables
+ integer(kind=i_def) :: df, k, j, total_faces
+ real(kind=r_bl) :: rhokm_land, rhokm_ssi, fland, flandfac, fseafac
+ real(kind=r_bl), dimension(0:bl_levels-1) :: tau_grad, tau_count_grad, &
+ u_sp, rdz_sp, rhokm_sp, rhogam_sp, tau_sp, fd_tau_sp
+
+ if (nfaces == 1) then
+ total_faces = 1
+ else
+ total_faces = ABS(face_selector_ew(map_w3_2d(1))) + ABS(face_selector_ns(map_w3_2d(1)))
+ end if
+
+ ! loop over all faces of the cell
+ do j = 1, total_faces
+ df = face_from_face_selector(j, face_selector_ew(map_w3_2d(1)), face_selector_ns(map_w3_2d(1)))
+ df = MIN(df, nfaces) ! Ensures this works for W3
+
+ !================================================================
+ ! In the UM this happens in bdy_expl3
+ !================================================================
+ fland = surf_interp(map_surf(df) + 0)
+ rhokm_land = surf_interp(map_surf(df) + 1)
+ rhokm_ssi = surf_interp(map_surf(df) + 2)
+ flandfac = surf_interp(map_surf(df) + 3)
+ fseafac = surf_interp(map_surf(df) + 4)
+
+ do k = 0, bl_levels-1
+ u_sp(k) = u_physics(map_half(df)+k)
+ rdz_sp(k) = rdz(map_rdz(df)+k)
+ rhokm_sp(k) = rhokm(map_full(df)+k)
+ rhogam_sp(k) = rhogam(map_half(df)+k)
+ fd_tau_sp(k) = fd_tau(map_half(df)+k)
+ tau_sp(k) = tau(map_half(df)+k)
+ end do
+
+ tau_land(map_2d(df)) = rhokm_land * u_sp(0) * flandfac
+
+ ! If sea surface current (sea_current) has not been obtained
+ ! from coupling fields or from an ancillary file then it will simply
+ ! contain uniform zeros.
+ tau_ssi(map_2d(df)) = rhokm_ssi * &
+ (u_sp(0) - sea_current(map_curr(df))) * fseafac
+ tau_sp(0) = fland * tau_land(map_2d(df)) &
+ + (1.0_r_bl - fland) * tau_ssi(map_2d(df))
+
+ if (formdrag == formdrag_dist_drag) then
+ if (fland > 0.0_r_bl) then
+ tau_land(map_2d(df)) = tau_land(map_2d(df)) &
+ + fd_tau(map_half(df)) / fland
+ end if
+ end if
+
+ call mym_ex_flux_uv(pdims, pdims, pdims, bl_levels, &
+ rdz_sp(1), &
+ rhokm_sp, &
+ rhogam_sp, &
+ u_sp, &
+ fd_tau_sp, &
+ tau_sp, &
+ tau_grad, tau_count_grad)
+
+ do k = 0, bl_levels-1
+ tau(map_half(df)+k) = tau_sp(k)
+ end do
+
+ end do ! loop over df
+
+ end subroutine bl_exp1a_du_code
+
+end module bl_exp1a_du_kernel_mod
diff --git a/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90 b/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90
new file mode 100644
index 0000000000..98ea4eb02f
--- /dev/null
+++ b/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90
@@ -0,0 +1,1235 @@
+!-----------------------------------------------------------------------------
+! (C) Crown copyright Met Office. All rights reserved.
+! The file LICENCE, distributed with this code, contains details of the terms
+! under which the code may be used.
+!-----------------------------------------------------------------------------
+!> @brief Interface to the UM High Order Turbulence Closure Scheme.
+module bl_exp1a_kernel_mod
+
+ use argument_mod, only: arg_type, &
+ GH_FIELD, GH_REAL, &
+ GH_INTEGER, &
+ GH_READ, GH_WRITE, &
+ GH_READWRITE, DOMAIN, &
+ ANY_DISCONTINUOUS_SPACE_1, &
+ ANY_DISCONTINUOUS_SPACE_2, &
+ ANY_DISCONTINUOUS_SPACE_3, &
+ ANY_DISCONTINUOUS_SPACE_4
+ use constants_mod, only: i_def, i_um, r_def, r_um, r_bl
+ use empty_data_mod, only: empty_real_data
+ use fs_continuity_mod, only: W3, Wtheta
+ use kernel_mod, only: kernel_type
+ use mixing_config_mod, only: smagorinsky, fullstress
+ use blayer_config_mod, only: shcu_buoy, bdy_tke, bdy_tke_deardorff
+ use mym_option_mod, only: tke_levels
+ use microphysics_config_mod, only: prog_tnuc
+ use jules_surface_config_mod, only: formdrag, formdrag_dist_drag
+
+ implicit none
+
+ private
+
+ !-----------------------------------------------------------------------------
+ ! Public types
+ !-----------------------------------------------------------------------------
+ !> Kernel metadata type.
+ !>
+ type, public, extends(kernel_type) :: bl_exp1a_kernel_type
+ private
+ type(arg_type) :: meta_args(82) = (/ &
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! theta_in_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! rho_in_w3
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! rho_in_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! wetrho_in_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! exner_in_w3
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! exner_in_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! u_in_w3
+ arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! v_in_w3
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! w_in_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! m_v_n
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! m_cl_n
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! m_ci_n
+ arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! height_w3
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! height_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! dz_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! rdz_w3
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! dtrdz_wth
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! shear_3d
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! delta
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, ANY_DISCONTINUOUS_SPACE_1),&! zh_2d
+ arg_type(GH_FIELD, GH_INTEGER, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! ntml_2d
+ arg_type(GH_FIELD, GH_INTEGER, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! cumulus_2d
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_2),&! tile_fraction
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1),&! sd_orog_2d
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1),&! peak_to_trough_orog
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1),&! silhouette_area_orog
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_2),&! tile_temperature
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! cf_bulk
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! cf_liquid
+ arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! tnuc
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINuOUS_SPACE_1),&! tnuc_nlcl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! visc_m_blend
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! visc_h_blend
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! dw_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, WTHETA), &! rhokm_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, ANY_DISCONTINUOUS_SPACE_3),&! surf_interp
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, W3), &! rhokh_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, WTHETA), &! tke_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, WTHETA), &! tsq_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, WTHETA), &! qsq_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, WTHETA), &! cov_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, ANY_DISCONTINUOUS_SPACE_1),&! zhpar_shcu_2d
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! rhogamu_w3
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! rhogamv_w3
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! bq_bl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! bt_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, W3), &! moist_flux_bl
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, W3), &! heat_flux_bl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! dtrdz_tq_bl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! fd_taux
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! fd_tauy
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1),&! sea_u_current
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1),&! sea_v_current
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! master_length
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, WTHETA), &! gradrinr
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! rhogamu_bl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! rhogamv_bl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! rhogamt_bl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! rhogamq_bl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! tke_shr_prod
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! tke_boy_prod
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! tke_dissp
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! sm25
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! sh25
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! dbdz
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! dvdzm
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1),&! z0m_eff
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1),&! ustar
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! z_lcl
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! inv_depth
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! qcl_at_inv_top
+ arg_type(GH_FIELD, GH_INTEGER, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! shallow_flag
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! uw0_flux
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! vw0_flux
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! lcl_height
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! parcel_top
+ arg_type(GH_FIELD, GH_INTEGER, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! level_parcel_top
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! wstar_2d
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! thv_flux
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! parcel_buoyancy
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_DISCONTINUOUS_SPACE_1),&! qsat_at_lcl
+ arg_type(GH_FIELD, GH_INTEGER, GH_WRITE, ANY_DISCONTINUOUS_SPACE_4) &! bl_type_ind
+ /)
+ integer :: operates_on = DOMAIN
+ contains
+ procedure, nopass :: bl_exp1a_code
+ end type
+
+ public :: bl_exp1a_code
+
+contains
+
+ !> @brief Interface to the UM High Order Turbulence Closure Scheme
+ !> @details The UM Boundary Layer scheme does:
+ !> vertical mixing of heat, momentum and moisture,
+ !> as documented in UMDP25
+ !> @param[in] nlayers Number of layers
+ !> @param[in] theta_in_wth Potential temperature field
+ !> @param[in] rho_in_w3 Density field in density space
+ !> @param[in] rho_in_wth Density field in theta space
+ !> @param[in] wetrho_in_wth Wet density field in wth space
+ !> @param[in] exner_in_w3 Exner pressure field in density space
+ !> @param[in] exner_in_wth Exner pressure field in wth space
+ !> @param[in] u_in_w3 'Zonal' wind in density space
+ !> @param[in] v_in_w3 'Meridional' wind in density space
+ !> @param[in] w_in_wth 'Vertical' wind in theta space
+ !> @param[in] m_v_n Vapour mixing ratio at time level n
+ !> @param[in] m_cl_n Cloud liquid mixing ratio at time level n
+ !> @param[in] m_ci_n Cloud ice mixing ratio at time level n
+ !> @param[in] height_w3 Height of density space above surface
+ !> @param[in] height_wth Height of theta space above surface
+ !> @param[in] dz_wth Layer depths at wtheta points
+ !> @param[in] rdz_w3 Inverse Layer depths at w3 points
+ !> @param[in] dtrdz_wth dt/(rho*r*r*dz) in wth
+ !> @param[in] shear_3d 3D wind shear on wtheta points
+ !> @param[in] delta Edge length on wtheta points
+ !> @param[in,out] zh_2d Boundary layer depth
+ !> @param[in,out] ntml_2d Number of turbulently mixed levels
+ !> @param[in,out] cumulus_2d Cumulus flag (true/false)
+ !> @param[in] tile_fraction Surface tile fractions
+ !> @param[in] sd_orog_2d Standard deviation of orography
+ !> @param[in] peak_to_trough_orog Half of peak-to-trough height over root(2) of orography
+ !> @param[in] silhouette_area_orog Silhouette area of orography
+ !> @param[in] tile_temperature Surface tile temperatures
+ !> @param[in] cf_bulk Bulk cloud fraction
+ !> @param[in] cf_liquid Liquid cloud fraction
+ !> @param[in] tnuc Temperature of nucleation (K)
+ !> @param[in,out] tnuc_nlcl Temperature of nucleation (K) (2D)
+ !> @param[in,out] visc_m_blend Blended BL-Smag diffusion coefficient for momentum
+ !> @param[in,out] visc_h_blend Blended BL-Smag diffusion coefficient for scalars
+ !> @param[in,out] dw_bl Vertical wind increment from BL scheme
+ !> @param[in,out] rhokm_bl Momentum eddy diffusivity on BL levels
+ !> @param[in,out] surf_interp Surface variables for regridding
+ !> @param[in,out] rhokh_bl Heat eddy diffusivity on BL levels
+ !> @param[in,out] tke_bl Turbulent kinetic energy (m2 s-2)
+ !> @param[in,out] tsq_bl Self covariant of tl'
+ !> @param[in,out] qsq_bl Self covariant of qw'
+ !> @param[in,out] cov_bl Correlation between tl' and qw'
+ !> @param[in,out] zhpar_shcu_2d Mixed layer height for non-gradient buoyancy flux
+ !> @param[in,out] rhogamu_w3 Counter Gradient Flux Term for U
+ !> @param[in,out] rhogamv_w3 Counter Gradient Flux Term for V
+ !> @param[in,out] bq_bl Buoyancy parameter for moisture
+ !> @param[in,out] bt_bl Buoyancy parameter for heat
+ !> @param[in,out] moist_flux_bl Vertical moisture flux on BL levels
+ !> @param[in,out] heat_flux_bl Vertical heat flux on BL levels
+ !> @param[in,out] dtrdz_tq_bl dt/(rho*r*r*dz) in wth
+ !> @param[in,out] fd_taux 'Zonal' momentum stress from form drag
+ !> @param[in,out] fd_tauy 'Meridional' momentum stress from form drag
+ !> @param[in] sea_u_current Ocean surface U current
+ !> @param[in] sea_v_current Ocean surface V current
+ !> @param[in,out] master_length Turbulence length scale in wth
+ !> @param[in,out] gradrinr Gradient Richardson number in wth
+ !> @param[in,out] rhogamu_bl Counter Gradient Flux Term for U
+ !> @param[in,out] rhogamv_bl Counter Gradient Flux Term for V
+ !> @param[in,out] rhogamt_bl Counter Gradient Flux Term for tl
+ !> @param[in,out] rhogamq_bl Counter Gradient Flux Term for qt
+ !> @param[in,out] tke_shr_prod Production rate of TKE by shear
+ !> @param[in,out] tke_boy_prod Production rate of TKE by buoyancy
+ !> @param[in,out] tke_dissp Dissipation rate of TKE
+ !> @param[in,out] sm25 Stability function for momentum
+ !> @param[in,out] sh25 Stability function for scalar
+ !> @param[in,out] dbdz Vertical gradient of buoyancy
+ !> @param[in,out] dvdzm Modulus of wind shear
+ !> @param[in] z0m_eff Grid mean effective roughness length
+ !> @param[in] ustar Friction velocity
+ !> @param[in,out] z_lcl Height of the LCL (wtheta levels)
+ !> @param[in,out] inv_depth Depth of BL top inversion layer
+ !> @param[in,out] qcl_at_inv_top Cloud water at top of inversion
+ !> @param[in,out] shallow_flag Indicator of shallow convection
+ !> @param[in,out] uw0_flux 'Zonal' surface momentum flux
+ !> @param[in,out] vw0 flux 'Meridional' surface momentum flux
+ !> @param[in,out] lcl_height Height of lifting condensation level (w3 levels)
+ !> @param[in,out] parcel_top Height of surface based parcel ascent
+ !> @param[in,out] level_parcel_top Model level of parcel_top
+ !> @param[in,out] wstar_2d BL velocity scale
+ !> @param[in,out] thv_flux Surface flux of theta_v
+ !> @param[in,out] parcel_buoyancy Integral of parcel buoyancy
+ !> @param[in,out] qsat_at_lcl Saturation specific hum at LCL
+ !> @param[in,out] bl_type_ind Diagnosed BL types
+ !> @param[in] ndf_wth Number of DOFs per cell for potential temperature space
+ !> @param[in] undf_wth Number of unique DOFs for potential temperature space
+ !> @param[in] map_wth Dofmap for the cell at the base of the column for potential temperature space
+ !> @param[in] ndf_w3 Number of DOFs per cell for density space
+ !> @param[in] undf_w3 Number of unique DOFs for density space
+ !> @param[in] map_w3 Dofmap for the cell at the base of the column for density space
+ !> @param[in] ndf_2d Number of DOFs per cell for 2D fields
+ !> @param[in] undf_2d Number of unique DOFs for 2D fields
+ !> @param[in] map_2d Dofmap for the cell at the base of the column for 2D fields
+ !> @param[in] ndf_tile Number of DOFs per cell for tiles
+ !> @param[in] undf_tile Number of total DOFs for tiles
+ !> @param[in] map_tile Dofmap for cell for surface tiles
+ !> @param[in] ndf_surf Number of DOFs per cell for surface variables
+ !> @param[in] undf_surf Number of unique DOFs for surface variables
+ !> @param[in] map_surf Dofmap for the cell at the base of the column for surface variables
+ !> @param[in] ndf_bl Number of DOFs per cell for BL types
+ !> @param[in] undf_bl Number of total DOFs for BL types
+ !> @param[in] map_bl Dofmap for cell for BL types
+ subroutine bl_exp1a_code(nlayers, seg_len, &
+ theta_in_wth, &
+ rho_in_w3, &
+ rho_in_wth, &
+ wetrho_in_wth, &
+ exner_in_w3, &
+ exner_in_wth, &
+ u_in_w3, &
+ v_in_w3, &
+ w_in_wth, &
+ m_v_n, &
+ m_cl_n, &
+ m_ci_n, &
+ height_w3, &
+ height_wth, &
+ dz_wth, &
+ rdz_w3, &
+ dtrdz_wth, &
+ shear_3d, &
+ delta, &
+ zh_2d, &
+ ntml_2d, &
+ cumulus_2d, &
+ tile_fraction, &
+ sd_orog_2d, &
+ peak_to_trough_orog, &
+ silhouette_area_orog, &
+ tile_temperature, &
+ cf_bulk, &
+ cf_liquid, &
+ tnuc, &
+ tnuc_nlcl, &
+ visc_m_blend, &
+ visc_h_blend, &
+ dw_bl, &
+ rhokm_bl, &
+ surf_interp, &
+ rhokh_bl, &
+ tke_bl, &
+ tsq_bl, &
+ qsq_bl, &
+ cov_bl, &
+ zhpar_shcu_2d, &
+ rhogamu_w3, &
+ rhogamv_w3, &
+ bq_bl, &
+ bt_bl, &
+ moist_flux_bl, &
+ heat_flux_bl, &
+ dtrdz_tq_bl, &
+ fd_taux, &
+ fd_tauy, &
+ sea_u_current, &
+ sea_v_current, &
+ master_length, &
+ gradrinr, &
+ rhogamu_bl, &
+ rhogamv_bl, &
+ rhogamt_bl, &
+ rhogamq_bl, &
+ tke_shr_prod, &
+ tke_boy_prod, &
+ tke_dissp, &
+ sm25, &
+ sh25, &
+ dbdz, &
+ dvdzm, &
+ z0m_eff, &
+ ustar, &
+ z_lcl, &
+ inv_depth, &
+ qcl_at_inv_top, &
+ shallow_flag, &
+ uw0_flux, &
+ vw0_flux, &
+ lcl_height, &
+ parcel_top, &
+ level_parcel_top, &
+ wstar_2d, &
+ thv_flux, &
+ parcel_buoyancy, &
+ qsat_at_lcl, &
+ bl_type_ind, &
+ ndf_wth, undf_wth, map_wth, &
+ ndf_w3, undf_w3, map_w3, &
+ ndf_2d, undf_2d, map_2d, &
+ ndf_tile, undf_tile, map_tile, &
+ ndf_surf, undf_surf, map_surf, &
+ ndf_bl, undf_bl, map_bl)
+
+ !---------------------------------------
+ ! LFRic modules
+ !---------------------------------------
+ use jules_control_init_mod, only: n_surf_tile
+
+ !---------------------------------------
+ ! UM modules containing switches or global constants
+ !---------------------------------------
+ use atm_fields_bounds_mod, only: pdims
+ use bl_option_mod, only: alpha_cd, l_noice_in_turb, l_use_surf_in_ri
+ use cv_run_mod, only: i_convection_vn, i_convection_vn_6a, &
+ cldbase_opt_dp, cldbase_opt_md
+ use nlsizes_namelist_mod, only: bl_levels
+ use planet_constants_mod, only: p_zero, kappa, planet_radius, &
+ lcrcp => lcrcp_bl, lsrcp => lsrcp_bl
+
+ use wtrac_atm_step_mod, only: atm_step_wtrac_type
+
+ ! subroutines used
+ use atmos_physics2_save_restore_mod, only: ap2_init_conv_diag
+ use bl_diags_mod, only: BL_diag, dealloc_bl_imp, dealloc_bl_expl, &
+ alloc_bl_expl
+ use conv_diag_6a_mod, only: conv_diag_6a
+ use buoy_tq_mod, only: buoy_tq
+ use bdy_expl2_1a_mod, only: bdy_expl2_1a
+ use tr_mix_mod, only: tr_mix
+
+ implicit none
+
+ ! Arguments
+ integer(kind=i_def), intent(in) :: nlayers, seg_len
+ integer(kind=i_def), intent(in) :: ndf_wth, undf_wth
+ integer(kind=i_def), intent(in) :: ndf_w3, undf_w3
+ integer(kind=i_def), intent(in) :: ndf_2d, undf_2d
+ integer(kind=i_def), intent(in) :: map_wth(ndf_wth, seg_len)
+ integer(kind=i_def), intent(in) :: map_w3(ndf_w3, seg_len)
+ integer(kind=i_def), intent(in) :: map_2d(ndf_2d, seg_len)
+
+ integer(kind=i_def), intent(in) :: ndf_tile, undf_tile
+ integer(kind=i_def), intent(in) :: map_tile(ndf_tile, seg_len)
+
+ integer(kind=i_def), intent(in) :: ndf_surf, undf_surf, ndf_bl, undf_bl
+ integer(kind=i_def), intent(in) :: map_surf(ndf_surf, seg_len)
+ integer(kind=i_def), intent(in) :: map_bl(ndf_bl, seg_len)
+
+ real(kind=r_def), dimension(undf_wth), intent(inout):: dw_bl, &
+ visc_h_blend, &
+ visc_m_blend, &
+ rhokm_bl, &
+ tke_bl, &
+ tsq_bl, &
+ qsq_bl, &
+ cov_bl, &
+ bq_bl, bt_bl, &
+ dtrdz_tq_bl, &
+ gradrinr
+ real(kind=r_def), dimension(undf_w3), intent(inout):: rho_in_w3, &
+ rhokh_bl, &
+ moist_flux_bl, &
+ heat_flux_bl, &
+ fd_taux, fd_tauy, &
+ rhogamu_w3, &
+ rhogamv_w3
+ real(kind=r_def), dimension(undf_w3), intent(in) :: exner_in_w3, &
+ u_in_w3, v_in_w3, &
+ height_w3, rdz_w3
+ real(kind=r_def), dimension(undf_wth), intent(in) :: theta_in_wth, &
+ rho_in_wth, &
+ wetrho_in_wth, &
+ exner_in_wth, &
+ w_in_wth, &
+ m_v_n, m_cl_n, &
+ m_ci_n, &
+ height_wth, &
+ dz_wth, &
+ dtrdz_wth, &
+ shear_3d, delta, &
+ cf_bulk, cf_liquid, &
+ tnuc
+ real(kind=r_def), dimension(undf_2d), intent(inout) :: zh_2d, &
+ zhpar_shcu_2d, &
+ z0m_eff, &
+ ustar, &
+ z_lcl, &
+ inv_depth, &
+ qcl_at_inv_top, &
+ uw0_flux, &
+ vw0_flux, &
+ lcl_height, &
+ parcel_top, &
+ wstar_2d, &
+ thv_flux, &
+ parcel_buoyancy, &
+ qsat_at_lcl, &
+ tnuc_nlcl
+ integer(kind=i_def), dimension(undf_2d), intent(inout) :: ntml_2d, &
+ cumulus_2d, &
+ shallow_flag, &
+ level_parcel_top
+ real(kind=r_def), dimension(undf_2d), intent(in) :: sea_u_current, &
+ sea_v_current
+
+ real(kind=r_def), intent(in) :: tile_fraction(undf_tile)
+ real(kind=r_def), intent(in) :: tile_temperature(undf_tile)
+ real(kind=r_def), intent(in) :: sd_orog_2d(undf_2d)
+ real(kind=r_def), intent(in) :: peak_to_trough_orog(undf_2d)
+ real(kind=r_def), intent(in) :: silhouette_area_orog(undf_2d)
+
+ integer(kind=i_def), dimension(undf_bl), intent(inout) :: bl_type_ind
+ real(kind=r_def), dimension(undf_surf), intent(inout) :: surf_interp
+
+ real(kind=r_def), pointer, intent(inout) :: master_length(:)
+ real(kind=r_def), pointer, intent(inout) :: rhogamu_bl(:)
+ real(kind=r_def), pointer, intent(inout) :: rhogamv_bl(:)
+ real(kind=r_def), pointer, intent(inout) :: rhogamt_bl(:)
+ real(kind=r_def), pointer, intent(inout) :: rhogamq_bl(:)
+ real(kind=r_def), pointer, intent(inout) :: tke_shr_prod(:)
+ real(kind=r_def), pointer, intent(inout) :: tke_boy_prod(:)
+ real(kind=r_def), pointer, intent(inout) :: tke_dissp(:)
+ real(kind=r_def), pointer, intent(inout) :: sm25(:)
+ real(kind=r_def), pointer, intent(inout) :: sh25(:)
+ real(kind=r_def), pointer, intent(inout) :: dbdz(:)
+ real(kind=r_def), pointer, intent(inout) :: dvdzm(:)
+ !-----------------------------------------------------------------------
+ ! Local variables for the kernel
+ !-----------------------------------------------------------------------
+ integer(i_def) :: k, i, l, n, land_field
+
+ ! local switches and scalars
+ integer(i_um) :: error_code
+ real(r_bl) :: weight1, weight2, weight3
+ logical :: l_spec_z0, l_cape_opt
+
+ ! profile fields from level 1 upwards
+ real(r_bl), dimension(seg_len,1,nlayers) :: z_rho, z_theta, &
+ bulk_cloud_fraction, rho_wet_tq, u_p, v_p, theta, &
+ p_rho_levels, exner_rho_levels, &
+ exner_theta_levels, &
+ bulk_cf_conv, qcf_conv, tnuc_new
+ ! Single precision is not accurate enough for distance from centre of planet
+ real(r_um), dimension(seg_len,1,nlayers) :: r_rho_levels
+
+ ! profile field on boundary layer levels
+ real(r_bl), dimension(seg_len,1,bl_levels) :: fqw, ftl, rhokh, bq_gb, &
+ bt_gb, rdz_charney_grid, &
+ temperature, qw, tl, bt, bq, &
+ bt_cld, bq_cld, a_qs, a_dqsdt, dqsdt, rhokm, tau_fd_x, tau_fd_y, rdz, &
+ shear, visc_m, visc_h, tke_trb, tsq_trb, qsq_trb, cov_trb
+
+ real(r_bl), dimension(seg_len,1,bl_levels+1) :: rho_mix
+
+ real(r_um), dimension(seg_len,1,bl_levels) :: w_mixed, w_flux, &
+ rhokm_mix, &
+ dtrdz_charney_grid
+
+ real(r_bl), dimension(seg_len,1,2:bl_levels) :: rhogamu, rhogamv
+
+ ! profile fields from level 0 upwards
+ real(r_bl), dimension(seg_len,1,0:nlayers) :: p_theta_levels, w, &
+ q, qcl, qcf
+ ! Single precision is not accurate enough for distance from centre of planet
+ real(r_um), dimension(seg_len,1,0:nlayers) :: r_theta_levels
+
+ ! single level real fields
+ real(r_bl), dimension(seg_len,1) :: p_star, tstar, zh_prev, zlcl, zhpar, &
+ zh, dzh, wstar, wthvs, u_0_p, v_0_p, zlcl_uv, qsat_lcl, delthvu, &
+ bl_type_1, bl_type_2, bl_type_3, bl_type_4, bl_type_5, bl_type_6, &
+ bl_type_7, uw0, vw0, &
+ h_blend_orog, flandg, qcl_inv_top, &
+ fb_surf, rib_gb, z0m_eff_gb, zhsc, ustargbm, &
+ delta_smag, tnuc_nlcl_um
+ real(r_um), dimension(seg_len,1) :: surf_dep_flux
+
+ real(r_bl), dimension(seg_len,1,3) :: t_frac, t_frac_dsc, we_lim, &
+ we_lim_dsc, zrzi, zrzi_dsc
+
+ ! single level integer fields
+ integer(i_um), dimension(seg_len,1) :: ntml, ntpar, kent, kent_dsc
+
+ ! single level logical fields
+ logical, dimension(seg_len,1) :: land_sea_mask, cumulus, l_shallow
+
+ ! fields on land points
+ real(r_bl), dimension(:), allocatable :: sil_orog_land_gb, ho2r2_orog_gb, &
+ sd_orog
+
+ ! integer fields on land points
+ integer, dimension(:), allocatable :: land_index
+
+ ! Fields which are not used and only required for subroutine argument list,
+ ! hence are unset in the kernel
+ ! if they become set, please move up to be with other variables
+ integer(i_um), parameter :: nscmdpkgs=15
+ logical, parameter :: l_scmdiags(nscmdpkgs)=.false.
+
+ real(r_bl), dimension(seg_len,1,nlayers) :: rho_wet
+
+ real(r_bl), dimension(seg_len,1,0:nlayers) :: conv_prog_precip
+
+ real(r_bl), dimension(seg_len,1) :: z0h_scm, z0m_scm, w_max, ql_ad, &
+ cin_undilute, cape_undilute, entrain_coef, ustar_in, g_ccp, h_ccp, &
+ ccp_strength, cu_over_orog, shallowc, flux_e, flux_h, &
+ z0msea, tstar_sea, tstar_land, ice_fract, tstar_sice, &
+ zhpar_shcu
+
+ ! single level integer fields
+ integer(i_um), dimension(seg_len,1) :: nlcl, conv_type, nbdsc, ntdsc
+
+ ! single level logical fields
+ logical, dimension(seg_len,1) :: no_cumulus, l_congestus, l_congestus2, &
+ l_mid
+
+ integer, dimension(seg_len,1) :: kent_dummy
+ real(r_um), dimension(seg_len,1) :: zeroes_2d
+ real(r_um), dimension(seg_len,1,3) :: zeroes_ent
+ logical, parameter :: l_extra_call = .false.
+
+ !-----------------------------------------------------------------------
+ ! Mapping of LFRic fields into UM variables
+ !-----------------------------------------------------------------------
+
+ ! Land fraction
+ land_field = 0
+ do i = 1, seg_len
+ flandg(i,1) = surf_interp(map_surf(1,i)+0)
+ if (flandg(i,1) > 0.0_r_bl) then
+ land_field = land_field + 1
+ end if
+ fb_surf(i,1) = surf_interp(map_surf(1,i)+6)
+ end do
+
+ allocate(land_index(land_field))
+ l = 0
+ do i = 1, seg_len
+ if (flandg(i,1) > 0.0_r_bl) then
+ l = l+1
+ land_index(l) = i
+ end if
+ end do
+
+ if (l_use_surf_in_ri) then
+ tstar = 0.0_r_bl
+ do i = 1, seg_len
+ do n = 1, n_surf_tile
+ if (tile_fraction(map_tile(1,i)+n-1) > 0.0_r_bl) then
+ tstar(i,1) = tstar(i,1) + tile_temperature(map_tile(1,i)+n-1) * &
+ tile_fraction(map_tile(1,i)+n-1)
+ end if
+ end do
+ end do
+ end if
+
+ allocate(sd_orog(land_field))
+ allocate(ho2r2_orog_gb(land_field))
+ allocate(sil_orog_land_gb(land_field))
+
+ do l = 1, land_field
+ ! Standard deviation of orography
+ sd_orog(l) = real(sd_orog_2d(map_2d(1,land_index(l))), r_bl)
+ ! Half of peak-to-trough height over root(2) of orography (ho2r2_orog_gb)
+ ho2r2_orog_gb(l) = real(peak_to_trough_orog(map_2d(1,land_index(l))), r_bl)
+ sil_orog_land_gb(l) = real(silhouette_area_orog(map_2d(1,land_index(l))), r_bl)
+ end do
+
+ ! Information passed from Jules explicit
+ do i = 1, seg_len
+ ustargbm(i,1) = ustar(map_2d(1,i))
+ rib_gb(i,1) = gradrinr(map_wth(1,i))
+ z0m_eff_gb(i,1) = z0m_eff(map_2d(1,i))
+ ftl(i,1,1) = heat_flux_bl(map_w3(1,i))
+ fqw(i,1,1) = moist_flux_bl(map_w3(1,i))
+ rhokh(i,1,1) = rhokh_bl(map_w3(1,i))
+ rhokm(i,1,1) = rhokm_bl(map_wth(1,i))
+ end do
+
+ if (prog_tnuc) then
+ ! Use tnuc from LFRic and map onto tnuc_new for UM to be passed to conv_diag_6a
+ do k = 1, nlayers
+ do i = 1, seg_len
+ tnuc_new(i,1,k) = real(tnuc(map_wth(1,i) + k),kind=r_bl)
+ end do ! i
+ end do ! k
+ end if
+
+ !-----------------------------------------------------------------------
+ ! assuming map_wth(1,i) points to level 0
+ ! and map_w3(1,i) points to level 1
+ !-----------------------------------------------------------------------
+ do i = 1, seg_len
+ do k = 0, nlayers
+ ! w wind on theta levels
+ w(i,1,k) = w_in_wth(map_wth(1,i) + k)
+ ! height of theta levels from centre of planet
+ r_theta_levels(i,1,k) = height_wth(map_wth(1,i) + k) + planet_radius
+ p_theta_levels(i,1,k) = p_zero*(exner_in_wth(map_wth(1,i) + k))**(1.0_r_def/kappa)
+ end do
+
+ do k = 1, nlayers
+ exner_theta_levels(i,1,k) = exner_in_wth(map_wth(1,i) + k)
+ ! potential temperature on theta levels
+ theta(i,1,k) = theta_in_wth(map_wth(1,i) + k)
+ ! wet density on theta and rho levels
+ rho_wet_tq(i,1,k) = wetrho_in_wth(map_wth(1,i) + k)
+ ! pressure on rho levels
+ p_rho_levels(i,1,k) = p_zero*(exner_in_w3(map_w3(1,i) + k-1))**(1.0_r_def/kappa)
+ ! exner pressure on rho levels
+ exner_rho_levels(i,1,k) = exner_in_w3(map_w3(1,i) + k-1)
+ ! u wind on rho levels
+ u_p(i,1,k) = u_in_w3(map_w3(1,i) + k-1)
+ ! v wind on rho levels
+ v_p(i,1,k) = v_in_w3(map_w3(1,i) + k-1)
+ ! height of rho levels from centre of planet
+ r_rho_levels(i,1,k) = height_w3(map_w3(1,i) + k-1) + planet_radius
+ ! height of levels above surface
+ z_rho(i,1,k) = height_w3(map_w3(1,i) + k-1) - height_wth(map_wth(1,i))
+ z_theta(i,1,k) = height_wth(map_wth(1,i) + k) - height_wth(map_wth(1,i))
+ ! water vapour mixing ratio
+ q(i,1,k) = m_v_n(map_wth(1,i) + k)
+ ! cloud liquid mixing ratio
+ qcl(i,1,k) = m_cl_n(map_wth(1,i) + k)
+ ! cloud ice mixing ratio
+ qcf_conv(i,1,k) = m_ci_n(map_wth(1,i) + k)
+ bulk_cf_conv(i,1,k) = cf_bulk(map_wth(1,i) + k)
+ if (l_noice_in_turb) then
+ qcf(i,1,k) = 0.0_r_bl
+ bulk_cloud_fraction(i,1,k) = cf_liquid(map_wth(1,i) + k)
+ else
+ qcf(i,1,k) = m_ci_n(map_wth(1,i) + k)
+ bulk_cloud_fraction(i,1,k) = cf_bulk(map_wth(1,i) + k)
+ end if
+ end do
+
+ do k = 1, bl_levels+1
+ rho_mix(i,1,k) = rho_in_w3(map_w3(1,i) + k-1)
+ end do
+
+ do k = 1, bl_levels
+ temperature(i,1,k) = theta_in_wth(map_wth(1,i) + k) * &
+ exner_in_wth(map_wth(1,i) + k)
+ tl(i,1,k) = temperature(i,1,k) - lcrcp*qcl(i,1,k) - lsrcp*qcf(i,1,k)
+ qw(i,1,k) = q(i,1,k) + qcl(i,1,k) + qcf(i,1,k)
+ rdz_charney_grid(i,1,k) = rdz_w3(map_w3(1,i) + k-1)
+ dtrdz_charney_grid(i,1,k) = dtrdz_wth(map_wth(1,i) + k) / &
+ rho_in_wth(map_wth(1,i) + k)
+ tke_trb(i,1,k) = tke_bl(map_wth(1,i) + k-1)
+ end do
+
+ if (bdy_tke /= bdy_tke_deardorff) then
+ do k = 1, bl_levels
+ tsq_trb(i,1,k) = tsq_bl(map_wth(1,i) + k-1)
+ qsq_trb(i,1,k) = qsq_bl(map_wth(1,i) + k-1)
+ cov_trb(i,1,k) = cov_bl(map_wth(1,i) + k-1)
+ end do
+ end if
+
+ do k = 2, bl_levels
+ rdz(i,1,k) = 1.0_r_bl/dz_wth(map_wth(1,i) + k-1)
+ end do
+
+ ! surface pressure
+ p_star(i,1) = p_theta_levels(i,1,0)
+ ! surface currents
+ u_0_p(i,1) = sea_u_current(map_2d(1,i))
+ v_0_p(i,1) = sea_v_current(map_2d(1,i))
+ ! previous BL height
+ zh(i,1) = zh_2d(map_2d(1,i))
+ zh_prev(i,1) = zh(i,1)
+ end do
+
+ if (shcu_buoy) then
+ do i = 1, seg_len
+ zhpar_shcu(i,1) = zhpar_shcu_2d(map_2d(1,i))
+ end do
+ end if
+
+ if ( smagorinsky ) then
+ do i = 1, seg_len
+ delta_smag(i,1) = delta(map_wth(1,i))
+ do k = 1, bl_levels
+ shear(i,1,k) = shear_3d(map_wth(1,i) + k)
+ end do
+ end do
+ end if
+
+ !-----------------------------------------------------------------------
+ ! Boundary layer diagnostics
+ !-----------------------------------------------------------------------
+
+ bl_diag%l_rhogamt = .not. associated(rhogamt_bl, empty_real_data)
+ bl_diag%l_rhogamq = .not. associated(rhogamq_bl, empty_real_data)
+ bl_diag%l_elm = .not. associated(master_length, empty_real_data)
+ bl_diag%l_tke_shr_prod = .not. associated(tke_shr_prod, empty_real_data)
+ bl_diag%l_tke_boy_prod = .not. associated(tke_boy_prod, empty_real_data)
+ bl_diag%l_tke_dissp = .not. associated(tke_dissp, empty_real_data)
+ bl_diag%l_sm = .not. associated(sm25, empty_real_data)
+ bl_diag%l_sh = .not. associated(sh25, empty_real_data)
+ bl_diag%l_dbdz = .not. associated(dbdz, empty_real_data)
+ bl_diag%l_dvdzm = .not. associated(dvdzm, empty_real_data)
+
+ call alloc_bl_expl(bl_diag, .true.)
+
+ bl_diag%l_gradrich = .true.
+ allocate(BL_diag%gradrich(seg_len,1,bl_levels))
+ bl_diag%gradrich = 0.0_r_bl
+
+ !----------------------------------------------------------------!
+ ! Run boundary layer scheme
+ !----------------------------------------------------------------!
+ call buoy_tq ( &
+ ! IN dimensions/logicals
+ bl_levels, &
+ ! IN fields
+ p_theta_levels,temperature,q,qcf,qcl,bulk_cloud_fraction, &
+ ! OUT fields
+ bt,bq,bt_cld,bq_cld,bt_gb,bq_gb,a_qs,a_dqsdt,dqsdt &
+ )
+
+ ! Use convection switches to decide the value of L_cape_opt
+ if (i_convection_vn == i_convection_vn_6a ) then
+ L_cape_opt = ( (cldbase_opt_dp == 3) .or. (cldbase_opt_md == 3) .or. &
+ (cldbase_opt_dp == 4) .or. (cldbase_opt_md == 4) .or. &
+ (cldbase_opt_dp == 5) .or. (cldbase_opt_md == 5) .or. &
+ (cldbase_opt_dp == 6) .or. (cldbase_opt_md == 6) )
+ else
+ L_cape_opt = .false.
+ end if
+
+ call ap2_init_conv_diag( 1, seg_len, ntml, ntpar, nlcl, cumulus, &
+ l_shallow, l_mid, delthvu, ql_ad, zhpar, dzh, qcl_inv_top, &
+ zlcl, zlcl_uv, conv_type, no_cumulus, w_max, w, L_cape_opt)
+
+ qsat_lcl = 0.0_r_bl
+ call conv_diag_6a( &
+ ! IN Parallel variables
+ seg_len, 1 &
+ ! IN model dimensions.
+ , bl_levels, p_rho_levels, p_theta_levels(1,1,1) &
+ , exner_rho_levels, rho_wet, rho_wet_tq, z_theta, z_rho &
+ , r_theta_levels &
+ ! IN Model switches
+ , l_extra_call, no_cumulus &
+ ! IN cloud data
+ , qcf_conv, qcl(1,1,1), bulk_cf_conv &
+ ! IN everything not covered so far :
+ , p_star, q(1,1,1), theta, exner_theta_levels, u_p, v_p &
+ , u_0_p, v_0_p, tstar_land, tstar_sea, tstar_sice, z0msea &
+ , flux_e, flux_h, ustar_in, L_spec_z0, z0m_scm, z0h_scm &
+ , tstar, land_sea_mask, flandg, ice_fract, w, w_max &
+ , conv_prog_precip, g_ccp, h_ccp, ccp_strength &
+ ! IN surface fluxes
+ , fb_surf, ustargbm &
+ ! SCM Diagnostics (dummy values in full UM)
+ , nSCMDpkgs,L_SCMDiags &
+ ! OUT data required elsewhere in UM system :
+ , zh,zhpar,dzh,qcl_inv_top,zlcl,zlcl_uv,delthvu,ql_ad, ntml &
+ , ntpar,nlcl, cumulus,l_shallow,l_congestus,l_congestus2 &
+ , conv_type, CIN_undilute,CAPE_undilute, wstar, wthvs &
+ , entrain_coef, qsat_lcl, Error_code, tnuc_new, tnuc_nlcl_um )
+
+ if (prog_tnuc) then
+ ! Use tnuc_nlcl_um from conv_diag_6a (UM) and map onto tnuc_nlcl for
+ ! LFRic to then be passed out to
+ do i = 1, seg_len
+ tnuc_nlcl(map_2d(1,i)) = real(tnuc_nlcl_um(i,1),kind=r_def)
+ end do
+ end if
+
+ call bdy_expl2_1a ( &
+ ! IN values defining vertical grid of model atmosphere :
+ bl_levels,p_theta_levels,land_field,land_index, &
+ ! IN U, V and W momentum fields.
+ u_p,v_p, u_0_p, v_0_p, &
+ ! IN variables for TKE scheme
+ p_star,p_rho_levels, &
+ ! IN from other part of explicit boundary layer code
+ rho_mix,rho_wet_tq,rdz,rdz_charney_grid, &
+ z_theta,z_rho,bt,bt_gb,bq_gb, &
+ flandg, rib_gb, sil_orog_land_gb,z0m_eff_gb, &
+ ! IN cloud/moisture data:
+ q,qcf,qcl,temperature,qw,tl, &
+ ! IN everything not covered so far :
+ fb_surf,ustargbm, &
+ zh_prev,ho2r2_orog_gb,sd_orog, &
+ ! 2 IN for Smagorinsky
+ delta_smag, shear, &
+ ! stash diag
+ BL_diag, &
+ ! INOUT variables
+ zh,ntml,ntpar,l_shallow,cumulus,fqw,ftl,rhokh,rhokm, &
+ tke_trb, tsq_trb, qsq_trb, cov_trb, zhpar_shcu, &
+ ! OUT New variables for message passing
+ tau_fd_x, tau_fd_y, visc_m, visc_h, rhogamu, rhogamv, &
+ ! OUT Diagnostic not requiring STASH flags :
+ shallowc,cu_over_orog, &
+ bl_type_1,bl_type_2,bl_type_3,bl_type_4,bl_type_5,bl_type_6, bl_type_7, &
+ ! OUT data required for tracer mixing :
+ kent, we_lim, t_frac, zrzi, kent_dsc, we_lim_dsc, t_frac_dsc, zrzi_dsc, &
+ ! OUT data required elsewhere in UM system :
+ zhsc,ntdsc,nbdsc,wstar,wthvs,uw0,vw0 &
+ )
+
+ if ( smagorinsky ) then
+
+ ! Interpolate rhokm from theta-levels to rho-levels, as is done for
+ ! rhokh in bdy_expl2.
+ ! NOTE: rhokm is defined on theta-levels with the k-indexing offset by
+ ! 1 compared to the rest of the UM (k=1 is the surface).
+
+ ! Bottom model-level is surface in both arrays, so no interp needed
+ ! (for rhokh_mix, this is done in the JULES routine sf_impl2_jls).
+ do i = 1, seg_len
+ rhokm_mix(i,1,1) = rhokm(i,1,1)
+ end do
+ do k = 2, bl_levels-1
+ do i = 1, seg_len
+ weight1 = z_theta(i,1,k) - z_theta(i,1,k-1)
+ weight2 = z_theta(i,1,k) - z_rho(i,1,k)
+ weight3 = z_rho(i,1,k) - z_theta(i,1,k-1)
+ rhokm_mix(i,1,k) = (weight3/weight1) * rhokm(i,1,k+1) &
+ + (weight2/weight1) * rhokm(i,1,k)
+ ! Scale exchange coefficients by 1/dz factor, as is done for
+ ! rhokh_mix in bdy_impl4
+ ! (note this doesn't need to be done for the surface exchange coef)
+ rhokm_mix(i,1,k) = rhokm_mix(i,1,k) * rdz_charney_grid(i,1,k)
+ end do
+ end do
+ k = bl_levels
+ do i = 1, seg_len
+ weight1 = z_theta(i,1,k) - z_theta(i,1,k-1)
+ weight2 = z_theta(i,1,k) - z_rho(i,1,k)
+ ! Assume rhokm(BL_LEVELS+1) is zero
+ rhokm_mix(i,1,k) = (weight2/weight1) * rhokm(i,1,k)
+ ! Scale exchange coefficients by 1/dz factor, as is done for
+ ! rhokh_mix in bdy_impl4
+ rhokm_mix(i,1,k) = rhokm_mix(i,1,k) * rdz_charney_grid(i,1,k)
+ end do
+
+ ! If full stress term is used, diagonal terms are doubled.
+ if (fullstress) then
+ do k = 1, bl_levels
+ do i = 1, seg_len
+ rhokm_mix(i,1,k) = 2.0 * rhokm_mix(i,1,k)
+ end do
+ end do
+ end if
+
+ kent_dummy = 2
+ zeroes_2d = 0.0_r_um
+ zeroes_ent = 0.0_r_um
+ do k = 1, bl_levels
+ do i = 1, seg_len
+ w_mixed(i,1,k) = w(i,1,k)
+ end do
+ end do
+
+ call tr_mix ( &
+ ! IN fields
+ r_theta_levels, r_rho_levels, pdims, &
+ bl_levels, alpha_cd, &
+ rhokm_mix(1:seg_len,1:1,2:bl_levels), &
+ rhokm_mix(1:seg_len,1:1,1), &
+ dtrdz_charney_grid, zeroes_2d, zeroes_2d, kent_dummy, &
+ zeroes_ent, zeroes_ent, zeroes_ent, kent_dummy, &
+ zeroes_ent, zeroes_ent, zeroes_ent, &
+ zeroes_2d, zeroes_2d, real(z_rho,r_um), &
+ ! INOUT / OUT fields
+ w_mixed, w_flux, surf_dep_flux &
+ )
+
+ do k = 1, bl_levels
+ do i = 1, seg_len
+ dw_bl(map_wth(1,i)+k) = w_mixed(i,1,k) - w(i,1,k)
+ end do
+ end do
+
+ end if
+
+ !----------------------------------------------------------------!
+ ! Update variables
+ !----------------------------------------------------------------!
+ ! Set dummy zhnl value to avoid undefined reference in interpolation later
+ do i = 1, seg_len
+ surf_interp(map_surf(1,i)+5) = 0.0_r_def
+ end do
+
+ do k=1,bl_levels
+ do i = 1, seg_len
+ bq_bl(map_wth(1,i) + k-1) = bq_gb(i,1,k)
+ bt_bl(map_wth(1,i) + k-1) = bt_gb(i,1,k)
+ dtrdz_tq_bl(map_wth(1,i) + k) = dtrdz_charney_grid(i,1,k)
+ end do
+ end do
+
+ ! Update variables for formdrag scheme
+ if (formdrag == formdrag_dist_drag) then
+ do k = 1, bl_levels
+ do i = 1, seg_len
+ ! These fields will be passed to set wind, which maps w3 (cell centre)
+ ! to w2 (cell face) vectors. However, they are actually defined in
+ ! wtheta (cell top centre) and need mapping to fd1 (cell top edge).
+ ! Set wind will therefore work correctly, but the indexing is shifted
+ ! by half a level in the vertical for the input & output
+ fd_taux(map_w3(1,i) + k-1) = tau_fd_x(i,1,k)
+ fd_tauy(map_w3(1,i) + k-1) = tau_fd_y(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ do k=bl_levels+1,nlayers
+ fd_taux(map_w3(1,i) + k-1) = 0.0_r_def
+ fd_tauy(map_w3(1,i) + k-1) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ ! Update variables for convection scheme
+ do i = 1, seg_len
+ zh_2d(map_2d(1,i)) = zh(i,1)
+ ntml_2d(map_2d(1,i)) = ntml(i,1)
+ if (cumulus(i,1)) then
+ cumulus_2d(map_2d(1,i)) = 1_i_def
+ else
+ cumulus_2d(map_2d(1,i)) = 0_i_def
+ end if
+ z_lcl(map_2d(1,i)) = real(zlcl(i,1), r_def)
+ inv_depth(map_2d(1,i)) = real(dzh(i,1), r_def)
+ qcl_at_inv_top(map_2d(1,i)) = real(qcl_inv_top(i,1), r_def)
+ if ( l_shallow(i,1) ) then
+ shallow_flag(map_2d(1,i)) = 1_i_def
+ else
+ shallow_flag(map_2d(1,i)) = 0_i_def
+ end if
+ uw0_flux(map_2d(1,i)) = uw0(i,1)
+ vw0_flux(map_2d(1,i)) = vw0(i,1)
+ lcl_height(map_2d(1,i)) = zlcl_uv(i,1)
+ parcel_top(map_2d(1,i)) = zhpar(i,1)
+ level_parcel_top(map_2d(1,i)) = ntpar(i,1)
+ wstar_2d(map_2d(1,i)) = wstar(i,1)
+ thv_flux(map_2d(1,i)) = wthvs(i,1)
+ parcel_buoyancy(map_2d(1,i)) = delthvu(i,1)
+ qsat_at_lcl(map_2d(1,i)) = qsat_lcl(i,1)
+ end do
+
+ ! Update variables for boundary layer scheme
+ do k = 1, bl_levels
+ do i = 1, seg_len
+ tke_bl(map_wth(1,i) + k-1) = tke_trb(i,1,k)
+ end do
+ end do
+
+ if (bdy_tke /= bdy_tke_deardorff) then
+ do k = 1, bl_levels
+ do i = 1, seg_len
+ tsq_bl(map_wth(1,i) + k-1) = tsq_trb(i,1,k)
+ qsq_bl(map_wth(1,i) + k-1) = qsq_trb(i,1,k)
+ cov_bl(map_wth(1,i) + k-1) = cov_trb(i,1,k)
+ end do
+ end do
+ end if
+
+ if (shcu_buoy) then
+ do i = 1, seg_len
+ zhpar_shcu_2d(map_2d(1,i)) = zhpar_shcu(i,1)
+ end do
+ end if
+
+ do i = 1, seg_len
+ gradrinr(map_wth(1,i)) = rib_gb(i,1)
+ end do
+ do k = 2, bl_levels
+ do i = 1, seg_len
+ rhokm_bl(map_wth(1,i) + k-1) = rhokm(i,1,k)
+ rhokh_bl(map_w3(1,i) + k-1) = rhokh(i,1,k)
+ moist_flux_bl(map_w3(1,i) + k-1) = fqw(i,1,k)
+ heat_flux_bl(map_w3(1,i) + k-1) = ftl(i,1,k)
+ gradrinr(map_wth(1,i) + k-1) = BL_diag%gradrich(i,1,k)
+ end do
+ end do
+
+ ! Counter gradient flux of momentum is defined at Wtheta level
+ ! but tentatively store in W3 data to convert to W2 data with set_wind
+ do k = 2, bl_levels
+ do i = 1, seg_len
+ ! true defined position is map_wth(1,i) +k-1
+ rhogamu_w3(map_w3(1,i) + k-2) = rhogamu(i,1,k)
+ rhogamv_w3(map_w3(1,i) + k-2) = rhogamv(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ do k = bl_levels, nlayers
+ rhogamu_w3(map_w3(1,i) + k-1) = 0.0_r_def
+ rhogamv_w3(map_w3(1,i) + k-1) = 0.0_r_def
+ end do
+ end do
+
+ do i = 1, seg_len
+ bl_type_ind(map_bl(1,i)+0) = bl_type_1(i,1)
+ bl_type_ind(map_bl(1,i)+1) = bl_type_2(i,1)
+ bl_type_ind(map_bl(1,i)+2) = bl_type_3(i,1)
+ bl_type_ind(map_bl(1,i)+3) = bl_type_4(i,1)
+ bl_type_ind(map_bl(1,i)+4) = bl_type_5(i,1)
+ bl_type_ind(map_bl(1,i)+5) = bl_type_6(i,1)
+ bl_type_ind(map_bl(1,i)+6) = bl_type_7(i,1)
+ end do
+
+ ! Update blended Smagorinsky diffusion coefficients
+ if ( smagorinsky ) then
+ do i = 1, seg_len
+ visc_m_blend(map_wth(1,i)) = visc_m(i,1,1)
+ visc_h_blend(map_wth(1,i)) = visc_h(i,1,1)
+ end do
+ do k = 1, bl_levels-1
+ do i = 1, seg_len
+ visc_m_blend(map_wth(1,i) + k) = visc_m(i,1,k)
+ visc_h_blend(map_wth(1,i) + k) = visc_h(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ visc_m_blend(map_wth(1,i) + bl_levels) = visc_m(i,1,bl_levels-1)
+ visc_h_blend(map_wth(1,i) + bl_levels) = visc_h(i,1,bl_levels-1)
+ end do
+ do i = 1, seg_len
+ do k = bl_levels+1, nlayers
+ visc_m_blend(map_wth(1,i) + k) = 0.0_r_def
+ visc_h_blend(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ endif
+
+ if (.not. associated(rhogamu_bl, empty_real_data)) then
+ do k = 2, bl_levels
+ do i = 1, seg_len
+ rhogamu_bl(map_wth(1,i) + k-1) = rhogamu(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ rhogamu_bl(map_wth(1,i)) = 0.0_r_def
+ do k = bl_levels, nlayers
+ rhogamu_bl(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(rhogamv_bl, empty_real_data)) then
+ do k = 2, bl_levels
+ do i = 1, seg_len
+ rhogamv_bl(map_wth(1,i) + k-1) = rhogamv(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ rhogamv_bl(map_wth(1,i)) = 0.0_r_def
+ do k = bl_levels, nlayers
+ rhogamv_bl(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(rhogamt_bl, empty_real_data)) then
+ do k = 2, bl_levels
+ do i = 1, seg_len
+ rhogamt_bl(map_w3(1,i) + k-1) = BL_diag%rhogamt(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ rhogamt_bl(map_w3(1,i)) = 0.0_r_def
+ do k = bl_levels, nlayers
+ rhogamt_bl(map_w3(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(rhogamq_bl, empty_real_data)) then
+ do k = 2, bl_levels
+ do i = 1, seg_len
+ rhogamq_bl(map_w3(1,i) + k-1) = BL_diag%rhogamq(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ rhogamq_bl(map_w3(1,i)) = 0.0_r_def
+ do k = bl_levels, nlayers
+ rhogamq_bl(map_w3(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(tke_shr_prod, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ tke_shr_prod(map_wth(1,i) + k-1) = BL_diag%tke_shr_prod(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ tke_shr_prod(map_wth(1,i)) = 0.0_r_def
+ do k = tke_levels, nlayers
+ tke_shr_prod(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(tke_boy_prod, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ tke_boy_prod(map_wth(1,i) + k-1) = BL_diag%tke_boy_prod(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ tke_boy_prod(map_wth(1,i)) = 0.0_r_def
+ do k = tke_levels, nlayers
+ tke_boy_prod(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(tke_dissp, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ tke_dissp(map_wth(1,i) + k-1) = BL_diag%tke_dissp(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ tke_dissp(map_wth(1,i)) = 0.0_r_def
+ do k = tke_levels, nlayers
+ tke_dissp(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(master_length, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ master_length(map_wth(1,i) + k-1) = BL_diag%elm(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ ! Copy above vaule as mym_length does.
+ master_length(map_wth(1,i)) = master_length(map_wth(1,i)+1)
+
+ do k = tke_levels, nlayers
+ master_length(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(sm25, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ sm25(map_wth(1,i) + k-1) = BL_diag%sm(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ sm25(map_wth(1,i)) = 0.0_r_def
+ do k = tke_levels, nlayers
+ sm25(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(sh25, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ sh25(map_wth(1,i) + k-1) = BL_diag%sh(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ sh25(map_wth(1,i)) = 0.0_r_def
+ do k = tke_levels, nlayers
+ sh25(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(dbdz, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ dbdz(map_wth(1,i) + k-1) = BL_diag%dbdz(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ dbdz(map_wth(1,i)) = 0.0_r_def
+ do k = tke_levels, nlayers
+ dbdz(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ if (.not. associated(dvdzm, empty_real_data)) then
+ do k = 2, tke_levels
+ do i = 1, seg_len
+ dvdzm(map_wth(1,i) + k-1) = BL_diag%dvdzm(i,1,k)
+ end do
+ end do
+ do i = 1, seg_len
+ dvdzm(map_wth(1,i)) = 0.0_r_def
+ do k = tke_levels, nlayers
+ dvdzm(map_wth(1,i) + k) = 0.0_r_def
+ end do
+ end do
+ end if
+
+ ! deallocate diagnostics deallocated in atmos_physics2
+ call dealloc_bl_expl(bl_diag)
+ deallocate(BL_diag%gradrich)
+ deallocate(land_index)
+ deallocate(sd_orog)
+ deallocate(ho2r2_orog_gb)
+ deallocate(sil_orog_land_gb)
+
+ end subroutine bl_exp1a_code
+
+end module bl_exp1a_kernel_mod
diff --git a/interfaces/physics_schemes_interface/source/kernel/bl_imp_du_kernel_mod.F90 b/interfaces/physics_schemes_interface/source/kernel/bl_imp_du_kernel_mod.F90
index e3ef8c9b9b..5769f63e4e 100644
--- a/interfaces/physics_schemes_interface/source/kernel/bl_imp_du_kernel_mod.F90
+++ b/interfaces/physics_schemes_interface/source/kernel/bl_imp_du_kernel_mod.F90
@@ -20,7 +20,9 @@ module bl_imp_du_kernel_mod
use kernel_mod, only: kernel_type
use nlsizes_namelist_mod, only: bl_levels
use timestepping_config_mod, only: outer_iterations
- use blayer_config_mod, only: fric_heating, bl_mix_w
+ use blayer_config_mod, only: fric_heating, bl_mix_w, bl_scheme, &
+ bl_scheme_9c, bl_scheme_1a
+ use mixing_config_mod, only: smagorinsky
use sci_face_selector_support_mod, only: face_from_face_selector
implicit none
@@ -408,7 +410,8 @@ subroutine bl_imp_du_code(nlayers, &
end do ! loop over df
- if (bl_mix_w) then
+ if ((bl_scheme == bl_scheme_9c .and. bl_mix_w) .or. &
+ (bl_scheme == bl_scheme_1a .and. smagorinsky)) then
! Copy dw_bl increment into du_bl
do k = 1, bl_levels
du_bl(map_w2(5)+k) = dw_bl(map_wth(1)+k)
diff --git a/interfaces/physics_schemes_interface/source/kernel/interp_edge_kernel_mod.F90 b/interfaces/physics_schemes_interface/source/kernel/interp_edge_kernel_mod.F90
new file mode 100644
index 0000000000..9a2c496603
--- /dev/null
+++ b/interfaces/physics_schemes_interface/source/kernel/interp_edge_kernel_mod.F90
@@ -0,0 +1,127 @@
+!-----------------------------------------------------------------------------
+! (C) Crown copyright Met Office. All rights reserved.
+! The file LICENCE, distributed with this code, contains details of the terms
+! under which the code may be used.
+!-----------------------------------------------------------------------------
+
+!> @brief Interpolates scalar variables from W3 (Wtheta) to W2 (shifted W2) dofs
+!> @details Takes all the variables required for BL momentum mixing and
+!> interpolates them from their lowest order W3 dof to W2 dofs
+!> so that wind increments can be calculated in their native space
+
+module interp_edge_kernel_mod
+
+ use kernel_mod, only: kernel_type
+ use argument_mod, only: arg_type, GH_SCALAR, GH_FIELD, &
+ GH_REAL, GH_INTEGER, GH_LOGICAL, &
+ GH_INC, GH_READ, &
+ ANY_SPACE_1, CELL_COLUMN, &
+ ANY_DISCONTINUOUS_SPACE_1
+
+ use constants_mod, only: r_def, i_def, l_def
+ use fs_continuity_mod, only: W2
+ use kernel_mod, only: kernel_type
+
+ implicit none
+
+ private
+
+ !----------------------------------------------------------------------------
+ ! Public types
+ !----------------------------------------------------------------------------
+ !> Kernel metadata type.
+ type, public, extends(kernel_type) :: interp_edge_kernel_type
+ private
+ type(arg_type) :: meta_args(5) = (/ &
+ arg_type(GH_SCALAR, GH_LOGICAL, GH_READ), &! flag_surface
+ arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! n_interp
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1), &! data_center
+ arg_type(GH_FIELD, GH_REAL, GH_INC, ANY_SPACE_1), &! data_edge
+ arg_type(GH_FIELD, GH_REAL, GH_READ, W2) &! w2_rmultiplicity
+ /)
+ integer :: operates_on = CELL_COLUMN
+ contains
+ procedure, nopass :: interp_edge_code
+ end type interp_edge_kernel_type
+
+ !----------------------------------------------------------------------------
+ ! Contained functions/subroutines
+ !----------------------------------------------------------------------------
+ public :: interp_edge_code
+
+contains
+
+ !> @brief Subroutine to do the re-mapping
+ !> @param[in] nlayers Number of layers
+ !> @param[in] flag_surface Flag of interpolating surface variables
+ !> @param[in] n_interp Number of indices to interpolate
+ !> @param[in] data_center Input data defined in W3(Wtheta) space
+ !> @param[in,out] data_edge Output data defined in W2(shifted W2) space
+ !> @param[in] w2_rmultiplicity Reciprocal of multiplicity for w2
+ !> @param[in] ndf_in Number of DOFs for W3(Wtheta) space
+ !> @param[in] undf_in Number of unique DOFs for W3(Wtheta) space
+ !> @param[in] map_in Dofmap for W3(Wtheta) space
+ !> @param[in] ndf_out Number of DOFs for W2(shifted W2) space
+ !> @param[in] undf_out Number of unique DOFs for W2(shifted W2) space
+ !> @param[in] map_out Dofmap for W2(shifted W2) space
+ !> @param[in] ndf_w2 Number of DOFs for W2 surface space
+ !> @param[in] undf_w2 Number of unique DOFs for W2 surface space
+ !> @param[in] map_w2 Dofmap for W2 surface space
+ subroutine interp_edge_code(nlayers, &
+ flag_surface, &
+ n_interp, &
+ data_center, &
+ data_edge, &
+ w2_rmultiplicity, &
+ ndf_in, &
+ undf_in, &
+ map_in, &
+ ndf_out, &
+ undf_out, &
+ map_out, &
+ ndf_w2, &
+ undf_w2, &
+ map_w2)
+
+ implicit none
+
+ ! Arguments
+ integer(kind=i_def), intent(in) :: nlayers
+ logical(kind=l_def), intent(in) :: flag_surface
+ integer(kind=i_def), intent(in) :: n_interp
+
+ integer(kind=i_def), intent(in) :: ndf_in, ndf_out, ndf_w2
+ integer(kind=i_def), intent(in) :: undf_in, undf_out, undf_w2
+ integer(kind=i_def), intent(in) :: map_in(ndf_in)
+ integer(kind=i_def), intent(in) :: map_out(ndf_out)
+ integer(kind=i_def), intent(in) :: map_w2(ndf_w2)
+
+ real(kind=r_def), dimension(undf_in), intent(in) :: data_center
+ real(kind=r_def), dimension(undf_out), intent(inout) :: data_edge
+ real(kind=r_def), dimension(undf_w2), intent(in) :: w2_rmultiplicity
+
+ ! Internal variables
+ integer :: k, df
+
+ ! Map w3 (wtheta) variables into w2 (shifted w2) space
+ if (flag_surface) then
+ do df = 1,4
+ do k = 0, n_interp-1
+ data_edge(map_out(df) + k) = data_edge(map_out(df) + k) + &
+ w2_rmultiplicity(map_w2(df)) * &
+ data_center(map_in(1) + k)
+ end do
+ end do
+ else
+ do df = 1,4
+ do k = 0, n_interp-1
+ data_edge(map_out(df) + k) = data_edge(map_out(df) + k) + &
+ w2_rmultiplicity(map_w2(df) + k) * &
+ data_center(map_in(1) + k)
+ end do
+ end do
+ end if
+
+ end subroutine interp_edge_code
+
+end module interp_edge_kernel_mod
diff --git a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90 b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
index b3e2e73252..f24de4fb15 100644
--- a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
+++ b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
@@ -29,7 +29,22 @@ module um_physics_init_mod
horiz_d_in => horiz_d, &
us_am_in => us_am
- use blayer_config_mod, only : a_ent_shr, a_ent_2_in => a_ent_2, &
+ use blayer_config_mod, only : bl_scheme, bl_scheme_9c, bl_scheme_1a, &
+ tke_levels_in => tke_levels, &
+ bdy_tke_in => bdy_tke, bdy_tke_my3, &
+ bdy_tke_my25, bdy_tke_deardorff, &
+ adv_turb_field, my_condense, &
+ shcu_buoy, &
+ shcu_levels_in => shcu_levels, &
+ my_lowest_pd_surf_in => my_lowest_pd_surf, &
+ my_lowest_pd_surf_off, &
+ my_lowest_pd_surf_businger, &
+ my_lowest_pd_surf_bh91, &
+ my_prod_adj, &
+ local_above_tkelvs, &
+ my_force_initialize, &
+ my_ini_dbdz_min_in => my_ini_dbdz_min, &
+ a_ent_shr, a_ent_2_in => a_ent_2, &
cbl_opt, cbl_opt_conventional, &
cbl_opt_standard, cbl_opt_adjustable, &
cbl_mix_fac, &
@@ -194,13 +209,16 @@ module um_physics_init_mod
heavy_rain_evap_fac_in => &
heavy_rain_evap_fac
- use mixing_config_mod, only : smagorinsky, &
- mixing_method => method, &
- method_3d_smag, &
- method_2d_smag, &
- method_blend_smag_fa, &
- method_blend_1dbl_fa, &
- mix_factor_in => mix_factor, &
+ use mixing_config_mod, only : smagorinsky, &
+ mixing_method_9c => method_9c, &
+ method_9c_3d_smag, &
+ method_9c_2d_smag, &
+ method_9c_blend_smag_fa, &
+ method_9c_blend_1dbl_fa, &
+ mixing_method_1a => method_1a, &
+ method_1a_3d_smag, &
+ method_1a_3dte_mk1, &
+ mix_factor_in => mix_factor, &
leonard_term
use radiation_config_mod, only : topography, topography_horizon
@@ -292,6 +310,9 @@ module um_physics_init_mod
include_moisture_moist, &
include_moisture_dry
+ use io_config_mod, only: checkpoint_read
+
+ use initialization_config_mod, only: init_option, init_option_checkpoint_dump
! Other LFRic modules used
use constants_mod, only: i_def, l_def, r_um, i_um, r_def, r_bl
@@ -300,6 +321,7 @@ module um_physics_init_mod
use log_mod, only : log_event, &
log_scratch_space, &
LOG_LEVEL_ERROR, &
+ LOG_LEVEL_WARNING, &
LOG_LEVEL_INFO
use mr_indices_mod, only : nummr_to_transport
@@ -357,7 +379,7 @@ subroutine um_physics_init()
sc_diag_opt, sc_diag_orig, sc_diag_cu_relax, sc_diag_cu_rh_max, &
sc_diag_all_rh_max, &
bl_res_inv, cosine_inv_flux, target_inv_profile, blending_option, &
- a_ent_shr_nml, alpha_cd, puns, pstb, kprof_cu, &
+ a_ent_shr_nml, alpha_cd, puns, pstb, kprof_cu, ishear_bl, &
non_local_bl, flux_bc_opt, i_bl_vn_9c, sharp_sea_mes_land, &
lem_conven, to_sharp_across_1km, off, on, DynDiag_Ribased, &
DynDiag_ZL_corrn, blend_allpoints, ng_stress, &
@@ -371,7 +393,13 @@ subroutine um_physics_init()
i_interp_local_cf_dbdz, tke_diag_fac, a_ent_2, dec_thres_cloud, &
dec_thres_cu, near_neut_z_on_l, blend_gridindep_fa, &
specified_fluxes_tstar, buoy_integ_low, num_sweeps_bflux, &
- l_use_sml_dsc_fixes, l_converge_ga, improved_tke_diag
+ l_use_sml_dsc_fixes, l_converge_ga, improved_tke_diag, i_bl_vn_1a
+ use mym_option_mod, only: bdy_tke, deardorff, mymodel25, mymodel3, &
+ l_3dtke, tke_levels, l_local_above_tkelvs, l_my_initialize, &
+ my_ini_dbdz_min, l_adv_turb_field, l_my_condense, l_shcu_buoy, &
+ shcu_levels, wb_ng_max, my_lowest_pd_surf, no_pd_surf, businger, &
+ bh1991, l_my_prod_adj, my_z_limit_elb, tke_cm_mx, tke_cm_fa, &
+ tke_dlen, ddf_length
use cloud_inputs_mod, only: i_cld_vn, forced_cu, i_rhcpt, i_cld_area, &
rhcrit, ice_fraction_method,falliceshear_method, cff_spread_rate, &
l_subgrid_qv, ice_width, min_liq_overlap, i_eacf, not_mixph, &
@@ -645,8 +673,6 @@ subroutine um_physics_init()
call log_event( log_scratch_space, LOG_LEVEL_ERROR )
end if
- a_ent_shr_nml = real(a_ent_shr, r_bl)
- a_ent_2 = real(a_ent_2_in, r_bl)
bl_levels = bl_levels_in
if(allocated(alpha_cd))deallocate(alpha_cd)
allocate(alpha_cd(bl_levels))
@@ -662,25 +688,6 @@ subroutine um_physics_init()
cbl_op = lem_adjust
end select
- dec_thres_cloud = real(dec_thres_cloud_in, r_bl)
- dec_thres_cu = real(dec_thres_cu_in, r_bl)
-
- select case ( entr_smooth_dec_in )
- case ( entr_smooth_dec_off )
- entr_smooth_dec = off
- case ( entr_smooth_dec_on )
- entr_smooth_dec = on
- case ( entr_smooth_dec_taper_zh )
- entr_smooth_dec = entr_taper_zh
- end select
-
- select case ( dzrad_disc_opt_in )
- case ( dzrad_disc_opt_level_ntm1 )
- dzrad_disc_opt = dzrad_ntm1
- case ( dzrad_disc_opt_smooth_1p5 )
- dzrad_disc_opt = dzrad_1p5dz
- end select
-
select case (flux_bc_opt_in)
case(flux_bc_opt_interactive, flux_bc_opt_specified_tstar)
flux_bc_opt = interactive_fluxes
@@ -698,61 +705,9 @@ subroutine um_physics_init()
fric_heating = off
end if
- i_bl_vn = i_bl_vn_9c
-
- select case (dyn_diag)
- case(dyn_diag_zi_l_sea)
- idyndiag = DynDiag_ZL_corrn
- case(dyn_diag_zi_l_cu)
- idyndiag = DynDiag_ZL_CuOnly
- case(dyn_diag_ri_based)
- idyndiag = DynDiag_Ribased
- end select
- near_neut_z_on_l = real(near_neut_z_on_l_in, r_bl)
-
- ! Interpolate the vertical gradients of sl,qw and calculate
- ! stability dbdz and Kh on theta-levels
- select case (interp_local)
- case(interp_local_gradients)
- i_interp_local = i_interp_local_gradients
- case(interp_local_cf_dbdz)
- i_interp_local = i_interp_local_cf_dbdz
- end select
-
- select case (reduce_fa_mix)
- case(reduce_fa_mix_inv_and_cu_lcl)
- keep_ri_fa = on
- case(reduce_fa_mix_inv_only)
- keep_ri_fa = except_disc_inv
- end select
-
- select case(kprof_cu_in)
- case(kprof_cu_buoy_integ)
- kprof_cu = buoy_integ
- case(kprof_cu_buoy_integ_low)
- kprof_cu = buoy_integ_low
- end select
-
- select case(bl_res_inv_in)
- case(bl_res_inv_off)
- bl_res_inv = off
- case(bl_res_inv_cosine_inv_flux)
- bl_res_inv = cosine_inv_flux
- case(bl_res_inv_target_inv_profile)
- bl_res_inv = target_inv_profile
- end select
-
- select case(ng_stress_in)
- case(ng_stress_BG97_limited)
- ng_stress = BrownGrant97_limited
- case(ng_stress_BG97_original)
- ng_stress = BrownGrant97_original
- end select
+ lambda_min_nml = 40.0_r_um
l_noice_in_turb = noice_in_turb
- l_new_kcloudtop = new_kcloudtop
- l_reset_dec_thres = .true.
- lambda_min_nml = 40.0_r_um
select case (free_atm_mix)
case(free_atm_mix_to_sharp)
@@ -768,17 +723,6 @@ subroutine um_physics_init()
pstb = 2.0_r_um
puns = real(p_unstable, r_um)
- select case ( sc_diag_opt_in )
- case ( sc_diag_opt_orig )
- sc_diag_opt = sc_diag_orig
- case ( sc_diag_opt_cu_relax )
- sc_diag_opt = sc_diag_cu_relax
- case ( sc_diag_opt_cu_rh_max )
- sc_diag_opt = sc_diag_cu_rh_max
- case ( sc_diag_opt_all_rh_max )
- sc_diag_opt = sc_diag_all_rh_max
- end select
-
ritrans = 0.1_r_bl
select case (sbl_opt)
@@ -797,21 +741,179 @@ subroutine um_physics_init()
sg_orog_mixing = sg_shear_enh_lambda
end select
- ! TKE scaling parameter and switch for fixes to variance diagnostics
- tke_diag_fac = 1.0_r_bl
- l_use_var_fixes = .true.
- zhloc_depth_fac = real(zhloc_depth_fac_in, r_bl)
-
if (topography == topography_horizon) then
! Set control logical for use of skyview factor in JULES
l_skyview = .true.
end if
- improved_tke_diag = improved_tke_diag_in
- l_use_sml_dsc_fixes = l_use_sml_dsc_fixes_in
- l_converge_ga = l_converge_ga_in
- num_sweeps_bflux = num_sweeps_bflux_in
+ if (bl_scheme == bl_scheme_9c) then
+ i_bl_vn = i_bl_vn_9c
+
+ a_ent_shr_nml = real(a_ent_shr, r_bl)
+ a_ent_2 = real(a_ent_2_in, r_bl)
+
+ dec_thres_cloud = real(dec_thres_cloud_in, r_bl)
+ dec_thres_cu = real(dec_thres_cu_in, r_bl)
+
+ select case ( entr_smooth_dec_in )
+ case ( entr_smooth_dec_off )
+ entr_smooth_dec = off
+ case ( entr_smooth_dec_on )
+ entr_smooth_dec = on
+ case ( entr_smooth_dec_taper_zh )
+ entr_smooth_dec = entr_taper_zh
+ end select
+
+ select case ( dzrad_disc_opt_in )
+ case ( dzrad_disc_opt_level_ntm1 )
+ dzrad_disc_opt = dzrad_ntm1
+ case ( dzrad_disc_opt_smooth_1p5 )
+ dzrad_disc_opt = dzrad_1p5dz
+ end select
+
+ select case (dyn_diag)
+ case(dyn_diag_zi_l_sea)
+ idyndiag = DynDiag_ZL_corrn
+ case(dyn_diag_zi_l_cu)
+ idyndiag = DynDiag_ZL_CuOnly
+ case(dyn_diag_ri_based)
+ idyndiag = DynDiag_Ribased
+ end select
+ near_neut_z_on_l = real(near_neut_z_on_l_in, r_bl)
+
+ ! Interpolate the vertical gradients of sl,qw and calculate
+ ! stability dbdz and Kh on theta-levels
+ select case (interp_local)
+ case(interp_local_gradients)
+ i_interp_local = i_interp_local_gradients
+ case(interp_local_cf_dbdz)
+ i_interp_local = i_interp_local_cf_dbdz
+ end select
+
+ select case (reduce_fa_mix)
+ case(reduce_fa_mix_inv_and_cu_lcl)
+ keep_ri_fa = on
+ case(reduce_fa_mix_inv_only)
+ keep_ri_fa = except_disc_inv
+ end select
+
+ select case(kprof_cu_in)
+ case(kprof_cu_buoy_integ)
+ kprof_cu = buoy_integ
+ case(kprof_cu_buoy_integ_low)
+ kprof_cu = buoy_integ_low
+ end select
+
+ select case(bl_res_inv_in)
+ case(bl_res_inv_off)
+ bl_res_inv = off
+ case(bl_res_inv_cosine_inv_flux)
+ bl_res_inv = cosine_inv_flux
+ case(bl_res_inv_target_inv_profile)
+ bl_res_inv = target_inv_profile
+ end select
+
+ select case(ng_stress_in)
+ case(ng_stress_BG97_limited)
+ ng_stress = BrownGrant97_limited
+ case(ng_stress_BG97_original)
+ ng_stress = BrownGrant97_original
+ end select
+
+ l_new_kcloudtop = new_kcloudtop
+ l_reset_dec_thres = .true.
+
+ select case ( sc_diag_opt_in )
+ case ( sc_diag_opt_orig )
+ sc_diag_opt = sc_diag_orig
+ case ( sc_diag_opt_cu_relax )
+ sc_diag_opt = sc_diag_cu_relax
+ case ( sc_diag_opt_cu_rh_max )
+ sc_diag_opt = sc_diag_cu_rh_max
+ case ( sc_diag_opt_all_rh_max )
+ sc_diag_opt = sc_diag_all_rh_max
+ end select
+
+ ! TKE scaling parameter and switch for fixes to variance diagnostics
+ tke_diag_fac = 1.0_r_bl
+ l_use_var_fixes = .true.
+ zhloc_depth_fac = real(zhloc_depth_fac_in, r_bl)
+
+ improved_tke_diag = improved_tke_diag_in
+ l_use_sml_dsc_fixes = l_use_sml_dsc_fixes_in
+ l_converge_ga = l_converge_ga_in
+ num_sweeps_bflux = num_sweeps_bflux_in
+
+ else if (bl_scheme == bl_scheme_1a) then
+ i_bl_vn = i_bl_vn_1a
+
+ ishear_bl = off
+
+ select case (bdy_tke_in)
+ case(bdy_tke_my3)
+ bdy_tke = mymodel3
+ case(bdy_tke_my25)
+ bdy_tke = mymodel25
+ case(bdy_tke_deardorff)
+ bdy_tke = deardorff
+ end select
+ ! A negative value for tke_levels means it should default to bl_levels.
+ if (tke_levels_in < 0 .or. tke_levels_in > bl_levels) then
+ tke_levels = bl_levels
+ write( log_scratch_space, '(A)' ) &
+ 'The value of tke_levels has been reset to bl_levels'
+ call log_event( log_scratch_space, LOG_LEVEL_WARNING )
+ else
+ tke_levels = tke_levels_in
+ end if
+
+ ! A negative value for shcu_levels means it should default to tke_levels.
+ if (shcu_levels_in < 0 .or. shcu_levels_in > tke_levels) then
+ shcu_levels = tke_levels
+ write( log_scratch_space, '(A)' ) &
+ 'The value of shcu_levels has been reset to tke_levels'
+ call log_event( log_scratch_space, LOG_LEVEL_WARNING )
+ else
+ shcu_levels = shcu_levels_in
+ end if
+
+ l_local_above_tkelvs = local_above_tkelvs
+ if (my_force_initialize) then
+ l_my_initialize = .true.
+ else
+ if (checkpoint_read .or. &
+ init_option == init_option_checkpoint_dump) then
+ l_my_initialize = .false.
+ else
+ l_my_initialize = .true.
+ end if
+ end if
+ my_ini_dbdz_min = my_ini_dbdz_min_in
+ l_adv_turb_field = adv_turb_field
+ l_my_condense = my_condense
+ l_shcu_buoy = shcu_buoy
+ wb_ng_max = 0.05_r_bl
+
+ select case (my_lowest_pd_surf_in)
+ case (my_lowest_pd_surf_off)
+ my_lowest_pd_surf = no_pd_surf
+ case (my_lowest_pd_surf_businger)
+ my_lowest_pd_surf = businger
+ case (my_lowest_pd_surf_bh91)
+ my_lowest_pd_surf = bh1991
+ end select
+
+ if (bdy_tke_in == bdy_tke_my3) then
+ l_my_prod_adj = my_prod_adj
+ end if
+
+ my_z_limit_elb = 1.0e10_r_bl
+ tke_cm_mx = 0.1_r_bl
+ tke_cm_fa = 0.1_r_bl
+ tke_dlen = ddf_length
+
+ end if
end if
! ----------------------------------------------------------------
@@ -1601,31 +1703,57 @@ subroutine um_physics_init()
turb_startlev_vert = 2
turb_endlev_vert = bl_levels
- ! Options which are bespoke to the choice of scheme
- select case ( mixing_method )
+ if ( bl_scheme == bl_scheme_9c ) then
+
+ ! Options which are bespoke to the choice of scheme
+ select case ( mixing_method_9c )
+
+ case( method_9c_3d_smag )
+ l_subfilter_horiz = .true.
+ l_subfilter_vert = .true.
+ blending_option = off
+ non_local_bl = off
+ ng_stress = off
+ case( method_9c_2d_smag )
+ l_subfilter_horiz = .true.
+ l_subfilter_vert = .false.
+ blending_option = off
+ case( method_9c_blend_smag_fa )
+ l_subfilter_horiz = .true.
+ l_subfilter_vert = .true.
+ blending_option = blend_allpoints
+ case( method_9c_blend_1dbl_fa )
+ l_subfilter_horiz = .true.
+ l_subfilter_vert = .true.
+ blending_option = blend_gridindep_fa
+ end select
- case( method_3d_smag )
- l_subfilter_horiz = .true.
- l_subfilter_vert = .true.
- blending_option = off
- non_local_bl = off
- ng_stress = off
- case( method_2d_smag )
- l_subfilter_horiz = .true.
- l_subfilter_vert = .false.
- blending_option = off
- case( method_blend_smag_fa )
- l_subfilter_horiz = .true.
- l_subfilter_vert = .true.
- blending_option = blend_allpoints
- case( method_blend_1dbl_fa )
- l_subfilter_horiz = .true.
- l_subfilter_vert = .true.
- blending_option = blend_gridindep_fa
- end select
+ else if ( bl_scheme == bl_scheme_1a ) then
+
+ select case ( mixing_method_1a )
+
+ case( method_1a_3d_smag )
+ l_3dtke = .false.
+ l_subfilter_horiz = .true.
+ l_subfilter_vert = .true.
+ blending_option = off
+ case( method_1a_3dte_mk1 )
+ l_3dtke = .true.
+ l_subfilter_horiz = .true.
+ l_subfilter_vert = .false.
+
+ ! This option may be useful to determine mixing strength
+ ! between tke_levels and bl_levels, however, hardwire
+ ! this option off for now.
+ blending_option = off
+ end select
+
+ end if
else ! not Smagorinsky
+ l_3dtke = .false.
+
! Switches for Smagorinsky being off
blending_option = off
l_subfilter_horiz = .false.
diff --git a/rose-stem/app/check_global_variables/file/dirtylist.txt b/rose-stem/app/check_global_variables/file/dirtylist.txt
index 1c17daa3ef..89aa924b45 100644
--- a/rose-stem/app/check_global_variables/file/dirtylist.txt
+++ b/rose-stem/app/check_global_variables/file/dirtylist.txt
@@ -10,6 +10,7 @@ interfaces/physics_schemes_interface/source/algorithm/spt_main_alg_mod.x90
interfaces/physics_schemes_interface/source/algorithm/um_domain_init_mod.x90
interfaces/physics_schemes_interface/source/constants/planet_constants_mod.F90
interfaces/physics_schemes_interface/source/diagnostics/bl_exp_diags_mod.f90
+interfaces/physics_schemes_interface/source/diagnostics/bl_exp1a_diags_mod.f90
interfaces/physics_schemes_interface/source/diagnostics/bl_imp_diags_mod.x90
interfaces/physics_schemes_interface/source/diagnostics/casim_diagnostics_mod.x90
interfaces/physics_schemes_interface/source/diagnostics/cld_diags_mod.x90
@@ -165,4 +166,9 @@ science/physics_schemes/source/diffusion_and_filtering/leonard_incs_mod.F90
science/physics_schemes/source/diffusion_and_filtering/turb_diff_mod.F90
science/physics_schemes/source/gravity_wave_drag/gw_ussp_prec_mod.F90
science/physics_schemes/source/gravity_wave_drag/g_wave_input_mod.F90
+science/physics_schemes/source/boundary_layer/mym_ctl.F90
+science/physics_schemes/source/boundary_layer/ddf_ctl.F90
+science/physics_schemes/source/boundary_layer/mym_errfunc.F90
+science/physics_schemes/source/boundary_layer/mym_const_mod.F90
+science/physics_schemes/source/boundary_layer/mym_option_mod.F90
diff --git a/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf b/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
index 335d8e89b4..ea6272eb15 100644
--- a/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
+++ b/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
@@ -3661,6 +3661,18 @@ ns=namelist/Science/Dynamics/Mixing
sort-key=Panel-A09
type=logical
+[namelist:mixing=fullstress]
+compulsory=true
+description=Switch to enable full tensor expression for stress.
+help=Switch to enable full tensor expression for stress in the turbulence
+ =scheme. If this is false then only the diffusion-terms are used. There
+ =are theoretical arguments to suggest that the additional terms enabled
+ =when this switch is true are generally small. This has been confirmed
+ =in a small number of case studies.
+!kind=default
+sort-key=Panel-A03
+type=logical
+
[namelist:mixing=leonard_kl]
compulsory=true
description=Leonard term parameter
@@ -3698,9 +3710,32 @@ help=Typical value is 1.0
sort-key=Panel-A10
type=real
-[namelist:mixing=method]
+[namelist:mixing=method_1a]
compulsory=true
-description=Smagorinsky subgrid mixing scheme option
+description=Smagorinsky subgrid mixing scheme option for 1A scheme
+!enumeration=true
+fail-if=this=='3dte_mk1' and namelist:blayer=bdy_tke=='deardorff'
+help=Options for Smagorinsky subgrid mixing scheme:
+ =_________________________________________________________________
+ =3D Smag
+ = Smagorinsky mixing scheme applied in horizontal and vertical.
+ =_________________________________________________________________
+ =3D TKE
+ = The Mellor-Yamada level 2.5 and level 3 versions of the 1A family
+ = of higher order turbulence closure schemes have been modified to run as
+ = 3-dimensional schemes, using a mixing length that asymptotes to the
+ = Smagorinsky mixing length at very high resolution, and the computation
+ = of various constants modified to use of 3D (rather than 1D) shear.
+ = This option activates this change to the computation of eddy viscosity
+ = and diffusivity.
+ = See UMDP 025 for further details.
+sort-key=Panel-A10a
+value-titles=3D Smagorinsky, 3D TKE
+values='3d_smag', '3dte_mk1'
+
+[namelist:mixing=method_9c]
+compulsory=true
+description=Smagorinsky subgrid mixing scheme option for 9c scheme
!enumeration=true
help=Options for Smagorinsky subgrid mixing scheme:
=_________________________________________________________________
@@ -3757,7 +3792,8 @@ help=Apply Smagorinsky mixing to theta,
= WARNING: Current implementation assumes a Cartesian mesh.
!kind=default
sort-key=Panel-A03
-trigger=namelist:mixing=method: .true. ;
+trigger=namelist:mixing=method_9c: .true. ;
+ =namelist:mixing=method_1a: .true. ;
=namelist:mixing=mix_factor: .true. ;
=namelist:mixing=smag_l_calc: .true. ;
=namelist:mixing=max_diff_factor: .true.;
@@ -5389,7 +5425,6 @@ trigger=namelist:physics=blayer_placement: this != "'none'" ;
=namelist:physics=lowest_level: this == "'um'" ;
=namelist:section_choice=convection: this != "'none'" ;
=namelist:blayer: this == "'um'" ;
- =namelist:mixing=method: this == "'um'" ;
value-titles=None, Unified Model
values='none', 'um'
diff --git a/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90 b/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90
index 3b306f65c3..addc7afe03 100644
--- a/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90
+++ b/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90
@@ -118,6 +118,7 @@ module slow_physics_alg_mod
use orographic_drag_alg_mod, only: orographic_drag_alg
use map_drag_incs_alg_mod, only: map_drag_incs_alg
use bl_exp_alg_mod, only: bl_exp_alg
+ use bl_exp1a_alg_mod, only: bl_exp1a_alg
use bl_imp_alg_mod, only: bl_imp_alg
use bl_extra_diags_mod, only: output_diags_for_bl_extra
use conv_ll_alg_mod, only: conv_ll_alg
@@ -129,6 +130,7 @@ module slow_physics_alg_mod
use pc2_conv_coupling_alg_mod, only: pc2_conv_coupling_alg
use pc2_checks_alg_mod, only: pc2_checks_alg
use methox_alg_mod, only: methox_alg
+ use blayer_config_mod, only: bl_scheme, bl_scheme_9c, bl_scheme_1a
use microphysics_config_mod, only: microphysics_casim
use aerosol_config_mod, only: activation_scheme, &
activation_scheme_jones, &
@@ -874,15 +876,24 @@ contains
surface_fields, soil_fields, snow_fields, &
aerosol_fields, recip_l_mo_sea, rhostar, &
t1_sd_2d, q1_sd_2d)
-
- call bl_exp_alg(modeldb%config, &
- theta, rho, exner, mr_n, &
- derived_fields, radiation_fields, &
- microphysics_fields, dmr_mphys, orography_fields, &
- turbulence_fields, convection_fields, cloud_fields, &
- surface_fields, &
- recip_l_mo_sea, rhostar, &
- t1_sd_2d, q1_sd_2d, clock)
+ if (bl_scheme == bl_scheme_9c) then
+ call bl_exp_alg(modeldb%config, &
+ theta, rho, exner, mr_n, &
+ derived_fields, radiation_fields, &
+ microphysics_fields, dmr_mphys, orography_fields, &
+ turbulence_fields, convection_fields, cloud_fields, &
+ surface_fields, &
+ recip_l_mo_sea, rhostar, &
+ t1_sd_2d, q1_sd_2d, clock)
+ else if (bl_scheme == bl_scheme_1a) then
+ call bl_exp1a_alg(modeldb%config, &
+ theta, rho, exner, mr_n, &
+ derived_fields, &
+ microphysics_fields, orography_fields, &
+ turbulence_fields, convection_fields, cloud_fields, &
+ surface_fields, &
+ clock)
+ end if
end if
!--------------------------------------------------------------------
diff --git a/science/gungho/source/driver/create_physics_prognostics_mod.F90 b/science/gungho/source/driver/create_physics_prognostics_mod.F90
index 6c2ffd64dc..124eab9cf5 100644
--- a/science/gungho/source/driver/create_physics_prognostics_mod.F90
+++ b/science/gungho/source/driver/create_physics_prognostics_mod.F90
@@ -78,6 +78,10 @@ module create_physics_prognostics_mod
use cloud_config_mod, only : scheme, &
scheme_pc2
use convection_config_mod, only : cv_scheme, cv_scheme_comorph
+ use blayer_config_mod, only : bl_scheme, bl_scheme_9c, &
+ bl_scheme_1a, bdy_tke, &
+ bdy_tke_my3, bdy_tke_deardorff, &
+ adv_turb_field, shcu_buoy
use external_forcing_config_mod, only : theta_forcing_nudging, &
theta_forcing, &
wind_forcing_nudging, &
@@ -634,8 +638,6 @@ subroutine process_physics_prognostics(processor)
end if
call processor%apply(make_spec('zh', main%turbulence, &
ckp=checkpoint_flag))
- call processor%apply(make_spec('wvar', main%turbulence, &
- ckp=turb_gen_mixph))
call processor%apply(make_spec('gradrinr', main%turbulence, Wtheta))
! 2D fields, don't need checkpointing
@@ -649,15 +651,21 @@ subroutine process_physics_prognostics(processor)
twod=.true.))
call processor%apply(make_spec('blend_height_tq', main%turbulence, W3, &
twod=.true., is_int=.true.))
- call processor%apply(make_spec('zh_nonloc', main%turbulence, W3, twod=.true.))
call processor%apply(make_spec('zhsc', main%turbulence, W3, twod=.true.))
- call processor%apply(make_spec('bl_weight_1dbl', main%turbulence, W3, &
- twod=.true.))
call processor%apply(make_spec('level_ent', main%turbulence, W3, twod=.true., &
is_int=.true.))
call processor%apply(make_spec('level_ent_dsc', main%turbulence, W3, twod=.true., &
is_int=.true.))
+ ! 2D fields, necessary only for 9C scheme
+ is_empty = (bl_scheme == bl_scheme_1a)
+ call processor%apply(make_spec('zh_nonloc', main%turbulence, W3, &
+ twod=.true., empty = is_empty))
+ call processor%apply(make_spec('bl_weight_1dbl', main%turbulence, W3, &
+ twod=.true., empty = is_empty))
+ call processor%apply(make_spec('wvar', main%turbulence, &
+ ckp=turb_gen_mixph, empty = is_empty))
+
! Space for the 7 BL types
! vector_space => function_space_collection%get_fs(twod_mesh, 0, 0, W3,
! get_ndata_val('boundary_layer_types'))
@@ -670,7 +678,6 @@ subroutine process_physics_prognostics(processor)
call processor%apply(make_spec('lmix_bl', main%turbulence, Wtheta))
call processor%apply(make_spec('dsldzm', main%turbulence, Wtheta))
call processor%apply(make_spec('mix_len_bm', main%turbulence, Wtheta))
- call processor%apply(make_spec('tke_bl', main%turbulence, Wtheta))
call processor%apply(make_spec('rhokm_bl', main%turbulence, Wtheta))
call processor%apply(make_spec('dtrdz_tq_bl', main%turbulence, Wtheta))
call processor%apply(make_spec('dw_bl', main%turbulence, Wtheta))
@@ -706,6 +713,54 @@ subroutine process_physics_prognostics(processor)
call processor%apply(make_spec('ent_zrzi_dsc', main%turbulence, W3, &
mult='entrainment_levels', twod=.true.))
+ ! 3D fields, might need checkpointing
+ if (bl_scheme == bl_scheme_1a) then
+ checkpoint_flag = .true.
+ advection_flag = adv_turb_field
+ else
+ checkpoint_flag = .false.
+ advection_flag = .false.
+ end if
+ call processor%apply(make_spec('tke_bl', main%turbulence, Wtheta, &
+ adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag))
+
+ ! Fields, necessary only for 1A scheme
+
+ ! 2D fields, might need checkpointing
+ if (bl_scheme == bl_scheme_1a .and. shcu_buoy) then
+ checkpoint_flag = .true.
+ else
+ checkpoint_flag = .false.
+ end if
+ call processor%apply(make_spec('zhpar_shcu', main%turbulence, W3, &
+ twod=.true., ckp=checkpoint_flag, empty = (.not. shcu_buoy)))
+
+ ! 3D fields, might need checkpointing
+ if (bl_scheme == bl_scheme_1a .and. bdy_tke /= bdy_tke_deardorff) then
+ is_empty = .false.
+ ! Checkpointing of tsq, qsq and cov are necessary even in level2.5 scheme
+ ! because previous value of those are used in partial condensation scheme.
+ checkpoint_flag = .true.
+ if (bdy_tke == bdy_tke_my3) then
+ advection_flag = adv_turb_field
+ else
+ advection_flag = .false.
+ end if
+ else
+ is_empty = .true.
+ checkpoint_flag = .false.
+ advection_flag = .false.
+ end if
+ call processor%apply(make_spec('tsq_bl', main%turbulence, Wtheta, &
+ adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ empty = is_empty))
+ call processor%apply(make_spec('qsq_bl', main%turbulence, Wtheta, &
+ adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ empty = is_empty))
+ call processor%apply(make_spec('cov_bl', main%turbulence, Wtheta, &
+ adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ empty = is_empty))
+
!========================================================================
! Fields owned by the convection scheme
!========================================================================
diff --git a/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
index 81a5e5c019..5e50b6c3cc 100644
--- a/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
@@ -38,7 +38,8 @@ contains
feign_mixing_config
use finite_element_config_mod, only : cellshape_quadrilateral, &
coord_system_xyz, coord_space_wchi
- use mixing_config_mod, only : method_3d_smag, &
+ use mixing_config_mod, only : method_1a_3d_smag, &
+ method_9c_3d_smag, &
smag_l_calc, smag_l_calc_UseDx
implicit none
@@ -49,13 +50,15 @@ contains
viscosity_mu = 0.0_r_def, &
smagorinsky = .false., &
mix_factor = 0.2_r_def, &
- method = method_3d_smag, &
+ method_1a = method_1a_3d_smag, &
+ method_9c = method_9c_3d_smag, &
smag_l_calc = smag_l_calc_UseDx, &
leonard_term = .false., &
leonard_kl = 4.0_r_def, &
conservative_diffusion = .false., &
density_weighted = .false., &
- max_diff_factor = 1.0_r_def )
+ max_diff_factor = 1.0_r_def, &
+ fullstress = .false. )
call feign_finite_element_config( &
cellshape=cellshape_quadrilateral, &
diff --git a/science/gungho/unit-test/kernel/diffusion/momentum_viscosity_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/momentum_viscosity_kernel_mod_test.pf
index 8f2886041e..1112d2bef1 100644
--- a/science/gungho/unit-test/kernel/diffusion/momentum_viscosity_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/momentum_viscosity_kernel_mod_test.pf
@@ -34,7 +34,6 @@ contains
use sci_chi_transform_mod, only : init_chi_transforms
use feign_config_mod, only : feign_finite_element_config
- use mixing_config_mod, only : method_3d_smag
use finite_element_config_mod, only : cellshape_quadrilateral, &
coord_system_xyz, coord_space_wchi
diff --git a/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
index b89e30e9db..53403c82e2 100644
--- a/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
@@ -37,7 +37,9 @@ contains
use sci_chi_transform_mod, only : init_chi_transforms
use feign_config_mod, only : feign_finite_element_config, &
feign_mixing_config
- use mixing_config_mod, only : method_3d_smag, smag_l_calc, &
+ use mixing_config_mod, only : method_1a_3d_smag, &
+ method_9c_3d_smag, &
+ smag_l_calc, &
smag_l_calc_UseDx
use finite_element_config_mod, only : cellshape_quadrilateral, &
coord_system_xyz, coord_space_wchi
@@ -50,13 +52,15 @@ contains
viscosity_mu = 0.0_r_def, &
smagorinsky = .false., &
mix_factor = 0.2_r_def, &
- method = method_3d_smag, &
+ method_1a = method_1a_3d_smag, &
+ method_9c = method_9c_3d_smag, &
smag_l_calc = smag_l_calc_UseDx, &
leonard_term = .false., &
leonard_kl = 1.0_r_def, &
conservative_diffusion = .false., &
density_weighted = .false., &
- max_diff_factor = 1.0_r_def )
+ max_diff_factor = 1.0_r_def, &
+ fullstress = .false. )
call feign_finite_element_config( &
cellshape=cellshape_quadrilateral, &
diff --git a/science/gungho/unit-test/kernel/diffusion/tracer_viscosity_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/tracer_viscosity_kernel_mod_test.pf
index 87bfd3bb2e..6176c98726 100644
--- a/science/gungho/unit-test/kernel/diffusion/tracer_viscosity_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/tracer_viscosity_kernel_mod_test.pf
@@ -30,7 +30,6 @@ contains
use sci_chi_transform_mod, only : init_chi_transforms
use feign_config_mod, only : feign_finite_element_config
- use mixing_config_mod, only : method_3d_smag
use finite_element_config_mod, only : cellshape_quadrilateral, &
coord_system_xyz, coord_space_wchi
diff --git a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90 b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
new file mode 100644
index 0000000000..f357eaf17b
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
@@ -0,0 +1,1596 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: Calculate the explicit turbulent fluxes of heat, moisture
+! and momentum between atmospheric levels
+! within the boundary layer, and/or the effects of these
+! fluxes on the primary model variables.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 25.
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE bdy_expl2_1a_mod
+
+USE UM_ParCore, ONLY: parcore_mype => mype
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'BDY_EXPL2_1A_MOD'
+CONTAINS
+
+SUBROUTINE bdy_expl2_1a ( &
+! IN values defining vertical grid of model atmosphere :
+ bl_levels,p_theta_levels,land_pts,land_index, cycleno, &
+ r_theta_levels, r_rho_levels, &
+! IN U, V and W momentum fields.
+ u_p,v_p,u_0_px,v_0_px, &
+! IN variables for TKE scheme
+ pstar,p_rho_levs, &
+! IN from other part of explicit boundary layer code
+ rho_mix,rho_wet_tq,rdz,rdz_charney_grid, &
+ z_tq,z_uv,bt,bt_gb,bq_gb, &
+ flandg,rib_gb, sil_orog_land, z0m_eff_gb, &
+! IN cloud/moisture data :
+ q,qcf,qcl,t,qw,tl, &
+! IN everything not covered so far :
+ fb_surf,u_s,h_blend_orog, &
+ zh_prev,ho2r2_orog,sd_orog, &
+! 1 IN 3 INOUT for Smagorinsky
+ delta_smag, rneutml_sq, visc_m, visc_h, &
+! SCM Diagnostics (dummy values in full UM) & stash diagnostics
+ nSCMDpkgs,L_SCMDiags,BL_diag, &
+! INOUT variables
+ zh,ntml,ntpar,l_shallow,cumulus,fqw,ftl,rhokh,rhokm, &
+! INOUT variables on TKE based turbulence schemes
+ e_trb, tsq_trb, qsq_trb, cov_trb, zhpar_shcu, &
+! OUT new variables for message passing
+ tau_fd_x, tau_fd_y, rhogamu, rhogamv, &
+! OUT Diagnostic not requiring STASH flags :
+ shallowc,cu_over_orog, &
+ bl_type_1,bl_type_2,bl_type_3,bl_type_4,bl_type_5,bl_type_6,bl_type_7, &
+! OUT data required for tracer mixing :
+ kent, we_lim, t_frac, zrzi, kent_dsc, we_lim_dsc, t_frac_dsc, zrzi_dsc, &
+! OUT data required elsewhere in UM system :
+ zhsc,ntdsc,nbdsc,wstar,wthvs,uw0,vw0 &
+ )
+
+USE atm_fields_bounds_mod, ONLY: pdims, tdims, tdims_l, &
+ pdims_s, ScmRowLen,ScmRow
+USE bl_option_mod, ONLY: t_drain, h_scale, sg_orog_mixing, local_fa, &
+ free_trop_layers, one_third, sg_shear, &
+ sg_shear_enh_lambda
+USE bl_diags_mod, ONLY: strnewbldiag
+USE cv_run_mod, ONLY: l_param_conv
+USE gen_phys_inputs_mod, ONLY: l_mr_physics
+USE jules_surface_mod, ONLY: formdrag, explicit_stress
+USE model_domain_mod, ONLY: model_type, mt_single_column
+USE mym_option_mod, ONLY: &
+ bdy_tke, deardorff, mymodel25, mymodel3, tke_levels, &
+ l_local_above_tkelvs, l_print_max_tke, l_3dtke
+USE mym_const_mod, ONLY: e_trb_max
+USE um_parcore, ONLY: nproc
+USE planet_constants_mod, ONLY: cp, g, vkman
+USE s_scmop_mod, ONLY: default_streams, &
+ t_avg, d_bl, d_sl, scmdiag_bl
+USE scmoutput_mod, ONLY: scmoutput
+USE turb_diff_mod, ONLY: &
+ l_subfilter_vert, l_subfilter_horiz, mix_factor, &
+ turb_startlev_vert, turb_endlev_vert
+USE umPrintMgr, ONLY: &
+ umPrint, &
+ umMessage
+USE water_constants_mod, ONLY: lc
+
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+
+USE ddf_ctl_mod, ONLY: ddf_ctl
+USE ex_coef_mod, ONLY: ex_coef
+USE mym_ctl_mod, ONLY: mym_ctl
+USE mym_ex_flux_tq_mod, ONLY: mym_ex_flux_tq
+USE fm_drag_mod, ONLY: fm_drag
+
+IMPLICIT NONE
+
+! Inputs :-
+INTEGER, INTENT(IN) :: &
+ land_pts, &
+ ! No.of land points in whole grid.
+ bl_levels, &
+ ! IN Max. no. of "boundary" levels
+ cycleno ! Iteration number (EG outer loop)
+
+! Declaration of new BL diagnostics.
+TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 0:bl_levels+1), &
+ r_theta_levels(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ 0:bl_levels), &
+ r_rho_levels(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ bl_levels), &
+ ! IN height of rho and theta levels
+ rho_mix(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! IN density on UV (ie. rho) levels;
+ ! used in RHOKH so dry density if
+ ! L_mr_physics is true
+ rho_wet_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! IN density on TQ (ie. theta) levels;
+ ! used in RHOKM so wet density
+ rdz( pdims_s%i_start:pdims_s%i_end, &
+ pdims_s%j_start:pdims_s%j_end, bl_levels ), &
+ ! IN RDZ(,1) is the reciprocal of
+ ! the height of level 1, i.e. of
+ ! the middle of layer 1. For
+ ! K > 1, RDZ(,K) is the
+ ! reciprocal of the vertical
+ ! distance from level K-1 to
+ ! level K.
+ rdz_charney_grid(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! IN RDZ(,1) is the reciprocal of
+ ! the height of level 1,
+ ! i.e. of the middle of layer 1
+ ! For K > 1, RDZ(,K) is the
+ ! reciprocal of the vertical
+ ! distance from level K-1 to
+ ! level K.
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! IN Z_tq(*,K) is height of full
+ ! level k.
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels+1), &
+ ! OUT Z_uv(*,K) is height of half
+ ! level k-1/2.
+ u_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! IN U on P-grid.
+ v_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! IN V on P-grid.
+ bt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! IN A buoyancy parameter for clear
+ ! air on p,T,q-levels
+ ! (full levels).
+ bt_gb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! IN A grid-box mean buoyancy param
+ ! on p,T,q-levels (full levels).
+ bq_gb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels)
+ ! IN A grid-box mean buoyancy param
+ ! on p,T,q-levels (full levels).
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ flandg(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end), &
+ ! IN Land fraction on all tiles
+ p_rho_levs(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end, &
+ pdims_s%k_start:bl_levels+1), &
+ ! IN p_rho_levs(*,K) is pressure at half
+ ! level k-1/2.
+ pstar(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! IN Surface pressure (Pascals).
+
+! (f) Atmospheric + any other data not covered so far, incl control.
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN Surface flux buoyancy over
+ ! density (m^2/s^3)
+
+ u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN Surface friction velocity
+ ! (m/s)
+ h_blend_orog(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN Blending height used as part
+ ! of effective roughness scheme
+ zh_prev(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN boundary layer height from
+ ! previous timestep
+ rib_gb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN Bulk Richardson number for lowest
+ ! layer
+ sil_orog_land(land_pts), &
+ ! IN Silhouette area of unresolved
+ ! orography per unit horizontal area
+ delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! IN delta_x used by Smagorinsky
+
+! Additional variables for SCM diagnostics which are dummy in full UM
+INTEGER, INTENT(IN) :: &
+ nSCMDpkgs ! No of SCM diagnostics packages
+
+LOGICAL, INTENT(IN) :: &
+ L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ u_0_px(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end), &
+ ! IN W'ly component of surface
+! current (m/s). P grid
+ v_0_px(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end), &
+ ! IN S'ly component of surface
+! current (m/s). P grid
+ ho2r2_orog(land_pts), &
+ ! IN peak to trough height of
+! unresolved orography
+! on land points only (m)
+ sd_orog(land_pts), &
+ ! IN Standard Deviation of unresolved
+! orography on land points only (m)
+ z0m_eff_gb(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! IN Effective grid-box roughness
+! length for momentum
+
+INTEGER, INTENT(IN) :: &
+ land_index(land_pts) ! IN LAND_INDEX(I)=J => the Jth
+! point in P_FIELD is the Ith
+! land point.
+! (e) Cloud data.
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ qcf(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! IN Cloud ice (kg per kg air)
+ qcl(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! IN Cloud liquid water
+ q(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! IN specific humidity
+ t(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! IN temperature
+ qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! IN Total water content
+ tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels)
+ ! IN Ice/liquid water temperature
+
+! INOUT variables
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ zh(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! INOUT Height above surface of top
+ ! of boundary layer (metres).
+ fqw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! INOUT Moisture flux between layers
+! (kg per square metre per sec).
+! FQW(,1) is total water flux
+! from surface, 'E'.
+ ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! INOUT FTL(,K) contains net turbulent
+! sensible heat flux into layer K
+! from below; so FTL(,1) is the
+! surface sensible heat, H. (W/m2)
+ rhokh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels)
+ ! INOUT Exchange coeffs for moisture.
+
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ rhokm(pdims_s%i_start:pdims_s%i_end, &
+ pdims_s%j_start:pdims_s%j_end ,bl_levels), &
+ ! Exchange coefficients for momentum on P-grid
+ rneutml_sq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! Square of the neutral mixing length scale
+ visc_m(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
+ ! Diffusion coefficient for momentum
+ visc_h(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels)
+ ! Diffusion coefficient for heat and moisture
+! INOUT but not used: variables used in the 1A version (TKE-based schemes)
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ tsq_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ qsq_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ cov_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ zhpar_shcu(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+
+LOGICAL, INTENT(IN OUT) :: &
+ cumulus(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! INOUT Logical switch for trade Cu
+ l_shallow(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! INOUT Flag to indicate shallow
+ ! convection
+
+INTEGER, INTENT(IN OUT) :: &
+ ntml(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! INOUT Number of model layers in the
+ ! turbulently mixed layer
+ ntpar(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! INOUT Top level of initial parcel
+ ! ascent. Used in convection scheme.
+
+! Outputs :-
+! (a) Calculated anyway (use STASH space from higher level) :-
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ rhogamu(pdims_s%i_start:pdims_s%i_end, &
+ pdims_s%j_start:pdims_s%j_end,2:bl_levels), &
+ ! Counter gradient terms for u
+ ! defined at theta level K-1
+ rhogamv(pdims_s%i_start:pdims_s%i_end, &
+ pdims_s%j_start:pdims_s%j_end,2:bl_levels), &
+ ! Counter gradient terms for v
+ ! defined at theta level K-1
+ tau_fd_x(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end, &
+ bl_levels), &
+ tau_fd_y(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end, &
+ bl_levels), &
+ bl_type_1(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Indicator set to 1.0 if stable
+ ! b.l. diagnosed, 0.0 otherwise.
+ bl_type_2(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Indicator set to 1.0 if Sc over
+ ! stable surface layer diagnosed,
+ ! 0.0 otherwise.
+ bl_type_3(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Indicator set to 1.0 if well
+ ! mixed b.l. diagnosed,
+ ! 0.0 otherwise.
+ bl_type_4(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Indicator set to 1.0 if
+ ! decoupled Sc layer (not over
+ ! cumulus) diagnosed,
+ ! 0.0 otherwise.
+ bl_type_5(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Indicator set to 1.0 if
+ ! decoupled Sc layer over cumulus
+ ! diagnosed, 0.0 otherwise.
+ bl_type_6(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Indicator set to 1.0 if a
+ ! cumulus capped b.l. diagnosed,
+ ! 0.0 otherwise.
+ bl_type_7(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! OUT Indicator set to 1.0 if a
+ ! Shear-dominated unstable b.l.
+ ! diagnosed, 0.0 otherwise.
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ wstar(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Convective velocity scale (m/s)
+ wthvs(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT surface flux of thv (Km/s)
+ shallowc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Shallow Cu diagnostic
+ ! Indicator set to 1.0 if shallow,
+ ! 0.0 if not shallow or not cumulus
+ cu_over_orog(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Indicator for cumulus
+ ! over steep orography
+ ! Indicator set to 1.0 if true,
+ ! 0.0 if false. Exclusive.
+ we_lim(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,3), &
+ ! OUT rho*entrainment rate implied b
+ ! placing of subsidence
+ zrzi(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,3), &
+ ! OUT (z-z_base)/(z_i-z_base)
+ t_frac(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,3), &
+ ! OUT a fraction of the timestep
+ we_lim_dsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,3), &
+ ! OUT rho*entrainment rate implied b
+ ! placing of subsidence
+ zrzi_dsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,3), &
+ ! OUT (z-z_base)/(z_i-z_base)
+ t_frac_dsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,3), &
+ ! OUT a fraction of the timestep
+ zhsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! OUT Top of decoupled layer
+
+INTEGER, INTENT(OUT) :: &
+ ntdsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Top level for turb mixing in
+! any decoupled Sc layer
+ nbdsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT Bottom level of any decoupled
+ ! turbulently-mixed Sc layer.
+ kent(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT grid-level of SML inversion
+ kent_dsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! OUT grid-level of DSC inversion
+
+!-2 Genuinely output, needed by other atmospheric routines :-
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ uw0(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! OUT U-component of surface wind stress
+ ! on P-grid
+ vw0(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! OUT V-component of surface wind stress
+ ! on P-grid
+!-----------------------------------------------------------------------
+! Symbolic constants (parameters) reqd in top-level routine :-
+
+REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
+ ! Temporary for SCM output
+REAL(KIND=real_umphys) :: sl(ScmRowLen,ScmRow,bl_levels) ! Static energy
+
+! Parameters also passed to EX_COEF
+! Layer interface K_LOG_LAYR-1/2 is the highest which requires log
+! profile correction factors to the vertical finite differences.
+! The value should be reassessed if the vertical resolution is changed.
+! We could set K_LOG_LAYR = BL_LEVELS and thus apply the correction
+! factors for all the interfaces treated by the boundary layer scheme;
+! this would be desirable theoretically but expensive computationally
+! because of the use of the log function.
+INTEGER, PARAMETER :: k_log_layr = 2
+!-----------------------------------------------------------------------
+! Workspace :-
+REAL(KIND=real_umphys) :: &
+ dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Buoyancy gradient across layer
+ ! interface.
+ dvdzm(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels), &
+ ! Modulus of wind shear.
+ rmlmax2(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! Square of asymptotic mixing length
+ ! for Smagorinsky scheme
+ ri(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,2:bl_levels), &
+ ! Local Richardson number.
+ rhokh_th_ri(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels), &
+ rhokm_ri(pdims_s%i_start:pdims_s%i_end, &
+ pdims_s%j_start:pdims_s%j_end ,bl_levels), &
+ ! Exchange coefficients for momentum and
+ ! heat on theta-levels as calculated by
+ ! the local Ri-based scheme
+ weight_1dbl(pdims%i_start:pdims%i_end, &
+ pdims%j_start:pdims%j_end ,bl_levels), &
+ ! Weighting applied to 1D BL scheme
+ ! to blend with Smagorinsky scheme,
+ ! index k held on theta level (k-1)
+ weight_1dbl_rho(pdims%i_start:pdims%i_end, &
+ pdims%j_start:pdims%j_end,bl_levels), &
+ ! weight_1dbl interpolated to rho levels
+ elm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,2:bl_levels), &
+ ! Mixing length for momentum as
+ ! calculated by the Ri-based scheme
+ elh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,2:bl_levels), &
+ elh_rho(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Mixing length for heat (m),
+ ! held on theta and rho levels, resp.
+ tke_loc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels), &
+ ! Ri-based scheme diagnosed TKE
+ fm_3d(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! stability function for momentum transport
+ ! level 1 value is dummy
+ fh_3d(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! stability function for heat and moisture.
+ ! level 1 value is dummy
+ sigma_h(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Standard deviation of subgrid
+ ! orography (m) [= 2root2 * ho2r2_orog]
+ p_half(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels)
+
+REAL(KIND=real_umphys), ALLOCATABLE :: visc_h_rho (:,:,:)
+ ! visc_h on rho levels
+
+REAL(KIND=real_umphys) :: &
+ zh_local(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! Height above surface of top of
+ ! boundary layer (metres) as
+ ! determined from the local
+ ! Richardson number profile.
+ dtldz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! TL+gz/cp gradient between
+ ! levels K and K-1
+ dqwdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! QW gradient between
+ dtldzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of TL across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dqwdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of QW across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Gradient of u at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+ dvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels)
+ ! Gradient of v at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+
+INTEGER :: &
+ ntml_local(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! Number of model layers in the
+! turbulently mixed layer as
+! determined from the local
+! Richardson number profile.
+ ntml_nl(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! Number of model layers in the
+! turbulently mixed layer as
+! determined from the parcel ascent.
+
+LOGICAL :: &
+ unstable(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! Logical switch for unstable
+ ! surface layer.
+ dsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! Flag set if decoupled
+ ! stratocumulus layer found
+
+REAL(KIND=real_umphys) :: &
+ rhogamt(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels), &
+ ! Counter gradient terms for TL
+ ! defined at rho levels
+ rhogamq(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels)
+ ! Counter gradient terms for QW
+ ! defined at rho levels
+
+REAL(KIND=real_umphys) :: &
+ lambda_min
+ ! Min value of length scale LAMBDA.
+
+! Local scalars :-
+REAL(KIND=real_umphys) :: &
+ weight1, &
+ weight2, &
+ weight3, &
+ r_weight1, &
+ zpr, &
+ ! z/sigma_h
+ slope, &
+ ! subgrid orographic slope
+ grcp ! G/CP
+
+INTEGER :: &
+ i,j,iScm,jScm, &
+ ! LOCAL Loop counter (horizontal field index).
+ k,ient, &
+ ! LOCAL Loop counter (vertical level index).
+ l
+! LOCAL Loop counter for land points
+
+! for print max
+INTEGER :: max_indices(3)
+INTEGER :: istat_gc ! status code of gc_rmax
+INTEGER :: mype ! my node ID
+INTEGER :: ikind ! loop counter for e_trb, tsq, qsq, cov
+INTEGER :: e_kind ! end number of ikind
+INTEGER :: asize ! work variable
+CHARACTER(LEN=5) :: varname(4)
+ ! variable names
+INTEGER, ALLOCATABLE :: indx_pe(:, :)
+ ! indices of the maximum points
+ ! in my processor
+INTEGER, ALLOCATABLE :: sumi(:, :)
+ ! indices and pe number
+REAL(KIND=real_umphys), ALLOCATABLE :: max_pe(:)
+ ! maximum values in my processor
+REAL(KIND=real_umphys), ALLOCATABLE :: max_real(:)
+ ! maximum values in the whole domain
+REAL(KIND=real_umphys), ALLOCATABLE :: abs_cov(:, :, :)
+ ! absolute values of cov_trb
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName = 'BDY_EXPL2_1A'
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+! Parameter check
+! error checking here moved to readsize/scm_shell
+
+! set pressure array.
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ p_half(i,j,1) = pstar(i,j)
+ END DO
+END DO
+DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ p_half(i,j,k) = p_rho_levs(i,j,k)
+ END DO
+ END DO
+END DO ! end of loop over bl_levels
+
+!-----------------------------------------------------------------------
+IF (formdrag == explicit_stress) THEN
+ !------------------------------------------------------------------
+ ! Calculate stress profiles
+ !------------------------------------------------------------------
+ CALL fm_drag ( &
+ ! IN levels
+ land_pts, land_index, bl_levels, &
+ ! IN fields
+ u_p, v_p, tl, qw, bt_gb, bq_gb, rho_wet_tq, &
+ z_uv, z_tq, z0m_eff_gb, zh_prev, rib_gb, sil_orog_land, &
+ ! OUT fields
+ tau_fd_x(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 1:bl_levels), &
+ tau_fd_y(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 1:bl_levels) &
+ )
+ !------------------------------------------------------------------
+ ! Orographic stress diagnostics
+ !------------------------------------------------------------------
+ IF (BL_diag%l_ostressx) THEN
+ DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%ostressx(i,j,k)=tau_fd_x(i,j,k)
+ END DO
+ END DO
+ END DO
+ END IF
+ IF (BL_diag%l_ostressy) THEN
+ DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%ostressy(i,j,k)=tau_fd_y(i,j,k)
+ END DO
+ END DO
+ END DO
+ END IF
+
+END IF
+
+!------------------------------------------------------------------
+! Initialize weighting applied to 1d BL scheme
+! (used to blend 1D with 3D Smagorinsky scheme)
+!------------------------------------------------------------------
+DO k = 1, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ weight_1dbl(i,j,k) = 1.0
+ weight_1dbl_rho(i,j,k) = 1.0 ! dummy here
+ END DO
+ END DO
+END DO
+!------------------------------------------------------------------
+! Initialize fluxes
+!------------------------------------------------------------------
+DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ ftl(i,j,k) = 0.0
+ fqw(i,j,k) = 0.0
+ END DO
+ END DO
+END DO
+!-------------------------------------------------------------
+! Set all variables from the non-local scheme to zero or "off"
+! - reset all fluxes and K's arising from the non-local scheme
+!-------------------------------------------------------------
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ ntml_nl(i,j) = ntml(i,j)
+ ! decoupled mixed layer
+ dsc(i,j) = .FALSE.
+ ntdsc(i,j) = 0
+ nbdsc(i,j) = 0
+ zhsc(i,j) = 0.0
+ ! entrainment variables for non-local tracer mixing
+ kent(i,j) = 2
+ kent_dsc(i,j) = 2
+ DO ient = 1, 3
+ t_frac(i,j,ient) = 0.0
+ zrzi(i,j,ient) = 0.0
+ we_lim(i,j,ient) = 0.0
+ t_frac_dsc(i,j,ient) = 0.0
+ zrzi_dsc(i,j,ient) = 0.0
+ we_lim_dsc(i,j,ient) = 0.0
+ END DO
+ unstable(i,j) = (fb_surf(i,j) > 0.0)
+ END DO
+END DO
+
+! for compatibility to the original bdy_expl2
+IF (l_subfilter_vert) THEN
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ cumulus(i,j) = .FALSE.
+ l_shallow(i,j) = .FALSE.
+ ntpar(i,j) = 0
+ ntml_nl(i,j) = -1 ! to ensure correct diagnostics
+ zh(i,j) = 0.0
+ END DO
+ END DO
+END IF
+!-----------------------------------------------------------------------
+! Calculate lapse rates
+!-----------------------------------------------------------------------
+grcp = g/cp
+DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ dtldz(i,j,k) = ( tl(i,j,k) - tl(i,j,k-1) ) &
+ * rdz_charney_grid(i,j,k) + grcp
+ dqwdz(i,j,k) = ( qw(i,j,k) - qw(i,j,k-1) ) &
+ * rdz_charney_grid(i,j,k)
+ END DO
+ END DO
+END DO
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( l_scmdiags(scmdiag_bl) .AND. &
+ model_type == mt_single_column ) THEN
+
+ DO k=1, bl_levels
+ DO j=pdims%j_start, pdims%j_end
+ jScm = j - pdims%j_start + 1
+ DO i=pdims%i_start, pdims%i_end
+ iScm = i - pdims%i_start + 1
+ sl(iScm,jScm,k) = tl(i,j,k) + grcp*z_tq(i,j,k)
+ END DO ! i
+ END DO ! j
+ END DO ! k
+
+ ! Output SL
+
+ CALL scmoutput(sl,'SL', &
+ 'Liquid/frozen water static energy (IN)','K', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ ! Output QW
+
+ CALL scmoutput(qw,'qw', &
+ 'Total water content (IN)','kg/kg', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+END IF ! scmdiag_bl / model_type
+
+
+! Calculate `buoyancy' gradient, DBDZ, on theta-levels
+! NOTE: DBDZ(K) is on theta-level K-1
+DO k = 3, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ r_weight1 = 1.0 / (r_rho_levels(i,j,k) - &
+ r_rho_levels(i,j,k-1))
+ weight2 = r_theta_levels(i,j,k-1)- &
+ r_rho_levels(i,j,k-1)
+ weight3 = r_rho_levels(i,j,k) - &
+ r_theta_levels(i,j,k-1)
+ dtldzm(i, j, k) = (weight2 * dtldz(i,j,k) &
+ + weight3 * dtldz(i,j,k-1)) * r_weight1
+ dqwdzm(i, j, k) = (weight2 * dqwdz(i,j,k) &
+ + weight3 * dqwdz(i,j,k-1)) * r_weight1
+ dbdz(i,j,k) = g*( bt_gb(i,j,k-1)*dtldzm(i, j, k) + &
+ bq_gb(i,j,k-1)*dqwdzm(i, j, k))
+ END DO
+ END DO
+END DO
+
+k = 2
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ dtldzm(i,j,k) = dtldz(i,j,k)
+ dqwdzm(i,j,k) = dqwdz(i,j,k)
+ dbdz(i,j,k) = g*( bt_gb(i,j,k-1)*dtldz(i,j,k) + &
+ bq_gb(i,j,k-1)*dqwdz(i,j,k) )
+ END DO
+END DO
+
+!--------------------------------------------------
+! Calculate modulus of shear on theta-levels
+! dvdzm(k) is on theta-level(k-1)
+!--------------------------------------------------
+DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ ! Calculation of dudz, dvdz is temporary until use of shear terms
+ ! is sorted.
+ dudz(i, j, k) = (u_p(i,j,k) - u_p(i,j,k-1)) * rdz(i, j, k)
+ dvdz(i, j, k) = (v_p(i,j,k) - v_p(i,j,k-1)) * rdz(i, j, k)
+ END DO
+ END DO
+END DO
+
+IF ((.NOT. l_subfilter_vert) .AND. (.NOT. l_3dtke) ) THEN
+
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ dvdzm(i, j, k) = MAX ( 1.0e-12 , &
+ SQRT(dudz(i, j, k) ** 2 + dvdz(i, j, k) ** 2))
+ END DO
+ END DO
+ END DO
+
+ELSE
+ ! On entry, visc_m is 3D shear(k) on theta-level(k)
+
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ dvdzm(i,j,k) = MAX( 1.0e-12 , visc_m(i,j,k-1) )
+ END DO
+ END DO
+ END DO
+
+END IF
+
+IF (l_subfilter_horiz .OR. l_subfilter_vert .OR. l_3dtke) THEN
+
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ rmlmax2(i,j) = ( mix_factor * delta_smag(i,j) )**2
+ END DO
+ END DO
+
+ DO k = 1, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ rneutml_sq(i,j,k) = 1.0 / ( &
+ 1.0/( vkman*(z_tq(i,j,k) + z0m_eff_gb(i,j)) )**2 &
+ + 1.0/rmlmax2(i,j) )
+ END DO
+ END DO
+ END DO
+
+END IF
+!-----------------------------------------------------------------------
+! Orographic enhancement of subgrid mixing
+!-----------------------------------------------------------------------
+! Calculate 2D array for standard deviation of subgrid orography.
+!-----------------------------------------------------------------------
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ sigma_h(i,j) = 0.0
+ END DO
+END DO
+DO l = 1, land_pts
+ j=(land_index(l)-1)/pdims%i_end + 1
+ i=land_index(l) - (j-1)*pdims%i_end
+ sigma_h(i,j) = MIN( sd_orog(l), 300.0 )
+END DO
+!-----------------------------------------------------------------------
+! Enhance resolved shear through unresolved subgrid drainage flows.
+!-----------------------------------------------------------------------
+IF (sg_orog_mixing == sg_shear .OR. &
+ sg_orog_mixing == sg_shear_enh_lambda) THEN
+
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+
+ IF (sigma_h(i,j) > 1.0 ) THEN
+ zpr = z_tq(i,j,k-1)/sigma_h(i,j)
+ ! Height dependence, to reduce effect to zero with height
+ ! gives z_scale~[1,0.95,0.5,0] at zpr=[0,0.6,1,1.7]
+ weight1 = 0.5*( 1.0 - TANH(4.0*(zpr-1.0) ) )
+
+ ! Take slope ~ sd/h_scale for small sd;
+ ! tends to 0.2 for large sd
+ slope = 1.0 / SQRT( 25.0 + (h_scale/sigma_h(i,j))**2 )
+
+ dvdzm(i,j,k) = MAX ( dvdzm(i,j,k), &
+ weight1*slope*t_drain*dbdz(i,j,k) )
+
+ IF (k==2 .AND. BL_diag%l_dvdzm) &
+ BL_diag%dvdzm(i,j,1)=weight1*slope*t_drain*dbdz(i,j,k)
+
+ END IF
+ END DO
+ END DO
+ END DO
+
+END IF ! sg_orog_mixing
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( l_scmdiags(scmdiag_bl) .AND. &
+ model_type == mt_single_column ) THEN
+
+ TmpScm3d(:,:,1) = 0.0
+
+ DO k=2, bl_levels
+ DO j=pdims%j_start, pdims%j_end
+ jScm = j - pdims%j_start + 1
+ DO i=pdims%i_start, pdims%i_end
+ iScm = i - pdims%i_start + 1
+ TmpScm3d(iScm, jScm, k) = dtldz(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'DTLDZ', &
+ 'Vertical gradient of TL', 'K/m', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k=2, bl_levels
+ DO j=pdims%j_start, pdims%j_end
+ jScm = j - pdims%j_start + 1
+ DO i=pdims%i_start, pdims%i_end
+ iScm = i - pdims%i_start + 1
+ TmpScm3d(iScm, jScm, k) = dqwdz(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'DQWDZ', &
+ 'Vertical gradient of QW','1/m', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k=2, bl_levels
+ DO j=pdims%j_start, pdims%j_end
+ jScm = j - pdims%j_start + 1
+ DO i=pdims%i_start, pdims%i_end
+ iScm = i - pdims%i_start + 1
+ TmpScm3d(iScm, jScm, k) = dbdz(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'DBDZ', &
+ 'Vertical gradient of buoyancy','1/ms2', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k=2, bl_levels
+ DO j=pdims%j_start, pdims%j_end
+ jScm = j - pdims%j_start + 1
+ DO i=pdims%i_start, pdims%i_end
+ iScm = i - pdims%i_start + 1
+ TmpScm3d(iScm, jScm, k) = dvdzm(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'DVDZM', &
+ 'Vertical gradient of wind velocity','1/s', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ CALL scmoutput(fb_surf,'FB_SURF', &
+ 'buoyancy flux at the surface','m2/s3', &
+ t_avg,d_sl,default_streams,'',routinename)
+
+END IF ! scmdiag_bl / model_type
+
+!------------------------------------------------------------------
+! call main subroutines
+!------------------------------------------------------------------
+IF (bdy_tke == mymodel25 .OR. bdy_tke == mymodel3) THEN
+ CALL mym_ctl( &
+ !in levels/switches
+ bl_levels, bdy_tke, nSCMDpkgs,L_SCMDiags, &
+ BL_diag, cycleno, &
+ !in fields
+ z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, qcf, bq_gb, bt_gb, &
+ rho_mix, rho_wet_tq, fqw, ftl, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, &
+ p_theta_levels, p_half, u_s, fb_surf, pstar, &
+ ! inout
+ e_trb, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh, zhpar_shcu, &
+ ! out
+ rhogamu, rhogamv, rhogamt, rhogamq)
+ELSE IF (bdy_tke == deardorff) THEN
+ CALL ddf_ctl( &
+ ! IN levels/switches
+ bl_levels, nSCMDpkgs, L_SCMDiags, BL_diag, cycleno, &
+ ! IN fields
+ z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, &
+ qcf, p_theta_levels, p_half,bq_gb, bt_gb, rho_mix, rho_wet_tq, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, u_s, fb_surf, pstar, &
+ ! INOUT fields
+ e_trb, rhokm, rhokh, zhpar_shcu)
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ rhogamu(i, j, k) = 0.0
+ rhogamv(i, j, k) = 0.0
+ rhogamt(i, j, k) = 0.0
+ rhogamq(i, j, k) = 0.0
+ END DO
+ END DO
+ END DO
+END IF
+
+! RHOKM and RHOKH could be changed by the subgrid turbulence
+! scheme, but BL_diag%rhokm, rhokh are the exchange coefficients
+! by the TKE schemes, which is the same sense in bdy_expl2 for
+! the UM BL scheme.
+
+IF (BL_diag%l_rhokm) THEN
+ DO k = 1, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ BL_diag%rhokm(i,j,k)=rhokm(i,j,k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_rhokh) THEN
+ DO k = 1, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ BL_diag%rhokh(i,j,k)=rhokh(i,j,k)
+ END DO
+ END DO
+ END DO
+END IF
+
+!-----------------------------------------------------------------------
+! The purpose of this block is to calculate local mixing above tke_levels
+! and the stability functions FM_3D and FM_3H with EX_COEF.
+!-----------------------------------------------------------------------
+IF (l_subfilter_horiz .OR. l_subfilter_vert .OR. &
+ (tke_levels < bl_levels .AND. l_local_above_tkelvs)) THEN
+
+ ! call local coeff calculation for levels 2 to bl_levels
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ ri(i, j, k) = dbdz(i, j, k) &
+ / ( dvdzm(i, j, k) * dvdzm(i ,j, k) )
+ END DO
+ END DO
+ END DO
+
+ IF (BL_diag%l_gradrich) THEN
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ BL_diag%gradrich(i,j,k)=ri(i,j,k)
+ END DO
+ END DO
+ END DO
+ END IF
+ !-----------------------------------------------------------------------
+ ! call local coeff calculation for levels 2 to bl_levels
+ !-----------------------------------------------------------------------
+ CALL ex_coef ( &
+ ! IN levels/logicals
+ bl_levels,k_log_layr,nSCMDpkgs,L_SCMDiags,BL_diag, &
+ ! IN fields
+ sigma_h,flandg,dbdz,dvdzm,ri,rho_wet_tq,z_uv,z_tq,z0m_eff_gb, &
+ h_blend_orog,zhpar_shcu,ntpar,ntml_nl,ntdsc,nbdsc,u_p,v_p,u_s, &
+ fb_surf,qw,tl,l_shallow,rmlmax2, rneutml_sq, delta_smag, &
+ ! IN/OUT fields
+ cumulus,weight_1dbl, &
+ ! OUT fields
+ lambda_min,zh_local,ntml_local,elm,elh,elh_rho,rhokm_ri, &
+ rhokh_th_ri,fm_3d,fh_3d,tke_loc &
+ )
+ !------------------------------------------------------------------
+ ! set diffusion coefs between tke_levels + 1 and bl_levels
+ ! with ones by the local scheme (EX_COEF)
+ !------------------------------------------------------------------
+ IF (tke_levels < bl_levels .AND. l_local_above_tkelvs) THEN
+ DO k = tke_levels + 1, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ rhokm(i, j, k) = rhokm_ri(i, j, k)
+
+ weight1 = r_theta_levels(i,j,k) - &
+ r_theta_levels(i,j, k-1)
+ weight2 = r_theta_levels(i,j,k) - &
+ r_rho_levels(i,j,k)
+ weight3 = r_rho_levels(i,j,k) - &
+ r_theta_levels(i,j,k-1)
+ IF ( k == bl_levels ) THEN
+ ! assume RHOKH_uv(BL_LEVELS+1) is zero
+ rhokh(i,j,k) = ( weight2/weight1 ) * rhokh_th_ri(i,j,k)
+ ELSE
+ rhokh(i,j,k) = weight3/weight1 * &
+ rhokh_th_ri(i,j,k+1) &
+ +weight2/weight1 * &
+ rhokh_th_ri(i,j,k)
+ END IF
+
+ IF (local_fa /= free_trop_layers) THEN
+ !--------------------------------------------------------
+ ! Code moved from EX_COEF to avoid interpolation:
+ ! Include mixing length, ELH, in RHOKH.
+ ! Here only use free trop mixing length, lambda_min
+ !--------------------------------------------------------
+ rhokh(i,j,k) = lambda_min * rhokh(i,j,k)
+ END IF ! test on local_fa NE free_trop_layers
+
+ ! Finally multiply RHOKH by dry density
+ IF (l_mr_physics) rhokh(i,j,k) = rho_mix(i,j,k) * rhokh(i,j,k)
+
+ END DO
+ END DO
+ END DO
+ END IF
+
+ IF (l_subfilter_horiz .OR. l_subfilter_vert) THEN
+
+ ! visc_m and visc_h for levels below tke_levels are set in mym_ctl.
+
+ IF (l_3dtke .AND. &
+ (tke_levels < bl_levels .AND. l_local_above_tkelvs)) THEN
+
+ DO k = tke_levels, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ visc_m(i,j,k) = visc_m(i,j,k)*rneutml_sq(i,j,k)
+ visc_h(i,j,k) = visc_h(i,j,k)*rneutml_sq(i,j,k)
+ END DO
+ END DO
+ END DO
+
+ DO k = tke_levels, bl_levels-1
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ ! stability functions are indexed with Ri, fm(k) on w(k-1)
+ visc_m(i,j,k) = visc_m(i,j,k)*fm_3d(i,j,k+1)
+ visc_h(i,j,k) = visc_h(i,j,k)*fh_3d(i,j,k+1)
+ END DO
+ END DO
+ END DO
+
+ ELSE IF (.NOT. l_3dtke) THEN
+
+ ! visc_m,h on IN are just S and visc_m,h(k) are co-located with w(k)
+ DO k = 1, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ visc_m(i,j,k) = visc_m(i,j,k)*rneutml_sq(i,j,k)
+ visc_h(i,j,k) = visc_h(i,j,k)*rneutml_sq(i,j,k)
+ END DO
+ END DO
+ END DO
+
+ DO k = 1, bl_levels-1
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ ! stability functions are indexed with Ri, fm(k) on w(k-1)
+ visc_m(i,j,k) = visc_m(i,j,k)*fm_3d(i,j,k+1)
+ visc_h(i,j,k) = visc_h(i,j,k)*fh_3d(i,j,k+1)
+ END DO
+ END DO
+ END DO
+
+ END IF
+ ! visc_m and visc _h are now lambda^2*S*FM and lambda^2*S*FH
+
+ IF (l_subfilter_vert) THEN
+
+ ! visc_h_rho(k) is held on rho(k), same as BL's rhokh
+ ALLOCATE (visc_h_rho(pdims%i_start:pdims%i_end, &
+ pdims%j_start:pdims%j_end, bl_levels))
+
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ weight1 = r_theta_levels(i,j,k) - r_theta_levels(i,j, k-1)
+ weight2 = r_theta_levels(i,j,k) - r_rho_levels(i,j,k)
+ weight3 = r_rho_levels(i,j,k) - r_theta_levels(i,j,k-1)
+ IF ( k == bl_levels ) THEN
+ ! assume visc_h(bl_levels) is zero
+ ! (Ri and thence f_h not defined)
+ visc_h_rho(i,j,k) = (weight2/weight1) * visc_h(i,j,k-1)
+ ELSE
+ visc_h_rho(i,j,k) = (weight3/weight1) * visc_h(i,j,k) &
+ + (weight2/weight1) * visc_h(i,j,k-1)
+ END IF
+ END DO
+ END DO
+ END DO
+
+ ! Overwrite the diffusion coefficients from the local BL scheme
+ !(RHOKM and RHOKH) with those obtained from the Smagorinsky scheme.
+
+ DO k = 2, bl_levels
+ IF (k >= turb_startlev_vert .AND. &
+ k <= turb_endlev_vert) THEN
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ rhokm(i,j,k) = visc_m(i,j,k-1)*rho_wet_tq(i,j,k-1)
+ rhokh(i,j,k) = visc_h_rho(i,j,k)*rho_mix(i,j,k)
+ END DO
+ END DO
+ ELSE
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ rhokm(i,j,k) = 0.0
+ rhokh(i,j,k) = 0.0
+ END DO
+ END DO
+ END IF
+ END DO
+
+ DEALLOCATE (visc_h_rho)
+
+ END IF ! L_subfilter_vert
+ END IF ! L_subfilter_horiz or L_subfilter_vert
+END IF ! Main if-test for calling Ri-based scheme
+
+!-----------------------------------------------------------------------
+! Diagnose boundary layer type.
+! Seven different types are considered:
+! 1 - Stable b.l.
+! 2 - Stratocumulus over a stable surface layer.
+! 3 - Well mixed buoyancy-driven b.l. (possibly with stratocumulus)
+! 4 - Decoupled stratocumulus (not over cumulus).
+! 5 - Decoupled stratocumulus over cumulus.
+! 6 - Cumulus capped b.l.
+! 7 - Shear-dominated unstable b.l.
+
+! Note that this part is exactly the same as the original bdy_expl2,
+! but diagnosed BL types can be only 1, 3, and 6.
+!-----------------------------------------------------------------------
+! First initialise the type variables and set the diagnostic ZHT.
+
+IF (BL_diag%l_zht) THEN
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ bl_diag%zht(i,j) = MAX( zh(i,j) , zhsc(i,j) )
+ END DO
+ END DO
+END IF
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ bl_type_1(i,j) = 0.0
+ bl_type_2(i,j) = 0.0
+ bl_type_3(i,j) = 0.0
+ bl_type_4(i,j) = 0.0
+ bl_type_5(i,j) = 0.0
+ bl_type_6(i,j) = 0.0
+ bl_type_7(i,j) = 0.0
+ END DO
+END DO
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ IF (.NOT. unstable(i,j) .AND. .NOT. dsc(i,j) .AND. &
+ .NOT. cumulus(i,j)) THEN
+ ! Stable b.l.
+ bl_type_1(i,j) = 1.0
+ ELSE IF (.NOT. unstable(i,j) .AND. dsc(i,j) .AND. &
+ .NOT. cumulus(i,j)) THEN
+ ! Stratocumulus over a stable surface layer
+ bl_type_2(i,j) = 1.0
+ ELSE IF (unstable(i,j) .AND. .NOT. cumulus(i,j) .AND. &
+ .NOT. dsc(i,j) ) THEN
+ ! Well mixed b.l. (possibly with stratocumulus)
+ IF ( ntml(i,j) > ntml_nl(i,j) ) THEN
+ ! shear-dominated - currently identified
+ ! by local NTML overriding non-local
+ bl_type_7(i,j) = 1.0
+ ELSE
+ ! buoyancy-dominated
+ bl_type_3(i,j) = 1.0
+ END IF
+ ELSE IF (unstable(i,j) .AND. dsc(i,j) .AND. &
+ .NOT. cumulus(i,j)) THEN
+ ! Decoupled stratocumulus (not over cumulus)
+ bl_type_4(i,j) = 1.0
+ ELSE IF (dsc(i,j) .AND. cumulus(i,j)) THEN
+ ! Decoupled stratocumulus over cumulus
+ bl_type_5(i,j) = 1.0
+ ELSE IF (.NOT. dsc(i,j) .AND. cumulus(i,j)) THEN
+ ! Cumulus capped b.l.
+ bl_type_6(i,j) = 1.0
+ END IF
+ END DO
+END DO
+!-----------------------------------------------------------------------
+! Calculation of explicit fluxes of T,Q
+!-----------------------------------------------------------------------
+CALL mym_ex_flux_tq( &
+ bl_levels, nSCMDpkgs, L_SCMDiags, &
+ tl, qw, rhokh, rhogamt, rhogamq, rdz_charney_grid, &
+ ftl, fqw)
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( l_scmdiags(scmdiag_bl) .AND. &
+ model_type == mt_single_column ) THEN
+
+ CALL scmoutput(u_s,'ustar', &
+ 'Explicit surface friction velocity','m/s', &
+ t_avg,d_sl,default_streams,'',routinename)
+
+ CALL scmoutput(e_trb,'e_trb', &
+ 'Turbulent Kinetic Energy','J/kg', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ IF (bdy_tke == mymodel25 .OR. bdy_tke == mymodel3) THEN
+ CALL scmoutput(tsq_trb,'tsq_trb', &
+ 'Self covariance of thetal','K2', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ CALL scmoutput(qsq_trb,'qsq_trb', &
+ 'Self covariance of qw','kg2/kg2', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ CALL scmoutput(cov_trb,'cov_trb', &
+ 'Correlation of thetal and qw','K2 kg2/kg2', &
+ t_avg,d_bl,default_streams,'',routinename)
+ END IF
+
+END IF ! scmdiag_bl / model_type
+
+
+IF (BL_diag%l_rhogamu) THEN
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ BL_diag%rhogamu(i, j, k) = rhogamu(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_rhogamv) THEN
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ BL_diag%rhogamv(i, j, k) = rhogamv(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_rhogamt) THEN
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ BL_diag%rhogamt(i, j, k) = - cp * rhogamt(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_rhogamq) THEN
+ DO k = 2, bl_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ BL_diag%rhogamq(i, j, k) = - lc * rhogamq(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+!-----------------------------------------------------------------------
+! Calculate explicit surface fluxes of U and V on
+! P-grid for convection scheme
+!-----------------------------------------------------------------------
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ uw0(i,j) = -rhokm(i,j,1) * &
+ ( u_p(i,j,1) - u_0_px(i,j) )
+ vw0(i,j) = -rhokm(i,j,1) * &
+ ( v_p(i,j,1) - v_0_px(i,j) )
+ END DO
+END DO
+!-----------------------------------------------------------------------
+! Set NTML to max number of turbulently mixed layers
+! Calculate quantities to pass to convection scheme.
+!-----------------------------------------------------------------------
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ wstar(i,j) = 0.0
+ wthvs(i,j) = 0.0
+ cu_over_orog(i,j) = 0.0
+ IF ( cumulus(i,j) ) THEN
+ IF ( fb_surf(i,j) > 0.0 ) THEN
+ wstar(i,j) = ( zh(i,j)*fb_surf(i,j) )**one_third
+ wthvs(i,j) = fb_surf(i,j) / ( g * bt(i,j,1) )
+ END IF
+ wstar(i,j) = MAX( 0.1, wstar(i,j) )
+ IF (.NOT. l_param_conv) THEN
+ ntml(i,j) = MAX( 2, ntml_nl(i,j) - 1 )
+ END IF
+ ELSE
+ ntml(i,j) = MAX( ntml_nl(i,j) , ntdsc(i,j) )
+ END IF
+ ! Limit explicitly calculated surface stresses
+ ! to a physically plausible level.
+ IF ( uw0(i,j) >= 5.0 ) THEN
+ uw0(i,j) = 5.0
+ ELSE IF ( uw0(i,j) <= -5.0 ) THEN
+ uw0(i,j) = -5.0
+ END IF
+ IF ( vw0(i,j) >= 5.0 ) THEN
+ vw0(i,j) = 5.0
+ ELSE IF ( vw0(i,j) <= -5.0 ) THEN
+ vw0(i,j) = -5.0
+ END IF
+ IF (BL_diag%l_wstar .AND. (fb_surf(i,j) >0.0)) THEN
+ BL_diag%wstar(i,j)= (zh(i,j)*fb_surf(i,j))**one_third
+ END IF
+ END DO
+END DO
+
+IF (l_param_conv) THEN
+
+ ! Check for CUMULUS having been diagnosed over steep orography.
+ ! Reset to false but keep NTML at NLCL (though decrease by 2 so that
+ ! coupling between BL and convection scheme can be maintained).
+ ! Reset type diagnostics.
+
+ DO l = 1, land_pts
+ j=(land_index(l)-1)/pdims%i_end + 1
+ i=land_index(l) - (j-1)*pdims%i_end
+ IF (cumulus(i,j) .AND. ho2r2_orog(l) > 900.0) THEN
+ cumulus(i,j) = .FALSE.
+ l_shallow(i,j) = .FALSE.
+ bl_type_5(i,j) = 0.0
+ bl_type_6(i,j) = 0.0
+ cu_over_orog(i,j) = 1.0
+ IF (ntml(i,j) >= 3) ntml(i,j) = ntml(i,j) - 2
+ END IF
+ END DO
+
+ ! Check that CUMULUS and L_SHALLOW are still consistent
+
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ IF ( .NOT. cumulus(i,j) ) l_shallow(i,j) = .FALSE.
+ END DO
+ END DO
+
+END IF ! (l_param_conv)
+!-----------------------------------------------------------------------
+! Set shallow convection diagnostic: 1.0 if L_SHALLOW (and CUMULUS)
+! 0.0 if .NOT. CUMULUS
+!-----------------------------------------------------------------------
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ IF ( cumulus(i,j) .AND. l_shallow(i,j) ) THEN
+ shallowc(i,j) = 1.0
+ ELSE
+ shallowc(i,j) = 0.0
+ END IF
+ END DO
+END DO
+
+! Print the maximum values of the prognostic variables
+IF (l_print_max_tke) THEN
+ IF (bdy_tke == mymodel25 .OR. bdy_tke == mymodel3) THEN
+ ! for e_trb, tsq, qsq and cov
+ e_kind = 4
+ ELSE IF (bdy_tke == deardorff) THEN
+ ! for e_trb
+ e_kind = 1
+ END IF
+
+ ALLOCATE(max_real(e_kind))
+ ALLOCATE(indx_pe(3, e_kind))
+ ALLOCATE(max_pe(e_kind))
+ ALLOCATE(sumi(4, e_kind))
+
+ ! obtain the maximum values on each processor
+ DO ikind = 1, e_kind
+ IF (ikind == 1) THEN
+ max_indices = MAXLOC( &
+ e_trb(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end,1:tke_levels))
+ max_real(ikind) = e_trb( &
+ max_indices(1), max_indices(2), max_indices(3))
+ ELSE IF (ikind == 2) THEN
+ max_indices = MAXLOC( &
+ tsq_trb(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end,1:tke_levels))
+ max_real(ikind) = tsq_trb( &
+ max_indices(1), max_indices(2), max_indices(3))
+ ELSE IF (ikind == 3) THEN
+ max_indices = MAXLOC( &
+ qsq_trb(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end,1:tke_levels))
+ max_real(ikind) = qsq_trb( &
+ max_indices(1), max_indices(2), max_indices(3))
+ ELSE IF (ikind == 4) THEN
+ ALLOCATE(abs_cov(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, tke_levels))
+ DO k = 1, tke_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ abs_cov(i, j, k) = ABS(cov_trb(i, j, k))
+ END DO
+ END DO
+ END DO
+ max_indices = MAXLOC( &
+ abs_cov(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end,1:tke_levels))
+ max_real(ikind) = abs_cov( &
+ max_indices(1), max_indices(2), max_indices(3))
+ DEALLOCATE(abs_cov)
+ END IF
+ indx_pe(1, ikind) = max_indices(1)
+ indx_pe(2, ikind) = max_indices(2)
+ indx_pe(3, ikind) = max_indices(3)
+ max_pe(ikind) = max_real(ikind)
+ END DO
+
+ SELECT CASE (model_type)
+
+ CASE (mt_single_column)
+ mype = 0
+
+ CASE DEFAULT
+ mype = parcore_mype
+ ! To avoid the same maximum value at more than two points.
+ ! The points in the processor with the largest mype would be
+ ! selected as the maximum point
+ IF (max_real(1) >= e_trb_max) THEN
+ max_real(1) = max_real(1) + mype * e_trb_max * 1.0e-5
+ max_pe(1) = max_real(1)
+ END IF
+
+ ! the maximum values in the whole domain
+ CALL gc_rmax(e_kind, nproc, istat_gc, max_real)
+
+ END SELECT ! model_type
+
+ DO ikind = 1, e_kind
+ IF (max_pe(ikind) >= max_real(ikind)) THEN
+ ! the maximum is on my pe.
+ ! set indices, pe number
+ sumi(1, ikind) = indx_pe(1, ikind)
+ sumi(2, ikind) = indx_pe(2, ikind)
+ sumi(3, ikind) = indx_pe(3, ikind)
+ sumi(4, ikind) = mype
+ ELSE
+ sumi(1, ikind) = 0
+ sumi(2, ikind) = 0
+ sumi(3, ikind) = 0
+ sumi(4, ikind) = 0
+ END IF
+ END DO
+
+ IF (model_type /= mt_single_column) THEN
+ ! obtain indices and pe number of the maximum points
+ asize = e_kind * 4
+ CALL gc_isum(asize, nproc, istat_gc, sumi)
+
+ ! Back to the original value (i.e. the maximum limit)
+ IF (max_real(1) > e_trb_max) THEN
+ max_real(1) = e_trb_max
+ END IF
+ END IF ! model_type
+
+ IF (mype == 0) THEN
+ varname(1) = 'e_trb'
+ varname(2) = 'tsq '
+ varname(3) = 'qsq '
+ varname(4) = 'cov '
+
+ WRITE(umMessage, '(A)') &
+ ' ***** Maximum turbulent variables at this timestep ***** '
+ CALL umPrint(umMessage,src='bdy_expl2_1a')
+ DO ikind = 1, e_kind
+
+ SELECT CASE (model_type)
+
+ CASE (mt_single_column)
+ ! only with a level number
+ WRITE(umMessage, '(A, A, 1X, E12.5, 1X, A, I4)') &
+ varname(ikind), ' max:', max_real(ikind), 'at level', &
+ sumi(3, ikind)
+ CALL umPrint(umMessage,src='bdy_expl2_1a')
+
+ CASE DEFAULT
+ ! with indices on the local processor and the pe number
+ WRITE(umMessage, &
+ '(1X, A, A, 1X, E12.5, 1X, A, I4, 1X, I4, 1X, I4, A, I4)') &
+ varname(ikind), ' max:', max_real(ikind), 'at (', &
+ sumi(1, ikind), sumi(2, ikind), sumi(3, ikind), &
+ ') on pe ', sumi(4, ikind)
+ CALL umPrint(umMessage,src='bdy_expl2_1a')
+
+ END SELECT ! model_type
+
+ END DO
+ END IF
+
+ DEALLOCATE(sumi)
+ DEALLOCATE(max_pe)
+ DEALLOCATE(indx_pe)
+ DEALLOCATE(max_real)
+END IF
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE bdy_expl2_1a
+END MODULE bdy_expl2_1a_mod
diff --git a/science/physics_schemes/source/boundary_layer/ddf_ctl.F90 b/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
new file mode 100644
index 0000000000..dbd85da680
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
@@ -0,0 +1,842 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: The main subroutine for the first order closure model
+! based on Deardorff (1980).
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE ddf_ctl_mod
+
+USE um_types, ONLY: real_umphys, real_eps
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'DDF_CTL_MOD'
+CONTAINS
+
+SUBROUTINE ddf_ctl( &
+! IN levels/switches
+ bl_levels, nSCMDpkgs, L_SCMDiags, BL_diag, cycleno, &
+! IN fields
+ z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, qcf, &
+ p_theta_levels, p_half, bq_gb, bt_gb, rho_mix, rho_wet_tq, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, u_s, fb_surf, pstar, &
+! INOUT fields
+ e_trb, rhokm, rhokh, zhpar_shcu)
+
+USE atm_fields_bounds_mod, ONLY: tdims_l, tdims, pdims, tdims_s, &
+ ScmRowLen, ScmRow
+USE bl_diags_mod, ONLY: strnewbldiag
+USE dynamics_input_mod, ONLY: numcycles
+USE gen_phys_inputs_mod, ONLY: l_mr_physics
+USE level_heights_mod, ONLY: &
+ r_theta_levels, r_rho_levels
+USE missing_data_mod, ONLY: rmdi
+USE model_domain_mod, ONLY: model_type, mt_single_column
+USE mym_const_mod, ONLY: e_trb_max
+USE mym_option_mod, ONLY: my_ini_dbdz_min, tke_cm_mx, l_shcu_buoy, &
+ l_my_condense, tke_cm_fa, my_lowest_pd_surf, tke_levels, &
+ l_my_ini_zero, l_my_initialize
+USE s_scmop_mod, ONLY: default_streams, &
+ t_avg, d_bl, d_sl, scmdiag_bl
+USE scmoutput_mod, ONLY: scmoutput
+
+USE parkind1, ONLY: jprb, jpim
+USE planet_constants_mod, ONLY: vkman, kappa, pref, c_virtual, grcp, g
+USE yomhook, ONLY: lhook, dr_hook
+
+USE ddf_initialize_mod, ONLY: ddf_initialize
+USE ddf_mix_length_mod, ONLY: ddf_mix_length
+USE mym_calcphi_mod, ONLY: mym_calcphi
+USE mym_condensation_mod, ONLY: mym_condensation
+USE mym_const_set_mod, ONLY: mym_const_set
+USE mym_shcu_buoy_mod, ONLY: mym_shcu_buoy
+USE mym_update_fields_mod, ONLY: mym_update_fields
+IMPLICIT NONE
+
+! Intent In Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels, &
+ ! Max. no. of "boundary" levels
+ cycleno ! Iteration number (EG outer loop)
+
+! Additional variables for SCM diagnostics which are dummy in full UM
+INTEGER, INTENT(IN) :: &
+ nSCMDpkgs ! No of SCM diagnostics packages
+
+LOGICAL, INTENT(IN) :: &
+ L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! IN Z_TQ(*,K) is height of theta level k.
+ u_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! U on P-grid.
+ v_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! V on P-grid.
+ qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! Total water content
+ tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! Ice/liquid water temperature
+ t(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! Temperature
+ q(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! specific humidity
+ qcl(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! Cloud liquid water
+ qcf(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! Cloud ice (kg per kg air)
+ p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 0:bl_levels+1), &
+ ! Pressure at theta level
+ p_half(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels), &
+ ! Pressure on rho levels (Pa)
+ bq_gb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! A grid-box mean buoyancy param
+ ! on T,q-levels (full levels).
+ bt_gb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! A grid-box mean buoyancy param
+ ! on T,q-levels (full levels).
+ rho_mix(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! density on UV (ie. rho) levels;
+ ! used in RHOKH so dry density if
+ ! L_mr_physics is true
+ rho_wet_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! density on TQ (ie. theta) levels;
+ ! used in RHOKM so wet density
+ dtldzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of TL across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dqwdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of QW across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Gradient of u at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+ dvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Gradient of v at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+ dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Modulus of wind shear at theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface friction velocity
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface flux buoyancy over density (m^2/s^3)
+ pstar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! surface pressure
+
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! TKE defined on theta levels K-1
+ rhokm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ bl_levels), &
+ ! Exchange coeffs for momentum
+ ! between K and K-1 on rho levels.
+ ! i.e. the coeffs are defined on theta level K-1.
+ rhokh(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels), &
+ ! Exchange coeffs for scalars
+ ! between K and K-1 on theta levels.
+ ! i.e. the coeffs are defined on rho levels
+ zhpar_shcu(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! Height of mixed layer used to evaluate
+ ! the non-gradient buoyancy flux
+
+! Declaration of BL diagnostics.
+TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+
+! Local Variables
+INTEGER :: &
+ i, j, k, iScm, jScm
+ ! Loop indexes
+
+REAL(KIND=real_umphys) :: &
+ r_weight1, &
+ ! weight factor to interpolate variables on rho
+ ! levels onto theta levels
+ weight2, &
+ ! weight factor to interpolate variables on rho
+ ! levels onto theta levels
+ weight3, &
+ ! weight factor to interpolate variables on rho
+ ! levels onto theta levels
+ taux, &
+ ! stress of x-direction
+ tauy, &
+ ! stress of y-direction
+ r_pr, &
+ ! reciprocal of the Prandtl number
+ coef_cm
+ ! coefficient appeared in determining a diffusion
+ ! coefficients
+
+INTEGER :: &
+ flag_calc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! flag to indicate whether the column should be
+ ! calculated
+
+REAL(KIND=real_umphys) :: &
+ r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! reciprocal of Monin-Obkhov length
+ rhokh_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! density on TQ (ie. theta) levels;
+ ! used in RHOKM so wet density
+ prod(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term
+ disp_coef(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of E_TRB in a dissipation term
+ pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! gradient function for momentum at the surface
+ ! minus non-dimensional height (height / MO length)
+ phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! gradient function for scalars at the surface
+ elm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! mixing length
+ ekw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! sqrt(e_trb) on theta level K-1
+ coef_ce(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficient appeared in a dissipation term
+ sl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! static energy
+ h_pbl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! height of PBL determined by vertical profile
+ ! of SL
+ tsq(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ bl_levels), &
+ ! Self covariance of liquid potential temperature
+ ! (thetal'**2) defined on theta levels K-1
+ qsq(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ bl_levels), &
+ ! Self covariance of total water
+ ! (qw'**2) defined on theta levels K-1
+ cov(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ bl_levels), &
+ ! Correlation between thetal and qw
+ ! (thetal'qw') defined on theta levels K-1
+ vt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Buoyancy parameter for FTL (excluding g/thetav)
+ ! on theta level K-1
+ vq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Buoyancy parameter for FQW (excluding g/thetav)
+ ! on theta level K-1
+ tv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Virtual temperature on theta level K-1
+ dbdz_l(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ exner(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! exner function on theta level K-1
+ gtr(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! G/thetav on theta level K-1
+ q1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! normalized excessive water from the saturation
+ ! on theta level K-1
+ cld(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! cloud fraction derived by the bi-normal
+ ! distribution on theta level K-1
+ ql(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! condensed liquid water derived by the bi-normal
+ ! distribution on theta level K-1
+ prod_m(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term by wind shear
+ prod_h(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term by buoyancy
+ wb_ng(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! buoyancy flux related to the skewness
+ ! on theta level K-1
+ frac_shcu(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! cloud fraction corrected by shallow cumulus
+ ! process on theta level K-1
+
+LOGICAL, SAVE :: &
+ l_first = .TRUE.
+ ! flag to indicate if it is the first execution
+
+INTEGER, PARAMETER :: &
+ levflag = 2
+ ! For using subroutines for the MY model.
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ c_corr = 2.0
+ ! coefficient appeared in parameterizing the width
+ ! of the bi-normal distribution function
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ diff_fact = 2.0
+ ! factor of a diffusion coef of E_TRB to that of
+ ! momentum
+
+! Scm arrays
+REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
+CHARACTER(LEN=*), PARAMETER :: RoutineName = 'DDF_CTL'
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+! Calculate Monin-Obukov Length
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ r_mosurf(i,j)= -vkman*fb_surf(i,j) &
+ / MAX(u_s(i,j)*u_s(i,j)*u_s(i,j), TINY(1.0))
+ END DO
+END DO
+
+! Calculate gradient functions
+IF (my_lowest_pd_surf > 0) THEN
+ CALL mym_calcphi( &
+ bl_levels, z_uv, r_mosurf, pmz, phh)
+END IF
+
+! Calculate static energy to determine the top of mixed layer
+DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ sl(i, j, k) = tl(i, j, k) + grcp * z_tq(i, j, k)
+ sl(i, j, k) = sl(i, j, k) * (1.0 + c_virtual * q(i, j, k) &
+ - qcl(i, j, k) - qcf(i, j, k))
+ END DO
+ END DO
+END DO
+
+! Determine the height of the top of mixed layer
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ flag_calc(i, j) = 1
+ h_pbl(i, j) = z_tq(i, j, 1)
+ END DO
+END DO
+DO k = 2, tke_levels - 1
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (flag_calc(i, j) == 1) THEN
+ IF (sl(i, j, k) > sl(i, j, 1)) THEN
+ h_pbl(i, j) = z_tq(i, j, k - 1) &
+ + (z_tq(i, j, k) - z_tq(i, j, k - 1)) &
+ * (sl(i, j, 1) - sl(i, j, k - 1)) &
+ / (sl(i, j, k) - sl(i, j, k - 1))
+ flag_calc(i, j) = 0
+ END IF
+ END IF
+ END DO
+ END DO
+END DO
+
+! Initialization. Executed only once.
+! In the initialization, balance between production and dissipation
+! is assumed. Diffusion coeffients required to determine production
+! terms are calculated with stability functions.
+IF (l_first) THEN
+ CALL mym_const_set
+
+ ! IF the first value of e_trb has been set to be missing by the
+ ! reconfiguration, the initialization for the whole domain
+ ! is essential.
+ IF (l_my_initialize .OR. ABS(e_trb(1, 1, 1) - rmdi) < real_eps) THEN
+ IF (l_my_ini_zero) THEN
+ DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.0
+ END DO
+ END DO
+ END DO
+ ELSE ! not l_my_ini_zero
+ ! Initialize the prognostic variables by assuming the balance
+ ! between production and dissipation terms
+
+ ! In the initialization, DBDZ by the LS cloud scheme is used.
+ ! To avoid to diagnose huge TKE, the lower limit for DBDZ
+ ! is imposed.
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ dbdz_l(i, j, k) = MAX(my_ini_dbdz_min, dbdz(i, j, k))
+ END DO
+ END DO
+ END DO
+ CALL ddf_initialize( &
+ bl_levels, &
+ z_uv, z_tq, dbdz_l, dvdzm, r_mosurf, fb_surf, u_s, h_pbl, &
+ e_trb)
+ ! Above tke_levels, the prognostic variables should be zeros.
+ DO k = tke_levels + 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.0
+ END DO
+ END DO
+ END DO
+ END IF ! test if l_my_ini_zero
+ END IF ! test if l_my_initialize .OR. e_trb == rmdi
+
+ IF (l_shcu_buoy) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (ABS(zhpar_shcu(i, j) - rmdi) < real_eps) THEN
+ ! if missing has been set by the reconfiguration,
+ ! it is replaced with z_tq(tke_levels-1).
+ zhpar_shcu(i, j) = z_tq(i, j, tke_levels-1)
+ END IF
+ END DO
+ END DO
+ END IF
+ ! need to initialise variables on every cycle as they will have been
+ ! reset to mdi
+ IF (cycleno == numcycles) l_first = .FALSE.
+END IF
+
+CALL ddf_mix_length( &
+ tdims%i_end,tdims%j_end,tdims_l%halo_i,tdims_l%halo_j, bl_levels, &
+ z_uv, z_tq, dbdz, r_mosurf, fb_surf, h_pbl, e_trb, &
+ elm, coef_ce, ekw)
+
+ ! Calculate diffusion coefficients
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (z_tq(i, j, k - 1) < h_pbl(i, j)) THEN
+ coef_cm = tke_cm_mx
+ ELSE
+ coef_cm = tke_cm_fa
+ END IF
+
+ r_pr = 1.0 + 2.0 * elm(i, j, k) &
+ / (r_rho_levels(i, j, k) - r_rho_levels(i, j, k - 1))
+ rhokm(i, j, k) = coef_cm * elm(i, j, k) * ekw(i, j, k)
+ rhokh_tq(i, j, k) = rhokm(i, j, k) * r_pr
+ END DO
+ END DO
+END DO
+
+! Set virtual temperature, exner function and g/thetav
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ tv(i, j, k) = t(i, j, k - 1) &
+ * (1.0 + c_virtual * q(i, j, k - 1) &
+ - qcl(i, j, k - 1) - qcf(i, j, k - 1))
+ exner(i, j, k) = &
+ (p_theta_levels(i, j, k - 1) / pref) ** kappa
+ gtr(i, j, k) = g / tv(i, j, k) * exner(i, j, k)
+ END DO
+ END DO
+END DO
+
+! The covariances to be required by mym_condensation
+! are diagnosed assuming balance between
+! production and dissipation.
+IF (l_my_condense .OR. l_shcu_buoy) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ tsq(i, j, k) = c_corr * elm(i, j, k) ** 2 &
+ * dtldzm(i, j, k) ** 2
+ qsq(i, j, k) = c_corr * elm(i, j, k) ** 2 &
+ * dqwdzm(i, j, k) ** 2
+ cov(i, j, k) = c_corr * elm(i, j, k) ** 2 &
+ * dtldzm(i, j, k) * dqwdzm(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL mym_condensation( &
+ ! IN levels/switches
+ bl_levels, levflag, nSCMDpkgs,L_SCMDiags, &
+ BL_diag, &
+ ! IN fields
+ qw, tl, t, p_theta_levels, tsq, qsq, cov, &
+ ! OUT fields
+ vt, vq, q1, cld, ql)
+END IF
+
+IF (.NOT. l_my_condense) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ ! convert buoy params from the UM notation to the MY notaation
+ vt(i, j, k) = bt_gb(i, j, k - 1) * tv(i, j, k)
+ vq(i, j, k) = bq_gb(i, j, k - 1) * tv(i, j, k) &
+ / exner(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (l_shcu_buoy) THEN
+ CALL mym_shcu_buoy( &
+ ! IN levels/switches
+ bl_levels, nSCMDpkgs,L_SCMDiags, BL_diag, &
+ ! IN fields
+ fb_surf, u_s, pstar, z_tq, z_uv, p_theta_levels, p_half, &
+ u_p, v_p, t, q, qcl, qcf, q1, cld, &
+ ! INOUT / OUT fields
+ zhpar_shcu, frac_shcu, wb_ng)
+ELSE
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ wb_ng(i,j,k) = 0.0
+ frac_shcu(i,j,k) = cld(i,j,k)
+ END DO
+ END DO
+ END DO
+END IF
+
+! Calculate production terms and coefficient of dissipation term.
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ dbdz_l(i, j, k) = gtr(i, j, k) &
+ * (vt(i, j, k) * dtldzm(i, j, k) &
+ + vq(i, j, k) * dqwdzm(i, j, k))
+ prod_h(i, j, k) = - rhokh_tq(i, j, k) * dbdz_l(i, j, k) &
+ + wb_ng(i, j, k)
+
+ taux = rhokm(i, j, k) * dudz(i, j, k)
+ tauy = rhokm(i, j, k) * dvdz(i, j, k)
+
+ prod_m(i, j, k) = taux * dudz(i, j, k) + tauy * dvdz(i, j, k)
+
+
+ prod(i, j, k) = prod_m(i, j, k) + prod_h(i, j, k)
+ disp_coef(i, j, k) = coef_ce(i, j, k) * ekw(i, j, k) &
+ / MAX(elm(i, j, k), 1.0e-20)
+
+ END DO
+ END DO
+END DO
+
+! Overwrite the production term at the lowest level by
+! the one evaluated with surface fluxes.
+IF (my_lowest_pd_surf > 0) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ prod(i, j, 2) = u_s(i, j) ** 3 * pmz(i, j) &
+ / (vkman * z_tq(i, j, 1))
+ END DO
+ END DO
+END IF
+
+CALL mym_update_fields( &
+ bl_levels, diff_fact, rhokm, prod, disp_coef, e_trb)
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( l_scmdiags(scmdiag_bl) .AND. &
+ model_type == mt_single_column ) THEN
+
+!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
+!$OMP PRIVATE(i, j, k) &
+!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
+ DO k = 1, bl_levels
+ DO j = 1, ScmRow
+ DO i = 1, ScmRowLen
+ TmpScm3d(i,j,k) = 0.0
+ END DO
+ END DO
+ END DO
+!$OMP END PARALLEL DO
+
+ DO k=1, bl_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = rhokm(i,j,k)
+ END DO ! i
+ END DO ! j
+ END DO ! k
+
+ CALL scmoutput(TmpScm3d,'momdif', &
+ 'Diffusivity of momentum','kg/(ms)', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k=1, bl_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = rhokh(i,j,k)
+ END DO ! i
+ END DO ! j
+ END DO ! k
+
+ CALL scmoutput(TmpScm3d,'htdiff', &
+ 'Diffusivity of heat','kg/(ms)', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+END IF ! scmdiag_bl / model_type
+
+DO k = tke_levels + 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.0
+ rhokm(i, j, k) = 0.0
+ rhokh_tq(i, j, k) = 0.0
+ rhokh(i, j, k) = 0.0
+ END DO
+ END DO
+END DO
+
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = MIN(MAX(e_trb(i, j, k), 1.0e-20), e_trb_max)
+ rhokm(i, j, k) = rho_wet_tq(i, j, k - 1) * rhokm(i, j, k)
+ END DO
+ END DO
+END DO
+
+! Note "RHO" here is always wet density (RHO_WET_TQ) so
+! save multiplication of RHOKH to after interpolation
+IF (.NOT. l_mr_physics) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ rhokh_tq(i, j, k) = rho_wet_tq(i, j, k - 1) * rhokh_tq(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+! Interpolate RHOKH_TQ on theta levels to rho levels
+DO k = 2, tke_levels - 1
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
+ r_theta_levels(i,j, k-1))
+ weight2 = (r_theta_levels(i,j,k) - &
+ r_rho_levels(i,j,k)) * r_weight1
+ weight3 = (r_rho_levels(i,j,k) - &
+ r_theta_levels(i,j,k-1)) * r_weight1
+ rhokh(i,j,k) = &
+ weight3 * rhokh_tq(i,j,k+1) &
+ +weight2 * rhokh_tq(i,j,k)
+ END DO
+ END DO
+END DO
+
+k = tke_levels
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
+ r_theta_levels(i,j, k-1))
+ weight2 = (r_theta_levels(i,j,k) - &
+ r_rho_levels(i,j,k)) * r_weight1
+
+ rhokh(i, j, k) = weight2 * rhokh_tq(i, j, k)
+ END DO
+END DO
+
+! Finally multiply RHOKH by dry density
+IF (l_mr_physics) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ rhokh(i, j, k) = rho_mix(i, j, k) * rhokh(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_dbdz) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%dbdz(i, j, k) = dbdz_l(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_dvdzm) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%dvdzm(i,j,k) = dvdzm(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_tke_shr_prod) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%tke_shr_prod(i, j, k) = prod_m(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_tke_boy_prod) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%tke_boy_prod(i, j, k) = prod_h(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_tke_boy_prod) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%tke_dissp(i, j, k) = &
+ coef_ce(i, j, k) * (ekw(i, j, k)) ** 3 &
+ / MAX(elm(i, j, k), 1.0e-20)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_elm) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%elm(i, j, k) = elm(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( l_scmdiags(scmdiag_bl) .AND. &
+ model_type == mt_single_column ) THEN
+
+!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
+!$OMP PRIVATE(i, j, k) &
+!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
+ DO k = 1, bl_levels
+ DO j = 1, ScmRow
+ DO i = 1, ScmRowLen
+ TmpScm3d(i,j,k) = 0.0
+ END DO
+ END DO
+ END DO
+!$OMP END PARALLEL DO
+
+ CALL scmoutput(h_pbl,'h_pbl', &
+ 'BL height by vertical profile of SL','m', &
+ t_avg,d_sl,default_streams,'',routinename)
+
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = elm(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'elm', &
+ 'mixing length','m', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm, k) = BL_diag%tke_shr_prod(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'tke_shr_prod', &
+ 'shear production of TKE','m2/s3', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = BL_diag%tke_boy_prod(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'tke_boy_prod', &
+ 'buoyancy production of TKE','m2/s3', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm, jScm, k) = BL_diag%tke_dissp(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'tke_dissp', &
+ ' dissipation of TKE','m2/s3', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+END IF ! scmdiag_bl / model_type
+
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE ddf_ctl
+END MODULE ddf_ctl_mod
diff --git a/science/physics_schemes/source/boundary_layer/ddf_initialize.F90 b/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
new file mode 100644
index 0000000000..a7bb0ab303
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
@@ -0,0 +1,261 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To set the initial TKE in the first order closure model
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE ddf_initialize_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'DDF_INITIALIZE_MOD'
+CONTAINS
+
+SUBROUTINE ddf_initialize( &
+ bl_levels, &
+ z_uv, z_tq, dbdz, dvdzm, r_mosurf, fb_surf, u_s, h_pbl, &
+ e_trb)
+
+USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_s
+USE mym_const_mod, ONLY: e_trb_max
+USE mym_option_mod, ONLY: tke_levels, l_my_extra_level, &
+ my_z_extra_fact, my_lowest_pd_surf, &
+ tke_cm_mx, tke_cm_fa
+USE parkind1, ONLY: jprb, jpim
+USE planet_constants_mod, ONLY: vkman
+USE yomhook, ONLY: lhook, dr_hook
+USE ddf_mix_length_mod, ONLY: ddf_mix_length
+USE mym_calcphi_mod, ONLY: mym_calcphi
+USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
+USE mym_implic_mod, ONLY: mym_implic
+IMPLICIT NONE
+
+! Intent In Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! IN Z_TQ(*,K) is height of theta level k.
+ ! Cloud ice (kg per kg air)
+ dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Modulus of wind shear at theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! reciprocal of Monin-Obkhov length
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface flux buoyancy over density (m^2/s^3)
+ u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface friction velocity
+ h_pbl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! height of PBL determined by vertical profile
+ ! of SL
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels)
+ ! TKE defined on theta levels K-1
+
+! Local variables
+INTEGER :: &
+ i, j, k, ll, &
+ itr_ini
+
+REAL(KIND=real_umphys) :: &
+ r_pr, &
+ elq, &
+ sm, &
+ sh, &
+ gm, &
+ gh
+
+REAL(KIND=real_umphys) :: &
+ ekw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ elm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ coef_cm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ coef_ce(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pdk(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ tke_levels), &
+ aa(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ bb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ cc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ pdk0(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ pr = 0.7, &
+ ! Prandtl number
+ ! only in the initialization,
+ ! constant prandtl number is assumed.
+ diff_fact = 2.0
+ ! factor of a diffusion coef of E_TRB to that of
+ ! momentum
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='DDF_INITIALIZE'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+r_pr = 1.0 / pr
+
+IF (my_lowest_pd_surf == 0) THEN
+ l_my_extra_level = .FALSE.
+ my_z_extra_fact = 1.0
+END IF
+
+! initial guess for e_trb, assuming neutral layer
+! and set some parameters
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (z_tq(i, j, k - 1) < h_pbl(i, j)) THEN
+ coef_cm(i, j, k) = tke_cm_mx
+ ELSE
+ coef_cm(i, j, k) = tke_cm_fa
+ END IF
+ sm = coef_cm(i, j, k)
+ sh = coef_cm(i, j, k) * r_pr
+ gm = dvdzm(i, j, k) ** 2
+ gh = -dbdz(i, j, k)
+ pdk(i, j, k) = sm * gm + sh * gh
+ IF (pdk(i, j, k) <= 0.0) THEN
+ pdk(i, j, k) = 0.0
+ e_trb(i, j, k) = 0.0
+ ELSE
+ e_trb(i, j, k) = 1.0e-5
+ END IF
+ END DO
+ END DO
+END DO
+
+IF (my_lowest_pd_surf > 0) THEN
+ CALL mym_calcphi( &
+ bl_levels, z_tq, r_mosurf, pmz, phh)
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk0(i, j) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
+ / (vkman * z_tq(i, j, 1))
+ END DO
+ END DO
+END IF ! IF MY_lowest_pd_surf
+
+itr_ini = tke_levels + 1
+
+DO ll = 1, itr_ini
+ CALL ddf_mix_length( &
+ tdims%i_end, tdims%j_end, 0, 0, bl_levels, &
+ z_uv, z_tq, dbdz, r_mosurf, fb_surf, h_pbl, e_trb, &
+ elm, coef_ce, ekw)
+
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (e_trb(i, j, k) <= 0.0) THEN
+ ekw(i, j, k) = 0.0
+ END IF
+ dfm(i, j, k) = coef_cm(i, j, k) * ekw(i, j, k) * elm(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL mym_diff_matcoef( &
+ bl_levels, diff_fact, dfm, aa, bb, cc)
+
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (bb(i, j, k) == 0.0) THEN
+ aa(i, j, k) = 0.0
+ bb(i, j, k) = 1.0
+ cc(i, j, k) = 0.0
+ e_trb(i, j, k) = 0.0
+ ELSE
+ elq = ekw(i, j, k) * elm(i, j, k)
+ aa(i, j, k) = - aa(i, j, k)
+ bb(i, j, k) = - bb(i, j, k) &
+ + ekw(i, j, k) * coef_ce(i, j, k) &
+ / MAX(elm(i, j, k), 1.0e-20)
+ bb(i, j, k) = SIGN(MAX(ABS(bb(i, j, k)), 1.0e-20), &
+ bb(i, j, k))
+
+ cc(i, j, k) = - cc(i, j, k)
+ e_trb(i, j, k) = elq * pdk(i, j, k)
+ END IF
+ END DO
+ END DO
+ END DO
+
+ IF (my_lowest_pd_surf > 0) THEN
+ k = 2
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (bb(i, j, k) /= 0.0 .AND. pdk(i, j, k) > 0.0) THEN
+ e_trb(i, j, k) = pdk0(i, j)
+ END IF
+ END DO
+ END DO
+ END IF ! IF MY_lowest_pd_surf > 0
+
+ CALL mym_implic( &
+ tke_levels, 2, tke_levels, aa, bb, cc, e_trb)
+END DO ! DO ll = 1, itr_ini
+
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = MIN( &
+ MAX(e_trb(i, j, k), 1.0e-20), &
+ e_trb_max)
+ END DO
+ END DO
+END DO
+
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, 1) = 0.0
+ END DO
+END DO
+
+DO k = tke_levels + 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.0
+ END DO
+ END DO
+END DO
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE ddf_initialize
+END MODULE ddf_initialize_mod
diff --git a/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90 b/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
new file mode 100644
index 0000000000..ef9b3732b2
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
@@ -0,0 +1,206 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To calculate the mixing length in the first order closure
+! model
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE ddf_mix_length_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'DDF_MIX_LENGTH_MOD'
+CONTAINS
+
+SUBROUTINE ddf_mix_length( &
+ row_length, rows, halo_i, halo_j, bl_levels, &
+ z_uv, z_tq, dbdz, r_mosurf, fb_surf, h_pbl, e_trb, &
+ elm, coef_ce, ekw)
+
+USE mym_option_mod, ONLY: tke_dlen, &
+ my_length, ddf_length, non_local_like_length, &
+ l_tke_dlen_blackadar, tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE planet_constants_mod, ONLY: vkman
+USE atm_fields_bounds_mod, ONLY: tdims
+USE yomhook, ONLY: lhook, dr_hook
+USE mym_length_mod, ONLY: mym_length
+IMPLICIT NONE
+
+! Intent In Variables
+INTEGER, INTENT(IN) :: &
+ row_length, &
+ ! Local number of points on a row
+ rows, &
+ ! Local number of rows in a theta field
+ halo_i, &
+ ! Size of halo in i direction.
+ halo_j, &
+ ! Size of halo in j direction.
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(row_length,rows,bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(row_length,rows,bl_levels), &
+ ! IN Z_TQ(*,K) is height of theta level k.
+ ! Cloud ice (kg per kg air)
+ dbdz(row_length,rows,tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ r_mosurf(row_length, rows), &
+ ! reciprocal of Monin-Obkhov length
+ fb_surf(row_length,rows), &
+ ! Surface flux buoyancy over density (m^2/s^3)
+ h_pbl(row_length, rows), &
+ ! height of PBL determined by vertical profile
+ ! of SL
+ e_trb(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, bl_levels)
+ ! TKE defined on theta levels K-1
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ elm(row_length, rows, tke_levels), &
+ ! mixing length
+ coef_ce(row_length, rows, tke_levels), &
+ ! coefficient appeared in a dissipation term
+ ekw(row_length, rows, tke_levels)
+ ! SQRT(e_trb)
+
+! Local variables
+INTEGER :: i, j, k
+ ! loop counter
+
+REAL(KIND=real_umphys) :: &
+ rbv, &
+ ! reciprocal of Brunt-Vaisala frequency
+ elb, &
+ ! mixing length driven by buoyancy
+ els, &
+ ! mixing length driven by surface
+ delta_z
+ ! vertical grid spacing
+
+REAL(KIND=real_umphys) :: &
+ qke(1-halo_i:row_length+halo_i, 1-halo_j:rows+halo_j, &
+ bl_levels), &
+ ! twice of TKE (denoted to q**2) on theta level K-1
+ qkw(row_length, rows, tke_levels)
+ ! q=sqrt(qke) on theta level K-1
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='DDF_MIX_LENGTH'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ ekw(i, j, k) = SQRT(MAX(e_trb(i, j, k), 1.0e-20))
+ END DO
+ END DO
+END DO
+
+IF (tke_dlen == my_length) THEN
+ DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ qke(i, j, k) = 2.0 * e_trb(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL mym_length( &
+ row_length, rows, halo_i, halo_j, bl_levels, &
+ qke, z_uv, z_tq, dbdz, r_mosurf, fb_surf, &
+ qkw, elm)
+ELSE IF (tke_dlen == ddf_length &
+ .OR. tke_dlen == non_local_like_length) THEN
+ DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ delta_z = z_uv(i, j, k) - z_uv(i, j, k - 1)
+ IF (dbdz(i, j, k) > 0.0) THEN
+ rbv = 1.0 / SQRT(dbdz(i, j, k))
+ elb = MAX(MIN(0.76 * ekw(i, j, k) * rbv, &
+ delta_z), 1.0e-10)
+ ELSE
+ elb = delta_z
+ END IF
+ elm(i, j, k) = elb
+ END DO
+ END DO
+ END DO
+
+ IF (tke_dlen == non_local_like_length) THEN
+ DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ IF (z_tq(i, j, k - 1) < h_pbl(i, j) ) THEN
+ elm(i, j, k) = 0.25 * 1.8 * h_pbl(i, j) &
+ * (1.0 - EXP( &
+ -4.0 * z_tq(i, j, k - 1)/h_pbl(i, j)) &
+ - 0.0003 * EXP( &
+ 8.0 * z_tq(i, j, k - 1) / h_pbl(i, j)))
+ END IF
+ END DO
+ END DO
+ END DO
+ END IF ! if tke_dlen == non_local_like_length
+
+ IF (l_tke_dlen_blackadar) THEN
+ DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ els = vkman * z_tq(i, j, k - 1)
+ elm(i, j, k) = els / (1.0 + els / elm(i, j, k))
+ END DO
+ END DO
+ END DO
+ END IF
+END IF
+
+! for diagnostics
+DO j = 1, rows
+ DO i = 1, row_length
+ elm(i, j, 1) = elm(i, j, 2)
+ END DO
+END DO
+
+IF (tke_dlen == non_local_like_length) THEN
+ DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ coef_ce(i, j, k) = 0.41
+ END DO
+ END DO
+ END DO
+ELSE
+ DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ coef_ce(i, j, k) = 0.19 + 0.74 * elm(i, j, k) &
+ / (z_uv(i, j, k) - z_uv(i, j, k - 1))
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE ddf_mix_length
+END MODULE ddf_mix_length_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_calcphi.F90 b/science/physics_schemes/source/boundary_layer/mym_calcphi.F90
new file mode 100644
index 0000000000..43bb61cf6d
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_calcphi.F90
@@ -0,0 +1,146 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+!
+! Purpose: To calculate gradient functions at the surface used in
+! evaluating the production terms of the prognostic
+! variables at the lowest layer.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_calcphi_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CALCPHI_MOD'
+CONTAINS
+
+SUBROUTINE mym_calcphi(bl_levels, z_tq, r_mosurf, pmz, phh)
+
+USE atm_fields_bounds_mod, ONLY: tdims
+USE mym_const_mod, ONLY: two_thirds, pr
+USE mym_option_mod, ONLY: &
+ businger, bh1991, my_lowest_pd_surf, &
+ l_my_extra_level, my_z_extra_fact
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! number of boundary layer levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Z_TQ(*,K) is height of theta
+ ! level k.
+ r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! reciprocal of Monin-Obkhov length
+
+! Intent OUT Variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! gradient function for momentum
+ ! at surface minus non-dimensional height
+ phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! gradient function for scalars
+ ! at surface
+
+! Local variables
+INTEGER :: &
+ i, j
+ ! Loop indexes
+
+REAL(KIND=real_umphys) :: &
+ zeta, &
+ ! non-dimensional height
+ tmp
+ ! work variable
+
+REAL(KIND=real_umphys) :: &
+ z_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! height of the lowest layer
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ ! coefficients appeared
+ ! in Beljaars and Holtslag(1991)
+ bel_a = 1.0, &
+ bel_b = 2.0 / 3.0, &
+ bel_c = 5.0, &
+ bel_d = 0.35
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ my_zeta_max = 2.0
+ ! upper limit for zeta
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_CALCPHI'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+IF (l_my_extra_level) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ z_1(i, j) = z_tq(i, j, 1) * my_z_extra_fact
+ END DO
+ END DO
+ELSE
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ z_1(i, j) = z_tq(i, j, 1)
+ END DO
+ END DO
+END IF
+
+IF (my_lowest_pd_surf == businger) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ zeta = MIN(z_1(i, j) * r_mosurf(i, j), my_zeta_max)
+ IF (zeta >= 0.0) THEN
+ pmz(i, j) = 1.0 + 4.7 * zeta
+ phh(i, j) = pr + 4.7 * zeta
+ ELSE
+ pmz(i, j) = 1.0 / SQRT(SQRT(1.0 - 15.0 * zeta))
+ phh(i, j) = pr / SQRT(1.0 - 9.0 * zeta)
+ END IF
+ pmz(i, j) = pmz(i, j) - zeta
+ END DO
+ END DO
+ELSE IF (my_lowest_pd_surf == bh1991) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ zeta = MIN(z_1(i, j) * r_mosurf(i, j), my_zeta_max)
+ IF (zeta >= 0) THEN
+ tmp = bel_b * EXP(-bel_d * zeta) &
+ * (bel_d * zeta - bel_c - 1.0)
+ pmz(i, j) = 1.0 - zeta * (tmp - bel_a)
+ phh(i, j) = 1.0 - zeta * (tmp - &
+ SQRT(1.0 + two_thirds * bel_a * zeta))
+ ELSE
+ tmp = SQRT(1.0 - 16.0 * zeta)
+ pmz(i, j) = 1.0 / SQRT(tmp)
+ phh(i, j) = 1.0 / tmp
+ END IF
+ pmz(i, j) = pmz(i, j) - zeta
+ END DO
+ END DO
+END IF
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_calcphi
+END MODULE mym_calcphi_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_condensation.F90 b/science/physics_schemes/source/boundary_layer/mym_condensation.F90
new file mode 100644
index 0000000000..f80b704811
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_condensation.F90
@@ -0,0 +1,518 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+
+! Purpose: To evaluate buoyancy parameters, cloud fraction, and
+! liquid water content in the MY model.
+! Fluctuation of heat and moisture is assumed to obey the
+! bi-normal distribution function.
+! Note that the cloud fraction and liquid water content
+! diagnosed here is not used in the other processes.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_condensation_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CONDENSATION_MOD'
+CONTAINS
+
+SUBROUTINE mym_condensation( &
+! IN levels/switches
+ bl_levels, levflag, nSCMDpkgs,L_SCMDiags, BL_diag, &
+! IN fields
+ qw, tl, t, p_theta_levels, tsq, qsq, cov, &
+! OUT fields
+ vt, vq, q1, cld, ql)
+
+USE atm_fields_bounds_mod, ONLY: tdims, ScmRowLen, ScmRow
+USE bl_diags_mod, ONLY: strnewbldiag
+USE conversions_mod, ONLY: pi
+USE gen_phys_inputs_mod, ONLY: l_mr_physics
+USE mym_option_mod, ONLY: tke_levels
+USE planet_constants_mod, ONLY: &
+ cp, r, repsilon, pref, kappa, c_virtual, one_minus_epsilon, ls
+USE water_constants_mod, ONLY: lc
+
+USE model_domain_mod, ONLY: model_type, mt_single_column
+USE s_scmop_mod, ONLY: default_streams, &
+ t_avg, d_bl, scmdiag_bl
+USE scmoutput_mod, ONLY: scmoutput
+
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+
+USE mym_errfunc_mod, ONLY: mym_errfunc
+IMPLICIT NONE
+
+! Intent In Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels, &
+ ! Max. no. of "boundary" levels
+ levflag
+ ! flag to indicate the level of MY
+ ! 2: MY2.5, 3:MY3
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! Total water content
+ tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! Ice/liquid water temperature
+ t(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! temperature
+ p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 0:bl_levels+1), &
+ ! pressure on theta levels (Pa)
+ tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariant of liquid potential temperature
+ ! (thetal'**2) defined on theta levels K-1
+ qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariant of total water
+ ! (qw'**2) defined on theta levels K-1
+ cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels)
+ ! Correlation between thetal and qw
+ ! (thetal'qw') defined on theta levels K-1
+
+! Additional variables for SCM diagnostics which are dummy in full UM
+INTEGER, INTENT(IN) :: nSCMDpkgs
+ ! No of SCM diagnostics packages
+
+LOGICAL, INTENT(IN) :: L_SCMDiags(nSCMDpkgs)
+ ! Logicals for SCM diagnostics packages
+
+! Declaration of BL diagnostics.
+TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+
+! Intent OUT Variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ vt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Buoyancy parameter (coefficients of )
+ ! on theta K-1
+ ! Note that g/thetav is not included.
+ vq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Buoyancy parameter (coefficients of )
+ ! on theta K-1
+ ! Note that g/thetav is not included.
+ q1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! normalized excess water content on theta K-1
+ cld(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! cloud fraction on theta K-1
+ ql(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, tke_levels)
+ ! condensed liquid water content
+
+! Local Variables
+INTEGER :: &
+ i, j, k, iScm, jScm
+ ! loop indexes
+REAL(KIND=real_umphys) :: &
+ rr2, &
+ ! 1 / sqrt(2)
+ rrp, &
+ ! 1 / sqrt(2 pi)
+ hl, &
+ ! latent heat
+ qsl, &
+ ! saturated specific humidity
+ dqsl, &
+ ! derivative of saturated specific humidity by
+ ! temperature
+ t3sq, &
+ ! work variable for
+ r3sq, &
+ ! work variable for
+ c3sq, &
+ ! work variable for
+ alp_qsl, &
+ ! alpha * qsl
+ eq1, &
+ ! work variable
+ qll, &
+ ! work variable
+ r_exner, &
+ ! reciprocal of Exner function
+ q2p, &
+ ! work variable
+ pt_tmp, &
+ ! work variable
+ qt, &
+ ! work variable
+ rac
+ ! work variable
+
+REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
+ ! work array for scmoutput
+
+REAL(KIND=real_umphys) :: &
+ rice(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! ratio of ice.
+ ! temperature > 0C : rice =0
+ ! temperature < -36C : rice =1
+ ! Between 0C and 36C, it is linearly interpolated
+ ! with temperature
+ hl_ovr_cp(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! latent heat over heat capacity
+ exner(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! Exner function
+ qmq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! Excess of total water from saturated one
+ alp(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficient related to saturation
+ ! (alpha in the paper)
+ bet(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficient related to saturation
+ ! (beta in the paper)
+ sgm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! standard deviation of the bi-normal distribution
+ ! function
+ erf_arg(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! array to store an argument for error function
+ erf_val(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! array to store a result of error function
+ qsw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! saturated specific ratio for water
+ qsi(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels)
+ ! saturated specific ratio for ice
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ e0cw = 6.11e2, &
+ tetn1w = 17.27, &
+ tetn2w = 273.15, &
+ tetn3w = 35.85, &
+ e0ci = 6.11e2, &
+ tetn1i = 21.875, &
+ tetn2i = 273.15, &
+ tetn3i = 7.65, &
+ ! coefficients in the Tetens' Formula
+ ttriple = 273.16, &
+ ! a triple point of water
+ temp_ice = 237.15
+ ! Below this temperature, all of condensed water
+ ! should be ice. -36C
+REAL(KIND=real_umphys), PARAMETER :: &
+ my_sgm_min_fct = 0.0, &
+ ! factor to set the lower limit for sgm
+ my_sgm_max_fct = 1.0
+ ! factor to set the upper limit for sgm
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_CONDENSATION'
+ ! for scmoutput
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+rr2 = 1.0 / SQRT(2.0)
+rrp = 1.0 / SQRT(2.0 * pi)
+
+! Here, qsw and qsi are saturated vapor pressure.
+! Using the Teten's formula instead of the subroutine "qmix"
+! because the saturated vapor pressure on liquid water is necessary
+! even in sub-zero temperature.
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+
+ qsw(i, j, k) = e0cw * EXP(tetn1w * &
+ (tl(i, j, k - 1) - tetn2w) &
+ / (tl(i, j, k - 1) - tetn3w) )
+ qsi(i, j, k) = e0ci * EXP(tetn1i * &
+ (tl(i, j, k - 1) - tetn2i) &
+ / (tl(i, j, k - 1) - tetn3i) )
+ END DO
+ END DO
+END DO
+
+! convert to mixing ratio or specific humidity
+IF (l_mr_physics) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ qsw(i, j, k) = repsilon * qsw(i, j, k) &
+ / p_theta_levels(i, j, k - 1)
+ qsi(i, j, k) = repsilon * qsi(i, j, k) &
+ / p_theta_levels(i, j, k - 1)
+ END DO
+ END DO
+ END DO
+ELSE
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ qsw(i, j, k) = repsilon * qsw(i, j, k) &
+ / (p_theta_levels(i, j, k - 1) &
+ - one_minus_epsilon * qsw(i, j, k))
+ qsi(i, j, k) = repsilon * qsi(i, j, k) &
+ / (p_theta_levels(i, j, k - 1) &
+ - one_minus_epsilon * qsi(i, j, k))
+ END DO
+ END DO
+ END DO
+END IF
+
+! Calculate sgm
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (tl(i, j, k -1) >= ttriple) THEN
+ rice(i, j, k) = 0.0
+ ELSE IF (tl(i, j, k - 1) < temp_ice) THEN
+ rice(i, j, k) = 1.0
+ ELSE
+ rice(i, j, k) = (ttriple - tl(i, j, k - 1)) &
+ / (ttriple - temp_ice)
+ END IF
+
+ hl = (1.0 - rice(i, j, k)) * lc + rice(i, j, k) * ls
+ qsl = (1.0 - rice(i, j, k)) * qsw(i, j, k) &
+ + rice(i, j, k) * qsi(i, j, k)
+
+ hl_ovr_cp(i, j, k) = hl / cp
+
+ dqsl = qsl * repsilon * hl / (r * tl(i, j, k - 1) **2)
+
+ exner(i, j, k) = (p_theta_levels(i, j, k - 1) / pref) ** kappa
+ qmq(i, j, k) = qw(i, j, k - 1) - qsl
+ alp(i, j, k) = 1.0 /(1.0 + dqsl * hl_ovr_cp(i, j, k))
+ bet(i, j, k) = dqsl * exner(i, j, k)
+
+ t3sq = MAX(tsq(i, j, k), 0.0)
+ r3sq = MAX(qsq(i, j, k), 0.0)
+ c3sq = cov(i, j, k)
+ c3sq = SIGN(MIN(ABS(c3sq), SQRT(t3sq * r3sq)), c3sq)
+
+ r3sq = r3sq + bet(i, j, k) ** 2 * t3sq &
+ -2.0 * bet(i, j, k) * c3sq
+ alp_qsl = MIN(alp(i, j, k) * qsl, qw(i, j, k - 1))
+ sgm(i, j, k) = MAX( &
+ MIN(0.5 * alp(i, j, k) * SQRT(MAX(r3sq, 0.0)), &
+ my_sgm_max_fct * alp_qsl), &
+ my_sgm_min_fct * alp_qsl, 1.0e-10)
+ END DO
+ END DO
+END DO
+
+IF (levflag /= 3) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ sgm(i, j, 2) = sgm(i, j, 3)
+ END DO
+ END DO
+END IF
+
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ erf_arg(i, j, 1) = 0.0
+ cld(i, j, 1) = 0.0
+ ql(i, j, 1) = 0.0
+ sgm(i, j, 1) = 0.0
+ q1(i, j, 1) = 0.0
+ END DO
+END DO
+
+! Preparation to calculate values of the err function
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ q1(i, j, k) = 0.5 * alp(i, j, k) &
+ * qmq(i, j, k) / sgm(i, j, k)
+ erf_arg(i, j, k) = q1(i, j, k) * rr2
+ END DO
+ END DO
+END DO
+
+CALL mym_errfunc(tdims%i_end*tdims%j_end*tke_levels, erf_arg, erf_val)
+
+! Calculate the buoyancy parameters vt and vq
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ cld(i, j, k) = 0.5 * (1.0 + erf_val(i, j, k))
+ IF (ABS(q1(i, j, k)) > 10.0 ) THEN
+ eq1 = 0.0
+ ELSE
+ eq1 = rrp * EXP(- 0.5 * q1(i, j, k) ** 2)
+ END IF
+ ! qll = ql / (2 * sgm)
+ qll = MAX(cld(i, j, k) * q1(i, j, k) + eq1, 0.0)
+
+ IF (qw(i, j, k) < 1.0e-10) THEN
+ ql(i, j, k) = 0.0
+ ELSE
+ ql(i, j, k) = MAX( &
+ 2.0 * sgm(i, j, k) * qll, 0.0)
+ END IF
+ ! To avoid negative QV (for safety)
+ ql(i, j, k) = MIN(ql(i, j, k), qw(i, j, k - 1) * 0.5)
+
+ r_exner = 1.0 / exner(i, j, k)
+ q2p = hl_ovr_cp(i, j, k) * r_exner
+ pt_tmp = t(i, j, k - 1) * r_exner
+ qt = 1.0 + c_virtual * qw(i, j, k - 1) &
+ - (1.0 + c_virtual) * ql(i, j, k)
+ rac = alp(i, j, k) * (cld(i, j, k) &
+ - qll * eq1) * (q2p * qt - (1.0 + c_virtual) * pt_tmp)
+
+ vt (i, j, k) = qt - rac * bet(i, j, k)
+ vq (i, j, k) = c_virtual * pt_tmp + rac
+ END DO
+ END DO
+END DO
+
+IF (BL_diag%l_cf_trb) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%cf_trb(i, j, k) = cld(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_ql_trb) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%ql_trb(i, j, k) = ql(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_sgm_trb) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%sgm_trb(i, j, k) = sgm(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( l_scmdiags(scmdiag_bl) .AND. &
+ model_type == mt_single_column ) THEN
+
+ ! Note that diagnostics here has only "tke_levels" levels.
+ ! It is necessary to copy them to an array which has "bl_levels"
+
+!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
+!$OMP PRIVATE(i, j, k) &
+!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
+ DO k = 1, bl_levels
+ DO j = 1, ScmRow
+ DO i = 1, ScmRowLen
+ TmpScm3d(i,j,k) = 0.0
+ END DO
+ END DO
+ END DO
+!$OMP END PARALLEL DO
+
+ ! for cld
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = cld(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'cf_trb', &
+ 'cloud fraction by TKE scheme',' ', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ ! for ql
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = ql(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'ql_trb', &
+ 'condensed water by TKE scheme','kg/kg', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ ! for sgm
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = sgm(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'sgm_trb', &
+ 'PDF width by TKE scheme',' ', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ ! for Q1
+ DO k=1, tke_levels
+ DO j=tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i=tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = q1(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'Q1', &
+ 'normalized excessive moisture',' ', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+END IF ! scmdiag_bl / model_type
+
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_condensation
+END MODULE mym_condensation_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_const_mod.F90 b/science/physics_schemes/source/boundary_layer/mym_const_mod.F90
new file mode 100644
index 0000000000..90063848a4
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_const_mod.F90
@@ -0,0 +1,140 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Module mym_const_mod----------------------------------------------
+
+! Purpose: To define constants including the closure constants used
+! in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+!---------------------------------------------------------------------
+MODULE mym_const_mod
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+SAVE
+
+ ! For the meaing of the variables, see the papers above.
+ ! N2001: Nakanishi, M., 2001
+ ! NN2004: Nakanishi, M. and H. Niino, 2004
+ ! NN2006: Nakanishi, M. and H. Niino, 2006
+
+ ! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+REAL(KIND=real_umphys) :: &
+ g1, &
+ ! gamma_1 = 1/3 - 2A_1 / B_1
+ g2, &
+ ! gamma_2 defined at Eq. (B4) in N2001
+ a1, &
+ ! closure constant A_1 defined at Eq.(7) in N2001
+ a2, &
+ ! closure constant A_2 defined at Eq.(8) in N2001
+ b1, &
+ ! closure constant B_1 defined at Eq.(5) in N2001
+ b2, &
+ ! closure constant B_2 defined at Eq.(6) in N2001
+ c1, &
+ ! closure constant C_1 defined at Eq.(7) in N2001
+ c2, &
+ ! closure constant C_2 defined at Eq.(7) in N2001
+ c3, &
+ ! closure constant C_3 defined at Eq.(7) in N2001
+ c4, &
+ ! closure constant C_1 defined at Eq.(7) in N2001
+ c5, &
+ ! closure constant C_1 defined at Eq.(7) in N2001
+ a1_2, &
+ ! A_1 / A_2
+ pr, &
+ ! Prandtl Number
+ rfc, &
+ ! Critical flux Richardson number
+ f1, &
+ ! F_1 defined at Eq. (B4) in N2001
+ f2, &
+ ! F_2 defined at Eq. (B4) in N2001
+ rf1, &
+ ! R_f1 defined at Eq. (B4) in N2001
+ rf2, &
+ ! R_f2 defined at Eq. (B4) in N2001
+ smc, &
+ ! A_1 F_1 / (A_2 F_2) appeared at Eq. (B2) in N2001
+ shc, &
+ ! 3 A_2 (gamma_1 + gamma_2) appeared at Eq. (B2)
+ ! in N2001
+ ri1, &
+ ! Ri_1 defined at Eq. (B7) in N2001
+ ri2, &
+ ! Ri_2 defined at Eq. (B7) in N2001
+ ri3, &
+ ! Ri_3 defined at Eq. (B7) in N2001
+ ri4, &
+ ! Ri_4 defined at Eq. (B7) in N2001
+ cc2, &
+ ! 1-C_2
+ cc3, &
+ ! 1-C_3
+ e1c, &
+ ! constant appeared in phi1 at Eq.(3a) in NN2006
+ e2c, &
+ ! constant appeared in phi2 at Eq.(3b) in NN2006
+ e3c, &
+ ! constant appeared in phi3 and phi3'
+ ! at Eq. (3c,d) in NN2006
+ e4c, &
+ ! constant appeared in phi4 and phi4'
+ ! at Eq. (3e,f) in NN2006
+ e5c, &
+ ! constant appeared in D and D'
+ ! at Eq.(2a,b) in NN2006
+ my_alpha1, &
+ ! alpha_1 defined at Eq.(40) in N2001
+ my_alpha2, &
+ ! alpha_2 defined at Eq.(41) in N2001
+ my_alpha3, &
+ ! alpha_3 defined at Eq.(41) in N2001
+ my_alpha4, &
+ ! alpha_4 defined at Eq.(39) in N2001
+ elt_min, &
+ ! lower limit of elt
+ one_third, &
+ ! 1.0 / 3.0
+ two_thirds, &
+ ! 2.0 / 3.0
+ coef_trbvar_diff_tke, &
+ ! factor of the diffusion for TKE to the one
+ ! for momentum
+ coef_trbvar_diff, &
+ ! factor of the diffusion for the other prognostic
+ ! variables appeared in MY to the one
+ ! for momentum
+ qke_max, &
+ ! upper limit for qke (twice of TKE) for safety.
+ e_trb_max
+ ! upper limit for e_trb for safety.
+END MODULE mym_const_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_const_set.F90 b/science/physics_schemes/source/boundary_layer/mym_const_set.F90
new file mode 100644
index 0000000000..e99d01b6b8
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_const_set.F90
@@ -0,0 +1,134 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Module mym_const_set----------------------------------------------
+
+! Purpose: To set constants defined in mym_const_mod
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_const_set_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CONST_SET_MOD'
+CONTAINS
+
+SUBROUTINE mym_const_set
+
+USE mym_const_mod, ONLY: g1,b1,b2,c2,c3,c4,c5,pr,a1,c1,a2,g2,a1_2, &
+ rfc,f1,f2,rf1,rf2,smc,shc,ri1,ri2,ri3,ri4,cc2,cc3,e1c,e2c,e3c, &
+ e4c,e5c,my_alpha1,my_alpha2,my_alpha3,my_alpha4,elt_min, &
+ one_third,two_thirds,coef_trbvar_diff_tke,coef_trbvar_diff, &
+ qke_max,e_trb_max
+USE mym_option_mod, ONLY: l_my3_improved_closure
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_CONST_SET'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+IF (l_my3_improved_closure) THEN
+ ! closure constants in the improved MY model (MYNN)
+ g1 = 0.235
+ b1 = 24.0
+ b2 = 15.0
+ c2 = 0.7
+ c3 = 0.323
+ c4 = 0.0
+ c5 = 0.2
+ pr = 0.74
+ELSE
+ ! closure constants in the original MY model
+ g1 = 0.222
+ b1 = 16.6
+ b2 = 10.1
+ c2 = 0.0
+ c3 = 0.0
+ c4 = 0.0
+ c5 = 0.0
+ pr = 0.80
+END IF
+! Combined constants
+a1 = b1 * ( 1.0 - 3.0 * g1 ) / 6.0
+c1 = g1 - 1.0 / ( 3.0 * a1 * b1 ** (1.0 / 3.0))
+a2 = a1 *( g1 - c1 ) / ( g1 * pr )
+g2 = b2 / b1 * ( 1.0 - c3 ) + 2.0 * a1 / b1 * ( 3.0 - 2.0 * c2 )
+a1_2 = a1 / a2
+
+rfc = g1 / (g1 + g2)
+f1 = b1 * (g1 - c1) + 3.0 * a2 *(1.0 - c2 ) * ( 1.0 - c5 ) &
+ +2.0 * a1 *(3.0 -2.0 * c2)
+f2 = b1 * (g1 + g2) - 3.0 * a1 *(1.0 - c2)
+rf1 = b1 * (g1 - c1) / f1
+rf2 = b1 * g1 / f2
+smc = a1 / a2 * f1 / f2
+shc = 3.0 * a2 * (g1 + g2)
+
+ri1 = 0.5 /smc
+ri2 = rf1 * smc
+ri3 = 4.0 * rf2 * smc - 2.0 * ri2
+ri4 = ri2 ** 2
+
+cc2 = 1.0 - c2
+cc3 = 1.0 - c3
+e1c = 3.0 * a2 * b2 * cc3
+e2c = 9.0 * a1 * a2 * cc2
+e3c = 9.0 * a2 * a2 * cc2 * (1.0 - c5)
+e4c = 12.0 * a1 * a2 *cc2
+e5c = 6.0 * a1 *a1
+
+! Other parameters
+my_alpha1 = 0.23
+my_alpha2 = 1.0
+my_alpha3 = 5.0
+my_alpha4 = 100.0
+elt_min = 20.0
+
+one_third = 1.0 / 3.0
+two_thirds = 2.0 / 3.0
+
+coef_trbvar_diff_tke = 3.0
+coef_trbvar_diff = 1.0
+
+qke_max = 500.0
+e_trb_max = 0.5 * qke_max
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_const_set
+END MODULE mym_const_set_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_ctl.F90 b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
new file mode 100644
index 0000000000..f791404362
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
@@ -0,0 +1,655 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: The main subroutine for the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_ctl_mod
+
+USE um_types, ONLY: real_umphys, real_eps
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CTL_MOD'
+CONTAINS
+
+SUBROUTINE mym_ctl( &
+! IN levels/switches
+ bl_levels, levflag, nSCMDpkgs,L_SCMDiags, &
+ BL_diag, cycleno, &
+! IN fields
+ z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, qcf, bq_gb, bt_gb, &
+ rho_mix, rho_wet_tq, fqw, ftl, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, &
+ p_theta_levels, p_half, u_s, fb_surf, pstar, &
+! INOUT fields
+ e_trb, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh, zhpar_shcu, &
+! OUT fields
+ rhogamu, rhogamv, rhogamt, rhogamq)
+
+USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, tdims_s
+USE bl_diags_mod, ONLY: strnewbldiag
+USE dynamics_input_mod, ONLY: numcycles
+USE gen_phys_inputs_mod, ONLY: l_mr_physics
+USE level_heights_mod, ONLY: &
+ r_theta_levels, r_rho_levels
+USE mym_option_mod, ONLY: l_my_condense, l_shcu_buoy, &
+ my_lowest_pd_surf, tke_levels, l_my_initialize, l_my_ini_zero, &
+ my_ini_dbdz_min, l_3dtke
+USE missing_data_mod, ONLY: rmdi
+USE parkind1, ONLY: jprb, jpim
+USE planet_constants_mod, ONLY: vkman, kappa, pref, c_virtual, g
+USE turb_diff_ctl_mod, ONLY: visc_m, visc_h
+USE yomhook, ONLY: lhook, dr_hook
+USE mym_calcphi_mod, ONLY: mym_calcphi
+USE mym_condensation_mod, ONLY: mym_condensation
+USE mym_const_set_mod, ONLY: mym_const_set
+USE mym_initialize_mod, ONLY: mym_initialize
+USE mym_shcu_buoy_mod, ONLY: mym_shcu_buoy
+USE mym_turbulence_mod, ONLY: mym_turbulence
+IMPLICIT NONE
+
+! Intent In Variables
+
+INTEGER, INTENT(IN) :: &
+ bl_levels, &
+ ! Max. no. of "boundary" levels
+ levflag, &
+ ! to indicate the level of the MY model
+ ! 2: level 2.5
+ ! 3: level 3
+ cycleno ! Iteration number (EG outer loop)
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Z_TQ(*,K) is height of theta level k.
+ u_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! U on P-grid.
+ v_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! V on P-grid.
+ qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! Total water content
+ tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! Ice/liquid water temperature
+ t(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! temperature
+ q(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! specific humidity
+ qcl(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! Cloud liquid water
+ qcf(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! Cloud ice (kg per kg air)
+ bq_gb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! A grid-box mean buoyancy param
+ ! on T,q-levels (full levels).
+ bt_gb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! A grid-box mean buoyancy param
+ ! on T,q-levels (full levels).
+ rho_mix(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! density on UV (ie. rho) levels;
+ ! used in RHOKH so dry density if
+ ! L_mr_physics is true
+ rho_wet_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! density on TQ (ie. theta) levels;
+ ! used in RHOKM so wet density
+ fqw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! Moisture flux between layers
+ ! (kg per square metre per sec).
+ ! FQW(,1) is total water flux
+ ! from surface, 'E'.
+ ! defined on rho levels
+ ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! FTL(,K) contains net turbulent
+ ! sensible heat flux into layer K
+ ! from below; so FTL(,1) is the
+ ! surface sensible heat, H. (W/m2)
+ ! defined on rho levels
+ dtldzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of TL across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dqwdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of QW across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Gradient of u at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+ dvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Gradient of v at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+ dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Modulus of wind shear at theta levels.
+ ! (:,:,K) represents the value on theta level K-1
+ p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 0:bl_levels+1), &
+ ! Pressure on theta levels (Pa)
+ p_half(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels), &
+ ! Pressure on rho levels (Pa)
+ u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface friction velocity
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface flux buoyancy over
+ ! density (m^2/s^3)
+ pstar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! surface pressure
+
+! Additional variables for SCM diagnostics which are dummy in full UM
+INTEGER, INTENT(IN) :: &
+ nSCMDpkgs ! No of SCM diagnostics packages
+
+LOGICAL, INTENT(IN) :: &
+ L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
+
+! Intent INOUT variables
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! TKE defined on theta levels K-1
+ tsq_trb(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end,bl_levels), &
+ ! Self covariance of liquid potential temperature
+ ! (thetal'**2) defined on theta levels K-1
+ qsq_trb(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end,bl_levels), &
+ ! Self covariance of total water
+ ! (qw'**2) defined on theta levels K-1
+ cov_trb(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end,bl_levels), &
+ ! Correlation between thetal and qw
+ ! (thetal'qw') defined on theta levels K-1
+ rhokm(tdims_s%i_start:tdims_s%i_end, &
+ tdims_s%j_start:tdims_s%j_end,bl_levels), &
+ ! Exchange coeffs for momentum
+ ! between K and K-1 on rho levels.
+ ! i.e. the coeffs are defined on theta level K-1.
+ rhokh(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels), &
+ ! Exchange coeffs for scalars
+ ! between K and K-1 on theta levels.
+ ! i.e. the coeffs are defined on rho levels
+ zhpar_shcu(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
+ ! Height of mixed layer used to evaluate
+ ! the non-gradient buoyancy flux
+
+! Declaration of BL diagnostics.
+TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+
+! Intent Out Variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ rhogamu(tdims_s%i_start:tdims_s%i_end, &
+ tdims_s%j_start:tdims_s%j_end,2:bl_levels), &
+ ! Counter gradient terms for TAUX
+ ! defined at theta level K-1
+ rhogamv(tdims_s%i_start:tdims_s%i_end, &
+ tdims_s%j_start:tdims_s%j_end,2:bl_levels), &
+ ! Counter gradient terms for TAUY
+ ! defined at theta level K-1
+ rhogamt(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels), &
+ ! Counter gradient terms for FTL
+ ! defined at rho levels
+ rhogamq(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels)
+ ! Counter gradient terms for FQW
+ ! defined at rho levels
+
+! Local Variables
+INTEGER :: &
+ i, j, k
+ ! loop indexes
+
+LOGICAL, SAVE :: &
+ l_first = .TRUE.
+ ! flag to indicate if it is the first execution
+REAL(KIND=real_umphys) :: &
+ r_weight1, &
+ ! weight factor to interpolate variables on rho
+ ! levels onto theta levels
+ weight2, &
+ ! weight factor to interpolate variables on rho
+ ! levels onto theta levels
+ weight3
+ ! weight factor to interpolate variables on rho
+ ! levels onto theta levels
+REAL(KIND=real_umphys) :: &
+ pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! gradient function for momentum at the surface
+ ! minus non-dimensional height (height / MO length)
+ phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! gradient function for scalars at the surface
+ r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! reciprocal of Monin-Obukhov length
+ qke(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ bl_levels), &
+ ! twice of TKE (denoted to q**2) on theta level K-1
+ dbdz_l(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ vt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Buoyancy parameter for FTL (excluding g/thetav)
+ ! on theta level K-1
+ vq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Buoyancy parameter for FQW (excluding g/thetav)
+ ! on theta level K-1
+ tv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Virtual temperature on theta level K-1
+ exner(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! exner function on theta level K-1
+ gtr(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! G/thetav on theta level K-1
+ rhokh_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! exchange coeffs for scalars on theta level K-1
+ rhogamt_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! counter gradient term for FTL on theta level K-1
+ rhogamq_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! counter gradient term for FQW on theta level K-1
+ q1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! normalized excessive water from the saturation
+ ! on theta level K-1
+ cld(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! cloud fraction derived by the bi-normal
+ ! distribution on theta level K-1
+ ql(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! condensed liquid water derived by the bi-normal
+ ! distribution on theta level K-1
+ wb_ng(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! buoyancy flux related to the skewness
+ ! on theta level K-1
+ frac_shcu(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! cloud fraction corrected by shallow cumulus
+ ! process on theta level K-1
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_CTL'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+! Monin-Obkhov length
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ r_mosurf(i,j)= -vkman*fb_surf(i,j) &
+ / MAX(u_s(i,j)*u_s(i,j)*u_s(i,j), TINY(1.0))
+ END DO
+END DO
+
+IF (l_first) THEN
+ CALL mym_const_set
+
+ ! IF the first value of e_trb has been set to be missing by the
+ ! reconfiguration, the initialization for the whole domain
+ ! is essential.
+ IF (l_my_initialize .OR. ABS(e_trb(1, 1, 1) - rmdi) < real_eps) THEN
+ IF (l_my_ini_zero) THEN
+ DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.0
+ tsq_trb(i, j, k) = 0.0
+ qsq_trb(i, j, k) = 0.0
+ cov_trb(i, j, k) = 0.0
+ END DO
+ END DO
+ END DO
+ ELSE ! not l_my_ini_zero
+ ! Initialize the prognostic variables by assuming the balance
+ ! between production and dissipation terms
+
+ ! In the initialization, DBDZ by the LS cloud scheme is used.
+ ! To avoid to diagnose huge TKE, the lower limit for DBDZ
+ ! is imposed.
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ dbdz_l(i, j, k) = MAX(my_ini_dbdz_min, dbdz(i, j, k))
+ END DO
+ END DO
+ END DO
+ ! Initialize the prognostic variables
+ CALL mym_initialize( &
+ ! IN levels
+ bl_levels, &
+ ! IN fields
+ z_uv, z_tq, dbdz_l, dvdzm, dtldzm, dqwdzm, &
+ fqw, ftl, u_s, r_mosurf, fb_surf, &
+ ! INOUT fields
+ e_trb, tsq_trb, qsq_trb, cov_trb)
+
+ ! Above tke_levels, the prognostic variables should be zeros.
+ DO k = tke_levels + 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.0
+ tsq_trb(i, j, k) = 0.0
+ qsq_trb(i, j, k) = 0.0
+ cov_trb(i, j, k) = 0.0
+ END DO
+ END DO
+ END DO
+ END IF ! test if l_my_ini_zero
+ END IF ! test if l_my_initialize .OR. e_trb == rmdi
+
+ IF (l_shcu_buoy) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (ABS(zhpar_shcu(i, j) - rmdi) < real_eps) THEN
+ ! if missing has been set by the reconfiguration,
+ ! it is replaced with z_tq(tke_levels-1).
+ zhpar_shcu(i,j) = z_tq(i,j,tke_levels-1)
+ END IF
+ END DO
+ END DO
+ END IF
+ ! need to initialise variables on every cycle as they will have been
+ ! reset to mdi
+ IF (cycleno == numcycles) l_first = .FALSE.
+END IF ! IF L_FIRST
+
+! copy e_trb to qke (qke = 2 e_trb)
+DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ qke(i, j, k) = 2.0 * e_trb(i, j, k)
+ END DO
+ END DO
+END DO
+
+! Set virtual temperature, exner function, and g / thetav
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ tv(i, j, k) = t(i, j, k - 1) &
+ * (1.0 + c_virtual * q(i, j, k - 1) &
+ - qcl(i, j, k - 1) - qcf(i, j, k - 1))
+ exner(i, j, k) = &
+ (p_theta_levels(i, j, k - 1) / pref) ** kappa
+ gtr(i, j, k) = g * exner(i, j, k) / tv(i, j, k)
+ END DO
+ END DO
+END DO
+
+IF (l_my_condense .OR. l_shcu_buoy) THEN
+ CALL mym_condensation( &
+ ! IN levels/switches
+ bl_levels, levflag, nSCMDpkgs,L_SCMDiags, &
+ BL_diag, &
+ ! IN fields
+ qw, tl, t, p_theta_levels, tsq_trb, qsq_trb, cov_trb, &
+ ! OUT fields
+ vt, vq, q1, cld, ql)
+END IF
+
+IF (l_my_condense) THEN
+ ! Re-evaluate DBDZ with the buoyancy parameters diagnosed by
+ ! mym_condensation
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ dbdz_l(i,j,k) = gtr(i, j, k) &
+ * ( vt(i, j, k) * dtldzm(i, j, k) + &
+ vq(i, j, k) * dqwdzm(i, j, k) )
+
+ END DO
+ END DO
+ END DO
+ELSE
+ ! Use the buoyancy parameters and DBDZ by the LS cloud scheme
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ ! convert buoy params from the UM notation to the MY notaation
+ vt(i, j, k) = bt_gb(i, j, k - 1) * tv(i, j, k)
+ vq(i, j, k) = bq_gb(i, j, k - 1) * tv(i, j, k) &
+ / exner(i, j, k)
+ dbdz_l(i,j,k) = dbdz(i,j,k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_dbdz) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%dbdz(i, j, k) = dbdz_l(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_dvdzm) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%dvdzm(i,j,k) = dvdzm(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (l_shcu_buoy) THEN
+ ! Evaluate the non-gradient buoyancy flux
+
+ CALL mym_shcu_buoy( &
+ ! IN levels/switches
+ bl_levels,nSCMDpkgs,L_SCMDiags, &
+ BL_diag, &
+ ! IN fields
+ fb_surf, u_s, pstar, &
+ z_tq, z_uv, p_theta_levels, p_half, &
+ u_p, v_p, t, q, qcl, qcf, q1, cld, &
+ ! INOUT / OUT fields
+ zhpar_shcu,frac_shcu, wb_ng)
+ELSE
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ wb_ng(i,j,k) = 0.0
+ frac_shcu(i,j,k) = cld(i,j,k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (my_lowest_pd_surf > 0) THEN
+ ! Calculate the gradient functions at the surface
+
+ CALL mym_calcphi( &
+ bl_levels, z_tq, r_mosurf, pmz, phh)
+END IF
+
+ ! Calculate diffusion coefficients and counter gradient terms,
+ ! and integrate the prognostic variables.
+
+CALL mym_turbulence( &
+! IN levels/switches
+ bl_levels, levflag, nSCMDpkgs,L_SCMDiags, BL_diag, &
+! IN fields
+ z_uv, z_tq, &
+ vq, vt, gtr, fqw, ftl, wb_ng, &
+ dbdz_l, dtldzm, dqwdzm, dvdzm, dudz, dvdz, &
+ r_mosurf, u_s, fb_surf, pmz, phh, &
+! INOUT fields
+ qke, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh_tq, &
+! OUT fields
+ rhogamu, rhogamv, rhogamt_tq, rhogamq_tq)
+
+IF (l_3dtke) THEN
+ DO k = 1, bl_levels-1
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ visc_m(i,j,k) = rhokm(i,j,k+1)
+ visc_h(i,j,k) = rhokh_tq(i,j,k+1)
+ END DO
+ END DO
+ END DO
+END IF
+
+ ! multiply the density
+DO k = 2, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ rhokm(i, j, k) = rho_wet_tq(i, j, k - 1) * rhokm(i, j, k)
+ rhogamu(i, j, k) = rho_wet_tq(i, j, k - 1) * rhogamu(i, j, k)
+ rhogamv(i, j, k) = rho_wet_tq(i, j, k - 1) * rhogamv(i, j, k)
+ END DO
+ END DO
+END DO
+
+! Note "RHO" here is always wet density (RHO_WET_TQ) so
+! save multiplication of RHOKH to after interpolation
+IF (.NOT. l_mr_physics) THEN
+ DO k = 2, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ rhokh_tq(i, j, k) = rho_wet_tq(i, j, k - 1) &
+ * rhokh_tq(i, j, k)
+ rhogamt_tq(i, j, k) = rho_wet_tq(i, j, k - 1) &
+ * rhogamt_tq(i, j, k)
+ rhogamq_tq(i, j, k) = rho_wet_tq(i, j, k - 1) &
+ * rhogamq_tq(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+! convert qke to e_trb
+DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.5 * qke(i, j, k)
+ END DO
+ END DO
+END DO
+
+! Interpolate RHOKH_TQ, RHOGAMT_TQ and RHOGAMQ_TQ on theta levels
+! to rho levels.
+DO k = 2, tke_levels - 1
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
+ r_theta_levels(i,j, k-1))
+ weight2 = (r_theta_levels(i,j,k) - &
+ r_rho_levels(i,j,k)) * r_weight1
+ weight3 = (r_rho_levels(i,j,k) - &
+ r_theta_levels(i,j,k-1)) * r_weight1
+ rhokh(i,j,k) = &
+ weight3 * rhokh_tq(i,j,k+1) &
+ +weight2 * rhokh_tq(i,j,k)
+ rhogamt(i,j,k) = &
+ weight3 * rhogamt_tq(i,j,k+1) &
+ +weight2 * rhogamt_tq(i,j,k)
+ rhogamq(i,j,k) = &
+ weight3 * rhogamq_tq(i,j,k+1) &
+ +weight2 * rhogamq_tq(i,j,k)
+ END DO
+ END DO
+END DO
+
+k = tke_levels
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
+ r_theta_levels(i,j, k-1))
+ weight2 = (r_theta_levels(i,j,k) - &
+ r_rho_levels(i,j,k)) * r_weight1
+ weight3 = (r_rho_levels(i,j,k) - &
+ r_theta_levels(i,j,k-1)) * r_weight1
+ rhokh(i,j,k) = weight2 * rhokh_tq(i,j,k)
+ rhogamt(i,j,k) = weight2 * rhogamt_tq(i,j,k)
+ rhogamq(i,j,k) = weight2 * rhogamq_tq(i,j,k)
+ END DO
+END DO
+
+! Finally multiply RHOKH by dry density
+IF (l_mr_physics) THEN
+ DO k = 2, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ rhokh(i, j, k) = rho_mix(i, j, k) * rhokh(i, j, k)
+ rhogamt(i, j, k) = rho_mix(i, j, k) * rhogamt(i, j, k)
+ rhogamq(i, j, k) = rho_mix(i, j, k) * rhogamq(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+! Above tke_levels, fluxes should be zero.
+DO k = tke_levels + 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ rhokh(i, j, k) = 0.0
+ rhogamt(i, j, k) = 0.0
+ rhogamq(i, j, k) = 0.0
+ END DO
+ END DO
+END DO
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_ctl
+END MODULE mym_ctl_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90 b/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
new file mode 100644
index 0000000000..127e43bbf6
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
@@ -0,0 +1,203 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To calculate tri-diagonal matrix elements due to
+! diffusion for the prognostic variables in the MY model
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_diff_matcoef_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_DIFF_MATCOEF_MOD'
+CONTAINS
+
+SUBROUTINE mym_diff_matcoef(bl_levels, coef, dfm, aa, bb, cc)
+
+USE atm_fields_bounds_mod, ONLY: pdims, tdims_s, tdims
+USE level_heights_mod, ONLY: &
+ r_theta_levels, r_rho_levels
+USE mym_option_mod, ONLY: &
+ l_my_extra_level, my_z_extra_fact, tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" level
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ coef
+ ! factor for the diffusion coefficients to those for
+ ! momentum
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ bl_levels)
+ ! diffusion coefficients for momentum
+
+! Intent OUT variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ ! coefficients of tri-diagonal equations
+ ! due to diffusion
+ aa(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
+ ! coefs of fields on level K-1
+ bb(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
+ ! coefs of fields on level K
+ cc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels)
+ ! coefs of fields on level K+1
+
+! Local variables
+INTEGER :: &
+ i, j, k, k_start
+ ! Loop indexes
+REAL(KIND=real_umphys) :: &
+ km_m1, &
+ ! diffusion coefficient on lower level by one
+ km_p1
+ ! diffusion coefficient on upper level by one
+
+REAL(KIND=real_umphys) :: &
+ r_dr_rho(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ tke_levels), &
+ ! reciprocal of grid spaces of rho levels
+ r_dr_theta(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! reciprocal of grid spaces of theta levels
+ weight1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ weight2(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! weight to interporate variables on theta levels
+ ! onto rho levels
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_DIFF_MATCOEF'
+
+! Calculate and save r_dr and weight
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ r_dr_theta(i, j, k) = 1.0 &
+ / (r_rho_levels(i, j, k + 1) - r_rho_levels(i, j, k))
+ r_dr_rho(i, j, k) = 1.0 &
+ / (r_theta_levels(i, j, k) &
+ - r_theta_levels(i, j, k - 1))
+
+ weight1(i, j, k) = &
+ (r_rho_levels(i, j, k) - r_theta_levels(i, j, k - 1)) &
+ * r_dr_rho(i, j, k)
+ weight2(i, j, k) = &
+ (r_theta_levels(i, j, k) - r_rho_levels(i, j, k)) &
+ * r_dr_rho(i, j, k)
+ END DO
+ END DO
+END DO
+
+! Calculate aa, bb, cc
+k = 2
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ km_m1 = coef * dfm(i, j, k)
+ km_p1 = coef * &
+ (weight1(i, j, k) * dfm(i, j, k + 1) &
+ + weight2(i, j, k) * dfm(i, j, k))
+
+ cc(i, j, k) = km_p1 * r_dr_rho(i, j, k) &
+ * r_dr_theta(i, j, k - 1)
+ aa(i, j, k) = km_m1 * r_dr_rho(i, j, k - 1) &
+ * r_dr_theta(i, j, k - 1)
+ bb(i, j, k) = -aa(i, j, k) - cc(i, j, k)
+ END DO
+END DO
+
+DO k = 3, tke_levels - 1
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ km_m1 = coef * &
+ (weight1(i, j, k - 1) * dfm(i, j, k) &
+ + weight2(i, j, k - 1) * dfm(i, j, k - 1))
+ km_p1 = coef * &
+ (weight1(i, j, k) * dfm(i, j, k + 1) &
+ + weight2(i, j, k) * dfm(i, j, k))
+
+ cc(i, j, k) = km_p1 * r_dr_rho(i, j, k) &
+ * r_dr_theta(i, j, k - 1)
+ aa(i, j, k) = km_m1 * r_dr_rho(i, j, k - 1) &
+ * r_dr_theta(i, j, k - 1)
+ bb(i, j, k) = -aa(i, j, k) - cc(i, j, k)
+
+ END DO
+ END DO
+END DO
+
+k = tke_levels
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ km_m1 = coef * &
+ (weight1(i, j, k - 1) * dfm(i, j, k) &
+ + weight2(i, j, k - 1) * dfm(i, j, k - 1))
+
+ km_p1 = coef * weight2(i, j, k) * dfm(i, j, k)
+
+ cc(i, j, k) = km_p1 * r_dr_rho(i, j, k) &
+ * r_dr_theta(i, j, k - 1)
+ aa(i, j, k) = km_m1 * r_dr_rho(i, j, k - 1) &
+ * r_dr_theta(i, j, k - 1)
+ bb(i, j, k) = -aa(i, j, k) - cc(i, j, k)
+
+ END DO
+END DO
+
+IF (l_my_extra_level) THEN
+ k_start = 1
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ aa(i, j, 1) = 0.0
+ cc(i, j, 1) = coef * dfm(i, j, 2) &
+ / ((r_theta_levels(i, j, 1) - r_theta_levels(i, j, 0)) &
+ * my_z_extra_fact) ** 2
+
+ bb(i, j, 1) = - aa(i, j, 1) - cc(i, j, 1)
+ END DO
+ END DO
+ELSE
+ k_start = 2
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ aa(i, j, 1) = 0.0
+ bb(i, j, 1) = 0.0
+ cc(i, j, 1) = 0.0
+ END DO
+ END DO
+END IF
+
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ aa(i, j, k_start) = 0.0
+ cc(i, j, tke_levels) = 0.0
+ END DO
+END DO
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_diff_matcoef
+END MODULE mym_diff_matcoef_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_errfunc.F90 b/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
new file mode 100644
index 0000000000..2ed82fb1cb
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
@@ -0,0 +1,126 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+!
+! Purpose: To fastly calculate values of error function in the MY
+! model.
+! The calculation is based on the expansion up to
+! the 13th order.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_errfunc_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_ERRFUNC_MOD'
+CONTAINS
+
+SUBROUTINE mym_errfunc(nn, x, y)
+
+USE conversions_mod, ONLY: pi
+USE yomhook, ONLY: lhook, dr_hook
+USE parkind1, ONLY: jprb, jpim
+IMPLICIT NONE
+
+INTEGER, INTENT(IN) :: nn ! size of array
+
+REAL(KIND=real_umphys), INTENT(IN) :: x(nn) ! input array
+
+REAL(KIND=real_umphys), INTENT(OUT) :: y(nn) ! output array
+
+! Local Variables
+INTEGER :: i ! Loop index
+
+REAL(KIND=real_umphys), SAVE :: &
+ c01, &
+ ! expansion coefficient of x
+ c03, &
+ ! expansion coefficient of x**3
+ c05, &
+ ! expansion coefficient of x**5
+ c07, &
+ ! expansion coefficient of x**7
+ c09, &
+ ! expansion coefficient of x**9
+ c11, &
+ ! expansion coefficient of x**11
+ c13, &
+ ! expansion coefficient of x**13
+ factor
+ ! common factor to all the coefficients
+
+REAL(KIND=real_umphys) :: &
+ x02, &
+ ! x powered by 2
+ x04, &
+ ! x powered by 4
+ x06, &
+ ! x powered by 6
+ x08, &
+ ! x powered by 8
+ x10, &
+ ! x powered by 10
+ x12
+ ! x powered by 12
+
+LOGICAL, SAVE :: first = .TRUE.
+ ! flag to indication first run
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ erfmax = 1.0
+ ! upper limit of the value to avoid it outside domain
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_ERRFUNC'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+IF (first) THEN
+ factor = 2.0 / SQRT(pi)
+ c01 = factor * 1.0
+ c03 = factor * 1.0 / 3.0
+ c05 = factor * 1.0 / 10.0
+ c07 = factor * 1.0 / 42.0
+ c09 = factor * 1.0 / 216.0
+ c11 = factor * 1.0 / 1320.0
+ c13 = factor * 1.0 / 9360.0
+ first = .FALSE.
+END IF
+DO i = 1, nn
+ x02 = x(i) * x(i)
+ x04 = x02 * x02
+ x06 = x04 * x02
+ x08 = x06 * x02
+ x10 = x08 * x02
+ x12 = x10 * x02
+ y(i) = x(i) * ( &
+ + c01 &
+ - c03 * x02 &
+ + c05 * x04 &
+ - c07 * x06 &
+ + c09 * x08 &
+ - c11 * x10 &
+ + c13 * x12)
+ IF (x(i) > 0) THEN
+ y(i) = MIN(y(i), erfmax)
+ ELSE
+ y(i) = MAX(y(i), -erfmax)
+ END IF
+END DO
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_errfunc
+END MODULE mym_errfunc_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90 b/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
new file mode 100644
index 0000000000..62f5e21645
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
@@ -0,0 +1,187 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+
+! Purpose: To calculate heat and moisture fluxes in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_ex_flux_tq_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_EX_FLUX_TQ_MOD'
+CONTAINS
+
+SUBROUTINE mym_ex_flux_tq( &
+ bl_levels, nSCMDpkgs, L_SCMDiags, &
+ tl, qw, rhokh, rhogamt, rhogamq, rdz, &
+ ftl, fqw)
+
+USE atm_fields_bounds_mod, ONLY: tdims, pdims
+USE model_domain_mod, ONLY: model_type, mt_single_column
+USE planet_constants_mod, ONLY: cp, grcp
+USE s_scmop_mod, ONLY: default_streams, &
+ t_avg, d_bl, scmdiag_bl
+USE scmoutput_mod, ONLY: scmoutput
+
+USE yomhook, ONLY: lhook, dr_hook
+USE parkind1, ONLY: jprb, jpim
+
+IMPLICIT NONE
+
+! INTENT IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+! Additional variables for SCM diagnostics which are dummy in full UM
+INTEGER, INTENT(IN) :: &
+ nSCMDpkgs ! No of SCM diagnostics packages
+
+LOGICAL, INTENT(IN) :: &
+ L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! Liquid/frozen water temperture (K)
+ qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! Total water content (kg/kg)
+ rhokh(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels), &
+ ! Exchange coeffs for scalars
+ ! between K and K-1 on theta levels.
+ ! i.e. the coeffs are defined on rho levels
+ rhogamt(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels), &
+ ! Counter gradient term for FTL on rho levels
+ rhogamq(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ 2:bl_levels), &
+ ! Counter gradient Term for FQW on
+ rdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels)
+ ! RDZ(,1) is the reciprocal
+ ! height of level 1, i.e. of the
+ ! middle of layer 1. For K > 1,
+ ! RDZ(,K) is the reciprocal of the
+ ! vertical distance from level
+ ! K-1 to level K.
+
+! INTENT OUT Variables
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ ftl(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! FTL(,K) contains net turb
+ ! sensible heat flux into layer K
+ ! from below; so FTL(,1) is the
+ ! surface sensible heat, H. (W/m2)
+ ! defined on rho levels
+ fqw(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, bl_levels)
+ ! Moisture flux between layers
+ ! (kg per square metre per sec).
+ ! FQW(,1) is total water flux
+ ! from surface, 'E'.
+ ! defined on rho levels
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_EX_FLUX_TQ'
+
+! LOCAL VARIABLES.
+
+INTEGER :: &
+ i, j, k
+
+REAL(KIND=real_umphys) :: &
+ grad_ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Gradient part of FTL
+ ! K*dth/dz
+ grad_fqw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Gradient part of FQW
+ ! K*dq/dz
+ count_grad_ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Counter gradient part of FTL
+ count_grad_fqw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels)
+ ! Counter gradient part of FQW
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+!-----------------------------------------------------------------------
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ grad_ftl(i,j,k)=0.0
+ grad_fqw(i,j,k)=0.0
+ count_grad_ftl(i,j,k)=0.0
+ count_grad_fqw(i,j,k)=0.0
+ END DO
+ END DO
+END DO
+
+DO k = 2, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ grad_ftl(i,j,k)= - rhokh(i,j,k) * &
+ ( ( ( tl(i,j,k) - tl(i,j,k-1) ) * rdz(i,j,k) ) &
+ + grcp )
+ grad_fqw(i,j,k)= - rhokh(i,j,k) * &
+ ( qw(i,j,k) - qw(i,j,k-1) ) * rdz(i,j,k)
+ count_grad_ftl(i,j,k) = -rhogamt(i,j,k)
+ count_grad_fqw(i,j,k) = -rhogamq(i,j,k)
+ ftl(i,j,k) = grad_ftl(i,j,k) + count_grad_ftl(i,j,k)
+ fqw(i,j,k) = grad_fqw(i,j,k) + count_grad_fqw(i,j,k)
+ END DO
+ END DO
+END DO
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( l_scmdiags(scmdiag_bl) .AND. &
+ model_type == mt_single_column ) THEN
+
+ DO k=1, bl_levels
+ DO j=tdims%j_start, tdims%j_end
+ DO i=tdims%i_start, tdims%i_end
+ grad_ftl(i,j,k)= cp * grad_ftl(i,j,k)
+ count_grad_ftl(i,j,k) = cp * count_grad_ftl(i,j,k)
+ END DO ! i
+ END DO ! j
+ END DO ! k
+
+ CALL scmoutput(grad_ftl,'Grad_ftl', &
+ 'Down gradient flux of TL','W/m2', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ CALL scmoutput(count_grad_ftl,'CG_ftl', &
+ 'Counter gradient part of flux of TL','W/m2', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ CALL scmoutput(grad_fqw,'Grad_fqw', &
+ 'Down-gradient flux of QW','kg/m2/s', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ CALL scmoutput(count_grad_fqw,'CG_fqw', &
+ 'Counter gradient part of flux of QW','kg/m2/s', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+END IF ! scmdiag_bl / model_type
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_ex_flux_tq
+END MODULE mym_ex_flux_tq_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90 b/science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90
new file mode 100644
index 0000000000..ecf819cc80
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90
@@ -0,0 +1,138 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+
+! Purpose: To calculate momentum fluxes in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_ex_flux_uv_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_EX_FLUX_UV_MOD'
+CONTAINS
+
+SUBROUTINE mym_ex_flux_uv( &
+ dimsi, dimsi_s, dimso, bl_levels, &
+ rdz_u_v, rhokm_u_v, rhogamuv_uv, u_v, tau_xy_fd_uv, &
+ tau_x_y, tau_grad, tau_count_grad)
+
+USE atm_fields_bounds_mod, ONLY: array_dims
+USE jules_surface_mod, ONLY: formdrag, explicit_stress
+USE yomhook, ONLY: lhook, dr_hook
+USE parkind1, ONLY: jprb, jpim
+IMPLICIT NONE
+
+! Intent IN Variables
+TYPE(array_dims), INTENT(IN) :: &
+ dimsi, & ! Array dimensions for the inputs
+ dimsi_s, & ! Array dimensions for input u or v (has haloes).
+ dimso ! Array dimensions for the outputs and work variables
+
+INTEGER, INTENT(IN) :: bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ rdz_u_v (dimsi%i_start:dimsi%i_end, &
+ dimsi%j_start:dimsi%j_end, 2:bl_levels), &
+ ! Reciprocal of the vertical
+ ! distance from level K-1 to
+ ! level K. (K > 1) on wind levels
+ rhokm_u_v (dimsi%i_start:dimsi%i_end, &
+ dimsi%j_start:dimsi%j_end, bl_levels), &
+ ! Exchange coefficients for
+ ! momentum, on UV-grid with
+ ! first and last j_end ignored.
+ ! for K>=2, between rho level K and K-1.
+ ! i.e. assigned at theta level K-1
+ rhogamuv_uv(dimsi%i_start:dimsi%i_end, &
+ dimsi%j_start:dimsi%j_end, 2:bl_levels), &
+ ! Counter Gradient Term for U or V
+ ! defined on UV-grid
+ u_v(dimsi_s%i_start:dimsi_s%i_end, &
+ dimsi_s%j_start:dimsi_s%j_end,bl_levels), &
+ ! Westerly_Southerly component of wind.
+ tau_xy_fd_uv(dimsi%i_start:dimsi%i_end, &
+ dimsi%j_start:dimsi%j_end, bl_levels)
+ ! X/Y-component of form-drag stress
+ ! at a UV point
+
+! Intent INOUT Variables
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ tau_x_y (dimso%i_start:dimso%i_end, &
+ dimso%j_start:dimso%j_end, bl_levels)
+ ! explicit x_y-component of
+ ! turbulent stress at levels
+ ! k-1/2; eg. TAUX(,1) is surface
+ ! stress. UV-grid, 1st and last j_end
+ ! set to "missing data". (N/sq m)
+
+! Intent OUT Variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ tau_grad(dimso%i_start:dimso%i_end, &
+ dimso%j_start:dimso%j_end,bl_levels), &
+ ! k*du/dz grad stress (kg/m/s2)
+ tau_count_grad(dimso%i_start:dimso%i_end, &
+ dimso%j_start:dimso%j_end,bl_levels)
+ ! Counter gradient stress (kg/m/s2)
+
+! LOCAL VARIABLES.
+INTEGER :: &
+ i, j, k
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_EX_FLUX_UV'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+k=1
+DO j = dimso%j_start, dimso%j_end
+ DO i = dimso%i_start, dimso%i_end
+ tau_grad(i,j,k) = 0.0
+ tau_count_grad(i,j,k) = 0.0
+ END DO
+END DO
+
+DO k = 2, bl_levels
+ DO j = dimso%j_start, dimso%j_end
+ DO i = dimso%i_start, dimso%i_end
+
+ tau_grad(i,j,k) = rhokm_u_v(i,j,k) * &
+ ( u_v(i,j,k) - u_v(i,j,k-1) ) *rdz_u_v(i,j,k)
+ tau_count_grad(i,j,k) = rhogamuv_uv(i, j, k)
+ tau_x_y(i,j,k) = tau_grad(i,j,k) + tau_count_grad(i,j,k)
+
+ END DO
+ END DO
+END DO
+
+! Add explicit orographic stress, noting that the surface stress
+! is to be added later
+
+IF (formdrag == explicit_stress) THEN
+ DO k = 2, bl_levels
+ DO j = dimso%j_start, dimso%j_end
+ DO i = dimso%i_start, dimso%i_end
+ tau_x_y(i,j,k) = tau_x_y(i,j,k) + tau_xy_fd_uv(i,j,k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_ex_flux_uv
+END MODULE mym_ex_flux_uv_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_implic.F90 b/science/physics_schemes/source/boundary_layer/mym_implic.F90
new file mode 100644
index 0000000000..c0a3a557db
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_implic.F90
@@ -0,0 +1,98 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+
+! Purpose: To solve the tri-diagonal equations for the prognostic
+! variables in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_implic_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_IMPLIC_MOD'
+CONTAINS
+
+SUBROUTINE mym_implic(levels, kst, ken, aa, bb, cc, qq)
+
+USE atm_fields_bounds_mod, ONLY: pdims
+USE yomhook, ONLY: lhook, dr_hook
+USE parkind1, ONLY: jprb, jpim
+IMPLICIT NONE
+
+INTEGER, INTENT(IN) :: &
+ levels, &
+ ! number of levels of variables to be solved
+ kst, &
+ ! index of start level to be solved
+ ken
+ ! index of emd level to be solved
+
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ aa(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, levels), &
+ ! coefficients of fields on level K-1
+ ! in the tri-diagonal equation
+ bb(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, levels), &
+ ! coefficients on fields level K
+ ! in the tri-diagonal equation
+ cc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, levels), &
+ ! coefficients on fields level K+1
+ ! in the tri-diagonal equation
+ qq(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, levels)
+ ! right hand side of the tri-diagonal equation
+
+! Local variables
+INTEGER :: &
+ i, j, k
+ ! Loop indexes
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_IMPLIC'
+
+! Solve from top to bottom
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO k = ken, kst + 1, -1
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ aa(i, j, k - 1) = aa(i, j, k - 1) * bb(i, j, k)
+ bb(i, j, k - 1) = bb(i, j, k - 1) * bb(i, j, k) &
+ - aa(i, j, k) * cc(i, j, k - 1)
+ qq(i, j, k - 1) = qq(i, j, k - 1) * bb(i, j, k) &
+ - qq(i, j, k) * cc(i, j, k - 1)
+ END DO
+ END DO
+END DO
+
+DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ qq(i, j, kst) = qq(i, j, kst) / bb(i, j, kst)
+ END DO
+END DO
+
+! Solve from bottom to top
+DO k = kst + 1, ken
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ qq(i, j, k) = (qq(i, j, k) - aa(i, j, k) * &
+ qq(i, j, k - 1)) / bb(i, j, k)
+ END DO
+ END DO
+END DO
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_implic
+END MODULE mym_implic_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_initialize.F90 b/science/physics_schemes/source/boundary_layer/mym_initialize.F90
new file mode 100644
index 0000000000..b03ab74764
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_initialize.F90
@@ -0,0 +1,497 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To set initial values of the prognostic variables
+! appeared in MYmodel (E_TRB, TSQ, QSQ, COV) with MY level
+! 2 model iteration, that is, assuming balance between
+! production and dissipation.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_initialize_mod
+
+USE um_types, ONLY: real_umphys, real_eps
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_INITIALIZE_MOD'
+CONTAINS
+
+SUBROUTINE mym_initialize( &
+! IN levels
+ bl_levels, &
+! IN fields
+ z_uv, z_tq, dbdz, dvdzm, dtldzm, dqwdzm, &
+ fqw, ftl, u_s, r_mosurf, fb_surf, &
+! INOUT fields
+ e_trb, tsq, qsq, cov)
+
+USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_s
+USE mym_const_mod, ONLY: b1, b2, qke_max, coef_trbvar_diff, &
+ coef_trbvar_diff_tke
+USE mym_option_mod, ONLY: &
+ my_lowest_pd_surf, l_my_extra_level, my_z_extra_fact, &
+ tke_levels, l_my_lowest_pd_surf_tqc
+USE planet_constants_mod, ONLY: vkman
+
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+USE mym_calcphi_mod, ONLY: mym_calcphi
+USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
+USE mym_implic_mod, ONLY: mym_implic
+USE mym_length_mod, ONLY: mym_length
+USE mym_level2_mod, ONLY: mym_level2
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Z_TQ(*,K) is height of theta
+ ! level k.
+ dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Modulus of wind shear at theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dtldzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of TL across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dqwdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of QW across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ fqw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! Moisture flux between layers
+ ! (kg per square metre per sec).
+ ! FQW(,1) is total water flux
+ ! from surface, 'E'.
+ ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! FTL(,K) contains net turbulent
+ ! sensible heat flux into layer K
+ ! from below; so FTL(,1) is the
+ ! surface sensible heat, H. (W/m2)
+ u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface friction velocity
+ r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! Surface flux buoyancy over
+ ! density (m^2/s^3)
+
+! Intent INOUT Variables
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! TKE defined on theta levels K-1
+ tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of liquid potential temperature
+ ! (thetal'**2) defined on theta levels K-1
+ qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of total water
+ ! (qw'**2) defined on theta levels K-1
+ cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels)
+ ! Correlation between thetal and qw
+ ! (thetal'qw') defined on theta levels K-1
+
+! Local variables
+INTEGER :: &
+ i, j, k, ll
+ ! Loop indexes
+
+REAL(KIND=real_umphys) :: &
+ phm, &
+ ! gradient function at the surface
+ elq
+ ! mixing length * qkw
+
+REAL(KIND=real_umphys) :: &
+ gm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! square of wind shear on theta level K-1
+ ! (a denominator of gradient Richardson number)
+ gh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! - buoyancy gradient on theta level K-1
+ ! (a numerator of gradient Richardson number)
+ sm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Non-dimensional diffusion coefficients for
+ ! momentum derived by level 2 scheme
+ ! defined on theta level K-1
+ sh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Non-dimensional diffusion coefficients for
+ ! scalars derived by level 2 scheme
+ ! define on theta level K-1
+ el(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! mixing length on theta level K-1
+ qkw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! q=sqrt(qke) on theta level K-1
+ pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! gradient function for momentum minus zeta
+ ! (zeta: height over Monin-Obkhov length)
+ phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! gradient function for scalars
+
+REAL(KIND=real_umphys) :: &
+ pdk(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production terms of qke divided by elq
+ pdt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production terms of tsq divided by elq
+ pdq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production terms of qsq divided by elq
+ pdc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production terms of cov divided by elq
+ pdk0(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! production terms of qke at the lowest level
+ pdt0(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! production terms of tsq at the lowest level
+ pdq0(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! production terms of qsq at the lowest level
+ pdc0(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! production terms of cov at the lowest level
+ aa_qke(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for qke
+ bb_qke(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for qke
+ cc_qke(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for qke
+ aa_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for tsq
+ bb_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for tsq
+ cc_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for tsq
+ aa_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for qsq
+ bb_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for qsq
+ cc_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for qsq
+ aa_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for cov
+ bb_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for cov
+ cc_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficients of the tri-diagonal eqs. for cov
+ aa_oth(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! work variable for aa_tsq, aa_qsq and aa_cov
+ bb_oth(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! work variable for bb_tsq, bb_qsq and bb_cov
+ cc_oth(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! work variable for cc_tsq, cc_qsq and cc_cov
+ qke_nohalo(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! qke without halos
+ dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ bl_levels)
+ ! diffusion coefficient for momentum
+ ! on theta level K-1
+
+INTEGER :: &
+ my3_itr_ini
+ ! number of iteration
+INTEGER :: k_start
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_INITIALIZE'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+my3_itr_ini = tke_levels + 1
+
+IF (my_lowest_pd_surf == 0) THEN
+ l_my_extra_level = .FALSE.
+ my_z_extra_fact = 1.0
+END IF
+
+IF (l_my_extra_level) THEN
+ k_start = 1
+ELSE
+ k_start = 2
+END IF
+
+DO k = 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.0
+ tsq(i, j, k) = 0.0
+ qsq(i, j, k) = 0.0
+ cov(i, j, k) = 0.0
+ END DO
+ END DO
+END DO
+
+CALL mym_level2( &
+ bl_levels, dbdz, dvdzm, gm, gh, sm, sh)
+
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk(i, j, k) = sm(i, j, k) * gm(i, j, k) &
+ + sh(i, j, k) * gh(i, j, k)
+ IF (pdk(i, j, k) <= 0.0) THEN
+ qke_nohalo(i, j, k) = 0.0
+ pdk(i, j, k) = 0.0
+ pdt(i, j, k) = 0.0
+ pdq(i, j, k) = 0.0
+ pdc(i, j, k) = 0.0
+ ELSE
+ qke_nohalo(i, j, k) = 1.0e-5
+ pdt(i, j, k) = sh(i, j, k) * dtldzm(i, j, k) ** 2
+ pdq(i, j, k) = sh(i, j, k) * dqwdzm(i, j, k) ** 2
+ pdc(i, j, k) = sh(i, j, k) * dtldzm(i, j, k) * dqwdzm(i, j, k)
+ END IF
+ END DO
+ END DO
+END DO
+
+IF (my_lowest_pd_surf > 0) THEN
+ CALL mym_calcphi( &
+ bl_levels, z_tq, r_mosurf, pmz, phh)
+ IF (l_my_extra_level) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk0(i, j) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
+ / (vkman * z_tq(i, j, 1) * my_z_extra_fact)
+ END DO
+ END DO
+
+ IF (l_my_lowest_pd_surf_tqc) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ phm = 1.0 / u_s(i, j) * phh(i, j) &
+ / (vkman * z_tq(i, j, 1) * my_z_extra_fact)
+ pdt0(i, j) = phm * ftl(i, j, 1) ** 2
+ pdq0(i, j) = phm * fqw(i, j, 1) ** 2
+ pdc0(i, j) = phm * ftl(i, j, 1) * fqw(i, j, 1)
+ END DO
+ END DO
+ END IF
+ ELSE
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk0(i, j) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
+ / (vkman * z_tq(i, j, 1))
+ END DO
+ END DO
+
+ IF (l_my_lowest_pd_surf_tqc) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ phm = 1.0 / u_s(i, j)* phh(i, j) &
+ / (vkman * z_tq(i, j, 1))
+ pdt0(i, j) = phm * ftl(i, j, 1) ** 2
+ pdq0(i, j) = phm * fqw(i, j, 1) ** 2
+ pdc0(i, j) = phm * ftl(i, j, 1) * fqw(i, j, 1)
+ END DO
+ END DO
+ END IF
+ END IF ! IF L_MY_EXTRA_LEVEL
+END IF ! IF MY_lowest_pd_surf
+
+DO ll = 1, my3_itr_ini
+ CALL mym_length( &
+ tdims%i_end, tdims%j_end, 0, 0, bl_levels, &
+ qke_nohalo, z_uv, z_tq, dbdz, r_mosurf, fb_surf, &
+ qkw, el)
+
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (qke_nohalo(i, j, k) <= 0.0) THEN
+ qkw(i, j, k) = 0.0
+ END IF
+ dfm(i, j, k) = sm(i, j, k) * qkw(i, j, k) * el(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL mym_diff_matcoef( &
+ bl_levels, coef_trbvar_diff_tke, dfm, &
+ aa_qke, bb_qke, cc_qke)
+
+ CALL mym_diff_matcoef( &
+ bl_levels, coef_trbvar_diff, dfm, &
+ aa_oth, bb_oth, cc_oth)
+
+ DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (bb_qke(i, j, k) == 0.0) THEN
+ aa_qke(i, j, k) = 0.0
+ bb_qke(i, j, k) = 1.0
+ cc_qke(i, j, k) = 0.0
+ qke_nohalo(i, j, k) = 0.0
+
+ aa_tsq(i, j, k) = 0.0
+ bb_tsq(i, j, k) = 1.0
+ cc_tsq(i, j, k) = 0.0
+ tsq(i, j, k) = 0.0
+
+ aa_qsq(i, j, k) = 0.0
+ bb_qsq(i, j, k) = 1.0
+ cc_qsq(i, j, k) = 0.0
+ qsq(i, j, k) = 0.0
+
+ aa_cov(i, j, k) = 0.0
+ bb_cov(i, j, k) = 1.0
+ cc_cov(i, j, k) = 0.0
+ cov(i, j, k) = 0.0
+ ELSE
+ elq = qkw(i, j, k) * el(i, j, k)
+ aa_qke(i, j, k) = - aa_qke(i, j, k)
+ bb_qke(i, j, k) = - bb_qke(i, j, k) &
+ + 2.0 * qkw(i, j, k) / (b1 * el(i, j, k))
+ bb_qke(i, j, k) = SIGN(MAX(ABS(bb_qke(i, j, k)), 1.0e-20), &
+ bb_qke(i, j, k))
+
+ cc_qke(i, j, k) = - cc_qke(i, j, k)
+ qke_nohalo(i, j, k) = 2.0 * elq * pdk(i, j, k)
+
+ aa_oth(i, j, k) = - aa_oth(i, j, k)
+ bb_oth(i, j, k) = - bb_oth(i, j, k) &
+ + 2.0 * qkw(i, j, k) / (b2 * el(i, j, k))
+ bb_oth(i, j, k) = SIGN(MAX(ABS(bb_oth(i, j, k)), 1.0e-20), &
+ bb_oth(i, j, k))
+ cc_oth(i, j, k) = - cc_oth(i, j, k)
+
+ aa_tsq(i, j, k) = aa_oth(i, j, k)
+ bb_tsq(i, j, k) = bb_oth(i, j, k)
+ cc_tsq(i, j, k) = cc_oth(i, j, k)
+ tsq(i, j, k) = 2.0 * elq * pdt(i, j, k)
+
+ aa_qsq(i, j, k) = aa_oth(i, j, k)
+ bb_qsq(i, j, k) = bb_oth(i, j, k)
+ cc_qsq(i, j, k) = cc_oth(i, j, k)
+ qsq(i, j, k) = 2.0 * elq * pdq(i, j, k)
+
+ aa_cov(i, j, k) = aa_oth(i, j, k)
+ bb_cov(i, j, k) = bb_oth(i, j, k)
+ cc_cov(i, j, k) = cc_oth(i, j, k)
+ cov(i, j, k) = 2.0 * elq * pdc(i, j, k)
+ END IF
+ END DO
+ END DO
+ END DO
+
+ IF (my_lowest_pd_surf > 0) THEN
+ k = k_start
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (ABS(bb_qke(i, j, k)) >= real_eps) THEN
+ qke_nohalo(i, j, k) = 2.0 * pdk0(i, j)
+ END IF
+ END DO
+ END DO
+
+ IF (l_my_lowest_pd_surf_tqc) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (ABS(bb_qke(i, j, k)) >= real_eps) THEN
+ tsq(i, j, k) = 2.0 * pdt0(i, j)
+ qsq(i, j, k) = 2.0 * pdq0(i, j)
+ cov(i, j, k) = 2.0 * pdc0(i, j)
+ END IF
+ END DO
+ END DO
+ END IF ! IF L_MY_lowest_pd_surf_tqc
+ END IF ! IF MY_lowest_pd_surf > 0
+
+ CALL mym_implic( &
+ tke_levels, k_start, tke_levels, &
+ aa_qke, bb_qke, cc_qke, qke_nohalo)
+
+ CALL mym_implic( &
+ tke_levels, k_start, tke_levels, &
+ aa_tsq, bb_tsq, cc_tsq, tsq)
+
+ CALL mym_implic( &
+ tke_levels, k_start, tke_levels, &
+ aa_qsq, bb_qsq, cc_qsq, qsq)
+
+ CALL mym_implic( &
+ tke_levels, k_start, tke_levels, &
+ aa_cov, bb_cov, cc_cov, cov)
+
+END DO ! iteration ll = 1, my3_itr_ini
+
+DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.5 * MIN( &
+ MAX(qke_nohalo(i, j, k), 1.0e-20), &
+ qke_max)
+ tsq(i, j, k) = MAX(tsq(i, j, k), 0.0)
+ qsq(i, j, k) = MAX(qsq(i, j, k), 0.0)
+ END DO
+ END DO
+END DO
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_initialize
+END MODULE mym_initialize_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_length.F90 b/science/physics_schemes/source/boundary_layer/mym_length.F90
new file mode 100644
index 0000000000..f1613296b5
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_length.F90
@@ -0,0 +1,218 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To calculate mixing length in the MY model.
+! The square root of TKE, required by this subroutine and
+! elsewhere, is also returned
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_length_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_LENGTH_MOD'
+CONTAINS
+
+SUBROUTINE mym_length( &
+ row_length, rows, halo_i, halo_j, bl_levels, &
+ qke, z_uv, z_tq, dbdz, r_mosurf, fb_surf, &
+ qkw, el)
+
+USE mym_const_mod, ONLY: my_alpha4, one_third, elt_min, my_alpha1, &
+ my_alpha2, my_alpha3
+USE mym_option_mod, ONLY: tke_levels, my_z_limit_elb, l_3dtke
+USE parkind1, ONLY: jprb, jpim
+USE planet_constants_mod, ONLY: vkman
+USE yomhook, ONLY: lhook, dr_hook
+USE turb_diff_ctl_mod, ONLY: delta_smag
+USE turb_diff_mod, ONLY: mix_factor
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ row_length, &
+ ! Local number of points on a row
+ rows, &
+ ! Local number of rows in a theta field
+ halo_i, &
+ ! Size of halo in i direction.
+ halo_j, &
+ ! Size of halo in j direction.
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ qke(1-halo_i:row_length+halo_i, 1-halo_j:rows+halo_j, &
+ bl_levels), &
+ ! twice of TKE (denoted to q**2) on theta level K-1
+ z_uv(row_length,rows,bl_levels+1), &
+ ! Z_UV(*,K) is height of rho level k
+ z_tq(row_length,rows,bl_levels), &
+ ! Z_TQ(*,K) is height of theta level k.
+ dbdz(row_length,rows,2:tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) represents the value on theta level K-1
+ r_mosurf(row_length, rows), &
+ ! reciprocal of Monin-Obukhov Length
+ fb_surf(row_length,rows)
+ ! Surface buoyancy flux over
+ ! density (m^2/s^3)
+
+! Intent OUT Variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ qkw(row_length, rows, tke_levels), &
+ ! q=sqrt(qke) on theta level K-1
+ el(row_length, rows, tke_levels)
+ ! mixing length on theta level K-1
+
+! Local variables
+
+INTEGER :: &
+ i, j, k
+ ! Loop indexes
+REAL(KIND=real_umphys) :: &
+ qdz, &
+ ! q times vertical grid space
+ alp32, &
+ ! combined constants (alpha3 / alpha2)
+ rbv, &
+ ! reciprocal of Brunt-Vaisala frequency
+ elb, &
+ ! mixing length related to buoyancy (L_B)
+ els, &
+ ! mixing length related to surface (L_S)
+ ell, &
+ ! additional mixing length for 3DTKE scheme (L_L)
+ zeta
+ ! non-dimensional length (height over MO length)
+REAL(KIND=real_umphys) :: &
+ elt(row_length, rows), &
+ ! mixing length related to vertical distribution
+ ! of TKE (L_T)
+ vsc(row_length, rows)
+ ! work arrays
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ zmax = 1.0, &
+ ! constant used in calculating els
+ cns = 2.7
+ ! constant used in calculating els
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_LENGTH'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO j = 1, rows
+ DO i = 1, row_length
+ elt(i, j) = 0.0
+ vsc(i, j) = 0.0
+ END DO
+END DO
+
+DO k = 1, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ qkw(i, j, k) = SQRT(MAX(qke(i, j, k), 1.0e-20))
+ END DO
+ END DO
+END DO
+
+! vertical integration of qz and q
+! Here, elt is still vertical integration of qz
+! and vsc is that of q
+DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ qdz = qkw(i, j, k) * (z_uv(i, j, k) - z_uv(i, j, k - 1))
+ elt(i, j) = elt(i, j) + qdz * z_tq(i, j, k - 1)
+ vsc(i, j) = vsc(i, j) + qdz
+ END DO
+ END DO
+END DO
+
+DO j = 1, rows
+ DO i = 1, row_length
+ elt(i, j) = MAX(my_alpha1 * elt(i, j) / (vsc(i, j) + 1.0e-10), &
+ elt_min)
+ vsc(i, j) = (elt(i, j) * MAX(fb_surf(i, j), 0.0)) ** one_third
+ END DO
+END DO
+
+alp32 = my_alpha3 / my_alpha2
+DO k = 2, tke_levels
+ DO j = 1, rows
+ DO i = 1, row_length
+ IF (dbdz(i, j, k) > 0.0) THEN
+ rbv = 1.0 / SQRT(dbdz(i, j, k))
+ elb = my_alpha2 * qkw(i, j, k) * rbv &
+ * (1.0 + alp32 * SQRT(vsc(i, j) * rbv / elt(i, j)))
+ ELSE
+ elb = 1.0e10
+ END IF
+
+ IF (z_tq(i, j, k - 1) > my_z_limit_elb) THEN
+ elb = MIN(elb, z_uv(i, j, k) - z_uv(i, j, k - 1))
+ END IF
+
+ zeta = z_tq(i, j, k - 1) * r_mosurf(i, j)
+ IF (zeta > 0.0) THEN
+ els = vkman * z_tq(i, j, k - 1) &
+ / (1.0 + cns * MIN(zeta, zmax))
+ ELSE
+ els = vkman * z_tq(i, j, k - 1) &
+ * MIN((1.0 - my_alpha4 * zeta) ** 0.2, 2.0)
+ END IF
+ IF (l_3dtke) THEN
+ ell = mix_factor * delta_smag(i,j)
+ el(i, j, k) = elb / ( elb / elt(i, j) + elb / els + elb / ell + 1.0)
+ ELSE
+ el(i, j, k) = elb / ( elb / elt(i, j) + elb / els + 1.0)
+ END IF
+ END DO
+ END DO
+END DO
+
+DO j = 1, rows
+ DO i = 1, row_length
+ el(i, j, 1) = el(i, j, 2)
+ END DO
+END DO
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_length
+END MODULE mym_length_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_level2.F90 b/science/physics_schemes/source/boundary_layer/mym_level2.F90
new file mode 100644
index 0000000000..083aaa7eb1
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_level2.F90
@@ -0,0 +1,135 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+
+! Purpose: To calculate fundamental values such as non-dimensional
+! diffusion coefficients in the MY model with level 2
+! scheme.
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_level2_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_LEVEL2_MOD'
+CONTAINS
+
+SUBROUTINE mym_level2( &
+ bl_levels, dbdz, dvdzm, gm, gh, sm, sh)
+
+USE atm_fields_bounds_mod, ONLY: tdims
+USE mym_const_mod, ONLY: ri1, ri2, ri3, ri4, rfc, rf1, rf2, shc, smc
+USE mym_option_mod, ONLY: tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels)
+ ! Modulus of wind shear at theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+
+! Intent OUT Variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ gm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! square of wind shear on theta level K-1
+ ! (a denominator of gradient Richardson number)
+ gh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! - buoyancy gradient on theta level K-1
+ ! (a numerator of gradient Richardson number)
+ sm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Non-dimensional diffusion coefficients for
+ ! momentum from level 2 scheme
+ ! defined on theta level K-1
+ sh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels)
+ ! Non-dimensional diffusion coefficients for
+ ! scalars from level 2 scheme
+ ! define on theta level K-1
+! Local variables
+INTEGER :: &
+ i, j, k
+ ! Loop indexes
+
+REAL(KIND=real_umphys) :: &
+ ri, &
+ ! gradient Richardson Number
+ rf
+ ! flux Richardson Number
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_LEVEL2'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ gm(i, j, k) = dvdzm(i, j, k) * dvdzm(i, j, k)
+ gh(i, j, k) = - dbdz(i, j, k)
+ ! Gradient Richardson number
+ ri = - gh(i, j, k) / MAX( gm(i, j, k), 1.0e-10 )
+ ! Flux Richardson number
+ rf = MIN(ri1 * (ri + ri2 - SQRT(ri ** 2 - ri3 * ri + ri4)), &
+ rfc )
+ sh(i, j, k) = shc * (rfc - rf) / (1.0 - rf)
+ sm(i, j, k) = smc * (rf1 - rf) / (rf2 - rf) * sh(i, j, k)
+ END DO
+ END DO
+END DO
+
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ gm(i, j, 1) = 0.0
+ gh(i, j, 1) = 0.0
+ sh(i, j, 1) = 0.0
+ sm(i, j, 1) = 0.0
+ END DO
+END DO
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_level2
+END MODULE mym_level2_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90 b/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
new file mode 100644
index 0000000000..1c8c00b1e0
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
@@ -0,0 +1,972 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To evaluate buoyancy flux in shallow convection
+! corresponding to the skewness of the distribution function
+! in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_shcu_buoy_mod
+
+USE um_types, ONLY: real_umphys, real_eps
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SHCU_BUOY_MOD'
+CONTAINS
+
+SUBROUTINE mym_shcu_buoy( &
+! IN levels/switches
+ bl_levels,nSCMDpkgs, L_SCMDiags, &
+ BL_diag, &
+! IN fields
+ fb_surf, ustar, pstar, &
+ z_tq, z_uv, p_theta_levels, p_rho_levels, &
+ u_p, v_p, t, q, qcl, qcf, q1, frac_gauss, &
+! INOUT / OUT fields
+ zhpar,frac, wb_ng)
+
+USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, &
+ ScmRowLen, ScmRow
+USE bl_diags_mod, ONLY: strnewbldiag
+USE conversions_mod, ONLY: pi
+USE gen_phys_inputs_mod, ONLY: l_mr_physics
+USE model_domain_mod, ONLY: model_type, mt_single_column
+USE mym_option_mod, ONLY: tke_levels, wb_ng_max, shcu_levels
+USE mym_const_mod, ONLY: one_third
+USE planet_constants_mod, ONLY: r, repsilon, pref, kappa, c_virtual, &
+ recip_kappa, g, lcrcp, ls, lsrcp, grcp
+USE s_scmop_mod, ONLY: default_streams, t_avg, d_bl, d_sl, scmdiag_bl
+USE scmoutput_mod, ONLY: scmoutput
+USE timestep_mod, ONLY: timestep
+USE water_constants_mod, ONLY: lc, tm
+
+USE qsat_mod, ONLY: qsat, qsat_mix
+
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+
+IMPLICIT NONE
+
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! buoyancy flux at the surface
+ ustar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! surface friction velocity
+ pstar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! surface pressure (Pa)
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! height of theta levels
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! height of p levels
+ p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 0:bl_levels + 1), &
+ ! pressure at theta levels (Pa)
+ p_rho_levels(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels)
+ ! pressure at rho levels (Pa)
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ u_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! U at pressure points
+ v_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ ! V at pressure points
+ t(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
+ ! temperature at theta levels
+ q(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! specific humidity at theta levels
+ qcl(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! liquid water content at theta levels
+ qcf(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ tdims_l%k_start:bl_levels), &
+ ! frozen water content at theta levels
+ q1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! normalized excess of water
+ ! (:,:,K) is located at theta level K-1
+ frac_gauss(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! cloud fraction derived with Gaussian distribution
+ ! function
+ ! (:,:,K) is located at theta level K-1
+
+! Additional variables for SCM diagnostics which are dummy in full UM
+INTEGER, INTENT(IN) :: &
+ nSCMDpkgs ! No of SCM diagnostics packages
+LOGICAL, INTENT(IN) :: &
+ L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
+
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ zhpar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! boundary layer height evaluated with Richardson Number
+
+! Declaration of BL diagnostics.
+TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ frac(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! cloud fraction including that by convection
+ ! (:,:,K) is located at theta level K-1
+ wb_ng(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! Non-gradint buoyancy flux due to the skewness
+ ! (:,:,K) is located at theta level K-1
+
+! local variables
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_SHCU_BUOY'
+REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
+ ! work array for scmoutput
+
+INTEGER :: i, j, k, iScm, jScm, &
+ k_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! level for start of parcel ascent
+ ktpar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! highest theta level below inversion (at ZHPAR)
+ k_neut(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! level of neutral parcel buoyancy
+ ktinv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! top level of inversion
+ k_lcl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! level of lifting condensation
+ interp_inv, &
+ ! flag to interpolated inversion heights (1=yes)
+ topbl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! 1 => top of bl reached
+ ! 2 => max allowable height reached
+REAL(KIND=real_umphys) :: &
+ exner(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! sigma^cappa
+ th(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! potential temperature
+ thl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! liquid water potential tempeature
+ tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! liquid water tempeature
+ qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! total water spec humidity
+ thvl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! virtual thl
+ THv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! virtual th
+ thv_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! virtual th for parcel
+ qc_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! parcel liquid water
+ dthvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels), &
+ ! gradient of THV at rho levels
+ dthvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ shcu_levels)
+ ! gradient of THV at theta levels
+
+REAL(KIND=real_umphys) :: &
+ thl_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! parcel thl
+ qw_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! parcel qw
+ sl_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! parcel static energy
+ th_ref(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! reference theta for parcel ascent
+ th_par_kp1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! parcel theta at level below
+ p_lcl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! pressure of LCL
+ thv_pert(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! threshold for parcel thv
+ z_lcl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! height of LCL
+ zh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! boundary layer depth (from RI)
+ zhpar_old(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! height of cloud-top on previous timestep
+ zhpar_max(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Maximum allowed height for cloud-top
+ ! (to limit growth rate of boundary layer)
+ w_star(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! sub-cloud layer velocity scale (m/s)
+ cape(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! convective available potential energy (m2/s2)
+ dbdz_inv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! buoyancy gradient across inversion
+ dz_inv_cu(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! inversion thickness above Cu
+ qsat_calc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! saturated water mixing ratio
+ t_ref(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! reference temperature
+
+REAL(KIND=real_umphys) :: &
+ virt_factor, &
+ ! Vfac = 1+0.61qv - qcl - qcf
+ z_surf, &
+ ! height of surface layer
+ w_s, &
+ ! velocity scale
+ thv_sd, &
+ ! standard deviation of thv in surface layer
+ dqsatdt,qsatfac, &
+ ! saturation coefficients in buoyancy parameters
+ qc_env, &
+ ! environment liquid water
+ vap_press, &
+ ! Vapour pressure.
+ t_lcl, &
+ ! temperature of LCL
+ th_par, &
+ ! theta of parcel
+ t_par, &
+ ! temperature of parcel
+ dpar_bydz, &
+ ! parcel thv gradient
+ denv_bydz, &
+ ! environement thv gradient
+ gamma_fa, &
+ ! free atmospheric lapse rate
+ gamma_cld, &
+ ! cloud layer lapse rate
+ wb_scale, &
+ ! buoyancy flux scaling (m2/s3)
+ w_cld, &
+ ! cloud layer velocity scale (m/s)
+ z_cld, &
+ ! cloud layer depth (m)
+ dz_inv_cu_rec, &
+ ! reconstructed inversion thickness above Cu
+ vscalsq_incld, &
+ ! incloud squared velocity scale
+ m_base, &
+ ! cloud base mass flux (m/s)
+ z_pr,ze_pr, &
+ ! scaled height
+ zpr_top, &
+ ! inversion top in scaled coordinate
+ f_ng, &
+ ! non-gradient shape functions
+ fnn, &
+ ! entrainment factor gN
+ z0,z1,z2,z3, &
+ ! heights for polynomial interpolation
+ d0,d1,d2,d3, &
+ ! values for polynomial interpolation
+ a2,a3,xi, &
+ ! work variables for polynomial interpolation
+ a_poly,b_poly,c_poly, &
+ ! coefficients in polynomial interpolation
+ ri, &
+ ! Richardson number
+ grid_int, &
+ ! THV integral over inversion
+ zhdisc, &
+ ! height of subgrid interpolated inversion
+ weight1, weight2, weight3, &
+ ! weight factors in interpolating
+ lrcp_c, &
+ ! Latent heat over heat capacity
+ l_heat, &
+ ! Latent heat
+ frcu
+ ! cloud fraction due to convection
+
+LOGICAL :: &
+ topinv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! indicates top of inversion being reached
+ topprof(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! indicates top of ascent being reached
+ above_lcl
+ ! indicates being above the LCL
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ a_parcel=0.2, &
+ b_parcel=3.26, &
+ max_t_grad=1.0e-3, &
+ ric=0.25
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ zhpar_old(i, j) = zhpar(i, j)
+ ! Limit boundary layer growth rate to 0.14 m/s
+ ! (approx 500m/hour)
+ zhpar_max(i,j) = MIN( z_tq(i, j, shcu_levels-1), &
+ zhpar_old(i, j)+timestep*0.14 )
+ zh(i, j) = 0.0
+ END DO
+END DO
+DO k = 1, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ ! initialise cumulus cloud fraction to zero
+ exner(i, j, k) = (p_theta_levels(i, j, k) / pref) ** kappa
+ th(i, j, k) = t(i, j, k) / exner(i, j, k)
+ thl(i, j, k) = th(i, j, k) &
+ - (lcrcp*qcl(i,j,k) + lsrcp*qcf(i,j,k)) / exner(i, j, k)
+ qw(i,j,k) = q(i,j,k) + qcl(i,j,k) + qcf(i,j,k)
+ thvl(i,j,k)= thl(i,j,k) * ( 1.0 + c_virtual*qw(i,j,k) )
+ virt_factor = 1.0 + c_virtual*q(i,j,k) &
+ - qcl(i,j,k) - qcf(i,j,k)
+ THv(i,j,k) = th(i,j,k) * virt_factor
+ thv_par(i,j,k) = THv(i,j,k) ! default for stable bls
+ wb_ng(i,j,k) = 0.0
+ frac(i,j,k) = frac_gauss(i,j,k)
+ tl(i,j,k) = t(i,j,k) - lcrcp*qcl(i,j,k) - lsrcp*qcf(i,j,k)
+ END DO
+ END DO
+END DO
+
+DO k = 2, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ dthvdz(i,j,k) = THv(i,j,k) - THv(i,j,k-1)
+ END DO
+ END DO
+END DO
+
+DO k = 3, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ weight1 = z_uv(i,j,k) - z_uv(i,j,k-1)
+ weight2 = z_tq(i,j,k-1)- z_uv(i,j,k-1)
+ weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
+ dthvdzm(i,j,k) = (weight2 * dthvdz(i,j,k) &
+ + weight3 * dthvdz(i,j,k-1)) / weight1
+ END DO
+ END DO
+END DO
+
+k = 2
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ dthvdzm(i,j,k) = dthvdz(i,j,k)
+ END DO
+END DO
+
+DO k = 2, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ ri = (u_p(i,j,k)-u_p(i,j,k-1))**2 &
+ +(v_p(i,j,k)-v_p(i,j,k-1))**2
+ ri = (g*(z_uv(i,j,k)-z_uv(i,j,k-1)) &
+ *dthvdzm(i,j,k)/THv(i,j,k)) / MAX( 1.0e-14, ri )
+ IF ( ri > ric .AND. ABS(zh(i,j)) < real_eps ) THEN
+ zh(i,j)=z_uv(i,j,k)
+ END IF
+ qc_par(i,j,k) = 0.0
+ END DO
+ END DO
+END DO
+!-----------------------------------------------------------------------
+! 1. Set up parcel
+!-----------------------------------------------------------------------
+! Start parcel ascent from grid-level above top of surface layer, taken
+! to be at a height, z_surf, given by 0.1*ZH
+!-----------------------------------------------------------------------
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ k_par(i,j) = 1
+ zhpar(i,j) = zh(i,j) ! initialise to bl depth (from RI)
+ k_lcl(i,j) = 1
+ IF (fb_surf(i,j) >= 0.0) THEN
+ z_surf = 0.1 * zh(i,j)
+ DO WHILE ( z_uv(i,j,k_par(i,j)) < z_surf .AND. &
+ ! not reached Z_SURF
+ thvl(i,j,k_par(i,j)+1) <= thvl(i,j,k_par(i,j)) )
+ ! not reached inversion
+ k_par(i,j) = k_par(i,j) + 1
+ END DO
+ w_s = ( fb_surf(i,j)*zh(i,j) + ustar(i,j)**3 )**one_third
+ thv_sd = 1.93 * fb_surf(i,j) * THv(i,j,k_par(i,j)) &
+ / ( g * w_s )
+ thl_par(i,j) = thl(i,j,k_par(i,j))
+ qw_par(i,j) = qw(i,j,k_par(i,j))
+ sl_par(i,j) = tl(i,j,k_par(i,j)) &
+ + grcp * z_tq(i,j,k_par(i,j))
+ !-----------------------------------------------------------------------
+ ! Calculate temperature and pressure of lifting condensation level
+ ! using approximations from Bolton (1980)
+ !-----------------------------------------------------------------------
+ vap_press = q(i,j,k_par(i,j)) * &
+ p_theta_levels(i,j,k_par(i,j)) / ( 100.0*repsilon )
+ IF (vap_press >= 0.0) THEN
+ t_lcl = 55.0 + 2840.0 / ( 3.5*LOG(t(i,j,k_par(i,j))) &
+ - LOG(vap_press) - 4.805 )
+ p_lcl(i,j) = p_theta_levels(i,j,k_par(i,j)) * &
+ ( t_lcl / t(i,j,k_par(i,j)) )**(recip_kappa)
+ ELSE
+ p_lcl(i,j) = pstar(i,j)
+ END IF
+ ! K_LCL is model level BELOW the lifting condensation level
+ k_lcl(i,j) = 1
+ DO k = 2, shcu_levels
+ IF (p_rho_levels(i,j,k) > p_lcl(i,j)) THEN
+ k_lcl(i,j) = k - 1
+ END IF
+ END DO
+ z_lcl(i,j) = z_uv(i,j,k_lcl(i,j)+1) &
+ + ( z_uv(i,j,k_lcl(i,j))-z_uv(i,j,k_lcl(i,j)+1) ) &
+ * ( p_rho_levels(i,j,k_lcl(i,j)+1) - p_lcl(i,j)) &
+ / ( p_rho_levels(i,j,k_lcl(i,j)+1) &
+ - p_rho_levels(i,j,k_lcl(i,j)) )
+ z_lcl(i,j) = MAX( z_uv(i,j,1), z_lcl(i,j) )
+ !-----------------------------------------------------------------------
+ ! Threshold on parcel buoyancy for ascent, THV_PERT, is related to
+ ! standard deviation of thv in surface layer
+ !-----------------------------------------------------------------------
+ thv_pert(i,j)= MAX( a_parcel, &
+ MIN( max_t_grad*zh(i,j), b_parcel*thv_sd ) )
+
+ th_ref(i,j) = thl_par(i,j)
+ th_par_kp1(i,j) = thl_par(i,j)
+ ELSE
+ ! dummy
+ th_ref(i,j) = thl(i,j,1)
+ z_lcl(i,j) = z_uv(i, j, 1)
+ END IF ! test on unstable
+ END DO
+END DO
+!-----------------------------------------------------------------------
+! 2 Parcel ascent:
+!-----------------------------------------------------------------------
+! Lift parcel conserving its THL and QW.
+! Calculate parcel QC by linearising q_sat about the parcel's
+! temperature extrapolated up to the next grid-level
+
+DO k = 1, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ t_ref(i,j) = th_ref(i,j)*exner(i,j,k)
+ END DO
+ END DO
+
+ IF ( l_mr_physics ) THEN
+ CALL qsat_mix(qsat_calc,t_ref,p_theta_levels(:,:,k),tdims%i_end,tdims%j_end)
+ ELSE
+ CALL qsat(qsat_calc,t_ref,p_theta_levels(:,:,k),tdims%i_end,tdims%j_end)
+ END IF
+
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (fb_surf(i,j) > 0.0) THEN
+ IF (t_ref(i,j) > tm) THEN
+ lrcp_c = lcrcp
+ l_heat = lc
+ ELSE
+ lrcp_c = lsrcp
+ l_heat = ls
+ END IF
+
+ dqsatdt = repsilon * l_heat * qsat_calc(i,j)/(r*t_ref(i,j)**2)
+ qsatfac = 1.0/(1.0+(lrcp_c)*dqsatdt)
+ qc_par(i,j,k) = MAX( 0.0, &
+ qsatfac*( qw_par(i,j) - qsat_calc(i,j) &
+ - (thl_par(i,j)-th_ref(i,j)) &
+ *exner(i,j,k)*dqsatdt ) )
+ qc_env = MAX( 0.0, qsatfac*( qw(i,j,k) - qsat_calc(i,j) &
+ - (tl(i,j,k)-t_ref(i,j)) *dqsatdt ) )
+ qc_par(i,j,k) = qc_par(i,j,k) + qcl(i,j,k) + qcf(i,j,k) &
+ - qc_env
+ t_par = sl_par(i,j) - grcp * z_tq(i,j,k) &
+ + lrcp_c * qc_par(i,j,k)
+ ! recalculate if signs of T_REF and T_PAR are different
+ IF (t_ref(i,j) <= tm .AND. t_par > tm) THEN
+ lrcp_c = lcrcp
+ qsatfac = 1.0/(1.0+(lrcp_c)*dqsatdt)
+ qc_par(i,j,k) = MAX( 0.0, &
+ qsatfac*( qw_par(i,j) - qsat_calc(i,j) &
+ - (sl_par(i,j)-grcp*z_tq(i,j,k)-t_ref(i,j)) &
+ *dqsatdt ) )
+ qc_par(i,j,k) = qc_par(i,j,k) + qcl(i,j,k) + qcf(i,j,k) &
+ - qc_env
+ t_par = sl_par(i,j) - grcp * z_tq(i,j,k) &
+ + lrcp_c * qc_par(i,j,k)
+ END IF
+ th_par = t_par / exner(i,j,k)
+ thv_par(i,j,k) = th_par * &
+ (1.0+c_virtual*qw_par(i,j) &
+ -(1.0+c_virtual)*qc_par(i,j,k))
+ IF (k > 1 .AND. k < shcu_levels - 1) THEN
+ ! extrapolate reference TH gradient up to next grid-level
+ z_pr = (z_tq(i,j,k+1)-z_tq(i,j,k)) &
+ /(z_tq(i,j,k)-z_tq(i,j,k-1))
+ th_ref(i,j) = th_par*(1.0+z_pr) &
+ - th_par_kp1(i,j)*z_pr
+ th_par_kp1(i,j) = th_par
+ END IF
+ END IF ! test on unstable
+ END DO
+ END DO
+END DO
+!-----------------------------------------------------------------------
+! 3 Identify layer boundaries
+!-----------------------------------------------------------------------
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ topbl(i,j) = 0
+ topprof(i,j) = .FALSE.
+ topinv(i,j)= .FALSE.
+ ktpar(i,j) = 1
+ k_neut(i,j) = 1
+ ktinv(i,j) = 1
+ dbdz_inv(i,j) = 0.003
+ ! start with a weak minimum inversion lapse rate
+ ! (~1.e-4 s^-2, converted from K/m to s^-2 later)
+ END DO
+END DO
+
+DO k = 2, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+
+ IF (fb_surf(i,j) > 0.0) THEN
+ !------------------------------------------------------------
+ ! Set flag to true when level BELOW is above the lcl
+ ! and above LCL transition zone
+ !------------------------------------------------------------
+ above_lcl = k-1 > k_lcl(i,j) + 1 &
+ .AND. z_tq(i,j,k-1) > 1.1*z_lcl(i,j)
+ !-------------------------------------------------------------
+ ! Calculate vertical gradients in parcel and environment THV
+ !-------------------------------------------------------------
+ dpar_bydz = (thv_par(i,j,k) - thv_par(i,j,k-1)) / &
+ (z_tq(i,j,k) - z_tq(i,j,k-1))
+ denv_bydz = (THv(i,j,k) - THv(i,j,k-1)) / &
+ (z_tq(i,j,k) - z_tq(i,j,k-1))
+ !-------------------------------------------------------------
+ ! Find top of inversion - where parcel has minimum buoyancy
+ !-------------------------------------------------------------
+ IF ( topbl(i,j) > 0 .AND. .NOT. topinv(i,j) ) THEN
+ dbdz_inv(i,j) = MAX( dbdz_inv(i,j), denv_bydz )
+ IF ( k-1 > ktpar(i,j)+2 .AND. ( &
+ ! Inversion at least two grid-levels thick
+ denv_bydz <= dpar_bydz .OR. &
+ ! => at a parcel buoyancy minimum
+ z_uv(i,j,k) > zhpar(i,j)+MIN(1000.0, 0.5*zhpar(i,j)) &
+ )) THEN
+ ! restrict inversion thickness < 1/2 bl depth and 1km
+ topinv(i,j) = .TRUE.
+ ktinv(i,j) = k-1
+ END IF
+ END IF
+ !-------------------------------------------------------------
+ ! Find base of inversion - where parcel has maximum buoyancy
+ ! or is negatively buoyant
+ !-------------------------------------------------------------
+ IF ( .NOT. topprof(i,j) .AND. k > k_par(i,j) .AND. &
+ ((thv_par(i,j,k)-THv(i,j,k) &
+ <= - thv_pert(i,j)) .OR. &
+ k > shcu_levels - 1 )) THEN
+ topprof(i,j) = .TRUE.
+ k_neut(i,j) = k-1
+ END IF
+
+ IF ( topbl(i,j) == 0 .AND. k > k_par(i,j) .AND. &
+ ( ( thv_par(i,j,k)-THv(i,j,k) &
+ <= - thv_pert(i,j)) .OR. &
+ ! plume non buoyant
+
+ ( above_lcl .AND. (denv_bydz > 1.25*dpar_bydz) ) &
+
+ ! or environmental virtual temperature gradient
+ ! significantly larger than parcel gradient
+ ! above lifting condensation level
+
+ )) THEN
+
+ topbl(i,j) = 1
+ ktpar(i,j) = k-1 ! marks most buoyant theta-level
+ ! (just below inversion)
+ zhpar(i,j) = z_uv(i,j,k)
+ dbdz_inv(i,j) = MAX( dbdz_inv(i,j), denv_bydz )
+ END IF
+
+ IF ( topbl(i,j) == 0 .AND. &
+ (z_tq(i,j,k-1) >= zhpar_max(i,j) &
+ .OR. k == shcu_levels)) THEN
+ ! gone above maximum allowed height
+ topbl(i,j) = 2
+ ktpar(i,j) = k-2
+ dbdz_inv(i,j) = MAX( dbdz_inv(i,j), denv_bydz )
+ END IF
+ END IF ! test on unstable
+ END DO
+ END DO
+END DO
+
+!-----------------------------------------------------------------------
+! 3.1 Interpolate inversion base and top between grid-levels
+!-----------------------------------------------------------------------
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF ( ktpar(i,j) > 1 ) THEN
+ !-----------------------------------------------------
+ ! parcel rose successfully
+ !-----------------------------------------------------
+ zhpar(i,j) = z_uv(i,j,ktpar(i,j)+1)
+
+ ! to determine if interpolation of the inversion is performed
+ IF (topbl(i,j) == 2) THEN
+ ! Stopped at max allowable height
+ interp_inv= 0
+ zhpar(i,j) = zhpar_max(i,j)
+ k = ktpar(i,j)
+ ELSE
+ interp_inv=1
+ !-------------------------------------------------------
+ ! First interpolate inversion base (max buoyancy excess)
+ !-------------------------------------------------------
+ !-----------------------------------------------------------
+ ! interpolate height by fitting a cubic to 3 parcel excesses,
+ ! at Z1 (top of cloud layer) and the two grid-levels above,
+ ! and matching cloud layer gradient (D1-D0) at Z1.
+ !-----------------------------------------------------------
+ k = ktpar(i,j)+2
+ z3=z_tq(i,j,k) -z_tq(i,j,k-2)
+ d3=thv_par(i,j,k)-THv(i,j,k)
+ z2=z_tq(i,j,k-1)-z_tq(i,j,k-2)
+ d2=thv_par(i,j,k-1)-THv(i,j,k-1)
+ z1=z_tq(i,j,k-2)-z_tq(i,j,k-2)
+ d1=thv_par(i,j,k-2)-THv(i,j,k-2)
+ z0=z_tq(i,j,k-3)-z_tq(i,j,k-2)
+ d0=thv_par(i,j,k-3)-THv(i,j,k-3)
+ c_poly = (d1-d0)/(z1-z0)
+ a2= d2 - d1 - c_poly*z2
+ a3= d3 - d1 - c_poly*z3
+ b_poly = (a3-a2*z3**3/z2**3)/(z3*z3*(1.0-z3/z2))
+ a_poly = (a2-b_poly*z2*z2)/z2**3
+
+ xi=b_poly*b_poly-3.0*a_poly*c_poly
+ IF (ABS(a_poly) >= real_eps .AND. xi > 0.0) THEN
+ ! ZHPAR is then the height where the above
+ ! polynomial has zero gradient
+ zhpar(i,j) = z_tq(i,j,k-2)-(b_poly+SQRT(xi)) &
+ /(3.0*a_poly)
+ zhpar(i,j) = MAX( MIN( zhpar(i,j), z_tq(i,j,k) ), &
+ z_tq(i,j,k-2) )
+ IF ( zhpar(i,j) > z_tq(i,j,ktpar(i,j)+1) ) THEN
+ ktpar(i,j)=ktpar(i,j)+1
+ END IF
+ END IF
+ k = ktpar(i,j)
+ denv_bydz = (THv(i,j,k+1) - THv(i,j,k)) / &
+ (z_tq(i,j,k+1) - z_tq(i,j,k))
+ END IF
+ IF ( interp_inv == 1 ) THEN
+ !-----------------------------------------------------
+ ! Now interpolate inversion top
+ !-----------------------------------------------------
+ IF ( ktinv(i,j) > ktpar(i,j)+1 ) THEN
+ k = ktinv(i,j)+1
+ dpar_bydz = (thv_par(i,j,k) - thv_par(i,j,k-1)) / &
+ (z_tq(i,j,k) - z_tq(i,j,k-1))
+ denv_bydz = (THv(i,j,k) - THv(i,j,k-1)) / &
+ (z_tq(i,j,k) - z_tq(i,j,k-1))
+ IF (denv_bydz < dpar_bydz) THEN
+ !-----------------------------------------------------------
+ ! interpolate height by fitting a parabola to parcel
+ ! excesses and finding the height of its minimum
+ !-----------------------------------------------------------
+ z1=z_tq(i,j,k)
+ d1=thv_par(i,j,k)-THv(i,j,k)
+ z2=z_tq(i,j,k-1)
+ d2=thv_par(i,j,k-1)-THv(i,j,k-1)
+ z3=z_tq(i,j,k-2)
+ d3=thv_par(i,j,k-2)-THv(i,j,k-2)
+ xi=z2**2-z3**2
+ b_poly=( d1-d3 - (d2-d3)*(z1**2-z3**2)/xi ) / &
+ ( z1-z3 - (z2-z3)*(z1**2-z3**2)/xi )
+ a_poly=(d2 - d3 - b_poly*(z2-z3) )/xi
+ END IF
+ END IF ! inversion top grid-level 2 levels above parcel top
+ END IF ! interp_inv flag
+ END IF ! parcel rose
+ END DO
+END DO
+!-----------------------------------------------------------------------
+! 4. Integrate parcel excess buoyancy
+!-----------------------------------------------------------------------
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ cape(i,j) = 0.0
+ END DO
+END DO
+DO k = 2, shcu_levels - 1
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (k > k_lcl(i,j) .AND. k <= k_neut(i,j)-1) THEN
+ cape(i,j) = cape(i,j) + (thv_par(i,j,k) - THv(i,j,k)) &
+ * (z_uv(i,j,k+1)-z_uv(i,j,k)) / THv(i,j,k)
+ END IF
+ END DO
+ END DO
+END DO
+!-----------------------------------------------------------------------
+! 6. Calculate non-gradient fluxes and velocity scales
+!-----------------------------------------------------------------------
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ dz_inv_cu(i,j) = 0.0
+ frcu = 0.0
+ IF (fb_surf(i,j) > 0.0) THEN
+ w_star(i,j) = ( fb_surf(i,j)*zhpar(i,j) )**one_third
+ ! dry bl scale
+ dbdz_inv(i,j) = g*dbdz_inv(i,j)/THv(i,j,ktpar(i,j))
+ ! convert to buoyancy units
+ dz_inv_cu(i,j) = 0.2*zhpar(i,j)
+ ! default for no CAPE
+ END IF
+
+ IF (cape(i,j) > 0.0 .AND. zhpar(i,j) - z_lcl(i,j) > 0.0) THEN
+ k = k_lcl(i,j)
+ ! calculate velocity scales
+ w_star(i,j) = ( fb_surf(i,j)*z_lcl(i,j) )**one_third
+ m_base = 0.04*w_star(i,j)
+ cape(i,j) = g * cape(i,j)
+ w_cld = ( m_base * cape(i,j) )**one_third
+ z_cld = zhpar(i,j) - z_lcl(i,j)
+ ! calculate fluxes at LCL
+ wb_scale = ( w_cld**3/z_cld ) * SQRT( m_base/w_cld )
+
+ !----------------------------------------------------------
+ ! Estimate inversion thickness.
+ !----------------------------------------------------------
+ vscalsq_incld = 2.0*cape(i,j)
+ dz_inv_cu(i,j) = SQRT( vscalsq_incld/dbdz_inv(i,j) )
+
+ ! If inversion is unresolved (less than 3 grid-levels thick)
+ ! then use profile reconstruction
+
+ IF ( ktpar(i,j) <= shcu_levels - 4 ) THEN
+ IF ( dz_inv_cu(i,j) &
+ < z_tq(i,j,ktpar(i,j)+3) - z_tq(i,j,ktpar(i,j)) ) THEN
+
+ ! First interpolate to find height of discontinuous inversion
+
+ k = ktpar(i,j)
+ gamma_cld = (THv(i,j,k)-THv(i,j,k-1)) &
+ /(z_tq(i,j,k)-z_tq(i,j,k-1))
+ IF (k-2 > k_lcl(i,j)) THEN
+ gamma_cld = MIN( gamma_cld, &
+ ( THv(i,j,k-1)-THv(i,j,k-2) ) &
+ /( z_tq(i,j,k-1)- z_tq(i,j,k-2) ) )
+ END IF
+ gamma_cld = MAX(0.0, gamma_cld)
+ gamma_fa = (THv(i,j,k+4)-THv(i,j,k+3)) &
+ /(z_tq(i,j,k+4)-z_tq(i,j,k+3))
+ gamma_fa = MAX(0.0, gamma_fa)
+ ! Integrate thv over the inversion grid-levels
+ grid_int = (THv(i,j,k+1)-THv(i,j,k)) &
+ *(z_uv(i,j,k+2)-z_uv(i,j,k+1)) &
+ + (THv(i,j,k+2)-THv(i,j,k)) &
+ *(z_uv(i,j,k+3)-z_uv(i,j,k+2)) &
+ + (THv(i,j,k+3)-THv(i,j,k)) &
+ *( z_tq(i,j,k+3)-z_uv(i,j,k+3))
+
+ c_poly = (THv(i,j,k+3)-THv(i,j,k)) &
+ *(z_tq(i,j,k+3)-z_tq(i,j,k)) &
+ - 0.5*gamma_fa*(z_tq(i,j,k+3)-z_tq(i,j,k))**2 &
+ - grid_int
+ b_poly = -(THv(i,j,k+3)-THv(i,j,k) &
+ -gamma_fa*(z_tq(i,j,k+3)-z_tq(i,j,k)))
+ a_poly = 0.5*(gamma_cld-gamma_fa)
+ xi = b_poly*b_poly-4.0*a_poly*c_poly
+
+ IF (xi >= 0.0 .AND. &
+ ( ABS(a_poly) >= real_eps &
+ .OR. ABS(b_poly) >= real_eps )) THEN
+ IF (ABS(a_poly) < real_eps) THEN
+ dz_inv_cu_rec = -c_poly/b_poly
+ ELSE
+ dz_inv_cu_rec = (-b_poly-SQRT(xi))/(2.0*a_poly)
+ END IF
+ zhdisc = z_tq(i,j,k)+dz_inv_cu_rec
+
+ ! Now calculate inversion stability given Dz=V^2/DB
+
+ c_poly = -vscalsq_incld*THv(i,j,k+1)/g
+ b_poly = THv(i,j,k+3)-gamma_fa *(z_tq(i,j,k+3)-zhdisc) &
+ -THv(i,j,k) -gamma_cld*(zhdisc -z_tq(i,j,k))
+ a_poly = 0.5*(gamma_cld+gamma_fa)
+ xi=b_poly*b_poly-4.0*a_poly*c_poly
+
+ IF (xi >= 0.0 .AND. &
+ ( ABS(a_poly) >= real_eps &
+ .OR. ABS(b_poly) >= real_eps )) THEN
+ IF (ABS(a_poly) < real_eps) THEN
+ dz_inv_cu_rec = -c_poly/b_poly
+ ELSE
+ dz_inv_cu_rec = (-b_poly+SQRT(xi))/(2.0*a_poly)
+ END IF
+ dz_inv_cu_rec = MIN( dz_inv_cu_rec, &
+ 2.0*(zhdisc-z_tq(i,j,ktpar(i,j))) )
+ IF (dz_inv_cu_rec <= dz_inv_cu(i,j)) THEN
+ dz_inv_cu(i,j) = dz_inv_cu_rec
+ END IF
+ END IF ! interpolation for DZ_INV_CU successful
+ END IF ! interpolation for ZHDISC successful
+
+ END IF ! inversion not resolved
+ END IF ! if ktpar(i,j) <= shcu_levels - 4
+
+ zpr_top = 1.0 + MIN(1.0, dz_inv_cu(i,j)/z_cld )
+ DO k = 1, shcu_levels-1
+ ! Z_PR=0 at cloud-base, 1 at cloud-top
+ z_pr = ( z_uv(i,j,k+1) - z_lcl(i,j) )/ z_cld
+ IF (z_pr > 0.0) THEN
+
+ ! Non-gradient function for WB
+
+ f_ng = 0.0
+ IF ( z_pr <= 0.9 ) THEN
+ ! function with gradient=0 at z=0.9
+ ! f=0,1 at z=0,0.9
+ ze_pr = z_pr/0.9
+ f_ng = 0.5 * SQRT(ze_pr) * (3.0-ze_pr)
+ ELSE IF (z_pr <= zpr_top) THEN
+ ze_pr = (z_pr-0.9)/(zpr_top-0.9) ! from 0 to 1
+ f_ng = 0.5 * (1.0+COS(pi*ze_pr))
+ END IF
+ fnn = 0.5 * (1.0 + TANH(0.8 * (q1(i,j,k+1) + 0.5)))
+ wb_ng(i,j,k+1) = MIN((1.0-fnn)*3.7*f_ng*wb_scale, wb_ng_max)
+ END IF ! if Z_PR > 0
+
+ ! Cloud fraction enhancement and sigma_s calculation (for ql)
+ ! (on Z rather than ZE levels)
+
+ z_pr = ( z_tq(i,j,k) - z_lcl(i,j) )/ z_cld
+ ! Z_PR=0 at cloud-base, 1 at cloud-top
+
+ IF (z_pr > 0.0) THEN
+ f_ng = 0.0
+ IF ( z_pr <= 0.9 ) THEN
+ f_ng = 1.0+3.0*EXP(-5.0*z_pr) ! =4 at cloud-base
+ ELSE IF ( z_pr < zpr_top ) THEN
+ ze_pr = (z_pr-0.9)/(zpr_top-0.9) ! from 0 to 1
+ f_ng = 0.5*(1.0+COS(pi*ze_pr))
+ END IF
+ frcu = 0.5*f_ng*MIN(0.5,m_base/w_cld)
+ END IF ! Z_PR > 0
+ frac(i,j,k+1) = MAX( frac_gauss(i,j,k+1), frcu)
+ END DO ! loop over K
+ END IF ! Test on CAPE
+ END DO
+END DO
+
+DO k = shcu_levels + 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ frac(i, j, k) = 0.0
+ wb_ng(i, j, k) = 0.0
+ END DO
+ END DO
+END DO
+
+IF (BL_diag%l_wb_ng) THEN
+ DO k = 2, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%wb_ng(i, j, k) = wb_ng(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( L_SCMDiags(scmdiag_bl) .AND. &
+ (model_type == mt_single_column) ) THEN
+
+ ! Note that diagnostics here has only "shcu_levels" levels.
+ ! It is necessary to copy them to an array which has "bl_levels"
+
+!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
+!$OMP PRIVATE(i, j, k) &
+!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
+ DO k = 1, bl_levels
+ DO j = 1, ScmRow
+ DO i = 1, ScmRowLen
+ TmpScm3d(i,j,k) = 0.0
+ END DO
+ END DO
+ END DO
+!$OMP END PARALLEL DO
+
+ ! for WB_NG
+ DO k = 1, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm, jScm, k) = wb_ng(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'WB_NG', &
+ 'Non-gradinet buoyancy flux',' ', &
+ t_avg, d_bl, default_streams, '', routinename)
+
+ ! for FRAC
+ DO k = 1, shcu_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm, jScm, k) = frac(i, j, k)
+ END DO
+ END DO
+ END DO
+ CALL scmoutput(TmpScm3d,'CF_NL', &
+ 'non-local cloud fraction',' ', &
+ t_avg, d_bl, default_streams, '', routinename)
+
+ CALL scmoutput(cape,'CAPE_scu', &
+ 'CAPE',' ', &
+ t_avg, d_sl, default_streams, '', routinename)
+
+ CALL scmoutput(z_lcl,'zlcl_scu', &
+ 'Z_LCL',' ', &
+ t_avg, d_sl, default_streams, '', routinename)
+
+ CALL scmoutput(zhpar,'zhpar_scu', &
+ 'ZHPAR',' ', &
+ t_avg, d_sl, default_streams, '', routinename)
+
+END IF
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_shcu_buoy
+END MODULE mym_shcu_buoy_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90 b/science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90
new file mode 100644
index 0000000000..1fbe6f1992
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90
@@ -0,0 +1,244 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To perform the incomplete LU decomposition with fill-in
+! level 2
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_simeq_ilud2_decmp_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SIMEQ_ILUD2_DECMP_MOD'
+CONTAINS
+
+SUBROUTINE mym_simeq_ilud2_decmp( &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
+ ppp_tc_k, pp1_tc_k, pp2_tc_k, &
+ aap_qsq_k, r_bbp_qsq_k, ccp_qsq_k, &
+ ppp_qc_k, pp1_qc_k, pp2_qc_k, &
+ aap_cov_k, r_bbp_cov_k, ccp_cov_k, &
+ ppp_ct_k, ppp_cq_k, pp1_ct_k, pp1_cq_k, pp2_ct_k, pp2_cq_k)
+
+USE mym_option_mod, ONLY: tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+! intent in variables
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ aa_tsq_k(tke_levels), &
+ bb_tsq_k(tke_levels), &
+ cc_tsq_k(tke_levels), &
+ pp_tc_k(tke_levels), &
+ aa_qsq_k(tke_levels), &
+ bb_qsq_k(tke_levels), &
+ cc_qsq_k(tke_levels), &
+ pp_qc_k(tke_levels), &
+ aa_cov_k(tke_levels), &
+ bb_cov_k(tke_levels), &
+ cc_cov_k(tke_levels), &
+ pp_ct_k(tke_levels), &
+ pp_cq_k(tke_levels)
+ ! matrix elements
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ aap_tsq_k(tke_levels), &
+ r_bbp_tsq_k(tke_levels), &
+ ccp_tsq_k(tke_levels), &
+ ppp_tc_k(tke_levels), &
+ pp1_tc_k(tke_levels), &
+ pp2_tc_k(tke_levels), &
+ aap_qsq_k(tke_levels), &
+ r_bbp_qsq_k(tke_levels), &
+ ccp_qsq_k(tke_levels), &
+ ppp_qc_k(tke_levels), &
+ pp1_qc_k(tke_levels), &
+ pp2_qc_k(tke_levels), &
+ aap_cov_k(tke_levels), &
+ r_bbp_cov_k(tke_levels), &
+ ccp_cov_k(tke_levels), &
+ ppp_ct_k(tke_levels), &
+ ppp_cq_k(tke_levels), &
+ pp1_ct_k(tke_levels), &
+ pp1_cq_k(tke_levels), &
+ pp2_ct_k(tke_levels), &
+ pp2_cq_k(tke_levels)
+ ! matrix elements of the ILU decomposed matrix
+
+INTEGER :: k
+ ! loop indexes
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SIMEQ_ILUD2_DECMP'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+aap_tsq_k(1) = aa_tsq_k(1)
+r_bbp_tsq_k(1) = 1.0 / bb_tsq_k(1)
+ccp_tsq_k(1) = cc_tsq_k(1)
+
+aap_qsq_k(1) = aa_qsq_k(1)
+r_bbp_qsq_k(1) = 1.0 / bb_qsq_k(1)
+ccp_qsq_k(1) = cc_qsq_k(1)
+
+ppp_tc_k(1) = pp_tc_k(1)
+ppp_qc_k(1) = pp_qc_k(1)
+
+pp1_tc_k(1) = 0.0
+pp1_qc_k(1) = 0.0
+pp2_tc_k(1) = 0.0
+pp2_qc_k(1) = 0.0
+
+DO k = 2, tke_levels
+ aap_tsq_k(k) = aa_tsq_k(k)
+ r_bbp_tsq_k(k) = 1.0 / (bb_tsq_k(k) &
+ - aap_tsq_k(k) * ccp_tsq_k(k - 1) * r_bbp_tsq_k(k - 1))
+ ccp_tsq_k(k) = cc_tsq_k(k)
+
+ aap_qsq_k(k) = aa_qsq_k(k)
+ r_bbp_qsq_k(k) = 1.0 / (bb_qsq_k(k) &
+ - aap_qsq_k(k) * ccp_qsq_k(k - 1) * r_bbp_qsq_k(k - 1))
+ ccp_qsq_k(k) = cc_qsq_k(k)
+
+ ppp_tc_k(k) = pp_tc_k(k)
+ ppp_qc_k(k) = pp_qc_k(k)
+
+ pp1_tc_k(k) = - aap_tsq_k(k) * r_bbp_tsq_k(k - 1) * ppp_tc_k(k - 1)
+ pp1_qc_k(k) = - aap_qsq_k(k) * r_bbp_qsq_k(k - 1) * ppp_qc_k(k - 1)
+
+ pp2_tc_k(k) = - aap_tsq_k(k) * r_bbp_tsq_k(k - 1) * pp1_tc_k(k - 1)
+ pp2_qc_k(k) = - aap_qsq_k(k) * r_bbp_qsq_k(k - 1) * pp1_qc_k(k - 1)
+
+END DO
+
+k = 1
+
+ppp_ct_k(k) = pp_ct_k(k)
+ppp_cq_k(k) = pp_cq_k(k)
+
+pp1_ct_k(k) = -ppp_ct_k(k) * r_bbp_tsq_k(k) * ccp_tsq_k(k)
+pp1_cq_k(k) = -ppp_cq_k(k) * r_bbp_qsq_k(k) * ccp_qsq_k(k)
+
+pp2_ct_k(k) = - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * ccp_tsq_k(k + 1)
+pp2_cq_k(k) = - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * ccp_qsq_k(k + 1)
+
+aap_cov_k(k) = 0.0
+
+r_bbp_cov_k(k) = 1.0 / ( &
+ bb_cov_k(k) &
+ - ppp_ct_k(k) * r_bbp_tsq_k(k) * ppp_tc_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * pp1_tc_k(k + 1) &
+ - pp2_ct_k(k) * r_bbp_tsq_k(k + 2) * pp2_tc_k(k + 2) &
+ - ppp_cq_k(k) * r_bbp_qsq_k(k) * ppp_qc_k(k) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * pp1_qc_k(k + 1) &
+ - pp2_cq_k(k) * r_bbp_qsq_k(k + 2) * pp2_qc_k(k + 2))
+
+ccp_cov_k(k) = cc_cov_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * ppp_tc_k(k + 1) &
+ - pp2_ct_k(k) * r_bbp_tsq_k(k + 2) * pp1_tc_k(k + 2) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * ppp_qc_k(k + 1) &
+ - pp2_cq_k(k) * r_bbp_qsq_k(k + 2) * pp1_qc_k(k + 2)
+
+DO k = 2, tke_levels - 2
+ ppp_ct_k(k) = pp_ct_k(k)
+ ppp_cq_k(k) = pp_cq_k(k)
+
+ pp1_ct_k(k) = -ppp_ct_k(k) * r_bbp_tsq_k(k) * ccp_tsq_k(k)
+ pp1_cq_k(k) = -ppp_cq_k(k) * r_bbp_qsq_k(k) * ccp_qsq_k(k)
+
+ pp2_ct_k(k) = - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * ccp_tsq_k(k + 1)
+ pp2_cq_k(k) = - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * ccp_qsq_k(k + 1)
+
+ aap_cov_k(k) = aa_cov_k(k) &
+ - ppp_ct_k(k) * r_bbp_tsq_k(k) * pp1_tc_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * pp2_tc_k(k + 1) &
+ - ppp_cq_k(k) * r_bbp_qsq_k(k) * pp1_qc_k(k) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * pp2_qc_k(k + 1)
+
+ r_bbp_cov_k(k) = 1.0 / ( &
+ bb_cov_k(k) &
+ - ppp_ct_k(k) * r_bbp_tsq_k(k) * ppp_tc_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * pp1_tc_k(k + 1) &
+ - pp2_ct_k(k) * r_bbp_tsq_k(k + 2) * pp2_tc_k(k + 2) &
+ - ppp_cq_k(k) * r_bbp_qsq_k(k) * ppp_qc_k(k) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * pp1_qc_k(k + 1) &
+ - pp2_cq_k(k) * r_bbp_qsq_k(k + 2) * pp2_qc_k(k + 2) &
+ - aap_cov_k(k) * r_bbp_cov_k(k - 1) * ccp_cov_k(k - 1))
+
+ ccp_cov_k(k) = cc_cov_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * ppp_tc_k(k + 1) &
+ - pp2_ct_k(k) * r_bbp_tsq_k(k + 2) * pp1_tc_k(k + 2) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * ppp_qc_k(k + 1) &
+ - pp2_cq_k(k) * r_bbp_qsq_k(k + 2) * pp1_qc_k(k + 2)
+END DO
+
+k = tke_levels - 1
+
+ppp_ct_k(k) = pp_ct_k(k)
+ppp_cq_k(k) = pp_cq_k(k)
+
+pp1_ct_k(k) = -ppp_ct_k(k) * r_bbp_tsq_k(k) * ccp_tsq_k(k)
+pp1_cq_k(k) = -ppp_cq_k(k) * r_bbp_qsq_k(k) * ccp_qsq_k(k)
+pp2_ct_k(k) = 0.0
+pp2_cq_k(k) = 0.0
+
+aap_cov_k(k) = aa_cov_k(k) &
+ - ppp_ct_k(k) * r_bbp_tsq_k(k) * pp1_tc_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * pp2_tc_k(k + 1) &
+ - ppp_cq_k(k) * r_bbp_qsq_k(k) * pp1_qc_k(k) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * pp2_qc_k(k + 1)
+
+r_bbp_cov_k(k) = 1.0 / ( &
+ bb_cov_k(k) &
+ - ppp_ct_k(k) * r_bbp_tsq_k(k) * ppp_tc_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * pp1_tc_k(k + 1) &
+ - ppp_cq_k(k) * r_bbp_qsq_k(k) * ppp_qc_k(k) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * pp1_qc_k(k + 1) &
+ - aap_cov_k(k) * r_bbp_cov_k(k - 1) * ccp_cov_k(k - 1))
+
+ccp_cov_k(k) = cc_cov_k(k) &
+ - pp1_ct_k(k) * r_bbp_tsq_k(k + 1) * ppp_tc_k(k + 1) &
+ - pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * ppp_qc_k(k + 1)
+
+k = tke_levels
+
+ppp_ct_k(k) = pp_ct_k(k)
+ppp_cq_k(k) = pp_cq_k(k)
+
+pp1_ct_k(k) = 0.0
+pp1_cq_k(k) = 0.0
+pp2_ct_k(k) = 0.0
+pp2_cq_k(k) = 0.0
+
+aap_cov_k(k) = aa_cov_k(k) &
+ - ppp_ct_k(k) * r_bbp_tsq_k(k) * pp1_tc_k(k) &
+ - ppp_cq_k(k) * r_bbp_qsq_k(k) * pp1_qc_k(k)
+r_bbp_cov_k(k) = 1.0 / ( &
+ bb_cov_k(k) &
+ - ppp_ct_k(k) * r_bbp_tsq_k(k) * ppp_tc_k(k) &
+ - ppp_cq_k(k) * r_bbp_qsq_k(k) * ppp_qc_k(k) &
+ - aap_cov_k(k) * r_bbp_cov_k(k - 1) * ccp_cov_k(k - 1))
+ccp_cov_k(k) = 0.0
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_simeq_ilud2_decmp
+END MODULE mym_simeq_ilud2_decmp_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90 b/science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90
new file mode 100644
index 0000000000..07b134ffdf
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90
@@ -0,0 +1,125 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To calculate products of a matrix and a vector
+! in solving the simultaneous equations.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_simeq_matrix_prod_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SIMEQ_MATRIX_PROD_MOD'
+CONTAINS
+
+SUBROUTINE mym_simeq_matrix_prod( &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ x_tsq_k, x_qsq_k, x_cov_k, &
+ y_tsq_k, y_qsq_k, y_cov_k)
+USE mym_option_mod, ONLY: tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ ! matrix elements (for meanings of each, see the document)
+ aa_tsq_k(tke_levels), &
+ bb_tsq_k(tke_levels), &
+ cc_tsq_k(tke_levels), &
+ pp_tc_k(tke_levels), &
+ aa_qsq_k(tke_levels), &
+ bb_qsq_k(tke_levels), &
+ cc_qsq_k(tke_levels), &
+ pp_qc_k(tke_levels), &
+ aa_cov_k(tke_levels), &
+ bb_cov_k(tke_levels), &
+ cc_cov_k(tke_levels), &
+ pp_ct_k(tke_levels), &
+ pp_cq_k(tke_levels), &
+ ! vector elements
+ x_tsq_k(tke_levels), &
+ x_qsq_k(tke_levels), &
+ x_cov_k(tke_levels)
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ ! vector elements of products (answers)
+ y_tsq_k(tke_levels), &
+ y_qsq_k(tke_levels), &
+ y_cov_k(tke_levels)
+
+INTEGER :: k
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SIMEQ_MATRIX_PROD'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+! y = A * x
+k = 1
+y_tsq_k(k) = bb_tsq_k(k) * x_tsq_k(k) &
+ + cc_tsq_k(k) * x_tsq_k(k + 1) &
+ + pp_tc_k(k) * x_cov_k(k)
+
+y_qsq_k(k) = bb_qsq_k(k) * x_qsq_k(k) &
+ + cc_qsq_k(k) * x_qsq_k(k + 1) &
+ + pp_qc_k(k) * x_cov_k(k)
+
+y_cov_k(k) = bb_cov_k(k) * x_cov_k(k) &
+ + cc_cov_k(k) * x_cov_k(k + 1) &
+ + pp_ct_k(k) * x_tsq_k(k) &
+ + pp_cq_k(k) * x_qsq_k(k)
+
+DO k = 2, tke_levels - 1
+ y_tsq_k(k) = aa_tsq_k(k) * x_tsq_k(k - 1) &
+ + bb_tsq_k(k) * x_tsq_k(k) &
+ + cc_tsq_k(k) * x_tsq_k(k + 1) &
+ + pp_tc_k(k) * x_cov_k(k)
+
+ y_qsq_k(k) = aa_qsq_k(k) * x_qsq_k(k - 1) &
+ + bb_qsq_k(k) * x_qsq_k(k) &
+ + cc_qsq_k(k) * x_qsq_k(k + 1) &
+ + pp_qc_k(k) * x_cov_k(k)
+
+ y_cov_k(k) = aa_cov_k(k) * x_cov_k(k - 1) &
+ + bb_cov_k(k) * x_cov_k(k) &
+ + cc_cov_k(k) * x_cov_k(k + 1) &
+ + pp_ct_k(k) * x_tsq_k(k) &
+ + pp_cq_k(k) * x_qsq_k(k)
+
+END DO
+
+k = tke_levels
+y_tsq_k(k) = aa_tsq_k(k) * x_tsq_k(k - 1) &
+ + bb_tsq_k(k) * x_tsq_k(k) &
+ + pp_tc_k(k) * x_cov_k(k)
+
+y_qsq_k(k) = aa_qsq_k(k) * x_qsq_k(k - 1) &
+ + bb_qsq_k(k) * x_qsq_k(k) &
+ + pp_qc_k(k) * x_cov_k(k)
+
+y_cov_k(k) = aa_cov_k(k) * x_cov_k(k - 1) &
+ + bb_cov_k(k) * x_cov_k(k) &
+ + pp_ct_k(k) * x_tsq_k(k) &
+ + pp_cq_k(k) * x_qsq_k(k)
+
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_simeq_matrix_prod
+END MODULE mym_simeq_matrix_prod_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
new file mode 100644
index 0000000000..d98f4b057c
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
@@ -0,0 +1,208 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+
+! Purpose: To solve simultaneous equations for tsq, qsq and cov
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_solve_simeq_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_MOD'
+CONTAINS
+
+SUBROUTINE mym_solve_simeq( &
+! IN levels
+ bl_levels, &
+! IN fields
+ qq_tsq, qq_qsq, qq_cov, aa_tsq, bb_tsq, cc_tsq, pp_tc, &
+ aa_qsq, bb_qsq, cc_qsq, pp_qc,aa_cov,bb_cov, cc_cov, pp_ct, pp_cq, &
+! OUT fields
+ tsq, qsq, cov)
+
+USE atm_fields_bounds_mod, ONLY: tdims
+USE mym_option_mod, ONLY: tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+USE mym_solve_simeq_bcgstab_mod, ONLY: mym_solve_simeq_bcgstab
+USE mym_solve_simeq_lud_mod, ONLY: mym_solve_simeq_lud
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" level
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ ! matrix elements (for meanings of each, see the document)
+ qq_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ qq_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ qq_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ aa_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ bb_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ cc_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_tc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ aa_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ bb_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ cc_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_qc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ aa_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ bb_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ cc_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_ct(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_cq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of liquid potential temperature
+ ! (thetal'**2) defined on theta levels K-1
+ qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of total water
+ ! (qw'**2) defined on theta levels K-1
+ cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels)
+ ! Correlation between thetal and qw
+ ! (thetal'qw') defined on theta levels K-1
+
+! Local variables
+INTEGER :: &
+ i, j, k, &
+ endflag
+
+REAL(KIND=real_umphys) :: &
+ ! one-dimensional variables to secure continuous memory accesses
+ qq_tsq_k(tke_levels), &
+ qq_qsq_k(tke_levels), &
+ qq_cov_k(tke_levels), &
+ aa_tsq_k(tke_levels), &
+ bb_tsq_k(tke_levels), &
+ cc_tsq_k(tke_levels), &
+ pp_tc_k(tke_levels), &
+ aa_qsq_k(tke_levels), &
+ bb_qsq_k(tke_levels), &
+ cc_qsq_k(tke_levels), &
+ pp_qc_k(tke_levels), &
+ aa_cov_k(tke_levels), &
+ bb_cov_k(tke_levels), &
+ cc_cov_k(tke_levels), &
+ pp_ct_k(tke_levels), &
+ pp_cq_k(tke_levels), &
+ tsq_k(tke_levels), &
+ qsq_k(tke_levels), &
+ cov_k(tke_levels)
+
+! Parameters
+INTEGER, PARAMETER :: &
+ max_itr = 500
+ ! the maximum iteration number
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ eps = 1.0e-15
+ ! convergence creteria
+
+REAL(KIND=real_umphys), PARAMETER :: &
+ tsq_scale = 1.0e0, &
+ qsq_scale = 1.0e6, &
+ cov_scale = 1.0e3, &
+ r_tsq_scale = 1.0 / tsq_scale, &
+ r_qsq_scale = 1.0 / qsq_scale, &
+ r_cov_scale = 1.0 / cov_scale, &
+ tc_scale = tsq_scale * r_cov_scale, &
+ qc_scale = qsq_scale * r_cov_scale, &
+ ct_scale = cov_scale * r_tsq_scale, &
+ cq_scale = cov_scale * r_qsq_scale
+ ! scaling factors for the matrix elements
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+
+ ! Copy to 1dim variables to secure continuous memory accesses
+ DO k = 1, tke_levels
+ qq_tsq_k(k) = qq_tsq(i, j, k) * tsq_scale
+ qq_qsq_k(k) = qq_qsq(i, j, k) * qsq_scale
+ qq_cov_k(k) = qq_cov(i, j, k) * cov_scale
+ aa_tsq_k(k) = aa_tsq(i, j, k)
+ bb_tsq_k(k) = bb_tsq(i, j, k)
+ cc_tsq_k(k) = cc_tsq(i, j, k)
+ pp_tc_k(k) = pp_tc(i, j, k) * tc_scale
+ aa_qsq_k(k) = aa_qsq(i, j, k)
+ bb_qsq_k(k) = bb_qsq(i, j, k)
+ cc_qsq_k(k) = cc_qsq(i, j, k)
+ pp_qc_k(k) = pp_qc(i, j, k) * qc_scale
+ aa_cov_k(k) = aa_cov(i, j, k)
+ bb_cov_k(k) = bb_cov(i, j, k)
+ cc_cov_k(k) = cc_cov(i, j, k)
+ pp_ct_k(k) = pp_ct(i, j, k) * ct_scale
+ pp_cq_k(k) = pp_cq(i, j, k) * cq_scale
+ END DO
+
+ CALL mym_solve_simeq_bcgstab( &
+ max_itr, eps, &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, &
+ pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k, endflag)
+
+ IF (endflag < 0) THEN
+ ! if failed to converge, solve eqs. by LU decomposition
+ CALL mym_solve_simeq_lud( &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k)
+ END IF
+
+ ! set the values into the original arrays.
+ DO k = 1, tke_levels
+ tsq(i, j, k) = tsq_k(k) * r_tsq_scale
+ qsq(i, j, k) = qsq_k(k) * r_qsq_scale
+ cov(i, j, k) = cov_k(k) * r_cov_scale
+ END DO
+
+ END DO !loop i = tdims%i_start, tdims%i_end
+END DO !loop j = tdims%j_start, tdims%j_end
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_solve_simeq
+END MODULE mym_solve_simeq_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90
new file mode 100644
index 0000000000..31c8daafe7
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90
@@ -0,0 +1,350 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To solve simultaneous equations by bi-conjugate gradient
+! stabilized method (BCGSTAB)
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_solve_simeq_bcgstab_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, &
+ PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_BCGSTAB_MOD'
+CONTAINS
+
+SUBROUTINE mym_solve_simeq_bcgstab( &
+ max_itr, eps, &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k, endflag)
+
+USE mym_option_mod, ONLY: tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+
+USE mym_simeq_ilud2_decmp_mod, ONLY: mym_simeq_ilud2_decmp
+USE mym_simeq_matrix_prod_mod, ONLY: mym_simeq_matrix_prod
+USE mym_solve_simeq_ilud2_mod, ONLY: mym_solve_simeq_ilud2
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ max_itr
+ ! the maximum number of iterations
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ eps
+ ! convergence condition
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ qq_tsq_k(tke_levels), &
+ qq_qsq_k(tke_levels), &
+ qq_cov_k(tke_levels), &
+ aa_tsq_k(tke_levels), &
+ bb_tsq_k(tke_levels), &
+ cc_tsq_k(tke_levels), &
+ pp_tc_k(tke_levels), &
+ aa_qsq_k(tke_levels), &
+ bb_qsq_k(tke_levels), &
+ cc_qsq_k(tke_levels), &
+ pp_qc_k(tke_levels), &
+ aa_cov_k(tke_levels), &
+ bb_cov_k(tke_levels), &
+ cc_cov_k(tke_levels), &
+ pp_ct_k(tke_levels), &
+ pp_cq_k(tke_levels)
+ ! matrix elements
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ tsq_k(tke_levels), &
+ qsq_k(tke_levels), &
+ cov_k(tke_levels)
+ ! solved tsq, qsq and cov
+
+INTEGER, INTENT(OUT) :: &
+ endflag
+ ! to indicate if converged
+ ! positive means proper solution is obtains.
+ ! 0: converged
+ ! 1: obtained an exact solution (residual = 0)
+ ! -1: max_itr iterations were done, but not converged
+ ! -2: solution in iterations becomes unexpectedly large,
+ ! so gave up
+
+! Local variables
+INTEGER :: &
+ k, m, &
+ ! loop indexes
+ nitr
+ ! a number of iterations
+
+REAL(KIND=real_umphys) :: &
+ norm, &
+ ! residual norm
+ r_qq_norm, &
+ ! reciprocal of the inirial residual norm
+ err, &
+ ! norm * r_qq_norm
+ bet, &
+ ! beta
+ alp_num, &
+ ! numerator of alpha
+ alp_den, &
+ ! denominator of alpha
+ alp, &
+ ! alpha
+ omg_num, &
+ ! numerator of omega
+ omg_den, &
+ ! denominator of omega
+ omg, &
+ ! omega
+ max_val
+ ! maximum value of solutions
+
+REAL(KIND=real_umphys) :: &
+ rvec_tsq(tke_levels), &
+ rvec_qsq(tke_levels), &
+ rvec_cov(tke_levels), &
+ r0vec_tsq(tke_levels), &
+ r0vec_qsq(tke_levels), &
+ r0vec_cov(tke_levels), &
+ pvec_tsq(tke_levels), &
+ pvec_qsq(tke_levels), &
+ pvec_cov(tke_levels), &
+ ppvec_tsq(tke_levels), &
+ ppvec_qsq(tke_levels), &
+ ppvec_cov(tke_levels), &
+ vvec_tsq(tke_levels), &
+ vvec_qsq(tke_levels), &
+ vvec_cov(tke_levels), &
+ svec_tsq(tke_levels), &
+ svec_qsq(tke_levels), &
+ svec_cov(tke_levels), &
+ ssvec_tsq(tke_levels), &
+ ssvec_qsq(tke_levels), &
+ ssvec_cov(tke_levels), &
+ tvec_tsq(tke_levels), &
+ tvec_qsq(tke_levels), &
+ tvec_cov(tke_levels), &
+ ! Vectors used in the BCG algorithm.
+ ! See the document
+ aap_tsq_k(tke_levels), &
+ r_bbp_tsq_k(tke_levels), &
+ ccp_tsq_k(tke_levels), &
+ aap_qsq_k(tke_levels), &
+ r_bbp_qsq_k(tke_levels), &
+ ccp_qsq_k(tke_levels), &
+ aap_cov_k(tke_levels), &
+ r_bbp_cov_k(tke_levels), &
+ ccp_cov_k(tke_levels), &
+ ppp_tc_k(tke_levels, 0:2), &
+ ppp_qc_k(tke_levels, 0:2), &
+ ppp_ct_k(tke_levels, 0:2), &
+ ppp_cq_k(tke_levels, 0:2)
+ ! elements of ILU(2)
+ ! the second dimension corresponds to the fill-in level
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ_BCGSTAB'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+CALL mym_simeq_ilud2_decmp( &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
+ ppp_tc_k(1, 0), ppp_tc_k(1, 1), ppp_tc_k(1, 2), &
+ aap_qsq_k, r_bbp_qsq_k, ccp_qsq_k, &
+ ppp_qc_k(1, 0), ppp_qc_k(1, 1), ppp_qc_k(1, 2), &
+ aap_cov_k, r_bbp_cov_k, ccp_cov_k, &
+ ppp_ct_k(1, 0), ppp_cq_k(1, 0), &
+ ppp_ct_k(1, 1), ppp_cq_k(1, 1), &
+ ppp_ct_k(1, 2), ppp_cq_k(1, 2))
+
+r_qq_norm = 0.0
+alp_num = 0.0
+DO k = 1, tke_levels
+ ! set the initial values
+ tsq_k(k) = 0.0
+ qsq_k(k) = 0.0
+ cov_k(k) = 0.0
+
+ ! rvec is a residual vector
+ rvec_tsq(k) = qq_tsq_k(k)
+ rvec_qsq(k) = qq_qsq_k(k)
+ rvec_cov(k) = qq_cov_k(k)
+
+ r0vec_tsq(k) = rvec_tsq(k)
+ r0vec_qsq(k) = rvec_qsq(k)
+ r0vec_cov(k) = rvec_cov(k)
+
+ pvec_tsq(k) = rvec_tsq(k)
+ pvec_qsq(k) = rvec_qsq(k)
+ pvec_cov(k) = rvec_cov(k)
+
+ alp_num = alp_num + r0vec_tsq(k) * rvec_tsq(k) &
+ + r0vec_qsq(k) * rvec_qsq(k) &
+ + r0vec_cov(k) * rvec_cov(k)
+
+ r_qq_norm = r_qq_norm + qq_tsq_k(k) * qq_tsq_k(k) &
+ + qq_qsq_k(k) * qq_qsq_k(k) &
+ + qq_cov_k(k) * qq_cov_k(k)
+
+END DO
+
+IF (r_qq_norm == 0.0) THEN
+ r_qq_norm = 0.0
+ endflag = 2
+ nitr = 0
+ELSE
+ r_qq_norm = 1.0 / r_qq_norm
+ endflag = -1
+ nitr = max_itr
+END IF
+
+outer_m_loop: DO m = 1, nitr
+ CALL mym_solve_simeq_ilud2( &
+ 0, &
+ pvec_tsq, pvec_qsq, pvec_cov, &
+ aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
+ ppp_tc_k(1, 0), ppp_tc_k(1, 1), ppp_tc_k(1, 2), &
+ aap_qsq_k, r_bbp_qsq_k, ccp_qsq_k, &
+ ppp_qc_k(1, 0), ppp_qc_k(1, 1), ppp_qc_k(1, 2), &
+ aap_cov_k, r_bbp_cov_k, ccp_cov_k, &
+ ppp_ct_k(1, 0), ppp_cq_k(1, 0), &
+ ppp_ct_k(1, 1), ppp_cq_k(1, 1), &
+ ppp_ct_k(1, 2), ppp_cq_k(1, 2), &
+ ppvec_tsq, ppvec_qsq, ppvec_cov)
+
+ ! v = A pp
+ CALL mym_simeq_matrix_prod( &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ ppvec_tsq, ppvec_qsq, ppvec_cov, &
+ vvec_tsq, vvec_qsq, vvec_cov)
+
+ alp_den = 0.0
+ DO k = 1, tke_levels
+ alp_den = alp_den + r0vec_tsq(k) * vvec_tsq(k) &
+ + r0vec_qsq(k) * vvec_qsq(k) &
+ + r0vec_cov(k) * vvec_cov(k)
+ END DO
+
+ IF (alp_den == 0.0) THEN
+ endflag = 1
+ ELSE
+ alp = alp_num / alp_den
+
+ DO k = 1, tke_levels
+ svec_tsq(k) = rvec_tsq(k) - alp * vvec_tsq(k)
+ svec_qsq(k) = rvec_qsq(k) - alp * vvec_qsq(k)
+ svec_cov(k) = rvec_cov(k) - alp * vvec_cov(k)
+ END DO
+
+ CALL mym_solve_simeq_ilud2( &
+ 0, &
+ svec_tsq, svec_qsq, svec_cov, &
+ aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
+ ppp_tc_k(1, 0), ppp_tc_k(1, 1), ppp_tc_k(1, 2), &
+ aap_qsq_k, r_bbp_qsq_k, ccp_qsq_k, &
+ ppp_qc_k(1, 0), ppp_qc_k(1, 1), ppp_qc_k(1, 2), &
+ aap_cov_k, r_bbp_cov_k, ccp_cov_k, &
+ ppp_ct_k(1, 0), ppp_cq_k(1, 0), &
+ ppp_ct_k(1, 1), ppp_cq_k(1, 1), &
+ ppp_ct_k(1, 2), ppp_cq_k(1, 2), &
+ ssvec_tsq, ssvec_qsq, ssvec_cov)
+
+ ! t = A ss
+ CALL mym_simeq_matrix_prod( &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ ssvec_tsq, ssvec_qsq, ssvec_cov, &
+ tvec_tsq, tvec_qsq, tvec_cov)
+
+ omg_num = 0.0
+ omg_den = 0.0
+ DO k = 1, tke_levels
+ omg_num = omg_num + tvec_tsq(k) * svec_tsq(k) &
+ + tvec_qsq(k) * svec_qsq(k) &
+ + tvec_cov(k) * svec_cov(k)
+ omg_den = omg_den + tvec_tsq(k) * tvec_tsq(k) &
+ + tvec_qsq(k) * tvec_qsq(k) &
+ + tvec_cov(k) * tvec_cov(k)
+ END DO
+
+ omg = omg_num / omg_den
+
+ alp_den = alp_num
+
+ alp_num = 0.0
+ norm = 0.0
+ max_val = 0.0
+ DO k = 1, tke_levels
+ tsq_k(k) = tsq_k(k) + alp * ppvec_tsq(k) + omg * ssvec_tsq(k)
+ qsq_k(k) = qsq_k(k) + alp * ppvec_qsq(k) + omg * ssvec_qsq(k)
+ cov_k(k) = cov_k(k) + alp * ppvec_cov(k) + omg * ssvec_cov(k)
+ rvec_tsq(k) = svec_tsq(k) - omg * tvec_tsq(k)
+ rvec_qsq(k) = svec_qsq(k) - omg * tvec_qsq(k)
+ rvec_cov(k) = svec_cov(k) - omg * tvec_cov(k)
+
+ alp_num = alp_num + r0vec_tsq(k) * rvec_tsq(k) &
+ + r0vec_qsq(k) * rvec_qsq(k) &
+ + r0vec_cov(k) * rvec_cov(k)
+ norm = norm + rvec_tsq(k) * rvec_tsq(k) &
+ + rvec_qsq(k) * rvec_qsq(k) &
+ + rvec_cov(k) * rvec_cov(k)
+
+ max_val = MAX(max_val, ABS(tsq_k(k)), &
+ ABS(qsq_k(k)), &
+ ABS(cov_k(k)))
+ END DO
+ err = SQRT(norm * r_qq_norm)
+
+ IF (err >= eps .AND. m < 30 .AND. max_val < 1.0e10) THEN
+ ! continue to the next step
+ ELSE IF (max_val > 100.0) THEN
+ ! Unexpectedly huge
+ endflag = -2
+ ELSE IF (err < eps) THEN
+ ! Converged
+ endflag = 0
+ END IF
+ END IF
+ IF (endflag /= -1) THEN
+ EXIT outer_m_loop
+ ELSE
+ bet = alp_num * alp / (alp_den * omg)
+ DO k = 1, tke_levels
+ pvec_tsq(k) = rvec_tsq(k) &
+ + bet * (pvec_tsq(k) - omg * vvec_tsq(k))
+ pvec_qsq(k) = rvec_qsq(k) &
+ + bet * (pvec_qsq(k) - omg * vvec_qsq(k))
+ pvec_cov(k) = rvec_cov(k) &
+ + bet * (pvec_cov(k) - omg * vvec_cov(k))
+ END DO
+ END IF
+END DO outer_m_loop ! loop m = 1, max_itr
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_solve_simeq_bcgstab
+END MODULE mym_solve_simeq_bcgstab_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90
new file mode 100644
index 0000000000..b109701d36
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90
@@ -0,0 +1,289 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To solve simultaneous equations of which the coefficient
+! matrix is obtained by imcompelete LU decomposition
+! with fill-in level 2 (ILU(2)) for the original coefficient
+! matrix.
+! ILU(2) decomposition is assumed to have been already done
+! in mym_simeq_ilud2_dcmp.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_solve_simeq_ilud2_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_ILUD2_MOD'
+CONTAINS
+
+SUBROUTINE mym_solve_simeq_ilud2( &
+ imode, &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
+ ppp_tc_k, pp1_tc_k, pp2_tc_k, &
+ aap_qsq_k, r_bbp_qsq_k, ccp_qsq_k, &
+ ppp_qc_k, pp1_qc_k, pp2_qc_k, &
+ aap_cov_k, r_bbp_cov_k, ccp_cov_k, &
+ ppp_ct_k, ppp_cq_k, pp1_ct_k, pp1_cq_k, pp2_ct_k, pp2_cq_k, &
+ tsq_k, qsq_k, cov_k)
+
+USE mym_option_mod, ONLY: tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+! intent in variables
+INTEGER, INTENT(IN) :: imode
+ ! mode switch for the Matrix
+ ! 0: normal, 1: transposed
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ qq_tsq_k(tke_levels), &
+ qq_qsq_k(tke_levels), &
+ qq_cov_k(tke_levels), &
+ aap_tsq_k(tke_levels), &
+ r_bbp_tsq_k(tke_levels), &
+ ccp_tsq_k(tke_levels), &
+ ppp_tc_k(tke_levels), &
+ pp1_tc_k(tke_levels), &
+ pp2_tc_k(tke_levels), &
+ aap_qsq_k(tke_levels), &
+ r_bbp_qsq_k(tke_levels), &
+ ccp_qsq_k(tke_levels), &
+ ppp_qc_k(tke_levels), &
+ pp1_qc_k(tke_levels), &
+ pp2_qc_k(tke_levels), &
+ aap_cov_k(tke_levels), &
+ r_bbp_cov_k(tke_levels), &
+ ccp_cov_k(tke_levels), &
+ ppp_ct_k(tke_levels), &
+ ppp_cq_k(tke_levels), &
+ pp1_ct_k(tke_levels), &
+ pp1_cq_k(tke_levels), &
+ pp2_ct_k(tke_levels), &
+ pp2_cq_k(tke_levels)
+ ! matrix elements of ILU decomposed matrix
+ ! See the document for details
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ tsq_k(tke_levels), &
+ qsq_k(tke_levels), &
+ cov_k(tke_levels)
+ ! solution vectors
+
+INTEGER :: k
+ ! loop indexes
+
+INTEGER, PARAMETER :: &
+ normal = 0, &
+ transposed = 1
+ ! symbols for the mode
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ_ILUD2'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+tsq_k(1) = qq_tsq_k(1) * r_bbp_tsq_k(1)
+qsq_k(1) = qq_qsq_k(1) * r_bbp_qsq_k(1)
+
+IF (imode == normal) THEN
+ DO k = 2, tke_levels
+ tsq_k(k) = (qq_tsq_k(k) - aap_tsq_k(k) * tsq_k(k - 1)) &
+ * r_bbp_tsq_k(k)
+ qsq_k(k) = (qq_qsq_k(k) - aap_qsq_k(k) * qsq_k(k - 1)) &
+ * r_bbp_qsq_k(k)
+ END DO
+
+ k = 1
+ cov_k(k) = (qq_cov_k(k) - ppp_ct_k(k) * tsq_k(k) &
+ - pp1_ct_k(k) * tsq_k(k + 1) &
+ - pp2_ct_k(k) * tsq_k(k + 2) &
+ - ppp_cq_k(k) * qsq_k(k) &
+ - pp1_cq_k(k) * qsq_k(k + 1) &
+ - pp2_cq_k(k) * qsq_k(k + 2)) &
+ * r_bbp_cov_k(k)
+
+ DO k = 2, tke_levels - 2
+ cov_k(k) = (qq_cov_k(k) - ppp_ct_k(k) * tsq_k(k) &
+ - pp1_ct_k(k) * tsq_k(k + 1) &
+ - pp2_ct_k(k) * tsq_k(k + 2) &
+ - ppp_cq_k(k) * qsq_k(k) &
+ - pp1_cq_k(k) * qsq_k(k + 1) &
+ - pp2_cq_k(k) * qsq_k(k + 2) &
+ - aap_cov_k(k) * cov_k(k - 1)) &
+ * r_bbp_cov_k(k)
+ END DO
+
+ k = tke_levels - 1
+ cov_k(k) = (qq_cov_k(k) - ppp_ct_k(k) * tsq_k(k) &
+ - pp1_ct_k(k) * tsq_k(k + 1) &
+ - ppp_cq_k(k) * qsq_k(k) &
+ - pp1_cq_k(k) * qsq_k(k + 1) &
+ - aap_cov_k(k) * cov_k(k - 1)) &
+ * r_bbp_cov_k(k)
+
+
+ k = tke_levels
+ cov_k(k) = (qq_cov_k(k) - ppp_ct_k(k) * tsq_k(k) &
+ - ppp_cq_k(k) * qsq_k(k) &
+ - aap_cov_k(k) * cov_k(k - 1)) &
+ * r_bbp_cov_k(k)
+
+
+ DO k = tke_levels - 1, 1, -1
+ cov_k(k) = cov_k(k) &
+ - ccp_cov_k(k) * cov_k(k + 1) * r_bbp_cov_k(k)
+ END DO
+
+ k = tke_levels
+ qsq_k(k) = qsq_k(k) - (ppp_qc_k(k) * cov_k(k) &
+ + pp1_qc_k(k) * cov_k(k - 1) &
+ + pp2_qc_k(k) * cov_k(k - 2)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) - (ppp_tc_k(k) * cov_k(k) &
+ + pp1_tc_k(k) * cov_k(k - 1) &
+ + pp2_tc_k(k) * cov_k(k - 2)) &
+ * r_bbp_tsq_k(k)
+
+ DO k = tke_levels - 1, 3, -1
+ qsq_k(k) = qsq_k(k) &
+ - (ppp_qc_k(k) * cov_k(k) + ccp_qsq_k(k) * qsq_k(k + 1) &
+ + pp1_qc_k(k) * cov_k(k - 1) &
+ + pp2_qc_k(k) * cov_k(k - 2)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) &
+ - (ppp_tc_k(k) * cov_k(k) + ccp_tsq_k(k) * tsq_k(k + 1) &
+ + pp1_tc_k(k) * cov_k(k - 1) &
+ + pp2_tc_k(k) * cov_k(k - 2)) &
+ * r_bbp_tsq_k(k)
+ END DO
+
+ k = 2
+ qsq_k(k) = qsq_k(k) &
+ - (ppp_qc_k(k) * cov_k(k) + ccp_qsq_k(k) * qsq_k(k + 1) &
+ + pp1_qc_k(k) * cov_k(k - 1)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) &
+ - (ppp_tc_k(k) * cov_k(k) + ccp_tsq_k(k) * tsq_k(k + 1) &
+ + pp1_tc_k(k) * cov_k(k - 1)) &
+ * r_bbp_tsq_k(k)
+
+
+ k = 1
+ qsq_k(k) = qsq_k(k) &
+ - (ppp_qc_k(k) * cov_k(k) + ccp_qsq_k(k) * qsq_k(k + 1)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) &
+ - (ppp_tc_k(k) * cov_k(k) + ccp_tsq_k(k) * tsq_k(k + 1)) &
+ * r_bbp_tsq_k(k)
+
+ELSE IF (imode == transposed) THEN
+ DO k = 2, tke_levels
+ tsq_k(k) = (qq_tsq_k(k) &
+ - ccp_tsq_k(k - 1) * tsq_k(k - 1)) * r_bbp_tsq_k(k)
+ qsq_k(k) = (qq_qsq_k(k) &
+ - ccp_qsq_k(k - 1) * qsq_k(k - 1)) * r_bbp_qsq_k(k)
+ END DO
+
+ k = 1
+ cov_k(k) = (qq_cov_k(k) - ppp_tc_k(k) * tsq_k(k) &
+ - pp1_tc_k(k + 1) * tsq_k(k + 1) &
+ - pp2_tc_k(k + 2) * tsq_k(k + 2) &
+ - ppp_qc_k(k) * qsq_k(k) &
+ - pp1_qc_k(k + 1) * qsq_k(k + 1) &
+ - pp2_qc_k(k + 2) * qsq_k(k + 2)) &
+ * r_bbp_cov_k(k)
+
+ DO k = 2, tke_levels - 2
+ cov_k(k) = (qq_cov_k(k) - ppp_tc_k(k) * tsq_k(k) &
+ - pp1_tc_k(k + 1) * tsq_k(k + 1) &
+ - pp2_tc_k(k + 2) * tsq_k(k + 2) &
+ - ppp_qc_k(k) * qsq_k(k) &
+ - pp1_qc_k(k + 1) * qsq_k(k + 1) &
+ - pp2_qc_k(k + 2) * qsq_k(k + 2) &
+ - ccp_cov_k(k - 1) * cov_k(k - 1)) &
+ * r_bbp_cov_k(k)
+ END DO
+
+ k = tke_levels - 1
+ cov_k(k) = (qq_cov_k(k) - ppp_tc_k(k) * tsq_k(k) &
+ - pp1_tc_k(k + 1) * tsq_k(k + 1) &
+ - ppp_qc_k(k) * qsq_k(k) &
+ - pp1_qc_k(k + 1) * qsq_k(k + 1) &
+ - ccp_cov_k(k - 1) * cov_k(k - 1)) &
+ * r_bbp_cov_k(k)
+
+
+ k = tke_levels
+ cov_k(k) = (qq_cov_k(k) - ppp_tc_k(k) * tsq_k(k) &
+ - ppp_qc_k(k) * qsq_k(k) &
+ - ccp_cov_k(k - 1) * cov_k(k - 1)) &
+ * r_bbp_cov_k(k)
+
+ DO k = tke_levels - 1, 1, -1
+ cov_k(k) = cov_k(k) &
+ - aap_cov_k(k + 1) * cov_k(k + 1) * r_bbp_cov_k(k)
+ END DO
+
+ k = tke_levels
+ qsq_k(k) = qsq_k(k) - (ppp_cq_k(k) * cov_k(k) &
+ + pp1_cq_k(k - 1) * cov_k(k - 1) &
+ + pp2_cq_k(k - 2) * cov_k(k - 2)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) - (ppp_ct_k(k) * cov_k(k) &
+ + pp1_ct_k(k - 1) * cov_k(k - 1) &
+ + pp2_ct_k(k - 2) * cov_k(k - 2)) &
+ * r_bbp_tsq_k(k)
+
+ DO k = tke_levels - 1, 3, -1
+ qsq_k(k) = qsq_k(k) &
+ - (ppp_cq_k(k) * cov_k(k) + aap_qsq_k(k + 1) * qsq_k(k + 1) &
+ + pp1_cq_k(k - 1) * cov_k(k - 1) &
+ + pp2_cq_k(k - 2) * cov_k(k - 2)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) &
+ - (ppp_ct_k(k) * cov_k(k) + aap_tsq_k(k + 1) * tsq_k(k + 1) &
+ + pp1_ct_k(k - 1) * cov_k(k - 1) &
+ + pp2_ct_k(k - 2) * cov_k(k - 2)) &
+ * r_bbp_tsq_k(k)
+ END DO
+
+ k = 2
+ qsq_k(k) = qsq_k(k) &
+ - (ppp_cq_k(k) * cov_k(k) + aap_qsq_k(k + 1) * qsq_k(k + 1) &
+ + pp1_cq_k(k - 1) * cov_k(k - 1)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) &
+ - (ppp_ct_k(k) * cov_k(k) + aap_tsq_k(k + 1) * tsq_k(k + 1) &
+ + pp1_ct_k(k - 1) * cov_k(k - 1)) &
+ * r_bbp_tsq_k(k)
+
+ k = 1
+ qsq_k(k) = qsq_k(k) &
+ - (ppp_cq_k(k) * cov_k(k) + aap_qsq_k(k + 1) * qsq_k(k + 1)) &
+ * r_bbp_qsq_k(k)
+ tsq_k(k) = tsq_k(k) &
+ - (ppp_ct_k(k) * cov_k(k) + aap_tsq_k(k + 1) * tsq_k(k + 1)) &
+ * r_bbp_tsq_k(k)
+
+END IF
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_solve_simeq_ilud2
+END MODULE mym_solve_simeq_ilud2_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90
new file mode 100644
index 0000000000..50c405c148
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90
@@ -0,0 +1,177 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To solve simultaneous equations by LU decomposition
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_solve_simeq_lud_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_LUD_MOD'
+CONTAINS
+
+SUBROUTINE mym_solve_simeq_lud( &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k)
+
+USE mym_option_mod, ONLY: tke_levels
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+IMPLICIT NONE
+
+! intent in variables
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ qq_tsq_k(tke_levels), &
+ qq_qsq_k(tke_levels), &
+ qq_cov_k(tke_levels), &
+ aa_tsq_k(tke_levels), &
+ bb_tsq_k(tke_levels), &
+ cc_tsq_k(tke_levels), &
+ pp_tc_k(tke_levels), &
+ aa_qsq_k(tke_levels), &
+ bb_qsq_k(tke_levels), &
+ cc_qsq_k(tke_levels), &
+ pp_qc_k(tke_levels), &
+ aa_cov_k(tke_levels), &
+ bb_cov_k(tke_levels), &
+ cc_cov_k(tke_levels), &
+ pp_ct_k(tke_levels), &
+ pp_cq_k(tke_levels)
+ ! matrix elements
+
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ tsq_k(tke_levels), &
+ qsq_k(tke_levels), &
+ cov_k(tke_levels)
+ ! solved tsq, qsq and cov
+
+INTEGER :: &
+ k, l, m, n, &
+ ! loop indexes
+ kpiv
+ ! index of a pivot
+
+REAL(KIND=real_umphys) :: &
+ wk
+ ! work variables
+
+REAL(KIND=real_umphys) :: &
+ amat(3 * tke_levels, 3 * tke_levels), &
+ ! coefficient matrix
+ bvec(3 * tke_levels)
+ ! vector in the right hand side
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ_LUD'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+amat(:, :) = 0.0
+
+DO k = 1, tke_levels
+ amat(k, k) = bb_tsq_k(k)
+ amat(tke_levels + k, tke_levels + k) = bb_qsq_k(k)
+ amat(2 * tke_levels + k, 2 * tke_levels + k) &
+ = bb_cov_k(k)
+ bvec(k) = qq_tsq_k(k)
+ bvec(tke_levels + k) = qq_qsq_k(k)
+ bvec(2 * tke_levels + k) = qq_cov_k(k)
+END DO
+
+DO k = 2, tke_levels
+ amat(k, k-1) = aa_tsq_k(k)
+ amat(tke_levels + k, tke_levels + k - 1) = aa_qsq_k(k)
+ amat(2 * tke_levels + k, 2 * tke_levels + k - 1) &
+ = aa_cov_k(k)
+END DO
+
+DO k = 1, tke_levels - 1
+ amat(k, k+1) = cc_tsq_k(k)
+ amat(tke_levels + k, tke_levels + k + 1) = cc_qsq_k(k)
+ amat(2 * tke_levels + k, 2 * tke_levels + k + 1) &
+ = cc_cov_k(k)
+END DO
+
+DO k = 1, tke_levels
+ amat(k, 2 * tke_levels + k) = pp_tc_k(k)
+ amat(tke_levels + k, 2 * tke_levels + k) = pp_qc_k(k)
+ amat(2 * tke_levels + k, k) = pp_ct_k(k)
+ amat(2 * tke_levels + k, tke_levels + k) = pp_cq_k(k)
+END DO
+
+n = 3 * tke_levels
+! main part
+DO k = 1, n
+ kpiv = k
+ wk = ABS(amat(k, k))
+ DO l = k + 1, n
+ IF (ABS(amat(l, k)) > wk) THEN
+ kpiv = l
+ wk = ABS(amat(l, k))
+ END IF
+ END DO
+
+ IF (kpiv /= k) THEN
+ DO m = 1, n
+ wk = amat(k, m)
+ amat(k, m) = amat(kpiv, m)
+ amat(kpiv, m) = wk
+ END DO
+ wk = bvec(k)
+ bvec(k) = bvec(kpiv)
+ bvec(kpiv) = wk
+ END IF
+
+ amat(k, k) = 1.0 / amat(k, k)
+
+ DO l = k + 1, n
+ amat(l, k) = amat(l, k) * amat(k, k)
+ END DO
+
+ DO m = k + 1, n
+ DO l = k+1, n
+ amat(l, m) = amat(l, m) - amat(k, m) * amat(l, k)
+ END DO
+ END DO
+END DO ! loop k = 1, n
+
+DO m = 1, n - 1
+ DO l = m + 1, n
+ bvec(l) = bvec(l) - bvec(m) * amat(l, m)
+ END DO
+END DO
+
+DO m = n, 1, -1
+ bvec(m) = bvec(m) * amat(m, m)
+ DO l = 1, m - 1
+ bvec(l) = bvec(l) - amat(l, m) * bvec(m)
+ END DO
+END DO
+
+DO k = 1, tke_levels
+ tsq_k(k) = bvec(k)
+ qsq_k(k) = bvec(tke_levels + k)
+ cov_k(k) = bvec(2 * tke_levels + k)
+END DO
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_solve_simeq_lud
+END MODULE mym_solve_simeq_lud_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_turbulence.F90 b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
new file mode 100644
index 0000000000..5a283e6e50
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
@@ -0,0 +1,1377 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To calculate the diffusion coefficients and counter
+! gradient term for momentum, heat and moisture, and
+! integrate the prognostic variables appearing
+! in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! This code is based on the code provided by the authors who wrote
+! the following papers.
+! * Nakanishi, M. and H. Niino, 2009: Development of an improved
+! turbulence closure model for the atmospheric boundary layer.
+! J. Meteor. Soc. Japan, 87, 895-912.
+! * Nakanishi, M. and H. Niino, 2006: An improved Mellor-Yamada
+! Level-3 model: Its numerical stability and application to
+! a regional prediction of advection fog.
+! Boundary-Layer Meteor., 119, 397-407.
+! * Nakanishi, M. and H. Niino, 2004: An improved Mellor-Yamada
+! Level-3 model with condensation physics: Its design and
+! verification.
+! Boundary-Layer Meteor., 112, 1-31.
+! * Nakanishi, M., 2001: Improvement of the Mellor-Yamada
+! turbulence closure model based on large-eddy simulation data.
+! Boundary-Layer Meteor., 99, 349-378.
+! The web site publicising their code:
+! http://www.nda.ac.jp/~naka/MYNN/index.html
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_turbulence_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_TURBULENCE_MOD'
+CONTAINS
+
+SUBROUTINE mym_turbulence( &
+! IN levels/switches
+ bl_levels, levflag, nSCMDpkgs,L_SCMDiags, BL_diag, &
+! IN fields
+ z_uv, z_tq, &
+ vq, vt, gtr, fqw, ftl, wb_ng, &
+ dbdz, dtldz, dqwdz, dvdzm, dudz, dvdz, &
+ r_mosurf, u_s, fb_surf, pmz, phh, &
+! INOUT fields
+ qke, tsq, qsq, cov, dfm, dfh, &
+! OUT fields
+ dfu_cg, dfv_cg, dft_cg, dfq_cg)
+
+USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, tdims_s, &
+ ScmRowLen, ScmRow
+USE bl_diags_mod, ONLY: strnewbldiag
+USE conversions_mod, ONLY: pi
+USE mym_const_mod, ONLY: e1c,e2c,e3c,e4c,e5c,a1,a2,c1,b2,qke_max, &
+ coef_trbvar_diff,coef_trbvar_diff_tke,two_thirds,a1_2, &
+ b1,one_third,cc3
+USE mym_option_mod, ONLY: &
+ my_lowest_pd_surf, l_my_extra_level, my_z_extra_fact, &
+ l_my_prod_adj, my_prod_adj_fact, tke_levels, &
+ l_my_lowest_pd_surf_tqc
+
+USE model_domain_mod, ONLY: model_type, mt_single_column
+USE s_scmop_mod, ONLY: default_streams, &
+ t_avg, d_bl, scmdiag_bl
+USE scmoutput_mod, ONLY: scmoutput
+
+USE parkind1, ONLY: jprb, jpim
+USE planet_constants_mod, ONLY: vkman
+USE yomhook, ONLY: lhook, dr_hook
+
+USE mym_length_mod, ONLY: mym_length
+USE mym_level2_mod, ONLY: mym_level2
+USE mym_update_covariance_mod, ONLY: mym_update_covariance
+USE mym_update_fields_mod, ONLY: mym_update_fields
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels, &
+ ! Max. no. of "boundary" levels
+ levflag
+ ! to indicate the level of the MY model
+ ! 2: level 2.5
+ ! 3: level 3
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Z_TQ(*,K) is height of theta level k.
+ vq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! A buoyancy param on theta level k-1
+ vt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! A buoyancy param on theta level k-1
+ gtr(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! g/thetav on theta level k-1
+ fqw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! Moisture flux between layers
+ ! (kg per square metre per sec).
+ ! FQW(,1) is total water flux
+ ! from surface, 'E'.
+ ! Defined on rho levels.
+ ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
+ ! FTL(,K) contains net turbulent
+ ! sensible heat flux into layer K
+ ! from below; so FTL(,1) is the
+ ! surface sensible heat, H. (W/m2)
+ ! Defined on rho levels.
+ wb_ng(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! buoyancy flux related to the skewness
+ ! on theta K-1 levels
+ dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:tke_levels), &
+ ! Buoyancy gradient across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dtldz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of TL across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dqwdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! gradient of QW across layer
+ ! interface interpolated to theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Modulus of wind shear at theta levels.
+ ! (:,:,K) repserents the value on theta level K-1
+ dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Gradient of u at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+ dvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! Gradient of v at theta levels.
+ !(:,:,K) repserents the value on theta level K-1
+ r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! reciprocal of Monin-Obukhov length
+ u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface friction velocity
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! Surface buoyancy flux
+ pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! gradient function for momentum at surface
+ phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! gradient function for scalars at surface
+
+! Additional variables for SCM diagnostics which are dummy in full UM
+INTEGER, INTENT(IN) :: &
+ nSCMDpkgs ! No of SCM diagnostics packages
+
+LOGICAL, INTENT(IN) :: &
+ L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
+
+! Intent INOUT Variables
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ qke(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
+ bl_levels), &
+ ! twice of TKE (denoted to q**2) on theta level K-1
+ tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of liquid potential temperature
+ ! (thetal'**2) defined on theta levels K-1
+ qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of total water
+ ! (qw'**2) defined on theta levels K-1
+ cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Correlation between thetal and qw
+ ! (thetal'qw') defined on theta levels K-1
+ dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ bl_levels), &
+ ! diffusion coefficient for momentum
+ ! on theta level K-1
+ dfh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels)
+ ! diffusion coefficient for scalars
+ ! on theta level K-1
+
+! Declaration of BL diagnostics.
+TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+
+! Intent OUT Variables
+REAL(KIND=real_umphys), INTENT(OUT) :: &
+ dfu_cg(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ 2:bl_levels), &
+ ! counter gradient term for u
+ ! on theta level K-1
+ dfv_cg(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ 2:bl_levels), &
+ ! counter gradient term for v
+ ! on theta level K-1
+ dft_cg(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels), &
+ ! counter gradient term for TL
+ ! on theta level K-1
+ dfq_cg(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ 2:bl_levels)
+ ! counter gradient term for QW
+ ! on theta level K-1
+
+! Local variables
+! Scalar
+INTEGER :: &
+ i, j, k, k_start, k_start_cor, iScm, jScm
+ ! Loop indexes
+
+REAL(KIND=real_umphys) :: &
+ e1, &
+ ! a variable denoted to E1 in the papers
+ e3, &
+ ! a variable denoted to E3 in the papers
+ e4, &
+ ! a variable denoted to E4 in the paper
+ q2sq, &
+ ! qke derived by level 2 scheme
+ t2sq, &
+ ! tsq derived by level 2 scheme
+ r2sq, &
+ ! qsq derived by level 2 scheme
+ t3sq, &
+ ! tsq derived by level 2.5 or 3 scheme
+ r3sq, &
+ ! qsq derived by level 2.5 or 3 scheme
+ c3sq, &
+ ! cov deribed by level 2.5 or 3 scheme
+ wden, &
+ ! work variable
+ eden, &
+ ! work variable
+ reden, &
+ ! reciprocal of eden
+ e6c, &
+ ! work variable
+ coef, &
+ ! work variable
+ elq, &
+ ! mixing length times qkw appeared
+ ! in the production term of qke
+ elh, &
+ ! mixing length times qkw appeared
+ ! in the production terms of tsq, qsq and cov.
+ phm, &
+ ! work variable
+ disp_coef, &
+ b1l, &
+ ! B1 (closure constant) times mixing length
+ b2l, &
+ ! work variable
+ clow, &
+ ! lower limit for difference between cov in level 3
+ ! and level 2
+ cupp
+ ! upper limit for difference between cov in level 3
+ ! and level 2
+
+REAL(KIND=real_umphys) :: &
+ gm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! square of wind shear on theta level K-1
+ ! (a denominator of gradient Richardson number)
+ gh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! - buoyancy gradient on theta level K-1
+ ! (a numerator of gradient Richardson number)
+ sm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Non-dimensional diffusion coefficients for
+ ! momentum derived by level 2 scheme
+ ! defined on theta level K-1
+ sh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! Non-dimensional diffusion coefficients for
+ ! scalars derived by level 2 scheme
+ ! define on theta level K-1
+ qkw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! q=sqrt(qke) on theta level K-1
+ elsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! square of mixing length
+ gmel(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! GM times the mixing length
+ ghel(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! GH times the mixing length
+ qdiv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! factor for flux correction: sqrt(q3sq/q2sq)
+ gamv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! counter gradient correction for production of qke
+ gamv_coef(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficient of (c3sq-c2sq) in gamv
+ gamt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! counter gradient term for flux of TL
+ ! gamt = gamt_tsq * tsq + gamt_cov * cov + gamt_res
+ gamt_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to tsq in gamt
+ gamt_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in gamt
+ gamt_res(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a residual part in gamt
+ gamt_factor(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! stability factor for gamt
+ gamq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! counter gradient term for flux of QW
+ ! gamq = gamq_qsq * qsq + gamq_cov * cov + gamq_res
+ gamq_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to qsq in gamq
+ gamq_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in gamq
+ gamq_res(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a residual part in gamq
+ gamq_factor(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! stability factor for gamq
+ pdc_factor(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! stability factor for pdc
+ smd(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! counter gradient correction for SM
+ smd_coef(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! coefficient of (c3sq-c2sq) in smd
+ e2(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a variable denoted to E2 in the papers
+ cu(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! / qke in level 3
+ cv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! / qke in level 3
+ cu25(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! / qke in level 2.5
+ cv25(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! / qke in level 2.5
+ cw25(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! / qke = 1 - - in level 2.5
+ pdk(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term of qke
+ pdt_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to tsq in a production term of tsq
+ pdt_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in a production term of tsq
+ pdt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term of tsq excluding a linear part
+ ! of tsq and cov
+ ! (Note that it is the production term itself
+ ! in level 2.5)
+ pdq_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to qsq in a production term of qsq
+ pdq_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in a production term of qsq
+ pdq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term of qsq excluding a linear part
+ ! of qsq and cov
+ ! (Note that it is the production term itself
+ ! in level 2.5)
+ pdc_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to tsq in a production term of cov
+ pdc_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to qsq in a production term of cov
+ pdc_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in a production term of cov
+ pdc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term of cov excluding a linear part
+ ! of cov, tsq and qsq
+ ! (Note that it is the production term itself
+ ! in level 2.5)
+ bp(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! coefficients of qke in the dissipation term
+ rp(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! production term of qke
+ el(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! mixing length
+ q3sq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! qke derived by level 2.5 or level 3
+ c2sq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! cov derived by level 2
+
+REAL(KIND=real_umphys), ALLOCATABLE :: &
+ ! These variables are required only when imp_mode /= FULL_IMPL
+ ! So usually they are not used.
+ ! (That is why they have an "allocatable" attribute.)
+ bp_tsq(:, :, :), &
+ ! coefficients of tsq in the dissipation term
+ rp_tsq(:, :, :), &
+ ! production term of tsq
+ bp_qsq(:, :, :), &
+ ! coefficients of qsq in the dissipation term
+ rp_qsq(:, :, :), &
+ ! production term of qsq
+ bp_cov(:, :, :), &
+ ! coefficients of cov in the dissipation term
+ rp_cov(:, :, :)
+ ! production term of cov
+
+INTEGER, PARAMETER :: &
+ ! Symbols for a switch
+ full_impl = 0, &
+ half_impl = 1, &
+ expl = 2
+
+INTEGER, PARAMETER :: &
+ imp_mode = full_impl
+ ! mode to integrate covariances
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_TURBULENCE'
+! work variable for scmoutput
+REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen, ScmRow, bl_levels)
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+IF (l_my_extra_level) THEN
+ k_start = 1
+ELSE
+ k_start = 2
+END IF
+
+CALL mym_level2( &
+ bl_levels,dbdz, dvdzm,gm, gh, sm, sh)
+
+CALL mym_length( &
+ tdims%i_end,tdims%j_end,tdims_l%halo_i,tdims_l%halo_j,bl_levels, &
+ qke, z_uv, z_tq, dbdz, r_mosurf, fb_surf, qkw, el)
+
+DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ elsq(i, j, k) = el(i, j, k) ** 2
+ q2sq = b1 * elsq(i, j, k) &
+ * (sm(i, j, k) * gm(i, j, k) + sh(i, j, k) * gh(i, j, k))
+ q3sq(i, j, k) = qkw(i, j, k) ** 2
+ gmel(i, j, k) = gm(i, j, k) * elsq(i, j, k)
+ ghel(i, j, k) = gh(i, j, k) * elsq(i, j, k)
+
+ ! adjust SM and SH by SQRT(q3sq / q2sq)
+ IF ( q3sq(i, j, k) < q2sq ) THEN
+ qdiv(i, j, k) = SQRT(q3sq(i, j, k) / q2sq)
+ sm(i, j, k) = sm(i, j, k) * qdiv(i, j, k)
+ sh(i, j, k) = sh(i, j, k) * qdiv(i, j, k)
+
+ e1 = q3sq(i, j, k) &
+ - e1c * ghel(i, j, k) * qdiv(i, j, k) ** 2
+ e2(i, j, k) = q3sq(i, j, k) &
+ - e2c * ghel(i, j, k) * qdiv(i, j, k) ** 2
+ e3 = e1 + e3c * ghel(i, j, k) * qdiv(i, j, k) ** 2
+ e4 = e1 - e4c * ghel(i, j, k) * qdiv(i, j, k) ** 2
+ eden = e2(i, j, k) * e4 &
+ + e3 * e5c * gmel(i, j, k) * qdiv(i, j, k) ** 2
+ eden = MAX(eden, 1.0e-20)
+ reden = 1.0 / eden
+ ELSE
+ e1 = q3sq(i, j, k) - e1c * ghel(i, j, k)
+ e2(i, j, k) = q3sq(i, j, k) - e2c * ghel(i, j, k)
+ e3 = e1 + e3c * ghel(i, j, k)
+ e4 = e1 - e4c * ghel(i, j, k)
+ eden = e2(i, j, k) * e4 + e3 * e5c * gmel(i, j, k)
+ eden = MAX(eden, 1.0e-20)
+ reden = 1.0 / eden
+
+ qdiv(i, j, k) = 1.0
+ sm(i, j, k) = q3sq(i, j, k) * a1 * (e3 - 3.0 * c1 *e4) &
+ * reden
+ sh(i, j, k) = q3sq(i, j, k) &
+ * a2 * (e2(i, j, k) + 3.0 * c1 * e5c * gmel(i, j, k)) &
+ * reden
+ END IF ! test if q3sq < q2sq
+ cu25(i, j, k) =(e2(i, j, k) &
+ + 3.0 * c1 * e5c * gmel(i, j, k) &
+ * qdiv(i, j, k) ** 2) * one_third * reden
+ cv25(i, j, k) = cu25(i, j, k) &
+ * (e4 - 0.5 * e4c * ghel(i, j, k) * qdiv(i, j, k) ** 2)
+ cw25(i, j, k) = cu25(i, j, k) * e1
+ cu25(i, j, k) = 1.0 - cv25(i, j, k) - cw25(i, j, k)
+ END DO
+ END DO
+END DO
+
+IF ( levflag == 3 ) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ t2sq = qdiv(i, j, k) * b2 * elsq(i, j, k) &
+ * sh(i, j, k) * dtldz(i, j, k) ** 2
+ r2sq = qdiv(i, j, k) * b2 * elsq(i, j, k) &
+ * sh(i, j, k) * dqwdz(i, j, k) ** 2
+ c2sq(i, j, k) = qdiv(i, j, k) * b2 * elsq(i, j, k) &
+ * sh(i, j, k) * dtldz(i, j, k) * dqwdz(i, j, k)
+ t3sq = MAX(tsq(i, j, k), 0.0)
+ r3sq = MAX(qsq(i, j, k), 0.0)
+ c3sq = cov(i, j, k)
+
+ c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
+
+ t2sq = vt(i, j, k) * t2sq + vq(i, j, k) * c2sq(i, j, k)
+ r2sq = vt(i, j, k) * c2sq(i, j, k) + vq(i, j, k) * r2sq
+ c2sq(i, j, k) = MAX(vt(i, j, k) * t2sq + vq(i, j, k) * r2sq, &
+ 0.0)
+ t3sq = vt(i, j, k) * t3sq + vq(i, j, k) * c3sq
+ r3sq = vt(i, j, k) * c3sq + vq(i, j, k) * r3sq
+ c3sq = MAX(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
+
+ ! Limitation on q, instead of L/q
+ IF ( q3sq(i, j, k) < -gh(i, j, k) * elsq(i, j, k)) THEN
+ q3sq(i, j, k) = -elsq(i, j, k) * gh(i, j, k)
+ END IF
+
+ ! Limitation on c3sq (0.12 =< cw =< 0.76)
+ ! e2 = q^2 * phi2'
+ e2(i, j, k) = q3sq(i, j, k) &
+ - e2c*ghel(i, j, k) * qdiv(i, j, k)**2
+ ! e3 = q^2 * phi3'
+ e3 = q3sq(i, j, k) + e3c*ghel(i, j, k) * qdiv(i, j, k)**2
+ ! e4 = q^2 * phi4'
+ e4 = q3sq(i, j, k) - e4c*ghel(i, j, k) * qdiv(i, j, k)**2
+ ! eden = q^4 D'
+ eden = e2(i, j, k) * e4 &
+ + e3 *e5c*gmel(i, j, k) * qdiv(i, j, k)**2
+
+ ! wden = numerator in the square braket in (10a) in NN2006
+ ! times (1-c3) * (g/thetav)**2 * GH
+ wden = cc3*gtr(i, j, k) **2 &
+ * elsq(i, j, k)**2 / elsq(i, j, k) &
+ * qdiv(i, j, k)**2 &
+ *( e2(i, j, k)*e4c &
+ - e3c*e5c*gmel(i, j, k) * qdiv(i, j, k)**2 )
+
+ IF ( wden /= 0.0 ) THEN
+ clow = q3sq(i, j, k) * ( 0.12-cw25(i, j, k) )*eden/wden
+ cupp = q3sq(i, j, k) *( 0.76-cw25(i, j, k) )*eden/wden
+
+ IF ( wden > 0.0 ) THEN
+ c3sq = MIN( MAX( c3sq, c2sq(i, j, k) + clow), &
+ c2sq(i, j, k) + cupp)
+ ELSE
+ c3sq = MAX( MIN( c3sq, c2sq(i, j, k) + clow), &
+ c2sq(i, j, k) + cupp)
+ END IF
+ END IF
+
+ e1 = e2(i, j, k) + e5c*gmel(i, j, k) * qdiv(i, j, k) ** 2
+ eden = MAX( eden, 1.0e-20 )
+ reden = 1.0 / eden
+
+ e6c = 3.0 * a2 *cc3 * gtr(i, j, k) &
+ * elsq(i, j, k) / elsq(i, j, k)
+
+ ! Calculate each term in Gamma_theta
+ coef = - e1 * qdiv(i, j, k) * e6c * reden
+ gamt_tsq(i, j, k) = coef * vt(i, j, k)
+ gamt_cov(i, j, k) = coef * vq(i, j, k)
+ gamt_res(i, j, k) = - coef * t2sq
+
+ ! Calculate each term in Gamma_q
+ gamq_qsq(i, j, k) = coef * vq(i, j, k)
+ gamq_cov(i, j, k) = coef * vt(i, j, k)
+ gamq_res(i, j, k) = - coef * r2sq
+
+ ! for Sm' and Sh'd(Theta_V)/dz
+ smd_coef(i, j, k) = elsq(i, j, k) * qdiv(i, j, k) * e6c &
+ * gtr(i, j, k) * reden * qdiv(i, j, k) ** 2 &
+ * (e3c + e4c) * a1_2
+ gamv_coef(i, j, k) = e1 * qdiv(i, j, k) * e6c * gtr(i, j, k) &
+ * reden
+ smd(i, j, k) = smd_coef(i, j, k) * (c3sq - c2sq(i, j, k))
+ gamv(i, j, k) = gamv_coef(i, j, k) * (c3sq - c2sq(i, j,k))
+
+ ! For elh (see below), qdiv in Level 3 is reset to 1.0.
+ qdiv(i, j, k) = 1.0
+
+ ! Calculate diffusion coefficients
+ elq = el(i, j, k) * qkw(i, j, k)
+ dfm(i, j, k) = elq * sm(i, j, k)
+ dfh(i, j, k) = elq * sh(i, j, k)
+
+ END DO
+ END DO
+ END DO
+
+ ! Adjustment for Gamma_theta and Gamma_q
+ ! After the adjustment, Gamma_theta and Gamma_q are calculated
+ IF (l_my_prod_adj .AND. &
+ (imp_mode == half_impl .OR. imp_mode == full_impl)) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+
+ elq = el(i, j, k) * qkw(i, j, k)
+ elh = elq * qdiv(i, j, k)
+ disp_coef = qkw(i, j, k) / (b2 * el(i, j, k)) &
+ + 0.5 * coef_trbvar_diff * dfm(i, j, k) &
+ * (2.0 * pi * my_prod_adj_fact(k) &
+ / (z_uv(i, j, k) - z_uv(i, j, k - 1))) ** 2
+
+ pdt_tsq(i, j, k) = elh * gamt_tsq(i, j, k) * dtldz(i, j, k)
+ IF (disp_coef < pdt_tsq(i, j, k)) THEN
+ gamt_factor(i, j, k) = disp_coef / pdt_tsq(i, j, k)
+ ELSE
+ gamt_factor(i, j, k) = 1.0
+ END IF
+
+ pdq_qsq(i, j, k) = elh * gamq_qsq(i, j, k) * dqwdz(i, j, k)
+ IF (disp_coef < pdq_qsq(i, j, k)) THEN
+ gamq_factor(i, j, k) = disp_coef / pdq_qsq(i, j, k)
+ ELSE
+ gamq_factor(i, j, k) = 1.0
+ END IF
+
+ gamt_tsq(i, j, k) = gamt_factor(i, j, k) * gamt_tsq(i, j, k)
+ gamt_cov(i, j, k) = gamt_factor(i, j, k) * gamt_cov(i, j, k)
+ gamt_res(i, j, k) = gamt_factor(i, j, k) * gamt_res(i, j, k)
+
+ gamq_qsq(i, j, k) = gamq_factor(i, j, k) * gamq_qsq(i, j, k)
+ gamq_cov(i, j, k) = gamq_factor(i, j, k) * gamq_cov(i, j, k)
+ gamq_res(i, j, k) = gamq_factor(i, j, k) * gamq_res(i, j, k)
+
+ pdc_cov(i, j, k) = elh &
+ * (gamt_cov(i, j, k) * dqwdz(i, j, k) &
+ + gamq_cov(i, j, k) * dtldz(i, j, k)) * 0.5
+ IF (disp_coef < pdc_cov(i, j, k)) THEN
+ pdc_factor(i, j, k) = disp_coef / pdc_cov(i, j, k)
+ ELSE
+ pdc_factor(i, j, k) = 1.0
+ END IF
+ gamt_tsq(i, j, k) = pdc_factor(i, j, k) * gamt_tsq(i, j, k)
+ gamt_cov(i, j, k) = pdc_factor(i, j, k) * gamt_cov(i, j, k)
+ gamt_res(i, j, k) = pdc_factor(i, j, k) * gamt_res(i, j, k)
+
+ gamq_qsq(i, j, k) = pdc_factor(i, j, k) * gamq_qsq(i, j, k)
+ gamq_cov(i, j, k) = pdc_factor(i, j, k) * gamq_cov(i, j, k)
+ gamq_res(i, j, k) = pdc_factor(i, j, k) * gamq_res(i, j, k)
+
+ gamt(i, j, k) = gamt_tsq(i, j, k) * tsq(i, j, k) &
+ + gamt_cov(i, j, k) * cov(i, j, k) &
+ + gamt_res(i, j, k)
+
+ gamq(i, j, k) = gamq_qsq(i, j, k) * qsq(i, j, k) &
+ + gamq_cov(i, j, k) * cov(i, j, k) &
+ + gamq_res(i, j, k)
+
+ END DO
+ END DO
+ END DO
+ ELSE
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ gamt(i, j, k) = gamt_tsq(i, j, k) * tsq(i, j, k) &
+ + gamt_cov(i, j, k) * cov(i, j, k) &
+ + gamt_res(i, j, k)
+
+ gamq(i, j, k) = gamq_qsq(i, j, k) * qsq(i, j, k) &
+ + gamq_cov(i, j, k) * cov(i, j, k) &
+ + gamq_res(i, j, k)
+
+ gamt_factor(i, j, k) = 1.0
+ gamq_factor(i, j, k) = 1.0
+ pdc_factor(i, j, k) = 1.0
+ END DO
+ END DO
+ END DO
+ END IF ! IF L_MY_PROD_ADJ
+
+ ! Calculate production terms
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+
+ elq = el(i, j, k) * qkw(i, j, k)
+ elh = elq * qdiv(i, j, k)
+
+ pdk(i, j, k) = elq * (sm(i, j, k) * gm(i, j, k) &
+ + sh(i, j, k) * gh(i, j, k)) &
+ + wb_ng(i,j,k)
+
+ pdt(i, j, k) = elh &
+ * (sh(i, j, k) * dtldz(i, j, k) + gamt_res(i, j, k)) &
+ * dtldz(i, j, k)
+ pdt_tsq(i, j, k) = elh * gamt_tsq(i, j, k) * dtldz(i, j, k)
+ pdt_cov(i, j, k) = elh * gamt_cov(i, j, k) * dtldz(i, j, k)
+
+ pdq(i, j, k) = elh &
+ * (sh(i, j, k) * dqwdz(i, j, k) + gamq_res(i, j, k)) &
+ * dqwdz(i, j, k)
+ pdq_qsq(i, j, k) = elh * gamq_qsq(i, j, k) * dqwdz(i, j, k)
+ pdq_cov(i, j, k) = elh * gamq_cov(i, j, k) * dqwdz(i, j, k)
+
+ pdc(i, j, k) = 0.5 * elh &
+ * ((sh(i, j, k) * dtldz(i, j, k) &
+ + gamt_res(i, j, k)) * dqwdz(i, j, k) &
+ + (sh(i, j, k) * dqwdz(i, j, k) &
+ + gamq_res(i, j, k)) * dtldz(i, j, k))
+
+ pdc_tsq(i, j, k) = elh &
+ * gamt_tsq(i, j, k) * dqwdz(i, j, k) * 0.5
+ pdc_qsq(i, j, k) = elh &
+ * gamq_qsq(i, j, k) * dtldz(i, j, k) * 0.5
+ pdc_cov(i, j, k) = 0.5 * elh &
+ * (gamt_cov(i, j, k) * dqwdz(i, j, k) &
+ + gamq_cov(i, j, k) * dtldz(i, j, k))
+
+ dfu_cg(i, j, k) = elq * smd(i, j, k) * dudz(i, j, k)
+ dfv_cg(i, j, k) = elq * smd(i, j, k) * dvdz(i, j, k)
+ dft_cg(i, j, k) = elq * gamt(i, j, k)
+ dfq_cg(i, j, k) = elq * gamq(i, j, k)
+ END DO
+ END DO
+ END DO
+ELSE ! level 2.5
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ ! In Level 2.5, qdiv is not reset.
+ gamt(i, j, k) = 0.0
+ gamq(i, j, k) = 0.0
+ gamv(i, j, k) = 0.0
+ smd(i, j, k) = 0.0
+ cu(i, j, k) = cu25(i, j, k)
+ cv(i, j, k) = cv25(i, j, k)
+
+ elq = el(i, j, k) * qkw(i, j, k)
+ elh = elq * qdiv(i, j, k)
+
+ pdk(i, j, k) = elq &
+ * (sm(i, j, k) * gm(i, j, k) &
+ + sh(i, j, k) * gh(i, j, k)) + wb_ng(i,j,k)
+ pdt(i, j, k) = elh &
+ * (sh(i, j, k) * dtldz(i, j, k)) * dtldz(i, j, k)
+ pdq(i, j, k) = elh &
+ * (sh(i, j, k) * dqwdz(i, j, k)) * dqwdz(i, j, k)
+ pdc(i, j, k) = elh &
+ * (sh(i, j, k) * dtldz(i, j, k)) * dqwdz(i, j, k) * 0.5 &
+ + elh &
+ * (sh(i, j, k) * dqwdz(i, j, k)) * dtldz(i, j, k) * 0.5
+
+ dfm(i, j, k) = elq * sm(i, j, k)
+ dfh(i, j, k) = elq * sh(i, j, k)
+ dfu_cg(i, j, k) = 0.0
+ dfv_cg(i, j, k) = 0.0
+ dft_cg(i, j, k) = 0.0
+ dfq_cg(i, j, k) = 0.0
+ END DO
+ END DO
+ END DO
+END IF ! test if levflag == 3
+
+! Overwrite production terms by ones calculated with surface fluxes
+IF (my_lowest_pd_surf > 0) THEN
+ IF (l_my_extra_level) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk(i, j, 1) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
+ / (vkman * z_tq(i, j, 1) * my_z_extra_fact)
+ END DO
+ END DO
+ IF (l_my_lowest_pd_surf_tqc) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ phm = 1.0 / u_s(i, j) * phh(i, j) &
+ / (vkman * z_tq(i, j, 1) * my_z_extra_fact)
+ pdt(i, j, 1) = phm * ftl(i, j, 1) ** 2
+ pdq(i, j, 1) = phm * fqw(i, j, 1) ** 2
+ pdc(i, j, 1) = phm * ftl(i, j, 1) * fqw(i, j, 1)
+ END DO
+ END DO
+ END IF
+ ELSE ! NOT L_MY_Extra_level
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk(i, j, 2) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
+ / (vkman * z_tq(i, j, 1))
+ pdk(i, j, 1) = 0.0
+ pdt(i, j, 1) = 0.0
+ pdq(i, j, 1) = 0.0
+ pdc(i, j, 1) = 0.0
+ END DO
+ END DO
+ IF (l_my_lowest_pd_surf_tqc) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ phm = 1.0 / u_s(i, j)* phh(i, j) &
+ / (vkman * z_tq(i, j, 1))
+ pdt(i, j, 2) = phm * ftl(i, j, 1) ** 2
+ pdq(i, j, 2) = phm * fqw(i, j, 1) ** 2
+ pdc(i, j, 2) = phm * ftl(i, j, 1) * fqw(i, j, 1)
+ pdt_tsq(i, j, 2) = 0.0
+ pdt_cov(i, j, 2) = 0.0
+ pdq_qsq(i, j, 2) = 0.0
+ pdq_cov(i, j, 2) = 0.0
+ pdc_tsq(i, j, 2) = 0.0
+ pdc_qsq(i, j, 2) = 0.0
+ pdc_cov(i, j, 2) = 0.0
+ END DO
+ END DO
+ END IF ! IF L_MY_lowest_pd_surf_tqc
+ END IF ! IF L_MY_EXTRA_LEVEL
+ELSE ! MY_lowest_pd_surf = 0
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk(i, j, 1) = 0.0
+ pdt(i, j, 1) = 0.0
+ pdq(i, j, 1) = 0.0
+ pdc(i, j, 1) = 0.0
+ END DO
+ END DO
+END IF ! IF MY_lowest_pd_surf
+
+! for diagnostics
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ gamt(i, j, 1) = 0.0
+ gamq(i, j, 1) = 0.0
+ gamv(i, j, 1) = 0.0
+ smd(i, j, 1) = 0.0
+ dfh(i, j, 1) = 0.0
+ pdt_tsq(i, j, 1) = 0.0
+ pdt_cov(i, j, 1) = 0.0
+ pdq_qsq(i, j, 1) = 0.0
+ pdq_cov(i, j, 1) = 0.0
+ pdc_tsq(i, j, 1) = 0.0
+ pdc_qsq(i, j, 1) = 0.0
+ pdc_cov(i, j, 1) = 0.0
+ END DO
+END DO
+
+IF (BL_diag%l_tke_shr_prod) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ elq = el(i, j, k) * qkw(i, j, k)
+ BL_diag%tke_shr_prod(i, j, k) = el(i, j, k) * qkw(i, j, k) &
+ * (sm(i, j, k) + smd(i, j, k)) * gm(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_tke_boy_prod) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%tke_boy_prod(i, j, k) = el(i, j, k) * qkw(i, j, k) &
+ * (sh(i, j, k) * gh(i, j, k) &
+ + gamv(i, j, k)) + wb_ng(i,j,k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_tke_boy_prod) THEN
+ DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%tke_dissp(i, j, k) = qkw(i, j, k) ** 3 &
+ / (b1 * el(i, j, k))
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (levflag == 3) THEN
+ ! Integrate the covariances
+
+ IF (imp_mode == full_impl) THEN
+ CALL mym_update_covariance( &
+ ! IN levels
+ bl_levels, &
+ ! IN fields
+ qkw, el, dfm, pdt_tsq, pdt_cov, pdt, &
+ pdq_qsq, pdq_cov, pdq, pdc_cov, pdc_tsq, pdc_qsq, pdc, &
+ ! INOUT fields
+ tsq, qsq, cov)
+ ELSE ! half implict or explicit
+ ALLOCATE(bp_tsq(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, tke_levels))
+ ALLOCATE(rp_tsq(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, tke_levels))
+ ALLOCATE(bp_qsq(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, tke_levels))
+ ALLOCATE(rp_qsq(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, tke_levels))
+ ALLOCATE(bp_cov(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, tke_levels))
+ ALLOCATE(rp_cov(tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, tke_levels))
+
+ IF (imp_mode == half_impl) THEN
+ DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdt(i, j, k) = pdt(i, j, k) &
+ + pdt_cov(i, j, k) * cov(i, j, k)
+
+ pdq(i, j, k) = pdq(i, j, k) &
+ + pdq_cov(i, j, k) * cov(i, j, k)
+
+ pdc(i, j, k) = pdc(i, j, k) &
+ + pdc_tsq(i, j, k) * tsq(i, j, k) &
+ + pdc_qsq(i, j, k) * qsq(i, j, k)
+
+ b2l = 2.0 * qkw(i, j, k) / (b2 * el(i, j, k))
+
+ bp_tsq(i, j, k) = b2l - 2.0 * pdt_tsq(i, j, k)
+ rp_tsq(i, j, k) = 2.0 * pdt(i, j, k)
+
+ bp_qsq(i, j, k) = b2l - 2.0 * pdq_qsq(i, j, k)
+ rp_qsq(i, j, k) = 2.0 * pdq(i, j, k)
+
+ bp_cov(i, j, k) = b2l - 2.0 * pdc_cov(i, j, k)
+ rp_cov(i, j, k) = 2.0 * pdc(i, j, k)
+ END DO
+ END DO
+ END DO
+ ELSE IF (imp_mode == expl) THEN
+ DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdt(i, j, k) = pdt(i, j, k) &
+ + pdt_tsq(i, j, k) * tsq(i, j, k) &
+ + pdt_cov(i, j, k) * cov(i, j, k)
+ pdq(i, j, k) = pdq(i, j, k) &
+ + pdq_qsq(i, j, k) * qsq(i, j, k) &
+ + pdq_cov(i, j, k) * cov(i, j, k)
+ pdc(i, j, k) = pdc(i, j, k) &
+ + pdc_cov(i, j, k) * cov(i, j, k) &
+ + pdc_tsq(i, j, k) * tsq(i, j, k) &
+ + pdc_qsq(i, j, k) * qsq(i, j, k)
+
+ b2l = 2.0 * qkw(i, j, k) / (b2 * el(i, j, k))
+
+ bp_tsq(i, j, k) = b2l
+ rp_tsq(i, j, k) = 2.0 * pdt(i, j, k)
+
+ bp_qsq(i, j, k) = b2l
+ rp_qsq(i, j, k) = 2.0 * pdq(i, j, k)
+
+ bp_cov(i, j, k) = b2l
+ rp_cov(i, j, k) = 2.0 * pdc(i, j, k)
+ END DO
+ END DO
+ END DO
+ END IF
+ CALL mym_update_fields( &
+ bl_levels, coef_trbvar_diff,dfm, rp_tsq, bp_tsq,tsq)
+
+ CALL mym_update_fields( &
+ bl_levels, coef_trbvar_diff,dfm, rp_qsq, bp_qsq,qsq)
+
+ CALL mym_update_fields( &
+ bl_levels, coef_trbvar_diff,dfm, rp_cov, bp_cov,cov)
+
+ DEALLOCATE(rp_cov)
+ DEALLOCATE(bp_cov)
+ DEALLOCATE(rp_qsq)
+ DEALLOCATE(bp_qsq)
+ DEALLOCATE(rp_tsq)
+ DEALLOCATE(bp_tsq)
+
+ END IF ! if imp_mode == FULL_IMPL
+ELSE ! level 2.5
+ ! In level 2.5, tsq, qsq, cov are diagnosed assuming balance between
+ ! prodcution and dissipation.
+ DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ IF (qkw(i, j, k) <= 1.0e-4) THEN
+ b2l = 0.0
+ ELSE
+ b2l = b2 * el(i, j, k) / qkw(i, j, k)
+ END IF
+ tsq(i, j, k) = b2l * 2.0 * pdt(i, j, k)
+ qsq(i, j, k) = b2l * 2.0 * pdq(i, j, k)
+ cov(i, j, k) = b2l * 2.0 * pdc(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (levflag >= 2) THEN
+ ! predict qke
+ IF (my_lowest_pd_surf > 0) THEN
+ k_start_cor = k_start + 1
+ ELSE
+ k_start_cor = k_start
+ END IF
+
+ IF (levflag == 3 .AND. &
+ (imp_mode == half_impl .OR. imp_mode == full_impl)) THEN
+ ! add correction terms evaluated with integrated tsq, qsq and cov
+ DO k = k_start_cor, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+
+ t3sq = MAX(tsq(i, j, k), 0.0)
+ r3sq = MAX(qsq(i, j, k), 0.0)
+ c3sq = cov(i, j, k)
+
+ c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
+
+ t3sq = vt(i, j, k) * t3sq + vq(i, j, k) * c3sq
+ r3sq = vt(i, j, k) * c3sq + vq(i, j, k) * r3sq
+ c3sq = MAX(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
+
+ elq = el(i, j, k) * qkw(i, j, k)
+ smd(i, j, k) = smd_coef(i, j, k) * (c3sq - c2sq(i, j, k))
+
+ pdk(i, j, k) = pdk(i, j, k) + elq &
+ * (smd(i, j, k) * gm(i, j, k) &
+ + gamv_coef(i, j, k) * (c3sq- c2sq(i, j, k)))
+ END DO
+ END DO
+ END DO
+ ELSE
+ DO k = k_start_cor, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ pdk(i, j, k) = pdk(i, j, k) &
+ + el(i, j, k) * qkw(i, j, k) &
+ * (smd(i, j, k) * gm(i, j, k) + gamv(i, j, k))
+ END DO
+ END DO
+ END DO
+ END IF ! if test levflag == 3
+
+ DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ b1l = b1 * el(i, j, k)
+ bp(i, j, k) = 2.0 * qkw(i, j, k) / b1l
+ rp(i, j, k) = 2.0 * pdk(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL mym_update_fields( &
+ bl_levels, coef_trbvar_diff_tke,dfm, rp, bp, qke)
+ELSE
+ ! level 2
+ ! diagnose qke
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ b2l = b2 * el(i, j, k)
+ qke(i, j, k) = (MAX(b2l * 2.0 * pdk(i, j, k), 0.0)) &
+ ** two_thirds
+ END DO
+ END DO
+ END DO
+END IF ! test if levflag >= 2
+
+DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ qke(i, j, k) = MIN(MAX(qke(i, j, k), 1.0e-20), qke_max)
+ tsq(i, j, k) = MAX(tsq(i, j, k), 0.0)
+ qsq(i, j, k) = MAX(qsq(i, j, k), 0.0)
+ END DO
+ END DO
+END DO
+
+DO k = tke_levels + 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ qke(i, j, k) = 0.0
+ tsq(i, j, k) = 0.0
+ qsq(i, j, k) = 0.0
+ cov(i, j, k) = 0.0
+ dfm(i, j, k) = 0.0
+ dfh(i, j, k) = 0.0
+ dfu_cg(i, j, k) = 0.0
+ dfv_cg(i, j, k) = 0.0
+ dft_cg(i, j, k) = 0.0
+ dfq_cg(i, j, k) = 0.0
+ END DO
+ END DO
+END DO
+
+!-----------------------------------------------------------------------
+! SCM Boundary Layer Diagnostics Package
+!-----------------------------------------------------------------------
+IF ( L_SCMDiags(scmdiag_bl) .AND. &
+ (model_type == mt_single_column) ) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ sm(i,j,1) = 0.0
+ sh(i,j,1) = 0.0
+ gamt_factor(i,j,1) = 1.0
+ gamq_factor(i,j,1) = 1.0
+ pdc_factor(i,j,1) = 1.0
+ END DO
+ END DO
+
+ ! Note that each diagnostics here has only "tke_levels" levels.
+ ! It is necessary to copy them to an array which has "bl_levels"
+ TmpScm3d(:, :, :) = 0.0
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = sm(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'sm', &
+ 'non-dim diffusion coefficient for momentum', ' ', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = sh(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'sh', &
+ 'non-dim diffusion coefficient for heat', ' ', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = dfm(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'momdif', &
+ 'Diffusivity of momentum','kg/(ms)', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = dfh(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'htdiff', &
+ 'Diffusivity of heat','kg/(ms)', &
+ t_avg,d_bl,default_streams,'',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = el(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'elm', &
+ 'mixing length','m', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = BL_diag%tke_shr_prod(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'tke_shr_prod', &
+ 'shear production of TKE','m2/s3', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = BL_diag%tke_boy_prod(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'tke_boy_prod', &
+ 'buoyancy production of TKE','m2/s3', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = BL_diag%tke_dissp(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'tke_dissp', &
+ ' dissipation of TKE','m2/s3', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ IF (levflag == 3) THEN
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = gamt_factor(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'gamt_factor', &
+ 'stability factor for gamt',' ', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = gamq_factor(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'gamq_factor', &
+ 'stability factor for gamt',' ', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 1, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = pdc_factor(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'pdc_factor', &
+ 'stability factor for pdc',' ', &
+ t_avg, d_bl, default_streams, '',routinename)
+ END IF ! if levflag == 3
+
+ TmpScm3d(:,:,1) = 0.0
+ DO k = 2, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = vt(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'vt', &
+ 'buoyancy parameter for heat','', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 2, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = vq(i, j, k)
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'vq', &
+ 'buoyancy parameter for moisture','', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+ DO k = 2, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ jScm = j - tdims%j_start + 1
+ DO i = tdims%i_start, tdims%i_end
+ iScm = i - tdims%i_start + 1
+ TmpScm3d(iScm,jScm,k) = - gh(i, j, k) &
+ / MAX( gm(i, j, k), 1.0e-10 )
+ END DO
+ END DO
+ END DO
+
+ CALL scmoutput(TmpScm3d,'grad_ri', &
+ 'gradient Richardson number','', &
+ t_avg, d_bl, default_streams, '',routinename)
+
+END IF ! L_SCMDiags(SCMDiag_bl) / model_type
+
+
+IF (BL_diag%l_elm) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%elm(i, j, k) = el(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_sm) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%sm(i, j, k) = sm(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (BL_diag%l_sh) THEN
+ DO k = 2, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ BL_diag%sh(i, j, k) = sh(i, j, k)
+ END DO
+ END DO
+ END DO
+END IF
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_turbulence
+END MODULE mym_turbulence_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90 b/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
new file mode 100644
index 0000000000..77fa240952
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
@@ -0,0 +1,263 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+
+! Purpose: To integrate the covariances(tsq, qsq, cov) appeared
+! in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_update_covariance_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_UPDATE_COVARIANCE_MOD'
+CONTAINS
+
+SUBROUTINE mym_update_covariance( &
+! IN levels
+ bl_levels, &
+! IN fields
+ qkw, el, dfm, pdt_tsq, pdt_cov, pdt_res, &
+ pdq_qsq, pdq_cov, pdq_res, pdc_cov, pdc_tsq, pdc_qsq, pdc_res, &
+! INOUT fields
+ tsq, qsq, cov)
+
+USE atm_fields_bounds_mod, ONLY: tdims, tdims_s
+USE mym_const_mod, ONLY: b2, coef_trbvar_diff
+USE mym_option_mod, ONLY: l_my_extra_level, tke_levels
+USE timestep_mod, ONLY: timestep
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
+USE mym_solve_simeq_mod, ONLY: mym_solve_simeq
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" level
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ qkw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! sqrt(qke) = sqrt(2TKE)
+ el(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! mixing length
+ dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ bl_levels), &
+ ! diffusion coefficients fot momentum
+ pdt_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to tsq in the production term of tsq
+ pdt_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in the production term of tsq
+ pdt_res(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a residual part in the production term of tsq
+ pdq_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to qsq in the production term of qsq
+ pdq_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in the production term of qsq
+ pdq_res(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a residual part in the production term of qsq
+ pdc_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to cov in the production term of cov
+ pdc_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to tsq in the production term of cov
+ pdc_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! a linear part to qsq in the production term of cov
+ pdc_res(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! a residual part in the production term of cov
+
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of liquid potential temperature
+ ! (thetal'**2) defined on theta levels K-1
+ qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Self covariance of total water
+ ! (qw'**2) defined on theta levels K-1
+ cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels)
+ ! Correlation between thetal and qw
+ ! (thetal'qw') defined on theta levels K-1
+
+! Local Variables
+INTEGER :: &
+ i, j, k, k_start
+ ! loop indexes, etc.
+REAL(KIND=real_umphys) :: &
+ elem
+ ! work variables
+
+REAL(KIND=real_umphys) :: &
+ disp_coef
+ ! coefficients of the prognostic variables in
+ ! dissipation terms
+
+REAL(KIND=real_umphys) :: &
+ aa(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ bb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ cc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
+ ! tri-diagonal matrix elements due to diffusion
+ qq_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ qq_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ qq_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ aa_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ bb_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ cc_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_tc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ aa_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ bb_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ cc_qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_qc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ aa_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ bb_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ cc_cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_ct(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ pp_cq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! matrix elements (see the documents for details)
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_UPDATE_COVARIANCE'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+CALL mym_diff_matcoef( &
+ bl_levels,coef_trbvar_diff, dfm, aa, bb, cc)
+
+IF (l_my_extra_level) THEN
+ k_start = 1
+ELSE
+ k_start = 2
+END IF
+
+! set maxtrix elements
+DO k = k_start, tke_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ disp_coef = 2.0 * qkw(i, j, k) / (b2 * el(i, j, k))
+ elem = 1.0 - bb(i, j, k) * timestep &
+ + timestep * disp_coef
+ bb_tsq(i, j, k) = elem &
+ - 2.0 * pdt_tsq(i, j, k) * timestep
+ bb_qsq(i, j, k) = elem &
+ - 2.0 * pdq_qsq(i, j, k) * timestep
+ bb_cov(i, j, k) = elem &
+ - 2.0 * pdc_cov(i, j, k) * timestep
+ qq_tsq(i, j, k) = tsq(i, j, k) &
+ + 2.0 * pdt_res(i, j, k) * timestep
+ qq_qsq(i, j, k) = qsq(i, j, k) &
+ + 2.0 * pdq_res(i, j, k) * timestep
+ qq_cov(i, j, k) = cov(i, j, k) &
+ + 2.0 * pdc_res(i, j, k) * timestep
+
+ elem = -aa(i, j, k) * timestep
+ aa_tsq(i, j, k) = elem
+ aa_qsq(i, j, k) = elem
+ aa_cov(i, j, k) = elem
+
+ elem = -cc(i, j, k) * timestep
+ cc_tsq(i, j, k) = elem
+ cc_qsq(i, j, k) = elem
+ cc_cov(i, j, k) = elem
+
+ pp_tc(i, j, k) = - 2.0 * pdt_cov(i, j, k) * timestep
+ pp_qc(i, j, k) = - 2.0 * pdq_cov(i, j, k) * timestep
+ pp_ct(i, j, k) = - 2.0 * pdc_tsq(i, j, k) * timestep
+ pp_cq(i, j, k) = - 2.0 * pdc_qsq(i, j, k) * timestep
+ END DO
+ END DO
+END DO
+
+DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ aa_tsq(i, j, k_start) = 0.0
+ aa_qsq(i, j, k_start) = 0.0
+ aa_cov(i, j, k_start) = 0.0
+
+ cc_tsq(i, j, tke_levels) = 0.0
+ cc_qsq(i, j, tke_levels) = 0.0
+ cc_cov(i, j, tke_levels) = 0.0
+ END DO
+END DO
+
+IF (.NOT. l_my_extra_level) THEN
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ bb_tsq(i, j, 1) = 1.0
+ bb_qsq(i, j, 1) = 1.0
+ bb_cov(i, j, 1) = 1.0
+ qq_tsq(i, j, 1) = 0.0
+ qq_qsq(i, j, 1) = 0.0
+ qq_cov(i, j, 1) = 0.0
+
+ aa_tsq(i, j, 1) = 0.0
+ aa_qsq(i, j, 1) = 0.0
+ aa_cov(i, j, 1) = 0.0
+
+ cc_tsq(i, j, 1) = 0.0
+ cc_qsq(i, j, 1) = 0.0
+ cc_cov(i, j, 1) = 0.0
+
+ pp_tc(i, j, 1) = 0.0
+ pp_qc(i, j, 1) = 0.0
+ pp_ct(i, j, 1) = 0.0
+ pp_cq(i, j, 1) = 0.0
+ END DO
+ END DO
+END IF
+
+! Solve the simultaneous equations for tsq, qsq and cov
+CALL mym_solve_simeq( &
+! IN levels
+ bl_levels, &
+! IN fields
+ qq_tsq, qq_qsq, qq_cov, aa_tsq, bb_tsq, cc_tsq, pp_tc, &
+ aa_qsq, bb_qsq, cc_qsq, pp_qc,aa_cov,bb_cov,cc_cov,pp_ct, pp_cq, &
+! OUT fields
+ tsq, qsq, cov)
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+
+END SUBROUTINE mym_update_covariance
+END MODULE mym_update_covariance_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_update_fields.F90 b/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
new file mode 100644
index 0000000000..8504b259a5
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
@@ -0,0 +1,117 @@
+! *****************************COPYRIGHT*******************************
+! (C) Crown copyright Met Office. All rights reserved.
+! For further details please refer to the file COPYRIGHT.txt
+! which you should have received as part of this distribution.
+! *****************************COPYRIGHT*******************************
+! Purpose: To integrate the prognostic variables appearing
+! in the MY model.
+
+! Programming standard : UMDP 3
+
+! Documentation: UMDP 025
+
+! Code Owner: Please refer to the UM file CodeOwners.txt
+! This file belongs in section: boundary_layer
+!---------------------------------------------------------------------
+MODULE mym_update_fields_mod
+
+USE um_types, ONLY: real_umphys
+
+IMPLICIT NONE
+
+CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_UPDATE_FIELDS_MOD'
+CONTAINS
+
+SUBROUTINE mym_update_fields(bl_levels,coef,dfm,prod,disp_coef,field)
+
+USE atm_fields_bounds_mod, ONLY: pdims, pdims_l, tdims, tdims_s
+USE mym_option_mod, ONLY: l_my_extra_level, tke_levels
+USE timestep_mod, ONLY: timestep
+USE parkind1, ONLY: jprb, jpim
+USE yomhook, ONLY: lhook, dr_hook
+USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
+USE mym_implic_mod, ONLY: mym_implic
+IMPLICIT NONE
+
+! Intent IN Variables
+INTEGER, INTENT(IN) :: &
+ bl_levels
+ ! Max. no. of "boundary" levels
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ coef
+ ! factor for the diffusion coefficients to those for
+ ! momentum
+
+REAL(KIND=real_umphys), INTENT(IN) :: &
+ dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
+ bl_levels), &
+ ! diffusion coefficients for momentum
+ prod(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels), &
+ ! production term
+ disp_coef(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ tke_levels)
+ ! coefficients of dissipation term
+
+! Intent INOUT Variables
+REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+ field(pdims_l%i_start:pdims_l%i_end,pdims_l%j_start:pdims_l%j_end, &
+ bl_levels)
+ ! field to be integrated
+
+! Local variables
+INTEGER :: &
+ i, j, k, k_start
+ ! Loop indexes
+
+REAL(KIND=real_umphys) :: &
+ aa(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
+ bb(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
+ cc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
+ qq(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels)
+ ! coefficients of tri-diagonal equations
+
+INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
+INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
+REAL(KIND=jprb) :: zhook_handle
+
+CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_UPDATE_FIELDS'
+
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
+! Calculate the coefficients of tri-diagonal eqs. due to diffusion
+CALL mym_diff_matcoef(bl_levels, coef, dfm, aa, bb, cc)
+
+IF (l_my_extra_level) THEN
+ k_start = 1
+ELSE
+ k_start = 2
+END IF
+
+DO k = k_start, tke_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ aa(i, j, k) = - aa(i, j, k) * timestep
+ bb(i, j, k) = 1.0 - bb(i, j, k) * timestep &
+ + timestep * disp_coef(i, j, k)
+ cc(i, j, k) = - cc(i, j, k) * timestep
+ qq(i, j, k) = field(i, j, k) + timestep * prod(i, j, k)
+ END DO
+ END DO
+END DO
+
+! Solve the tri-diagonal equations
+CALL mym_implic(tke_levels, k_start, tke_levels, aa, bb, cc, qq)
+
+DO k = k_start, tke_levels
+ DO j = pdims%j_start, pdims%j_end
+ DO i = pdims%i_start, pdims%i_end
+ field(i, j, k) = qq(i, j, k)
+ END DO
+ END DO
+END DO
+IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+RETURN
+END SUBROUTINE mym_update_fields
+END MODULE mym_update_fields_mod
From aed80b92a83ba6f512852346ca0a6ad55b3a615a Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Wed, 29 Jul 2026 14:44:45 +0100
Subject: [PATCH 2/9] Show minimum necessary modifications to UM's source code.
---
.../source/boundary_layer/bdy_expl2_1a.F90 | 433 +++---------------
.../source/boundary_layer/ddf_ctl.F90 | 208 ++-------
.../source/boundary_layer/ddf_initialize.F90 | 10 +-
.../source/boundary_layer/ddf_mix_length.F90 | 6 +-
.../boundary_layer/mym_condensation.F90 | 100 +---
.../source/boundary_layer/mym_ctl.F90 | 101 ++--
.../boundary_layer/mym_diff_matcoef.F90 | 41 +-
.../source/boundary_layer/mym_ex_flux_tq.F90 | 45 +-
.../source/boundary_layer/mym_initialize.F90 | 22 +-
.../source/boundary_layer/mym_length.F90 | 5 +-
.../source/boundary_layer/mym_shcu_buoy.F90 | 92 +---
.../source/boundary_layer/mym_turbulence.F90 | 258 +----------
.../boundary_layer/mym_update_covariance.F90 | 11 +-
.../boundary_layer/mym_update_fields.F90 | 9 +-
14 files changed, 226 insertions(+), 1115 deletions(-)
diff --git a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90 b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
index f357eaf17b..32b07dd000 100644
--- a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
+++ b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
@@ -27,8 +27,7 @@ MODULE bdy_expl2_1a_mod
SUBROUTINE bdy_expl2_1a ( &
! IN values defining vertical grid of model atmosphere :
- bl_levels,p_theta_levels,land_pts,land_index, cycleno, &
- r_theta_levels, r_rho_levels, &
+ bl_levels,p_theta_levels,land_pts,land_index, &
! IN U, V and W momentum fields.
u_p,v_p,u_0_px,v_0_px, &
! IN variables for TKE scheme
@@ -40,18 +39,18 @@ SUBROUTINE bdy_expl2_1a ( &
! IN cloud/moisture data :
q,qcf,qcl,t,qw,tl, &
! IN everything not covered so far :
- fb_surf,u_s,h_blend_orog, &
+ fb_surf,u_s, &
zh_prev,ho2r2_orog,sd_orog, &
-! 1 IN 3 INOUT for Smagorinsky
- delta_smag, rneutml_sq, visc_m, visc_h, &
-! SCM Diagnostics (dummy values in full UM) & stash diagnostics
- nSCMDpkgs,L_SCMDiags,BL_diag, &
+! 2 IN for Smagorinsky
+ delta_smag, shear, &
+! stash diagnostics
+ BL_diag, &
! INOUT variables
zh,ntml,ntpar,l_shallow,cumulus,fqw,ftl,rhokh,rhokm, &
! INOUT variables on TKE based turbulence schemes
e_trb, tsq_trb, qsq_trb, cov_trb, zhpar_shcu, &
! OUT new variables for message passing
- tau_fd_x, tau_fd_y, rhogamu, rhogamv, &
+ tau_fd_x, tau_fd_y, visc_m, visc_h, rhogamu, rhogamv, &
! OUT Diagnostic not requiring STASH flags :
shallowc,cu_over_orog, &
bl_type_1,bl_type_2,bl_type_3,bl_type_4,bl_type_5,bl_type_6,bl_type_7, &
@@ -62,30 +61,21 @@ SUBROUTINE bdy_expl2_1a ( &
)
USE atm_fields_bounds_mod, ONLY: pdims, tdims, tdims_l, &
- pdims_s, ScmRowLen,ScmRow
+ pdims_s
USE bl_option_mod, ONLY: t_drain, h_scale, sg_orog_mixing, local_fa, &
- free_trop_layers, one_third, sg_shear, &
+ free_trop_layers, smooth_to_bdys, one_third, sg_shear, &
sg_shear_enh_lambda
USE bl_diags_mod, ONLY: strnewbldiag
USE cv_run_mod, ONLY: l_param_conv
USE gen_phys_inputs_mod, ONLY: l_mr_physics
USE jules_surface_mod, ONLY: formdrag, explicit_stress
-USE model_domain_mod, ONLY: model_type, mt_single_column
USE mym_option_mod, ONLY: &
bdy_tke, deardorff, mymodel25, mymodel3, tke_levels, &
- l_local_above_tkelvs, l_print_max_tke, l_3dtke
-USE mym_const_mod, ONLY: e_trb_max
-USE um_parcore, ONLY: nproc
+ l_local_above_tkelvs, l_3dtke
USE planet_constants_mod, ONLY: cp, g, vkman
-USE s_scmop_mod, ONLY: default_streams, &
- t_avg, d_bl, d_sl, scmdiag_bl
-USE scmoutput_mod, ONLY: scmoutput
USE turb_diff_mod, ONLY: &
l_subfilter_vert, l_subfilter_horiz, mix_factor, &
turb_startlev_vert, turb_endlev_vert
-USE umPrintMgr, ONLY: &
- umPrint, &
- umMessage
USE water_constants_mod, ONLY: lc
USE parkind1, ONLY: jprb, jpim
@@ -103,9 +93,8 @@ SUBROUTINE bdy_expl2_1a ( &
INTEGER, INTENT(IN) :: &
land_pts, &
! No.of land points in whole grid.
- bl_levels, &
+ bl_levels
! IN Max. no. of "boundary" levels
- cycleno ! Iteration number (EG outer loop)
! Declaration of new BL diagnostics.
TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
@@ -113,11 +102,6 @@ SUBROUTINE bdy_expl2_1a ( &
REAL(KIND=real_umphys), INTENT(IN) :: &
p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
0:bl_levels+1), &
- r_theta_levels(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
- 0:bl_levels), &
- r_rho_levels(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
- bl_levels), &
- ! IN height of rho and theta levels
rho_mix(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! IN density on UV (ie. rho) levels;
@@ -186,9 +170,6 @@ SUBROUTINE bdy_expl2_1a ( &
u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! IN Surface friction velocity
! (m/s)
- h_blend_orog(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
- ! IN Blending height used as part
- ! of effective roughness scheme
zh_prev(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! IN boundary layer height from
! previous timestep
@@ -198,15 +179,10 @@ SUBROUTINE bdy_expl2_1a ( &
sil_orog_land(land_pts), &
! IN Silhouette area of unresolved
! orography per unit horizontal area
- delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! IN delta_x used by Smagorinsky
-
-! Additional variables for SCM diagnostics which are dummy in full UM
-INTEGER, INTENT(IN) :: &
- nSCMDpkgs ! No of SCM diagnostics packages
-
-LOGICAL, INTENT(IN) :: &
- L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
+ shear(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels)
+ ! IN 3D Wind shear parameter
REAL(KIND=real_umphys), INTENT(IN) :: &
u_0_px(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end), &
@@ -268,14 +244,8 @@ SUBROUTINE bdy_expl2_1a ( &
REAL(KIND=real_umphys), INTENT(IN OUT) :: &
rhokm(pdims_s%i_start:pdims_s%i_end, &
- pdims_s%j_start:pdims_s%j_end ,bl_levels), &
+ pdims_s%j_start:pdims_s%j_end ,bl_levels)
! Exchange coefficients for momentum on P-grid
- rneutml_sq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
- ! Square of the neutral mixing length scale
- visc_m(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
- ! Diffusion coefficient for momentum
- visc_h(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels)
- ! Diffusion coefficient for heat and moisture
! INOUT but not used: variables used in the 1A version (TKE-based schemes)
REAL(KIND=real_umphys), INTENT(IN OUT) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
@@ -306,6 +276,10 @@ SUBROUTINE bdy_expl2_1a ( &
! Outputs :-
! (a) Calculated anyway (use STASH space from higher level) :-
REAL(KIND=real_umphys), INTENT(OUT) :: &
+ visc_m(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
+ ! Diffusion coefficient for momentum
+ visc_h(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
+ ! Diffusion coefficient for heat and moisture
rhogamu(pdims_s%i_start:pdims_s%i_end, &
pdims_s%j_start:pdims_s%j_end,2:bl_levels), &
! Counter gradient terms for u
@@ -401,10 +375,6 @@ SUBROUTINE bdy_expl2_1a ( &
!-----------------------------------------------------------------------
! Symbolic constants (parameters) reqd in top-level routine :-
-REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
- ! Temporary for SCM output
-REAL(KIND=real_umphys) :: sl(ScmRowLen,ScmRow,bl_levels) ! Static energy
-
! Parameters also passed to EX_COEF
! Layer interface K_LOG_LAYR-1/2 is the highest which requires log
! profile correction factors to the vertical finite differences.
@@ -464,7 +434,9 @@ SUBROUTINE bdy_expl2_1a ( &
sigma_h(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! Standard deviation of subgrid
! orography (m) [= 2root2 * ho2r2_orog]
- p_half(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels)
+ p_half(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
+ rneutml_sq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels)
+ ! Square of the neutral mixing length scale
REAL(KIND=real_umphys), ALLOCATABLE :: visc_h_rho (:,:,:)
! visc_h on rho levels
@@ -475,6 +447,10 @@ SUBROUTINE bdy_expl2_1a ( &
! boundary layer (metres) as
! determined from the local
! Richardson number profile.
+ zhnl(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! non-local PBL depth
+ zdsc_base(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
+ ! Height of base of K_top in DSC
dtldz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! TL+gz/cp gradient between
@@ -547,34 +523,13 @@ SUBROUTINE bdy_expl2_1a ( &
grcp ! G/CP
INTEGER :: &
- i,j,iScm,jScm, &
+ i,j, &
! LOCAL Loop counter (horizontal field index).
k,ient, &
! LOCAL Loop counter (vertical level index).
l
! LOCAL Loop counter for land points
-! for print max
-INTEGER :: max_indices(3)
-INTEGER :: istat_gc ! status code of gc_rmax
-INTEGER :: mype ! my node ID
-INTEGER :: ikind ! loop counter for e_trb, tsq, qsq, cov
-INTEGER :: e_kind ! end number of ikind
-INTEGER :: asize ! work variable
-CHARACTER(LEN=5) :: varname(4)
- ! variable names
-INTEGER, ALLOCATABLE :: indx_pe(:, :)
- ! indices of the maximum points
- ! in my processor
-INTEGER, ALLOCATABLE :: sumi(:, :)
- ! indices and pe number
-REAL(KIND=real_umphys), ALLOCATABLE :: max_pe(:)
- ! maximum values in my processor
-REAL(KIND=real_umphys), ALLOCATABLE :: max_real(:)
- ! maximum values in the whole domain
-REAL(KIND=real_umphys), ALLOCATABLE :: abs_cov(:, :, :)
- ! absolute values of cov_trb
-
CHARACTER(LEN=*), PARAMETER :: RoutineName = 'BDY_EXPL2_1A'
INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
@@ -676,6 +631,8 @@ SUBROUTINE bdy_expl2_1a ( &
ntdsc(i,j) = 0
nbdsc(i,j) = 0
zhsc(i,j) = 0.0
+ zhnl(i,j) = 0.0
+ zdsc_base(i,j) = 0.0
! entrainment variables for non-local tracer mixing
kent(i,j) = 2
kent_dsc(i,j) = 2
@@ -699,7 +656,6 @@ SUBROUTINE bdy_expl2_1a ( &
l_shallow(i,j) = .FALSE.
ntpar(i,j) = 0
ntml_nl(i,j) = -1 ! to ensure correct diagnostics
- zh(i,j) = 0.0
END DO
END DO
END IF
@@ -718,48 +674,15 @@ SUBROUTINE bdy_expl2_1a ( &
END DO
END DO
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( l_scmdiags(scmdiag_bl) .AND. &
- model_type == mt_single_column ) THEN
-
- DO k=1, bl_levels
- DO j=pdims%j_start, pdims%j_end
- jScm = j - pdims%j_start + 1
- DO i=pdims%i_start, pdims%i_end
- iScm = i - pdims%i_start + 1
- sl(iScm,jScm,k) = tl(i,j,k) + grcp*z_tq(i,j,k)
- END DO ! i
- END DO ! j
- END DO ! k
-
- ! Output SL
-
- CALL scmoutput(sl,'SL', &
- 'Liquid/frozen water static energy (IN)','K', &
- t_avg,d_bl,default_streams,'',routinename)
-
- ! Output QW
-
- CALL scmoutput(qw,'qw', &
- 'Total water content (IN)','kg/kg', &
- t_avg,d_bl,default_streams,'',routinename)
-
-END IF ! scmdiag_bl / model_type
-
! Calculate `buoyancy' gradient, DBDZ, on theta-levels
! NOTE: DBDZ(K) is on theta-level K-1
DO k = 3, bl_levels
DO j = pdims%j_start, pdims%j_end
DO i = pdims%i_start, pdims%i_end
- r_weight1 = 1.0 / (r_rho_levels(i,j,k) - &
- r_rho_levels(i,j,k-1))
- weight2 = r_theta_levels(i,j,k-1)- &
- r_rho_levels(i,j,k-1)
- weight3 = r_rho_levels(i,j,k) - &
- r_theta_levels(i,j,k-1)
+ r_weight1 = 1.0 / (z_uv(i,j,k) - z_uv(i,j,k-1))
+ weight2 = z_tq(i,j,k-1)- z_uv(i,j,k-1)
+ weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
dtldzm(i, j, k) = (weight2 * dtldz(i,j,k) &
+ weight3 * dtldz(i,j,k-1)) * r_weight1
dqwdzm(i, j, k) = (weight2 * dqwdz(i,j,k) &
@@ -807,12 +730,11 @@ SUBROUTINE bdy_expl2_1a ( &
END DO
ELSE
- ! On entry, visc_m is 3D shear(k) on theta-level(k)
DO k = 2, bl_levels
DO j = pdims%j_start, pdims%j_end
DO i = pdims%i_start, pdims%i_end
- dvdzm(i,j,k) = MAX( 1.0e-12 , visc_m(i,j,k-1) )
+ dvdzm(i,j,k) = MAX( 1.0e-12 , shear(i,j,k-1) )
END DO
END DO
END DO
@@ -886,71 +808,6 @@ SUBROUTINE bdy_expl2_1a ( &
END IF ! sg_orog_mixing
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( l_scmdiags(scmdiag_bl) .AND. &
- model_type == mt_single_column ) THEN
-
- TmpScm3d(:,:,1) = 0.0
-
- DO k=2, bl_levels
- DO j=pdims%j_start, pdims%j_end
- jScm = j - pdims%j_start + 1
- DO i=pdims%i_start, pdims%i_end
- iScm = i - pdims%i_start + 1
- TmpScm3d(iScm, jScm, k) = dtldz(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'DTLDZ', &
- 'Vertical gradient of TL', 'K/m', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k=2, bl_levels
- DO j=pdims%j_start, pdims%j_end
- jScm = j - pdims%j_start + 1
- DO i=pdims%i_start, pdims%i_end
- iScm = i - pdims%i_start + 1
- TmpScm3d(iScm, jScm, k) = dqwdz(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'DQWDZ', &
- 'Vertical gradient of QW','1/m', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k=2, bl_levels
- DO j=pdims%j_start, pdims%j_end
- jScm = j - pdims%j_start + 1
- DO i=pdims%i_start, pdims%i_end
- iScm = i - pdims%i_start + 1
- TmpScm3d(iScm, jScm, k) = dbdz(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'DBDZ', &
- 'Vertical gradient of buoyancy','1/ms2', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k=2, bl_levels
- DO j=pdims%j_start, pdims%j_end
- jScm = j - pdims%j_start + 1
- DO i=pdims%i_start, pdims%i_end
- iScm = i - pdims%i_start + 1
- TmpScm3d(iScm, jScm, k) = dvdzm(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'DVDZM', &
- 'Vertical gradient of wind velocity','1/s', &
- t_avg,d_bl,default_streams,'',routinename)
-
- CALL scmoutput(fb_surf,'FB_SURF', &
- 'buoyancy flux at the surface','m2/s3', &
- t_avg,d_sl,default_streams,'',routinename)
-
-END IF ! scmdiag_bl / model_type
!------------------------------------------------------------------
! call main subroutines
@@ -958,25 +815,26 @@ SUBROUTINE bdy_expl2_1a ( &
IF (bdy_tke == mymodel25 .OR. bdy_tke == mymodel3) THEN
CALL mym_ctl( &
!in levels/switches
- bl_levels, bdy_tke, nSCMDpkgs,L_SCMDiags, &
- BL_diag, cycleno, &
+ bl_levels, bdy_tke, &
+ BL_diag, &
!in fields
z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, qcf, bq_gb, bt_gb, &
rho_mix, rho_wet_tq, fqw, ftl, &
- dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, delta_smag, &
p_theta_levels, p_half, u_s, fb_surf, pstar, &
! inout
e_trb, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh, zhpar_shcu, &
! out
- rhogamu, rhogamv, rhogamt, rhogamq)
+ visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq)
ELSE IF (bdy_tke == deardorff) THEN
CALL ddf_ctl( &
! IN levels/switches
- bl_levels, nSCMDpkgs, L_SCMDiags, BL_diag, cycleno, &
+ bl_levels, BL_diag, &
! IN fields
z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, &
qcf, p_theta_levels, p_half,bq_gb, bt_gb, rho_mix, rho_wet_tq, &
- dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, u_s, fb_surf, pstar, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, delta_smag, &
+ u_s, fb_surf, pstar, &
! INOUT fields
e_trb, rhokm, rhokh, zhpar_shcu)
DO k = 2, bl_levels
@@ -1047,11 +905,11 @@ SUBROUTINE bdy_expl2_1a ( &
!-----------------------------------------------------------------------
CALL ex_coef ( &
! IN levels/logicals
- bl_levels,k_log_layr,nSCMDpkgs,L_SCMDiags,BL_diag, &
+ bl_levels,k_log_layr,BL_diag, &
! IN fields
- sigma_h,flandg,dbdz,dvdzm,ri,rho_wet_tq,z_uv,z_tq,z0m_eff_gb, &
- h_blend_orog,zhpar_shcu,ntpar,ntml_nl,ntdsc,nbdsc,u_p,v_p,u_s, &
- fb_surf,qw,tl,l_shallow,rmlmax2, rneutml_sq, delta_smag, &
+ sigma_h,flandg,dvdzm,ri,rho_wet_tq,z_uv,z_tq,z0m_eff_gb,zhnl,zhpar_shcu, &
+ zhsc,zdsc_base,ntpar,ntml_nl,ntdsc,nbdsc,l_shallow,rmlmax2,rneutml_sq, &
+ delta_smag, &
! IN/OUT fields
cumulus,weight_1dbl, &
! OUT fields
@@ -1068,12 +926,9 @@ SUBROUTINE bdy_expl2_1a ( &
DO i = pdims%i_start, pdims%i_end
rhokm(i, j, k) = rhokm_ri(i, j, k)
- weight1 = r_theta_levels(i,j,k) - &
- r_theta_levels(i,j, k-1)
- weight2 = r_theta_levels(i,j,k) - &
- r_rho_levels(i,j,k)
- weight3 = r_rho_levels(i,j,k) - &
- r_theta_levels(i,j,k-1)
+ weight1 = z_tq(i,j,k) - z_tq(i,j, k-1)
+ weight2 = z_tq(i,j,k) - z_uv(i,j,k)
+ weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
IF ( k == bl_levels ) THEN
! assume RHOKH_uv(BL_LEVELS+1) is zero
rhokh(i,j,k) = ( weight2/weight1 ) * rhokh_th_ri(i,j,k)
@@ -1084,7 +939,8 @@ SUBROUTINE bdy_expl2_1a ( &
rhokh_th_ri(i,j,k)
END IF
- IF (local_fa /= free_trop_layers) THEN
+ IF ((local_fa /= free_trop_layers) .and. &
+ (local_fa /= smooth_to_bdys)) THEN
!--------------------------------------------------------
! Code moved from EX_COEF to avoid interpolation:
! Include mixing length, ELH, in RHOKH.
@@ -1111,8 +967,8 @@ SUBROUTINE bdy_expl2_1a ( &
DO k = tke_levels, bl_levels
DO j = pdims%j_start, pdims%j_end
DO i = pdims%i_start, pdims%i_end
- visc_m(i,j,k) = visc_m(i,j,k)*rneutml_sq(i,j,k)
- visc_h(i,j,k) = visc_h(i,j,k)*rneutml_sq(i,j,k)
+ visc_m(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
+ visc_h(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
END DO
END DO
END DO
@@ -1133,8 +989,8 @@ SUBROUTINE bdy_expl2_1a ( &
DO k = 1, bl_levels
DO j = pdims%j_start, pdims%j_end
DO i = pdims%i_start, pdims%i_end
- visc_m(i,j,k) = visc_m(i,j,k)*rneutml_sq(i,j,k)
- visc_h(i,j,k) = visc_h(i,j,k)*rneutml_sq(i,j,k)
+ visc_m(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
+ visc_h(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
END DO
END DO
END DO
@@ -1161,9 +1017,9 @@ SUBROUTINE bdy_expl2_1a ( &
DO k = 2, bl_levels
DO j = pdims%j_start, pdims%j_end
DO i = pdims%i_start, pdims%i_end
- weight1 = r_theta_levels(i,j,k) - r_theta_levels(i,j, k-1)
- weight2 = r_theta_levels(i,j,k) - r_rho_levels(i,j,k)
- weight3 = r_rho_levels(i,j,k) - r_theta_levels(i,j,k-1)
+ weight1 = z_tq(i,j,k) - z_tq(i,j, k-1)
+ weight2 = z_tq(i,j,k) - z_uv(i,j,k)
+ weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
IF ( k == bl_levels ) THEN
! assume visc_h(bl_levels) is zero
! (Ri and thence f_h not defined)
@@ -1276,40 +1132,10 @@ SUBROUTINE bdy_expl2_1a ( &
! Calculation of explicit fluxes of T,Q
!-----------------------------------------------------------------------
CALL mym_ex_flux_tq( &
- bl_levels, nSCMDpkgs, L_SCMDiags, &
+ bl_levels, &
tl, qw, rhokh, rhogamt, rhogamq, rdz_charney_grid, &
ftl, fqw)
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( l_scmdiags(scmdiag_bl) .AND. &
- model_type == mt_single_column ) THEN
-
- CALL scmoutput(u_s,'ustar', &
- 'Explicit surface friction velocity','m/s', &
- t_avg,d_sl,default_streams,'',routinename)
-
- CALL scmoutput(e_trb,'e_trb', &
- 'Turbulent Kinetic Energy','J/kg', &
- t_avg,d_bl,default_streams,'',routinename)
-
- IF (bdy_tke == mymodel25 .OR. bdy_tke == mymodel3) THEN
- CALL scmoutput(tsq_trb,'tsq_trb', &
- 'Self covariance of thetal','K2', &
- t_avg,d_bl,default_streams,'',routinename)
-
- CALL scmoutput(qsq_trb,'qsq_trb', &
- 'Self covariance of qw','kg2/kg2', &
- t_avg,d_bl,default_streams,'',routinename)
-
- CALL scmoutput(cov_trb,'cov_trb', &
- 'Correlation of thetal and qw','K2 kg2/kg2', &
- t_avg,d_bl,default_streams,'',routinename)
- END IF
-
-END IF ! scmdiag_bl / model_type
-
IF (BL_diag%l_rhogamu) THEN
DO k = 2, bl_levels
@@ -1445,151 +1271,6 @@ SUBROUTINE bdy_expl2_1a ( &
END DO
END DO
-! Print the maximum values of the prognostic variables
-IF (l_print_max_tke) THEN
- IF (bdy_tke == mymodel25 .OR. bdy_tke == mymodel3) THEN
- ! for e_trb, tsq, qsq and cov
- e_kind = 4
- ELSE IF (bdy_tke == deardorff) THEN
- ! for e_trb
- e_kind = 1
- END IF
-
- ALLOCATE(max_real(e_kind))
- ALLOCATE(indx_pe(3, e_kind))
- ALLOCATE(max_pe(e_kind))
- ALLOCATE(sumi(4, e_kind))
-
- ! obtain the maximum values on each processor
- DO ikind = 1, e_kind
- IF (ikind == 1) THEN
- max_indices = MAXLOC( &
- e_trb(tdims%i_start:tdims%i_end, &
- tdims%j_start:tdims%j_end,1:tke_levels))
- max_real(ikind) = e_trb( &
- max_indices(1), max_indices(2), max_indices(3))
- ELSE IF (ikind == 2) THEN
- max_indices = MAXLOC( &
- tsq_trb(tdims%i_start:tdims%i_end, &
- tdims%j_start:tdims%j_end,1:tke_levels))
- max_real(ikind) = tsq_trb( &
- max_indices(1), max_indices(2), max_indices(3))
- ELSE IF (ikind == 3) THEN
- max_indices = MAXLOC( &
- qsq_trb(tdims%i_start:tdims%i_end, &
- tdims%j_start:tdims%j_end,1:tke_levels))
- max_real(ikind) = qsq_trb( &
- max_indices(1), max_indices(2), max_indices(3))
- ELSE IF (ikind == 4) THEN
- ALLOCATE(abs_cov(tdims%i_start:tdims%i_end, &
- tdims%j_start:tdims%j_end, tke_levels))
- DO k = 1, tke_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- abs_cov(i, j, k) = ABS(cov_trb(i, j, k))
- END DO
- END DO
- END DO
- max_indices = MAXLOC( &
- abs_cov(tdims%i_start:tdims%i_end, &
- tdims%j_start:tdims%j_end,1:tke_levels))
- max_real(ikind) = abs_cov( &
- max_indices(1), max_indices(2), max_indices(3))
- DEALLOCATE(abs_cov)
- END IF
- indx_pe(1, ikind) = max_indices(1)
- indx_pe(2, ikind) = max_indices(2)
- indx_pe(3, ikind) = max_indices(3)
- max_pe(ikind) = max_real(ikind)
- END DO
-
- SELECT CASE (model_type)
-
- CASE (mt_single_column)
- mype = 0
-
- CASE DEFAULT
- mype = parcore_mype
- ! To avoid the same maximum value at more than two points.
- ! The points in the processor with the largest mype would be
- ! selected as the maximum point
- IF (max_real(1) >= e_trb_max) THEN
- max_real(1) = max_real(1) + mype * e_trb_max * 1.0e-5
- max_pe(1) = max_real(1)
- END IF
-
- ! the maximum values in the whole domain
- CALL gc_rmax(e_kind, nproc, istat_gc, max_real)
-
- END SELECT ! model_type
-
- DO ikind = 1, e_kind
- IF (max_pe(ikind) >= max_real(ikind)) THEN
- ! the maximum is on my pe.
- ! set indices, pe number
- sumi(1, ikind) = indx_pe(1, ikind)
- sumi(2, ikind) = indx_pe(2, ikind)
- sumi(3, ikind) = indx_pe(3, ikind)
- sumi(4, ikind) = mype
- ELSE
- sumi(1, ikind) = 0
- sumi(2, ikind) = 0
- sumi(3, ikind) = 0
- sumi(4, ikind) = 0
- END IF
- END DO
-
- IF (model_type /= mt_single_column) THEN
- ! obtain indices and pe number of the maximum points
- asize = e_kind * 4
- CALL gc_isum(asize, nproc, istat_gc, sumi)
-
- ! Back to the original value (i.e. the maximum limit)
- IF (max_real(1) > e_trb_max) THEN
- max_real(1) = e_trb_max
- END IF
- END IF ! model_type
-
- IF (mype == 0) THEN
- varname(1) = 'e_trb'
- varname(2) = 'tsq '
- varname(3) = 'qsq '
- varname(4) = 'cov '
-
- WRITE(umMessage, '(A)') &
- ' ***** Maximum turbulent variables at this timestep ***** '
- CALL umPrint(umMessage,src='bdy_expl2_1a')
- DO ikind = 1, e_kind
-
- SELECT CASE (model_type)
-
- CASE (mt_single_column)
- ! only with a level number
- WRITE(umMessage, '(A, A, 1X, E12.5, 1X, A, I4)') &
- varname(ikind), ' max:', max_real(ikind), 'at level', &
- sumi(3, ikind)
- CALL umPrint(umMessage,src='bdy_expl2_1a')
-
- CASE DEFAULT
- ! with indices on the local processor and the pe number
- WRITE(umMessage, &
- '(1X, A, A, 1X, E12.5, 1X, A, I4, 1X, I4, 1X, I4, A, I4)') &
- varname(ikind), ' max:', max_real(ikind), 'at (', &
- sumi(1, ikind), sumi(2, ikind), sumi(3, ikind), &
- ') on pe ', sumi(4, ikind)
- CALL umPrint(umMessage,src='bdy_expl2_1a')
-
- END SELECT ! model_type
-
- END DO
- END IF
-
- DEALLOCATE(sumi)
- DEALLOCATE(max_pe)
- DEALLOCATE(indx_pe)
- DEALLOCATE(max_real)
-END IF
-
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
RETURN
END SUBROUTINE bdy_expl2_1a
diff --git a/science/physics_schemes/source/boundary_layer/ddf_ctl.F90 b/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
index dbd85da680..6f913e0d9c 100644
--- a/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
+++ b/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
@@ -15,7 +15,7 @@
!---------------------------------------------------------------------
MODULE ddf_ctl_mod
-USE um_types, ONLY: real_umphys, real_eps
+USE um_types, ONLY: real_umphys
IMPLICIT NONE
@@ -24,30 +24,22 @@ MODULE ddf_ctl_mod
SUBROUTINE ddf_ctl( &
! IN levels/switches
- bl_levels, nSCMDpkgs, L_SCMDiags, BL_diag, cycleno, &
+ bl_levels, BL_diag, &
! IN fields
z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, qcf, &
p_theta_levels, p_half, bq_gb, bt_gb, rho_mix, rho_wet_tq, &
- dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, u_s, fb_surf, pstar, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, delta_smag, u_s, fb_surf, pstar,&
! INOUT fields
e_trb, rhokm, rhokh, zhpar_shcu)
-USE atm_fields_bounds_mod, ONLY: tdims_l, tdims, pdims, tdims_s, &
- ScmRowLen, ScmRow
+USE atm_fields_bounds_mod, ONLY: tdims_l, tdims, pdims, tdims_s
USE bl_diags_mod, ONLY: strnewbldiag
-USE dynamics_input_mod, ONLY: numcycles
USE gen_phys_inputs_mod, ONLY: l_mr_physics
-USE level_heights_mod, ONLY: &
- r_theta_levels, r_rho_levels
-USE missing_data_mod, ONLY: rmdi
USE model_domain_mod, ONLY: model_type, mt_single_column
USE mym_const_mod, ONLY: e_trb_max
USE mym_option_mod, ONLY: my_ini_dbdz_min, tke_cm_mx, l_shcu_buoy, &
l_my_condense, tke_cm_fa, my_lowest_pd_surf, tke_levels, &
l_my_ini_zero, l_my_initialize
-USE s_scmop_mod, ONLY: default_streams, &
- t_avg, d_bl, d_sl, scmdiag_bl
-USE scmoutput_mod, ONLY: scmoutput
USE parkind1, ONLY: jprb, jpim
USE planet_constants_mod, ONLY: vkman, kappa, pref, c_virtual, grcp, g
@@ -64,16 +56,8 @@ SUBROUTINE ddf_ctl( &
! Intent In Variables
INTEGER, INTENT(IN) :: &
- bl_levels, &
+ bl_levels
! Max. no. of "boundary" levels
- cycleno ! Iteration number (EG outer loop)
-
-! Additional variables for SCM diagnostics which are dummy in full UM
-INTEGER, INTENT(IN) :: &
- nSCMDpkgs ! No of SCM diagnostics packages
-
-LOGICAL, INTENT(IN) :: &
- L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
REAL(KIND=real_umphys), INTENT(IN) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
@@ -151,6 +135,8 @@ SUBROUTINE ddf_ctl( &
2:bl_levels), &
! Modulus of wind shear at theta levels.
! (:,:,K) repserents the value on theta level K-1
+ delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN delta_x used by Smagorinsky
u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! Surface friction velocity
fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -181,7 +167,7 @@ SUBROUTINE ddf_ctl( &
! Local Variables
INTEGER :: &
- i, j, k, iScm, jScm
+ i, j, k
! Loop indexes
REAL(KIND=real_umphys) :: &
@@ -315,8 +301,6 @@ SUBROUTINE ddf_ctl( &
! factor of a diffusion coef of E_TRB to that of
! momentum
-! Scm arrays
-REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
CHARACTER(LEN=*), PARAMETER :: RoutineName = 'DDF_CTL'
INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
@@ -383,7 +367,7 @@ SUBROUTINE ddf_ctl( &
! IF the first value of e_trb has been set to be missing by the
! reconfiguration, the initialization for the whole domain
! is essential.
- IF (l_my_initialize .OR. ABS(e_trb(1, 1, 1) - rmdi) < real_eps) THEN
+ IF (l_my_initialize) THEN
IF (l_my_ini_zero) THEN
DO k = 1, bl_levels
DO j = tdims%j_start, tdims%j_end
@@ -408,7 +392,7 @@ SUBROUTINE ddf_ctl( &
END DO
CALL ddf_initialize( &
bl_levels, &
- z_uv, z_tq, dbdz_l, dvdzm, r_mosurf, fb_surf, u_s, h_pbl, &
+ z_uv, z_tq, dbdz_l, dvdzm, delta_smag, r_mosurf, fb_surf, u_s, h_pbl, &
e_trb)
! Above tke_levels, the prognostic variables should be zeros.
DO k = tke_levels + 1, bl_levels
@@ -419,27 +403,21 @@ SUBROUTINE ddf_ctl( &
END DO
END DO
END IF ! test if l_my_ini_zero
- END IF ! test if l_my_initialize .OR. e_trb == rmdi
+ END IF ! test if l_my_initialize
- IF (l_shcu_buoy) THEN
+ IF (l_shcu_buoy .and. l_my_initialize) THEN
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
- IF (ABS(zhpar_shcu(i, j) - rmdi) < real_eps) THEN
- ! if missing has been set by the reconfiguration,
- ! it is replaced with z_tq(tke_levels-1).
- zhpar_shcu(i, j) = z_tq(i, j, tke_levels-1)
- END IF
+ zhpar_shcu(i, j) = z_tq(i, j, tke_levels-1)
END DO
END DO
END IF
- ! need to initialise variables on every cycle as they will have been
- ! reset to mdi
- IF (cycleno == numcycles) l_first = .FALSE.
+ l_first = .FALSE.
END IF
CALL ddf_mix_length( &
tdims%i_end,tdims%j_end,tdims_l%halo_i,tdims_l%halo_j, bl_levels, &
- z_uv, z_tq, dbdz, r_mosurf, fb_surf, h_pbl, e_trb, &
+ z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, h_pbl, e_trb, &
elm, coef_ce, ekw)
! Calculate diffusion coefficients
@@ -453,7 +431,7 @@ SUBROUTINE ddf_ctl( &
END IF
r_pr = 1.0 + 2.0 * elm(i, j, k) &
- / (r_rho_levels(i, j, k) - r_rho_levels(i, j, k - 1))
+ / (z_uv(i, j, k) - z_uv(i, j, k - 1))
rhokm(i, j, k) = coef_cm * elm(i, j, k) * ekw(i, j, k)
rhokh_tq(i, j, k) = rhokm(i, j, k) * r_pr
END DO
@@ -493,7 +471,7 @@ SUBROUTINE ddf_ctl( &
CALL mym_condensation( &
! IN levels/switches
- bl_levels, levflag, nSCMDpkgs,L_SCMDiags, &
+ bl_levels, levflag, &
BL_diag, &
! IN fields
qw, tl, t, p_theta_levels, tsq, qsq, cov, &
@@ -517,7 +495,7 @@ SUBROUTINE ddf_ctl( &
IF (l_shcu_buoy) THEN
CALL mym_shcu_buoy( &
! IN levels/switches
- bl_levels, nSCMDpkgs,L_SCMDiags, BL_diag, &
+ bl_levels, BL_diag, &
! IN fields
fb_surf, u_s, pstar, z_tq, z_uv, p_theta_levels, p_half, &
u_p, v_p, t, q, qcl, qcf, q1, cld, &
@@ -570,55 +548,7 @@ SUBROUTINE ddf_ctl( &
END IF
CALL mym_update_fields( &
- bl_levels, diff_fact, rhokm, prod, disp_coef, e_trb)
-
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( l_scmdiags(scmdiag_bl) .AND. &
- model_type == mt_single_column ) THEN
-
-!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
-!$OMP PRIVATE(i, j, k) &
-!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
- DO k = 1, bl_levels
- DO j = 1, ScmRow
- DO i = 1, ScmRowLen
- TmpScm3d(i,j,k) = 0.0
- END DO
- END DO
- END DO
-!$OMP END PARALLEL DO
-
- DO k=1, bl_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = rhokm(i,j,k)
- END DO ! i
- END DO ! j
- END DO ! k
-
- CALL scmoutput(TmpScm3d,'momdif', &
- 'Diffusivity of momentum','kg/(ms)', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k=1, bl_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = rhokh(i,j,k)
- END DO ! i
- END DO ! j
- END DO ! k
-
- CALL scmoutput(TmpScm3d,'htdiff', &
- 'Diffusivity of heat','kg/(ms)', &
- t_avg,d_bl,default_streams,'',routinename)
-
-END IF ! scmdiag_bl / model_type
+ bl_levels, diff_fact, z_uv, z_tq, rhokm, prod, disp_coef, e_trb)
DO k = tke_levels + 1, bl_levels
DO j = tdims%j_start, tdims%j_end
@@ -656,12 +586,12 @@ SUBROUTINE ddf_ctl( &
DO k = 2, tke_levels - 1
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
- r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
- r_theta_levels(i,j, k-1))
- weight2 = (r_theta_levels(i,j,k) - &
- r_rho_levels(i,j,k)) * r_weight1
- weight3 = (r_rho_levels(i,j,k) - &
- r_theta_levels(i,j,k-1)) * r_weight1
+ r_weight1 = 1.0 / (z_tq(i,j,k) - &
+ z_tq(i,j, k-1))
+ weight2 = (z_tq(i,j,k) - &
+ z_uv(i,j,k)) * r_weight1
+ weight3 = (z_uv(i,j,k) - &
+ z_tq(i,j,k-1)) * r_weight1
rhokh(i,j,k) = &
weight3 * rhokh_tq(i,j,k+1) &
+weight2 * rhokh_tq(i,j,k)
@@ -672,10 +602,10 @@ SUBROUTINE ddf_ctl( &
k = tke_levels
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
- r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
- r_theta_levels(i,j, k-1))
- weight2 = (r_theta_levels(i,j,k) - &
- r_rho_levels(i,j,k)) * r_weight1
+ r_weight1 = 1.0 / (z_tq(i,j,k) - &
+ z_tq(i,j, k-1))
+ weight2 = (z_tq(i,j,k) - &
+ z_uv(i,j,k)) * r_weight1
rhokh(i, j, k) = weight2 * rhokh_tq(i, j, k)
END DO
@@ -754,86 +684,6 @@ SUBROUTINE ddf_ctl( &
END DO
END IF
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( l_scmdiags(scmdiag_bl) .AND. &
- model_type == mt_single_column ) THEN
-
-!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
-!$OMP PRIVATE(i, j, k) &
-!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
- DO k = 1, bl_levels
- DO j = 1, ScmRow
- DO i = 1, ScmRowLen
- TmpScm3d(i,j,k) = 0.0
- END DO
- END DO
- END DO
-!$OMP END PARALLEL DO
-
- CALL scmoutput(h_pbl,'h_pbl', &
- 'BL height by vertical profile of SL','m', &
- t_avg,d_sl,default_streams,'',routinename)
-
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = elm(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'elm', &
- 'mixing length','m', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm, k) = BL_diag%tke_shr_prod(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'tke_shr_prod', &
- 'shear production of TKE','m2/s3', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = BL_diag%tke_boy_prod(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'tke_boy_prod', &
- 'buoyancy production of TKE','m2/s3', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm, jScm, k) = BL_diag%tke_dissp(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'tke_dissp', &
- ' dissipation of TKE','m2/s3', &
- t_avg,d_bl,default_streams,'',routinename)
-
-END IF ! scmdiag_bl / model_type
-
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
RETURN
diff --git a/science/physics_schemes/source/boundary_layer/ddf_initialize.F90 b/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
index a7bb0ab303..2b8b7f2924 100644
--- a/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
+++ b/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
@@ -23,7 +23,7 @@ MODULE ddf_initialize_mod
SUBROUTINE ddf_initialize( &
bl_levels, &
- z_uv, z_tq, dbdz, dvdzm, r_mosurf, fb_surf, u_s, h_pbl, &
+ z_uv, z_tq, dbdz, dvdzm, delta_smag, r_mosurf, fb_surf, u_s, h_pbl, &
e_trb)
USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_s
@@ -62,6 +62,8 @@ SUBROUTINE ddf_initialize( &
2:bl_levels), &
! Modulus of wind shear at theta levels.
! (:,:,K) repserents the value on theta level K-1
+ delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN delta_x used by Smagorinsky
r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! reciprocal of Monin-Obkhov length
fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -175,7 +177,7 @@ SUBROUTINE ddf_initialize( &
DO ll = 1, itr_ini
CALL ddf_mix_length( &
tdims%i_end, tdims%j_end, 0, 0, bl_levels, &
- z_uv, z_tq, dbdz, r_mosurf, fb_surf, h_pbl, e_trb, &
+ z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, h_pbl, e_trb, &
elm, coef_ce, ekw)
DO k = 2, tke_levels
@@ -190,7 +192,7 @@ SUBROUTINE ddf_initialize( &
END DO
CALL mym_diff_matcoef( &
- bl_levels, diff_fact, dfm, aa, bb, cc)
+ bl_levels, diff_fact, z_uv, z_tq, dfm, aa, bb, cc)
DO k = 2, tke_levels
DO j = tdims%j_start, tdims%j_end
@@ -206,7 +208,7 @@ SUBROUTINE ddf_initialize( &
bb(i, j, k) = - bb(i, j, k) &
+ ekw(i, j, k) * coef_ce(i, j, k) &
/ MAX(elm(i, j, k), 1.0e-20)
- bb(i, j, k) = SIGN(MAX(ABS(bb(i, j, k)), 1.0e-20), &
+ bb(i, j, k) = SIGN(MAX(ABS(bb(i, j, k)), 1.0e-20_real_umphys), &
bb(i, j, k))
cc(i, j, k) = - cc(i, j, k)
diff --git a/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90 b/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
index ef9b3732b2..bedfc327f7 100644
--- a/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
+++ b/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
@@ -24,7 +24,7 @@ MODULE ddf_mix_length_mod
SUBROUTINE ddf_mix_length( &
row_length, rows, halo_i, halo_j, bl_levels, &
- z_uv, z_tq, dbdz, r_mosurf, fb_surf, h_pbl, e_trb, &
+ z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, h_pbl, e_trb, &
elm, coef_ce, ekw)
USE mym_option_mod, ONLY: tke_dlen, &
@@ -60,6 +60,8 @@ SUBROUTINE ddf_mix_length( &
! Buoyancy gradient across layer
! interface interpolated to theta levels.
! (:,:,K) repserents the value on theta level K-1
+ delta_smag(row_length,rows), &
+ ! IN delta_x used by Smagorinsky
r_mosurf(row_length, rows), &
! reciprocal of Monin-Obkhov length
fb_surf(row_length,rows), &
@@ -126,7 +128,7 @@ SUBROUTINE ddf_mix_length( &
END DO
CALL mym_length( &
row_length, rows, halo_i, halo_j, bl_levels, &
- qke, z_uv, z_tq, dbdz, r_mosurf, fb_surf, &
+ qke, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, &
qkw, elm)
ELSE IF (tke_dlen == ddf_length &
.OR. tke_dlen == non_local_like_length) THEN
diff --git a/science/physics_schemes/source/boundary_layer/mym_condensation.F90 b/science/physics_schemes/source/boundary_layer/mym_condensation.F90
index f80b704811..fd2e8a02ba 100644
--- a/science/physics_schemes/source/boundary_layer/mym_condensation.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_condensation.F90
@@ -48,13 +48,13 @@ MODULE mym_condensation_mod
SUBROUTINE mym_condensation( &
! IN levels/switches
- bl_levels, levflag, nSCMDpkgs,L_SCMDiags, BL_diag, &
+ bl_levels, levflag, BL_diag, &
! IN fields
qw, tl, t, p_theta_levels, tsq, qsq, cov, &
! OUT fields
vt, vq, q1, cld, ql)
-USE atm_fields_bounds_mod, ONLY: tdims, ScmRowLen, ScmRow
+USE atm_fields_bounds_mod, ONLY: tdims
USE bl_diags_mod, ONLY: strnewbldiag
USE conversions_mod, ONLY: pi
USE gen_phys_inputs_mod, ONLY: l_mr_physics
@@ -64,9 +64,6 @@ SUBROUTINE mym_condensation( &
USE water_constants_mod, ONLY: lc
USE model_domain_mod, ONLY: model_type, mt_single_column
-USE s_scmop_mod, ONLY: default_streams, &
- t_avg, d_bl, scmdiag_bl
-USE scmoutput_mod, ONLY: scmoutput
USE parkind1, ONLY: jprb, jpim
USE yomhook, ONLY: lhook, dr_hook
@@ -105,13 +102,6 @@ SUBROUTINE mym_condensation( &
! Correlation between thetal and qw
! (thetal'qw') defined on theta levels K-1
-! Additional variables for SCM diagnostics which are dummy in full UM
-INTEGER, INTENT(IN) :: nSCMDpkgs
- ! No of SCM diagnostics packages
-
-LOGICAL, INTENT(IN) :: L_SCMDiags(nSCMDpkgs)
- ! Logicals for SCM diagnostics packages
-
! Declaration of BL diagnostics.
TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
@@ -135,7 +125,7 @@ SUBROUTINE mym_condensation( &
! Local Variables
INTEGER :: &
- i, j, k, iScm, jScm
+ i, j, k
! loop indexes
REAL(KIND=real_umphys) :: &
rr2, &
@@ -172,9 +162,6 @@ SUBROUTINE mym_condensation( &
rac
! work variable
-REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
- ! work array for scmoutput
-
REAL(KIND=real_umphys) :: &
rice(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
@@ -238,13 +225,13 @@ SUBROUTINE mym_condensation( &
! factor to set the upper limit for sgm
CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_CONDENSATION'
- ! for scmoutput
INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
REAL(KIND=jprb) :: zhook_handle
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+
rr2 = 1.0 / SQRT(2.0)
rrp = 1.0 / SQRT(2.0 * pi)
@@ -432,85 +419,6 @@ SUBROUTINE mym_condensation( &
END DO
END IF
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( l_scmdiags(scmdiag_bl) .AND. &
- model_type == mt_single_column ) THEN
-
- ! Note that diagnostics here has only "tke_levels" levels.
- ! It is necessary to copy them to an array which has "bl_levels"
-
-!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
-!$OMP PRIVATE(i, j, k) &
-!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
- DO k = 1, bl_levels
- DO j = 1, ScmRow
- DO i = 1, ScmRowLen
- TmpScm3d(i,j,k) = 0.0
- END DO
- END DO
- END DO
-!$OMP END PARALLEL DO
-
- ! for cld
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = cld(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'cf_trb', &
- 'cloud fraction by TKE scheme',' ', &
- t_avg,d_bl,default_streams,'',routinename)
-
- ! for ql
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = ql(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'ql_trb', &
- 'condensed water by TKE scheme','kg/kg', &
- t_avg,d_bl,default_streams,'',routinename)
-
- ! for sgm
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = sgm(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'sgm_trb', &
- 'PDF width by TKE scheme',' ', &
- t_avg,d_bl,default_streams,'',routinename)
-
- ! for Q1
- DO k=1, tke_levels
- DO j=tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i=tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = q1(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'Q1', &
- 'normalized excessive moisture',' ', &
- t_avg,d_bl,default_streams,'',routinename)
-
-END IF ! scmdiag_bl / model_type
-
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
RETURN
diff --git a/science/physics_schemes/source/boundary_layer/mym_ctl.F90 b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
index f791404362..0b183e48c9 100644
--- a/science/physics_schemes/source/boundary_layer/mym_ctl.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
@@ -33,7 +33,7 @@
!---------------------------------------------------------------------
MODULE mym_ctl_mod
-USE um_types, ONLY: real_umphys, real_eps
+USE um_types, ONLY: real_umphys
IMPLICIT NONE
@@ -42,31 +42,26 @@ MODULE mym_ctl_mod
SUBROUTINE mym_ctl( &
! IN levels/switches
- bl_levels, levflag, nSCMDpkgs,L_SCMDiags, &
- BL_diag, cycleno, &
+ bl_levels, levflag, &
+ BL_diag, &
! IN fields
z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, qcf, bq_gb, bt_gb, &
rho_mix, rho_wet_tq, fqw, ftl, &
- dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, &
+ dtldzm, dqwdzm, dudz, dvdz, dbdz, dvdzm, delta_smag, &
p_theta_levels, p_half, u_s, fb_surf, pstar, &
! INOUT fields
e_trb, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh, zhpar_shcu, &
! OUT fields
- rhogamu, rhogamv, rhogamt, rhogamq)
+ visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq)
USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, tdims_s
USE bl_diags_mod, ONLY: strnewbldiag
-USE dynamics_input_mod, ONLY: numcycles
USE gen_phys_inputs_mod, ONLY: l_mr_physics
-USE level_heights_mod, ONLY: &
- r_theta_levels, r_rho_levels
USE mym_option_mod, ONLY: l_my_condense, l_shcu_buoy, &
my_lowest_pd_surf, tke_levels, l_my_initialize, l_my_ini_zero, &
my_ini_dbdz_min, l_3dtke
-USE missing_data_mod, ONLY: rmdi
USE parkind1, ONLY: jprb, jpim
USE planet_constants_mod, ONLY: vkman, kappa, pref, c_virtual, g
-USE turb_diff_ctl_mod, ONLY: visc_m, visc_h
USE yomhook, ONLY: lhook, dr_hook
USE mym_calcphi_mod, ONLY: mym_calcphi
USE mym_condensation_mod, ONLY: mym_condensation
@@ -81,11 +76,10 @@ SUBROUTINE mym_ctl( &
INTEGER, INTENT(IN) :: &
bl_levels, &
! Max. no. of "boundary" levels
- levflag, &
+ levflag
! to indicate the level of the MY model
! 2: level 2.5
! 3: level 3
- cycleno ! Iteration number (EG outer loop)
REAL(KIND=real_umphys), INTENT(IN) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
@@ -169,6 +163,8 @@ SUBROUTINE mym_ctl( &
2:bl_levels), &
! Modulus of wind shear at theta levels.
! (:,:,K) represents the value on theta level K-1
+ delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN delta_x used by Smagorinsky
p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
0:bl_levels+1), &
! Pressure on theta levels (Pa)
@@ -183,13 +179,6 @@ SUBROUTINE mym_ctl( &
pstar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! surface pressure
-! Additional variables for SCM diagnostics which are dummy in full UM
-INTEGER, INTENT(IN) :: &
- nSCMDpkgs ! No of SCM diagnostics packages
-
-LOGICAL, INTENT(IN) :: &
- L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
-
! Intent INOUT variables
REAL(KIND=real_umphys), INTENT(IN OUT) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
@@ -226,6 +215,8 @@ SUBROUTINE mym_ctl( &
! Intent Out Variables
REAL(KIND=real_umphys), INTENT(OUT) :: &
+ visc_m(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
+ visc_h(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
rhogamu(tdims_s%i_start:tdims_s%i_end, &
tdims_s%j_start:tdims_s%j_end,2:bl_levels), &
! Counter gradient terms for TAUX
@@ -342,7 +333,7 @@ SUBROUTINE mym_ctl( &
! IF the first value of e_trb has been set to be missing by the
! reconfiguration, the initialization for the whole domain
! is essential.
- IF (l_my_initialize .OR. ABS(e_trb(1, 1, 1) - rmdi) < real_eps) THEN
+ IF (l_my_initialize) THEN
IF (l_my_ini_zero) THEN
DO k = 1, bl_levels
DO j = tdims%j_start, tdims%j_end
@@ -374,7 +365,7 @@ SUBROUTINE mym_ctl( &
bl_levels, &
! IN fields
z_uv, z_tq, dbdz_l, dvdzm, dtldzm, dqwdzm, &
- fqw, ftl, u_s, r_mosurf, fb_surf, &
+ fqw, ftl, u_s, r_mosurf, fb_surf, delta_smag, &
! INOUT fields
e_trb, tsq_trb, qsq_trb, cov_trb)
@@ -390,22 +381,16 @@ SUBROUTINE mym_ctl( &
END DO
END DO
END IF ! test if l_my_ini_zero
- END IF ! test if l_my_initialize .OR. e_trb == rmdi
+ END IF ! test if l_my_initialize
- IF (l_shcu_buoy) THEN
+ IF (l_shcu_buoy .and. l_my_initialize) THEN
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
- IF (ABS(zhpar_shcu(i, j) - rmdi) < real_eps) THEN
- ! if missing has been set by the reconfiguration,
- ! it is replaced with z_tq(tke_levels-1).
- zhpar_shcu(i,j) = z_tq(i,j,tke_levels-1)
- END IF
+ zhpar_shcu(i,j) = z_tq(i,j,tke_levels-1)
END DO
END DO
END IF
- ! need to initialise variables on every cycle as they will have been
- ! reset to mdi
- IF (cycleno == numcycles) l_first = .FALSE.
+ l_first = .FALSE.
END IF ! IF L_FIRST
! copy e_trb to qke (qke = 2 e_trb)
@@ -434,7 +419,7 @@ SUBROUTINE mym_ctl( &
IF (l_my_condense .OR. l_shcu_buoy) THEN
CALL mym_condensation( &
! IN levels/switches
- bl_levels, levflag, nSCMDpkgs,L_SCMDiags, &
+ bl_levels, levflag, &
BL_diag, &
! IN fields
qw, tl, t, p_theta_levels, tsq_trb, qsq_trb, cov_trb, &
@@ -495,7 +480,7 @@ SUBROUTINE mym_ctl( &
CALL mym_shcu_buoy( &
! IN levels/switches
- bl_levels,nSCMDpkgs,L_SCMDiags, &
+ bl_levels, &
BL_diag, &
! IN fields
fb_surf, u_s, pstar, &
@@ -526,11 +511,11 @@ SUBROUTINE mym_ctl( &
CALL mym_turbulence( &
! IN levels/switches
- bl_levels, levflag, nSCMDpkgs,L_SCMDiags, BL_diag, &
+ bl_levels, levflag, BL_diag, &
! IN fields
z_uv, z_tq, &
vq, vt, gtr, fqw, ftl, wb_ng, &
- dbdz_l, dtldzm, dqwdzm, dvdzm, dudz, dvdz, &
+ dbdz_l, dtldzm, dqwdzm, dvdzm, dudz, dvdz, delta_smag, &
r_mosurf, u_s, fb_surf, pmz, phh, &
! INOUT fields
qke, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh_tq, &
@@ -590,12 +575,12 @@ SUBROUTINE mym_ctl( &
DO k = 2, tke_levels - 1
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
- r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
- r_theta_levels(i,j, k-1))
- weight2 = (r_theta_levels(i,j,k) - &
- r_rho_levels(i,j,k)) * r_weight1
- weight3 = (r_rho_levels(i,j,k) - &
- r_theta_levels(i,j,k-1)) * r_weight1
+ r_weight1 = 1.0 / (z_tq(i,j,k) - &
+ z_tq(i,j, k-1))
+ weight2 = (z_tq(i,j,k) - &
+ z_uv(i,j,k)) * r_weight1
+ weight3 = (z_uv(i,j,k) - &
+ z_tq(i,j,k-1)) * r_weight1
rhokh(i,j,k) = &
weight3 * rhokh_tq(i,j,k+1) &
+weight2 * rhokh_tq(i,j,k)
@@ -612,18 +597,29 @@ SUBROUTINE mym_ctl( &
k = tke_levels
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
- r_weight1 = 1.0 / (r_theta_levels(i,j,k) - &
- r_theta_levels(i,j, k-1))
- weight2 = (r_theta_levels(i,j,k) - &
- r_rho_levels(i,j,k)) * r_weight1
- weight3 = (r_rho_levels(i,j,k) - &
- r_theta_levels(i,j,k-1)) * r_weight1
+ r_weight1 = 1.0 / (z_tq(i,j,k) - &
+ z_tq(i,j, k-1))
+ weight2 = (z_tq(i,j,k) - &
+ z_uv(i,j,k)) * r_weight1
+ weight3 = (z_uv(i,j,k) - &
+ z_tq(i,j,k-1)) * r_weight1
rhokh(i,j,k) = weight2 * rhokh_tq(i,j,k)
rhogamt(i,j,k) = weight2 * rhogamt_tq(i,j,k)
rhogamq(i,j,k) = weight2 * rhogamq_tq(i,j,k)
END DO
END DO
+! Above tke_levels, fluxes should be zero.
+DO k = tke_levels + 1, bl_levels
+ DO j = tdims%j_start, tdims%j_end
+ DO i = tdims%i_start, tdims%i_end
+ rhokh(i, j, k) = 0.0
+ rhogamt(i, j, k) = 0.0
+ rhogamq(i, j, k) = 0.0
+ END DO
+ END DO
+END DO
+
! Finally multiply RHOKH by dry density
IF (l_mr_physics) THEN
DO k = 2, bl_levels
@@ -637,17 +633,6 @@ SUBROUTINE mym_ctl( &
END DO
END IF
-! Above tke_levels, fluxes should be zero.
-DO k = tke_levels + 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- rhokh(i, j, k) = 0.0
- rhogamt(i, j, k) = 0.0
- rhogamq(i, j, k) = 0.0
- END DO
- END DO
-END DO
-
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
RETURN
diff --git a/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90 b/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
index 127e43bbf6..ae3798177c 100644
--- a/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
@@ -22,11 +22,9 @@ MODULE mym_diff_matcoef_mod
CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_DIFF_MATCOEF_MOD'
CONTAINS
-SUBROUTINE mym_diff_matcoef(bl_levels, coef, dfm, aa, bb, cc)
+SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
USE atm_fields_bounds_mod, ONLY: pdims, tdims_s, tdims
-USE level_heights_mod, ONLY: &
- r_theta_levels, r_rho_levels
USE mym_option_mod, ONLY: &
l_my_extra_level, my_z_extra_fact, tke_levels
USE parkind1, ONLY: jprb, jpim
@@ -44,6 +42,12 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, dfm, aa, bb, cc)
! momentum
REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Z_TQ(*,K) is height of theta level k
dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
bl_levels)
! diffusion coefficients for momentum
@@ -93,21 +97,24 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, dfm, aa, bb, cc)
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO k = 1, tke_levels
+k = 1
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ r_dr_theta(i, j, k) = 1.0 / (z_uv(i, j, k + 1) - z_uv(i, j, k))
+ r_dr_rho(i, j, k) = 1.0 / z_tq(i, j, k)
+ weight1(i, j, k) = z_uv(i, j, k) * r_dr_rho(i, j, k)
+ weight2(i, j, k) = (z_tq(i, j, k) - z_uv(i, j, k)) * r_dr_rho(i, j, k)
+ end do
+end do
+
+DO k = 2, tke_levels
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
- r_dr_theta(i, j, k) = 1.0 &
- / (r_rho_levels(i, j, k + 1) - r_rho_levels(i, j, k))
- r_dr_rho(i, j, k) = 1.0 &
- / (r_theta_levels(i, j, k) &
- - r_theta_levels(i, j, k - 1))
-
- weight1(i, j, k) = &
- (r_rho_levels(i, j, k) - r_theta_levels(i, j, k - 1)) &
- * r_dr_rho(i, j, k)
- weight2(i, j, k) = &
- (r_theta_levels(i, j, k) - r_rho_levels(i, j, k)) &
- * r_dr_rho(i, j, k)
+ r_dr_theta(i, j, k) = 1.0 / (z_uv(i, j, k + 1) - z_uv(i, j, k))
+ r_dr_rho(i, j, k) = 1.0 / (z_tq(i, j, k) - z_tq(i, j, k - 1))
+
+ weight1(i, j, k) = (z_uv(i, j, k) - z_tq(i, j, k - 1)) * r_dr_rho(i, j, k)
+ weight2(i, j, k) = (z_tq(i, j, k) - z_uv(i, j, k)) * r_dr_rho(i, j, k)
END DO
END DO
END DO
@@ -173,7 +180,7 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, dfm, aa, bb, cc)
DO i = tdims%i_start, tdims%i_end
aa(i, j, 1) = 0.0
cc(i, j, 1) = coef * dfm(i, j, 2) &
- / ((r_theta_levels(i, j, 1) - r_theta_levels(i, j, 0)) &
+ / (z_tq(i, j, 1) &
* my_z_extra_fact) ** 2
bb(i, j, 1) = - aa(i, j, 1) - cc(i, j, 1)
diff --git a/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90 b/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
index 62f5e21645..379f42f6c6 100644
--- a/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
@@ -23,16 +23,13 @@ MODULE mym_ex_flux_tq_mod
CONTAINS
SUBROUTINE mym_ex_flux_tq( &
- bl_levels, nSCMDpkgs, L_SCMDiags, &
+ bl_levels, &
tl, qw, rhokh, rhogamt, rhogamq, rdz, &
ftl, fqw)
USE atm_fields_bounds_mod, ONLY: tdims, pdims
USE model_domain_mod, ONLY: model_type, mt_single_column
USE planet_constants_mod, ONLY: cp, grcp
-USE s_scmop_mod, ONLY: default_streams, &
- t_avg, d_bl, scmdiag_bl
-USE scmoutput_mod, ONLY: scmoutput
USE yomhook, ONLY: lhook, dr_hook
USE parkind1, ONLY: jprb, jpim
@@ -44,13 +41,6 @@ SUBROUTINE mym_ex_flux_tq( &
bl_levels
! Max. no. of "boundary" levels
-! Additional variables for SCM diagnostics which are dummy in full UM
-INTEGER, INTENT(IN) :: &
- nSCMDpkgs ! No of SCM diagnostics packages
-
-LOGICAL, INTENT(IN) :: &
- L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
-
REAL(KIND=real_umphys), INTENT(IN) :: &
tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
! Liquid/frozen water temperture (K)
@@ -148,39 +138,6 @@ SUBROUTINE mym_ex_flux_tq( &
END DO
END DO
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( l_scmdiags(scmdiag_bl) .AND. &
- model_type == mt_single_column ) THEN
-
- DO k=1, bl_levels
- DO j=tdims%j_start, tdims%j_end
- DO i=tdims%i_start, tdims%i_end
- grad_ftl(i,j,k)= cp * grad_ftl(i,j,k)
- count_grad_ftl(i,j,k) = cp * count_grad_ftl(i,j,k)
- END DO ! i
- END DO ! j
- END DO ! k
-
- CALL scmoutput(grad_ftl,'Grad_ftl', &
- 'Down gradient flux of TL','W/m2', &
- t_avg,d_bl,default_streams,'',routinename)
-
- CALL scmoutput(count_grad_ftl,'CG_ftl', &
- 'Counter gradient part of flux of TL','W/m2', &
- t_avg,d_bl,default_streams,'',routinename)
-
- CALL scmoutput(grad_fqw,'Grad_fqw', &
- 'Down-gradient flux of QW','kg/m2/s', &
- t_avg,d_bl,default_streams,'',routinename)
-
- CALL scmoutput(count_grad_fqw,'CG_fqw', &
- 'Counter gradient part of flux of QW','kg/m2/s', &
- t_avg,d_bl,default_streams,'',routinename)
-
-END IF ! scmdiag_bl / model_type
-
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
RETURN
END SUBROUTINE mym_ex_flux_tq
diff --git a/science/physics_schemes/source/boundary_layer/mym_initialize.F90 b/science/physics_schemes/source/boundary_layer/mym_initialize.F90
index b03ab74764..1e1dcc59f4 100644
--- a/science/physics_schemes/source/boundary_layer/mym_initialize.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_initialize.F90
@@ -48,7 +48,7 @@ SUBROUTINE mym_initialize( &
bl_levels, &
! IN fields
z_uv, z_tq, dbdz, dvdzm, dtldzm, dqwdzm, &
- fqw, ftl, u_s, r_mosurf, fb_surf, &
+ fqw, ftl, u_s, r_mosurf, fb_surf, delta_smag, &
! INOUT fields
e_trb, tsq, qsq, cov)
@@ -114,9 +114,11 @@ SUBROUTINE mym_initialize( &
u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! Surface friction velocity
r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
- fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! Surface flux buoyancy over
! density (m^2/s^3)
+ delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
+ ! IN delta_x used by Smagorinsky
! Intent INOUT Variables
REAL(KIND=real_umphys), INTENT(IN OUT) :: &
@@ -287,6 +289,12 @@ SUBROUTINE mym_initialize( &
CALL mym_level2( &
bl_levels, dbdz, dvdzm, gm, gh, sm, sh)
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ qke_nohalo(i, j, 1) = 0.0
+ end do
+end do
+
DO k = 2, tke_levels
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
@@ -355,7 +363,7 @@ SUBROUTINE mym_initialize( &
DO ll = 1, my3_itr_ini
CALL mym_length( &
tdims%i_end, tdims%j_end, 0, 0, bl_levels, &
- qke_nohalo, z_uv, z_tq, dbdz, r_mosurf, fb_surf, &
+ qke_nohalo, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, &
qkw, el)
DO k = 2, tke_levels
@@ -370,11 +378,11 @@ SUBROUTINE mym_initialize( &
END DO
CALL mym_diff_matcoef( &
- bl_levels, coef_trbvar_diff_tke, dfm, &
+ bl_levels, coef_trbvar_diff_tke, z_uv, z_tq, dfm, &
aa_qke, bb_qke, cc_qke)
CALL mym_diff_matcoef( &
- bl_levels, coef_trbvar_diff, dfm, &
+ bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, &
aa_oth, bb_oth, cc_oth)
DO k = k_start, tke_levels
@@ -405,7 +413,7 @@ SUBROUTINE mym_initialize( &
aa_qke(i, j, k) = - aa_qke(i, j, k)
bb_qke(i, j, k) = - bb_qke(i, j, k) &
+ 2.0 * qkw(i, j, k) / (b1 * el(i, j, k))
- bb_qke(i, j, k) = SIGN(MAX(ABS(bb_qke(i, j, k)), 1.0e-20), &
+ bb_qke(i, j, k) = SIGN(MAX(ABS(bb_qke(i, j, k)), 1.0e-20_real_umphys),&
bb_qke(i, j, k))
cc_qke(i, j, k) = - cc_qke(i, j, k)
@@ -414,7 +422,7 @@ SUBROUTINE mym_initialize( &
aa_oth(i, j, k) = - aa_oth(i, j, k)
bb_oth(i, j, k) = - bb_oth(i, j, k) &
+ 2.0 * qkw(i, j, k) / (b2 * el(i, j, k))
- bb_oth(i, j, k) = SIGN(MAX(ABS(bb_oth(i, j, k)), 1.0e-20), &
+ bb_oth(i, j, k) = SIGN(MAX(ABS(bb_oth(i, j, k)), 1.0e-20_real_umphys),&
bb_oth(i, j, k))
cc_oth(i, j, k) = - cc_oth(i, j, k)
diff --git a/science/physics_schemes/source/boundary_layer/mym_length.F90 b/science/physics_schemes/source/boundary_layer/mym_length.F90
index f1613296b5..4afceb5f1e 100644
--- a/science/physics_schemes/source/boundary_layer/mym_length.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_length.F90
@@ -44,7 +44,7 @@ MODULE mym_length_mod
SUBROUTINE mym_length( &
row_length, rows, halo_i, halo_j, bl_levels, &
- qke, z_uv, z_tq, dbdz, r_mosurf, fb_surf, &
+ qke, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, &
qkw, el)
USE mym_const_mod, ONLY: my_alpha4, one_third, elt_min, my_alpha1, &
@@ -53,7 +53,6 @@ SUBROUTINE mym_length( &
USE parkind1, ONLY: jprb, jpim
USE planet_constants_mod, ONLY: vkman
USE yomhook, ONLY: lhook, dr_hook
-USE turb_diff_ctl_mod, ONLY: delta_smag
USE turb_diff_mod, ONLY: mix_factor
IMPLICIT NONE
@@ -82,6 +81,8 @@ SUBROUTINE mym_length( &
! Buoyancy gradient across layer
! interface interpolated to theta levels.
! (:,:,K) represents the value on theta level K-1
+ delta_smag(row_length,rows), &
+ ! IN delta_x used by Smagorinsky
r_mosurf(row_length, rows), &
! reciprocal of Monin-Obukhov Length
fb_surf(row_length,rows)
diff --git a/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90 b/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
index 1c8c00b1e0..629e6a8636 100644
--- a/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
@@ -25,7 +25,7 @@ MODULE mym_shcu_buoy_mod
SUBROUTINE mym_shcu_buoy( &
! IN levels/switches
- bl_levels,nSCMDpkgs, L_SCMDiags, &
+ bl_levels, &
BL_diag, &
! IN fields
fb_surf, ustar, pstar, &
@@ -34,8 +34,7 @@ SUBROUTINE mym_shcu_buoy( &
! INOUT / OUT fields
zhpar,frac, wb_ng)
-USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, &
- ScmRowLen, ScmRow
+USE atm_fields_bounds_mod, only: tdims, pdims, tdims_l
USE bl_diags_mod, ONLY: strnewbldiag
USE conversions_mod, ONLY: pi
USE gen_phys_inputs_mod, ONLY: l_mr_physics
@@ -44,8 +43,6 @@ SUBROUTINE mym_shcu_buoy( &
USE mym_const_mod, ONLY: one_third
USE planet_constants_mod, ONLY: r, repsilon, pref, kappa, c_virtual, &
recip_kappa, g, lcrcp, ls, lsrcp, grcp
-USE s_scmop_mod, ONLY: default_streams, t_avg, d_bl, d_sl, scmdiag_bl
-USE scmoutput_mod, ONLY: scmoutput
USE timestep_mod, ONLY: timestep
USE water_constants_mod, ONLY: lc, tm
@@ -107,12 +104,6 @@ SUBROUTINE mym_shcu_buoy( &
! function
! (:,:,K) is located at theta level K-1
-! Additional variables for SCM diagnostics which are dummy in full UM
-INTEGER, INTENT(IN) :: &
- nSCMDpkgs ! No of SCM diagnostics packages
-LOGICAL, INTENT(IN) :: &
- L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
-
REAL(KIND=real_umphys), INTENT(IN OUT) :: &
zhpar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! boundary layer height evaluated with Richardson Number
@@ -133,10 +124,8 @@ SUBROUTINE mym_shcu_buoy( &
! local variables
CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_SHCU_BUOY'
-REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen,ScmRow,bl_levels)
- ! work array for scmoutput
-INTEGER :: i, j, k, iScm, jScm, &
+INTEGER :: i, j, k, &
k_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! level for start of parcel ascent
ktpar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -417,9 +406,14 @@ SUBROUTINE mym_shcu_buoy( &
! Calculate temperature and pressure of lifting condensation level
! using approximations from Bolton (1980)
!-----------------------------------------------------------------------
- vap_press = q(i,j,k_par(i,j)) * &
- p_theta_levels(i,j,k_par(i,j)) / ( 100.0*repsilon )
- IF (vap_press >= 0.0) THEN
+ if ( l_mr_physics ) then
+ vap_press = 0.01*q(i,j,k_par(i,j)) * &
+ p_theta_levels(i,j,k_par(i,j)) / ( repsilon+q(i,j,k_par(i,j)) )
+ else
+ vap_press = q(i,j,k_par(i,j)) * &
+ p_theta_levels(i,j,k_par(i,j)) / ( 100.0*repsilon )
+ end if
+ IF (vap_press > 0.0) THEN
t_lcl = 55.0 + 2840.0 / ( 3.5*LOG(t(i,j,k_par(i,j))) &
- LOG(vap_press) - 4.805 )
p_lcl(i,j) = p_theta_levels(i,j,k_par(i,j)) * &
@@ -902,70 +896,6 @@ SUBROUTINE mym_shcu_buoy( &
END DO
END IF
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( L_SCMDiags(scmdiag_bl) .AND. &
- (model_type == mt_single_column) ) THEN
-
- ! Note that diagnostics here has only "shcu_levels" levels.
- ! It is necessary to copy them to an array which has "bl_levels"
-
-!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
-!$OMP PRIVATE(i, j, k) &
-!$OMP SHARED(bl_levels, ScmRow, ScmRowLen, TmpScm3d)
- DO k = 1, bl_levels
- DO j = 1, ScmRow
- DO i = 1, ScmRowLen
- TmpScm3d(i,j,k) = 0.0
- END DO
- END DO
- END DO
-!$OMP END PARALLEL DO
-
- ! for WB_NG
- DO k = 1, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm, jScm, k) = wb_ng(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'WB_NG', &
- 'Non-gradinet buoyancy flux',' ', &
- t_avg, d_bl, default_streams, '', routinename)
-
- ! for FRAC
- DO k = 1, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm, jScm, k) = frac(i, j, k)
- END DO
- END DO
- END DO
- CALL scmoutput(TmpScm3d,'CF_NL', &
- 'non-local cloud fraction',' ', &
- t_avg, d_bl, default_streams, '', routinename)
-
- CALL scmoutput(cape,'CAPE_scu', &
- 'CAPE',' ', &
- t_avg, d_sl, default_streams, '', routinename)
-
- CALL scmoutput(z_lcl,'zlcl_scu', &
- 'Z_LCL',' ', &
- t_avg, d_sl, default_streams, '', routinename)
-
- CALL scmoutput(zhpar,'zhpar_scu', &
- 'ZHPAR',' ', &
- t_avg, d_sl, default_streams, '', routinename)
-
-END IF
-
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
RETURN
END SUBROUTINE mym_shcu_buoy
diff --git a/science/physics_schemes/source/boundary_layer/mym_turbulence.F90 b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
index 5a283e6e50..ece19cf3e5 100644
--- a/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
@@ -45,19 +45,18 @@ MODULE mym_turbulence_mod
SUBROUTINE mym_turbulence( &
! IN levels/switches
- bl_levels, levflag, nSCMDpkgs,L_SCMDiags, BL_diag, &
+ bl_levels, levflag, BL_diag, &
! IN fields
z_uv, z_tq, &
vq, vt, gtr, fqw, ftl, wb_ng, &
- dbdz, dtldz, dqwdz, dvdzm, dudz, dvdz, &
+ dbdz, dtldz, dqwdz, dvdzm, dudz, dvdz, delta_smag, &
r_mosurf, u_s, fb_surf, pmz, phh, &
! INOUT fields
qke, tsq, qsq, cov, dfm, dfh, &
! OUT fields
dfu_cg, dfv_cg, dft_cg, dfq_cg)
-USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, tdims_s, &
- ScmRowLen, ScmRow
+USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, tdims_s
USE bl_diags_mod, ONLY: strnewbldiag
USE conversions_mod, ONLY: pi
USE mym_const_mod, ONLY: e1c,e2c,e3c,e4c,e5c,a1,a2,c1,b2,qke_max, &
@@ -69,9 +68,6 @@ SUBROUTINE mym_turbulence( &
l_my_lowest_pd_surf_tqc
USE model_domain_mod, ONLY: model_type, mt_single_column
-USE s_scmop_mod, ONLY: default_streams, &
- t_avg, d_bl, scmdiag_bl
-USE scmoutput_mod, ONLY: scmoutput
USE parkind1, ONLY: jprb, jpim
USE planet_constants_mod, ONLY: vkman
@@ -149,6 +145,8 @@ SUBROUTINE mym_turbulence( &
2:bl_levels), &
! Gradient of v at theta levels.
!(:,:,K) repserents the value on theta level K-1
+ delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
+ ! IN delta_x used by Smagorinsky
r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! reciprocal of Monin-Obukhov length
u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -160,13 +158,6 @@ SUBROUTINE mym_turbulence( &
phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! gradient function for scalars at surface
-! Additional variables for SCM diagnostics which are dummy in full UM
-INTEGER, INTENT(IN) :: &
- nSCMDpkgs ! No of SCM diagnostics packages
-
-LOGICAL, INTENT(IN) :: &
- L_SCMDiags(nSCMDpkgs) ! Logicals for SCM diagnostics packages
-
! Intent INOUT Variables
REAL(KIND=real_umphys), INTENT(IN OUT) :: &
qke(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
@@ -217,7 +208,7 @@ SUBROUTINE mym_turbulence( &
! Local variables
! Scalar
INTEGER :: &
- i, j, k, k_start, k_start_cor, iScm, jScm
+ i, j, k, k_start, k_start_cor
! Loop indexes
REAL(KIND=real_umphys) :: &
@@ -445,8 +436,6 @@ SUBROUTINE mym_turbulence( &
! mode to integrate covariances
CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_TURBULENCE'
-! work variable for scmoutput
-REAL(KIND=real_umphys) :: TmpScm3d(ScmRowLen, ScmRow, bl_levels)
INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
@@ -464,7 +453,7 @@ SUBROUTINE mym_turbulence( &
CALL mym_length( &
tdims%i_end,tdims%j_end,tdims_l%halo_i,tdims_l%halo_j,bl_levels, &
- qke, z_uv, z_tq, dbdz, r_mosurf, fb_surf, qkw, el)
+ qke, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, qkw, el)
DO k = 2, tke_levels
DO j = tdims%j_start, tdims%j_end
@@ -890,7 +879,7 @@ SUBROUTINE mym_turbulence( &
END DO
END IF
-IF (BL_diag%l_tke_boy_prod) THEN
+IF (BL_diag%l_tke_dissp) THEN
DO k = k_start, tke_levels
DO j = tdims%j_start, tdims%j_end
DO i = tdims%i_start, tdims%i_end
@@ -909,6 +898,7 @@ SUBROUTINE mym_turbulence( &
! IN levels
bl_levels, &
! IN fields
+ z_uv, z_tq, &
qkw, el, dfm, pdt_tsq, pdt_cov, pdt, &
pdq_qsq, pdq_cov, pdq, pdc_cov, pdc_tsq, pdc_qsq, pdc, &
! INOUT fields
@@ -984,13 +974,13 @@ SUBROUTINE mym_turbulence( &
END DO
END IF
CALL mym_update_fields( &
- bl_levels, coef_trbvar_diff,dfm, rp_tsq, bp_tsq,tsq)
+ bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, rp_tsq, bp_tsq,tsq)
CALL mym_update_fields( &
- bl_levels, coef_trbvar_diff,dfm, rp_qsq, bp_qsq,qsq)
+ bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, rp_qsq, bp_qsq,qsq)
CALL mym_update_fields( &
- bl_levels, coef_trbvar_diff,dfm, rp_cov, bp_cov,cov)
+ bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, rp_cov, bp_cov,cov)
DEALLOCATE(rp_cov)
DEALLOCATE(bp_cov)
@@ -1076,7 +1066,7 @@ SUBROUTINE mym_turbulence( &
END DO
CALL mym_update_fields( &
- bl_levels, coef_trbvar_diff_tke,dfm, rp, bp, qke)
+ bl_levels, coef_trbvar_diff_tke, z_uv, z_tq, dfm, rp, bp, qke)
ELSE
! level 2
! diagnose qke
@@ -1118,228 +1108,6 @@ SUBROUTINE mym_turbulence( &
END DO
END DO
-!-----------------------------------------------------------------------
-! SCM Boundary Layer Diagnostics Package
-!-----------------------------------------------------------------------
-IF ( L_SCMDiags(scmdiag_bl) .AND. &
- (model_type == mt_single_column) ) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- sm(i,j,1) = 0.0
- sh(i,j,1) = 0.0
- gamt_factor(i,j,1) = 1.0
- gamq_factor(i,j,1) = 1.0
- pdc_factor(i,j,1) = 1.0
- END DO
- END DO
-
- ! Note that each diagnostics here has only "tke_levels" levels.
- ! It is necessary to copy them to an array which has "bl_levels"
- TmpScm3d(:, :, :) = 0.0
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = sm(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'sm', &
- 'non-dim diffusion coefficient for momentum', ' ', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = sh(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'sh', &
- 'non-dim diffusion coefficient for heat', ' ', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = dfm(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'momdif', &
- 'Diffusivity of momentum','kg/(ms)', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = dfh(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'htdiff', &
- 'Diffusivity of heat','kg/(ms)', &
- t_avg,d_bl,default_streams,'',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = el(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'elm', &
- 'mixing length','m', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = BL_diag%tke_shr_prod(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'tke_shr_prod', &
- 'shear production of TKE','m2/s3', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = BL_diag%tke_boy_prod(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'tke_boy_prod', &
- 'buoyancy production of TKE','m2/s3', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = BL_diag%tke_dissp(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'tke_dissp', &
- ' dissipation of TKE','m2/s3', &
- t_avg, d_bl, default_streams, '',routinename)
-
- IF (levflag == 3) THEN
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = gamt_factor(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'gamt_factor', &
- 'stability factor for gamt',' ', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = gamq_factor(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'gamq_factor', &
- 'stability factor for gamt',' ', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = pdc_factor(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'pdc_factor', &
- 'stability factor for pdc',' ', &
- t_avg, d_bl, default_streams, '',routinename)
- END IF ! if levflag == 3
-
- TmpScm3d(:,:,1) = 0.0
- DO k = 2, bl_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = vt(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'vt', &
- 'buoyancy parameter for heat','', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 2, bl_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = vq(i, j, k)
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'vq', &
- 'buoyancy parameter for moisture','', &
- t_avg, d_bl, default_streams, '',routinename)
-
- DO k = 2, bl_levels
- DO j = tdims%j_start, tdims%j_end
- jScm = j - tdims%j_start + 1
- DO i = tdims%i_start, tdims%i_end
- iScm = i - tdims%i_start + 1
- TmpScm3d(iScm,jScm,k) = - gh(i, j, k) &
- / MAX( gm(i, j, k), 1.0e-10 )
- END DO
- END DO
- END DO
-
- CALL scmoutput(TmpScm3d,'grad_ri', &
- 'gradient Richardson number','', &
- t_avg, d_bl, default_streams, '',routinename)
-
-END IF ! L_SCMDiags(SCMDiag_bl) / model_type
-
-
IF (BL_diag%l_elm) THEN
DO k = 2, tke_levels
DO j = tdims%j_start, tdims%j_end
diff --git a/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90 b/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
index 77fa240952..7f2e6b6b7f 100644
--- a/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
@@ -27,12 +27,13 @@ SUBROUTINE mym_update_covariance( &
! IN levels
bl_levels, &
! IN fields
+ z_uv, z_tq, &
qkw, el, dfm, pdt_tsq, pdt_cov, pdt_res, &
pdq_qsq, pdq_cov, pdq_res, pdc_cov, pdc_tsq, pdc_qsq, pdc_res, &
! INOUT fields
tsq, qsq, cov)
-USE atm_fields_bounds_mod, ONLY: tdims, tdims_s
+USE atm_fields_bounds_mod, ONLY: tdims, tdims_s, pdims
USE mym_const_mod, ONLY: b2, coef_trbvar_diff
USE mym_option_mod, ONLY: l_my_extra_level, tke_levels
USE timestep_mod, ONLY: timestep
@@ -48,6 +49,12 @@ SUBROUTINE mym_update_covariance( &
! Max. no. of "boundary" level
REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ ! Z_UV(*,K) is height of u level k
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Z_TQ(*,K) is height of theta level k.
qkw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! sqrt(qke) = sqrt(2TKE)
@@ -162,7 +169,7 @@ SUBROUTINE mym_update_covariance( &
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
CALL mym_diff_matcoef( &
- bl_levels,coef_trbvar_diff, dfm, aa, bb, cc)
+ bl_levels,coef_trbvar_diff, z_uv, z_tq, dfm, aa, bb, cc)
IF (l_my_extra_level) THEN
k_start = 1
diff --git a/science/physics_schemes/source/boundary_layer/mym_update_fields.F90 b/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
index 8504b259a5..6c2eaf30ce 100644
--- a/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
@@ -22,7 +22,7 @@ MODULE mym_update_fields_mod
CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_UPDATE_FIELDS_MOD'
CONTAINS
-SUBROUTINE mym_update_fields(bl_levels,coef,dfm,prod,disp_coef,field)
+SUBROUTINE mym_update_fields(bl_levels,coef,z_uv,z_tq,dfm,prod,disp_coef,field)
USE atm_fields_bounds_mod, ONLY: pdims, pdims_l, tdims, tdims_s
USE mym_option_mod, ONLY: l_my_extra_level, tke_levels
@@ -44,6 +44,11 @@ SUBROUTINE mym_update_fields(bl_levels,coef,dfm,prod,disp_coef,field)
! momentum
REAL(KIND=real_umphys), INTENT(IN) :: &
+ z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
+ bl_levels+1), &
+ z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
+ bl_levels), &
+ ! Z_TQ(*,K) is height of theta level k
dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
bl_levels), &
! diffusion coefficients for momentum
@@ -81,7 +86,7 @@ SUBROUTINE mym_update_fields(bl_levels,coef,dfm,prod,disp_coef,field)
IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
! Calculate the coefficients of tri-diagonal eqs. due to diffusion
-CALL mym_diff_matcoef(bl_levels, coef, dfm, aa, bb, cc)
+CALL mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
IF (l_my_extra_level) THEN
k_start = 1
From 6a5b4367bb1213e017ecc2521f858505cf352619 Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Wed, 29 Jul 2026 14:47:11 +0100
Subject: [PATCH 3/9] Convert real_umphys into r_bl & Apply LFRic code styling
script (lfric_styling.py).
---
.../source/boundary_layer/bdy_expl2_1a.F90 | 846 +++++++++---------
.../source/boundary_layer/ddf_ctl.F90 | 522 +++++------
.../source/boundary_layer/ddf_initialize.F90 | 212 ++---
.../source/boundary_layer/ddf_mix_length.F90 | 198 ++--
.../source/boundary_layer/mym_calcphi.F90 | 134 +--
.../boundary_layer/mym_condensation.F90 | 274 +++---
.../source/boundary_layer/mym_const_mod.F90 | 12 +-
.../source/boundary_layer/mym_const_set.F90 | 46 +-
.../source/boundary_layer/mym_ctl.F90 | 388 ++++----
.../boundary_layer/mym_diff_matcoef.F90 | 124 +--
.../source/boundary_layer/mym_errfunc.F90 | 76 +-
.../source/boundary_layer/mym_ex_flux_tq.F90 | 78 +-
.../source/boundary_layer/mym_ex_flux_uv.F90 | 90 +-
.../source/boundary_layer/mym_implic.F90 | 76 +-
.../source/boundary_layer/mym_initialize.F90 | 280 +++---
.../source/boundary_layer/mym_length.F90 | 156 ++--
.../source/boundary_layer/mym_level2.F90 | 76 +-
.../source/boundary_layer/mym_option_mod.F90 | 16 +-
.../source/boundary_layer/mym_shcu_buoy.F90 | 554 ++++++------
.../boundary_layer/mym_simeq_ilud2_decmp.F90 | 52 +-
.../boundary_layer/mym_simeq_matrix_prod.F90 | 48 +-
.../source/boundary_layer/mym_solve_simeq.F90 | 84 +-
.../mym_solve_simeq_bcgstab.F90 | 136 +--
.../boundary_layer/mym_solve_simeq_ilud2.F90 | 86 +-
.../boundary_layer/mym_solve_simeq_lud.F90 | 120 +--
.../source/boundary_layer/mym_turbulence.F90 | 620 ++++++-------
.../boundary_layer/mym_update_covariance.F90 | 104 +--
.../boundary_layer/mym_update_fields.F90 | 92 +-
28 files changed, 2750 insertions(+), 2750 deletions(-)
diff --git a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90 b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
index 32b07dd000..8324db6595 100644
--- a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
+++ b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
@@ -15,17 +15,17 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE bdy_expl2_1a_mod
+module bdy_expl2_1a_mod
-USE UM_ParCore, ONLY: parcore_mype => mype
-USE um_types, ONLY: real_umphys
+use UM_ParCore, only: parcore_mype => mype
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'BDY_EXPL2_1A_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'BDY_EXPL2_1A_MOD'
+contains
-SUBROUTINE bdy_expl2_1a ( &
+subroutine bdy_expl2_1a ( &
! IN values defining vertical grid of model atmosphere :
bl_levels,p_theta_levels,land_pts,land_index, &
! IN U, V and W momentum fields.
@@ -60,46 +60,46 @@ SUBROUTINE bdy_expl2_1a ( &
zhsc,ntdsc,nbdsc,wstar,wthvs,uw0,vw0 &
)
-USE atm_fields_bounds_mod, ONLY: pdims, tdims, tdims_l, &
+use atm_fields_bounds_mod, only: pdims, tdims, tdims_l, &
pdims_s
-USE bl_option_mod, ONLY: t_drain, h_scale, sg_orog_mixing, local_fa, &
+use bl_option_mod, only: t_drain, h_scale, sg_orog_mixing, local_fa, &
free_trop_layers, smooth_to_bdys, one_third, sg_shear, &
sg_shear_enh_lambda
-USE bl_diags_mod, ONLY: strnewbldiag
-USE cv_run_mod, ONLY: l_param_conv
-USE gen_phys_inputs_mod, ONLY: l_mr_physics
-USE jules_surface_mod, ONLY: formdrag, explicit_stress
-USE mym_option_mod, ONLY: &
+use bl_diags_mod, only: strnewbldiag
+use cv_run_mod, only: l_param_conv
+use gen_phys_inputs_mod, only: l_mr_physics
+use jules_surface_mod, only: formdrag, explicit_stress
+use mym_option_mod, only: &
bdy_tke, deardorff, mymodel25, mymodel3, tke_levels, &
l_local_above_tkelvs, l_3dtke
-USE planet_constants_mod, ONLY: cp, g, vkman
-USE turb_diff_mod, ONLY: &
+use planet_constants_mod, only: cp, g, vkman
+use turb_diff_mod, only: &
l_subfilter_vert, l_subfilter_horiz, mix_factor, &
turb_startlev_vert, turb_endlev_vert
-USE water_constants_mod, ONLY: lc
+use water_constants_mod, only: lc
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
-USE ddf_ctl_mod, ONLY: ddf_ctl
-USE ex_coef_mod, ONLY: ex_coef
-USE mym_ctl_mod, ONLY: mym_ctl
-USE mym_ex_flux_tq_mod, ONLY: mym_ex_flux_tq
-USE fm_drag_mod, ONLY: fm_drag
+use ddf_ctl_mod, only: ddf_ctl
+use ex_coef_mod, only: ex_coef
+use mym_ctl_mod, only: mym_ctl
+use mym_ex_flux_tq_mod, only: mym_ex_flux_tq
+use fm_drag_mod, only: fm_drag
-IMPLICIT NONE
+implicit none
! Inputs :-
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
land_pts, &
! No.of land points in whole grid.
bl_levels
! IN Max. no. of "boundary" levels
! Declaration of new BL diagnostics.
-TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+type (strnewbldiag), intent(in out) :: BL_diag
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
0:bl_levels+1), &
rho_mix(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
@@ -150,7 +150,7 @@ SUBROUTINE bdy_expl2_1a ( &
! IN A grid-box mean buoyancy param
! on p,T,q-levels (full levels).
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
flandg(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end), &
! IN Land fraction on all tiles
p_rho_levs(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end, &
@@ -162,7 +162,7 @@ SUBROUTINE bdy_expl2_1a ( &
! (f) Atmospheric + any other data not covered so far, incl control.
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! IN Surface flux buoyancy over
! density (m^2/s^3)
@@ -184,7 +184,7 @@ SUBROUTINE bdy_expl2_1a ( &
shear(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels)
! IN 3D Wind shear parameter
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
u_0_px(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end), &
! IN W'ly component of surface
! current (m/s). P grid
@@ -202,12 +202,12 @@ SUBROUTINE bdy_expl2_1a ( &
! IN Effective grid-box roughness
! length for momentum
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
land_index(land_pts) ! IN LAND_INDEX(I)=J => the Jth
! point in P_FIELD is the Ith
! land point.
! (e) Cloud data.
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
qcf(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
tdims_l%k_start:bl_levels), &
! IN Cloud ice (kg per kg air)
@@ -225,7 +225,7 @@ SUBROUTINE bdy_expl2_1a ( &
! IN Ice/liquid water temperature
! INOUT variables
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
zh(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! INOUT Height above surface of top
! of boundary layer (metres).
@@ -242,12 +242,12 @@ SUBROUTINE bdy_expl2_1a ( &
rhokh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels)
! INOUT Exchange coeffs for moisture.
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
rhokm(pdims_s%i_start:pdims_s%i_end, &
pdims_s%j_start:pdims_s%j_end ,bl_levels)
! Exchange coefficients for momentum on P-grid
! INOUT but not used: variables used in the 1A version (TKE-based schemes)
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
tsq_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
@@ -258,14 +258,14 @@ SUBROUTINE bdy_expl2_1a ( &
bl_levels), &
zhpar_shcu(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
-LOGICAL, INTENT(IN OUT) :: &
+logical, intent(in out) :: &
cumulus(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! INOUT Logical switch for trade Cu
l_shallow(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
! INOUT Flag to indicate shallow
! convection
-INTEGER, INTENT(IN OUT) :: &
+integer, intent(in out) :: &
ntml(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! INOUT Number of model layers in the
! turbulently mixed layer
@@ -275,7 +275,7 @@ SUBROUTINE bdy_expl2_1a ( &
! Outputs :-
! (a) Calculated anyway (use STASH space from higher level) :-
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
visc_m(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
! Diffusion coefficient for momentum
visc_h(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
@@ -321,7 +321,7 @@ SUBROUTINE bdy_expl2_1a ( &
! Shear-dominated unstable b.l.
! diagnosed, 0.0 otherwise.
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
wstar(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! OUT Convective velocity scale (m/s)
wthvs(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
@@ -352,7 +352,7 @@ SUBROUTINE bdy_expl2_1a ( &
zhsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
! OUT Top of decoupled layer
-INTEGER, INTENT(OUT) :: &
+integer, intent(out) :: &
ntdsc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! OUT Top level for turb mixing in
! any decoupled Sc layer
@@ -365,7 +365,7 @@ SUBROUTINE bdy_expl2_1a ( &
! OUT grid-level of DSC inversion
!-2 Genuinely output, needed by other atmospheric routines :-
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
uw0(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! OUT U-component of surface wind stress
! on P-grid
@@ -383,10 +383,10 @@ SUBROUTINE bdy_expl2_1a ( &
! factors for all the interfaces treated by the boundary layer scheme;
! this would be desirable theoretically but expensive computationally
! because of the use of the log function.
-INTEGER, PARAMETER :: k_log_layr = 2
+integer, parameter :: k_log_layr = 2
!-----------------------------------------------------------------------
! Workspace :-
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Buoyancy gradient across layer
@@ -438,10 +438,10 @@ SUBROUTINE bdy_expl2_1a ( &
rneutml_sq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels)
! Square of the neutral mixing length scale
-REAL(KIND=real_umphys), ALLOCATABLE :: visc_h_rho (:,:,:)
+real(kind=r_bl), allocatable :: visc_h_rho (:,:,:)
! visc_h on rho levels
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
zh_local(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! Height above surface of top of
! boundary layer (metres) as
@@ -477,7 +477,7 @@ SUBROUTINE bdy_expl2_1a ( &
! Gradient of v at theta levels.
!(:,:,K) repserents the value on theta level K-1
-INTEGER :: &
+integer :: &
ntml_local(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! Number of model layers in the
! turbulently mixed layer as
@@ -488,7 +488,7 @@ SUBROUTINE bdy_expl2_1a ( &
! turbulently mixed layer as
! determined from the parcel ascent.
-LOGICAL :: &
+logical :: &
unstable(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
! Logical switch for unstable
! surface layer.
@@ -496,7 +496,7 @@ SUBROUTINE bdy_expl2_1a ( &
! Flag set if decoupled
! stratocumulus layer found
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
rhogamt(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
2:bl_levels), &
! Counter gradient terms for TL
@@ -506,12 +506,12 @@ SUBROUTINE bdy_expl2_1a ( &
! Counter gradient terms for QW
! defined at rho levels
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
lambda_min
! Min value of length scale LAMBDA.
! Local scalars :-
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
weight1, &
weight2, &
weight3, &
@@ -522,7 +522,7 @@ SUBROUTINE bdy_expl2_1a ( &
! subgrid orographic slope
grcp ! G/CP
-INTEGER :: &
+integer :: &
i,j, &
! LOCAL Loop counter (horizontal field index).
k,ient, &
@@ -530,37 +530,37 @@ SUBROUTINE bdy_expl2_1a ( &
l
! LOCAL Loop counter for land points
-CHARACTER(LEN=*), PARAMETER :: RoutineName = 'BDY_EXPL2_1A'
+character(len=*), parameter :: RoutineName = 'BDY_EXPL2_1A'
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
! Parameter check
! error checking here moved to readsize/scm_shell
! set pressure array.
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
p_half(i,j,1) = pstar(i,j)
- END DO
-END DO
-DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ end do
+end do
+do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
p_half(i,j,k) = p_rho_levs(i,j,k)
- END DO
- END DO
-END DO ! end of loop over bl_levels
+ end do
+ end do
+end do ! end of loop over bl_levels
!-----------------------------------------------------------------------
-IF (formdrag == explicit_stress) THEN
+if (formdrag == explicit_stress) then
!------------------------------------------------------------------
! Calculate stress profiles
!------------------------------------------------------------------
- CALL fm_drag ( &
+ call fm_drag ( &
! IN levels
land_pts, land_index, bl_levels, &
! IN fields
@@ -575,59 +575,59 @@ SUBROUTINE bdy_expl2_1a ( &
!------------------------------------------------------------------
! Orographic stress diagnostics
!------------------------------------------------------------------
- IF (BL_diag%l_ostressx) THEN
- DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (BL_diag%l_ostressx) then
+ do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%ostressx(i,j,k)=tau_fd_x(i,j,k)
- END DO
- END DO
- END DO
- END IF
- IF (BL_diag%l_ostressy) THEN
- DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+ end if
+ if (BL_diag%l_ostressy) then
+ do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%ostressy(i,j,k)=tau_fd_y(i,j,k)
- END DO
- END DO
- END DO
- END IF
+ end do
+ end do
+ end do
+ end if
-END IF
+end if
!------------------------------------------------------------------
! Initialize weighting applied to 1d BL scheme
! (used to blend 1D with 3D Smagorinsky scheme)
!------------------------------------------------------------------
-DO k = 1, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = 1, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
weight_1dbl(i,j,k) = 1.0
weight_1dbl_rho(i,j,k) = 1.0 ! dummy here
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
!------------------------------------------------------------------
! Initialize fluxes
!------------------------------------------------------------------
-DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
ftl(i,j,k) = 0.0
fqw(i,j,k) = 0.0
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
!-------------------------------------------------------------
! Set all variables from the non-local scheme to zero or "off"
! - reset all fluxes and K's arising from the non-local scheme
!-------------------------------------------------------------
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
ntml_nl(i,j) = ntml(i,j)
! decoupled mixed layer
- dsc(i,j) = .FALSE.
+ dsc(i,j) = .false.
ntdsc(i,j) = 0
nbdsc(i,j) = 0
zhsc(i,j) = 0.0
@@ -636,50 +636,50 @@ SUBROUTINE bdy_expl2_1a ( &
! entrainment variables for non-local tracer mixing
kent(i,j) = 2
kent_dsc(i,j) = 2
- DO ient = 1, 3
+ do ient = 1, 3
t_frac(i,j,ient) = 0.0
zrzi(i,j,ient) = 0.0
we_lim(i,j,ient) = 0.0
t_frac_dsc(i,j,ient) = 0.0
zrzi_dsc(i,j,ient) = 0.0
we_lim_dsc(i,j,ient) = 0.0
- END DO
+ end do
unstable(i,j) = (fb_surf(i,j) > 0.0)
- END DO
-END DO
+ end do
+end do
! for compatibility to the original bdy_expl2
-IF (l_subfilter_vert) THEN
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- cumulus(i,j) = .FALSE.
- l_shallow(i,j) = .FALSE.
+if (l_subfilter_vert) then
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
+ cumulus(i,j) = .false.
+ l_shallow(i,j) = .false.
ntpar(i,j) = 0
ntml_nl(i,j) = -1 ! to ensure correct diagnostics
- END DO
- END DO
-END IF
+ end do
+ end do
+end if
!-----------------------------------------------------------------------
! Calculate lapse rates
!-----------------------------------------------------------------------
grcp = g/cp
-DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
dtldz(i,j,k) = ( tl(i,j,k) - tl(i,j,k-1) ) &
* rdz_charney_grid(i,j,k) + grcp
dqwdz(i,j,k) = ( qw(i,j,k) - qw(i,j,k-1) ) &
* rdz_charney_grid(i,j,k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Calculate `buoyancy' gradient, DBDZ, on theta-levels
! NOTE: DBDZ(K) is on theta-level K-1
-DO k = 3, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = 3, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
r_weight1 = 1.0 / (z_uv(i,j,k) - z_uv(i,j,k-1))
weight2 = z_tq(i,j,k-1)- z_uv(i,j,k-1)
weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
@@ -689,131 +689,131 @@ SUBROUTINE bdy_expl2_1a ( &
+ weight3 * dqwdz(i,j,k-1)) * r_weight1
dbdz(i,j,k) = g*( bt_gb(i,j,k-1)*dtldzm(i, j, k) + &
bq_gb(i,j,k-1)*dqwdzm(i, j, k))
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
k = 2
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
dtldzm(i,j,k) = dtldz(i,j,k)
dqwdzm(i,j,k) = dqwdz(i,j,k)
dbdz(i,j,k) = g*( bt_gb(i,j,k-1)*dtldz(i,j,k) + &
bq_gb(i,j,k-1)*dqwdz(i,j,k) )
- END DO
-END DO
+ end do
+end do
!--------------------------------------------------
! Calculate modulus of shear on theta-levels
! dvdzm(k) is on theta-level(k-1)
!--------------------------------------------------
-DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
! Calculation of dudz, dvdz is temporary until use of shear terms
! is sorted.
dudz(i, j, k) = (u_p(i,j,k) - u_p(i,j,k-1)) * rdz(i, j, k)
dvdz(i, j, k) = (v_p(i,j,k) - v_p(i,j,k-1)) * rdz(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-IF ((.NOT. l_subfilter_vert) .AND. (.NOT. l_3dtke) ) THEN
+if ((.not. l_subfilter_vert) .and. (.not. l_3dtke) ) then
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- dvdzm(i, j, k) = MAX ( 1.0e-12 , &
- SQRT(dudz(i, j, k) ** 2 + dvdz(i, j, k) ** 2))
- END DO
- END DO
- END DO
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
+ dvdzm(i, j, k) = max ( 1.0e-12 , &
+ sqrt(dudz(i, j, k) ** 2 + dvdz(i, j, k) ** 2))
+ end do
+ end do
+ end do
-ELSE
+else
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- dvdzm(i,j,k) = MAX( 1.0e-12 , shear(i,j,k-1) )
- END DO
- END DO
- END DO
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
+ dvdzm(i,j,k) = max( 1.0e-12 , shear(i,j,k-1) )
+ end do
+ end do
+ end do
-END IF
+end if
-IF (l_subfilter_horiz .OR. l_subfilter_vert .OR. l_3dtke) THEN
+if (l_subfilter_horiz .or. l_subfilter_vert .or. l_3dtke) then
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
rmlmax2(i,j) = ( mix_factor * delta_smag(i,j) )**2
- END DO
- END DO
+ end do
+ end do
- DO k = 1, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 1, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
rneutml_sq(i,j,k) = 1.0 / ( &
1.0/( vkman*(z_tq(i,j,k) + z0m_eff_gb(i,j)) )**2 &
+ 1.0/rmlmax2(i,j) )
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
-END IF
+end if
!-----------------------------------------------------------------------
! Orographic enhancement of subgrid mixing
!-----------------------------------------------------------------------
! Calculate 2D array for standard deviation of subgrid orography.
!-----------------------------------------------------------------------
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
sigma_h(i,j) = 0.0
- END DO
-END DO
-DO l = 1, land_pts
+ end do
+end do
+do l = 1, land_pts
j=(land_index(l)-1)/pdims%i_end + 1
i=land_index(l) - (j-1)*pdims%i_end
- sigma_h(i,j) = MIN( sd_orog(l), 300.0 )
-END DO
+ sigma_h(i,j) = min( sd_orog(l), 300.0 )
+end do
!-----------------------------------------------------------------------
! Enhance resolved shear through unresolved subgrid drainage flows.
!-----------------------------------------------------------------------
-IF (sg_orog_mixing == sg_shear .OR. &
- sg_orog_mixing == sg_shear_enh_lambda) THEN
+if (sg_orog_mixing == sg_shear .or. &
+ sg_orog_mixing == sg_shear_enh_lambda) then
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
- IF (sigma_h(i,j) > 1.0 ) THEN
+ if (sigma_h(i,j) > 1.0 ) then
zpr = z_tq(i,j,k-1)/sigma_h(i,j)
! Height dependence, to reduce effect to zero with height
! gives z_scale~[1,0.95,0.5,0] at zpr=[0,0.6,1,1.7]
- weight1 = 0.5*( 1.0 - TANH(4.0*(zpr-1.0) ) )
+ weight1 = 0.5*( 1.0 - tanh(4.0*(zpr-1.0) ) )
! Take slope ~ sd/h_scale for small sd;
! tends to 0.2 for large sd
- slope = 1.0 / SQRT( 25.0 + (h_scale/sigma_h(i,j))**2 )
+ slope = 1.0 / sqrt( 25.0 + (h_scale/sigma_h(i,j))**2 )
- dvdzm(i,j,k) = MAX ( dvdzm(i,j,k), &
+ dvdzm(i,j,k) = max ( dvdzm(i,j,k), &
weight1*slope*t_drain*dbdz(i,j,k) )
- IF (k==2 .AND. BL_diag%l_dvdzm) &
+ if (k==2 .and. BL_diag%l_dvdzm) &
BL_diag%dvdzm(i,j,1)=weight1*slope*t_drain*dbdz(i,j,k)
- END IF
- END DO
- END DO
- END DO
+ end if
+ end do
+ end do
+ end do
-END IF ! sg_orog_mixing
+end if ! sg_orog_mixing
!------------------------------------------------------------------
! call main subroutines
!------------------------------------------------------------------
-IF (bdy_tke == mymodel25 .OR. bdy_tke == mymodel3) THEN
- CALL mym_ctl( &
+if (bdy_tke == mymodel25 .or. bdy_tke == mymodel3) then
+ call mym_ctl( &
!in levels/switches
bl_levels, bdy_tke, &
BL_diag, &
@@ -826,8 +826,8 @@ SUBROUTINE bdy_expl2_1a ( &
e_trb, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh, zhpar_shcu, &
! out
visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq)
-ELSE IF (bdy_tke == deardorff) THEN
- CALL ddf_ctl( &
+else if (bdy_tke == deardorff) then
+ call ddf_ctl( &
! IN levels/switches
bl_levels, BL_diag, &
! IN fields
@@ -837,73 +837,73 @@ SUBROUTINE bdy_expl2_1a ( &
u_s, fb_surf, pstar, &
! INOUT fields
e_trb, rhokm, rhokh, zhpar_shcu)
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
rhogamu(i, j, k) = 0.0
rhogamv(i, j, k) = 0.0
rhogamt(i, j, k) = 0.0
rhogamq(i, j, k) = 0.0
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
! RHOKM and RHOKH could be changed by the subgrid turbulence
! scheme, but BL_diag%rhokm, rhokh are the exchange coefficients
! by the TKE schemes, which is the same sense in bdy_expl2 for
! the UM BL scheme.
-IF (BL_diag%l_rhokm) THEN
- DO k = 1, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+if (BL_diag%l_rhokm) then
+ do k = 1, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
BL_diag%rhokm(i,j,k)=rhokm(i,j,k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_rhokh) THEN
- DO k = 1, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_rhokh) then
+ do k = 1, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
BL_diag%rhokh(i,j,k)=rhokh(i,j,k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
!-----------------------------------------------------------------------
! The purpose of this block is to calculate local mixing above tke_levels
! and the stability functions FM_3D and FM_3H with EX_COEF.
!-----------------------------------------------------------------------
-IF (l_subfilter_horiz .OR. l_subfilter_vert .OR. &
- (tke_levels < bl_levels .AND. l_local_above_tkelvs)) THEN
+if (l_subfilter_horiz .or. l_subfilter_vert .or. &
+ (tke_levels < bl_levels .and. l_local_above_tkelvs)) then
! call local coeff calculation for levels 2 to bl_levels
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
ri(i, j, k) = dbdz(i, j, k) &
/ ( dvdzm(i, j, k) * dvdzm(i ,j, k) )
- END DO
- END DO
- END DO
-
- IF (BL_diag%l_gradrich) THEN
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ end do
+ end do
+ end do
+
+ if (BL_diag%l_gradrich) then
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
BL_diag%gradrich(i,j,k)=ri(i,j,k)
- END DO
- END DO
- END DO
- END IF
+ end do
+ end do
+ end do
+ end if
!-----------------------------------------------------------------------
! call local coeff calculation for levels 2 to bl_levels
!-----------------------------------------------------------------------
- CALL ex_coef ( &
+ call ex_coef ( &
! IN levels/logicals
bl_levels,k_log_layr,BL_diag, &
! IN fields
@@ -920,145 +920,145 @@ SUBROUTINE bdy_expl2_1a ( &
! set diffusion coefs between tke_levels + 1 and bl_levels
! with ones by the local scheme (EX_COEF)
!------------------------------------------------------------------
- IF (tke_levels < bl_levels .AND. l_local_above_tkelvs) THEN
- DO k = tke_levels + 1, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ if (tke_levels < bl_levels .and. l_local_above_tkelvs) then
+ do k = tke_levels + 1, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
rhokm(i, j, k) = rhokm_ri(i, j, k)
weight1 = z_tq(i,j,k) - z_tq(i,j, k-1)
weight2 = z_tq(i,j,k) - z_uv(i,j,k)
weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
- IF ( k == bl_levels ) THEN
+ if ( k == bl_levels ) then
! assume RHOKH_uv(BL_LEVELS+1) is zero
rhokh(i,j,k) = ( weight2/weight1 ) * rhokh_th_ri(i,j,k)
- ELSE
+ else
rhokh(i,j,k) = weight3/weight1 * &
rhokh_th_ri(i,j,k+1) &
+weight2/weight1 * &
rhokh_th_ri(i,j,k)
- END IF
+ end if
- IF ((local_fa /= free_trop_layers) .and. &
- (local_fa /= smooth_to_bdys)) THEN
+ if ((local_fa /= free_trop_layers) .and. &
+ (local_fa /= smooth_to_bdys)) then
!--------------------------------------------------------
! Code moved from EX_COEF to avoid interpolation:
! Include mixing length, ELH, in RHOKH.
! Here only use free trop mixing length, lambda_min
!--------------------------------------------------------
rhokh(i,j,k) = lambda_min * rhokh(i,j,k)
- END IF ! test on local_fa NE free_trop_layers
+ end if ! test on local_fa NE free_trop_layers
! Finally multiply RHOKH by dry density
- IF (l_mr_physics) rhokh(i,j,k) = rho_mix(i,j,k) * rhokh(i,j,k)
+ if (l_mr_physics) rhokh(i,j,k) = rho_mix(i,j,k) * rhokh(i,j,k)
- END DO
- END DO
- END DO
- END IF
+ end do
+ end do
+ end do
+ end if
- IF (l_subfilter_horiz .OR. l_subfilter_vert) THEN
+ if (l_subfilter_horiz .or. l_subfilter_vert) then
! visc_m and visc_h for levels below tke_levels are set in mym_ctl.
- IF (l_3dtke .AND. &
- (tke_levels < bl_levels .AND. l_local_above_tkelvs)) THEN
+ if (l_3dtke .and. &
+ (tke_levels < bl_levels .and. l_local_above_tkelvs)) then
- DO k = tke_levels, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = tke_levels, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
visc_m(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
visc_h(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- DO k = tke_levels, bl_levels-1
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = tke_levels, bl_levels-1
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
! stability functions are indexed with Ri, fm(k) on w(k-1)
visc_m(i,j,k) = visc_m(i,j,k)*fm_3d(i,j,k+1)
visc_h(i,j,k) = visc_h(i,j,k)*fh_3d(i,j,k+1)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- ELSE IF (.NOT. l_3dtke) THEN
+ else if (.not. l_3dtke) then
! visc_m,h on IN are just S and visc_m,h(k) are co-located with w(k)
- DO k = 1, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 1, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
visc_m(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
visc_h(i,j,k) = shear(i,j,k)*rneutml_sq(i,j,k)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- DO k = 1, bl_levels-1
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 1, bl_levels-1
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
! stability functions are indexed with Ri, fm(k) on w(k-1)
visc_m(i,j,k) = visc_m(i,j,k)*fm_3d(i,j,k+1)
visc_h(i,j,k) = visc_h(i,j,k)*fh_3d(i,j,k+1)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- END IF
+ end if
! visc_m and visc _h are now lambda^2*S*FM and lambda^2*S*FH
- IF (l_subfilter_vert) THEN
+ if (l_subfilter_vert) then
! visc_h_rho(k) is held on rho(k), same as BL's rhokh
- ALLOCATE (visc_h_rho(pdims%i_start:pdims%i_end, &
+ allocate (visc_h_rho(pdims%i_start:pdims%i_end, &
pdims%j_start:pdims%j_end, bl_levels))
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
weight1 = z_tq(i,j,k) - z_tq(i,j, k-1)
weight2 = z_tq(i,j,k) - z_uv(i,j,k)
weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
- IF ( k == bl_levels ) THEN
+ if ( k == bl_levels ) then
! assume visc_h(bl_levels) is zero
! (Ri and thence f_h not defined)
visc_h_rho(i,j,k) = (weight2/weight1) * visc_h(i,j,k-1)
- ELSE
+ else
visc_h_rho(i,j,k) = (weight3/weight1) * visc_h(i,j,k) &
+ (weight2/weight1) * visc_h(i,j,k-1)
- END IF
- END DO
- END DO
- END DO
+ end if
+ end do
+ end do
+ end do
! Overwrite the diffusion coefficients from the local BL scheme
!(RHOKM and RHOKH) with those obtained from the Smagorinsky scheme.
- DO k = 2, bl_levels
- IF (k >= turb_startlev_vert .AND. &
- k <= turb_endlev_vert) THEN
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ do k = 2, bl_levels
+ if (k >= turb_startlev_vert .and. &
+ k <= turb_endlev_vert) then
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
rhokm(i,j,k) = visc_m(i,j,k-1)*rho_wet_tq(i,j,k-1)
rhokh(i,j,k) = visc_h_rho(i,j,k)*rho_mix(i,j,k)
- END DO
- END DO
- ELSE
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ end do
+ end do
+ else
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
rhokm(i,j,k) = 0.0
rhokh(i,j,k) = 0.0
- END DO
- END DO
- END IF
- END DO
+ end do
+ end do
+ end if
+ end do
- DEALLOCATE (visc_h_rho)
+ deallocate (visc_h_rho)
- END IF ! L_subfilter_vert
- END IF ! L_subfilter_horiz or L_subfilter_vert
-END IF ! Main if-test for calling Ri-based scheme
+ end if ! L_subfilter_vert
+ end if ! L_subfilter_horiz or L_subfilter_vert
+end if ! Main if-test for calling Ri-based scheme
!-----------------------------------------------------------------------
! Diagnose boundary layer type.
@@ -1076,15 +1076,15 @@ SUBROUTINE bdy_expl2_1a ( &
!-----------------------------------------------------------------------
! First initialise the type variables and set the diagnostic ZHT.
-IF (BL_diag%l_zht) THEN
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- bl_diag%zht(i,j) = MAX( zh(i,j) , zhsc(i,j) )
- END DO
- END DO
-END IF
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+if (BL_diag%l_zht) then
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
+ bl_diag%zht(i,j) = max( zh(i,j) , zhsc(i,j) )
+ end do
+ end do
+end if
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
bl_type_1(i,j) = 0.0
bl_type_2(i,j) = 0.0
bl_type_3(i,j) = 0.0
@@ -1092,186 +1092,186 @@ SUBROUTINE bdy_expl2_1a ( &
bl_type_5(i,j) = 0.0
bl_type_6(i,j) = 0.0
bl_type_7(i,j) = 0.0
- END DO
-END DO
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- IF (.NOT. unstable(i,j) .AND. .NOT. dsc(i,j) .AND. &
- .NOT. cumulus(i,j)) THEN
+ end do
+end do
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
+ if (.not. unstable(i,j) .and. .not. dsc(i,j) .and. &
+ .not. cumulus(i,j)) then
! Stable b.l.
bl_type_1(i,j) = 1.0
- ELSE IF (.NOT. unstable(i,j) .AND. dsc(i,j) .AND. &
- .NOT. cumulus(i,j)) THEN
+ else if (.not. unstable(i,j) .and. dsc(i,j) .and. &
+ .not. cumulus(i,j)) then
! Stratocumulus over a stable surface layer
bl_type_2(i,j) = 1.0
- ELSE IF (unstable(i,j) .AND. .NOT. cumulus(i,j) .AND. &
- .NOT. dsc(i,j) ) THEN
+ else if (unstable(i,j) .and. .not. cumulus(i,j) .and. &
+ .not. dsc(i,j) ) then
! Well mixed b.l. (possibly with stratocumulus)
- IF ( ntml(i,j) > ntml_nl(i,j) ) THEN
+ if ( ntml(i,j) > ntml_nl(i,j) ) then
! shear-dominated - currently identified
! by local NTML overriding non-local
bl_type_7(i,j) = 1.0
- ELSE
+ else
! buoyancy-dominated
bl_type_3(i,j) = 1.0
- END IF
- ELSE IF (unstable(i,j) .AND. dsc(i,j) .AND. &
- .NOT. cumulus(i,j)) THEN
+ end if
+ else if (unstable(i,j) .and. dsc(i,j) .and. &
+ .not. cumulus(i,j)) then
! Decoupled stratocumulus (not over cumulus)
bl_type_4(i,j) = 1.0
- ELSE IF (dsc(i,j) .AND. cumulus(i,j)) THEN
+ else if (dsc(i,j) .and. cumulus(i,j)) then
! Decoupled stratocumulus over cumulus
bl_type_5(i,j) = 1.0
- ELSE IF (.NOT. dsc(i,j) .AND. cumulus(i,j)) THEN
+ else if (.not. dsc(i,j) .and. cumulus(i,j)) then
! Cumulus capped b.l.
bl_type_6(i,j) = 1.0
- END IF
- END DO
-END DO
+ end if
+ end do
+end do
!-----------------------------------------------------------------------
! Calculation of explicit fluxes of T,Q
!-----------------------------------------------------------------------
-CALL mym_ex_flux_tq( &
+call mym_ex_flux_tq( &
bl_levels, &
tl, qw, rhokh, rhogamt, rhogamq, rdz_charney_grid, &
ftl, fqw)
-IF (BL_diag%l_rhogamu) THEN
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+if (BL_diag%l_rhogamu) then
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
BL_diag%rhogamu(i, j, k) = rhogamu(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_rhogamv) THEN
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_rhogamv) then
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
BL_diag%rhogamv(i, j, k) = rhogamv(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_rhogamt) THEN
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_rhogamt) then
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
BL_diag%rhogamt(i, j, k) = - cp * rhogamt(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_rhogamq) THEN
- DO k = 2, bl_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_rhogamq) then
+ do k = 2, bl_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
BL_diag%rhogamq(i, j, k) = - lc * rhogamq(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
!-----------------------------------------------------------------------
! Calculate explicit surface fluxes of U and V on
! P-grid for convection scheme
!-----------------------------------------------------------------------
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
uw0(i,j) = -rhokm(i,j,1) * &
( u_p(i,j,1) - u_0_px(i,j) )
vw0(i,j) = -rhokm(i,j,1) * &
( v_p(i,j,1) - v_0_px(i,j) )
- END DO
-END DO
+ end do
+end do
!-----------------------------------------------------------------------
! Set NTML to max number of turbulently mixed layers
! Calculate quantities to pass to convection scheme.
!-----------------------------------------------------------------------
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
wstar(i,j) = 0.0
wthvs(i,j) = 0.0
cu_over_orog(i,j) = 0.0
- IF ( cumulus(i,j) ) THEN
- IF ( fb_surf(i,j) > 0.0 ) THEN
+ if ( cumulus(i,j) ) then
+ if ( fb_surf(i,j) > 0.0 ) then
wstar(i,j) = ( zh(i,j)*fb_surf(i,j) )**one_third
wthvs(i,j) = fb_surf(i,j) / ( g * bt(i,j,1) )
- END IF
- wstar(i,j) = MAX( 0.1, wstar(i,j) )
- IF (.NOT. l_param_conv) THEN
- ntml(i,j) = MAX( 2, ntml_nl(i,j) - 1 )
- END IF
- ELSE
- ntml(i,j) = MAX( ntml_nl(i,j) , ntdsc(i,j) )
- END IF
+ end if
+ wstar(i,j) = max( 0.1, wstar(i,j) )
+ if (.not. l_param_conv) then
+ ntml(i,j) = max( 2, ntml_nl(i,j) - 1 )
+ end if
+ else
+ ntml(i,j) = max( ntml_nl(i,j) , ntdsc(i,j) )
+ end if
! Limit explicitly calculated surface stresses
! to a physically plausible level.
- IF ( uw0(i,j) >= 5.0 ) THEN
+ if ( uw0(i,j) >= 5.0 ) then
uw0(i,j) = 5.0
- ELSE IF ( uw0(i,j) <= -5.0 ) THEN
+ else if ( uw0(i,j) <= -5.0 ) then
uw0(i,j) = -5.0
- END IF
- IF ( vw0(i,j) >= 5.0 ) THEN
+ end if
+ if ( vw0(i,j) >= 5.0 ) then
vw0(i,j) = 5.0
- ELSE IF ( vw0(i,j) <= -5.0 ) THEN
+ else if ( vw0(i,j) <= -5.0 ) then
vw0(i,j) = -5.0
- END IF
- IF (BL_diag%l_wstar .AND. (fb_surf(i,j) >0.0)) THEN
+ end if
+ if (BL_diag%l_wstar .and. (fb_surf(i,j) >0.0)) then
BL_diag%wstar(i,j)= (zh(i,j)*fb_surf(i,j))**one_third
- END IF
- END DO
-END DO
+ end if
+ end do
+end do
-IF (l_param_conv) THEN
+if (l_param_conv) then
! Check for CUMULUS having been diagnosed over steep orography.
! Reset to false but keep NTML at NLCL (though decrease by 2 so that
! coupling between BL and convection scheme can be maintained).
! Reset type diagnostics.
- DO l = 1, land_pts
+ do l = 1, land_pts
j=(land_index(l)-1)/pdims%i_end + 1
i=land_index(l) - (j-1)*pdims%i_end
- IF (cumulus(i,j) .AND. ho2r2_orog(l) > 900.0) THEN
- cumulus(i,j) = .FALSE.
- l_shallow(i,j) = .FALSE.
+ if (cumulus(i,j) .and. ho2r2_orog(l) > 900.0) then
+ cumulus(i,j) = .false.
+ l_shallow(i,j) = .false.
bl_type_5(i,j) = 0.0
bl_type_6(i,j) = 0.0
cu_over_orog(i,j) = 1.0
- IF (ntml(i,j) >= 3) ntml(i,j) = ntml(i,j) - 2
- END IF
- END DO
+ if (ntml(i,j) >= 3) ntml(i,j) = ntml(i,j) - 2
+ end if
+ end do
! Check that CUMULUS and L_SHALLOW are still consistent
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- IF ( .NOT. cumulus(i,j) ) l_shallow(i,j) = .FALSE.
- END DO
- END DO
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
+ if ( .not. cumulus(i,j) ) l_shallow(i,j) = .false.
+ end do
+ end do
-END IF ! (l_param_conv)
+end if ! (l_param_conv)
!-----------------------------------------------------------------------
! Set shallow convection diagnostic: 1.0 if L_SHALLOW (and CUMULUS)
! 0.0 if .NOT. CUMULUS
!-----------------------------------------------------------------------
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
- IF ( cumulus(i,j) .AND. l_shallow(i,j) ) THEN
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
+ if ( cumulus(i,j) .and. l_shallow(i,j) ) then
shallowc(i,j) = 1.0
- ELSE
+ else
shallowc(i,j) = 0.0
- END IF
- END DO
-END DO
-
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE bdy_expl2_1a
-END MODULE bdy_expl2_1a_mod
+ end if
+ end do
+end do
+
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine bdy_expl2_1a
+end module bdy_expl2_1a_mod
diff --git a/science/physics_schemes/source/boundary_layer/ddf_ctl.F90 b/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
index 6f913e0d9c..869519b49f 100644
--- a/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
+++ b/science/physics_schemes/source/boundary_layer/ddf_ctl.F90
@@ -13,16 +13,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE ddf_ctl_mod
+module ddf_ctl_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'DDF_CTL_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'DDF_CTL_MOD'
+contains
-SUBROUTINE ddf_ctl( &
+subroutine ddf_ctl( &
! IN levels/switches
bl_levels, BL_diag, &
! IN fields
@@ -32,34 +32,34 @@ SUBROUTINE ddf_ctl( &
! INOUT fields
e_trb, rhokm, rhokh, zhpar_shcu)
-USE atm_fields_bounds_mod, ONLY: tdims_l, tdims, pdims, tdims_s
-USE bl_diags_mod, ONLY: strnewbldiag
-USE gen_phys_inputs_mod, ONLY: l_mr_physics
-USE model_domain_mod, ONLY: model_type, mt_single_column
-USE mym_const_mod, ONLY: e_trb_max
-USE mym_option_mod, ONLY: my_ini_dbdz_min, tke_cm_mx, l_shcu_buoy, &
+use atm_fields_bounds_mod, only: tdims_l, tdims, pdims, tdims_s
+use bl_diags_mod, only: strnewbldiag
+use gen_phys_inputs_mod, only: l_mr_physics
+use model_domain_mod, only: model_type, mt_single_column
+use mym_const_mod, only: e_trb_max
+use mym_option_mod, only: my_ini_dbdz_min, tke_cm_mx, l_shcu_buoy, &
l_my_condense, tke_cm_fa, my_lowest_pd_surf, tke_levels, &
l_my_ini_zero, l_my_initialize
-USE parkind1, ONLY: jprb, jpim
-USE planet_constants_mod, ONLY: vkman, kappa, pref, c_virtual, grcp, g
-USE yomhook, ONLY: lhook, dr_hook
+use parkind1, only: jprb, jpim
+use planet_constants_mod, only: vkman, kappa, pref, c_virtual, grcp, g
+use yomhook, only: lhook, dr_hook
-USE ddf_initialize_mod, ONLY: ddf_initialize
-USE ddf_mix_length_mod, ONLY: ddf_mix_length
-USE mym_calcphi_mod, ONLY: mym_calcphi
-USE mym_condensation_mod, ONLY: mym_condensation
-USE mym_const_set_mod, ONLY: mym_const_set
-USE mym_shcu_buoy_mod, ONLY: mym_shcu_buoy
-USE mym_update_fields_mod, ONLY: mym_update_fields
-IMPLICIT NONE
+use ddf_initialize_mod, only: ddf_initialize
+use ddf_mix_length_mod, only: ddf_mix_length
+use mym_calcphi_mod, only: mym_calcphi
+use mym_condensation_mod, only: mym_condensation
+use mym_const_set_mod, only: mym_const_set
+use mym_shcu_buoy_mod, only: mym_shcu_buoy
+use mym_update_fields_mod, only: mym_update_fields
+implicit none
! Intent In Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! Z_UV(*,K) is height of u level k
@@ -144,7 +144,7 @@ SUBROUTINE ddf_ctl( &
pstar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! surface pressure
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! TKE defined on theta levels K-1
@@ -163,14 +163,14 @@ SUBROUTINE ddf_ctl( &
! the non-gradient buoyancy flux
! Declaration of BL diagnostics.
-TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+type (strnewbldiag), intent(in out) :: BL_diag
! Local Variables
-INTEGER :: &
+integer :: &
i, j, k
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
r_weight1, &
! weight factor to interpolate variables on rho
! levels onto theta levels
@@ -190,12 +190,12 @@ SUBROUTINE ddf_ctl( &
! coefficient appeared in determining a diffusion
! coefficients
-INTEGER :: &
+integer :: &
flag_calc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! flag to indicate whether the column should be
! calculated
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! reciprocal of Monin-Obkhov length
rhokh_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
@@ -283,193 +283,193 @@ SUBROUTINE ddf_ctl( &
! cloud fraction corrected by shallow cumulus
! process on theta level K-1
-LOGICAL, SAVE :: &
- l_first = .TRUE.
+logical, save :: &
+ l_first = .true.
! flag to indicate if it is the first execution
-INTEGER, PARAMETER :: &
+integer, parameter :: &
levflag = 2
! For using subroutines for the MY model.
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
c_corr = 2.0
! coefficient appeared in parameterizing the width
! of the bi-normal distribution function
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
diff_fact = 2.0
! factor of a diffusion coef of E_TRB to that of
! momentum
-CHARACTER(LEN=*), PARAMETER :: RoutineName = 'DDF_CTL'
+character(len=*), parameter :: RoutineName = 'DDF_CTL'
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
! Calculate Monin-Obukov Length
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
r_mosurf(i,j)= -vkman*fb_surf(i,j) &
- / MAX(u_s(i,j)*u_s(i,j)*u_s(i,j), TINY(1.0))
- END DO
-END DO
+ / max(u_s(i,j)*u_s(i,j)*u_s(i,j), tiny(1.0))
+ end do
+end do
! Calculate gradient functions
-IF (my_lowest_pd_surf > 0) THEN
- CALL mym_calcphi( &
+if (my_lowest_pd_surf > 0) then
+ call mym_calcphi( &
bl_levels, z_uv, r_mosurf, pmz, phh)
-END IF
+end if
! Calculate static energy to determine the top of mixed layer
-DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 1, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
sl(i, j, k) = tl(i, j, k) + grcp * z_tq(i, j, k)
sl(i, j, k) = sl(i, j, k) * (1.0 + c_virtual * q(i, j, k) &
- qcl(i, j, k) - qcf(i, j, k))
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Determine the height of the top of mixed layer
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
flag_calc(i, j) = 1
h_pbl(i, j) = z_tq(i, j, 1)
- END DO
-END DO
-DO k = 2, tke_levels - 1
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (flag_calc(i, j) == 1) THEN
- IF (sl(i, j, k) > sl(i, j, 1)) THEN
+ end do
+end do
+do k = 2, tke_levels - 1
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (flag_calc(i, j) == 1) then
+ if (sl(i, j, k) > sl(i, j, 1)) then
h_pbl(i, j) = z_tq(i, j, k - 1) &
+ (z_tq(i, j, k) - z_tq(i, j, k - 1)) &
* (sl(i, j, 1) - sl(i, j, k - 1)) &
/ (sl(i, j, k) - sl(i, j, k - 1))
flag_calc(i, j) = 0
- END IF
- END IF
- END DO
- END DO
-END DO
+ end if
+ end if
+ end do
+ end do
+end do
! Initialization. Executed only once.
! In the initialization, balance between production and dissipation
! is assumed. Diffusion coeffients required to determine production
! terms are calculated with stability functions.
-IF (l_first) THEN
- CALL mym_const_set
+if (l_first) then
+ call mym_const_set
! IF the first value of e_trb has been set to be missing by the
! reconfiguration, the initialization for the whole domain
! is essential.
- IF (l_my_initialize) THEN
- IF (l_my_ini_zero) THEN
- DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (l_my_initialize) then
+ if (l_my_ini_zero) then
+ do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.0
- END DO
- END DO
- END DO
- ELSE ! not l_my_ini_zero
+ end do
+ end do
+ end do
+ else ! not l_my_ini_zero
! Initialize the prognostic variables by assuming the balance
! between production and dissipation terms
! In the initialization, DBDZ by the LS cloud scheme is used.
! To avoid to diagnose huge TKE, the lower limit for DBDZ
! is imposed.
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- dbdz_l(i, j, k) = MAX(my_ini_dbdz_min, dbdz(i, j, k))
- END DO
- END DO
- END DO
- CALL ddf_initialize( &
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ dbdz_l(i, j, k) = max(my_ini_dbdz_min, dbdz(i, j, k))
+ end do
+ end do
+ end do
+ call ddf_initialize( &
bl_levels, &
z_uv, z_tq, dbdz_l, dvdzm, delta_smag, r_mosurf, fb_surf, u_s, h_pbl, &
e_trb)
! Above tke_levels, the prognostic variables should be zeros.
- DO k = tke_levels + 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do k = tke_levels + 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.0
- END DO
- END DO
- END DO
- END IF ! test if l_my_ini_zero
- END IF ! test if l_my_initialize
-
- IF (l_shcu_buoy .and. l_my_initialize) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+ end if ! test if l_my_ini_zero
+ end if ! test if l_my_initialize
+
+ if (l_shcu_buoy .and. l_my_initialize) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
zhpar_shcu(i, j) = z_tq(i, j, tke_levels-1)
- END DO
- END DO
- END IF
- l_first = .FALSE.
-END IF
+ end do
+ end do
+ end if
+ l_first = .false.
+end if
-CALL ddf_mix_length( &
+call ddf_mix_length( &
tdims%i_end,tdims%j_end,tdims_l%halo_i,tdims_l%halo_j, bl_levels, &
z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, h_pbl, e_trb, &
elm, coef_ce, ekw)
! Calculate diffusion coefficients
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (z_tq(i, j, k - 1) < h_pbl(i, j)) THEN
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (z_tq(i, j, k - 1) < h_pbl(i, j)) then
coef_cm = tke_cm_mx
- ELSE
+ else
coef_cm = tke_cm_fa
- END IF
+ end if
r_pr = 1.0 + 2.0 * elm(i, j, k) &
/ (z_uv(i, j, k) - z_uv(i, j, k - 1))
rhokm(i, j, k) = coef_cm * elm(i, j, k) * ekw(i, j, k)
rhokh_tq(i, j, k) = rhokm(i, j, k) * r_pr
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Set virtual temperature, exner function and g/thetav
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
tv(i, j, k) = t(i, j, k - 1) &
* (1.0 + c_virtual * q(i, j, k - 1) &
- qcl(i, j, k - 1) - qcf(i, j, k - 1))
exner(i, j, k) = &
(p_theta_levels(i, j, k - 1) / pref) ** kappa
gtr(i, j, k) = g / tv(i, j, k) * exner(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! The covariances to be required by mym_condensation
! are diagnosed assuming balance between
! production and dissipation.
-IF (l_my_condense .OR. l_shcu_buoy) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (l_my_condense .or. l_shcu_buoy) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
tsq(i, j, k) = c_corr * elm(i, j, k) ** 2 &
* dtldzm(i, j, k) ** 2
qsq(i, j, k) = c_corr * elm(i, j, k) ** 2 &
* dqwdzm(i, j, k) ** 2
cov(i, j, k) = c_corr * elm(i, j, k) ** 2 &
* dtldzm(i, j, k) * dqwdzm(i, j, k)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- CALL mym_condensation( &
+ call mym_condensation( &
! IN levels/switches
bl_levels, levflag, &
BL_diag, &
@@ -477,23 +477,23 @@ SUBROUTINE ddf_ctl( &
qw, tl, t, p_theta_levels, tsq, qsq, cov, &
! OUT fields
vt, vq, q1, cld, ql)
-END IF
+end if
-IF (.NOT. l_my_condense) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (.not. l_my_condense) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
! convert buoy params from the UM notation to the MY notaation
vt(i, j, k) = bt_gb(i, j, k - 1) * tv(i, j, k)
vq(i, j, k) = bq_gb(i, j, k - 1) * tv(i, j, k) &
/ exner(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (l_shcu_buoy) THEN
- CALL mym_shcu_buoy( &
+if (l_shcu_buoy) then
+ call mym_shcu_buoy( &
! IN levels/switches
bl_levels, BL_diag, &
! IN fields
@@ -501,21 +501,21 @@ SUBROUTINE ddf_ctl( &
u_p, v_p, t, q, qcl, qcf, q1, cld, &
! INOUT / OUT fields
zhpar_shcu, frac_shcu, wb_ng)
-ELSE
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+else
+ do k = 1, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
wb_ng(i,j,k) = 0.0
frac_shcu(i,j,k) = cld(i,j,k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
! Calculate production terms and coefficient of dissipation term.
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
dbdz_l(i, j, k) = gtr(i, j, k) &
* (vt(i, j, k) * dtldzm(i, j, k) &
+ vq(i, j, k) * dqwdzm(i, j, k))
@@ -530,62 +530,62 @@ SUBROUTINE ddf_ctl( &
prod(i, j, k) = prod_m(i, j, k) + prod_h(i, j, k)
disp_coef(i, j, k) = coef_ce(i, j, k) * ekw(i, j, k) &
- / MAX(elm(i, j, k), 1.0e-20)
+ / max(elm(i, j, k), 1.0e-20)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Overwrite the production term at the lowest level by
! the one evaluated with surface fluxes.
-IF (my_lowest_pd_surf > 0) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (my_lowest_pd_surf > 0) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
prod(i, j, 2) = u_s(i, j) ** 3 * pmz(i, j) &
/ (vkman * z_tq(i, j, 1))
- END DO
- END DO
-END IF
+ end do
+ end do
+end if
-CALL mym_update_fields( &
+call mym_update_fields( &
bl_levels, diff_fact, z_uv, z_tq, rhokm, prod, disp_coef, e_trb)
-DO k = tke_levels + 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = tke_levels + 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.0
rhokm(i, j, k) = 0.0
rhokh_tq(i, j, k) = 0.0
rhokh(i, j, k) = 0.0
- END DO
- END DO
-END DO
-
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- e_trb(i, j, k) = MIN(MAX(e_trb(i, j, k), 1.0e-20), e_trb_max)
+ end do
+ end do
+end do
+
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = min(max(e_trb(i, j, k), 1.0e-20), e_trb_max)
rhokm(i, j, k) = rho_wet_tq(i, j, k - 1) * rhokm(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Note "RHO" here is always wet density (RHO_WET_TQ) so
! save multiplication of RHOKH to after interpolation
-IF (.NOT. l_mr_physics) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (.not. l_mr_physics) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
rhokh_tq(i, j, k) = rho_wet_tq(i, j, k - 1) * rhokh_tq(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
! Interpolate RHOKH_TQ on theta levels to rho levels
-DO k = 2, tke_levels - 1
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels - 1
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
r_weight1 = 1.0 / (z_tq(i,j,k) - &
z_tq(i,j, k-1))
weight2 = (z_tq(i,j,k) - &
@@ -595,98 +595,98 @@ SUBROUTINE ddf_ctl( &
rhokh(i,j,k) = &
weight3 * rhokh_tq(i,j,k+1) &
+weight2 * rhokh_tq(i,j,k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
k = tke_levels
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
r_weight1 = 1.0 / (z_tq(i,j,k) - &
z_tq(i,j, k-1))
weight2 = (z_tq(i,j,k) - &
z_uv(i,j,k)) * r_weight1
rhokh(i, j, k) = weight2 * rhokh_tq(i, j, k)
- END DO
-END DO
+ end do
+end do
! Finally multiply RHOKH by dry density
-IF (l_mr_physics) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (l_mr_physics) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
rhokh(i, j, k) = rho_mix(i, j, k) * rhokh(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_dbdz) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_dbdz) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%dbdz(i, j, k) = dbdz_l(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_dvdzm) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_dvdzm) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%dvdzm(i,j,k) = dvdzm(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_tke_shr_prod) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_tke_shr_prod) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%tke_shr_prod(i, j, k) = prod_m(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_tke_boy_prod) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_tke_boy_prod) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%tke_boy_prod(i, j, k) = prod_h(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_tke_boy_prod) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_tke_boy_prod) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%tke_dissp(i, j, k) = &
coef_ce(i, j, k) * (ekw(i, j, k)) ** 3 &
- / MAX(elm(i, j, k), 1.0e-20)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_elm) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ / max(elm(i, j, k), 1.0e-20)
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_elm) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%elm(i, j, k) = elm(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE ddf_ctl
-END MODULE ddf_ctl_mod
+end subroutine ddf_ctl
+end module ddf_ctl_mod
diff --git a/science/physics_schemes/source/boundary_layer/ddf_initialize.F90 b/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
index 2b8b7f2924..e2e750664a 100644
--- a/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
+++ b/science/physics_schemes/source/boundary_layer/ddf_initialize.F90
@@ -12,40 +12,40 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE ddf_initialize_mod
+module ddf_initialize_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'DDF_INITIALIZE_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'DDF_INITIALIZE_MOD'
+contains
-SUBROUTINE ddf_initialize( &
+subroutine ddf_initialize( &
bl_levels, &
z_uv, z_tq, dbdz, dvdzm, delta_smag, r_mosurf, fb_surf, u_s, h_pbl, &
e_trb)
-USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_s
-USE mym_const_mod, ONLY: e_trb_max
-USE mym_option_mod, ONLY: tke_levels, l_my_extra_level, &
+use atm_fields_bounds_mod, only: tdims, pdims, tdims_s
+use mym_const_mod, only: e_trb_max
+use mym_option_mod, only: tke_levels, l_my_extra_level, &
my_z_extra_fact, my_lowest_pd_surf, &
tke_cm_mx, tke_cm_fa
-USE parkind1, ONLY: jprb, jpim
-USE planet_constants_mod, ONLY: vkman
-USE yomhook, ONLY: lhook, dr_hook
-USE ddf_mix_length_mod, ONLY: ddf_mix_length
-USE mym_calcphi_mod, ONLY: mym_calcphi
-USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
-USE mym_implic_mod, ONLY: mym_implic
-IMPLICIT NONE
+use parkind1, only: jprb, jpim
+use planet_constants_mod, only: vkman
+use yomhook, only: lhook, dr_hook
+use ddf_mix_length_mod, only: ddf_mix_length
+use mym_calcphi_mod, only: mym_calcphi
+use mym_diff_matcoef_mod, only: mym_diff_matcoef
+use mym_implic_mod, only: mym_implic
+implicit none
! Intent In Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! Z_UV(*,K) is height of u level k
@@ -74,17 +74,17 @@ SUBROUTINE ddf_initialize( &
! height of PBL determined by vertical profile
! of SL
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels)
! TKE defined on theta levels K-1
! Local variables
-INTEGER :: &
+integer :: &
i, j, k, ll, &
itr_ini
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
r_pr, &
elq, &
sm, &
@@ -92,7 +92,7 @@ SUBROUTINE ddf_initialize( &
gm, &
gh
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
ekw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
elm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
@@ -112,7 +112,7 @@ SUBROUTINE ddf_initialize( &
pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
pr = 0.7, &
! Prandtl number
! only in the initialization,
@@ -121,143 +121,143 @@ SUBROUTINE ddf_initialize( &
! factor of a diffusion coef of E_TRB to that of
! momentum
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='DDF_INITIALIZE'
+character(len=*), parameter :: RoutineName='DDF_INITIALIZE'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
r_pr = 1.0 / pr
-IF (my_lowest_pd_surf == 0) THEN
- l_my_extra_level = .FALSE.
+if (my_lowest_pd_surf == 0) then
+ l_my_extra_level = .false.
my_z_extra_fact = 1.0
-END IF
+end if
! initial guess for e_trb, assuming neutral layer
! and set some parameters
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (z_tq(i, j, k - 1) < h_pbl(i, j)) THEN
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (z_tq(i, j, k - 1) < h_pbl(i, j)) then
coef_cm(i, j, k) = tke_cm_mx
- ELSE
+ else
coef_cm(i, j, k) = tke_cm_fa
- END IF
+ end if
sm = coef_cm(i, j, k)
sh = coef_cm(i, j, k) * r_pr
gm = dvdzm(i, j, k) ** 2
gh = -dbdz(i, j, k)
pdk(i, j, k) = sm * gm + sh * gh
- IF (pdk(i, j, k) <= 0.0) THEN
+ if (pdk(i, j, k) <= 0.0) then
pdk(i, j, k) = 0.0
e_trb(i, j, k) = 0.0
- ELSE
+ else
e_trb(i, j, k) = 1.0e-5
- END IF
- END DO
- END DO
-END DO
+ end if
+ end do
+ end do
+end do
-IF (my_lowest_pd_surf > 0) THEN
- CALL mym_calcphi( &
+if (my_lowest_pd_surf > 0) then
+ call mym_calcphi( &
bl_levels, z_tq, r_mosurf, pmz, phh)
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk0(i, j) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
/ (vkman * z_tq(i, j, 1))
- END DO
- END DO
-END IF ! IF MY_lowest_pd_surf
+ end do
+ end do
+end if ! IF MY_lowest_pd_surf
itr_ini = tke_levels + 1
-DO ll = 1, itr_ini
- CALL ddf_mix_length( &
+do ll = 1, itr_ini
+ call ddf_mix_length( &
tdims%i_end, tdims%j_end, 0, 0, bl_levels, &
z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, h_pbl, e_trb, &
elm, coef_ce, ekw)
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (e_trb(i, j, k) <= 0.0) THEN
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (e_trb(i, j, k) <= 0.0) then
ekw(i, j, k) = 0.0
- END IF
+ end if
dfm(i, j, k) = coef_cm(i, j, k) * ekw(i, j, k) * elm(i, j, k)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- CALL mym_diff_matcoef( &
+ call mym_diff_matcoef( &
bl_levels, diff_fact, z_uv, z_tq, dfm, aa, bb, cc)
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (bb(i, j, k) == 0.0) THEN
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (bb(i, j, k) == 0.0) then
aa(i, j, k) = 0.0
bb(i, j, k) = 1.0
cc(i, j, k) = 0.0
e_trb(i, j, k) = 0.0
- ELSE
+ else
elq = ekw(i, j, k) * elm(i, j, k)
aa(i, j, k) = - aa(i, j, k)
bb(i, j, k) = - bb(i, j, k) &
+ ekw(i, j, k) * coef_ce(i, j, k) &
- / MAX(elm(i, j, k), 1.0e-20)
- bb(i, j, k) = SIGN(MAX(ABS(bb(i, j, k)), 1.0e-20_real_umphys), &
+ / max(elm(i, j, k), 1.0e-20)
+ bb(i, j, k) = sign(max(abs(bb(i, j, k)), 1.0e-20_r_bl), &
bb(i, j, k))
cc(i, j, k) = - cc(i, j, k)
e_trb(i, j, k) = elq * pdk(i, j, k)
- END IF
- END DO
- END DO
- END DO
+ end if
+ end do
+ end do
+ end do
- IF (my_lowest_pd_surf > 0) THEN
+ if (my_lowest_pd_surf > 0) then
k = 2
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (bb(i, j, k) /= 0.0 .AND. pdk(i, j, k) > 0.0) THEN
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (bb(i, j, k) /= 0.0 .and. pdk(i, j, k) > 0.0) then
e_trb(i, j, k) = pdk0(i, j)
- END IF
- END DO
- END DO
- END IF ! IF MY_lowest_pd_surf > 0
+ end if
+ end do
+ end do
+ end if ! IF MY_lowest_pd_surf > 0
- CALL mym_implic( &
+ call mym_implic( &
tke_levels, 2, tke_levels, aa, bb, cc, e_trb)
-END DO ! DO ll = 1, itr_ini
+end do ! DO ll = 1, itr_ini
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- e_trb(i, j, k) = MIN( &
- MAX(e_trb(i, j, k), 1.0e-20), &
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = min( &
+ max(e_trb(i, j, k), 1.0e-20), &
e_trb_max)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, 1) = 0.0
- END DO
-END DO
+ end do
+end do
-DO k = tke_levels + 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = tke_levels + 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.0
- END DO
- END DO
-END DO
-
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE ddf_initialize
-END MODULE ddf_initialize_mod
+ end do
+ end do
+end do
+
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine ddf_initialize
+end module ddf_initialize_mod
diff --git a/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90 b/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
index bedfc327f7..ce6a37aca1 100644
--- a/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
+++ b/science/physics_schemes/source/boundary_layer/ddf_mix_length.F90
@@ -13,32 +13,32 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE ddf_mix_length_mod
+module ddf_mix_length_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'DDF_MIX_LENGTH_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'DDF_MIX_LENGTH_MOD'
+contains
-SUBROUTINE ddf_mix_length( &
+subroutine ddf_mix_length( &
row_length, rows, halo_i, halo_j, bl_levels, &
z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, h_pbl, e_trb, &
elm, coef_ce, ekw)
-USE mym_option_mod, ONLY: tke_dlen, &
+use mym_option_mod, only: tke_dlen, &
my_length, ddf_length, non_local_like_length, &
l_tke_dlen_blackadar, tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE planet_constants_mod, ONLY: vkman
-USE atm_fields_bounds_mod, ONLY: tdims
-USE yomhook, ONLY: lhook, dr_hook
-USE mym_length_mod, ONLY: mym_length
-IMPLICIT NONE
+use parkind1, only: jprb, jpim
+use planet_constants_mod, only: vkman
+use atm_fields_bounds_mod, only: tdims
+use yomhook, only: lhook, dr_hook
+use mym_length_mod, only: mym_length
+implicit none
! Intent In Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
row_length, &
! Local number of points on a row
rows, &
@@ -50,7 +50,7 @@ SUBROUTINE ddf_mix_length( &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(row_length,rows,bl_levels+1), &
! Z_UV(*,K) is height of u level k
z_tq(row_length,rows,bl_levels), &
@@ -73,7 +73,7 @@ SUBROUTINE ddf_mix_length( &
tdims%j_start:tdims%j_end, bl_levels)
! TKE defined on theta levels K-1
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
elm(row_length, rows, tke_levels), &
! mixing length
coef_ce(row_length, rows, tke_levels), &
@@ -82,10 +82,10 @@ SUBROUTINE ddf_mix_length( &
! SQRT(e_trb)
! Local variables
-INTEGER :: i, j, k
+integer :: i, j, k
! loop counter
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
rbv, &
! reciprocal of Brunt-Vaisala frequency
elb, &
@@ -95,114 +95,114 @@ SUBROUTINE ddf_mix_length( &
delta_z
! vertical grid spacing
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
qke(1-halo_i:row_length+halo_i, 1-halo_j:rows+halo_j, &
bl_levels), &
! twice of TKE (denoted to q**2) on theta level K-1
qkw(row_length, rows, tke_levels)
! q=sqrt(qke) on theta level K-1
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='DDF_MIX_LENGTH'
+character(len=*), parameter :: RoutineName='DDF_MIX_LENGTH'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
- ekw(i, j, k) = SQRT(MAX(e_trb(i, j, k), 1.0e-20))
- END DO
- END DO
-END DO
+do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
+ ekw(i, j, k) = sqrt(max(e_trb(i, j, k), 1.0e-20))
+ end do
+ end do
+end do
-IF (tke_dlen == my_length) THEN
- DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
+if (tke_dlen == my_length) then
+ do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
qke(i, j, k) = 2.0 * e_trb(i, j, k)
- END DO
- END DO
- END DO
- CALL mym_length( &
+ end do
+ end do
+ end do
+ call mym_length( &
row_length, rows, halo_i, halo_j, bl_levels, &
qke, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, &
qkw, elm)
-ELSE IF (tke_dlen == ddf_length &
- .OR. tke_dlen == non_local_like_length) THEN
- DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
+else if (tke_dlen == ddf_length &
+ .or. tke_dlen == non_local_like_length) then
+ do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
delta_z = z_uv(i, j, k) - z_uv(i, j, k - 1)
- IF (dbdz(i, j, k) > 0.0) THEN
- rbv = 1.0 / SQRT(dbdz(i, j, k))
- elb = MAX(MIN(0.76 * ekw(i, j, k) * rbv, &
+ if (dbdz(i, j, k) > 0.0) then
+ rbv = 1.0 / sqrt(dbdz(i, j, k))
+ elb = max(min(0.76 * ekw(i, j, k) * rbv, &
delta_z), 1.0e-10)
- ELSE
+ else
elb = delta_z
- END IF
+ end if
elm(i, j, k) = elb
- END DO
- END DO
- END DO
-
- IF (tke_dlen == non_local_like_length) THEN
- DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
- IF (z_tq(i, j, k - 1) < h_pbl(i, j) ) THEN
+ end do
+ end do
+ end do
+
+ if (tke_dlen == non_local_like_length) then
+ do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
+ if (z_tq(i, j, k - 1) < h_pbl(i, j) ) then
elm(i, j, k) = 0.25 * 1.8 * h_pbl(i, j) &
- * (1.0 - EXP( &
+ * (1.0 - exp( &
-4.0 * z_tq(i, j, k - 1)/h_pbl(i, j)) &
- - 0.0003 * EXP( &
+ - 0.0003 * exp( &
8.0 * z_tq(i, j, k - 1) / h_pbl(i, j)))
- END IF
- END DO
- END DO
- END DO
- END IF ! if tke_dlen == non_local_like_length
-
- IF (l_tke_dlen_blackadar) THEN
- DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
+ end if
+ end do
+ end do
+ end do
+ end if ! if tke_dlen == non_local_like_length
+
+ if (l_tke_dlen_blackadar) then
+ do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
els = vkman * z_tq(i, j, k - 1)
elm(i, j, k) = els / (1.0 + els / elm(i, j, k))
- END DO
- END DO
- END DO
- END IF
-END IF
+ end do
+ end do
+ end do
+ end if
+end if
! for diagnostics
-DO j = 1, rows
- DO i = 1, row_length
+do j = 1, rows
+ do i = 1, row_length
elm(i, j, 1) = elm(i, j, 2)
- END DO
-END DO
+ end do
+end do
-IF (tke_dlen == non_local_like_length) THEN
- DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
+if (tke_dlen == non_local_like_length) then
+ do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
coef_ce(i, j, k) = 0.41
- END DO
- END DO
- END DO
-ELSE
- DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
+ end do
+ end do
+ end do
+else
+ do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
coef_ce(i, j, k) = 0.19 + 0.74 * elm(i, j, k) &
/ (z_uv(i, j, k) - z_uv(i, j, k - 1))
- END DO
- END DO
- END DO
-END IF
-
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE ddf_mix_length
-END MODULE ddf_mix_length_mod
+ end do
+ end do
+ end do
+end if
+
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine ddf_mix_length
+end module ddf_mix_length_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_calcphi.F90 b/science/physics_schemes/source/boundary_layer/mym_calcphi.F90
index 43bb61cf6d..1b0230f7b4 100644
--- a/science/physics_schemes/source/boundary_layer/mym_calcphi.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_calcphi.F90
@@ -15,32 +15,32 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_calcphi_mod
+module mym_calcphi_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CALCPHI_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_CALCPHI_MOD'
+contains
-SUBROUTINE mym_calcphi(bl_levels, z_tq, r_mosurf, pmz, phh)
+subroutine mym_calcphi(bl_levels, z_tq, r_mosurf, pmz, phh)
-USE atm_fields_bounds_mod, ONLY: tdims
-USE mym_const_mod, ONLY: two_thirds, pr
-USE mym_option_mod, ONLY: &
+use atm_fields_bounds_mod, only: tdims
+use mym_const_mod, only: two_thirds, pr
+use mym_option_mod, only: &
businger, bh1991, my_lowest_pd_surf, &
l_my_extra_level, my_z_extra_fact
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! number of boundary layer levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! Z_TQ(*,K) is height of theta
@@ -49,7 +49,7 @@ SUBROUTINE mym_calcphi(bl_levels, z_tq, r_mosurf, pmz, phh)
! reciprocal of Monin-Obkhov length
! Intent OUT Variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! gradient function for momentum
! at surface minus non-dimensional height
@@ -58,21 +58,21 @@ SUBROUTINE mym_calcphi(bl_levels, z_tq, r_mosurf, pmz, phh)
! at surface
! Local variables
-INTEGER :: &
+integer :: &
i, j
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
zeta, &
! non-dimensional height
tmp
! work variable
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
z_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! height of the lowest layer
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
! coefficients appeared
! in Beljaars and Holtslag(1991)
bel_a = 1.0, &
@@ -80,67 +80,67 @@ SUBROUTINE mym_calcphi(bl_levels, z_tq, r_mosurf, pmz, phh)
bel_c = 5.0, &
bel_d = 0.35
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
my_zeta_max = 2.0
! upper limit for zeta
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_CALCPHI'
+character(len=*), parameter :: RoutineName='MYM_CALCPHI'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-IF (l_my_extra_level) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (l_my_extra_level) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
z_1(i, j) = z_tq(i, j, 1) * my_z_extra_fact
- END DO
- END DO
-ELSE
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+else
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
z_1(i, j) = z_tq(i, j, 1)
- END DO
- END DO
-END IF
-
-IF (my_lowest_pd_surf == businger) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- zeta = MIN(z_1(i, j) * r_mosurf(i, j), my_zeta_max)
- IF (zeta >= 0.0) THEN
+ end do
+ end do
+end if
+
+if (my_lowest_pd_surf == businger) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ zeta = min(z_1(i, j) * r_mosurf(i, j), my_zeta_max)
+ if (zeta >= 0.0) then
pmz(i, j) = 1.0 + 4.7 * zeta
phh(i, j) = pr + 4.7 * zeta
- ELSE
- pmz(i, j) = 1.0 / SQRT(SQRT(1.0 - 15.0 * zeta))
- phh(i, j) = pr / SQRT(1.0 - 9.0 * zeta)
- END IF
+ else
+ pmz(i, j) = 1.0 / sqrt(sqrt(1.0 - 15.0 * zeta))
+ phh(i, j) = pr / sqrt(1.0 - 9.0 * zeta)
+ end if
pmz(i, j) = pmz(i, j) - zeta
- END DO
- END DO
-ELSE IF (my_lowest_pd_surf == bh1991) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- zeta = MIN(z_1(i, j) * r_mosurf(i, j), my_zeta_max)
- IF (zeta >= 0) THEN
- tmp = bel_b * EXP(-bel_d * zeta) &
+ end do
+ end do
+else if (my_lowest_pd_surf == bh1991) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ zeta = min(z_1(i, j) * r_mosurf(i, j), my_zeta_max)
+ if (zeta >= 0) then
+ tmp = bel_b * exp(-bel_d * zeta) &
* (bel_d * zeta - bel_c - 1.0)
pmz(i, j) = 1.0 - zeta * (tmp - bel_a)
phh(i, j) = 1.0 - zeta * (tmp - &
- SQRT(1.0 + two_thirds * bel_a * zeta))
- ELSE
- tmp = SQRT(1.0 - 16.0 * zeta)
- pmz(i, j) = 1.0 / SQRT(tmp)
+ sqrt(1.0 + two_thirds * bel_a * zeta))
+ else
+ tmp = sqrt(1.0 - 16.0 * zeta)
+ pmz(i, j) = 1.0 / sqrt(tmp)
phh(i, j) = 1.0 / tmp
- END IF
+ end if
pmz(i, j) = pmz(i, j) - zeta
- END DO
- END DO
-END IF
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-
-END SUBROUTINE mym_calcphi
-END MODULE mym_calcphi_mod
+ end do
+ end do
+end if
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+
+end subroutine mym_calcphi
+end module mym_calcphi_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_condensation.F90 b/science/physics_schemes/source/boundary_layer/mym_condensation.F90
index fd2e8a02ba..dacc47757c 100644
--- a/science/physics_schemes/source/boundary_layer/mym_condensation.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_condensation.F90
@@ -37,16 +37,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_condensation_mod
+module mym_condensation_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CONDENSATION_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_CONDENSATION_MOD'
+contains
-SUBROUTINE mym_condensation( &
+subroutine mym_condensation( &
! IN levels/switches
bl_levels, levflag, BL_diag, &
! IN fields
@@ -54,32 +54,32 @@ SUBROUTINE mym_condensation( &
! OUT fields
vt, vq, q1, cld, ql)
-USE atm_fields_bounds_mod, ONLY: tdims
-USE bl_diags_mod, ONLY: strnewbldiag
-USE conversions_mod, ONLY: pi
-USE gen_phys_inputs_mod, ONLY: l_mr_physics
-USE mym_option_mod, ONLY: tke_levels
-USE planet_constants_mod, ONLY: &
+use atm_fields_bounds_mod, only: tdims
+use bl_diags_mod, only: strnewbldiag
+use conversions_mod, only: pi
+use gen_phys_inputs_mod, only: l_mr_physics
+use mym_option_mod, only: tke_levels
+use planet_constants_mod, only: &
cp, r, repsilon, pref, kappa, c_virtual, one_minus_epsilon, ls
-USE water_constants_mod, ONLY: lc
+use water_constants_mod, only: lc
-USE model_domain_mod, ONLY: model_type, mt_single_column
+use model_domain_mod, only: model_type, mt_single_column
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
-USE mym_errfunc_mod, ONLY: mym_errfunc
-IMPLICIT NONE
+use mym_errfunc_mod, only: mym_errfunc
+implicit none
! Intent In Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels, &
! Max. no. of "boundary" levels
levflag
! flag to indicate the level of MY
! 2: MY2.5, 3:MY3
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
! Total water content
tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
@@ -103,10 +103,10 @@ SUBROUTINE mym_condensation( &
! (thetal'qw') defined on theta levels K-1
! Declaration of BL diagnostics.
-TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+type (strnewbldiag), intent(in out) :: BL_diag
! Intent OUT Variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
vt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! Buoyancy parameter (coefficients of )
! on theta K-1
@@ -124,10 +124,10 @@ SUBROUTINE mym_condensation( &
! condensed liquid water content
! Local Variables
-INTEGER :: &
+integer :: &
i, j, k
! loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
rr2, &
! 1 / sqrt(2)
rrp, &
@@ -162,7 +162,7 @@ SUBROUTINE mym_condensation( &
rac
! work variable
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
rice(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! ratio of ice.
@@ -203,7 +203,7 @@ SUBROUTINE mym_condensation( &
qsi(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels)
! saturated specific ratio for ice
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
e0cw = 6.11e2, &
tetn1w = 17.27, &
tetn2w = 273.15, &
@@ -218,80 +218,80 @@ SUBROUTINE mym_condensation( &
temp_ice = 237.15
! Below this temperature, all of condensed water
! should be ice. -36C
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
my_sgm_min_fct = 0.0, &
! factor to set the lower limit for sgm
my_sgm_max_fct = 1.0
! factor to set the upper limit for sgm
-CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_CONDENSATION'
+character(len=*), parameter :: RoutineName = 'MYM_CONDENSATION'
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-rr2 = 1.0 / SQRT(2.0)
-rrp = 1.0 / SQRT(2.0 * pi)
+rr2 = 1.0 / sqrt(2.0)
+rrp = 1.0 / sqrt(2.0 * pi)
! Here, qsw and qsi are saturated vapor pressure.
! Using the Teten's formula instead of the subroutine "qmix"
! because the saturated vapor pressure on liquid water is necessary
! even in sub-zero temperature.
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
- qsw(i, j, k) = e0cw * EXP(tetn1w * &
+ qsw(i, j, k) = e0cw * exp(tetn1w * &
(tl(i, j, k - 1) - tetn2w) &
/ (tl(i, j, k - 1) - tetn3w) )
- qsi(i, j, k) = e0ci * EXP(tetn1i * &
+ qsi(i, j, k) = e0ci * exp(tetn1i * &
(tl(i, j, k - 1) - tetn2i) &
/ (tl(i, j, k - 1) - tetn3i) )
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! convert to mixing ratio or specific humidity
-IF (l_mr_physics) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (l_mr_physics) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
qsw(i, j, k) = repsilon * qsw(i, j, k) &
/ p_theta_levels(i, j, k - 1)
qsi(i, j, k) = repsilon * qsi(i, j, k) &
/ p_theta_levels(i, j, k - 1)
- END DO
- END DO
- END DO
-ELSE
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+else
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
qsw(i, j, k) = repsilon * qsw(i, j, k) &
/ (p_theta_levels(i, j, k - 1) &
- one_minus_epsilon * qsw(i, j, k))
qsi(i, j, k) = repsilon * qsi(i, j, k) &
/ (p_theta_levels(i, j, k - 1) &
- one_minus_epsilon * qsi(i, j, k))
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
! Calculate sgm
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (tl(i, j, k -1) >= ttriple) THEN
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (tl(i, j, k -1) >= ttriple) then
rice(i, j, k) = 0.0
- ELSE IF (tl(i, j, k - 1) < temp_ice) THEN
+ else if (tl(i, j, k - 1) < temp_ice) then
rice(i, j, k) = 1.0
- ELSE
+ else
rice(i, j, k) = (ttriple - tl(i, j, k - 1)) &
/ (ttriple - temp_ice)
- END IF
+ end if
hl = (1.0 - rice(i, j, k)) * lc + rice(i, j, k) * ls
qsl = (1.0 - rice(i, j, k)) * qsw(i, j, k) &
@@ -306,74 +306,74 @@ SUBROUTINE mym_condensation( &
alp(i, j, k) = 1.0 /(1.0 + dqsl * hl_ovr_cp(i, j, k))
bet(i, j, k) = dqsl * exner(i, j, k)
- t3sq = MAX(tsq(i, j, k), 0.0)
- r3sq = MAX(qsq(i, j, k), 0.0)
+ t3sq = max(tsq(i, j, k), 0.0)
+ r3sq = max(qsq(i, j, k), 0.0)
c3sq = cov(i, j, k)
- c3sq = SIGN(MIN(ABS(c3sq), SQRT(t3sq * r3sq)), c3sq)
+ c3sq = sign(min(abs(c3sq), sqrt(t3sq * r3sq)), c3sq)
r3sq = r3sq + bet(i, j, k) ** 2 * t3sq &
-2.0 * bet(i, j, k) * c3sq
- alp_qsl = MIN(alp(i, j, k) * qsl, qw(i, j, k - 1))
- sgm(i, j, k) = MAX( &
- MIN(0.5 * alp(i, j, k) * SQRT(MAX(r3sq, 0.0)), &
+ alp_qsl = min(alp(i, j, k) * qsl, qw(i, j, k - 1))
+ sgm(i, j, k) = max( &
+ min(0.5 * alp(i, j, k) * sqrt(max(r3sq, 0.0)), &
my_sgm_max_fct * alp_qsl), &
my_sgm_min_fct * alp_qsl, 1.0e-10)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-IF (levflag /= 3) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (levflag /= 3) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
sgm(i, j, 2) = sgm(i, j, 3)
- END DO
- END DO
-END IF
+ end do
+ end do
+end if
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
erf_arg(i, j, 1) = 0.0
cld(i, j, 1) = 0.0
ql(i, j, 1) = 0.0
sgm(i, j, 1) = 0.0
q1(i, j, 1) = 0.0
- END DO
-END DO
+ end do
+end do
! Preparation to calculate values of the err function
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
q1(i, j, k) = 0.5 * alp(i, j, k) &
* qmq(i, j, k) / sgm(i, j, k)
erf_arg(i, j, k) = q1(i, j, k) * rr2
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-CALL mym_errfunc(tdims%i_end*tdims%j_end*tke_levels, erf_arg, erf_val)
+call mym_errfunc(tdims%i_end*tdims%j_end*tke_levels, erf_arg, erf_val)
! Calculate the buoyancy parameters vt and vq
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
cld(i, j, k) = 0.5 * (1.0 + erf_val(i, j, k))
- IF (ABS(q1(i, j, k)) > 10.0 ) THEN
+ if (abs(q1(i, j, k)) > 10.0 ) then
eq1 = 0.0
- ELSE
- eq1 = rrp * EXP(- 0.5 * q1(i, j, k) ** 2)
- END IF
+ else
+ eq1 = rrp * exp(- 0.5 * q1(i, j, k) ** 2)
+ end if
! qll = ql / (2 * sgm)
- qll = MAX(cld(i, j, k) * q1(i, j, k) + eq1, 0.0)
+ qll = max(cld(i, j, k) * q1(i, j, k) + eq1, 0.0)
- IF (qw(i, j, k) < 1.0e-10) THEN
+ if (qw(i, j, k) < 1.0e-10) then
ql(i, j, k) = 0.0
- ELSE
- ql(i, j, k) = MAX( &
+ else
+ ql(i, j, k) = max( &
2.0 * sgm(i, j, k) * qll, 0.0)
- END IF
+ end if
! To avoid negative QV (for safety)
- ql(i, j, k) = MIN(ql(i, j, k), qw(i, j, k - 1) * 0.5)
+ ql(i, j, k) = min(ql(i, j, k), qw(i, j, k - 1) * 0.5)
r_exner = 1.0 / exner(i, j, k)
q2p = hl_ovr_cp(i, j, k) * r_exner
@@ -385,42 +385,42 @@ SUBROUTINE mym_condensation( &
vt (i, j, k) = qt - rac * bet(i, j, k)
vq (i, j, k) = c_virtual * pt_tmp + rac
- END DO
- END DO
-END DO
-
-IF (BL_diag%l_cf_trb) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+end do
+
+if (BL_diag%l_cf_trb) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%cf_trb(i, j, k) = cld(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_ql_trb) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_ql_trb) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%ql_trb(i, j, k) = ql(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_sgm_trb) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_sgm_trb) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%sgm_trb(i, j, k) = sgm(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_condensation
-END MODULE mym_condensation_mod
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_condensation
+end module mym_condensation_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_const_mod.F90 b/science/physics_schemes/source/boundary_layer/mym_const_mod.F90
index 90063848a4..4e92facfe0 100644
--- a/science/physics_schemes/source/boundary_layer/mym_const_mod.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_const_mod.F90
@@ -32,11 +32,11 @@
! http://www.nda.ac.jp/~naka/MYNN/index.html
!---------------------------------------------------------------------
-MODULE mym_const_mod
-USE um_types, ONLY: real_umphys
+module mym_const_mod
+use um_types, only: r_bl
-IMPLICIT NONE
-SAVE
+implicit none
+save
! For the meaing of the variables, see the papers above.
! N2001: Nakanishi, M., 2001
@@ -45,7 +45,7 @@ MODULE mym_const_mod
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
g1, &
! gamma_1 = 1/3 - 2A_1 / B_1
g2, &
@@ -137,4 +137,4 @@ MODULE mym_const_mod
! upper limit for qke (twice of TKE) for safety.
e_trb_max
! upper limit for e_trb for safety.
-END MODULE mym_const_mod
+end module mym_const_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_const_set.F90 b/science/physics_schemes/source/boundary_layer/mym_const_set.F90
index e99d01b6b8..b3a1a1d876 100644
--- a/science/physics_schemes/source/boundary_layer/mym_const_set.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_const_set.F90
@@ -33,35 +33,35 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_const_set_mod
+module mym_const_set_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CONST_SET_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_CONST_SET_MOD'
+contains
-SUBROUTINE mym_const_set
+subroutine mym_const_set
-USE mym_const_mod, ONLY: g1,b1,b2,c2,c3,c4,c5,pr,a1,c1,a2,g2,a1_2, &
+use mym_const_mod, only: g1,b1,b2,c2,c3,c4,c5,pr,a1,c1,a2,g2,a1_2, &
rfc,f1,f2,rf1,rf2,smc,shc,ri1,ri2,ri3,ri4,cc2,cc3,e1c,e2c,e3c, &
e4c,e5c,my_alpha1,my_alpha2,my_alpha3,my_alpha4,elt_min, &
one_third,two_thirds,coef_trbvar_diff_tke,coef_trbvar_diff, &
qke_max,e_trb_max
-USE mym_option_mod, ONLY: l_my3_improved_closure
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use mym_option_mod, only: l_my3_improved_closure
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_CONST_SET'
+character(len=*), parameter :: RoutineName='MYM_CONST_SET'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-IF (l_my3_improved_closure) THEN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (l_my3_improved_closure) then
! closure constants in the improved MY model (MYNN)
g1 = 0.235
b1 = 24.0
@@ -71,7 +71,7 @@ SUBROUTINE mym_const_set
c4 = 0.0
c5 = 0.2
pr = 0.74
-ELSE
+else
! closure constants in the original MY model
g1 = 0.222
b1 = 16.6
@@ -81,7 +81,7 @@ SUBROUTINE mym_const_set
c4 = 0.0
c5 = 0.0
pr = 0.80
-END IF
+end if
! Combined constants
a1 = b1 * ( 1.0 - 3.0 * g1 ) / 6.0
c1 = g1 - 1.0 / ( 3.0 * a1 * b1 ** (1.0 / 3.0))
@@ -127,8 +127,8 @@ SUBROUTINE mym_const_set
qke_max = 500.0
e_trb_max = 0.5 * qke_max
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_const_set
-END MODULE mym_const_set_mod
+end subroutine mym_const_set
+end module mym_const_set_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_ctl.F90 b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
index 0b183e48c9..8203f91084 100644
--- a/science/physics_schemes/source/boundary_layer/mym_ctl.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
@@ -31,16 +31,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_ctl_mod
+module mym_ctl_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_CTL_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_CTL_MOD'
+contains
-SUBROUTINE mym_ctl( &
+subroutine mym_ctl( &
! IN levels/switches
bl_levels, levflag, &
BL_diag, &
@@ -54,26 +54,26 @@ SUBROUTINE mym_ctl( &
! OUT fields
visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq)
-USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, tdims_s
-USE bl_diags_mod, ONLY: strnewbldiag
-USE gen_phys_inputs_mod, ONLY: l_mr_physics
-USE mym_option_mod, ONLY: l_my_condense, l_shcu_buoy, &
+use atm_fields_bounds_mod, only: tdims, pdims, tdims_l, tdims_s
+use bl_diags_mod, only: strnewbldiag
+use gen_phys_inputs_mod, only: l_mr_physics
+use mym_option_mod, only: l_my_condense, l_shcu_buoy, &
my_lowest_pd_surf, tke_levels, l_my_initialize, l_my_ini_zero, &
my_ini_dbdz_min, l_3dtke
-USE parkind1, ONLY: jprb, jpim
-USE planet_constants_mod, ONLY: vkman, kappa, pref, c_virtual, g
-USE yomhook, ONLY: lhook, dr_hook
-USE mym_calcphi_mod, ONLY: mym_calcphi
-USE mym_condensation_mod, ONLY: mym_condensation
-USE mym_const_set_mod, ONLY: mym_const_set
-USE mym_initialize_mod, ONLY: mym_initialize
-USE mym_shcu_buoy_mod, ONLY: mym_shcu_buoy
-USE mym_turbulence_mod, ONLY: mym_turbulence
-IMPLICIT NONE
+use parkind1, only: jprb, jpim
+use planet_constants_mod, only: vkman, kappa, pref, c_virtual, g
+use yomhook, only: lhook, dr_hook
+use mym_calcphi_mod, only: mym_calcphi
+use mym_condensation_mod, only: mym_condensation
+use mym_const_set_mod, only: mym_const_set
+use mym_initialize_mod, only: mym_initialize
+use mym_shcu_buoy_mod, only: mym_shcu_buoy
+use mym_turbulence_mod, only: mym_turbulence
+implicit none
! Intent In Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels, &
! Max. no. of "boundary" levels
levflag
@@ -81,7 +81,7 @@ SUBROUTINE mym_ctl( &
! 2: level 2.5
! 3: level 3
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! Z_UV(*,K) is height of u level k
@@ -180,7 +180,7 @@ SUBROUTINE mym_ctl( &
! surface pressure
! Intent INOUT variables
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! TKE defined on theta levels K-1
@@ -211,10 +211,10 @@ SUBROUTINE mym_ctl( &
! the non-gradient buoyancy flux
! Declaration of BL diagnostics.
-TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+type (strnewbldiag), intent(in out) :: BL_diag
! Intent Out Variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
visc_m(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
visc_h(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end,bl_levels),&
rhogamu(tdims_s%i_start:tdims_s%i_end, &
@@ -235,14 +235,14 @@ SUBROUTINE mym_ctl( &
! defined at rho levels
! Local Variables
-INTEGER :: &
+integer :: &
i, j, k
! loop indexes
-LOGICAL, SAVE :: &
- l_first = .TRUE.
+logical, save :: &
+ l_first = .true.
! flag to indicate if it is the first execution
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
r_weight1, &
! weight factor to interpolate variables on rho
! levels onto theta levels
@@ -252,7 +252,7 @@ SUBROUTINE mym_ctl( &
weight3
! weight factor to interpolate variables on rho
! levels onto theta levels
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
pmz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! gradient function for momentum at the surface
! minus non-dimensional height (height / MO length)
@@ -311,56 +311,56 @@ SUBROUTINE mym_ctl( &
! cloud fraction corrected by shallow cumulus
! process on theta level K-1
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_CTL'
+character(len=*), parameter :: RoutineName='MYM_CTL'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
! Monin-Obkhov length
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
r_mosurf(i,j)= -vkman*fb_surf(i,j) &
- / MAX(u_s(i,j)*u_s(i,j)*u_s(i,j), TINY(1.0))
- END DO
-END DO
+ / max(u_s(i,j)*u_s(i,j)*u_s(i,j), tiny(1.0))
+ end do
+end do
-IF (l_first) THEN
- CALL mym_const_set
+if (l_first) then
+ call mym_const_set
! IF the first value of e_trb has been set to be missing by the
! reconfiguration, the initialization for the whole domain
! is essential.
- IF (l_my_initialize) THEN
- IF (l_my_ini_zero) THEN
- DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (l_my_initialize) then
+ if (l_my_ini_zero) then
+ do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.0
tsq_trb(i, j, k) = 0.0
qsq_trb(i, j, k) = 0.0
cov_trb(i, j, k) = 0.0
- END DO
- END DO
- END DO
- ELSE ! not l_my_ini_zero
+ end do
+ end do
+ end do
+ else ! not l_my_ini_zero
! Initialize the prognostic variables by assuming the balance
! between production and dissipation terms
! In the initialization, DBDZ by the LS cloud scheme is used.
! To avoid to diagnose huge TKE, the lower limit for DBDZ
! is imposed.
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- dbdz_l(i, j, k) = MAX(my_ini_dbdz_min, dbdz(i, j, k))
- END DO
- END DO
- END DO
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ dbdz_l(i, j, k) = max(my_ini_dbdz_min, dbdz(i, j, k))
+ end do
+ end do
+ end do
! Initialize the prognostic variables
- CALL mym_initialize( &
+ call mym_initialize( &
! IN levels
bl_levels, &
! IN fields
@@ -370,54 +370,54 @@ SUBROUTINE mym_ctl( &
e_trb, tsq_trb, qsq_trb, cov_trb)
! Above tke_levels, the prognostic variables should be zeros.
- DO k = tke_levels + 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do k = tke_levels + 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.0
tsq_trb(i, j, k) = 0.0
qsq_trb(i, j, k) = 0.0
cov_trb(i, j, k) = 0.0
- END DO
- END DO
- END DO
- END IF ! test if l_my_ini_zero
- END IF ! test if l_my_initialize
-
- IF (l_shcu_buoy .and. l_my_initialize) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+ end if ! test if l_my_ini_zero
+ end if ! test if l_my_initialize
+
+ if (l_shcu_buoy .and. l_my_initialize) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
zhpar_shcu(i,j) = z_tq(i,j,tke_levels-1)
- END DO
- END DO
- END IF
- l_first = .FALSE.
-END IF ! IF L_FIRST
+ end do
+ end do
+ end if
+ l_first = .false.
+end if ! IF L_FIRST
! copy e_trb to qke (qke = 2 e_trb)
-DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
qke(i, j, k) = 2.0 * e_trb(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Set virtual temperature, exner function, and g / thetav
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
tv(i, j, k) = t(i, j, k - 1) &
* (1.0 + c_virtual * q(i, j, k - 1) &
- qcl(i, j, k - 1) - qcf(i, j, k - 1))
exner(i, j, k) = &
(p_theta_levels(i, j, k - 1) / pref) ** kappa
gtr(i, j, k) = g * exner(i, j, k) / tv(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-IF (l_my_condense .OR. l_shcu_buoy) THEN
- CALL mym_condensation( &
+if (l_my_condense .or. l_shcu_buoy) then
+ call mym_condensation( &
! IN levels/switches
bl_levels, levflag, &
BL_diag, &
@@ -425,60 +425,60 @@ SUBROUTINE mym_ctl( &
qw, tl, t, p_theta_levels, tsq_trb, qsq_trb, cov_trb, &
! OUT fields
vt, vq, q1, cld, ql)
-END IF
+end if
-IF (l_my_condense) THEN
+if (l_my_condense) then
! Re-evaluate DBDZ with the buoyancy parameters diagnosed by
! mym_condensation
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
dbdz_l(i,j,k) = gtr(i, j, k) &
* ( vt(i, j, k) * dtldzm(i, j, k) + &
vq(i, j, k) * dqwdzm(i, j, k) )
- END DO
- END DO
- END DO
-ELSE
+ end do
+ end do
+ end do
+else
! Use the buoyancy parameters and DBDZ by the LS cloud scheme
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
! convert buoy params from the UM notation to the MY notaation
vt(i, j, k) = bt_gb(i, j, k - 1) * tv(i, j, k)
vq(i, j, k) = bq_gb(i, j, k - 1) * tv(i, j, k) &
/ exner(i, j, k)
dbdz_l(i,j,k) = dbdz(i,j,k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_dbdz) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_dbdz) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%dbdz(i, j, k) = dbdz_l(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_dvdzm) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_dvdzm) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%dvdzm(i,j,k) = dvdzm(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (l_shcu_buoy) THEN
+if (l_shcu_buoy) then
! Evaluate the non-gradient buoyancy flux
- CALL mym_shcu_buoy( &
+ call mym_shcu_buoy( &
! IN levels/switches
bl_levels, &
BL_diag, &
@@ -488,28 +488,28 @@ SUBROUTINE mym_ctl( &
u_p, v_p, t, q, qcl, qcf, q1, cld, &
! INOUT / OUT fields
zhpar_shcu,frac_shcu, wb_ng)
-ELSE
- DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+else
+ do k = 1, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
wb_ng(i,j,k) = 0.0
frac_shcu(i,j,k) = cld(i,j,k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (my_lowest_pd_surf > 0) THEN
+if (my_lowest_pd_surf > 0) then
! Calculate the gradient functions at the surface
- CALL mym_calcphi( &
+ call mym_calcphi( &
bl_levels, z_tq, r_mosurf, pmz, phh)
-END IF
+end if
! Calculate diffusion coefficients and counter gradient terms,
! and integrate the prognostic variables.
-CALL mym_turbulence( &
+call mym_turbulence( &
! IN levels/switches
bl_levels, levflag, BL_diag, &
! IN fields
@@ -522,59 +522,59 @@ SUBROUTINE mym_ctl( &
! OUT fields
rhogamu, rhogamv, rhogamt_tq, rhogamq_tq)
-IF (l_3dtke) THEN
- DO k = 1, bl_levels-1
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+if (l_3dtke) then
+ do k = 1, bl_levels-1
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
visc_m(i,j,k) = rhokm(i,j,k+1)
visc_h(i,j,k) = rhokh_tq(i,j,k+1)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
! multiply the density
-DO k = 2, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
rhokm(i, j, k) = rho_wet_tq(i, j, k - 1) * rhokm(i, j, k)
rhogamu(i, j, k) = rho_wet_tq(i, j, k - 1) * rhogamu(i, j, k)
rhogamv(i, j, k) = rho_wet_tq(i, j, k - 1) * rhogamv(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Note "RHO" here is always wet density (RHO_WET_TQ) so
! save multiplication of RHOKH to after interpolation
-IF (.NOT. l_mr_physics) THEN
- DO k = 2, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (.not. l_mr_physics) then
+ do k = 2, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
rhokh_tq(i, j, k) = rho_wet_tq(i, j, k - 1) &
* rhokh_tq(i, j, k)
rhogamt_tq(i, j, k) = rho_wet_tq(i, j, k - 1) &
* rhogamt_tq(i, j, k)
rhogamq_tq(i, j, k) = rho_wet_tq(i, j, k - 1) &
* rhogamq_tq(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
! convert qke to e_trb
-DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.5 * qke(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Interpolate RHOKH_TQ, RHOGAMT_TQ and RHOGAMQ_TQ on theta levels
! to rho levels.
-DO k = 2, tke_levels - 1
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels - 1
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
r_weight1 = 1.0 / (z_tq(i,j,k) - &
z_tq(i,j, k-1))
weight2 = (z_tq(i,j,k) - &
@@ -590,13 +590,13 @@ SUBROUTINE mym_ctl( &
rhogamq(i,j,k) = &
weight3 * rhogamq_tq(i,j,k+1) &
+weight2 * rhogamq_tq(i,j,k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
k = tke_levels
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
r_weight1 = 1.0 / (z_tq(i,j,k) - &
z_tq(i,j, k-1))
weight2 = (z_tq(i,j,k) - &
@@ -606,35 +606,35 @@ SUBROUTINE mym_ctl( &
rhokh(i,j,k) = weight2 * rhokh_tq(i,j,k)
rhogamt(i,j,k) = weight2 * rhogamt_tq(i,j,k)
rhogamq(i,j,k) = weight2 * rhogamq_tq(i,j,k)
- END DO
-END DO
+ end do
+end do
! Above tke_levels, fluxes should be zero.
-DO k = tke_levels + 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = tke_levels + 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
rhokh(i, j, k) = 0.0
rhogamt(i, j, k) = 0.0
rhogamq(i, j, k) = 0.0
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Finally multiply RHOKH by dry density
-IF (l_mr_physics) THEN
- DO k = 2, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (l_mr_physics) then
+ do k = 2, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
rhokh(i, j, k) = rho_mix(i, j, k) * rhokh(i, j, k)
rhogamt(i, j, k) = rho_mix(i, j, k) * rhogamt(i, j, k)
rhogamq(i, j, k) = rho_mix(i, j, k) * rhogamq(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_ctl
-END MODULE mym_ctl_mod
+end subroutine mym_ctl
+end module mym_ctl_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90 b/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
index ae3798177c..496b26ff82 100644
--- a/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90
@@ -13,35 +13,35 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_diff_matcoef_mod
+module mym_diff_matcoef_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_DIFF_MATCOEF_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_DIFF_MATCOEF_MOD'
+contains
-SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
+subroutine mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
-USE atm_fields_bounds_mod, ONLY: pdims, tdims_s, tdims
-USE mym_option_mod, ONLY: &
+use atm_fields_bounds_mod, only: pdims, tdims_s, tdims
+use mym_option_mod, only: &
l_my_extra_level, my_z_extra_fact, tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" level
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
coef
! factor for the diffusion coefficients to those for
! momentum
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! Z_UV(*,K) is height of u level k
@@ -53,7 +53,7 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
! diffusion coefficients for momentum
! Intent OUT variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
! coefficients of tri-diagonal equations
! due to diffusion
aa(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
@@ -64,16 +64,16 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
! coefs of fields on level K+1
! Local variables
-INTEGER :: &
+integer :: &
i, j, k, k_start
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
km_m1, &
! diffusion coefficient on lower level by one
km_p1
! diffusion coefficient on upper level by one
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
r_dr_rho(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
tke_levels), &
! reciprocal of grid spaces of rho levels
@@ -87,15 +87,15 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
! weight to interporate variables on theta levels
! onto rho levels
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_DIFF_MATCOEF'
+character(len=*), parameter :: RoutineName='MYM_DIFF_MATCOEF'
! Calculate and save r_dr and weight
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
k = 1
do j = tdims%j_start, tdims%j_end
@@ -107,22 +107,22 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
end do
end do
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
r_dr_theta(i, j, k) = 1.0 / (z_uv(i, j, k + 1) - z_uv(i, j, k))
r_dr_rho(i, j, k) = 1.0 / (z_tq(i, j, k) - z_tq(i, j, k - 1))
weight1(i, j, k) = (z_uv(i, j, k) - z_tq(i, j, k - 1)) * r_dr_rho(i, j, k)
weight2(i, j, k) = (z_tq(i, j, k) - z_uv(i, j, k)) * r_dr_rho(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Calculate aa, bb, cc
k = 2
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
km_m1 = coef * dfm(i, j, k)
km_p1 = coef * &
(weight1(i, j, k) * dfm(i, j, k + 1) &
@@ -133,12 +133,12 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
aa(i, j, k) = km_m1 * r_dr_rho(i, j, k - 1) &
* r_dr_theta(i, j, k - 1)
bb(i, j, k) = -aa(i, j, k) - cc(i, j, k)
- END DO
-END DO
+ end do
+end do
-DO k = 3, tke_levels - 1
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 3, tke_levels - 1
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
km_m1 = coef * &
(weight1(i, j, k - 1) * dfm(i, j, k) &
+ weight2(i, j, k - 1) * dfm(i, j, k - 1))
@@ -152,13 +152,13 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
* r_dr_theta(i, j, k - 1)
bb(i, j, k) = -aa(i, j, k) - cc(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
k = tke_levels
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
km_m1 = coef * &
(weight1(i, j, k - 1) * dfm(i, j, k) &
+ weight2(i, j, k - 1) * dfm(i, j, k - 1))
@@ -171,40 +171,40 @@ SUBROUTINE mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
* r_dr_theta(i, j, k - 1)
bb(i, j, k) = -aa(i, j, k) - cc(i, j, k)
- END DO
-END DO
+ end do
+end do
-IF (l_my_extra_level) THEN
+if (l_my_extra_level) then
k_start = 1
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
aa(i, j, 1) = 0.0
cc(i, j, 1) = coef * dfm(i, j, 2) &
/ (z_tq(i, j, 1) &
* my_z_extra_fact) ** 2
bb(i, j, 1) = - aa(i, j, 1) - cc(i, j, 1)
- END DO
- END DO
-ELSE
+ end do
+ end do
+else
k_start = 2
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
aa(i, j, 1) = 0.0
bb(i, j, 1) = 0.0
cc(i, j, 1) = 0.0
- END DO
- END DO
-END IF
+ end do
+ end do
+end if
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
aa(i, j, k_start) = 0.0
cc(i, j, tke_levels) = 0.0
- END DO
-END DO
+ end do
+end do
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_diff_matcoef
-END MODULE mym_diff_matcoef_mod
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_diff_matcoef
+end module mym_diff_matcoef_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_errfunc.F90 b/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
index 2ed82fb1cb..40fbda7cee 100644
--- a/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
@@ -16,32 +16,32 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_errfunc_mod
+module mym_errfunc_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_ERRFUNC_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_ERRFUNC_MOD'
+contains
-SUBROUTINE mym_errfunc(nn, x, y)
+subroutine mym_errfunc(nn, x, y)
-USE conversions_mod, ONLY: pi
-USE yomhook, ONLY: lhook, dr_hook
-USE parkind1, ONLY: jprb, jpim
-IMPLICIT NONE
+use conversions_mod, only: pi
+use yomhook, only: lhook, dr_hook
+use parkind1, only: jprb, jpim
+implicit none
-INTEGER, INTENT(IN) :: nn ! size of array
+integer, intent(in) :: nn ! size of array
-REAL(KIND=real_umphys), INTENT(IN) :: x(nn) ! input array
+real(kind=r_bl), intent(in) :: x(nn) ! input array
-REAL(KIND=real_umphys), INTENT(OUT) :: y(nn) ! output array
+real(kind=r_bl), intent(out) :: y(nn) ! output array
! Local Variables
-INTEGER :: i ! Loop index
+integer :: i ! Loop index
-REAL(KIND=real_umphys), SAVE :: &
+real(kind=r_bl), save :: &
c01, &
! expansion coefficient of x
c03, &
@@ -59,7 +59,7 @@ SUBROUTINE mym_errfunc(nn, x, y)
factor
! common factor to all the coefficients
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
x02, &
! x powered by 2
x04, &
@@ -73,23 +73,23 @@ SUBROUTINE mym_errfunc(nn, x, y)
x12
! x powered by 12
-LOGICAL, SAVE :: first = .TRUE.
+logical, save :: first = .true.
! flag to indication first run
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
erfmax = 1.0
! upper limit of the value to avoid it outside domain
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_ERRFUNC'
+character(len=*), parameter :: RoutineName='MYM_ERRFUNC'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-IF (first) THEN
- factor = 2.0 / SQRT(pi)
+if (first) then
+ factor = 2.0 / sqrt(pi)
c01 = factor * 1.0
c03 = factor * 1.0 / 3.0
c05 = factor * 1.0 / 10.0
@@ -97,9 +97,9 @@ SUBROUTINE mym_errfunc(nn, x, y)
c09 = factor * 1.0 / 216.0
c11 = factor * 1.0 / 1320.0
c13 = factor * 1.0 / 9360.0
- first = .FALSE.
-END IF
-DO i = 1, nn
+ first = .false.
+end if
+do i = 1, nn
x02 = x(i) * x(i)
x04 = x02 * x02
x06 = x04 * x02
@@ -114,13 +114,13 @@ SUBROUTINE mym_errfunc(nn, x, y)
+ c09 * x08 &
- c11 * x10 &
+ c13 * x12)
- IF (x(i) > 0) THEN
- y(i) = MIN(y(i), erfmax)
- ELSE
- y(i) = MAX(y(i), -erfmax)
- END IF
-END DO
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_errfunc
-END MODULE mym_errfunc_mod
+ if (x(i) > 0) then
+ y(i) = min(y(i), erfmax)
+ else
+ y(i) = max(y(i), -erfmax)
+ end if
+end do
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_errfunc
+end module mym_errfunc_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90 b/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
index 379f42f6c6..24fc7e19ca 100644
--- a/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90
@@ -13,35 +13,35 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_ex_flux_tq_mod
+module mym_ex_flux_tq_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_EX_FLUX_TQ_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_EX_FLUX_TQ_MOD'
+contains
-SUBROUTINE mym_ex_flux_tq( &
+subroutine mym_ex_flux_tq( &
bl_levels, &
tl, qw, rhokh, rhogamt, rhogamq, rdz, &
ftl, fqw)
-USE atm_fields_bounds_mod, ONLY: tdims, pdims
-USE model_domain_mod, ONLY: model_type, mt_single_column
-USE planet_constants_mod, ONLY: cp, grcp
+use atm_fields_bounds_mod, only: tdims, pdims
+use model_domain_mod, only: model_type, mt_single_column
+use planet_constants_mod, only: cp, grcp
-USE yomhook, ONLY: lhook, dr_hook
-USE parkind1, ONLY: jprb, jpim
+use yomhook, only: lhook, dr_hook
+use parkind1, only: jprb, jpim
-IMPLICIT NONE
+implicit none
! INTENT IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
tl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
! Liquid/frozen water temperture (K)
qw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels), &
@@ -66,7 +66,7 @@ SUBROUTINE mym_ex_flux_tq( &
! K-1 to level K.
! INTENT OUT Variables
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
ftl(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
! FTL(,K) contains net turb
! sensible heat flux into layer K
@@ -80,14 +80,14 @@ SUBROUTINE mym_ex_flux_tq( &
! from surface, 'E'.
! defined on rho levels
-CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_EX_FLUX_TQ'
+character(len=*), parameter :: RoutineName = 'MYM_EX_FLUX_TQ'
! LOCAL VARIABLES.
-INTEGER :: &
+integer :: &
i, j, k
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
grad_ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! Gradient part of FTL
@@ -103,28 +103,28 @@ SUBROUTINE mym_ex_flux_tq( &
bl_levels)
! Counter gradient part of FQW
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
!-----------------------------------------------------------------------
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
grad_ftl(i,j,k)=0.0
grad_fqw(i,j,k)=0.0
count_grad_ftl(i,j,k)=0.0
count_grad_fqw(i,j,k)=0.0
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO k = 2, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
grad_ftl(i,j,k)= - rhokh(i,j,k) * &
( ( ( tl(i,j,k) - tl(i,j,k-1) ) * rdz(i,j,k) ) &
+ grcp )
@@ -134,11 +134,11 @@ SUBROUTINE mym_ex_flux_tq( &
count_grad_fqw(i,j,k) = -rhogamq(i,j,k)
ftl(i,j,k) = grad_ftl(i,j,k) + count_grad_ftl(i,j,k)
fqw(i,j,k) = grad_fqw(i,j,k) + count_grad_fqw(i,j,k)
- END DO
- END DO
-END DO
-
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_ex_flux_tq
-END MODULE mym_ex_flux_tq_mod
+ end do
+ end do
+end do
+
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_ex_flux_tq
+end module mym_ex_flux_tq_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90 b/science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90
index ecf819cc80..95fb47cd5e 100644
--- a/science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_ex_flux_uv.F90
@@ -13,36 +13,36 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_ex_flux_uv_mod
+module mym_ex_flux_uv_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_EX_FLUX_UV_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_EX_FLUX_UV_MOD'
+contains
-SUBROUTINE mym_ex_flux_uv( &
+subroutine mym_ex_flux_uv( &
dimsi, dimsi_s, dimso, bl_levels, &
rdz_u_v, rhokm_u_v, rhogamuv_uv, u_v, tau_xy_fd_uv, &
tau_x_y, tau_grad, tau_count_grad)
-USE atm_fields_bounds_mod, ONLY: array_dims
-USE jules_surface_mod, ONLY: formdrag, explicit_stress
-USE yomhook, ONLY: lhook, dr_hook
-USE parkind1, ONLY: jprb, jpim
-IMPLICIT NONE
+use atm_fields_bounds_mod, only: array_dims
+use jules_surface_mod, only: formdrag, explicit_stress
+use yomhook, only: lhook, dr_hook
+use parkind1, only: jprb, jpim
+implicit none
! Intent IN Variables
-TYPE(array_dims), INTENT(IN) :: &
+type(array_dims), intent(in) :: &
dimsi, & ! Array dimensions for the inputs
dimsi_s, & ! Array dimensions for input u or v (has haloes).
dimso ! Array dimensions for the outputs and work variables
-INTEGER, INTENT(IN) :: bl_levels
+integer, intent(in) :: bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
rdz_u_v (dimsi%i_start:dimsi%i_end, &
dimsi%j_start:dimsi%j_end, 2:bl_levels), &
! Reciprocal of the vertical
@@ -68,7 +68,7 @@ SUBROUTINE mym_ex_flux_uv( &
! at a UV point
! Intent INOUT Variables
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
tau_x_y (dimso%i_start:dimso%i_end, &
dimso%j_start:dimso%j_end, bl_levels)
! explicit x_y-component of
@@ -78,7 +78,7 @@ SUBROUTINE mym_ex_flux_uv( &
! set to "missing data". (N/sq m)
! Intent OUT Variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
tau_grad(dimso%i_start:dimso%i_end, &
dimso%j_start:dimso%j_end,bl_levels), &
! k*du/dz grad stress (kg/m/s2)
@@ -87,52 +87,52 @@ SUBROUTINE mym_ex_flux_uv( &
! Counter gradient stress (kg/m/s2)
! LOCAL VARIABLES.
-INTEGER :: &
+integer :: &
i, j, k
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_EX_FLUX_UV'
+character(len=*), parameter :: RoutineName='MYM_EX_FLUX_UV'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
k=1
-DO j = dimso%j_start, dimso%j_end
- DO i = dimso%i_start, dimso%i_end
+do j = dimso%j_start, dimso%j_end
+ do i = dimso%i_start, dimso%i_end
tau_grad(i,j,k) = 0.0
tau_count_grad(i,j,k) = 0.0
- END DO
-END DO
+ end do
+end do
-DO k = 2, bl_levels
- DO j = dimso%j_start, dimso%j_end
- DO i = dimso%i_start, dimso%i_end
+do k = 2, bl_levels
+ do j = dimso%j_start, dimso%j_end
+ do i = dimso%i_start, dimso%i_end
tau_grad(i,j,k) = rhokm_u_v(i,j,k) * &
( u_v(i,j,k) - u_v(i,j,k-1) ) *rdz_u_v(i,j,k)
tau_count_grad(i,j,k) = rhogamuv_uv(i, j, k)
tau_x_y(i,j,k) = tau_grad(i,j,k) + tau_count_grad(i,j,k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Add explicit orographic stress, noting that the surface stress
! is to be added later
-IF (formdrag == explicit_stress) THEN
- DO k = 2, bl_levels
- DO j = dimso%j_start, dimso%j_end
- DO i = dimso%i_start, dimso%i_end
+if (formdrag == explicit_stress) then
+ do k = 2, bl_levels
+ do j = dimso%j_start, dimso%j_end
+ do i = dimso%i_start, dimso%i_end
tau_x_y(i,j,k) = tau_x_y(i,j,k) + tau_xy_fd_uv(i,j,k)
- END DO
- END DO
- END DO
-END IF
-
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_ex_flux_uv
-END MODULE mym_ex_flux_uv_mod
+ end do
+ end do
+ end do
+end if
+
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_ex_flux_uv
+end module mym_ex_flux_uv_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_implic.F90 b/science/physics_schemes/source/boundary_layer/mym_implic.F90
index c0a3a557db..eb97bd0709 100644
--- a/science/physics_schemes/source/boundary_layer/mym_implic.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_implic.F90
@@ -14,23 +14,23 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_implic_mod
+module mym_implic_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_IMPLIC_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_IMPLIC_MOD'
+contains
-SUBROUTINE mym_implic(levels, kst, ken, aa, bb, cc, qq)
+subroutine mym_implic(levels, kst, ken, aa, bb, cc, qq)
-USE atm_fields_bounds_mod, ONLY: pdims
-USE yomhook, ONLY: lhook, dr_hook
-USE parkind1, ONLY: jprb, jpim
-IMPLICIT NONE
+use atm_fields_bounds_mod, only: pdims
+use yomhook, only: lhook, dr_hook
+use parkind1, only: jprb, jpim
+implicit none
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
levels, &
! number of levels of variables to be solved
kst, &
@@ -38,7 +38,7 @@ SUBROUTINE mym_implic(levels, kst, ken, aa, bb, cc, qq)
ken
! index of emd level to be solved
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
aa(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, levels), &
! coefficients of fields on level K-1
! in the tri-diagonal equation
@@ -52,47 +52,47 @@ SUBROUTINE mym_implic(levels, kst, ken, aa, bb, cc, qq)
! right hand side of the tri-diagonal equation
! Local variables
-INTEGER :: &
+integer :: &
i, j, k
! Loop indexes
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_IMPLIC'
+character(len=*), parameter :: RoutineName='MYM_IMPLIC'
! Solve from top to bottom
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO k = ken, kst + 1, -1
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = ken, kst + 1, -1
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
aa(i, j, k - 1) = aa(i, j, k - 1) * bb(i, j, k)
bb(i, j, k - 1) = bb(i, j, k - 1) * bb(i, j, k) &
- aa(i, j, k) * cc(i, j, k - 1)
qq(i, j, k - 1) = qq(i, j, k - 1) * bb(i, j, k) &
- qq(i, j, k) * cc(i, j, k - 1)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
qq(i, j, kst) = qq(i, j, kst) / bb(i, j, kst)
- END DO
-END DO
+ end do
+end do
! Solve from bottom to top
-DO k = kst + 1, ken
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = kst + 1, ken
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
qq(i, j, k) = (qq(i, j, k) - aa(i, j, k) * &
qq(i, j, k - 1)) / bb(i, j, k)
- END DO
- END DO
-END DO
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_implic
-END MODULE mym_implic_mod
+ end do
+ end do
+end do
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_implic
+end module mym_implic_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_initialize.F90 b/science/physics_schemes/source/boundary_layer/mym_initialize.F90
index 1e1dcc59f4..b53f81b76d 100644
--- a/science/physics_schemes/source/boundary_layer/mym_initialize.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_initialize.F90
@@ -34,16 +34,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_initialize_mod
+module mym_initialize_mod
-USE um_types, ONLY: real_umphys, real_eps
+use um_types, only: r_bl, real_eps
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_INITIALIZE_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_INITIALIZE_MOD'
+contains
-SUBROUTINE mym_initialize( &
+subroutine mym_initialize( &
! IN levels
bl_levels, &
! IN fields
@@ -52,29 +52,29 @@ SUBROUTINE mym_initialize( &
! INOUT fields
e_trb, tsq, qsq, cov)
-USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_s
-USE mym_const_mod, ONLY: b1, b2, qke_max, coef_trbvar_diff, &
+use atm_fields_bounds_mod, only: tdims, pdims, tdims_s
+use mym_const_mod, only: b1, b2, qke_max, coef_trbvar_diff, &
coef_trbvar_diff_tke
-USE mym_option_mod, ONLY: &
+use mym_option_mod, only: &
my_lowest_pd_surf, l_my_extra_level, my_z_extra_fact, &
tke_levels, l_my_lowest_pd_surf_tqc
-USE planet_constants_mod, ONLY: vkman
+use planet_constants_mod, only: vkman
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-USE mym_calcphi_mod, ONLY: mym_calcphi
-USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
-USE mym_implic_mod, ONLY: mym_implic
-USE mym_length_mod, ONLY: mym_length
-USE mym_level2_mod, ONLY: mym_level2
-IMPLICIT NONE
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+use mym_calcphi_mod, only: mym_calcphi
+use mym_diff_matcoef_mod, only: mym_diff_matcoef
+use mym_implic_mod, only: mym_implic
+use mym_length_mod, only: mym_length
+use mym_level2_mod, only: mym_level2
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! Z_UV(*,K) is height of u level k
@@ -121,7 +121,7 @@ SUBROUTINE mym_initialize( &
! IN delta_x used by Smagorinsky
! Intent INOUT Variables
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! TKE defined on theta levels K-1
@@ -139,17 +139,17 @@ SUBROUTINE mym_initialize( &
! (thetal'qw') defined on theta levels K-1
! Local variables
-INTEGER :: &
+integer :: &
i, j, k, ll
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
phm, &
! gradient function at the surface
elq
! mixing length * qkw
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
gm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! square of wind shear on theta level K-1
! (a denominator of gradient Richardson number)
@@ -175,7 +175,7 @@ SUBROUTINE mym_initialize( &
phh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! gradient function for scalars
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
pdk(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! production terms of qke divided by elq
@@ -249,44 +249,44 @@ SUBROUTINE mym_initialize( &
! diffusion coefficient for momentum
! on theta level K-1
-INTEGER :: &
+integer :: &
my3_itr_ini
! number of iteration
-INTEGER :: k_start
+integer :: k_start
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_INITIALIZE'
+character(len=*), parameter :: RoutineName='MYM_INITIALIZE'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
my3_itr_ini = tke_levels + 1
-IF (my_lowest_pd_surf == 0) THEN
- l_my_extra_level = .FALSE.
+if (my_lowest_pd_surf == 0) then
+ l_my_extra_level = .false.
my_z_extra_fact = 1.0
-END IF
+end if
-IF (l_my_extra_level) THEN
+if (l_my_extra_level) then
k_start = 1
-ELSE
+else
k_start = 2
-END IF
+end if
-DO k = 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
e_trb(i, j, k) = 0.0
tsq(i, j, k) = 0.0
qsq(i, j, k) = 0.0
cov(i, j, k) = 0.0
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-CALL mym_level2( &
+call mym_level2( &
bl_levels, dbdz, dvdzm, gm, gh, sm, sh)
do j = tdims%j_start, tdims%j_end
@@ -295,100 +295,100 @@ SUBROUTINE mym_initialize( &
end do
end do
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk(i, j, k) = sm(i, j, k) * gm(i, j, k) &
+ sh(i, j, k) * gh(i, j, k)
- IF (pdk(i, j, k) <= 0.0) THEN
+ if (pdk(i, j, k) <= 0.0) then
qke_nohalo(i, j, k) = 0.0
pdk(i, j, k) = 0.0
pdt(i, j, k) = 0.0
pdq(i, j, k) = 0.0
pdc(i, j, k) = 0.0
- ELSE
+ else
qke_nohalo(i, j, k) = 1.0e-5
pdt(i, j, k) = sh(i, j, k) * dtldzm(i, j, k) ** 2
pdq(i, j, k) = sh(i, j, k) * dqwdzm(i, j, k) ** 2
pdc(i, j, k) = sh(i, j, k) * dtldzm(i, j, k) * dqwdzm(i, j, k)
- END IF
- END DO
- END DO
-END DO
+ end if
+ end do
+ end do
+end do
-IF (my_lowest_pd_surf > 0) THEN
- CALL mym_calcphi( &
+if (my_lowest_pd_surf > 0) then
+ call mym_calcphi( &
bl_levels, z_tq, r_mosurf, pmz, phh)
- IF (l_my_extra_level) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (l_my_extra_level) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk0(i, j) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
/ (vkman * z_tq(i, j, 1) * my_z_extra_fact)
- END DO
- END DO
+ end do
+ end do
- IF (l_my_lowest_pd_surf_tqc) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (l_my_lowest_pd_surf_tqc) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
phm = 1.0 / u_s(i, j) * phh(i, j) &
/ (vkman * z_tq(i, j, 1) * my_z_extra_fact)
pdt0(i, j) = phm * ftl(i, j, 1) ** 2
pdq0(i, j) = phm * fqw(i, j, 1) ** 2
pdc0(i, j) = phm * ftl(i, j, 1) * fqw(i, j, 1)
- END DO
- END DO
- END IF
- ELSE
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end if
+ else
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk0(i, j) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
/ (vkman * z_tq(i, j, 1))
- END DO
- END DO
+ end do
+ end do
- IF (l_my_lowest_pd_surf_tqc) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (l_my_lowest_pd_surf_tqc) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
phm = 1.0 / u_s(i, j)* phh(i, j) &
/ (vkman * z_tq(i, j, 1))
pdt0(i, j) = phm * ftl(i, j, 1) ** 2
pdq0(i, j) = phm * fqw(i, j, 1) ** 2
pdc0(i, j) = phm * ftl(i, j, 1) * fqw(i, j, 1)
- END DO
- END DO
- END IF
- END IF ! IF L_MY_EXTRA_LEVEL
-END IF ! IF MY_lowest_pd_surf
-
-DO ll = 1, my3_itr_ini
- CALL mym_length( &
+ end do
+ end do
+ end if
+ end if ! IF L_MY_EXTRA_LEVEL
+end if ! IF MY_lowest_pd_surf
+
+do ll = 1, my3_itr_ini
+ call mym_length( &
tdims%i_end, tdims%j_end, 0, 0, bl_levels, &
qke_nohalo, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, &
qkw, el)
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (qke_nohalo(i, j, k) <= 0.0) THEN
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (qke_nohalo(i, j, k) <= 0.0) then
qkw(i, j, k) = 0.0
- END IF
+ end if
dfm(i, j, k) = sm(i, j, k) * qkw(i, j, k) * el(i, j, k)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- CALL mym_diff_matcoef( &
+ call mym_diff_matcoef( &
bl_levels, coef_trbvar_diff_tke, z_uv, z_tq, dfm, &
aa_qke, bb_qke, cc_qke)
- CALL mym_diff_matcoef( &
+ call mym_diff_matcoef( &
bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, &
aa_oth, bb_oth, cc_oth)
- DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (bb_qke(i, j, k) == 0.0) THEN
+ do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (bb_qke(i, j, k) == 0.0) then
aa_qke(i, j, k) = 0.0
bb_qke(i, j, k) = 1.0
cc_qke(i, j, k) = 0.0
@@ -408,12 +408,12 @@ SUBROUTINE mym_initialize( &
bb_cov(i, j, k) = 1.0
cc_cov(i, j, k) = 0.0
cov(i, j, k) = 0.0
- ELSE
+ else
elq = qkw(i, j, k) * el(i, j, k)
aa_qke(i, j, k) = - aa_qke(i, j, k)
bb_qke(i, j, k) = - bb_qke(i, j, k) &
+ 2.0 * qkw(i, j, k) / (b1 * el(i, j, k))
- bb_qke(i, j, k) = SIGN(MAX(ABS(bb_qke(i, j, k)), 1.0e-20_real_umphys),&
+ bb_qke(i, j, k) = sign(max(abs(bb_qke(i, j, k)), 1.0e-20_r_bl),&
bb_qke(i, j, k))
cc_qke(i, j, k) = - cc_qke(i, j, k)
@@ -422,7 +422,7 @@ SUBROUTINE mym_initialize( &
aa_oth(i, j, k) = - aa_oth(i, j, k)
bb_oth(i, j, k) = - bb_oth(i, j, k) &
+ 2.0 * qkw(i, j, k) / (b2 * el(i, j, k))
- bb_oth(i, j, k) = SIGN(MAX(ABS(bb_oth(i, j, k)), 1.0e-20_real_umphys),&
+ bb_oth(i, j, k) = sign(max(abs(bb_oth(i, j, k)), 1.0e-20_r_bl),&
bb_oth(i, j, k))
cc_oth(i, j, k) = - cc_oth(i, j, k)
@@ -440,66 +440,66 @@ SUBROUTINE mym_initialize( &
bb_cov(i, j, k) = bb_oth(i, j, k)
cc_cov(i, j, k) = cc_oth(i, j, k)
cov(i, j, k) = 2.0 * elq * pdc(i, j, k)
- END IF
- END DO
- END DO
- END DO
+ end if
+ end do
+ end do
+ end do
- IF (my_lowest_pd_surf > 0) THEN
+ if (my_lowest_pd_surf > 0) then
k = k_start
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (ABS(bb_qke(i, j, k)) >= real_eps) THEN
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (abs(bb_qke(i, j, k)) >= real_eps) then
qke_nohalo(i, j, k) = 2.0 * pdk0(i, j)
- END IF
- END DO
- END DO
-
- IF (l_my_lowest_pd_surf_tqc) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (ABS(bb_qke(i, j, k)) >= real_eps) THEN
+ end if
+ end do
+ end do
+
+ if (l_my_lowest_pd_surf_tqc) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (abs(bb_qke(i, j, k)) >= real_eps) then
tsq(i, j, k) = 2.0 * pdt0(i, j)
qsq(i, j, k) = 2.0 * pdq0(i, j)
cov(i, j, k) = 2.0 * pdc0(i, j)
- END IF
- END DO
- END DO
- END IF ! IF L_MY_lowest_pd_surf_tqc
- END IF ! IF MY_lowest_pd_surf > 0
+ end if
+ end do
+ end do
+ end if ! IF L_MY_lowest_pd_surf_tqc
+ end if ! IF MY_lowest_pd_surf > 0
- CALL mym_implic( &
+ call mym_implic( &
tke_levels, k_start, tke_levels, &
aa_qke, bb_qke, cc_qke, qke_nohalo)
- CALL mym_implic( &
+ call mym_implic( &
tke_levels, k_start, tke_levels, &
aa_tsq, bb_tsq, cc_tsq, tsq)
- CALL mym_implic( &
+ call mym_implic( &
tke_levels, k_start, tke_levels, &
aa_qsq, bb_qsq, cc_qsq, qsq)
- CALL mym_implic( &
+ call mym_implic( &
tke_levels, k_start, tke_levels, &
aa_cov, bb_cov, cc_cov, cov)
-END DO ! iteration ll = 1, my3_itr_ini
+end do ! iteration ll = 1, my3_itr_ini
-DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- e_trb(i, j, k) = 0.5 * MIN( &
- MAX(qke_nohalo(i, j, k), 1.0e-20), &
+do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ e_trb(i, j, k) = 0.5 * min( &
+ max(qke_nohalo(i, j, k), 1.0e-20), &
qke_max)
- tsq(i, j, k) = MAX(tsq(i, j, k), 0.0)
- qsq(i, j, k) = MAX(qsq(i, j, k), 0.0)
- END DO
- END DO
-END DO
+ tsq(i, j, k) = max(tsq(i, j, k), 0.0)
+ qsq(i, j, k) = max(qsq(i, j, k), 0.0)
+ end do
+ end do
+end do
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_initialize
-END MODULE mym_initialize_mod
+end subroutine mym_initialize
+end module mym_initialize_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_length.F90 b/science/physics_schemes/source/boundary_layer/mym_length.F90
index 4afceb5f1e..e70b4e16d6 100644
--- a/science/physics_schemes/source/boundary_layer/mym_length.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_length.F90
@@ -33,31 +33,31 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_length_mod
+module mym_length_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_LENGTH_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_LENGTH_MOD'
+contains
-SUBROUTINE mym_length( &
+subroutine mym_length( &
row_length, rows, halo_i, halo_j, bl_levels, &
qke, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, &
qkw, el)
-USE mym_const_mod, ONLY: my_alpha4, one_third, elt_min, my_alpha1, &
+use mym_const_mod, only: my_alpha4, one_third, elt_min, my_alpha1, &
my_alpha2, my_alpha3
-USE mym_option_mod, ONLY: tke_levels, my_z_limit_elb, l_3dtke
-USE parkind1, ONLY: jprb, jpim
-USE planet_constants_mod, ONLY: vkman
-USE yomhook, ONLY: lhook, dr_hook
-USE turb_diff_mod, ONLY: mix_factor
-IMPLICIT NONE
+use mym_option_mod, only: tke_levels, my_z_limit_elb, l_3dtke
+use parkind1, only: jprb, jpim
+use planet_constants_mod, only: vkman
+use yomhook, only: lhook, dr_hook
+use turb_diff_mod, only: mix_factor
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
row_length, &
! Local number of points on a row
rows, &
@@ -69,7 +69,7 @@ SUBROUTINE mym_length( &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
qke(1-halo_i:row_length+halo_i, 1-halo_j:rows+halo_j, &
bl_levels), &
! twice of TKE (denoted to q**2) on theta level K-1
@@ -90,7 +90,7 @@ SUBROUTINE mym_length( &
! density (m^2/s^3)
! Intent OUT Variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
qkw(row_length, rows, tke_levels), &
! q=sqrt(qke) on theta level K-1
el(row_length, rows, tke_levels)
@@ -98,10 +98,10 @@ SUBROUTINE mym_length( &
! Local variables
-INTEGER :: &
+integer :: &
i, j, k
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
qdz, &
! q times vertical grid space
alp32, &
@@ -116,104 +116,104 @@ SUBROUTINE mym_length( &
! additional mixing length for 3DTKE scheme (L_L)
zeta
! non-dimensional length (height over MO length)
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
elt(row_length, rows), &
! mixing length related to vertical distribution
! of TKE (L_T)
vsc(row_length, rows)
! work arrays
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
zmax = 1.0, &
! constant used in calculating els
cns = 2.7
! constant used in calculating els
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_LENGTH'
+character(len=*), parameter :: RoutineName='MYM_LENGTH'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO j = 1, rows
- DO i = 1, row_length
+do j = 1, rows
+ do i = 1, row_length
elt(i, j) = 0.0
vsc(i, j) = 0.0
- END DO
-END DO
+ end do
+end do
-DO k = 1, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
- qkw(i, j, k) = SQRT(MAX(qke(i, j, k), 1.0e-20))
- END DO
- END DO
-END DO
+do k = 1, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
+ qkw(i, j, k) = sqrt(max(qke(i, j, k), 1.0e-20))
+ end do
+ end do
+end do
! vertical integration of qz and q
! Here, elt is still vertical integration of qz
! and vsc is that of q
-DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
+do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
qdz = qkw(i, j, k) * (z_uv(i, j, k) - z_uv(i, j, k - 1))
elt(i, j) = elt(i, j) + qdz * z_tq(i, j, k - 1)
vsc(i, j) = vsc(i, j) + qdz
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO j = 1, rows
- DO i = 1, row_length
- elt(i, j) = MAX(my_alpha1 * elt(i, j) / (vsc(i, j) + 1.0e-10), &
+do j = 1, rows
+ do i = 1, row_length
+ elt(i, j) = max(my_alpha1 * elt(i, j) / (vsc(i, j) + 1.0e-10), &
elt_min)
- vsc(i, j) = (elt(i, j) * MAX(fb_surf(i, j), 0.0)) ** one_third
- END DO
-END DO
+ vsc(i, j) = (elt(i, j) * max(fb_surf(i, j), 0.0)) ** one_third
+ end do
+end do
alp32 = my_alpha3 / my_alpha2
-DO k = 2, tke_levels
- DO j = 1, rows
- DO i = 1, row_length
- IF (dbdz(i, j, k) > 0.0) THEN
- rbv = 1.0 / SQRT(dbdz(i, j, k))
+do k = 2, tke_levels
+ do j = 1, rows
+ do i = 1, row_length
+ if (dbdz(i, j, k) > 0.0) then
+ rbv = 1.0 / sqrt(dbdz(i, j, k))
elb = my_alpha2 * qkw(i, j, k) * rbv &
- * (1.0 + alp32 * SQRT(vsc(i, j) * rbv / elt(i, j)))
- ELSE
+ * (1.0 + alp32 * sqrt(vsc(i, j) * rbv / elt(i, j)))
+ else
elb = 1.0e10
- END IF
+ end if
- IF (z_tq(i, j, k - 1) > my_z_limit_elb) THEN
- elb = MIN(elb, z_uv(i, j, k) - z_uv(i, j, k - 1))
- END IF
+ if (z_tq(i, j, k - 1) > my_z_limit_elb) then
+ elb = min(elb, z_uv(i, j, k) - z_uv(i, j, k - 1))
+ end if
zeta = z_tq(i, j, k - 1) * r_mosurf(i, j)
- IF (zeta > 0.0) THEN
+ if (zeta > 0.0) then
els = vkman * z_tq(i, j, k - 1) &
- / (1.0 + cns * MIN(zeta, zmax))
- ELSE
+ / (1.0 + cns * min(zeta, zmax))
+ else
els = vkman * z_tq(i, j, k - 1) &
- * MIN((1.0 - my_alpha4 * zeta) ** 0.2, 2.0)
- END IF
- IF (l_3dtke) THEN
+ * min((1.0 - my_alpha4 * zeta) ** 0.2, 2.0)
+ end if
+ if (l_3dtke) then
ell = mix_factor * delta_smag(i,j)
el(i, j, k) = elb / ( elb / elt(i, j) + elb / els + elb / ell + 1.0)
- ELSE
+ else
el(i, j, k) = elb / ( elb / elt(i, j) + elb / els + 1.0)
- END IF
- END DO
- END DO
-END DO
+ end if
+ end do
+ end do
+end do
-DO j = 1, rows
- DO i = 1, row_length
+do j = 1, rows
+ do i = 1, row_length
el(i, j, 1) = el(i, j, 2)
- END DO
-END DO
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+ end do
+end do
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_length
-END MODULE mym_length_mod
+end subroutine mym_length
+end module mym_length_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_level2.F90 b/science/physics_schemes/source/boundary_layer/mym_level2.F90
index 083aaa7eb1..6970c51189 100644
--- a/science/physics_schemes/source/boundary_layer/mym_level2.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_level2.F90
@@ -33,31 +33,31 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_level2_mod
+module mym_level2_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_LEVEL2_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_LEVEL2_MOD'
+contains
-SUBROUTINE mym_level2( &
+subroutine mym_level2( &
bl_levels, dbdz, dvdzm, gm, gh, sm, sh)
-USE atm_fields_bounds_mod, ONLY: tdims
-USE mym_const_mod, ONLY: ri1, ri2, ri3, ri4, rfc, rf1, rf2, shc, smc
-USE mym_option_mod, ONLY: tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use atm_fields_bounds_mod, only: tdims
+use mym_const_mod, only: ri1, ri2, ri3, ri4, rfc, rf1, rf2, shc, smc
+use mym_option_mod, only: tke_levels
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:tke_levels), &
! Buoyancy gradient across layer
@@ -69,7 +69,7 @@ SUBROUTINE mym_level2( &
! (:,:,K) repserents the value on theta level K-1
! Intent OUT Variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
gm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! square of wind shear on theta level K-1
! (a denominator of gradient Richardson number)
@@ -85,51 +85,51 @@ SUBROUTINE mym_level2( &
! scalars from level 2 scheme
! define on theta level K-1
! Local variables
-INTEGER :: &
+integer :: &
i, j, k
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
ri, &
! gradient Richardson Number
rf
! flux Richardson Number
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_LEVEL2'
+character(len=*), parameter :: RoutineName='MYM_LEVEL2'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
gm(i, j, k) = dvdzm(i, j, k) * dvdzm(i, j, k)
gh(i, j, k) = - dbdz(i, j, k)
! Gradient Richardson number
- ri = - gh(i, j, k) / MAX( gm(i, j, k), 1.0e-10 )
+ ri = - gh(i, j, k) / max( gm(i, j, k), 1.0e-10 )
! Flux Richardson number
- rf = MIN(ri1 * (ri + ri2 - SQRT(ri ** 2 - ri3 * ri + ri4)), &
+ rf = min(ri1 * (ri + ri2 - sqrt(ri ** 2 - ri3 * ri + ri4)), &
rfc )
sh(i, j, k) = shc * (rfc - rf) / (1.0 - rf)
sm(i, j, k) = smc * (rf1 - rf) / (rf2 - rf) * sh(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
gm(i, j, 1) = 0.0
gh(i, j, 1) = 0.0
sh(i, j, 1) = 0.0
sm(i, j, 1) = 0.0
- END DO
-END DO
+ end do
+end do
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_level2
-END MODULE mym_level2_mod
+end subroutine mym_level2
+end module mym_level2_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_option_mod.F90 b/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
index 348dccb562..3f933bf4a4 100644
--- a/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
@@ -18,7 +18,7 @@ module mym_option_mod
use missing_data_mod, only: rmdi, imdi
use control_max_sizes, only: max_bl_levels
-use um_types, only: real_umphys
+use um_types, only: r_bl
implicit none
@@ -62,7 +62,7 @@ module mym_option_mod
! 07 The lower limit for dbdz in the initialization to avoid to diagnose huge
! initial values.
-real(kind=real_umphys) :: my_ini_dbdz_min = rmdi ! suggested 1.0e-5
+real(kind=r_bl) :: my_ini_dbdz_min = rmdi ! suggested 1.0e-5
! 08 A switch to turn on advection of the prognostic variables in the TKE
! scheme (E_TRB, TSQ, QSQ, COV).
@@ -83,7 +83,7 @@ module mym_option_mod
integer :: shcu_levels = imdi ! suggested -1 to set to TKE levels
! 12 The maximum limit for the non-gradient buoyancy flux
-real(kind=real_umphys) :: wb_ng_max = rmdi ! suggested 0.05
+real(kind=r_bl) :: wb_ng_max = rmdi ! suggested 0.05
! 13 Switch related to production terms at the lowest levels
integer :: my_lowest_pd_surf = imdi ! suggested bh1991
@@ -100,16 +100,16 @@ module mym_option_mod
logical :: l_my_prod_adj = .false. ! suggested true
! 15 if Z_TQ > MY_z_limit_elb, elb is limited less than vertical grid spacing.
-real(kind=real_umphys) :: my_z_limit_elb = rmdi ! suggested 1.0e10 to not use
+real(kind=r_bl) :: my_z_limit_elb = rmdi ! suggested 1.0e10 to not use
! 16 If true, the maximum values of the prognostic variables are printed.
logical :: l_print_max_tke = .false.
! 17 A proportional coef CM below the top of mixed layer K = CM * sqrt(E) * L
-real(kind=real_umphys) :: tke_cm_mx = rmdi ! suggested 0.1
+real(kind=r_bl) :: tke_cm_mx = rmdi ! suggested 0.1
! 18 A proportional coef CM above the top of mixed layer K = CM * sqrt(E) * L
-real(kind=real_umphys) :: tke_cm_fa = rmdi ! suggested 0.1
+real(kind=r_bl) :: tke_cm_fa = rmdi ! suggested 0.1
! 19 Switch to choose mixing length in the first order model
integer :: tke_dlen = imdi ! suggested my_length
@@ -136,14 +136,14 @@ module mym_option_mod
! if L_MY_EXTRA_LEVEL == .true., the extra level is assigned at
! Z_TQ(:,:,1) * MY_Z_EXTRA_FACT above the surface.
! not a parameter as set in mym_initialise
-real(kind=real_umphys) :: my_z_extra_fact = 0.5
+real(kind=r_bl) :: my_z_extra_fact = 0.5
! Factor in production term adjustment related to diffusion.
! A smaller factor makes the adjustment activate more often,
! but too strong adjustment might adversely affect the accuracy of
! forecasts. With the value 0.225, sufficient computational stability
! is secured in the UKV.
-real(kind=real_umphys), parameter :: my_prod_adj_fact(1:max_bl_levels) = 0.225
+real(kind=r_bl), parameter :: my_prod_adj_fact(1:max_bl_levels) = 0.225
! Use the correction to the mixing length by Blackadar (valid only in the
! first order model)
diff --git a/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90 b/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
index 629e6a8636..f0f1b34ea3 100644
--- a/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90
@@ -14,16 +14,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_shcu_buoy_mod
+module mym_shcu_buoy_mod
-USE um_types, ONLY: real_umphys, real_eps
+use um_types, only: r_bl, real_eps
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SHCU_BUOY_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_SHCU_BUOY_MOD'
+contains
-SUBROUTINE mym_shcu_buoy( &
+subroutine mym_shcu_buoy( &
! IN levels/switches
bl_levels, &
BL_diag, &
@@ -34,30 +34,30 @@ SUBROUTINE mym_shcu_buoy( &
! INOUT / OUT fields
zhpar,frac, wb_ng)
-USE atm_fields_bounds_mod, only: tdims, pdims, tdims_l
-USE bl_diags_mod, ONLY: strnewbldiag
-USE conversions_mod, ONLY: pi
-USE gen_phys_inputs_mod, ONLY: l_mr_physics
-USE model_domain_mod, ONLY: model_type, mt_single_column
-USE mym_option_mod, ONLY: tke_levels, wb_ng_max, shcu_levels
-USE mym_const_mod, ONLY: one_third
-USE planet_constants_mod, ONLY: r, repsilon, pref, kappa, c_virtual, &
+use atm_fields_bounds_mod, only: tdims, pdims, tdims_l
+use bl_diags_mod, only: strnewbldiag
+use conversions_mod, only: pi
+use gen_phys_inputs_mod, only: l_mr_physics
+use model_domain_mod, only: model_type, mt_single_column
+use mym_option_mod, only: tke_levels, wb_ng_max, shcu_levels
+use mym_const_mod, only: one_third
+use planet_constants_mod, only: r, repsilon, pref, kappa, c_virtual, &
recip_kappa, g, lcrcp, ls, lsrcp, grcp
-USE timestep_mod, ONLY: timestep
-USE water_constants_mod, ONLY: lc, tm
+use timestep_mod, only: timestep
+use water_constants_mod, only: lc, tm
-USE qsat_mod, ONLY: qsat, qsat_mix
+use qsat_mod, only: qsat, qsat_mix
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
-IMPLICIT NONE
+implicit none
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
fb_surf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! buoyancy flux at the surface
ustar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -65,7 +65,7 @@ SUBROUTINE mym_shcu_buoy( &
pstar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! surface pressure (Pa)
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! height of theta levels
@@ -79,7 +79,7 @@ SUBROUTINE mym_shcu_buoy( &
bl_levels)
! pressure at rho levels (Pa)
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
u_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
! U at pressure points
v_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
@@ -104,14 +104,14 @@ SUBROUTINE mym_shcu_buoy( &
! function
! (:,:,K) is located at theta level K-1
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
zhpar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! boundary layer height evaluated with Richardson Number
! Declaration of BL diagnostics.
-TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+type (strnewbldiag), intent(in out) :: BL_diag
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
frac(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! cloud fraction including that by convection
@@ -123,9 +123,9 @@ SUBROUTINE mym_shcu_buoy( &
! local variables
-CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_SHCU_BUOY'
+character(len=*), parameter :: RoutineName = 'MYM_SHCU_BUOY'
-INTEGER :: i, j, k, &
+integer :: i, j, k, &
k_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! level for start of parcel ascent
ktpar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -141,7 +141,7 @@ SUBROUTINE mym_shcu_buoy( &
topbl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! 1 => top of bl reached
! 2 => max allowable height reached
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
exner(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
shcu_levels), &
! sigma^cappa
@@ -176,7 +176,7 @@ SUBROUTINE mym_shcu_buoy( &
shcu_levels)
! gradient of THV at theta levels
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
thl_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! parcel thl
qw_par(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -213,7 +213,7 @@ SUBROUTINE mym_shcu_buoy( &
t_ref(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end)
! reference temperature
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
virt_factor, &
! Vfac = 1+0.61qv - qcl - qcf
z_surf, &
@@ -285,7 +285,7 @@ SUBROUTINE mym_shcu_buoy( &
frcu
! cloud fraction due to convection
-LOGICAL :: &
+logical :: &
topinv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! indicates top of inversion being reached
topprof(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -293,30 +293,30 @@ SUBROUTINE mym_shcu_buoy( &
above_lcl
! indicates being above the LCL
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
a_parcel=0.2, &
b_parcel=3.26, &
max_t_grad=1.0e-3, &
ric=0.25
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
zhpar_old(i, j) = zhpar(i, j)
! Limit boundary layer growth rate to 0.14 m/s
! (approx 500m/hour)
- zhpar_max(i,j) = MIN( z_tq(i, j, shcu_levels-1), &
+ zhpar_max(i,j) = min( z_tq(i, j, shcu_levels-1), &
zhpar_old(i, j)+timestep*0.14 )
zh(i, j) = 0.0
- END DO
-END DO
-DO k = 1, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+end do
+do k = 1, shcu_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
! initialise cumulus cloud fraction to zero
exner(i, j, k) = (p_theta_levels(i, j, k) / pref) ** kappa
th(i, j, k) = t(i, j, k) / exner(i, j, k)
@@ -331,70 +331,70 @@ SUBROUTINE mym_shcu_buoy( &
wb_ng(i,j,k) = 0.0
frac(i,j,k) = frac_gauss(i,j,k)
tl(i,j,k) = t(i,j,k) - lcrcp*qcl(i,j,k) - lsrcp*qcf(i,j,k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO k = 2, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, shcu_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
dthvdz(i,j,k) = THv(i,j,k) - THv(i,j,k-1)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO k = 3, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 3, shcu_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
weight1 = z_uv(i,j,k) - z_uv(i,j,k-1)
weight2 = z_tq(i,j,k-1)- z_uv(i,j,k-1)
weight3 = z_uv(i,j,k) - z_tq(i,j,k-1)
dthvdzm(i,j,k) = (weight2 * dthvdz(i,j,k) &
+ weight3 * dthvdz(i,j,k-1)) / weight1
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
k = 2
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
dthvdzm(i,j,k) = dthvdz(i,j,k)
- END DO
-END DO
+ end do
+end do
-DO k = 2, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, shcu_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
ri = (u_p(i,j,k)-u_p(i,j,k-1))**2 &
+(v_p(i,j,k)-v_p(i,j,k-1))**2
ri = (g*(z_uv(i,j,k)-z_uv(i,j,k-1)) &
- *dthvdzm(i,j,k)/THv(i,j,k)) / MAX( 1.0e-14, ri )
- IF ( ri > ric .AND. ABS(zh(i,j)) < real_eps ) THEN
+ *dthvdzm(i,j,k)/THv(i,j,k)) / max( 1.0e-14, ri )
+ if ( ri > ric .and. abs(zh(i,j)) < real_eps ) then
zh(i,j)=z_uv(i,j,k)
- END IF
+ end if
qc_par(i,j,k) = 0.0
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
!-----------------------------------------------------------------------
! 1. Set up parcel
!-----------------------------------------------------------------------
! Start parcel ascent from grid-level above top of surface layer, taken
! to be at a height, z_surf, given by 0.1*ZH
!-----------------------------------------------------------------------
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
k_par(i,j) = 1
zhpar(i,j) = zh(i,j) ! initialise to bl depth (from RI)
k_lcl(i,j) = 1
- IF (fb_surf(i,j) >= 0.0) THEN
+ if (fb_surf(i,j) >= 0.0) then
z_surf = 0.1 * zh(i,j)
- DO WHILE ( z_uv(i,j,k_par(i,j)) < z_surf .AND. &
+ do while ( z_uv(i,j,k_par(i,j)) < z_surf .and. &
! not reached Z_SURF
thvl(i,j,k_par(i,j)+1) <= thvl(i,j,k_par(i,j)) )
! not reached inversion
k_par(i,j) = k_par(i,j) + 1
- END DO
+ end do
w_s = ( fb_surf(i,j)*zh(i,j) + ustar(i,j)**3 )**one_third
thv_sd = 1.93 * fb_surf(i,j) * THv(i,j,k_par(i,j)) &
/ ( g * w_s )
@@ -413,43 +413,43 @@ SUBROUTINE mym_shcu_buoy( &
vap_press = q(i,j,k_par(i,j)) * &
p_theta_levels(i,j,k_par(i,j)) / ( 100.0*repsilon )
end if
- IF (vap_press > 0.0) THEN
- t_lcl = 55.0 + 2840.0 / ( 3.5*LOG(t(i,j,k_par(i,j))) &
- - LOG(vap_press) - 4.805 )
+ if (vap_press > 0.0) then
+ t_lcl = 55.0 + 2840.0 / ( 3.5*log(t(i,j,k_par(i,j))) &
+ - log(vap_press) - 4.805 )
p_lcl(i,j) = p_theta_levels(i,j,k_par(i,j)) * &
( t_lcl / t(i,j,k_par(i,j)) )**(recip_kappa)
- ELSE
+ else
p_lcl(i,j) = pstar(i,j)
- END IF
+ end if
! K_LCL is model level BELOW the lifting condensation level
k_lcl(i,j) = 1
- DO k = 2, shcu_levels
- IF (p_rho_levels(i,j,k) > p_lcl(i,j)) THEN
+ do k = 2, shcu_levels
+ if (p_rho_levels(i,j,k) > p_lcl(i,j)) then
k_lcl(i,j) = k - 1
- END IF
- END DO
+ end if
+ end do
z_lcl(i,j) = z_uv(i,j,k_lcl(i,j)+1) &
+ ( z_uv(i,j,k_lcl(i,j))-z_uv(i,j,k_lcl(i,j)+1) ) &
* ( p_rho_levels(i,j,k_lcl(i,j)+1) - p_lcl(i,j)) &
/ ( p_rho_levels(i,j,k_lcl(i,j)+1) &
- p_rho_levels(i,j,k_lcl(i,j)) )
- z_lcl(i,j) = MAX( z_uv(i,j,1), z_lcl(i,j) )
+ z_lcl(i,j) = max( z_uv(i,j,1), z_lcl(i,j) )
!-----------------------------------------------------------------------
! Threshold on parcel buoyancy for ascent, THV_PERT, is related to
! standard deviation of thv in surface layer
!-----------------------------------------------------------------------
- thv_pert(i,j)= MAX( a_parcel, &
- MIN( max_t_grad*zh(i,j), b_parcel*thv_sd ) )
+ thv_pert(i,j)= max( a_parcel, &
+ min( max_t_grad*zh(i,j), b_parcel*thv_sd ) )
th_ref(i,j) = thl_par(i,j)
th_par_kp1(i,j) = thl_par(i,j)
- ELSE
+ else
! dummy
th_ref(i,j) = thl(i,j,1)
z_lcl(i,j) = z_uv(i, j, 1)
- END IF ! test on unstable
- END DO
-END DO
+ end if ! test on unstable
+ end do
+end do
!-----------------------------------------------------------------------
! 2 Parcel ascent:
!-----------------------------------------------------------------------
@@ -457,47 +457,47 @@ SUBROUTINE mym_shcu_buoy( &
! Calculate parcel QC by linearising q_sat about the parcel's
! temperature extrapolated up to the next grid-level
-DO k = 1, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 1, shcu_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
t_ref(i,j) = th_ref(i,j)*exner(i,j,k)
- END DO
- END DO
-
- IF ( l_mr_physics ) THEN
- CALL qsat_mix(qsat_calc,t_ref,p_theta_levels(:,:,k),tdims%i_end,tdims%j_end)
- ELSE
- CALL qsat(qsat_calc,t_ref,p_theta_levels(:,:,k),tdims%i_end,tdims%j_end)
- END IF
-
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (fb_surf(i,j) > 0.0) THEN
- IF (t_ref(i,j) > tm) THEN
+ end do
+ end do
+
+ if ( l_mr_physics ) then
+ call qsat_mix(qsat_calc,t_ref,p_theta_levels(:,:,k),tdims%i_end,tdims%j_end)
+ else
+ call qsat(qsat_calc,t_ref,p_theta_levels(:,:,k),tdims%i_end,tdims%j_end)
+ end if
+
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (fb_surf(i,j) > 0.0) then
+ if (t_ref(i,j) > tm) then
lrcp_c = lcrcp
l_heat = lc
- ELSE
+ else
lrcp_c = lsrcp
l_heat = ls
- END IF
+ end if
dqsatdt = repsilon * l_heat * qsat_calc(i,j)/(r*t_ref(i,j)**2)
qsatfac = 1.0/(1.0+(lrcp_c)*dqsatdt)
- qc_par(i,j,k) = MAX( 0.0, &
+ qc_par(i,j,k) = max( 0.0, &
qsatfac*( qw_par(i,j) - qsat_calc(i,j) &
- (thl_par(i,j)-th_ref(i,j)) &
*exner(i,j,k)*dqsatdt ) )
- qc_env = MAX( 0.0, qsatfac*( qw(i,j,k) - qsat_calc(i,j) &
+ qc_env = max( 0.0, qsatfac*( qw(i,j,k) - qsat_calc(i,j) &
- (tl(i,j,k)-t_ref(i,j)) *dqsatdt ) )
qc_par(i,j,k) = qc_par(i,j,k) + qcl(i,j,k) + qcf(i,j,k) &
- qc_env
t_par = sl_par(i,j) - grcp * z_tq(i,j,k) &
+ lrcp_c * qc_par(i,j,k)
! recalculate if signs of T_REF and T_PAR are different
- IF (t_ref(i,j) <= tm .AND. t_par > tm) THEN
+ if (t_ref(i,j) <= tm .and. t_par > tm) then
lrcp_c = lcrcp
qsatfac = 1.0/(1.0+(lrcp_c)*dqsatdt)
- qc_par(i,j,k) = MAX( 0.0, &
+ qc_par(i,j,k) = max( 0.0, &
qsatfac*( qw_par(i,j) - qsat_calc(i,j) &
- (sl_par(i,j)-grcp*z_tq(i,j,k)-t_ref(i,j)) &
*dqsatdt ) )
@@ -505,51 +505,51 @@ SUBROUTINE mym_shcu_buoy( &
- qc_env
t_par = sl_par(i,j) - grcp * z_tq(i,j,k) &
+ lrcp_c * qc_par(i,j,k)
- END IF
+ end if
th_par = t_par / exner(i,j,k)
thv_par(i,j,k) = th_par * &
(1.0+c_virtual*qw_par(i,j) &
-(1.0+c_virtual)*qc_par(i,j,k))
- IF (k > 1 .AND. k < shcu_levels - 1) THEN
+ if (k > 1 .and. k < shcu_levels - 1) then
! extrapolate reference TH gradient up to next grid-level
z_pr = (z_tq(i,j,k+1)-z_tq(i,j,k)) &
/(z_tq(i,j,k)-z_tq(i,j,k-1))
th_ref(i,j) = th_par*(1.0+z_pr) &
- th_par_kp1(i,j)*z_pr
th_par_kp1(i,j) = th_par
- END IF
- END IF ! test on unstable
- END DO
- END DO
-END DO
+ end if
+ end if ! test on unstable
+ end do
+ end do
+end do
!-----------------------------------------------------------------------
! 3 Identify layer boundaries
!-----------------------------------------------------------------------
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
topbl(i,j) = 0
- topprof(i,j) = .FALSE.
- topinv(i,j)= .FALSE.
+ topprof(i,j) = .false.
+ topinv(i,j)= .false.
ktpar(i,j) = 1
k_neut(i,j) = 1
ktinv(i,j) = 1
dbdz_inv(i,j) = 0.003
! start with a weak minimum inversion lapse rate
! (~1.e-4 s^-2, converted from K/m to s^-2 later)
- END DO
-END DO
+ end do
+end do
-DO k = 2, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, shcu_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
- IF (fb_surf(i,j) > 0.0) THEN
+ if (fb_surf(i,j) > 0.0) then
!------------------------------------------------------------
! Set flag to true when level BELOW is above the lcl
! and above LCL transition zone
!------------------------------------------------------------
above_lcl = k-1 > k_lcl(i,j) + 1 &
- .AND. z_tq(i,j,k-1) > 1.1*z_lcl(i,j)
+ .and. z_tq(i,j,k-1) > 1.1*z_lcl(i,j)
!-------------------------------------------------------------
! Calculate vertical gradients in parcel and environment THV
!-------------------------------------------------------------
@@ -560,82 +560,82 @@ SUBROUTINE mym_shcu_buoy( &
!-------------------------------------------------------------
! Find top of inversion - where parcel has minimum buoyancy
!-------------------------------------------------------------
- IF ( topbl(i,j) > 0 .AND. .NOT. topinv(i,j) ) THEN
- dbdz_inv(i,j) = MAX( dbdz_inv(i,j), denv_bydz )
- IF ( k-1 > ktpar(i,j)+2 .AND. ( &
+ if ( topbl(i,j) > 0 .and. .not. topinv(i,j) ) then
+ dbdz_inv(i,j) = max( dbdz_inv(i,j), denv_bydz )
+ if ( k-1 > ktpar(i,j)+2 .and. ( &
! Inversion at least two grid-levels thick
- denv_bydz <= dpar_bydz .OR. &
+ denv_bydz <= dpar_bydz .or. &
! => at a parcel buoyancy minimum
- z_uv(i,j,k) > zhpar(i,j)+MIN(1000.0, 0.5*zhpar(i,j)) &
- )) THEN
+ z_uv(i,j,k) > zhpar(i,j)+min(1000.0, 0.5*zhpar(i,j)) &
+ )) then
! restrict inversion thickness < 1/2 bl depth and 1km
- topinv(i,j) = .TRUE.
+ topinv(i,j) = .true.
ktinv(i,j) = k-1
- END IF
- END IF
+ end if
+ end if
!-------------------------------------------------------------
! Find base of inversion - where parcel has maximum buoyancy
! or is negatively buoyant
!-------------------------------------------------------------
- IF ( .NOT. topprof(i,j) .AND. k > k_par(i,j) .AND. &
+ if ( .not. topprof(i,j) .and. k > k_par(i,j) .and. &
((thv_par(i,j,k)-THv(i,j,k) &
- <= - thv_pert(i,j)) .OR. &
- k > shcu_levels - 1 )) THEN
- topprof(i,j) = .TRUE.
+ <= - thv_pert(i,j)) .or. &
+ k > shcu_levels - 1 )) then
+ topprof(i,j) = .true.
k_neut(i,j) = k-1
- END IF
+ end if
- IF ( topbl(i,j) == 0 .AND. k > k_par(i,j) .AND. &
+ if ( topbl(i,j) == 0 .and. k > k_par(i,j) .and. &
( ( thv_par(i,j,k)-THv(i,j,k) &
- <= - thv_pert(i,j)) .OR. &
+ <= - thv_pert(i,j)) .or. &
! plume non buoyant
- ( above_lcl .AND. (denv_bydz > 1.25*dpar_bydz) ) &
+ ( above_lcl .and. (denv_bydz > 1.25*dpar_bydz) ) &
! or environmental virtual temperature gradient
! significantly larger than parcel gradient
! above lifting condensation level
- )) THEN
+ )) then
topbl(i,j) = 1
ktpar(i,j) = k-1 ! marks most buoyant theta-level
! (just below inversion)
zhpar(i,j) = z_uv(i,j,k)
- dbdz_inv(i,j) = MAX( dbdz_inv(i,j), denv_bydz )
- END IF
+ dbdz_inv(i,j) = max( dbdz_inv(i,j), denv_bydz )
+ end if
- IF ( topbl(i,j) == 0 .AND. &
+ if ( topbl(i,j) == 0 .and. &
(z_tq(i,j,k-1) >= zhpar_max(i,j) &
- .OR. k == shcu_levels)) THEN
+ .or. k == shcu_levels)) then
! gone above maximum allowed height
topbl(i,j) = 2
ktpar(i,j) = k-2
- dbdz_inv(i,j) = MAX( dbdz_inv(i,j), denv_bydz )
- END IF
- END IF ! test on unstable
- END DO
- END DO
-END DO
+ dbdz_inv(i,j) = max( dbdz_inv(i,j), denv_bydz )
+ end if
+ end if ! test on unstable
+ end do
+ end do
+end do
!-----------------------------------------------------------------------
! 3.1 Interpolate inversion base and top between grid-levels
!-----------------------------------------------------------------------
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF ( ktpar(i,j) > 1 ) THEN
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if ( ktpar(i,j) > 1 ) then
!-----------------------------------------------------
! parcel rose successfully
!-----------------------------------------------------
zhpar(i,j) = z_uv(i,j,ktpar(i,j)+1)
! to determine if interpolation of the inversion is performed
- IF (topbl(i,j) == 2) THEN
+ if (topbl(i,j) == 2) then
! Stopped at max allowable height
interp_inv= 0
zhpar(i,j) = zhpar_max(i,j)
k = ktpar(i,j)
- ELSE
+ else
interp_inv=1
!-------------------------------------------------------
! First interpolate inversion base (max buoyancy excess)
@@ -661,32 +661,32 @@ SUBROUTINE mym_shcu_buoy( &
a_poly = (a2-b_poly*z2*z2)/z2**3
xi=b_poly*b_poly-3.0*a_poly*c_poly
- IF (ABS(a_poly) >= real_eps .AND. xi > 0.0) THEN
+ if (abs(a_poly) >= real_eps .and. xi > 0.0) then
! ZHPAR is then the height where the above
! polynomial has zero gradient
- zhpar(i,j) = z_tq(i,j,k-2)-(b_poly+SQRT(xi)) &
+ zhpar(i,j) = z_tq(i,j,k-2)-(b_poly+sqrt(xi)) &
/(3.0*a_poly)
- zhpar(i,j) = MAX( MIN( zhpar(i,j), z_tq(i,j,k) ), &
+ zhpar(i,j) = max( min( zhpar(i,j), z_tq(i,j,k) ), &
z_tq(i,j,k-2) )
- IF ( zhpar(i,j) > z_tq(i,j,ktpar(i,j)+1) ) THEN
+ if ( zhpar(i,j) > z_tq(i,j,ktpar(i,j)+1) ) then
ktpar(i,j)=ktpar(i,j)+1
- END IF
- END IF
+ end if
+ end if
k = ktpar(i,j)
denv_bydz = (THv(i,j,k+1) - THv(i,j,k)) / &
(z_tq(i,j,k+1) - z_tq(i,j,k))
- END IF
- IF ( interp_inv == 1 ) THEN
+ end if
+ if ( interp_inv == 1 ) then
!-----------------------------------------------------
! Now interpolate inversion top
!-----------------------------------------------------
- IF ( ktinv(i,j) > ktpar(i,j)+1 ) THEN
+ if ( ktinv(i,j) > ktpar(i,j)+1 ) then
k = ktinv(i,j)+1
dpar_bydz = (thv_par(i,j,k) - thv_par(i,j,k-1)) / &
(z_tq(i,j,k) - z_tq(i,j,k-1))
denv_bydz = (THv(i,j,k) - THv(i,j,k-1)) / &
(z_tq(i,j,k) - z_tq(i,j,k-1))
- IF (denv_bydz < dpar_bydz) THEN
+ if (denv_bydz < dpar_bydz) then
!-----------------------------------------------------------
! interpolate height by fitting a parabola to parcel
! excesses and finding the height of its minimum
@@ -701,47 +701,47 @@ SUBROUTINE mym_shcu_buoy( &
b_poly=( d1-d3 - (d2-d3)*(z1**2-z3**2)/xi ) / &
( z1-z3 - (z2-z3)*(z1**2-z3**2)/xi )
a_poly=(d2 - d3 - b_poly*(z2-z3) )/xi
- END IF
- END IF ! inversion top grid-level 2 levels above parcel top
- END IF ! interp_inv flag
- END IF ! parcel rose
- END DO
-END DO
+ end if
+ end if ! inversion top grid-level 2 levels above parcel top
+ end if ! interp_inv flag
+ end if ! parcel rose
+ end do
+end do
!-----------------------------------------------------------------------
! 4. Integrate parcel excess buoyancy
!-----------------------------------------------------------------------
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
cape(i,j) = 0.0
- END DO
-END DO
-DO k = 2, shcu_levels - 1
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (k > k_lcl(i,j) .AND. k <= k_neut(i,j)-1) THEN
+ end do
+end do
+do k = 2, shcu_levels - 1
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (k > k_lcl(i,j) .and. k <= k_neut(i,j)-1) then
cape(i,j) = cape(i,j) + (thv_par(i,j,k) - THv(i,j,k)) &
* (z_uv(i,j,k+1)-z_uv(i,j,k)) / THv(i,j,k)
- END IF
- END DO
- END DO
-END DO
+ end if
+ end do
+ end do
+end do
!-----------------------------------------------------------------------
! 6. Calculate non-gradient fluxes and velocity scales
!-----------------------------------------------------------------------
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
dz_inv_cu(i,j) = 0.0
frcu = 0.0
- IF (fb_surf(i,j) > 0.0) THEN
+ if (fb_surf(i,j) > 0.0) then
w_star(i,j) = ( fb_surf(i,j)*zhpar(i,j) )**one_third
! dry bl scale
dbdz_inv(i,j) = g*dbdz_inv(i,j)/THv(i,j,ktpar(i,j))
! convert to buoyancy units
dz_inv_cu(i,j) = 0.2*zhpar(i,j)
! default for no CAPE
- END IF
+ end if
- IF (cape(i,j) > 0.0 .AND. zhpar(i,j) - z_lcl(i,j) > 0.0) THEN
+ if (cape(i,j) > 0.0 .and. zhpar(i,j) - z_lcl(i,j) > 0.0) then
k = k_lcl(i,j)
! calculate velocity scales
w_star(i,j) = ( fb_surf(i,j)*z_lcl(i,j) )**one_third
@@ -750,35 +750,35 @@ SUBROUTINE mym_shcu_buoy( &
w_cld = ( m_base * cape(i,j) )**one_third
z_cld = zhpar(i,j) - z_lcl(i,j)
! calculate fluxes at LCL
- wb_scale = ( w_cld**3/z_cld ) * SQRT( m_base/w_cld )
+ wb_scale = ( w_cld**3/z_cld ) * sqrt( m_base/w_cld )
!----------------------------------------------------------
! Estimate inversion thickness.
!----------------------------------------------------------
vscalsq_incld = 2.0*cape(i,j)
- dz_inv_cu(i,j) = SQRT( vscalsq_incld/dbdz_inv(i,j) )
+ dz_inv_cu(i,j) = sqrt( vscalsq_incld/dbdz_inv(i,j) )
! If inversion is unresolved (less than 3 grid-levels thick)
! then use profile reconstruction
- IF ( ktpar(i,j) <= shcu_levels - 4 ) THEN
- IF ( dz_inv_cu(i,j) &
- < z_tq(i,j,ktpar(i,j)+3) - z_tq(i,j,ktpar(i,j)) ) THEN
+ if ( ktpar(i,j) <= shcu_levels - 4 ) then
+ if ( dz_inv_cu(i,j) &
+ < z_tq(i,j,ktpar(i,j)+3) - z_tq(i,j,ktpar(i,j)) ) then
! First interpolate to find height of discontinuous inversion
k = ktpar(i,j)
gamma_cld = (THv(i,j,k)-THv(i,j,k-1)) &
/(z_tq(i,j,k)-z_tq(i,j,k-1))
- IF (k-2 > k_lcl(i,j)) THEN
- gamma_cld = MIN( gamma_cld, &
+ if (k-2 > k_lcl(i,j)) then
+ gamma_cld = min( gamma_cld, &
( THv(i,j,k-1)-THv(i,j,k-2) ) &
/( z_tq(i,j,k-1)- z_tq(i,j,k-2) ) )
- END IF
- gamma_cld = MAX(0.0, gamma_cld)
+ end if
+ gamma_cld = max(0.0, gamma_cld)
gamma_fa = (THv(i,j,k+4)-THv(i,j,k+3)) &
/(z_tq(i,j,k+4)-z_tq(i,j,k+3))
- gamma_fa = MAX(0.0, gamma_fa)
+ gamma_fa = max(0.0, gamma_fa)
! Integrate thv over the inversion grid-levels
grid_int = (THv(i,j,k+1)-THv(i,j,k)) &
*(z_uv(i,j,k+2)-z_uv(i,j,k+1)) &
@@ -796,14 +796,14 @@ SUBROUTINE mym_shcu_buoy( &
a_poly = 0.5*(gamma_cld-gamma_fa)
xi = b_poly*b_poly-4.0*a_poly*c_poly
- IF (xi >= 0.0 .AND. &
- ( ABS(a_poly) >= real_eps &
- .OR. ABS(b_poly) >= real_eps )) THEN
- IF (ABS(a_poly) < real_eps) THEN
+ if (xi >= 0.0 .and. &
+ ( abs(a_poly) >= real_eps &
+ .or. abs(b_poly) >= real_eps )) then
+ if (abs(a_poly) < real_eps) then
dz_inv_cu_rec = -c_poly/b_poly
- ELSE
- dz_inv_cu_rec = (-b_poly-SQRT(xi))/(2.0*a_poly)
- END IF
+ else
+ dz_inv_cu_rec = (-b_poly-sqrt(xi))/(2.0*a_poly)
+ end if
zhdisc = z_tq(i,j,k)+dz_inv_cu_rec
! Now calculate inversion stability given Dz=V^2/DB
@@ -814,46 +814,46 @@ SUBROUTINE mym_shcu_buoy( &
a_poly = 0.5*(gamma_cld+gamma_fa)
xi=b_poly*b_poly-4.0*a_poly*c_poly
- IF (xi >= 0.0 .AND. &
- ( ABS(a_poly) >= real_eps &
- .OR. ABS(b_poly) >= real_eps )) THEN
- IF (ABS(a_poly) < real_eps) THEN
+ if (xi >= 0.0 .and. &
+ ( abs(a_poly) >= real_eps &
+ .or. abs(b_poly) >= real_eps )) then
+ if (abs(a_poly) < real_eps) then
dz_inv_cu_rec = -c_poly/b_poly
- ELSE
- dz_inv_cu_rec = (-b_poly+SQRT(xi))/(2.0*a_poly)
- END IF
- dz_inv_cu_rec = MIN( dz_inv_cu_rec, &
+ else
+ dz_inv_cu_rec = (-b_poly+sqrt(xi))/(2.0*a_poly)
+ end if
+ dz_inv_cu_rec = min( dz_inv_cu_rec, &
2.0*(zhdisc-z_tq(i,j,ktpar(i,j))) )
- IF (dz_inv_cu_rec <= dz_inv_cu(i,j)) THEN
+ if (dz_inv_cu_rec <= dz_inv_cu(i,j)) then
dz_inv_cu(i,j) = dz_inv_cu_rec
- END IF
- END IF ! interpolation for DZ_INV_CU successful
- END IF ! interpolation for ZHDISC successful
+ end if
+ end if ! interpolation for DZ_INV_CU successful
+ end if ! interpolation for ZHDISC successful
- END IF ! inversion not resolved
- END IF ! if ktpar(i,j) <= shcu_levels - 4
+ end if ! inversion not resolved
+ end if ! if ktpar(i,j) <= shcu_levels - 4
- zpr_top = 1.0 + MIN(1.0, dz_inv_cu(i,j)/z_cld )
- DO k = 1, shcu_levels-1
+ zpr_top = 1.0 + min(1.0, dz_inv_cu(i,j)/z_cld )
+ do k = 1, shcu_levels-1
! Z_PR=0 at cloud-base, 1 at cloud-top
z_pr = ( z_uv(i,j,k+1) - z_lcl(i,j) )/ z_cld
- IF (z_pr > 0.0) THEN
+ if (z_pr > 0.0) then
! Non-gradient function for WB
f_ng = 0.0
- IF ( z_pr <= 0.9 ) THEN
+ if ( z_pr <= 0.9 ) then
! function with gradient=0 at z=0.9
! f=0,1 at z=0,0.9
ze_pr = z_pr/0.9
- f_ng = 0.5 * SQRT(ze_pr) * (3.0-ze_pr)
- ELSE IF (z_pr <= zpr_top) THEN
+ f_ng = 0.5 * sqrt(ze_pr) * (3.0-ze_pr)
+ else if (z_pr <= zpr_top) then
ze_pr = (z_pr-0.9)/(zpr_top-0.9) ! from 0 to 1
- f_ng = 0.5 * (1.0+COS(pi*ze_pr))
- END IF
- fnn = 0.5 * (1.0 + TANH(0.8 * (q1(i,j,k+1) + 0.5)))
- wb_ng(i,j,k+1) = MIN((1.0-fnn)*3.7*f_ng*wb_scale, wb_ng_max)
- END IF ! if Z_PR > 0
+ f_ng = 0.5 * (1.0+cos(pi*ze_pr))
+ end if
+ fnn = 0.5 * (1.0 + tanh(0.8 * (q1(i,j,k+1) + 0.5)))
+ wb_ng(i,j,k+1) = min((1.0-fnn)*3.7*f_ng*wb_scale, wb_ng_max)
+ end if ! if Z_PR > 0
! Cloud fraction enhancement and sigma_s calculation (for ql)
! (on Z rather than ZE levels)
@@ -861,42 +861,42 @@ SUBROUTINE mym_shcu_buoy( &
z_pr = ( z_tq(i,j,k) - z_lcl(i,j) )/ z_cld
! Z_PR=0 at cloud-base, 1 at cloud-top
- IF (z_pr > 0.0) THEN
+ if (z_pr > 0.0) then
f_ng = 0.0
- IF ( z_pr <= 0.9 ) THEN
- f_ng = 1.0+3.0*EXP(-5.0*z_pr) ! =4 at cloud-base
- ELSE IF ( z_pr < zpr_top ) THEN
+ if ( z_pr <= 0.9 ) then
+ f_ng = 1.0+3.0*exp(-5.0*z_pr) ! =4 at cloud-base
+ else if ( z_pr < zpr_top ) then
ze_pr = (z_pr-0.9)/(zpr_top-0.9) ! from 0 to 1
- f_ng = 0.5*(1.0+COS(pi*ze_pr))
- END IF
- frcu = 0.5*f_ng*MIN(0.5,m_base/w_cld)
- END IF ! Z_PR > 0
- frac(i,j,k+1) = MAX( frac_gauss(i,j,k+1), frcu)
- END DO ! loop over K
- END IF ! Test on CAPE
- END DO
-END DO
-
-DO k = shcu_levels + 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ f_ng = 0.5*(1.0+cos(pi*ze_pr))
+ end if
+ frcu = 0.5*f_ng*min(0.5,m_base/w_cld)
+ end if ! Z_PR > 0
+ frac(i,j,k+1) = max( frac_gauss(i,j,k+1), frcu)
+ end do ! loop over K
+ end if ! Test on CAPE
+ end do
+end do
+
+do k = shcu_levels + 1, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
frac(i, j, k) = 0.0
wb_ng(i, j, k) = 0.0
- END DO
- END DO
-END DO
-
-IF (BL_diag%l_wb_ng) THEN
- DO k = 2, shcu_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+end do
+
+if (BL_diag%l_wb_ng) then
+ do k = 2, shcu_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%wb_ng(i, j, k) = wb_ng(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_shcu_buoy
-END MODULE mym_shcu_buoy_mod
+ end do
+ end do
+ end do
+end if
+
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_shcu_buoy
+end module mym_shcu_buoy_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90 b/science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90
index 1fbe6f1992..128e36d01a 100644
--- a/science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_simeq_ilud2_decmp.F90
@@ -13,16 +13,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_simeq_ilud2_decmp_mod
+module mym_simeq_ilud2_decmp_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SIMEQ_ILUD2_DECMP_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_SIMEQ_ILUD2_DECMP_MOD'
+contains
-SUBROUTINE mym_simeq_ilud2_decmp( &
+subroutine mym_simeq_ilud2_decmp( &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
@@ -33,13 +33,13 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
aap_cov_k, r_bbp_cov_k, ccp_cov_k, &
ppp_ct_k, ppp_cq_k, pp1_ct_k, pp1_cq_k, pp2_ct_k, pp2_cq_k)
-USE mym_option_mod, ONLY: tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use mym_option_mod, only: tke_levels
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
! intent in variables
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
aa_tsq_k(tke_levels), &
bb_tsq_k(tke_levels), &
cc_tsq_k(tke_levels), &
@@ -55,7 +55,7 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
pp_cq_k(tke_levels)
! matrix elements
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
aap_tsq_k(tke_levels), &
r_bbp_tsq_k(tke_levels), &
ccp_tsq_k(tke_levels), &
@@ -79,16 +79,16 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
pp2_cq_k(tke_levels)
! matrix elements of the ILU decomposed matrix
-INTEGER :: k
+integer :: k
! loop indexes
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SIMEQ_ILUD2_DECMP'
+character(len=*), parameter :: RoutineName='MYM_SIMEQ_ILUD2_DECMP'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
aap_tsq_k(1) = aa_tsq_k(1)
r_bbp_tsq_k(1) = 1.0 / bb_tsq_k(1)
@@ -106,7 +106,7 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
pp2_tc_k(1) = 0.0
pp2_qc_k(1) = 0.0
-DO k = 2, tke_levels
+do k = 2, tke_levels
aap_tsq_k(k) = aa_tsq_k(k)
r_bbp_tsq_k(k) = 1.0 / (bb_tsq_k(k) &
- aap_tsq_k(k) * ccp_tsq_k(k - 1) * r_bbp_tsq_k(k - 1))
@@ -126,7 +126,7 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
pp2_tc_k(k) = - aap_tsq_k(k) * r_bbp_tsq_k(k - 1) * pp1_tc_k(k - 1)
pp2_qc_k(k) = - aap_qsq_k(k) * r_bbp_qsq_k(k - 1) * pp1_qc_k(k - 1)
-END DO
+end do
k = 1
@@ -156,7 +156,7 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
- pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * ppp_qc_k(k + 1) &
- pp2_cq_k(k) * r_bbp_qsq_k(k + 2) * pp1_qc_k(k + 2)
-DO k = 2, tke_levels - 2
+do k = 2, tke_levels - 2
ppp_ct_k(k) = pp_ct_k(k)
ppp_cq_k(k) = pp_cq_k(k)
@@ -187,7 +187,7 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
- pp2_ct_k(k) * r_bbp_tsq_k(k + 2) * pp1_tc_k(k + 2) &
- pp1_cq_k(k) * r_bbp_qsq_k(k + 1) * ppp_qc_k(k + 1) &
- pp2_cq_k(k) * r_bbp_qsq_k(k + 2) * pp1_qc_k(k + 2)
-END DO
+end do
k = tke_levels - 1
@@ -237,8 +237,8 @@ SUBROUTINE mym_simeq_ilud2_decmp( &
- aap_cov_k(k) * r_bbp_cov_k(k - 1) * ccp_cov_k(k - 1))
ccp_cov_k(k) = 0.0
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_simeq_ilud2_decmp
-END MODULE mym_simeq_ilud2_decmp_mod
+end subroutine mym_simeq_ilud2_decmp
+end module mym_simeq_ilud2_decmp_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90 b/science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90
index 07b134ffdf..3a403f7191 100644
--- a/science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_simeq_matrix_prod.F90
@@ -13,27 +13,27 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_simeq_matrix_prod_mod
+module mym_simeq_matrix_prod_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SIMEQ_MATRIX_PROD_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_SIMEQ_MATRIX_PROD_MOD'
+contains
-SUBROUTINE mym_simeq_matrix_prod( &
+subroutine mym_simeq_matrix_prod( &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
x_tsq_k, x_qsq_k, x_cov_k, &
y_tsq_k, y_qsq_k, y_cov_k)
-USE mym_option_mod, ONLY: tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use mym_option_mod, only: tke_levels
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
! matrix elements (for meanings of each, see the document)
aa_tsq_k(tke_levels), &
bb_tsq_k(tke_levels), &
@@ -53,21 +53,21 @@ SUBROUTINE mym_simeq_matrix_prod( &
x_qsq_k(tke_levels), &
x_cov_k(tke_levels)
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
! vector elements of products (answers)
y_tsq_k(tke_levels), &
y_qsq_k(tke_levels), &
y_cov_k(tke_levels)
-INTEGER :: k
+integer :: k
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SIMEQ_MATRIX_PROD'
+character(len=*), parameter :: RoutineName='MYM_SIMEQ_MATRIX_PROD'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
! y = A * x
k = 1
@@ -84,7 +84,7 @@ SUBROUTINE mym_simeq_matrix_prod( &
+ pp_ct_k(k) * x_tsq_k(k) &
+ pp_cq_k(k) * x_qsq_k(k)
-DO k = 2, tke_levels - 1
+do k = 2, tke_levels - 1
y_tsq_k(k) = aa_tsq_k(k) * x_tsq_k(k - 1) &
+ bb_tsq_k(k) * x_tsq_k(k) &
+ cc_tsq_k(k) * x_tsq_k(k + 1) &
@@ -101,7 +101,7 @@ SUBROUTINE mym_simeq_matrix_prod( &
+ pp_ct_k(k) * x_tsq_k(k) &
+ pp_cq_k(k) * x_qsq_k(k)
-END DO
+end do
k = tke_levels
y_tsq_k(k) = aa_tsq_k(k) * x_tsq_k(k - 1) &
@@ -118,8 +118,8 @@ SUBROUTINE mym_simeq_matrix_prod( &
+ pp_cq_k(k) * x_qsq_k(k)
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_simeq_matrix_prod
-END MODULE mym_simeq_matrix_prod_mod
+end subroutine mym_simeq_matrix_prod
+end module mym_simeq_matrix_prod_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
index d98f4b057c..685669c315 100644
--- a/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
@@ -13,16 +13,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_solve_simeq_mod
+module mym_solve_simeq_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_SOLVE_SIMEQ_MOD'
+contains
-SUBROUTINE mym_solve_simeq( &
+subroutine mym_solve_simeq( &
! IN levels
bl_levels, &
! IN fields
@@ -31,20 +31,20 @@ SUBROUTINE mym_solve_simeq( &
! OUT fields
tsq, qsq, cov)
-USE atm_fields_bounds_mod, ONLY: tdims
-USE mym_option_mod, ONLY: tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-USE mym_solve_simeq_bcgstab_mod, ONLY: mym_solve_simeq_bcgstab
-USE mym_solve_simeq_lud_mod, ONLY: mym_solve_simeq_lud
-IMPLICIT NONE
+use atm_fields_bounds_mod, only: tdims
+use mym_option_mod, only: tke_levels
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+use mym_solve_simeq_bcgstab_mod, only: mym_solve_simeq_bcgstab
+use mym_solve_simeq_lud_mod, only: mym_solve_simeq_lud
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" level
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
! matrix elements (for meanings of each, see the document)
qq_tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
@@ -79,7 +79,7 @@ SUBROUTINE mym_solve_simeq( &
pp_cq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels)
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! Self covariance of liquid potential temperature
@@ -94,11 +94,11 @@ SUBROUTINE mym_solve_simeq( &
! (thetal'qw') defined on theta levels K-1
! Local variables
-INTEGER :: &
+integer :: &
i, j, k, &
endflag
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
! one-dimensional variables to secure continuous memory accesses
qq_tsq_k(tke_levels), &
qq_qsq_k(tke_levels), &
@@ -121,15 +121,15 @@ SUBROUTINE mym_solve_simeq( &
cov_k(tke_levels)
! Parameters
-INTEGER, PARAMETER :: &
+integer, parameter :: &
max_itr = 500
! the maximum iteration number
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
eps = 1.0e-15
! convergence creteria
-REAL(KIND=real_umphys), PARAMETER :: &
+real(kind=r_bl), parameter :: &
tsq_scale = 1.0e0, &
qsq_scale = 1.0e6, &
cov_scale = 1.0e3, &
@@ -142,19 +142,19 @@ SUBROUTINE mym_solve_simeq( &
cq_scale = cov_scale * r_qsq_scale
! scaling factors for the matrix elements
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ'
+character(len=*), parameter :: RoutineName='MYM_SOLVE_SIMEQ'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
! Copy to 1dim variables to secure continuous memory accesses
- DO k = 1, tke_levels
+ do k = 1, tke_levels
qq_tsq_k(k) = qq_tsq(i, j, k) * tsq_scale
qq_qsq_k(k) = qq_qsq(i, j, k) * qsq_scale
qq_cov_k(k) = qq_cov(i, j, k) * cov_scale
@@ -171,9 +171,9 @@ SUBROUTINE mym_solve_simeq( &
cc_cov_k(k) = cc_cov(i, j, k)
pp_ct_k(k) = pp_ct(i, j, k) * ct_scale
pp_cq_k(k) = pp_cq(i, j, k) * cq_scale
- END DO
+ end do
- CALL mym_solve_simeq_bcgstab( &
+ call mym_solve_simeq_bcgstab( &
max_itr, eps, &
qq_tsq_k, qq_qsq_k, qq_cov_k, &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
@@ -182,27 +182,27 @@ SUBROUTINE mym_solve_simeq( &
pp_ct_k, pp_cq_k, &
tsq_k, qsq_k, cov_k, endflag)
- IF (endflag < 0) THEN
+ if (endflag < 0) then
! if failed to converge, solve eqs. by LU decomposition
- CALL mym_solve_simeq_lud( &
+ call mym_solve_simeq_lud( &
qq_tsq_k, qq_qsq_k, qq_cov_k, &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
tsq_k, qsq_k, cov_k)
- END IF
+ end if
! set the values into the original arrays.
- DO k = 1, tke_levels
+ do k = 1, tke_levels
tsq(i, j, k) = tsq_k(k) * r_tsq_scale
qsq(i, j, k) = qsq_k(k) * r_qsq_scale
cov(i, j, k) = cov_k(k) * r_cov_scale
- END DO
+ end do
- END DO !loop i = tdims%i_start, tdims%i_end
-END DO !loop j = tdims%j_start, tdims%j_end
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+ end do !loop i = tdims%i_start, tdims%i_end
+end do !loop j = tdims%j_start, tdims%j_end
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_solve_simeq
-END MODULE mym_solve_simeq_mod
+end subroutine mym_solve_simeq
+end module mym_solve_simeq_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90
index 31c8daafe7..cd93d202d0 100644
--- a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_bcgstab.F90
@@ -12,17 +12,17 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_solve_simeq_bcgstab_mod
+module mym_solve_simeq_bcgstab_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, &
- PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_BCGSTAB_MOD'
-CONTAINS
+character(len=*), parameter, &
+ private :: ModuleName = 'MYM_SOLVE_SIMEQ_BCGSTAB_MOD'
+contains
-SUBROUTINE mym_solve_simeq_bcgstab( &
+subroutine mym_solve_simeq_bcgstab( &
max_itr, eps, &
qq_tsq_k, qq_qsq_k, qq_cov_k, &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
@@ -30,25 +30,25 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
tsq_k, qsq_k, cov_k, endflag)
-USE mym_option_mod, ONLY: tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
+use mym_option_mod, only: tke_levels
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
-USE mym_simeq_ilud2_decmp_mod, ONLY: mym_simeq_ilud2_decmp
-USE mym_simeq_matrix_prod_mod, ONLY: mym_simeq_matrix_prod
-USE mym_solve_simeq_ilud2_mod, ONLY: mym_solve_simeq_ilud2
-IMPLICIT NONE
+use mym_simeq_ilud2_decmp_mod, only: mym_simeq_ilud2_decmp
+use mym_simeq_matrix_prod_mod, only: mym_simeq_matrix_prod
+use mym_solve_simeq_ilud2_mod, only: mym_solve_simeq_ilud2
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
max_itr
! the maximum number of iterations
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
eps
! convergence condition
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
qq_tsq_k(tke_levels), &
qq_qsq_k(tke_levels), &
qq_cov_k(tke_levels), &
@@ -67,13 +67,13 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
pp_cq_k(tke_levels)
! matrix elements
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
tsq_k(tke_levels), &
qsq_k(tke_levels), &
cov_k(tke_levels)
! solved tsq, qsq and cov
-INTEGER, INTENT(OUT) :: &
+integer, intent(out) :: &
endflag
! to indicate if converged
! positive means proper solution is obtains.
@@ -84,13 +84,13 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
! so gave up
! Local variables
-INTEGER :: &
+integer :: &
k, m, &
! loop indexes
nitr
! a number of iterations
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
norm, &
! residual norm
r_qq_norm, &
@@ -114,7 +114,7 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
max_val
! maximum value of solutions
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
rvec_tsq(tke_levels), &
rvec_qsq(tke_levels), &
rvec_cov(tke_levels), &
@@ -156,15 +156,15 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
ppp_cq_k(tke_levels, 0:2)
! elements of ILU(2)
! the second dimension corresponds to the fill-in level
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ_BCGSTAB'
+character(len=*), parameter :: RoutineName='MYM_SOLVE_SIMEQ_BCGSTAB'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-CALL mym_simeq_ilud2_decmp( &
+call mym_simeq_ilud2_decmp( &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
@@ -179,7 +179,7 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
r_qq_norm = 0.0
alp_num = 0.0
-DO k = 1, tke_levels
+do k = 1, tke_levels
! set the initial values
tsq_k(k) = 0.0
qsq_k(k) = 0.0
@@ -206,20 +206,20 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
+ qq_qsq_k(k) * qq_qsq_k(k) &
+ qq_cov_k(k) * qq_cov_k(k)
-END DO
+end do
-IF (r_qq_norm == 0.0) THEN
+if (r_qq_norm == 0.0) then
r_qq_norm = 0.0
endflag = 2
nitr = 0
-ELSE
+else
r_qq_norm = 1.0 / r_qq_norm
endflag = -1
nitr = max_itr
-END IF
+end if
-outer_m_loop: DO m = 1, nitr
- CALL mym_solve_simeq_ilud2( &
+outer_m_loop: do m = 1, nitr
+ call mym_solve_simeq_ilud2( &
0, &
pvec_tsq, pvec_qsq, pvec_cov, &
aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
@@ -233,7 +233,7 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
ppvec_tsq, ppvec_qsq, ppvec_cov)
! v = A pp
- CALL mym_simeq_matrix_prod( &
+ call mym_simeq_matrix_prod( &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
@@ -241,24 +241,24 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
vvec_tsq, vvec_qsq, vvec_cov)
alp_den = 0.0
- DO k = 1, tke_levels
+ do k = 1, tke_levels
alp_den = alp_den + r0vec_tsq(k) * vvec_tsq(k) &
+ r0vec_qsq(k) * vvec_qsq(k) &
+ r0vec_cov(k) * vvec_cov(k)
- END DO
+ end do
- IF (alp_den == 0.0) THEN
+ if (alp_den == 0.0) then
endflag = 1
- ELSE
+ else
alp = alp_num / alp_den
- DO k = 1, tke_levels
+ do k = 1, tke_levels
svec_tsq(k) = rvec_tsq(k) - alp * vvec_tsq(k)
svec_qsq(k) = rvec_qsq(k) - alp * vvec_qsq(k)
svec_cov(k) = rvec_cov(k) - alp * vvec_cov(k)
- END DO
+ end do
- CALL mym_solve_simeq_ilud2( &
+ call mym_solve_simeq_ilud2( &
0, &
svec_tsq, svec_qsq, svec_cov, &
aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
@@ -272,7 +272,7 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
ssvec_tsq, ssvec_qsq, ssvec_cov)
! t = A ss
- CALL mym_simeq_matrix_prod( &
+ call mym_simeq_matrix_prod( &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
@@ -281,14 +281,14 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
omg_num = 0.0
omg_den = 0.0
- DO k = 1, tke_levels
+ do k = 1, tke_levels
omg_num = omg_num + tvec_tsq(k) * svec_tsq(k) &
+ tvec_qsq(k) * svec_qsq(k) &
+ tvec_cov(k) * svec_cov(k)
omg_den = omg_den + tvec_tsq(k) * tvec_tsq(k) &
+ tvec_qsq(k) * tvec_qsq(k) &
+ tvec_cov(k) * tvec_cov(k)
- END DO
+ end do
omg = omg_num / omg_den
@@ -297,7 +297,7 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
alp_num = 0.0
norm = 0.0
max_val = 0.0
- DO k = 1, tke_levels
+ do k = 1, tke_levels
tsq_k(k) = tsq_k(k) + alp * ppvec_tsq(k) + omg * ssvec_tsq(k)
qsq_k(k) = qsq_k(k) + alp * ppvec_qsq(k) + omg * ssvec_qsq(k)
cov_k(k) = cov_k(k) + alp * ppvec_cov(k) + omg * ssvec_cov(k)
@@ -312,39 +312,39 @@ SUBROUTINE mym_solve_simeq_bcgstab( &
+ rvec_qsq(k) * rvec_qsq(k) &
+ rvec_cov(k) * rvec_cov(k)
- max_val = MAX(max_val, ABS(tsq_k(k)), &
- ABS(qsq_k(k)), &
- ABS(cov_k(k)))
- END DO
- err = SQRT(norm * r_qq_norm)
+ max_val = max(max_val, abs(tsq_k(k)), &
+ abs(qsq_k(k)), &
+ abs(cov_k(k)))
+ end do
+ err = sqrt(norm * r_qq_norm)
- IF (err >= eps .AND. m < 30 .AND. max_val < 1.0e10) THEN
+ if (err >= eps .and. m < 30 .and. max_val < 1.0e10) then
! continue to the next step
- ELSE IF (max_val > 100.0) THEN
+ else if (max_val > 100.0) then
! Unexpectedly huge
endflag = -2
- ELSE IF (err < eps) THEN
+ else if (err < eps) then
! Converged
endflag = 0
- END IF
- END IF
- IF (endflag /= -1) THEN
- EXIT outer_m_loop
- ELSE
+ end if
+ end if
+ if (endflag /= -1) then
+ exit outer_m_loop
+ else
bet = alp_num * alp / (alp_den * omg)
- DO k = 1, tke_levels
+ do k = 1, tke_levels
pvec_tsq(k) = rvec_tsq(k) &
+ bet * (pvec_tsq(k) - omg * vvec_tsq(k))
pvec_qsq(k) = rvec_qsq(k) &
+ bet * (pvec_qsq(k) - omg * vvec_qsq(k))
pvec_cov(k) = rvec_cov(k) &
+ bet * (pvec_cov(k) - omg * vvec_cov(k))
- END DO
- END IF
-END DO outer_m_loop ! loop m = 1, max_itr
+ end do
+ end if
+end do outer_m_loop ! loop m = 1, max_itr
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_solve_simeq_bcgstab
-END MODULE mym_solve_simeq_bcgstab_mod
+end subroutine mym_solve_simeq_bcgstab
+end module mym_solve_simeq_bcgstab_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90
index b109701d36..67ff6790d1 100644
--- a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_ilud2.F90
@@ -17,16 +17,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_solve_simeq_ilud2_mod
+module mym_solve_simeq_ilud2_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_ILUD2_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_SOLVE_SIMEQ_ILUD2_MOD'
+contains
-SUBROUTINE mym_solve_simeq_ilud2( &
+subroutine mym_solve_simeq_ilud2( &
imode, &
qq_tsq_k, qq_qsq_k, qq_cov_k, &
aap_tsq_k, r_bbp_tsq_k, ccp_tsq_k, &
@@ -37,17 +37,17 @@ SUBROUTINE mym_solve_simeq_ilud2( &
ppp_ct_k, ppp_cq_k, pp1_ct_k, pp1_cq_k, pp2_ct_k, pp2_cq_k, &
tsq_k, qsq_k, cov_k)
-USE mym_option_mod, ONLY: tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use mym_option_mod, only: tke_levels
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
! intent in variables
-INTEGER, INTENT(IN) :: imode
+integer, intent(in) :: imode
! mode switch for the Matrix
! 0: normal, 1: transposed
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
qq_tsq_k(tke_levels), &
qq_qsq_k(tke_levels), &
qq_cov_k(tke_levels), &
@@ -75,38 +75,38 @@ SUBROUTINE mym_solve_simeq_ilud2( &
! matrix elements of ILU decomposed matrix
! See the document for details
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
tsq_k(tke_levels), &
qsq_k(tke_levels), &
cov_k(tke_levels)
! solution vectors
-INTEGER :: k
+integer :: k
! loop indexes
-INTEGER, PARAMETER :: &
+integer, parameter :: &
normal = 0, &
transposed = 1
! symbols for the mode
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ_ILUD2'
+character(len=*), parameter :: RoutineName='MYM_SOLVE_SIMEQ_ILUD2'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
tsq_k(1) = qq_tsq_k(1) * r_bbp_tsq_k(1)
qsq_k(1) = qq_qsq_k(1) * r_bbp_qsq_k(1)
-IF (imode == normal) THEN
- DO k = 2, tke_levels
+if (imode == normal) then
+ do k = 2, tke_levels
tsq_k(k) = (qq_tsq_k(k) - aap_tsq_k(k) * tsq_k(k - 1)) &
* r_bbp_tsq_k(k)
qsq_k(k) = (qq_qsq_k(k) - aap_qsq_k(k) * qsq_k(k - 1)) &
* r_bbp_qsq_k(k)
- END DO
+ end do
k = 1
cov_k(k) = (qq_cov_k(k) - ppp_ct_k(k) * tsq_k(k) &
@@ -117,7 +117,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
- pp2_cq_k(k) * qsq_k(k + 2)) &
* r_bbp_cov_k(k)
- DO k = 2, tke_levels - 2
+ do k = 2, tke_levels - 2
cov_k(k) = (qq_cov_k(k) - ppp_ct_k(k) * tsq_k(k) &
- pp1_ct_k(k) * tsq_k(k + 1) &
- pp2_ct_k(k) * tsq_k(k + 2) &
@@ -126,7 +126,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
- pp2_cq_k(k) * qsq_k(k + 2) &
- aap_cov_k(k) * cov_k(k - 1)) &
* r_bbp_cov_k(k)
- END DO
+ end do
k = tke_levels - 1
cov_k(k) = (qq_cov_k(k) - ppp_ct_k(k) * tsq_k(k) &
@@ -144,10 +144,10 @@ SUBROUTINE mym_solve_simeq_ilud2( &
* r_bbp_cov_k(k)
- DO k = tke_levels - 1, 1, -1
+ do k = tke_levels - 1, 1, -1
cov_k(k) = cov_k(k) &
- ccp_cov_k(k) * cov_k(k + 1) * r_bbp_cov_k(k)
- END DO
+ end do
k = tke_levels
qsq_k(k) = qsq_k(k) - (ppp_qc_k(k) * cov_k(k) &
@@ -159,7 +159,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
+ pp2_tc_k(k) * cov_k(k - 2)) &
* r_bbp_tsq_k(k)
- DO k = tke_levels - 1, 3, -1
+ do k = tke_levels - 1, 3, -1
qsq_k(k) = qsq_k(k) &
- (ppp_qc_k(k) * cov_k(k) + ccp_qsq_k(k) * qsq_k(k + 1) &
+ pp1_qc_k(k) * cov_k(k - 1) &
@@ -170,7 +170,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
+ pp1_tc_k(k) * cov_k(k - 1) &
+ pp2_tc_k(k) * cov_k(k - 2)) &
* r_bbp_tsq_k(k)
- END DO
+ end do
k = 2
qsq_k(k) = qsq_k(k) &
@@ -191,13 +191,13 @@ SUBROUTINE mym_solve_simeq_ilud2( &
- (ppp_tc_k(k) * cov_k(k) + ccp_tsq_k(k) * tsq_k(k + 1)) &
* r_bbp_tsq_k(k)
-ELSE IF (imode == transposed) THEN
- DO k = 2, tke_levels
+else if (imode == transposed) then
+ do k = 2, tke_levels
tsq_k(k) = (qq_tsq_k(k) &
- ccp_tsq_k(k - 1) * tsq_k(k - 1)) * r_bbp_tsq_k(k)
qsq_k(k) = (qq_qsq_k(k) &
- ccp_qsq_k(k - 1) * qsq_k(k - 1)) * r_bbp_qsq_k(k)
- END DO
+ end do
k = 1
cov_k(k) = (qq_cov_k(k) - ppp_tc_k(k) * tsq_k(k) &
@@ -208,7 +208,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
- pp2_qc_k(k + 2) * qsq_k(k + 2)) &
* r_bbp_cov_k(k)
- DO k = 2, tke_levels - 2
+ do k = 2, tke_levels - 2
cov_k(k) = (qq_cov_k(k) - ppp_tc_k(k) * tsq_k(k) &
- pp1_tc_k(k + 1) * tsq_k(k + 1) &
- pp2_tc_k(k + 2) * tsq_k(k + 2) &
@@ -217,7 +217,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
- pp2_qc_k(k + 2) * qsq_k(k + 2) &
- ccp_cov_k(k - 1) * cov_k(k - 1)) &
* r_bbp_cov_k(k)
- END DO
+ end do
k = tke_levels - 1
cov_k(k) = (qq_cov_k(k) - ppp_tc_k(k) * tsq_k(k) &
@@ -234,10 +234,10 @@ SUBROUTINE mym_solve_simeq_ilud2( &
- ccp_cov_k(k - 1) * cov_k(k - 1)) &
* r_bbp_cov_k(k)
- DO k = tke_levels - 1, 1, -1
+ do k = tke_levels - 1, 1, -1
cov_k(k) = cov_k(k) &
- aap_cov_k(k + 1) * cov_k(k + 1) * r_bbp_cov_k(k)
- END DO
+ end do
k = tke_levels
qsq_k(k) = qsq_k(k) - (ppp_cq_k(k) * cov_k(k) &
@@ -249,7 +249,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
+ pp2_ct_k(k - 2) * cov_k(k - 2)) &
* r_bbp_tsq_k(k)
- DO k = tke_levels - 1, 3, -1
+ do k = tke_levels - 1, 3, -1
qsq_k(k) = qsq_k(k) &
- (ppp_cq_k(k) * cov_k(k) + aap_qsq_k(k + 1) * qsq_k(k + 1) &
+ pp1_cq_k(k - 1) * cov_k(k - 1) &
@@ -260,7 +260,7 @@ SUBROUTINE mym_solve_simeq_ilud2( &
+ pp1_ct_k(k - 1) * cov_k(k - 1) &
+ pp2_ct_k(k - 2) * cov_k(k - 2)) &
* r_bbp_tsq_k(k)
- END DO
+ end do
k = 2
qsq_k(k) = qsq_k(k) &
@@ -280,10 +280,10 @@ SUBROUTINE mym_solve_simeq_ilud2( &
- (ppp_ct_k(k) * cov_k(k) + aap_tsq_k(k + 1) * tsq_k(k + 1)) &
* r_bbp_tsq_k(k)
-END IF
+end if
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_solve_simeq_ilud2
-END MODULE mym_solve_simeq_ilud2_mod
+end subroutine mym_solve_simeq_ilud2
+end module mym_solve_simeq_ilud2_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90
index 50c405c148..d2177443bb 100644
--- a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_lud.F90
@@ -12,29 +12,29 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_solve_simeq_lud_mod
+module mym_solve_simeq_lud_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_SOLVE_SIMEQ_LUD_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_SOLVE_SIMEQ_LUD_MOD'
+contains
-SUBROUTINE mym_solve_simeq_lud( &
+subroutine mym_solve_simeq_lud( &
qq_tsq_k, qq_qsq_k, qq_cov_k, &
aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
tsq_k, qsq_k, cov_k)
-USE mym_option_mod, ONLY: tke_levels
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-IMPLICIT NONE
+use mym_option_mod, only: tke_levels
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+implicit none
! intent in variables
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
qq_tsq_k(tke_levels), &
qq_qsq_k(tke_levels), &
qq_cov_k(tke_levels), &
@@ -53,39 +53,39 @@ SUBROUTINE mym_solve_simeq_lud( &
pp_cq_k(tke_levels)
! matrix elements
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
tsq_k(tke_levels), &
qsq_k(tke_levels), &
cov_k(tke_levels)
! solved tsq, qsq and cov
-INTEGER :: &
+integer :: &
k, l, m, n, &
! loop indexes
kpiv
! index of a pivot
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
wk
! work variables
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
amat(3 * tke_levels, 3 * tke_levels), &
! coefficient matrix
bvec(3 * tke_levels)
! vector in the right hand side
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_SOLVE_SIMEQ_LUD'
+character(len=*), parameter :: RoutineName='MYM_SOLVE_SIMEQ_LUD'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
amat(:, :) = 0.0
-DO k = 1, tke_levels
+do k = 1, tke_levels
amat(k, k) = bb_tsq_k(k)
amat(tke_levels + k, tke_levels + k) = bb_qsq_k(k)
amat(2 * tke_levels + k, 2 * tke_levels + k) &
@@ -93,85 +93,85 @@ SUBROUTINE mym_solve_simeq_lud( &
bvec(k) = qq_tsq_k(k)
bvec(tke_levels + k) = qq_qsq_k(k)
bvec(2 * tke_levels + k) = qq_cov_k(k)
-END DO
+end do
-DO k = 2, tke_levels
+do k = 2, tke_levels
amat(k, k-1) = aa_tsq_k(k)
amat(tke_levels + k, tke_levels + k - 1) = aa_qsq_k(k)
amat(2 * tke_levels + k, 2 * tke_levels + k - 1) &
= aa_cov_k(k)
-END DO
+end do
-DO k = 1, tke_levels - 1
+do k = 1, tke_levels - 1
amat(k, k+1) = cc_tsq_k(k)
amat(tke_levels + k, tke_levels + k + 1) = cc_qsq_k(k)
amat(2 * tke_levels + k, 2 * tke_levels + k + 1) &
= cc_cov_k(k)
-END DO
+end do
-DO k = 1, tke_levels
+do k = 1, tke_levels
amat(k, 2 * tke_levels + k) = pp_tc_k(k)
amat(tke_levels + k, 2 * tke_levels + k) = pp_qc_k(k)
amat(2 * tke_levels + k, k) = pp_ct_k(k)
amat(2 * tke_levels + k, tke_levels + k) = pp_cq_k(k)
-END DO
+end do
n = 3 * tke_levels
! main part
-DO k = 1, n
+do k = 1, n
kpiv = k
- wk = ABS(amat(k, k))
- DO l = k + 1, n
- IF (ABS(amat(l, k)) > wk) THEN
+ wk = abs(amat(k, k))
+ do l = k + 1, n
+ if (abs(amat(l, k)) > wk) then
kpiv = l
- wk = ABS(amat(l, k))
- END IF
- END DO
+ wk = abs(amat(l, k))
+ end if
+ end do
- IF (kpiv /= k) THEN
- DO m = 1, n
+ if (kpiv /= k) then
+ do m = 1, n
wk = amat(k, m)
amat(k, m) = amat(kpiv, m)
amat(kpiv, m) = wk
- END DO
+ end do
wk = bvec(k)
bvec(k) = bvec(kpiv)
bvec(kpiv) = wk
- END IF
+ end if
amat(k, k) = 1.0 / amat(k, k)
- DO l = k + 1, n
+ do l = k + 1, n
amat(l, k) = amat(l, k) * amat(k, k)
- END DO
+ end do
- DO m = k + 1, n
- DO l = k+1, n
+ do m = k + 1, n
+ do l = k+1, n
amat(l, m) = amat(l, m) - amat(k, m) * amat(l, k)
- END DO
- END DO
-END DO ! loop k = 1, n
+ end do
+ end do
+end do ! loop k = 1, n
-DO m = 1, n - 1
- DO l = m + 1, n
+do m = 1, n - 1
+ do l = m + 1, n
bvec(l) = bvec(l) - bvec(m) * amat(l, m)
- END DO
-END DO
+ end do
+end do
-DO m = n, 1, -1
+do m = n, 1, -1
bvec(m) = bvec(m) * amat(m, m)
- DO l = 1, m - 1
+ do l = 1, m - 1
bvec(l) = bvec(l) - amat(l, m) * bvec(m)
- END DO
-END DO
+ end do
+end do
-DO k = 1, tke_levels
+do k = 1, tke_levels
tsq_k(k) = bvec(k)
qsq_k(k) = bvec(tke_levels + k)
cov_k(k) = bvec(2 * tke_levels + k)
-END DO
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+end do
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_solve_simeq_lud
-END MODULE mym_solve_simeq_lud_mod
+end subroutine mym_solve_simeq_lud
+end module mym_solve_simeq_lud_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_turbulence.F90 b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
index ece19cf3e5..d2a0bd3169 100644
--- a/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
@@ -34,16 +34,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_turbulence_mod
+module mym_turbulence_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_TURBULENCE_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_TURBULENCE_MOD'
+contains
-SUBROUTINE mym_turbulence( &
+subroutine mym_turbulence( &
! IN levels/switches
bl_levels, levflag, BL_diag, &
! IN fields
@@ -56,31 +56,31 @@ SUBROUTINE mym_turbulence( &
! OUT fields
dfu_cg, dfv_cg, dft_cg, dfq_cg)
-USE atm_fields_bounds_mod, ONLY: tdims, pdims, tdims_l, tdims_s
-USE bl_diags_mod, ONLY: strnewbldiag
-USE conversions_mod, ONLY: pi
-USE mym_const_mod, ONLY: e1c,e2c,e3c,e4c,e5c,a1,a2,c1,b2,qke_max, &
+use atm_fields_bounds_mod, only: tdims, pdims, tdims_l, tdims_s
+use bl_diags_mod, only: strnewbldiag
+use conversions_mod, only: pi
+use mym_const_mod, only: e1c,e2c,e3c,e4c,e5c,a1,a2,c1,b2,qke_max, &
coef_trbvar_diff,coef_trbvar_diff_tke,two_thirds,a1_2, &
b1,one_third,cc3
-USE mym_option_mod, ONLY: &
+use mym_option_mod, only: &
my_lowest_pd_surf, l_my_extra_level, my_z_extra_fact, &
l_my_prod_adj, my_prod_adj_fact, tke_levels, &
l_my_lowest_pd_surf_tqc
-USE model_domain_mod, ONLY: model_type, mt_single_column
+use model_domain_mod, only: model_type, mt_single_column
-USE parkind1, ONLY: jprb, jpim
-USE planet_constants_mod, ONLY: vkman
-USE yomhook, ONLY: lhook, dr_hook
+use parkind1, only: jprb, jpim
+use planet_constants_mod, only: vkman
+use yomhook, only: lhook, dr_hook
-USE mym_length_mod, ONLY: mym_length
-USE mym_level2_mod, ONLY: mym_level2
-USE mym_update_covariance_mod, ONLY: mym_update_covariance
-USE mym_update_fields_mod, ONLY: mym_update_fields
-IMPLICIT NONE
+use mym_length_mod, only: mym_length
+use mym_level2_mod, only: mym_level2
+use mym_update_covariance_mod, only: mym_update_covariance
+use mym_update_fields_mod, only: mym_update_fields
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels, &
! Max. no. of "boundary" levels
levflag
@@ -88,7 +88,7 @@ SUBROUTINE mym_turbulence( &
! 2: level 2.5
! 3: level 3
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! Z_UV(*,K) is height of u level k
@@ -159,7 +159,7 @@ SUBROUTINE mym_turbulence( &
! gradient function for scalars at surface
! Intent INOUT Variables
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
qke(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
bl_levels), &
! twice of TKE (denoted to q**2) on theta level K-1
@@ -184,10 +184,10 @@ SUBROUTINE mym_turbulence( &
! on theta level K-1
! Declaration of BL diagnostics.
-TYPE (strnewbldiag), INTENT(IN OUT) :: BL_diag
+type (strnewbldiag), intent(in out) :: BL_diag
! Intent OUT Variables
-REAL(KIND=real_umphys), INTENT(OUT) :: &
+real(kind=r_bl), intent(out) :: &
dfu_cg(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
2:bl_levels), &
! counter gradient term for u
@@ -207,11 +207,11 @@ SUBROUTINE mym_turbulence( &
! Local variables
! Scalar
-INTEGER :: &
+integer :: &
i, j, k, k_start, k_start_cor
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
e1, &
! a variable denoted to E1 in the papers
e3, &
@@ -260,7 +260,7 @@ SUBROUTINE mym_turbulence( &
! upper limit for difference between cov in level 3
! and level 2
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
gm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! square of wind shear on theta level K-1
! (a denominator of gradient Richardson number)
@@ -408,7 +408,7 @@ SUBROUTINE mym_turbulence( &
tke_levels)
! cov derived by level 2
-REAL(KIND=real_umphys), ALLOCATABLE :: &
+real(kind=r_bl), allocatable :: &
! These variables are required only when imp_mode /= FULL_IMPL
! So usually they are not used.
! (That is why they have an "allocatable" attribute.)
@@ -425,39 +425,39 @@ SUBROUTINE mym_turbulence( &
rp_cov(:, :, :)
! production term of cov
-INTEGER, PARAMETER :: &
+integer, parameter :: &
! Symbols for a switch
full_impl = 0, &
half_impl = 1, &
expl = 2
-INTEGER, PARAMETER :: &
+integer, parameter :: &
imp_mode = full_impl
! mode to integrate covariances
-CHARACTER(LEN=*), PARAMETER :: RoutineName = 'MYM_TURBULENCE'
+character(len=*), parameter :: RoutineName = 'MYM_TURBULENCE'
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-IF (l_my_extra_level) THEN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (l_my_extra_level) then
k_start = 1
-ELSE
+else
k_start = 2
-END IF
+end if
-CALL mym_level2( &
+call mym_level2( &
bl_levels,dbdz, dvdzm,gm, gh, sm, sh)
-CALL mym_length( &
+call mym_length( &
tdims%i_end,tdims%j_end,tdims_l%halo_i,tdims_l%halo_j,bl_levels, &
qke, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, qkw, el)
-DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
elsq(i, j, k) = el(i, j, k) ** 2
q2sq = b1 * elsq(i, j, k) &
* (sm(i, j, k) * gm(i, j, k) + sh(i, j, k) * gh(i, j, k))
@@ -466,8 +466,8 @@ SUBROUTINE mym_turbulence( &
ghel(i, j, k) = gh(i, j, k) * elsq(i, j, k)
! adjust SM and SH by SQRT(q3sq / q2sq)
- IF ( q3sq(i, j, k) < q2sq ) THEN
- qdiv(i, j, k) = SQRT(q3sq(i, j, k) / q2sq)
+ if ( q3sq(i, j, k) < q2sq ) then
+ qdiv(i, j, k) = sqrt(q3sq(i, j, k) / q2sq)
sm(i, j, k) = sm(i, j, k) * qdiv(i, j, k)
sh(i, j, k) = sh(i, j, k) * qdiv(i, j, k)
@@ -479,15 +479,15 @@ SUBROUTINE mym_turbulence( &
e4 = e1 - e4c * ghel(i, j, k) * qdiv(i, j, k) ** 2
eden = e2(i, j, k) * e4 &
+ e3 * e5c * gmel(i, j, k) * qdiv(i, j, k) ** 2
- eden = MAX(eden, 1.0e-20)
+ eden = max(eden, 1.0e-20)
reden = 1.0 / eden
- ELSE
+ else
e1 = q3sq(i, j, k) - e1c * ghel(i, j, k)
e2(i, j, k) = q3sq(i, j, k) - e2c * ghel(i, j, k)
e3 = e1 + e3c * ghel(i, j, k)
e4 = e1 - e4c * ghel(i, j, k)
eden = e2(i, j, k) * e4 + e3 * e5c * gmel(i, j, k)
- eden = MAX(eden, 1.0e-20)
+ eden = max(eden, 1.0e-20)
reden = 1.0 / eden
qdiv(i, j, k) = 1.0
@@ -496,7 +496,7 @@ SUBROUTINE mym_turbulence( &
sh(i, j, k) = q3sq(i, j, k) &
* a2 * (e2(i, j, k) + 3.0 * c1 * e5c * gmel(i, j, k)) &
* reden
- END IF ! test if q3sq < q2sq
+ end if ! test if q3sq < q2sq
cu25(i, j, k) =(e2(i, j, k) &
+ 3.0 * c1 * e5c * gmel(i, j, k) &
* qdiv(i, j, k) ** 2) * one_third * reden
@@ -504,38 +504,38 @@ SUBROUTINE mym_turbulence( &
* (e4 - 0.5 * e4c * ghel(i, j, k) * qdiv(i, j, k) ** 2)
cw25(i, j, k) = cu25(i, j, k) * e1
cu25(i, j, k) = 1.0 - cv25(i, j, k) - cw25(i, j, k)
- END DO
- END DO
-END DO
-
-IF ( levflag == 3 ) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+end do
+
+if ( levflag == 3 ) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
t2sq = qdiv(i, j, k) * b2 * elsq(i, j, k) &
* sh(i, j, k) * dtldz(i, j, k) ** 2
r2sq = qdiv(i, j, k) * b2 * elsq(i, j, k) &
* sh(i, j, k) * dqwdz(i, j, k) ** 2
c2sq(i, j, k) = qdiv(i, j, k) * b2 * elsq(i, j, k) &
* sh(i, j, k) * dtldz(i, j, k) * dqwdz(i, j, k)
- t3sq = MAX(tsq(i, j, k), 0.0)
- r3sq = MAX(qsq(i, j, k), 0.0)
+ t3sq = max(tsq(i, j, k), 0.0)
+ r3sq = max(qsq(i, j, k), 0.0)
c3sq = cov(i, j, k)
- c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
+ c3sq = sign( min( abs(c3sq), sqrt(t3sq*r3sq) ), c3sq )
t2sq = vt(i, j, k) * t2sq + vq(i, j, k) * c2sq(i, j, k)
r2sq = vt(i, j, k) * c2sq(i, j, k) + vq(i, j, k) * r2sq
- c2sq(i, j, k) = MAX(vt(i, j, k) * t2sq + vq(i, j, k) * r2sq, &
+ c2sq(i, j, k) = max(vt(i, j, k) * t2sq + vq(i, j, k) * r2sq, &
0.0)
t3sq = vt(i, j, k) * t3sq + vq(i, j, k) * c3sq
r3sq = vt(i, j, k) * c3sq + vq(i, j, k) * r3sq
- c3sq = MAX(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
+ c3sq = max(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
! Limitation on q, instead of L/q
- IF ( q3sq(i, j, k) < -gh(i, j, k) * elsq(i, j, k)) THEN
+ if ( q3sq(i, j, k) < -gh(i, j, k) * elsq(i, j, k)) then
q3sq(i, j, k) = -elsq(i, j, k) * gh(i, j, k)
- END IF
+ end if
! Limitation on c3sq (0.12 =< cw =< 0.76)
! e2 = q^2 * phi2'
@@ -557,21 +557,21 @@ SUBROUTINE mym_turbulence( &
*( e2(i, j, k)*e4c &
- e3c*e5c*gmel(i, j, k) * qdiv(i, j, k)**2 )
- IF ( wden /= 0.0 ) THEN
+ if ( wden /= 0.0 ) then
clow = q3sq(i, j, k) * ( 0.12-cw25(i, j, k) )*eden/wden
cupp = q3sq(i, j, k) *( 0.76-cw25(i, j, k) )*eden/wden
- IF ( wden > 0.0 ) THEN
- c3sq = MIN( MAX( c3sq, c2sq(i, j, k) + clow), &
+ if ( wden > 0.0 ) then
+ c3sq = min( max( c3sq, c2sq(i, j, k) + clow), &
c2sq(i, j, k) + cupp)
- ELSE
- c3sq = MAX( MIN( c3sq, c2sq(i, j, k) + clow), &
+ else
+ c3sq = max( min( c3sq, c2sq(i, j, k) + clow), &
c2sq(i, j, k) + cupp)
- END IF
- END IF
+ end if
+ end if
e1 = e2(i, j, k) + e5c*gmel(i, j, k) * qdiv(i, j, k) ** 2
- eden = MAX( eden, 1.0e-20 )
+ eden = max( eden, 1.0e-20 )
reden = 1.0 / eden
e6c = 3.0 * a2 *cc3 * gtr(i, j, k) &
@@ -605,17 +605,17 @@ SUBROUTINE mym_turbulence( &
dfm(i, j, k) = elq * sm(i, j, k)
dfh(i, j, k) = elq * sh(i, j, k)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
! Adjustment for Gamma_theta and Gamma_q
! After the adjustment, Gamma_theta and Gamma_q are calculated
- IF (l_my_prod_adj .AND. &
- (imp_mode == half_impl .OR. imp_mode == full_impl)) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (l_my_prod_adj .and. &
+ (imp_mode == half_impl .or. imp_mode == full_impl)) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
elq = el(i, j, k) * qkw(i, j, k)
elh = elq * qdiv(i, j, k)
@@ -625,18 +625,18 @@ SUBROUTINE mym_turbulence( &
/ (z_uv(i, j, k) - z_uv(i, j, k - 1))) ** 2
pdt_tsq(i, j, k) = elh * gamt_tsq(i, j, k) * dtldz(i, j, k)
- IF (disp_coef < pdt_tsq(i, j, k)) THEN
+ if (disp_coef < pdt_tsq(i, j, k)) then
gamt_factor(i, j, k) = disp_coef / pdt_tsq(i, j, k)
- ELSE
+ else
gamt_factor(i, j, k) = 1.0
- END IF
+ end if
pdq_qsq(i, j, k) = elh * gamq_qsq(i, j, k) * dqwdz(i, j, k)
- IF (disp_coef < pdq_qsq(i, j, k)) THEN
+ if (disp_coef < pdq_qsq(i, j, k)) then
gamq_factor(i, j, k) = disp_coef / pdq_qsq(i, j, k)
- ELSE
+ else
gamq_factor(i, j, k) = 1.0
- END IF
+ end if
gamt_tsq(i, j, k) = gamt_factor(i, j, k) * gamt_tsq(i, j, k)
gamt_cov(i, j, k) = gamt_factor(i, j, k) * gamt_cov(i, j, k)
@@ -649,11 +649,11 @@ SUBROUTINE mym_turbulence( &
pdc_cov(i, j, k) = elh &
* (gamt_cov(i, j, k) * dqwdz(i, j, k) &
+ gamq_cov(i, j, k) * dtldz(i, j, k)) * 0.5
- IF (disp_coef < pdc_cov(i, j, k)) THEN
+ if (disp_coef < pdc_cov(i, j, k)) then
pdc_factor(i, j, k) = disp_coef / pdc_cov(i, j, k)
- ELSE
+ else
pdc_factor(i, j, k) = 1.0
- END IF
+ end if
gamt_tsq(i, j, k) = pdc_factor(i, j, k) * gamt_tsq(i, j, k)
gamt_cov(i, j, k) = pdc_factor(i, j, k) * gamt_cov(i, j, k)
gamt_res(i, j, k) = pdc_factor(i, j, k) * gamt_res(i, j, k)
@@ -670,13 +670,13 @@ SUBROUTINE mym_turbulence( &
+ gamq_cov(i, j, k) * cov(i, j, k) &
+ gamq_res(i, j, k)
- END DO
- END DO
- END DO
- ELSE
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+ else
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
gamt(i, j, k) = gamt_tsq(i, j, k) * tsq(i, j, k) &
+ gamt_cov(i, j, k) * cov(i, j, k) &
+ gamt_res(i, j, k)
@@ -688,15 +688,15 @@ SUBROUTINE mym_turbulence( &
gamt_factor(i, j, k) = 1.0
gamq_factor(i, j, k) = 1.0
pdc_factor(i, j, k) = 1.0
- END DO
- END DO
- END DO
- END IF ! IF L_MY_PROD_ADJ
+ end do
+ end do
+ end do
+ end if ! IF L_MY_PROD_ADJ
! Calculate production terms
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
elq = el(i, j, k) * qkw(i, j, k)
elh = elq * qdiv(i, j, k)
@@ -735,13 +735,13 @@ SUBROUTINE mym_turbulence( &
dfv_cg(i, j, k) = elq * smd(i, j, k) * dvdz(i, j, k)
dft_cg(i, j, k) = elq * gamt(i, j, k)
dfq_cg(i, j, k) = elq * gamq(i, j, k)
- END DO
- END DO
- END DO
-ELSE ! level 2.5
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+else ! level 2.5
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
! In Level 2.5, qdiv is not reset.
gamt(i, j, k) = 0.0
gamq(i, j, k) = 0.0
@@ -771,45 +771,45 @@ SUBROUTINE mym_turbulence( &
dfv_cg(i, j, k) = 0.0
dft_cg(i, j, k) = 0.0
dfq_cg(i, j, k) = 0.0
- END DO
- END DO
- END DO
-END IF ! test if levflag == 3
+ end do
+ end do
+ end do
+end if ! test if levflag == 3
! Overwrite production terms by ones calculated with surface fluxes
-IF (my_lowest_pd_surf > 0) THEN
- IF (l_my_extra_level) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (my_lowest_pd_surf > 0) then
+ if (l_my_extra_level) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk(i, j, 1) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
/ (vkman * z_tq(i, j, 1) * my_z_extra_fact)
- END DO
- END DO
- IF (l_my_lowest_pd_surf_tqc) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ if (l_my_lowest_pd_surf_tqc) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
phm = 1.0 / u_s(i, j) * phh(i, j) &
/ (vkman * z_tq(i, j, 1) * my_z_extra_fact)
pdt(i, j, 1) = phm * ftl(i, j, 1) ** 2
pdq(i, j, 1) = phm * fqw(i, j, 1) ** 2
pdc(i, j, 1) = phm * ftl(i, j, 1) * fqw(i, j, 1)
- END DO
- END DO
- END IF
- ELSE ! NOT L_MY_Extra_level
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end if
+ else ! NOT L_MY_Extra_level
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk(i, j, 2) = 1.0 * u_s(i, j) ** 3 * pmz(i, j) &
/ (vkman * z_tq(i, j, 1))
pdk(i, j, 1) = 0.0
pdt(i, j, 1) = 0.0
pdq(i, j, 1) = 0.0
pdc(i, j, 1) = 0.0
- END DO
- END DO
- IF (l_my_lowest_pd_surf_tqc) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ if (l_my_lowest_pd_surf_tqc) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
phm = 1.0 / u_s(i, j)* phh(i, j) &
/ (vkman * z_tq(i, j, 1))
pdt(i, j, 2) = phm * ftl(i, j, 1) ** 2
@@ -822,24 +822,24 @@ SUBROUTINE mym_turbulence( &
pdc_tsq(i, j, 2) = 0.0
pdc_qsq(i, j, 2) = 0.0
pdc_cov(i, j, 2) = 0.0
- END DO
- END DO
- END IF ! IF L_MY_lowest_pd_surf_tqc
- END IF ! IF L_MY_EXTRA_LEVEL
-ELSE ! MY_lowest_pd_surf = 0
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end if ! IF L_MY_lowest_pd_surf_tqc
+ end if ! IF L_MY_EXTRA_LEVEL
+else ! MY_lowest_pd_surf = 0
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk(i, j, 1) = 0.0
pdt(i, j, 1) = 0.0
pdq(i, j, 1) = 0.0
pdc(i, j, 1) = 0.0
- END DO
- END DO
-END IF ! IF MY_lowest_pd_surf
+ end do
+ end do
+end if ! IF MY_lowest_pd_surf
! for diagnostics
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
gamt(i, j, 1) = 0.0
gamq(i, j, 1) = 0.0
gamv(i, j, 1) = 0.0
@@ -852,49 +852,49 @@ SUBROUTINE mym_turbulence( &
pdc_tsq(i, j, 1) = 0.0
pdc_qsq(i, j, 1) = 0.0
pdc_cov(i, j, 1) = 0.0
- END DO
-END DO
+ end do
+end do
-IF (BL_diag%l_tke_shr_prod) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (BL_diag%l_tke_shr_prod) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
elq = el(i, j, k) * qkw(i, j, k)
BL_diag%tke_shr_prod(i, j, k) = el(i, j, k) * qkw(i, j, k) &
* (sm(i, j, k) + smd(i, j, k)) * gm(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_tke_boy_prod) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_tke_boy_prod) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%tke_boy_prod(i, j, k) = el(i, j, k) * qkw(i, j, k) &
* (sh(i, j, k) * gh(i, j, k) &
+ gamv(i, j, k)) + wb_ng(i,j,k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_tke_dissp) THEN
- DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_tke_dissp) then
+ do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%tke_dissp(i, j, k) = qkw(i, j, k) ** 3 &
/ (b1 * el(i, j, k))
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (levflag == 3) THEN
+if (levflag == 3) then
! Integrate the covariances
- IF (imp_mode == full_impl) THEN
- CALL mym_update_covariance( &
+ if (imp_mode == full_impl) then
+ call mym_update_covariance( &
! IN levels
bl_levels, &
! IN fields
@@ -903,24 +903,24 @@ SUBROUTINE mym_turbulence( &
pdq_qsq, pdq_cov, pdq, pdc_cov, pdc_tsq, pdc_qsq, pdc, &
! INOUT fields
tsq, qsq, cov)
- ELSE ! half implict or explicit
- ALLOCATE(bp_tsq(tdims%i_start:tdims%i_end, &
+ else ! half implict or explicit
+ allocate(bp_tsq(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end, tke_levels))
- ALLOCATE(rp_tsq(tdims%i_start:tdims%i_end, &
+ allocate(rp_tsq(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end, tke_levels))
- ALLOCATE(bp_qsq(tdims%i_start:tdims%i_end, &
+ allocate(bp_qsq(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end, tke_levels))
- ALLOCATE(rp_qsq(tdims%i_start:tdims%i_end, &
+ allocate(rp_qsq(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end, tke_levels))
- ALLOCATE(bp_cov(tdims%i_start:tdims%i_end, &
+ allocate(bp_cov(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end, tke_levels))
- ALLOCATE(rp_cov(tdims%i_start:tdims%i_end, &
+ allocate(rp_cov(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end, tke_levels))
- IF (imp_mode == half_impl) THEN
- DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ if (imp_mode == half_impl) then
+ do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdt(i, j, k) = pdt(i, j, k) &
+ pdt_cov(i, j, k) * cov(i, j, k)
@@ -941,13 +941,13 @@ SUBROUTINE mym_turbulence( &
bp_cov(i, j, k) = b2l - 2.0 * pdc_cov(i, j, k)
rp_cov(i, j, k) = 2.0 * pdc(i, j, k)
- END DO
- END DO
- END DO
- ELSE IF (imp_mode == expl) THEN
- DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+ else if (imp_mode == expl) then
+ do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdt(i, j, k) = pdt(i, j, k) &
+ pdt_tsq(i, j, k) * tsq(i, j, k) &
+ pdt_cov(i, j, k) * cov(i, j, k)
@@ -969,70 +969,70 @@ SUBROUTINE mym_turbulence( &
bp_cov(i, j, k) = b2l
rp_cov(i, j, k) = 2.0 * pdc(i, j, k)
- END DO
- END DO
- END DO
- END IF
- CALL mym_update_fields( &
+ end do
+ end do
+ end do
+ end if
+ call mym_update_fields( &
bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, rp_tsq, bp_tsq,tsq)
- CALL mym_update_fields( &
+ call mym_update_fields( &
bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, rp_qsq, bp_qsq,qsq)
- CALL mym_update_fields( &
+ call mym_update_fields( &
bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, rp_cov, bp_cov,cov)
- DEALLOCATE(rp_cov)
- DEALLOCATE(bp_cov)
- DEALLOCATE(rp_qsq)
- DEALLOCATE(bp_qsq)
- DEALLOCATE(rp_tsq)
- DEALLOCATE(bp_tsq)
+ deallocate(rp_cov)
+ deallocate(bp_cov)
+ deallocate(rp_qsq)
+ deallocate(bp_qsq)
+ deallocate(rp_tsq)
+ deallocate(bp_tsq)
- END IF ! if imp_mode == FULL_IMPL
-ELSE ! level 2.5
+ end if ! if imp_mode == FULL_IMPL
+else ! level 2.5
! In level 2.5, tsq, qsq, cov are diagnosed assuming balance between
! prodcution and dissipation.
- DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- IF (qkw(i, j, k) <= 1.0e-4) THEN
+ do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ if (qkw(i, j, k) <= 1.0e-4) then
b2l = 0.0
- ELSE
+ else
b2l = b2 * el(i, j, k) / qkw(i, j, k)
- END IF
+ end if
tsq(i, j, k) = b2l * 2.0 * pdt(i, j, k)
qsq(i, j, k) = b2l * 2.0 * pdq(i, j, k)
cov(i, j, k) = b2l * 2.0 * pdc(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (levflag >= 2) THEN
+if (levflag >= 2) then
! predict qke
- IF (my_lowest_pd_surf > 0) THEN
+ if (my_lowest_pd_surf > 0) then
k_start_cor = k_start + 1
- ELSE
+ else
k_start_cor = k_start
- END IF
+ end if
- IF (levflag == 3 .AND. &
- (imp_mode == half_impl .OR. imp_mode == full_impl)) THEN
+ if (levflag == 3 .and. &
+ (imp_mode == half_impl .or. imp_mode == full_impl)) then
! add correction terms evaluated with integrated tsq, qsq and cov
- DO k = k_start_cor, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do k = k_start_cor, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
- t3sq = MAX(tsq(i, j, k), 0.0)
- r3sq = MAX(qsq(i, j, k), 0.0)
+ t3sq = max(tsq(i, j, k), 0.0)
+ r3sq = max(qsq(i, j, k), 0.0)
c3sq = cov(i, j, k)
- c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
+ c3sq = sign( min( abs(c3sq), sqrt(t3sq*r3sq) ), c3sq )
t3sq = vt(i, j, k) * t3sq + vq(i, j, k) * c3sq
r3sq = vt(i, j, k) * c3sq + vq(i, j, k) * r3sq
- c3sq = MAX(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
+ c3sq = max(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
elq = el(i, j, k) * qkw(i, j, k)
smd(i, j, k) = smd_coef(i, j, k) * (c3sq - c2sq(i, j, k))
@@ -1040,60 +1040,60 @@ SUBROUTINE mym_turbulence( &
pdk(i, j, k) = pdk(i, j, k) + elq &
* (smd(i, j, k) * gm(i, j, k) &
+ gamv_coef(i, j, k) * (c3sq- c2sq(i, j, k)))
- END DO
- END DO
- END DO
- ELSE
- DO k = k_start_cor, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+ else
+ do k = k_start_cor, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
pdk(i, j, k) = pdk(i, j, k) &
+ el(i, j, k) * qkw(i, j, k) &
* (smd(i, j, k) * gm(i, j, k) + gamv(i, j, k))
- END DO
- END DO
- END DO
- END IF ! if test levflag == 3
-
- DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+ end if ! if test levflag == 3
+
+ do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
b1l = b1 * el(i, j, k)
bp(i, j, k) = 2.0 * qkw(i, j, k) / b1l
rp(i, j, k) = 2.0 * pdk(i, j, k)
- END DO
- END DO
- END DO
+ end do
+ end do
+ end do
- CALL mym_update_fields( &
+ call mym_update_fields( &
bl_levels, coef_trbvar_diff_tke, z_uv, z_tq, dfm, rp, bp, qke)
-ELSE
+else
! level 2
! diagnose qke
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
b2l = b2 * el(i, j, k)
- qke(i, j, k) = (MAX(b2l * 2.0 * pdk(i, j, k), 0.0)) &
+ qke(i, j, k) = (max(b2l * 2.0 * pdk(i, j, k), 0.0)) &
** two_thirds
- END DO
- END DO
- END DO
-END IF ! test if levflag >= 2
-
-DO k = 1, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
- qke(i, j, k) = MIN(MAX(qke(i, j, k), 1.0e-20), qke_max)
- tsq(i, j, k) = MAX(tsq(i, j, k), 0.0)
- qsq(i, j, k) = MAX(qsq(i, j, k), 0.0)
- END DO
- END DO
-END DO
-
-DO k = tke_levels + 1, bl_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if ! test if levflag >= 2
+
+do k = 1, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ qke(i, j, k) = min(max(qke(i, j, k), 1.0e-20), qke_max)
+ tsq(i, j, k) = max(tsq(i, j, k), 0.0)
+ qsq(i, j, k) = max(qsq(i, j, k), 0.0)
+ end do
+ end do
+end do
+
+do k = tke_levels + 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
qke(i, j, k) = 0.0
tsq(i, j, k) = 0.0
qsq(i, j, k) = 0.0
@@ -1104,42 +1104,42 @@ SUBROUTINE mym_turbulence( &
dfv_cg(i, j, k) = 0.0
dft_cg(i, j, k) = 0.0
dfq_cg(i, j, k) = 0.0
- END DO
- END DO
-END DO
-
-IF (BL_diag%l_elm) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+end do
+
+if (BL_diag%l_elm) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%elm(i, j, k) = el(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_sm) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_sm) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%sm(i, j, k) = sm(i, j, k)
- END DO
- END DO
- END DO
-END IF
-
-IF (BL_diag%l_sh) THEN
- DO k = 2, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+ end do
+ end do
+ end do
+end if
+
+if (BL_diag%l_sh) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
BL_diag%sh(i, j, k) = sh(i, j, k)
- END DO
- END DO
- END DO
-END IF
+ end do
+ end do
+ end do
+end if
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_turbulence
-END MODULE mym_turbulence_mod
+end subroutine mym_turbulence
+end module mym_turbulence_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90 b/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
index 7f2e6b6b7f..f763c9a070 100644
--- a/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90
@@ -14,16 +14,16 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_update_covariance_mod
+module mym_update_covariance_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_UPDATE_COVARIANCE_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_UPDATE_COVARIANCE_MOD'
+contains
-SUBROUTINE mym_update_covariance( &
+subroutine mym_update_covariance( &
! IN levels
bl_levels, &
! IN fields
@@ -33,22 +33,22 @@ SUBROUTINE mym_update_covariance( &
! INOUT fields
tsq, qsq, cov)
-USE atm_fields_bounds_mod, ONLY: tdims, tdims_s, pdims
-USE mym_const_mod, ONLY: b2, coef_trbvar_diff
-USE mym_option_mod, ONLY: l_my_extra_level, tke_levels
-USE timestep_mod, ONLY: timestep
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
-USE mym_solve_simeq_mod, ONLY: mym_solve_simeq
-IMPLICIT NONE
+use atm_fields_bounds_mod, only: tdims, tdims_s, pdims
+use mym_const_mod, only: b2, coef_trbvar_diff
+use mym_option_mod, only: l_my_extra_level, tke_levels
+use timestep_mod, only: timestep
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+use mym_diff_matcoef_mod, only: mym_diff_matcoef
+use mym_solve_simeq_mod, only: mym_solve_simeq
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" level
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
! Z_UV(*,K) is height of u level k
@@ -94,7 +94,7 @@ SUBROUTINE mym_update_covariance( &
tke_levels)
! a residual part in the production term of cov
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! Self covariance of liquid potential temperature
@@ -109,19 +109,19 @@ SUBROUTINE mym_update_covariance( &
! (thetal'qw') defined on theta levels K-1
! Local Variables
-INTEGER :: &
+integer :: &
i, j, k, k_start
! loop indexes, etc.
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
elem
! work variables
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
disp_coef
! coefficients of the prognostic variables in
! dissipation terms
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
aa(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
bb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
cc(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
@@ -160,27 +160,27 @@ SUBROUTINE mym_update_covariance( &
tke_levels)
! matrix elements (see the documents for details)
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_UPDATE_COVARIANCE'
+character(len=*), parameter :: RoutineName='MYM_UPDATE_COVARIANCE'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
-CALL mym_diff_matcoef( &
+call mym_diff_matcoef( &
bl_levels,coef_trbvar_diff, z_uv, z_tq, dfm, aa, bb, cc)
-IF (l_my_extra_level) THEN
+if (l_my_extra_level) then
k_start = 1
-ELSE
+else
k_start = 2
-END IF
+end if
! set maxtrix elements
-DO k = k_start, tke_levels
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do k = k_start, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
disp_coef = 2.0 * qkw(i, j, k) / (b2 * el(i, j, k))
elem = 1.0 - bb(i, j, k) * timestep &
+ timestep * disp_coef
@@ -211,12 +211,12 @@ SUBROUTINE mym_update_covariance( &
pp_qc(i, j, k) = - 2.0 * pdq_cov(i, j, k) * timestep
pp_ct(i, j, k) = - 2.0 * pdc_tsq(i, j, k) * timestep
pp_cq(i, j, k) = - 2.0 * pdc_qsq(i, j, k) * timestep
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
-DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
aa_tsq(i, j, k_start) = 0.0
aa_qsq(i, j, k_start) = 0.0
aa_cov(i, j, k_start) = 0.0
@@ -224,12 +224,12 @@ SUBROUTINE mym_update_covariance( &
cc_tsq(i, j, tke_levels) = 0.0
cc_qsq(i, j, tke_levels) = 0.0
cc_cov(i, j, tke_levels) = 0.0
- END DO
-END DO
+ end do
+end do
-IF (.NOT. l_my_extra_level) THEN
- DO j = tdims%j_start, tdims%j_end
- DO i = tdims%i_start, tdims%i_end
+if (.not. l_my_extra_level) then
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
bb_tsq(i, j, 1) = 1.0
bb_qsq(i, j, 1) = 1.0
bb_cov(i, j, 1) = 1.0
@@ -249,12 +249,12 @@ SUBROUTINE mym_update_covariance( &
pp_qc(i, j, 1) = 0.0
pp_ct(i, j, 1) = 0.0
pp_cq(i, j, 1) = 0.0
- END DO
- END DO
-END IF
+ end do
+ end do
+end if
! Solve the simultaneous equations for tsq, qsq and cov
-CALL mym_solve_simeq( &
+call mym_solve_simeq( &
! IN levels
bl_levels, &
! IN fields
@@ -263,8 +263,8 @@ SUBROUTINE mym_update_covariance( &
! OUT fields
tsq, qsq, cov)
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
-END SUBROUTINE mym_update_covariance
-END MODULE mym_update_covariance_mod
+end subroutine mym_update_covariance
+end module mym_update_covariance_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_update_fields.F90 b/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
index 6c2eaf30ce..494f24f028 100644
--- a/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_update_fields.F90
@@ -13,37 +13,37 @@
! Code Owner: Please refer to the UM file CodeOwners.txt
! This file belongs in section: boundary_layer
!---------------------------------------------------------------------
-MODULE mym_update_fields_mod
+module mym_update_fields_mod
-USE um_types, ONLY: real_umphys
+use um_types, only: r_bl
-IMPLICIT NONE
+implicit none
-CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName = 'MYM_UPDATE_FIELDS_MOD'
-CONTAINS
+character(len=*), parameter, private :: ModuleName = 'MYM_UPDATE_FIELDS_MOD'
+contains
-SUBROUTINE mym_update_fields(bl_levels,coef,z_uv,z_tq,dfm,prod,disp_coef,field)
+subroutine mym_update_fields(bl_levels,coef,z_uv,z_tq,dfm,prod,disp_coef,field)
-USE atm_fields_bounds_mod, ONLY: pdims, pdims_l, tdims, tdims_s
-USE mym_option_mod, ONLY: l_my_extra_level, tke_levels
-USE timestep_mod, ONLY: timestep
-USE parkind1, ONLY: jprb, jpim
-USE yomhook, ONLY: lhook, dr_hook
-USE mym_diff_matcoef_mod, ONLY: mym_diff_matcoef
-USE mym_implic_mod, ONLY: mym_implic
-IMPLICIT NONE
+use atm_fields_bounds_mod, only: pdims, pdims_l, tdims, tdims_s
+use mym_option_mod, only: l_my_extra_level, tke_levels
+use timestep_mod, only: timestep
+use parkind1, only: jprb, jpim
+use yomhook, only: lhook, dr_hook
+use mym_diff_matcoef_mod, only: mym_diff_matcoef
+use mym_implic_mod, only: mym_implic
+implicit none
! Intent IN Variables
-INTEGER, INTENT(IN) :: &
+integer, intent(in) :: &
bl_levels
! Max. no. of "boundary" levels
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
coef
! factor for the diffusion coefficients to those for
! momentum
-REAL(KIND=real_umphys), INTENT(IN) :: &
+real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
@@ -60,63 +60,63 @@ SUBROUTINE mym_update_fields(bl_levels,coef,z_uv,z_tq,dfm,prod,disp_coef,field)
! coefficients of dissipation term
! Intent INOUT Variables
-REAL(KIND=real_umphys), INTENT(IN OUT) :: &
+real(kind=r_bl), intent(in out) :: &
field(pdims_l%i_start:pdims_l%i_end,pdims_l%j_start:pdims_l%j_end, &
bl_levels)
! field to be integrated
! Local variables
-INTEGER :: &
+integer :: &
i, j, k, k_start
! Loop indexes
-REAL(KIND=real_umphys) :: &
+real(kind=r_bl) :: &
aa(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
bb(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
cc(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels), &
qq(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,tke_levels)
! coefficients of tri-diagonal equations
-INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
-INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
-REAL(KIND=jprb) :: zhook_handle
+integer(kind=jpim), parameter :: zhook_in = 0
+integer(kind=jpim), parameter :: zhook_out = 1
+real(kind=jprb) :: zhook_handle
-CHARACTER(LEN=*), PARAMETER :: RoutineName='MYM_UPDATE_FIELDS'
+character(len=*), parameter :: RoutineName='MYM_UPDATE_FIELDS'
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
! Calculate the coefficients of tri-diagonal eqs. due to diffusion
-CALL mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
+call mym_diff_matcoef(bl_levels, coef, z_uv, z_tq, dfm, aa, bb, cc)
-IF (l_my_extra_level) THEN
+if (l_my_extra_level) then
k_start = 1
-ELSE
+else
k_start = 2
-END IF
+end if
-DO k = k_start, tke_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = k_start, tke_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
aa(i, j, k) = - aa(i, j, k) * timestep
bb(i, j, k) = 1.0 - bb(i, j, k) * timestep &
+ timestep * disp_coef(i, j, k)
cc(i, j, k) = - cc(i, j, k) * timestep
qq(i, j, k) = field(i, j, k) + timestep * prod(i, j, k)
- END DO
- END DO
-END DO
+ end do
+ end do
+end do
! Solve the tri-diagonal equations
-CALL mym_implic(tke_levels, k_start, tke_levels, aa, bb, cc, qq)
+call mym_implic(tke_levels, k_start, tke_levels, aa, bb, cc, qq)
-DO k = k_start, tke_levels
- DO j = pdims%j_start, pdims%j_end
- DO i = pdims%i_start, pdims%i_end
+do k = k_start, tke_levels
+ do j = pdims%j_start, pdims%j_end
+ do i = pdims%i_start, pdims%i_end
field(i, j, k) = qq(i, j, k)
- END DO
- END DO
-END DO
-IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
-RETURN
-END SUBROUTINE mym_update_fields
-END MODULE mym_update_fields_mod
+ end do
+ end do
+end do
+if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle)
+return
+end subroutine mym_update_fields
+end module mym_update_fields_mod
From dfe0b36de98384b799f305d3bf39440eaa52ce0b Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Wed, 29 Jul 2026 14:48:08 +0100
Subject: [PATCH 4/9] Additional modification so that 3DTE scheme can work in
single precision.
---
.../um-boundary_layer/HEAD/rose-meta.conf | 20 ++
.../source/support/um_physics_init_mod.f90 | 11 +-
.../source/boundary_layer/bdy_expl2_1a.F90 | 6 +
.../source/boundary_layer/mym_errfunc.F90 | 18 +-
.../source/boundary_layer/mym_implic.F90 | 14 +-
.../source/boundary_layer/mym_level2.F90 | 9 +
.../source/boundary_layer/mym_option_mod.F90 | 8 +
.../boundary_layer/mym_simeq_solve_hepta.F90 | 124 ++++++++++++
.../source/boundary_layer/mym_solve_simeq.F90 | 46 +++--
.../boundary_layer/mym_solve_simeq_gauss.F90 | 189 ++++++++++++++++++
10 files changed, 415 insertions(+), 30 deletions(-)
create mode 100644 science/physics_schemes/source/boundary_layer/mym_simeq_solve_hepta.F90
create mode 100644 science/physics_schemes/source/boundary_layer/mym_solve_simeq_gauss.F90
diff --git a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
index 0716e0b909..03f2a9e298 100644
--- a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
+++ b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
@@ -63,6 +63,7 @@ help=The 1A TKE schemes consists of the following three models.
ns=namelist/Science/UM Boundary layer
sort-key=Panel-A10a
trigger=namelist:blayer=my_prod_adj: 'my3' ;
+ =namelist:blayer=my_simeq_solver: 'my3' ;
value-titles=The first order eddy-diffusive model based on Deardorff (1980),
=The Mellor-Yamada level 2.5 model,
=The Mellor-Yamada level 3 model
@@ -605,6 +606,25 @@ ns=namelist/Science/UM Boundary layer
sort-key=Panel-A10a
type=logical
+[namelist:blayer=my_simeq_solver]
+compulsory=true
+description=Method for solving simultaneous equations of turbulent second moments
+!enumeration=true
+help=The prognostic equations of turbulent second moments in level 3 are solved
+ =implicitly, solving (3*tke_levels) x (3*tke_levels) sparse matrix.
+ =Two matrix solvers are available:
+ =* Bi-conjugate gradient stabilized (BCGSTAB) method
+ =* Gaussian elimination (forward elimination and backward substitution)
+ =These two solvers are mathematically equivalent. But gaussian elimination
+ =uses less memory and (generally) faster to compute than bcgstab.
+ =Suggested Gaussian elimination.
+!kind=default
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+value-titles=Use bi-conjugate gradient stabilized (BCGSTAB) method,
+ =Use gaussian elimination
+values='bicgstab', 'gauss'
+
[namelist:blayer=near_neut_z_on_l]
compulsory=true
description=Threshold value of z/l below which to diagnose shear-driven BL
diff --git a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90 b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
index f24de4fb15..58f15f5bf3 100644
--- a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
+++ b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
@@ -44,6 +44,9 @@ module um_physics_init_mod
local_above_tkelvs, &
my_force_initialize, &
my_ini_dbdz_min_in => my_ini_dbdz_min, &
+ my_simeq_solver, &
+ my_simeq_solver_bicgstab, &
+ my_simeq_solver_gauss, &
a_ent_shr, a_ent_2_in => a_ent_2, &
cbl_opt, cbl_opt_conventional, &
cbl_opt_standard, cbl_opt_adjustable, &
@@ -399,7 +402,7 @@ subroutine um_physics_init()
my_ini_dbdz_min, l_adv_turb_field, l_my_condense, l_shcu_buoy, &
shcu_levels, wb_ng_max, my_lowest_pd_surf, no_pd_surf, businger, &
bh1991, l_my_prod_adj, my_z_limit_elb, tke_cm_mx, tke_cm_fa, &
- tke_dlen, ddf_length
+ tke_dlen, ddf_length, simeq_solver, bicgstab, gauss
use cloud_inputs_mod, only: i_cld_vn, forced_cu, i_rhcpt, i_cld_area, &
rhcrit, ice_fraction_method,falliceshear_method, cff_spread_rate, &
l_subgrid_qv, ice_width, min_liq_overlap, i_eacf, not_mixph, &
@@ -906,6 +909,12 @@ subroutine um_physics_init()
if (bdy_tke_in == bdy_tke_my3) then
l_my_prod_adj = my_prod_adj
+ select case (my_simeq_solver)
+ case (my_simeq_solver_bicgstab)
+ simeq_solver = bicgstab
+ case (my_simeq_solver_gauss)
+ simeq_solver = gauss
+ end select
end if
my_z_limit_elb = 1.0e10_r_bl
diff --git a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90 b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
index 8324db6595..ed5f678d67 100644
--- a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
+++ b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
@@ -530,6 +530,11 @@ subroutine bdy_expl2_1a ( &
l
! LOCAL Loop counter for land points
+real(kind=r_bl), parameter :: max_ri = 0.01_r_bl*sqrt(huge(1.0_r_bl))
+ ! Maximum (absolute) Richardson number which ensures that
+ ! the stability functions (~ri^2) remain real-valued at
+ ! the given model precision
+
character(len=*), parameter :: RoutineName = 'BDY_EXPL2_1A'
integer(kind=jpim), parameter :: zhook_in = 0
@@ -887,6 +892,7 @@ subroutine bdy_expl2_1a ( &
do i = pdims%i_start, pdims%i_end
ri(i, j, k) = dbdz(i, j, k) &
/ ( dvdzm(i, j, k) * dvdzm(i ,j, k) )
+ ri(i, j, k) = max(min(ri(i,j,k),max_ri),-max_ri)
end do
end do
end do
diff --git a/science/physics_schemes/source/boundary_layer/mym_errfunc.F90 b/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
index 40fbda7cee..eea8a4c311 100644
--- a/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_errfunc.F90
@@ -59,7 +59,9 @@ subroutine mym_errfunc(nn, x, y)
factor
! common factor to all the coefficients
-real(kind=r_bl) :: &
+real(kind=r_bl) :: &
+ x01, &
+ ! x with upper limit
x02, &
! x powered by 2
x04, &
@@ -80,6 +82,13 @@ subroutine mym_errfunc(nn, x, y)
erfmax = 1.0
! upper limit of the value to avoid it outside domain
+real(kind=r_bl), parameter :: &
+ argmax = 100.0
+ ! upper limit of the arguments to avoid floating overflow
+ ! Given the precision of this Taylor expansion, calculations for
+ ! |x|>1.65 are sticked to erfmax and yield no meaningful results,
+ ! so this poses no problem.
+
integer(kind=jpim), parameter :: zhook_in = 0
integer(kind=jpim), parameter :: zhook_out = 1
real(kind=jprb) :: zhook_handle
@@ -100,13 +109,14 @@ subroutine mym_errfunc(nn, x, y)
first = .false.
end if
do i = 1, nn
- x02 = x(i) * x(i)
+ x01 = max(min(x(i), argmax), -argmax)
+ x02 = x01 * x01
x04 = x02 * x02
x06 = x04 * x02
x08 = x06 * x02
x10 = x08 * x02
x12 = x10 * x02
- y(i) = x(i) * ( &
+ y(i) = x01 * ( &
+ c01 &
- c03 * x02 &
+ c05 * x04 &
@@ -114,7 +124,7 @@ subroutine mym_errfunc(nn, x, y)
+ c09 * x08 &
- c11 * x10 &
+ c13 * x12)
- if (x(i) > 0) then
+ if (x01 > 0) then
y(i) = min(y(i), erfmax)
else
y(i) = max(y(i), -erfmax)
diff --git a/science/physics_schemes/source/boundary_layer/mym_implic.F90 b/science/physics_schemes/source/boundary_layer/mym_implic.F90
index eb97bd0709..410b3954fb 100644
--- a/science/physics_schemes/source/boundary_layer/mym_implic.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_implic.F90
@@ -68,11 +68,12 @@ subroutine mym_implic(levels, kst, ken, aa, bb, cc, qq)
do k = ken, kst + 1, -1
do j = pdims%j_start, pdims%j_end
do i = pdims%i_start, pdims%i_end
- aa(i, j, k - 1) = aa(i, j, k - 1) * bb(i, j, k)
- bb(i, j, k - 1) = bb(i, j, k - 1) * bb(i, j, k) &
- - aa(i, j, k) * cc(i, j, k - 1)
- qq(i, j, k - 1) = qq(i, j, k - 1) * bb(i, j, k) &
- - qq(i, j, k) * cc(i, j, k - 1)
+ ! normalising so that bb = 1.0
+ aa(i, j, k) = aa(i, j, k) / bb(i, j, k)
+ qq(i, j, k) = qq(i, j, k) / bb(i, j, k)
+
+ bb(i, j, k - 1) = bb(i, j, k - 1) - cc(i, j, k - 1) * aa(i, j, k)
+ qq(i, j, k - 1) = qq(i, j, k - 1) - cc(i, j, k - 1) * qq(i, j, k)
end do
end do
end do
@@ -87,8 +88,7 @@ subroutine mym_implic(levels, kst, ken, aa, bb, cc, qq)
do k = kst + 1, ken
do j = pdims%j_start, pdims%j_end
do i = pdims%i_start, pdims%i_end
- qq(i, j, k) = (qq(i, j, k) - aa(i, j, k) * &
- qq(i, j, k - 1)) / bb(i, j, k)
+ qq(i, j, k) = qq(i, j, k) - aa(i, j, k) * qq(i, j, k - 1)
end do
end do
end do
diff --git a/science/physics_schemes/source/boundary_layer/mym_level2.F90 b/science/physics_schemes/source/boundary_layer/mym_level2.F90
index 6970c51189..64632bd686 100644
--- a/science/physics_schemes/source/boundary_layer/mym_level2.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_level2.F90
@@ -95,6 +95,14 @@ subroutine mym_level2( &
rf
! flux Richardson Number
+real(kind=r_bl), parameter :: &
+ ri_max = 1.0e5
+ ! upper limit of gradient Richardson number to avoid
+ ! loss of significance in single precision
+ ! When Ri exceeds 10^6, stability function gets non-zero value
+ ! even though Ri exceeds the critical Richardson number
+ ! in single precision.
+
integer(kind=jpim), parameter :: zhook_in = 0
integer(kind=jpim), parameter :: zhook_out = 1
real(kind=jprb) :: zhook_handle
@@ -110,6 +118,7 @@ subroutine mym_level2( &
gh(i, j, k) = - dbdz(i, j, k)
! Gradient Richardson number
ri = - gh(i, j, k) / max( gm(i, j, k), 1.0e-10 )
+ ri = min( ri, ri_max )
! Flux Richardson number
rf = min(ri1 * (ri + ri2 - sqrt(ri ** 2 - ri3 * ri + ri4)), &
rfc )
diff --git a/science/physics_schemes/source/boundary_layer/mym_option_mod.F90 b/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
index 3f933bf4a4..15b06961a3 100644
--- a/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
@@ -121,6 +121,14 @@ module mym_option_mod
! with correction based on Sun and Chang (1986)
non_local_like_length = 3
+! Switch to choose solver of simultaneous equations
+integer :: simeq_solver = 1
+integer, parameter :: &
+! use bi-conjugate gradient stabilized method (BCGSTAB)
+ bicgstab = 0, &
+! use forward elimination backward substitution method
+ gauss = 1
+
!=======================================================================
! TKE options not in a namelist, ordered by type
!=======================================================================
diff --git a/science/physics_schemes/source/boundary_layer/mym_simeq_solve_hepta.F90 b/science/physics_schemes/source/boundary_layer/mym_simeq_solve_hepta.F90
new file mode 100644
index 0000000000..3642eb5518
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_simeq_solve_hepta.F90
@@ -0,0 +1,124 @@
+!-----------------------------------------------------------------------------
+! (C) Crown copyright Met Office. All rights reserved.
+! The file LICENCE, distributed with this code, contains details of the terms
+! under which the code may be used.
+!-----------------------------------------------------------------------------
+!> @brief Do gaussian elimination of hepta diagonal matrix.
+module mym_simeq_solve_hepta_mod
+
+ implicit none
+
+ private
+ public :: mym_simeq_solve_hepta
+
+contains
+
+ !> @brief Do gaussian elimination of hepta diagonal matrix.
+ !> @param[in] dd Diagonal element of matrix
+ !> @param[in] ee First off-diagonal element of matrix
+ !> @param[in] ff Second off-diagonal element of matrix
+ !> @param[in] gg Third off-diagonal element of matrix
+ !> @param[in] aa Third off-diagonal element of matrix
+ !> @param[in] bb Second off-diagonal element of matrix
+ !> @param[in] cc First off-diagonal element of matrix
+ !> @param[in] qq Right hand side term of equation
+ subroutine mym_simeq_solve_hepta(dd, ee, ff, gg, aa, bb, cc, qq)
+
+ use constants_mod, only: i_def, r_bl
+ use bl_option_mod, only: one
+ use mym_option_mod, only: tke_levels
+
+ implicit none
+
+ real(kind=r_bl), dimension(3*tke_levels), intent(in) :: dd, ee, ff, gg
+
+ real(kind=r_bl), dimension(3*tke_levels), intent(inout) :: aa, bb, cc, qq
+
+ integer(kind=i_def) :: k
+
+ real(kind=r_bl) :: ddk, rddk, fac1, fac2, fac3
+
+ k = 3*tke_levels
+ rddk = one / dd(k)
+ aa(k) = aa(k) * rddk
+ bb(k) = bb(k) * rddk
+ cc(k) = cc(k) * rddk
+ qq(k) = qq(k) * rddk
+
+ k = 3*tke_levels - 1
+ fac1 = ee(k)
+ ddk = dd(k) - fac1 * cc(k + 1)
+ rddk = one / ddk
+ aa(k) = aa(k) * rddk
+ bb(k) = ( bb(k) - fac1 * aa(k + 1) ) * rddk
+ cc(k) = ( cc(k) - fac1 * bb(k + 1) ) * rddk
+ qq(k) = ( qq(k) - fac1 * qq(k + 1) ) * rddk
+
+ k = 3*tke_levels - 2
+ fac2 = ff(k)
+ fac1 = ee(k) - fac2 * cc(k + 2)
+ ddk = dd(k) - fac1 * cc(k + 1) - fac2 * bb(k + 2)
+ rddk = one / ddk
+ aa(k) = aa(k) * rddk
+ bb(k) = ( bb(k) - fac1 * aa(k + 1) ) * rddk
+ cc(k) = ( cc(k) - fac1 * bb(k + 1) - fac2 * aa(k + 2) ) * rddk
+ qq(k) = ( qq(k) - fac1 * qq(k + 1) - fac2 * qq(k + 2) ) * rddk
+
+ do k = 3*tke_levels - 3, 4, -1
+ fac3 = gg(k)
+ fac2 = ff(k) - fac3 * cc(k + 3)
+ fac1 = ee(k) - fac2 * cc(k + 2) - fac3 * bb(k + 3)
+ ddk = dd(k) - fac1 * cc(k + 1) - fac2 * bb(k + 2) - fac3 * aa(k + 3)
+ rddk = one / ddk
+ aa(k) = aa(k) * rddk
+ bb(k) = ( bb(k) - fac1 * aa(k + 1) ) * rddk
+ cc(k) = ( cc(k) - fac1 * bb(k + 1) - fac2 * aa(k + 2) ) * rddk
+ qq(k) = ( qq(k) - fac1 * qq(k + 1) - fac2 * qq(k + 2) &
+ - fac3 * qq(k + 3) ) * rddk
+ end do
+
+ k = 3
+ fac3 = gg(k)
+ fac2 = ff(k) - fac3 * cc(k + 3)
+ fac1 = ee(k) - fac2 * cc(k + 2) - fac3 * bb(k + 3)
+ ddk = dd(k) - fac1 * cc(k + 1) - fac2 * bb(k + 2) - fac3 * aa(k + 3)
+ rddk = one / ddk
+ bb(k) = ( bb(k) - fac1 * aa(k + 1) ) * rddk
+ cc(k) = ( cc(k) - fac1 * bb(k + 1) - fac2 * aa(k + 2) ) * rddk
+ qq(k) = ( qq(k) - fac1 * qq(k + 1) - fac2 * qq(k + 2) &
+ - fac3 * qq(k + 3) ) * rddk
+
+ k = 2
+ fac3 = gg(k)
+ fac2 = ff(k) - fac3 * cc(k + 3)
+ fac1 = ee(k) - fac2 * cc(k + 2) - fac3 * bb(k + 3)
+ ddk = dd(k) - fac1 * cc(k + 1) - fac2 * bb(k + 2) - fac3 * aa(k + 3)
+ rddk = one / ddk
+ cc(k) = ( cc(k) - fac1 * bb(k + 1) - fac2 * aa(k + 2) ) * rddk
+ qq(k) = ( qq(k) - fac1 * qq(k + 1) - fac2 * qq(k + 2) &
+ - fac3 * qq(k + 3) ) * rddk
+
+ k = 1
+ fac3 = gg(k)
+ fac2 = ff(k) - fac3 * cc(k + 3)
+ fac1 = ee(k) - fac2 * cc(k + 2) - fac3 * bb(k + 3)
+ ddk = dd(k) - fac1 * cc(k + 1) - fac2 * bb(k + 2) - fac3 * aa(k + 3)
+ rddk = one / ddk
+ qq(k) = ( qq(k) - fac1 * qq(k + 1) - fac2 * qq(k + 2) &
+ - fac3 * qq(k + 3) ) * rddk
+
+ k = 2
+ qq(k) = qq(k) - cc(k) * qq(k - 1)
+
+ k = 3
+ qq(k) = qq(k) - cc(k) * qq(k - 1) - bb(k) * qq(k - 2)
+
+ do k = 4, 3*tke_levels
+ qq(k) = qq(k) - cc(k) * qq(k - 1) - bb(k) * qq(k - 2) - aa(k) * qq(k - 3)
+ end do
+
+ return
+
+ end subroutine mym_simeq_solve_hepta
+
+end module mym_simeq_solve_hepta_mod
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
index 685669c315..9d69b41ad7 100644
--- a/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq.F90
@@ -32,11 +32,12 @@ subroutine mym_solve_simeq( &
tsq, qsq, cov)
use atm_fields_bounds_mod, only: tdims
-use mym_option_mod, only: tke_levels
+use mym_option_mod, only: tke_levels, simeq_solver, bicgstab, gauss
use parkind1, only: jprb, jpim
use yomhook, only: lhook, dr_hook
use mym_solve_simeq_bcgstab_mod, only: mym_solve_simeq_bcgstab
use mym_solve_simeq_lud_mod, only: mym_solve_simeq_lud
+use mym_solve_simeq_gauss_mod, only: mym_solve_simeq_gauss
implicit none
! Intent IN Variables
@@ -173,23 +174,32 @@ subroutine mym_solve_simeq( &
pp_cq_k(k) = pp_cq(i, j, k) * cq_scale
end do
- call mym_solve_simeq_bcgstab( &
- max_itr, eps, &
- qq_tsq_k, qq_qsq_k, qq_cov_k, &
- aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
- aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
- aa_cov_k, bb_cov_k, cc_cov_k, &
- pp_ct_k, pp_cq_k, &
- tsq_k, qsq_k, cov_k, endflag)
-
- if (endflag < 0) then
- ! if failed to converge, solve eqs. by LU decomposition
- call mym_solve_simeq_lud( &
- qq_tsq_k, qq_qsq_k, qq_cov_k, &
- aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
- aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
- aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
- tsq_k, qsq_k, cov_k)
+ if (simeq_solver == bicgstab) then
+ call mym_solve_simeq_bcgstab( &
+ max_itr, eps, &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, &
+ pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k, endflag)
+
+ if (endflag < 0) then
+ ! if failed to converge, solve eqs. by LU decomposition
+ call mym_solve_simeq_lud( &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k)
+ end if
+ else if (simeq_solver == gauss) then
+ call mym_solve_simeq_gauss( &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k)
end if
! set the values into the original arrays.
diff --git a/science/physics_schemes/source/boundary_layer/mym_solve_simeq_gauss.F90 b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_gauss.F90
new file mode 100644
index 0000000000..4c51c8d090
--- /dev/null
+++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq_gauss.F90
@@ -0,0 +1,189 @@
+!-----------------------------------------------------------------------------
+! (C) Crown copyright Met Office. All rights reserved.
+! The file LICENCE, distributed with this code, contains details of the terms
+! under which the code may be used.
+!-----------------------------------------------------------------------------
+!> @brief Solve simultaneous equations with gaussian elimination.
+module mym_solve_simeq_gauss_mod
+
+ implicit none
+
+ private
+ public :: mym_solve_simeq_gauss
+
+contains
+ !> @brief Solve simultaneous equations with gaussian elimination.
+ !> @param[in] qq_tsq_k Right hand side term of tsq(k) equation
+ !> @param[in] qq_qsq_k Right hand side term of qsq(k) equation
+ !> @param[in] qq_cov_k Right hand side term of cov(k) equation
+ !> @param[in] aa_tsq_k Coefficient of tsq(k-1)
+ !> @param[in] bb_tsq_k Coefficient of tsq(k)
+ !> @param[in] cc_tsq_k Coefficient of tsq(k+1)
+ !> @param[in] pp_tc_k Correlation with cov in tsq equation
+ !> @param[in] aa_qsq_k Coefficient of qsq(k-1)
+ !> @param[in] bb_qsq_k Coefficient of qsq(k)
+ !> @param[in] cc_qsq_k Coefficient of qsq(k+1)
+ !> @param[in] pp_qc_k Correlation with cov in qsq equation
+ !> @param[in] aa_cov_k Coefficient of cov(k-1)
+ !> @param[in] bb_cov_k Coefficient of cov(k)
+ !> @param[in] cc_cov_k Coefficient of cov(k+1)
+ !> @param[in] pp_ct_k Correlation with tsq in cov equation
+ !> @param[in] pp_cq_k Correlation with qsq in cov equation
+ !> @param[out] tsq_k Solved tsq
+ !> @param[out] qsq_k Solved qsq
+ !> @param[out] cov_k Solved cov
+ subroutine mym_solve_simeq_gauss( &
+ qq_tsq_k, qq_qsq_k, qq_cov_k, &
+ aa_tsq_k, bb_tsq_k, cc_tsq_k, pp_tc_k, &
+ aa_qsq_k, bb_qsq_k, cc_qsq_k, pp_qc_k, &
+ aa_cov_k, bb_cov_k, cc_cov_k, pp_ct_k, pp_cq_k, &
+ tsq_k, qsq_k, cov_k)
+
+ use constants_mod, only: i_def, r_bl
+ use bl_option_mod, only: zero
+ use mym_option_mod, only: tke_levels
+ use mym_simeq_solve_hepta_mod, only: mym_simeq_solve_hepta
+
+ implicit none
+
+ real(kind=r_bl), dimension(tke_levels), intent(in) :: qq_tsq_k, &
+ qq_qsq_k, &
+ qq_cov_k, &
+ aa_tsq_k, &
+ bb_tsq_k, &
+ cc_tsq_k, &
+ pp_tc_k, &
+ aa_qsq_k, &
+ bb_qsq_k, &
+ cc_qsq_k, &
+ pp_qc_k, &
+ aa_cov_k, &
+ bb_cov_k, &
+ cc_cov_k, &
+ pp_ct_k, &
+ pp_cq_k
+
+ real(kind=r_bl), dimension(tke_levels), intent(out) :: tsq_k, &
+ qsq_k, &
+ cov_k
+ ! Local variables
+ integer(kind=i_def) :: k, kt, kq, kc
+
+ real(kind=r_bl), dimension(3*tke_levels) :: aa, bb, cc, dd, ee, ff, gg, qq
+ ! elements of heptadiag matrix
+
+ k = 1
+ kt = 1
+ kq = 2
+ kc = 3
+
+ bb(kc) = pp_ct_k(k)
+
+ cc(kq) = zero
+ cc(kc) = pp_cq_k(k)
+
+ dd(kt) = bb_tsq_k(k)
+ dd(kq) = bb_qsq_k(k)
+ dd(kc) = bb_cov_k(k)
+
+ ee(kt) = zero
+ ee(kq) = pp_qc_k(k)
+ ee(kc) = zero
+
+ ff(kt) = pp_tc_k(k)
+ ff(kq) = zero
+ ff(kc) = zero
+
+ gg(kt) = cc_tsq_k(k)
+ gg(kq) = cc_qsq_k(k)
+ gg(kc) = cc_cov_k(k)
+
+ qq(kt) = qq_tsq_k(k)
+ qq(kq) = qq_qsq_k(k)
+ qq(kc) = qq_cov_k(k)
+
+ do k = 2, tke_levels - 1
+ kt = 3*k - 2
+ kq = kt + 1
+ kc = kt + 2
+
+ aa(kt) = aa_tsq_k(k)
+ aa(kq) = aa_qsq_k(k)
+ aa(kc) = aa_cov_k(k)
+
+ bb(kt) = zero
+ bb(kq) = zero
+ bb(kc) = pp_ct_k(k)
+
+ cc(kt) = zero
+ cc(kq) = zero
+ cc(kc) = pp_cq_k(k)
+
+ dd(kt) = bb_tsq_k(k)
+ dd(kq) = bb_qsq_k(k)
+ dd(kc) = bb_cov_k(k)
+
+ ee(kt) = zero
+ ee(kq) = pp_qc_k(k)
+ ee(kc) = zero
+
+ ff(kt) = pp_tc_k(k)
+ ff(kq) = zero
+ ff(kc) = zero
+
+ gg(kt) = cc_tsq_k(k)
+ gg(kq) = cc_qsq_k(k)
+ gg(kc) = cc_cov_k(k)
+
+ qq(kt) = qq_tsq_k(k)
+ qq(kq) = qq_qsq_k(k)
+ qq(kc) = qq_cov_k(k)
+ end do
+
+ k = tke_levels
+ kt = 3*k - 2
+ kq = kt + 1
+ kc = kt + 2
+
+ aa(kt) = aa_tsq_k(k)
+ aa(kq) = aa_qsq_k(k)
+ aa(kc) = aa_cov_k(k)
+
+ bb(kt) = zero
+ bb(kq) = zero
+ bb(kc) = pp_ct_k(k)
+
+ cc(kt) = zero
+ cc(kq) = zero
+ cc(kc) = pp_cq_k(k)
+
+ dd(kt) = bb_tsq_k(k)
+ dd(kq) = bb_qsq_k(k)
+ dd(kc) = bb_cov_k(k)
+
+ ee(kt) = zero
+ ee(kq) = pp_qc_k(k)
+
+ ff(kt) = pp_tc_k(k)
+
+ qq(kt) = qq_tsq_k(k)
+ qq(kq) = qq_qsq_k(k)
+ qq(kc) = qq_cov_k(k)
+
+ call mym_simeq_solve_hepta(dd, ee, ff, gg, aa, bb, cc, qq)
+
+ do k = 1, tke_levels
+ kt = 3*k - 2
+ kq = kt + 1
+ kc = kt + 2
+
+ tsq_k(k) = qq(kt)
+ qsq_k(k) = qq(kq)
+ cov_k(k) = qq(kc)
+ end do
+
+ return
+
+ end subroutine mym_solve_simeq_gauss
+
+end module mym_solve_simeq_gauss_mod
From 16063430252b4663791a11b37aa242b4b9daf398 Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Wed, 29 Jul 2026 14:49:17 +0100
Subject: [PATCH 5/9] Merge adv and con tracer into pos tracer and create gen
tracer.
---
.../example/configuration.nml | 2 +-
.../example_forecast/configuration.nml | 2 +-
applications/jules/example/configuration.nml | 2 +-
.../lfric_atm/example/configuration.nml | 2 +-
.../ngarch/example/configuration_bl.nml | 2 +-
.../ngarch/example/configuration_casim.nml | 2 +-
.../rose-meta/um-boundary_layer/versions.py | 46 +++
.../source/support/um_physics_init_mod.f90 | 3 +-
rose-stem/app/lfric2lfric/rose-app.conf | 26 +-
.../semi_implicit_timestep_alg_mod.X90 | 110 +++----
.../gungho_transport_control_alg_mod.X90 | 98 +++---
.../driver/create_gungho_prognostics_mod.F90 | 2 +-
.../driver/create_physics_prognostics_mod.F90 | 286 +++++++++---------
.../gungho/source/driver/field_mapper_mod.F90 | 56 ++--
.../gungho/source/driver/field_spec_mod.F90 | 22 +-
.../driver/gungho_diagnostics_driver_mod.F90 | 6 +-
.../source/driver/gungho_init_fields_mod.X90 | 62 ++--
.../tl_test/tl_test_semi_imp_alg_mod.x90 | 16 +-
18 files changed, 395 insertions(+), 350 deletions(-)
diff --git a/applications/jedi_lfric_tests/example/configuration.nml b/applications/jedi_lfric_tests/example/configuration.nml
index 1d5c54cd59..eb2505aa14 100644
--- a/applications/jedi_lfric_tests/example/configuration.nml
+++ b/applications/jedi_lfric_tests/example/configuration.nml
@@ -389,7 +389,7 @@ ffsl_splitting=5*1,
ffsl_unity_3d=.false.,
ffsl_vertical_order=2,2,1,2,2,
field_names='density','potential_temperature','wind','moisture',
-'con_tracer',
+'pos_tracer',
fv_horizontal_order=2,
fv_vertical_order=2,
horizontal_method=5*1,
diff --git a/applications/jedi_lfric_tests/example_forecast/configuration.nml b/applications/jedi_lfric_tests/example_forecast/configuration.nml
index 5cd7cf6842..9196fc85ab 100644
--- a/applications/jedi_lfric_tests/example_forecast/configuration.nml
+++ b/applications/jedi_lfric_tests/example_forecast/configuration.nml
@@ -337,7 +337,7 @@ ffsl_splitting=5*1,
ffsl_unity_3d=.false.,
ffsl_vertical_order=2,2,1,2,2,
field_names='density','potential_temperature','wind','moisture',
-'con_tracer',
+'pos_tracer',
fv_horizontal_order=2,
fv_vertical_order=2,
horizontal_method=5*1,
diff --git a/applications/jules/example/configuration.nml b/applications/jules/example/configuration.nml
index 6c353e5b12..bd6dda8a4d 100644
--- a/applications/jules/example/configuration.nml
+++ b/applications/jules/example/configuration.nml
@@ -804,7 +804,7 @@ ffsl_splitting=6*1,
ffsl_unity_3d=.true.,
ffsl_vertical_order=2,2,1,2,2,2,
field_names='density','potential_temperature','wind','moisture',
-'adv_tracer','con_tracer',
+'gen_tracer','pos_tracer',
fv_horizontal_order=2,
fv_vertical_order=2,
horizontal_method=6*2,
diff --git a/applications/lfric_atm/example/configuration.nml b/applications/lfric_atm/example/configuration.nml
index d1519a88fa..9589bd31cb 100644
--- a/applications/lfric_atm/example/configuration.nml
+++ b/applications/lfric_atm/example/configuration.nml
@@ -1001,7 +1001,7 @@ ffsl_splitting=6*1,
ffsl_unity_3d=.true.,
ffsl_vertical_order=2,2,1,2,2,2,
field_names='density','potential_temperature','wind','moisture',
-'adv_tracer','con_tracer',
+'gen_tracer','pos_tracer',
fv_horizontal_order=2,
fv_vertical_order=2,
horizontal_method=6*2,
diff --git a/applications/ngarch/example/configuration_bl.nml b/applications/ngarch/example/configuration_bl.nml
index 26a2b3789f..3ab4fb020e 100644
--- a/applications/ngarch/example/configuration_bl.nml
+++ b/applications/ngarch/example/configuration_bl.nml
@@ -508,7 +508,7 @@ ffsl_splitting=6*1,
ffsl_unity_3d=.true.,
ffsl_vertical_order=2,2,1,2,2,2,
field_names='density','potential_temperature','wind','moisture',
-'adv_tracer','con_tracer',
+'gen_tracer','pos_tracer',
fv_horizontal_order=2,
fv_vertical_order=2,
horizontal_method=6*2,
diff --git a/applications/ngarch/example/configuration_casim.nml b/applications/ngarch/example/configuration_casim.nml
index 306c8bc8cf..9e9b1b0ec0 100644
--- a/applications/ngarch/example/configuration_casim.nml
+++ b/applications/ngarch/example/configuration_casim.nml
@@ -569,7 +569,7 @@ ffsl_splitting=6*1,
ffsl_unity_3d=.true.,
ffsl_vertical_order=2,2,1,2,2,2,
field_names='density','potential_temperature','wind','moisture',
-'adv_tracer','con_tracer',
+'gen_tracer','pos_tracer',
fv_horizontal_order=2,
fv_vertical_order=2,
horizontal_method=6*2,
diff --git a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
index f19b17c64a..0eadf2266a 100644
--- a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
+++ b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
@@ -55,4 +55,50 @@ def upgrade(self, config, meta_config=None):
config, ["namelist:mixing", "method_9c"], mixing_method
)
+ conf_hash = {}
+ conf_list = ["field_names", "enforce_min_value", "min_value"]
+ # read list type namelists
+ for conf in conf_list:
+ conf_val = self.get_setting_value(
+ config, ["namelist:transport", conf]
+ ).split(",")
+ conf_hash[conf] = []
+ for value in conf_val:
+ if "*" in value:
+ num = int(value.split("*")[0])
+ val = value.split("*")[1]
+ for i in range(num):
+ conf_hash[conf].append(val)
+ else:
+ conf_hash[conf].append(value)
+ # modify namelist value according to condition
+ if (
+ "'con_tracer'" in conf_hash["field_names"]
+ and "'adv_tracer'" in conf_hash["field_names"]
+ ):
+ i = conf_hash["field_names"].index("'con_tracer'")
+ j = conf_hash["field_names"].index("'adv_tracer'")
+ conf_hash["field_names"][i] = "'pos_tracer'"
+ conf_hash["field_names"][j] = "'gen_tracer'"
+ conf_hash["enforce_min_value"][i] = ".true."
+ conf_hash["enforce_min_value"][j] = ".false."
+ conf_hash["min_value"][i] = "0.0"
+ conf_hash["min_value"][j] = "-99999999.0"
+ elif "'con_tracer'" in conf_hash["field_names"]:
+ i = conf_hash["field_names"].index("'con_tracer'")
+ conf_hash["field_names"][i] = "'pos_tracer'"
+ conf_hash["enforce_min_value"][i] = ".true."
+ conf_hash["min_value"][i] = "0.0"
+ elif "'adv_tracer'" in conf_hash["field_names"]:
+ i = conf_hash["field_names"].index("'adv_tracer'")
+ conf_hash["field_names"][i] = "'pos_tracer'"
+ conf_hash["enforce_min_value"][i] = ".true."
+ conf_hash["min_value"][i] = "0.0"
+ # change namelist value
+ for conf in conf_list:
+ self.change_setting_value(
+ config, ["namelist:transport", conf], ",".join(conf_hash[conf])
+ )
+
+
return config, self.reports
diff --git a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90 b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
index 58f15f5bf3..c0910456d3 100644
--- a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
+++ b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
@@ -708,9 +708,8 @@ subroutine um_physics_init()
fric_heating = off
end if
- lambda_min_nml = 40.0_r_um
-
l_noice_in_turb = noice_in_turb
+ lambda_min_nml = 40.0_r_um
select case (free_atm_mix)
case(free_atm_mix_to_sharp)
diff --git a/rose-stem/app/lfric2lfric/rose-app.conf b/rose-stem/app/lfric2lfric/rose-app.conf
index ad82ed4495..f6adba28f7 100644
--- a/rose-stem/app/lfric2lfric/rose-app.conf
+++ b/rose-stem/app/lfric2lfric/rose-app.conf
@@ -1470,43 +1470,43 @@ cap_density_predictor=0
cheap_update=.false.
consistent_metric=.false.
dep_pt_stencil_extent=3
-enforce_min_value=.false.
+enforce_min_value=6*.false.
equation_form=1,3,2,3,2,3
ffsl_inner_order=0
ffsl_outer_order=0
ffsl_splitting=0
ffsl_unity_3d=.false.
-ffsl_vertical_order=0
+ffsl_vertical_order=6*0
field_names='density','potential_temperature','wind','moisture',
='adv_tracer','con_tracer'
fv_horizontal_order=0
fv_vertical_order=0
-horizontal_method=0
-horizontal_monotone=0
-log_space=.false.
+horizontal_method=6*0
+horizontal_monotone=6*0
+log_space=6*.false.
max_vert_cfl_calc='uniform'
!!min_val_abs_tol=0
!!min_val_max_iterations=0
min_val_method='clipping'
-min_value=0
+min_value=6*0.0
oned_reconstruction=.false.
operators='fv'
panel_edge_high_order=.true.
panel_edge_treatment='none'
profile_size=6
-reversible=.false.
+reversible=6*.false.
runge_kutta_method='forward_euler'
-scheme=0
+scheme=6*0
si_outer_transport='none'
-special_edges_monotone=0
-splitting=0
+special_edges_monotone=6*0
+splitting=6*0
substep_transport='off'
theta_dispersion_correction=.false.
theta_variable='dry'
use_density_predictor=.false.
-vertical_method=0
-vertical_monotone=0
-vertical_monotone_order=0
+vertical_method=6*0
+vertical_monotone=6*0
+vertical_monotone_order=6*0
wind_mono_top=.false.
!!wind_mono_top_depth=5
diff --git a/science/gungho/source/algorithm/timestepping/semi_implicit_timestep_alg_mod.X90 b/science/gungho/source/algorithm/timestepping/semi_implicit_timestep_alg_mod.X90
index 298decc8ba..18c5e4b4d6 100644
--- a/science/gungho/source/algorithm/timestepping/semi_implicit_timestep_alg_mod.X90
+++ b/science/gungho/source/algorithm/timestepping/semi_implicit_timestep_alg_mod.X90
@@ -280,10 +280,10 @@ contains
type( field_array_type ), pointer :: moist_dyn_array
type( field_type ), pointer :: moist_dyn(:)
- type( field_collection_type ), pointer :: adv_tracer_all_outer
- type( field_collection_type ), pointer :: adv_tracer_last_outer
- type( field_collection_type ), pointer :: con_tracer_all_outer
- type( field_collection_type ), pointer :: con_tracer_last_outer
+ type( field_collection_type ), pointer :: gen_tracer_all_outer
+ type( field_collection_type ), pointer :: gen_tracer_last_outer
+ type( field_collection_type ), pointer :: pos_tracer_all_outer
+ type( field_collection_type ), pointer :: pos_tracer_last_outer
type( field_collection_type ), pointer :: derived_fields
type( field_collection_type ), pointer :: radiation_fields
type( field_collection_type ), pointer :: microphysics_fields
@@ -337,10 +337,10 @@ contains
mesh => theta%get_mesh()
twod_mesh => mesh_collection%get_mesh(mesh, TWOD)
- adv_tracer_all_outer => modeldb%fields%get_field_collection("adv_tracer_all_outer")
- adv_tracer_last_outer => modeldb%fields%get_field_collection("adv_tracer_last_outer")
- con_tracer_all_outer => modeldb%fields%get_field_collection("con_tracer_all_outer")
- con_tracer_last_outer => modeldb%fields%get_field_collection("con_tracer_last_outer")
+ gen_tracer_all_outer => modeldb%fields%get_field_collection("gen_tracer_all_outer")
+ gen_tracer_last_outer => modeldb%fields%get_field_collection("gen_tracer_last_outer")
+ pos_tracer_all_outer => modeldb%fields%get_field_collection("pos_tracer_all_outer")
+ pos_tracer_last_outer => modeldb%fields%get_field_collection("pos_tracer_last_outer")
derived_fields => modeldb%fields%get_field_collection("derived_fields")
microphysics_fields => modeldb%fields%get_field_collection("microphysics_fields")
turbulence_fields => modeldb%fields%get_field_collection("turbulence_fields")
@@ -375,8 +375,8 @@ contains
! Run the timestep
call run_step(self, modeldb, &
u, rho, theta, exner, mr, moist_dyn, &
- adv_tracer_all_outer,adv_tracer_last_outer, &
- con_tracer_all_outer,con_tracer_last_outer, &
+ gen_tracer_all_outer,gen_tracer_last_outer, &
+ pos_tracer_all_outer,pos_tracer_last_outer, &
prognostic_fields, moisture_fields, &
derived_fields, radiation_fields, &
microphysics_fields, electric_fields, &
@@ -409,8 +409,8 @@ contains
nullify( model_clock, mesh, &
prognostic_fields, moisture_fields, &
u, rho, theta, exner, mr, moist_dyn, &
- adv_tracer_all_outer,adv_tracer_last_outer, &
- con_tracer_all_outer,con_tracer_last_outer, &
+ gen_tracer_all_outer,gen_tracer_last_outer, &
+ pos_tracer_all_outer,pos_tracer_last_outer, &
derived_fields, radiation_fields, &
microphysics_fields, electric_fields, &
orography_fields, &
@@ -589,10 +589,10 @@ contains
!> @param[in,out] exner Exner pressure
!> @param[in,out] mr Mixing ratios
!> @param[in,out] moist_dyn Factors for moist dynamics
- !> @param[in,out] adv_tracer_all_outer Group of fields to be advected
- !> @param[in,out] adv_tracer_last_outer Group of fields to be advected
- !> @param[in,out] con_tracer_all_outer Second group of fields to be advected
- !> @param[in,out] con_tracer_last_outer Second group of fields to be advected
+ !> @param[in,out] gen_tracer_all_outer Group of fields to be advected
+ !> @param[in,out] gen_tracer_last_outer Group of fields to be advected
+ !> @param[in,out] pos_tracer_all_outer Second group of fields to be advected
+ !> @param[in,out] pos_tracer_last_outer Second group of fields to be advected
!> @param[in,out] prognostic_fields Prognostic field collection
!> @param[in,out] moisture_fields Moisture field collection
!> @param[in,out] derived_fields Group of derived fields
@@ -623,8 +623,8 @@ contains
!> @param[in] twod_mesh The current 2d mesh
subroutine run_step(self, modeldb, &
u, rho, theta, exner, mr, moist_dyn, &
- adv_tracer_all_outer,adv_tracer_last_outer, &
- con_tracer_all_outer,con_tracer_last_outer, &
+ gen_tracer_all_outer,gen_tracer_last_outer, &
+ pos_tracer_all_outer,pos_tracer_last_outer, &
prognostic_fields, moisture_fields, &
derived_fields, radiation_fields, &
microphysics_fields, electric_fields, &
@@ -651,10 +651,10 @@ contains
type( field_type ), intent( inout ) :: mr(nummr)
type( field_type ), intent( inout ) :: moist_dyn(num_moist_factors)
! field groups
- type( field_collection_type ), intent( inout ) :: adv_tracer_all_outer
- type( field_collection_type ), intent( inout ) :: adv_tracer_last_outer
- type( field_collection_type ), intent( inout ) :: con_tracer_all_outer
- type( field_collection_type ), intent( inout ) :: con_tracer_last_outer
+ type( field_collection_type ), intent( inout ) :: gen_tracer_all_outer
+ type( field_collection_type ), intent( inout ) :: gen_tracer_last_outer
+ type( field_collection_type ), intent( inout ) :: pos_tracer_all_outer
+ type( field_collection_type ), intent( inout ) :: pos_tracer_last_outer
type( field_collection_type ), intent( inout ) :: prognostic_fields
type( field_collection_type ), intent( inout ) :: moisture_fields
type( field_collection_type ), intent( inout ) :: derived_fields
@@ -726,10 +726,10 @@ contains
logical(kind=l_def) :: write_moisture_diag, do_moist_correction
! Fields after slow physics to be advected (i.e. field_n + slow phys inc)
- type( field_collection_type ) :: adv_tracer_all_outer_after_slow
- type( field_collection_type ) :: adv_tracer_last_outer_after_slow
- type( field_collection_type ) :: con_tracer_all_outer_after_slow
- type( field_collection_type ) :: con_tracer_last_outer_after_slow
+ type( field_collection_type ) :: gen_tracer_all_outer_after_slow
+ type( field_collection_type ) :: gen_tracer_last_outer_after_slow
+ type( field_collection_type ) :: pos_tracer_all_outer_after_slow
+ type( field_collection_type ) :: pos_tracer_last_outer_after_slow
! Reference fields are checkpointed
logical(kind=l_def) :: checkpoint_reference_fields
@@ -902,18 +902,18 @@ contains
!==========================================================================
! Start the Outer (advection) loop
!==========================================================================
- call conditional_collection_copy(adv_tracer_all_outer_after_slow, &
- generic_fields_to_copy=adv_tracer_all_outer, &
- field_list=adv_tracer_all_outer)
- call conditional_collection_copy(adv_tracer_last_outer_after_slow, &
- generic_fields_to_copy=adv_tracer_last_outer, &
- field_list=adv_tracer_last_outer)
- call conditional_collection_copy(con_tracer_all_outer_after_slow, &
- generic_fields_to_copy=con_tracer_all_outer, &
- field_list=con_tracer_all_outer)
- call conditional_collection_copy(con_tracer_last_outer_after_slow, &
- generic_fields_to_copy=con_tracer_last_outer, &
- field_list=con_tracer_last_outer)
+ call conditional_collection_copy(gen_tracer_all_outer_after_slow, &
+ generic_fields_to_copy=gen_tracer_all_outer, &
+ field_list=gen_tracer_all_outer)
+ call conditional_collection_copy(gen_tracer_last_outer_after_slow, &
+ generic_fields_to_copy=gen_tracer_last_outer, &
+ field_list=gen_tracer_last_outer)
+ call conditional_collection_copy(pos_tracer_all_outer_after_slow, &
+ generic_fields_to_copy=pos_tracer_all_outer, &
+ field_list=pos_tracer_all_outer)
+ call conditional_collection_copy(pos_tracer_last_outer_after_slow, &
+ generic_fields_to_copy=pos_tracer_last_outer, &
+ field_list=pos_tracer_last_outer)
call invoke( setval_X(self%wind_prev, self%state(igh_u)) )
outer_dynamics_loop: do outer = 1,outer_iterations
@@ -926,10 +926,10 @@ contains
self%state_n(igh_u), mr, mr_to_adv, model_clock, &
outer, cheap_update, self%adv_inc_prev, self%wind_prev, &
self%state_after_slow(igh_d), self%total_dry_flux, &
- adv_tracer_all_outer, adv_tracer_all_outer_after_slow, &
- adv_tracer_last_outer, adv_tracer_last_outer_after_slow, &
- con_tracer_all_outer, con_tracer_all_outer_after_slow, &
- con_tracer_last_outer, con_tracer_last_outer_after_slow &
+ gen_tracer_all_outer, gen_tracer_all_outer_after_slow, &
+ gen_tracer_last_outer, gen_tracer_last_outer_after_slow, &
+ pos_tracer_all_outer, pos_tracer_all_outer_after_slow, &
+ pos_tracer_last_outer, pos_tracer_last_outer_after_slow &
)
if ( cheap_update .AND. (outer < outer_iterations) ) then
@@ -942,14 +942,14 @@ contains
call invoke( inc_X_plus_Y(self%advected_state(igh_d), self%rhs_adv(igh_d) ), &
inc_X_plus_Y(self%advected_state(igh_t), self%rhs_adv(igh_t) ), &
inc_X_plus_Y(self%advected_state(igh_u), self%du ) )
- call adv_tracer_all_outer_after_slow%clear()
- call con_tracer_all_outer_after_slow%clear()
- call conditional_collection_copy(adv_tracer_all_outer_after_slow, &
- generic_fields_to_copy=adv_tracer_all_outer, &
- field_list=adv_tracer_all_outer)
- call conditional_collection_copy(con_tracer_all_outer_after_slow, &
- generic_fields_to_copy=con_tracer_all_outer, &
- field_list=con_tracer_all_outer)
+ call gen_tracer_all_outer_after_slow%clear()
+ call pos_tracer_all_outer_after_slow%clear()
+ call conditional_collection_copy(gen_tracer_all_outer_after_slow, &
+ generic_fields_to_copy=gen_tracer_all_outer, &
+ field_list=gen_tracer_all_outer)
+ call conditional_collection_copy(pos_tracer_all_outer_after_slow, &
+ generic_fields_to_copy=pos_tracer_all_outer, &
+ field_list=pos_tracer_all_outer)
if (self%use_moisture) then
! Update the moisture to be transported in the next outer iteration
! by setting mr_to_adv to point to the moisture after the previous
@@ -1181,13 +1181,13 @@ contains
!--------------------------------------------------------------------
! End of Outer (advection) loop
!--------------------------------------------------------------------
- call adv_tracer_all_outer_after_slow%clear()
- call adv_tracer_last_outer_after_slow%clear()
- call con_tracer_all_outer_after_slow%clear()
- call con_tracer_last_outer_after_slow%clear()
+ call gen_tracer_all_outer_after_slow%clear()
+ call gen_tracer_last_outer_after_slow%clear()
+ call pos_tracer_all_outer_after_slow%clear()
+ call pos_tracer_last_outer_after_slow%clear()
if (transport_ageofair) then
- call con_tracer_last_outer%get_field('ageofair', ageofair)
+ call pos_tracer_last_outer%get_field('ageofair', ageofair)
call ageofair_update(ageofair, model_clock)
end if
diff --git a/science/gungho/source/algorithm/transport/control/gungho_transport_control_alg_mod.X90 b/science/gungho/source/algorithm/transport/control/gungho_transport_control_alg_mod.X90
index f799cef47f..33e8363bb2 100644
--- a/science/gungho/source/algorithm/transport/control/gungho_transport_control_alg_mod.X90
+++ b/science/gungho/source/algorithm/transport/control/gungho_transport_control_alg_mod.X90
@@ -157,21 +157,21 @@ contains
!! without the predictor factor
!> @param[in] total_dry_flux (Optional) the mass flux used to transport
!! the dry density
- !> @param[in,out] adv_tracer_all_outer
+ !> @param[in,out] gen_tracer_all_outer
!! (Optional) Tracers after transport on every iteration
- !> @param[in] adv_tracer_all_outer_after_slow
+ !> @param[in] gen_tracer_all_outer_after_slow
!! (Optional) Tracers to transport every iteration
- !> @param[in,out] adv_tracer_last_outer
+ !> @param[in,out] gen_tracer_last_outer
!! (Optional) Tracers after transport on final iteration only
- !> @param[in] adv_tracer_last_outer_after_slow
+ !> @param[in] gen_tracer_last_outer_after_slow
!! (Optional) Tracers to transport on final iteration only
- !> @param[in,out] con_tracer_all_outer
+ !> @param[in,out] pos_tracer_all_outer
!! (Optional) Second group of tracers after transport on every iteration
- !> @param[in] con_tracer_all_outer_after_slow
+ !> @param[in] pos_tracer_all_outer_after_slow
!! (Optional) Second group of tracers to transport every iteration
- !> @param[in,out] con_tracer_last_outer
+ !> @param[in,out] pos_tracer_last_outer
!! (Optional) Second group of tracers after transport on final iteration only
- !> @param[in] con_tracer_last_outer_after_slow
+ !> @param[in] pos_tracer_last_outer_after_slow
!! (Optional) Second group of tracers to transport on final iteration only
subroutine gungho_transport_control_alg(config, &
@@ -181,14 +181,14 @@ contains
cheap_update, prev_inc, wind_prev, &
rho_d_n, &
total_dry_flux, &
- adv_tracer_all_outer, &
- adv_tracer_all_outer_after_slow, &
- adv_tracer_last_outer, &
- adv_tracer_last_outer_after_slow, &
- con_tracer_all_outer, &
- con_tracer_all_outer_after_slow, &
- con_tracer_last_outer, &
- con_tracer_last_outer_after_slow &
+ gen_tracer_all_outer, &
+ gen_tracer_all_outer_after_slow, &
+ gen_tracer_last_outer, &
+ gen_tracer_last_outer_after_slow, &
+ pos_tracer_all_outer, &
+ pos_tracer_all_outer_after_slow, &
+ pos_tracer_last_outer, &
+ pos_tracer_last_outer_after_slow &
)
use derived_config_mod, only: bundle_size
@@ -232,14 +232,14 @@ contains
type(field_type), intent(in), optional :: wind_prev
type(field_type), target, intent(in), optional :: rho_d_n
type(r_tran_field_type), intent(in), optional :: total_dry_flux
- type(field_collection_type), intent(inout), optional :: adv_tracer_all_outer
- type(field_collection_type), intent(in), optional :: adv_tracer_all_outer_after_slow
- type(field_collection_type), intent(inout), optional :: adv_tracer_last_outer
- type(field_collection_type), intent(in), optional :: adv_tracer_last_outer_after_slow
- type(field_collection_type), intent(inout), optional :: con_tracer_all_outer
- type(field_collection_type), intent(in), optional :: con_tracer_all_outer_after_slow
- type(field_collection_type), intent(inout), optional :: con_tracer_last_outer
- type(field_collection_type), intent(in), optional :: con_tracer_last_outer_after_slow
+ type(field_collection_type), intent(inout), optional :: gen_tracer_all_outer
+ type(field_collection_type), intent(in), optional :: gen_tracer_all_outer_after_slow
+ type(field_collection_type), intent(inout), optional :: gen_tracer_last_outer
+ type(field_collection_type), intent(in), optional :: gen_tracer_last_outer_after_slow
+ type(field_collection_type), intent(inout), optional :: pos_tracer_all_outer
+ type(field_collection_type), intent(in), optional :: pos_tracer_all_outer_after_slow
+ type(field_collection_type), intent(inout), optional :: pos_tracer_last_outer
+ type(field_collection_type), intent(in), optional :: pos_tracer_last_outer_after_slow
! Internal variables
logical(kind=l_def) :: do_moisture_diagnostics
@@ -388,29 +388,29 @@ contains
! ---------------------------------------------------------------------- !
! Transport tracers which are active in fast physics, and therefore need
! transporting on every outer iteration
- if (present(adv_tracer_all_outer) &
- .and. check_transport_name('adv_tracer') ) then
+ if (present(gen_tracer_all_outer) &
+ .and. check_transport_name('gen_tracer') ) then
call log_event( &
- "Transporting advective tracers (all)...", LOG_LEVEL_DEBUG &
+ "Transporting general tracers (all)...", LOG_LEVEL_DEBUG &
)
transport_metadata => &
- transport_metadata_collection%get_transport_metadata('adv_tracer')
+ transport_metadata_collection%get_transport_metadata('gen_tracer')
call tracer_collection_transport_alg( &
- adv_tracer_all_outer, adv_tracer_all_outer_after_slow, &
+ gen_tracer_all_outer, gen_tracer_all_outer_after_slow, &
transport_controller, transport_metadata &
)
end if
- if (present(con_tracer_all_outer) &
- .and. check_transport_name('con_tracer') ) then
+ if (present(pos_tracer_all_outer) &
+ .and. check_transport_name('pos_tracer') ) then
call log_event( &
- "Transporting conservative tracers (all)...", LOG_LEVEL_DEBUG &
+ "Transporting positive tracers (all)...", LOG_LEVEL_DEBUG &
)
transport_metadata => &
- transport_metadata_collection%get_transport_metadata('con_tracer')
+ transport_metadata_collection%get_transport_metadata('pos_tracer')
call tracer_collection_transport_alg( &
- con_tracer_all_outer, con_tracer_all_outer_after_slow, &
+ pos_tracer_all_outer, pos_tracer_all_outer_after_slow, &
transport_controller, transport_metadata &
)
end if
@@ -480,43 +480,43 @@ contains
end if
! ---------------------------------------------------------------------- !
- ! Advective tracers
- if (present(adv_tracer_last_outer) &
- .and. check_transport_name('adv_tracer') ) then
+ ! General tracers
+ if (present(gen_tracer_last_outer) &
+ .and. check_transport_name('gen_tracer') ) then
call log_event( &
- "Transporting advective tracers (last)...", LOG_LEVEL_DEBUG &
+ "Transporting general tracers (last)...", LOG_LEVEL_DEBUG &
)
- ! Get the transport metadata for last outer advective tracers
+ ! Get the transport metadata for last outer general tracers
transport_metadata => &
- transport_metadata_collection%get_transport_metadata('adv_tracer')
+ transport_metadata_collection%get_transport_metadata('gen_tracer')
call tracer_collection_transport_alg( &
- adv_tracer_last_outer, adv_tracer_last_outer_after_slow, &
+ gen_tracer_last_outer, gen_tracer_last_outer_after_slow, &
transport_controller, transport_metadata &
)
end if
! ---------------------------------------------------------------------- !
- ! Conservative tracers
- if (present(con_tracer_last_outer) &
- .and. check_transport_name('con_tracer') ) then
+ ! Positive tracers
+ if (present(pos_tracer_last_outer) &
+ .and. check_transport_name('pos_tracer') ) then
call log_event( &
- "Transporting conservative tracers (last)...", LOG_LEVEL_DEBUG &
+ "Transporting positive tracers (last)...", LOG_LEVEL_DEBUG &
)
- ! Get the transport metadata for last outer conservative tracers
+ ! Get the transport metadata for last outer positive tracers
transport_metadata => &
- transport_metadata_collection%get_transport_metadata('con_tracer')
+ transport_metadata_collection%get_transport_metadata('pos_tracer')
if (use_multires_coupling .and. coarse_aerosol_transport) then
call coarse_collection_transport_alg( &
- con_tracer_last_outer, con_tracer_last_outer_after_slow, &
+ pos_tracer_last_outer, pos_tracer_last_outer_after_slow, &
aerosol_transport_controller, transport_metadata &
)
else
call tracer_collection_transport_alg( &
- con_tracer_last_outer, con_tracer_last_outer_after_slow, &
+ pos_tracer_last_outer, pos_tracer_last_outer_after_slow, &
transport_controller, transport_metadata &
)
end if
diff --git a/science/gungho/source/driver/create_gungho_prognostics_mod.F90 b/science/gungho/source/driver/create_gungho_prognostics_mod.F90
index a237a44fcb..a4b43245d5 100644
--- a/science/gungho/source/driver/create_gungho_prognostics_mod.F90
+++ b/science/gungho/source/driver/create_gungho_prognostics_mod.F90
@@ -153,7 +153,7 @@ subroutine process_gungho_prognostics(proc)
if (transport_ageofair) then
call proc%apply(make_spec('ageofair', main%none, &
- W3, adv_coll=adv%last_con, order_h=ord_h, order_v=ord_v, ckp=.true., &
+ W3, adv_coll=adv%last_pos, order_h=ord_h, order_v=ord_v, ckp=.true., &
legacy=legacy))
end if
end subroutine process_gungho_prognostics
diff --git a/science/gungho/source/driver/create_physics_prognostics_mod.F90 b/science/gungho/source/driver/create_physics_prognostics_mod.F90
index 124eab9cf5..0274b6bf15 100644
--- a/science/gungho/source/driver/create_physics_prognostics_mod.F90
+++ b/science/gungho/source/driver/create_physics_prognostics_mod.F90
@@ -546,7 +546,7 @@ subroutine process_physics_prognostics(processor)
! 3D fields, need checkpointing
call processor%apply(make_spec('precfrac', main%microphysics, &
- adv_coll=if_adv(l_mcr_precfrac, adv%all_adv), ckp=l_mcr_precfrac, &
+ adv_coll=if_adv(l_mcr_precfrac, adv%all_pos), ckp=l_mcr_precfrac, &
empty = (.not. l_mcr_precfrac) ))
! Fields for CASIM (Cloud-AeroSol Interacting Microphysics)
@@ -555,18 +555,18 @@ subroutine process_physics_prognostics(processor)
call processor%apply(make_spec('nl_mphys', main%microphysics, &
adv_coll=if_adv((advection_flag .and. casim_iopt_act /= 0_i_def), &
- adv%last_adv), ckp=checkpoint_flag, empty = (.not. microphysics_casim)))
+ adv%last_pos), ckp=checkpoint_flag, empty = (.not. microphysics_casim)))
call processor%apply(make_spec('nr_mphys', main%microphysics, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag, &
empty = (.not. microphysics_casim) ))
call processor%apply(make_spec('ni_mphys', main%microphysics, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag, &
empty = (.not. microphysics_casim) ))
call processor%apply(make_spec('ns_mphys', main%microphysics, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag, &
empty = (.not. microphysics_casim) ))
call processor%apply(make_spec('ng_mphys', main%microphysics, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag, &
empty = (.not. microphysics_casim) ))
! 2D fields, don't need checkpointing
@@ -722,7 +722,7 @@ subroutine process_physics_prognostics(processor)
advection_flag = .false.
end if
call processor%apply(make_spec('tke_bl', main%turbulence, Wtheta, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Fields, necessary only for 1A scheme
@@ -752,13 +752,13 @@ subroutine process_physics_prognostics(processor)
advection_flag = .false.
end if
call processor%apply(make_spec('tsq_bl', main%turbulence, Wtheta, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag, &
empty = is_empty))
call processor%apply(make_spec('qsq_bl', main%turbulence, Wtheta, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag, &
empty = is_empty))
call processor%apply(make_spec('cov_bl', main%turbulence, Wtheta, &
- adv_coll=if_adv(advection_flag, adv%last_adv), ckp=checkpoint_flag, &
+ adv_coll=if_adv(advection_flag, adv%last_gen), ckp=checkpoint_flag, &
empty = is_empty))
!========================================================================
@@ -840,13 +840,13 @@ subroutine process_physics_prognostics(processor)
call processor%apply(make_spec('conv_prog_dtheta', main%convection, &
adv_coll=if_adv((l_conv_prog_dtheta .and. adv_conv_prog_dtheta), &
- adv%all_adv), ckp=l_conv_prog_dtheta, empty=(.not. l_conv_prog_dtheta)))
+ adv%all_gen), ckp=l_conv_prog_dtheta, empty=(.not. l_conv_prog_dtheta)))
call processor%apply(make_spec('conv_prog_dmv', main%convection, &
- adv_coll=if_adv((l_conv_prog_dq .and. adv_conv_prog_dq), adv%all_adv), &
+ adv_coll=if_adv((l_conv_prog_dq .and. adv_conv_prog_dq), adv%all_gen), &
ckp=l_conv_prog_dq, empty=(.not. l_conv_prog_dq)))
call processor%apply(make_spec('conv_prog_precip', main%convection, &
- adv_coll=if_adv(l_conv_prog_precip, adv%all_adv), &
+ adv_coll=if_adv(l_conv_prog_precip, adv%all_pos), &
ckp=l_conv_prog_precip, empty=(.not. l_conv_prog_precip)))
!========================================================================
@@ -869,15 +869,15 @@ subroutine process_physics_prognostics(processor)
advection_flag=.false.
endif
call processor%apply(make_spec('liquid_fraction', main%cloud, &
- adv_coll=if_adv(advection_flag, adv%all_adv), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%all_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('frozen_fraction', main%cloud, &
- adv_coll=if_adv(advection_flag, adv%all_adv), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%all_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('bulk_fraction', main%cloud, &
- adv_coll=if_adv(advection_flag, adv%all_adv), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%all_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('rh_crit', main%cloud, Wtheta))
call processor%apply(make_spec('departure_exner_wth', main%cloud, Wtheta, &
- adv_coll=if_adv(advection_flag, adv%last_adv)))
+ adv_coll=if_adv(advection_flag, adv%last_pos)))
call processor%apply(make_spec('sigma_ml', main%cloud, Wtheta))
call processor%apply(make_spec('sigma_mi', main%cloud, Wtheta))
@@ -1254,166 +1254,166 @@ subroutine process_physics_prognostics(processor)
end if
call processor%apply(make_spec('o3p', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('n', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('no', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('lumped_n', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('n2o5', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('ho2no2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hono2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
is_rad = ( (ch4_rad_opt == ch4_rad_opt_ancil) .or. &
(ch4_rad_opt == ch4_rad_opt_prognostic) )
call processor%apply(make_spec('ch4', main%chemistry, &
empty=(is_empty .and. .not. is_rad), &
adv_coll=if_adv((advection_flag .or. &
- (ch4_rad_opt == ch4_rad_opt_prognostic)), adv%last_con), &
+ (ch4_rad_opt == ch4_rad_opt_prognostic)), adv%last_pos), &
ckp=(checkpoint_flag .or. is_rad)))
is_rad = ( (co_rad_opt == co_rad_opt_ancil) .or. &
(co_rad_opt == co_rad_opt_prognostic) )
call processor%apply(make_spec('co', main%chemistry, &
empty=(is_empty .and. .not. is_rad), &
adv_coll=if_adv((advection_flag .or. &
- (co_rad_opt == co_rad_opt_prognostic)), adv%last_con), &
+ (co_rad_opt == co_rad_opt_prognostic)), adv%last_pos), &
ckp=(checkpoint_flag .or. is_rad)))
call processor%apply(make_spec('hcho', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('meooh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('h', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('cl', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('cl2o2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('clo', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('oclo', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('br', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('lumped_br', main%chemistry, empty=is_empty,&
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('brcl', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('brono2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
is_rad = ( (n2o_rad_opt == n2o_rad_opt_ancil) .or. &
(n2o_rad_opt == n2o_rad_opt_prognostic) )
call processor%apply(make_spec('n2o', main%chemistry, &
empty=(is_empty .and. .not. is_rad), &
adv_coll=if_adv((advection_flag .or. &
- (n2o_rad_opt == n2o_rad_opt_prognostic)), adv%last_con), &
+ (n2o_rad_opt == n2o_rad_opt_prognostic)), adv%last_pos), &
ckp=(checkpoint_flag .or. is_rad)))
call processor%apply(make_spec('lumped_cl', main%chemistry, empty=is_empty,&
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hocl', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hbr', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hobr', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('clono2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('cfcl3', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('cf2cl2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('mebr', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hono', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('c2h6', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('etooh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('mecho', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('pan', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('c3h8', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('n_prooh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('i_prooh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('etcho', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('me2co', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('mecoch2ooh', main%chemistry,empty=is_empty,&
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('ppan', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('meono2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('c5h8', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('isooh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('ison', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('macr', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('macrooh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('mpan', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hacet', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('mgly', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('nald', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hcooh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('meco3h', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('meco2h', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
is_rad = ( (h2_rad_opt == h2_rad_opt_ancil) .or. &
(h2_rad_opt == h2_rad_opt_prognostic) )
call processor%apply(make_spec('h2', main%chemistry, &
empty=(is_empty .and. .not. is_rad), &
adv_coll=if_adv((advection_flag .or. &
- (h2_rad_opt == h2_rad_opt_prognostic)), adv%last_con), &
+ (h2_rad_opt == h2_rad_opt_prognostic)), adv%last_pos), &
ckp=(checkpoint_flag .or. is_rad)))
call processor%apply(make_spec('meoh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('msa', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
is_rad = ( (nh3_rad_opt == nh3_rad_opt_ancil) .or. &
(nh3_rad_opt == nh3_rad_opt_prognostic) )
call processor%apply(make_spec('nh3', main%chemistry, &
empty=(is_empty .and. .not. is_rad), &
adv_coll=if_adv((advection_flag .or. &
- (nh3_rad_opt == nh3_rad_opt_prognostic)), adv%last_con), &
+ (nh3_rad_opt == nh3_rad_opt_prognostic)), adv%last_pos), &
ckp=(checkpoint_flag .or. is_rad)))
call processor%apply(make_spec('cs2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('csul', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('h2s', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('so3', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('passive_o3', main%chemistry, &
empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('age_of_air', main%chemistry, &
empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Non-UKCA gases that can be radiatively active
is_rad = ( (co2_rad_opt == co2_rad_opt_ancil) .or. &
(co2_rad_opt == co2_rad_opt_prognostic) )
call processor%apply(make_spec('co2', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((co2_rad_opt == co2_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((co2_rad_opt == co2_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = (h2o_rad_opt == h2o_rad_opt_ancil) .or. &
! If dry, this field is used instead of the standard mr field
@@ -1423,73 +1423,73 @@ subroutine process_physics_prognostics(processor)
empty=(.not. is_rad), &
adv_coll=if_adv((h2o_rad_opt == h2o_rad_opt_prognostic) .and. &
(moisture_formulation == moisture_formulation_dry), &
- adv%last_con), &
+ adv%last_pos), &
ckp=is_rad))
is_rad = ( (hcn_rad_opt == hcn_rad_opt_ancil) .or. &
(hcn_rad_opt == hcn_rad_opt_prognostic) )
call processor%apply(make_spec('hcn', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((hcn_rad_opt == hcn_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((hcn_rad_opt == hcn_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (he_rad_opt == he_rad_opt_ancil) .or. &
(he_rad_opt == he_rad_opt_prognostic) )
call processor%apply(make_spec('he', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((he_rad_opt == he_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((he_rad_opt == he_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (n2_rad_opt == n2_rad_opt_ancil) .or. &
(n2_rad_opt == n2_rad_opt_prognostic) )
call processor%apply(make_spec('n2', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((n2_rad_opt == n2_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((n2_rad_opt == n2_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (o2_rad_opt == o2_rad_opt_ancil) .or. &
(o2_rad_opt == o2_rad_opt_prognostic) )
call processor%apply(make_spec('o2', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((o2_rad_opt == o2_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((o2_rad_opt == o2_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (cs_rad_opt == cs_rad_opt_ancil) .or. &
(cs_rad_opt == cs_rad_opt_prognostic) )
call processor%apply(make_spec('cs', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((cs_rad_opt == cs_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((cs_rad_opt == cs_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (k_rad_opt == k_rad_opt_ancil) .or. &
(k_rad_opt == k_rad_opt_prognostic) )
call processor%apply(make_spec('k', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((k_rad_opt == k_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((k_rad_opt == k_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (li_rad_opt == li_rad_opt_ancil) .or. &
(li_rad_opt == li_rad_opt_prognostic) )
call processor%apply(make_spec('li', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((li_rad_opt == li_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((li_rad_opt == li_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (na_rad_opt == na_rad_opt_ancil) .or. &
(na_rad_opt == na_rad_opt_prognostic) )
call processor%apply(make_spec('na', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((na_rad_opt == na_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((na_rad_opt == na_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (rb_rad_opt == rb_rad_opt_ancil) .or. &
(rb_rad_opt == rb_rad_opt_prognostic) )
call processor%apply(make_spec('rb', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((rb_rad_opt == rb_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((rb_rad_opt == rb_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (tio_rad_opt == tio_rad_opt_ancil) .or. &
(tio_rad_opt == tio_rad_opt_prognostic) )
call processor%apply(make_spec('tio', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((tio_rad_opt == tio_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((tio_rad_opt == tio_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
is_rad = ( (vo_rad_opt == vo_rad_opt_ancil) .or. &
(vo_rad_opt == vo_rad_opt_prognostic) )
call processor%apply(make_spec('vo', main%chemistry, &
empty=(.not. is_rad), &
- adv_coll=if_adv((vo_rad_opt == vo_rad_opt_prognostic), adv%last_con), &
+ adv_coll=if_adv((vo_rad_opt == vo_rad_opt_prognostic), adv%last_pos), &
ckp=is_rad))
@@ -1509,34 +1509,34 @@ subroutine process_physics_prognostics(processor)
is_empty = .true.
end if
call processor%apply(make_spec('meoo', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('etoo', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('meco3', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('n_proo', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('i_proo', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('etco3', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('mecoch2oo', main%chemistry, empty=is_empty,&
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Fields that are never advected ('lumped' versions of no2,bro,hcl are)
advection_flag = .false.
call processor%apply(make_spec('o1d', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('no2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('bro', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('hcl', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('iso2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('macro2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Species which are active in all chemistry schemes, but some not advected
! for Offline oxidants
@@ -1553,7 +1553,7 @@ subroutine process_physics_prognostics(processor)
end if
! H2O2 - advected under all schemes
call processor%apply(make_spec('h2o2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
if ( chem_scheme == chem_scheme_offline_ox ) then
advection_flag = .false.
@@ -1562,14 +1562,14 @@ subroutine process_physics_prognostics(processor)
! Special case: ozone from radiation_fields is used instead
call processor%apply(make_spec('o3', main%chemistry, &
empty=(is_empty .and. .not. is_rad), &
- adv_coll=if_adv((advection_flag .or. is_rad), adv%last_con), &
+ adv_coll=if_adv((advection_flag .or. is_rad), adv%last_pos), &
ckp=(checkpoint_flag .or. is_rad)))
call processor%apply(make_spec('no3', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('oh', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('ho2', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Aerosol precursors - always active but checkpointed and advected only for
! glomap_mode_ukca aerosol scheme
@@ -1585,24 +1585,24 @@ subroutine process_physics_prognostics(processor)
is_empty = .true.
end if
call processor%apply(make_spec('dms', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
is_rad = ( (so2_rad_opt == so2_rad_opt_ancil) .or. &
(so2_rad_opt == so2_rad_opt_prognostic) )
call processor%apply(make_spec('so2', main%chemistry, &
empty=(is_empty .and. .not. is_rad), &
adv_coll=if_adv((advection_flag .or. &
- (so2_rad_opt == so2_rad_opt_prognostic)), adv%last_con), &
+ (so2_rad_opt == so2_rad_opt_prognostic)), adv%last_pos), &
ckp=(checkpoint_flag .or. is_rad)))
call processor%apply(make_spec('h2so4', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('dmso', main%chemistry, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('monoterpene', main%chemistry, &
empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
call processor%apply(make_spec('secondary_organic', main%chemistry, &
empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Upper limit for H2O2 (ancillary field) only active for glomap_mode and
! checkpointed for offline oxidants, never advected
call processor%apply(make_spec('h2o2_limit', main%chemistry, &
@@ -1696,13 +1696,13 @@ subroutine process_physics_prognostics(processor)
end if
! Nucleation soluble mode number mixing ratio
call processor%apply(make_spec('n_nuc_sol', main%aerosol, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Nucleation soluble H2SO4 aerosol mmr
call processor%apply(make_spec('nuc_sol_su', main%aerosol, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Nucleation soluble organic carbon aerosol mmr
call processor%apply(make_spec('nuc_sol_om', main%aerosol, empty=is_empty, &
- adv_coll=if_adv(advection_flag, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag, adv%last_pos), ckp=checkpoint_flag))
! Set flag defaults
checkpoint_flag = .false.
@@ -1739,84 +1739,84 @@ subroutine process_physics_prognostics(processor)
! Aitken soluble mode number mixing ratio
call processor%apply(make_spec('n_ait_sol', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Aitken soluble H2SO4 aerosol mmr
call processor%apply(make_spec('ait_sol_su', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Aitken soluble black carbon aerosol mmr
call processor%apply(make_spec('ait_sol_bc', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Aitken soluble organic carbon aerosol mmr
call processor%apply(make_spec('ait_sol_om', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Accumulation soluble mode number mixing ratio
call processor%apply(make_spec('n_acc_sol', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Accumulation soluble H2SO4 aerosol mmr
call processor%apply(make_spec('acc_sol_su', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Accumulation soluble black carbon aerosol mmr
call processor%apply(make_spec('acc_sol_bc', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Accumulation soluble organic carbon aerosol mmr
call processor%apply(make_spec('acc_sol_om', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Accumulation soluble sea salt aerosol mmr
call processor%apply(make_spec('acc_sol_ss', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Coarse soluble mode number mixing ratio
call processor%apply(make_spec('n_cor_sol', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Coarse soluble H2SO4 aerosol mmr
call processor%apply(make_spec('cor_sol_su', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Coarse soluble black carbon aerosol mmr
call processor%apply(make_spec('cor_sol_bc', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Coarse soluble organic carbon aerosol mmr
call processor%apply(make_spec('cor_sol_om', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Coarse soluble sea salt aerosol mmr
call processor%apply(make_spec('cor_sol_ss', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Aitken insoluble mode number mixing ratio
call processor%apply(make_spec('n_ait_ins', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Aitken insoluble black carbon aerosol mmr
call processor%apply(make_spec('ait_ins_bc', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Aitken insoluble organic carbon aerosol mmr
call processor%apply(make_spec('ait_ins_om', main%aerosol, Wtheta, coarse=coarse_rad_aerosol, &
- coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_con), &
+ coarse_mesh_name=mesh_name, adv_coll=if_adv(advection_flag, adv%last_pos), &
ckp=checkpoint_flag))
! Accumulation insoluble mode number mixing ratio
call processor%apply(make_spec('n_acc_ins', main%aerosol, Wtheta, coarse=.false., &
- adv_coll=if_adv(advection_flag_dust, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag_dust, adv%last_pos), ckp=checkpoint_flag))
! Accumulation insoluble dust aerosol mmr
call processor%apply(make_spec('acc_ins_du', main%aerosol, Wtheta, coarse=.false., &
- adv_coll=if_adv(advection_flag_dust, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag_dust, adv%last_pos), ckp=checkpoint_flag))
! Coarse insoluble mode number mixing ratio
call processor%apply(make_spec('n_cor_ins', main%aerosol, Wtheta, coarse=.false., &
- adv_coll=if_adv(advection_flag_dust, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag_dust, adv%last_pos), ckp=checkpoint_flag))
! Coarse insoluble dust aerosol mmr
call processor%apply(make_spec('cor_ins_du', main%aerosol, Wtheta, coarse=.false., &
- adv_coll=if_adv(advection_flag_dust, adv%last_con), ckp=checkpoint_flag))
+ adv_coll=if_adv(advection_flag_dust, adv%last_pos), ckp=checkpoint_flag))
! 3D fields, might need checkpointing
if (aerosol == aerosol_um .and. glomap_mode == glomap_mode_ukca) then
@@ -1953,7 +1953,7 @@ subroutine process_physics_prognostics(processor)
! Murk field
call processor%apply(make_spec('murk', main%aerosol, &
- adv_coll=if_adv(murk_prognostic, adv%last_con), &
+ adv_coll=if_adv(murk_prognostic, adv%last_pos), &
ckp=murk_prognostic, empty = (.not. murk) ))
call processor%apply(make_spec('murk_source', main%aerosol, Wtheta, &
empty = (.not. murk_prognostic) ))
diff --git a/science/gungho/source/driver/field_mapper_mod.F90 b/science/gungho/source/driver/field_mapper_mod.F90
index 433c671643..2f6f74f66a 100644
--- a/science/gungho/source/driver/field_mapper_mod.F90
+++ b/science/gungho/source/driver/field_mapper_mod.F90
@@ -36,10 +36,10 @@ module field_mapper_mod
type(field_collection_type), pointer :: depository
type(field_collection_type), pointer :: prognostic
- type(field_collection_type), pointer :: adv_all_outer
- type(field_collection_type), pointer :: adv_last_outer
- type(field_collection_type), pointer :: con_all_outer
- type(field_collection_type), pointer :: con_last_outer
+ type(field_collection_type), pointer :: pos_all_outer
+ type(field_collection_type), pointer :: pos_last_outer
+ type(field_collection_type), pointer :: gen_all_outer
+ type(field_collection_type), pointer :: gen_last_outer
type(field_collection_type), pointer :: derived
type(field_collection_type), pointer :: radiation
type(field_collection_type), pointer :: microphysics
@@ -122,10 +122,10 @@ end function get_gungho_axes
!> @param[in,out] depository Main collection of all fields in memory
!> @param[in,out] moisture_fields Collection of moisture field arrays
!> @param[in,out] prognostic_fields The prognostic variables in the model
- !> @param[in,out] adv_tracer_all_outer Collection of fields that need to be advected every outer iteration
- !> @param[in,out] adv_tracer_last_outer Collection of fields that need to be advected at final outer iteration
- !> @param[in,out] con_tracer_all_outer Second collection of fields that need to be advected every outer iteration
- !> @param[in,out] con_tracer_last_outer Second collection of fields that need to be advected at final outer iteration
+ !> @param[in,out] gen_tracer_all_outer Collection of fields that need to be advected every outer iteration
+ !> @param[in,out] gen_tracer_last_outer Collection of fields that need to be advected at final outer iteration
+ !> @param[in,out] pos_tracer_all_outer Second collection of fields that need to be advected every outer iteration
+ !> @param[in,out] pos_tracer_last_outer Second collection of fields that need to be advected at final outer iteration
!> @param[in,out] derived_fields Collection of FD fields derived from FE fields
!> @param[in,out] radiation_fields Collection of fields for radiation scheme
!> @param[in,out] microphysics_fields Collection of fields for microphys scheme
@@ -146,10 +146,10 @@ subroutine init(self, &
depository_fields, &
moisture_fields, &
prognostic_fields, &
- adv_tracer_all_outer, &
- adv_tracer_last_outer, &
- con_tracer_all_outer, &
- con_tracer_last_outer, &
+ gen_tracer_all_outer, &
+ gen_tracer_last_outer, &
+ pos_tracer_all_outer, &
+ pos_tracer_last_outer, &
derived_fields, &
radiation_fields, &
microphysics_fields, &
@@ -173,10 +173,10 @@ subroutine init(self, &
type(field_collection_type), target, intent(inout) :: depository_fields
type(field_collection_type), target, intent(inout) :: moisture_fields
type(field_collection_type), target, intent(inout) :: prognostic_fields
- type(field_collection_type), target, intent(inout) :: adv_tracer_all_outer
- type(field_collection_type), target, intent(inout) :: adv_tracer_last_outer
- type(field_collection_type), target, intent(inout) :: con_tracer_all_outer
- type(field_collection_type), target, intent(inout) :: con_tracer_last_outer
+ type(field_collection_type), target, intent(inout) :: gen_tracer_all_outer
+ type(field_collection_type), target, intent(inout) :: gen_tracer_last_outer
+ type(field_collection_type), target, intent(inout) :: pos_tracer_all_outer
+ type(field_collection_type), target, intent(inout) :: pos_tracer_last_outer
type(field_collection_type), target, intent(inout) :: derived_fields
type(field_collection_type), target, intent(inout) :: radiation_fields
type(field_collection_type), target, intent(inout) :: microphysics_fields
@@ -198,10 +198,10 @@ subroutine init(self, &
self%depository => depository_fields
self%moisture => moisture_fields
self%prognostic => prognostic_fields
- self%adv_all_outer => adv_tracer_all_outer
- self%adv_last_outer => adv_tracer_last_outer
- self%con_all_outer => con_tracer_all_outer
- self%con_last_outer => con_tracer_last_outer
+ self%gen_all_outer => gen_tracer_all_outer
+ self%gen_last_outer => gen_tracer_last_outer
+ self%pos_all_outer => pos_tracer_all_outer
+ self%pos_last_outer => pos_tracer_last_outer
self%derived => derived_fields
self%radiation => radiation_fields
self%microphysics => microphysics_fields
@@ -267,14 +267,14 @@ function get_adv_coll_ptr(self, adv_coll) result(coll_ptr)
select case(adv_coll)
case(adv_coll_dict%none)
coll_ptr => null()
- case(adv_coll_dict%all_adv)
- coll_ptr => self%adv_all_outer
- case(adv_coll_dict%last_adv)
- coll_ptr => self%adv_last_outer
- case(adv_coll_dict%all_con)
- coll_ptr => self%con_all_outer
- case(adv_coll_dict%last_con)
- coll_ptr => self%con_last_outer
+ case(adv_coll_dict%all_gen)
+ coll_ptr => self%gen_all_outer
+ case(adv_coll_dict%last_gen)
+ coll_ptr => self%gen_last_outer
+ case(adv_coll_dict%all_pos)
+ coll_ptr => self%pos_all_outer
+ case(adv_coll_dict%last_pos)
+ coll_ptr => self%pos_last_outer
case default
coll_ptr => null()
call log_event('unexpected advected collection enumerator', log_level_error)
diff --git a/science/gungho/source/driver/field_spec_mod.F90 b/science/gungho/source/driver/field_spec_mod.F90
index 0ba36a2c78..99c5634389 100644
--- a/science/gungho/source/driver/field_spec_mod.F90
+++ b/science/gungho/source/driver/field_spec_mod.F90
@@ -69,23 +69,23 @@ module field_spec_mod
!> @brief Dictionary of advected field collections
type :: adv_coll_dict_type
integer(i_def) :: none ! Not advected
- integer(i_def) :: all_adv ! Adv_fields_all_outer
- integer(i_def) :: last_adv ! Adv_fields_last_outer
- integer(i_def) :: all_con ! Con_fields_all_outer
- integer(i_def) :: last_con ! Con_fields_last_outer
+ integer(i_def) :: all_gen ! Gen_fields_all_outer
+ integer(i_def) :: last_gen ! Gen_fields_last_outer
+ integer(i_def) :: all_pos ! Pos_fields_all_outer
+ integer(i_def) :: last_pos ! Pos_fields_last_outer
end type adv_coll_dict_type
integer(i_def), parameter :: enum_adv_none = 387
- integer(i_def), parameter :: enum_all_adv = 391
- integer(i_def), parameter :: enum_last_adv = 395
- integer(i_def), parameter :: enum_all_con = 399
- integer(i_def), parameter :: enum_last_con = 412
+ integer(i_def), parameter :: enum_all_gen = 391
+ integer(i_def), parameter :: enum_last_gen = 395
+ integer(i_def), parameter :: enum_all_pos = 399
+ integer(i_def), parameter :: enum_last_pos = 412
!> @brief Map advected field enumerators to collections.
type(adv_coll_dict_type), parameter :: adv_coll_dict &
- = adv_coll_dict_type( enum_adv_none, enum_all_adv, &
- enum_last_adv, enum_all_con, &
- enum_last_con )
+ = adv_coll_dict_type( enum_adv_none, enum_all_gen, &
+ enum_last_gen, enum_all_pos, &
+ enum_last_pos )
!> @brief Dictionary of moisture field arrays
type :: moist_arr_dict_type
diff --git a/science/gungho/source/driver/gungho_diagnostics_driver_mod.F90 b/science/gungho/source/driver/gungho_diagnostics_driver_mod.F90
index 6c1cb79283..16531658f9 100644
--- a/science/gungho/source/driver/gungho_diagnostics_driver_mod.F90
+++ b/science/gungho/source/driver/gungho_diagnostics_driver_mod.F90
@@ -89,7 +89,7 @@ subroutine gungho_diagnostics_driver( modeldb, &
logical, intent(in) :: nodal_output_on_w3
type(field_collection_type), pointer :: prognostic_fields
- type(field_collection_type), pointer :: con_tracer_last_outer
+ type(field_collection_type), pointer :: pos_tracer_last_outer
type(field_collection_type), pointer :: lbc_fields
type(field_collection_type), pointer :: moisture_fields
type(field_type), pointer :: mr(:)
@@ -155,7 +155,7 @@ subroutine gungho_diagnostics_driver( modeldb, &
moist_dyn => moist_dyn_array%bundle
derived_fields => modeldb%fields%get_field_collection("derived_fields")
panel_id => get_panel_id(mesh)
- con_tracer_last_outer => modeldb%fields%get_field_collection("con_tracer_last_outer")
+ pos_tracer_last_outer => modeldb%fields%get_field_collection("pos_tracer_last_outer")
! Can't just iterate through the prognostic/diagnostic collections as
! some fields are scalars and some fields are vectors, so explicitly
@@ -199,7 +199,7 @@ subroutine gungho_diagnostics_driver( modeldb, &
deallocate(fs_ids)
if (transport_ageofair) then
- call con_tracer_last_outer%get_field('ageofair',ageofair)
+ call pos_tracer_last_outer%get_field('ageofair',ageofair)
call write_scalar_diagnostic('ageofair', ageofair, &
modeldb%clock, mesh, nodal_output_on_w3)
end if
diff --git a/science/gungho/source/driver/gungho_init_fields_mod.X90 b/science/gungho/source/driver/gungho_init_fields_mod.X90
index b00b7c2258..312156c693 100644
--- a/science/gungho/source/driver/gungho_init_fields_mod.X90
+++ b/science/gungho/source/driver/gungho_init_fields_mod.X90
@@ -370,10 +370,10 @@ subroutine create_model_data( modeldb, &
type(field_collection_type), pointer :: ancil_fields
type(field_collection_type), pointer :: electric_fields
type(field_collection_type), pointer :: orography_fields
- type(field_collection_type), pointer :: adv_tracer_all_outer
- type(field_collection_type), pointer :: adv_tracer_last_outer
- type(field_collection_type), pointer :: con_tracer_all_outer
- type(field_collection_type), pointer :: con_tracer_last_outer
+ type(field_collection_type), pointer :: gen_tracer_all_outer
+ type(field_collection_type), pointer :: gen_tracer_last_outer
+ type(field_collection_type), pointer :: pos_tracer_all_outer
+ type(field_collection_type), pointer :: pos_tracer_last_outer
type(field_collection_type), pointer :: microphysics_fields
type(field_collection_type), pointer :: derived_fields
type(field_collection_type), pointer :: cloud_fields
@@ -467,14 +467,14 @@ subroutine create_model_data( modeldb, &
electric_fields => modeldb%fields%get_field_collection("electric_fields")
call modeldb%fields%add_empty_field_collection("orography_fields", table_len = 100)
orography_fields => modeldb%fields%get_field_collection("orography_fields")
- call modeldb%fields%add_empty_field_collection("adv_tracer_all_outer", table_len = 100)
- adv_tracer_all_outer => modeldb%fields%get_field_collection("adv_tracer_all_outer")
- call modeldb%fields%add_empty_field_collection("adv_tracer_last_outer", table_len = 100)
- adv_tracer_last_outer => modeldb%fields%get_field_collection("adv_tracer_last_outer")
- call modeldb%fields%add_empty_field_collection("con_tracer_all_outer", table_len = 100)
- con_tracer_all_outer => modeldb%fields%get_field_collection("con_tracer_all_outer")
- call modeldb%fields%add_empty_field_collection("con_tracer_last_outer", table_len = 100)
- con_tracer_last_outer => modeldb%fields%get_field_collection("con_tracer_last_outer")
+ call modeldb%fields%add_empty_field_collection("gen_tracer_all_outer", table_len = 100)
+ gen_tracer_all_outer => modeldb%fields%get_field_collection("gen_tracer_all_outer")
+ call modeldb%fields%add_empty_field_collection("gen_tracer_last_outer", table_len = 100)
+ gen_tracer_last_outer => modeldb%fields%get_field_collection("gen_tracer_last_outer")
+ call modeldb%fields%add_empty_field_collection("pos_tracer_all_outer", table_len = 100)
+ pos_tracer_all_outer => modeldb%fields%get_field_collection("pos_tracer_all_outer")
+ call modeldb%fields%add_empty_field_collection("pos_tracer_last_outer", table_len = 100)
+ pos_tracer_last_outer => modeldb%fields%get_field_collection("pos_tracer_last_outer")
call modeldb%fields%add_empty_field_collection("microphysics_fields", table_len = 100)
microphysics_fields => modeldb%fields%get_field_collection("microphysics_fields")
call modeldb%fields%add_empty_field_collection("derived_fields", table_len = 100)
@@ -489,10 +489,10 @@ subroutine create_model_data( modeldb, &
call field_mapper%init( depository, &
moisture_fields, &
prognostic_fields, &
- adv_tracer_all_outer, &
- adv_tracer_last_outer, &
- con_tracer_all_outer, &
- con_tracer_last_outer, &
+ gen_tracer_all_outer, &
+ gen_tracer_last_outer, &
+ pos_tracer_all_outer, &
+ pos_tracer_last_outer, &
derived_fields, &
radiation_fields, &
microphysics_fields, &
@@ -660,7 +660,7 @@ subroutine create_model_data( modeldb, &
type(field_collection_type), pointer :: ancil_fields
type(field_collection_type), pointer :: electric_fields
type(field_collection_type), pointer :: orography_fields
- type(field_collection_type), pointer :: con_tracer_last_outer
+ type(field_collection_type), pointer :: pos_tracer_last_outer
type(field_collection_type), pointer :: microphysics_fields
type(field_collection_type), pointer :: derived_fields
type(field_collection_type), pointer :: cloud_fields
@@ -708,7 +708,7 @@ subroutine create_model_data( modeldb, &
stph_fields => modeldb%fields%get_field_collection("stph_fields")
ancil_fields => modeldb%fields%get_field_collection("ancil_fields")
orography_fields => modeldb%fields%get_field_collection("orography_fields")
- con_tracer_last_outer => modeldb%fields%get_field_collection("con_tracer_last_outer")
+ pos_tracer_last_outer => modeldb%fields%get_field_collection("pos_tracer_last_outer")
microphysics_fields => modeldb%fields%get_field_collection("microphysics_fields")
derived_fields => modeldb%fields%get_field_collection("derived_fields")
cloud_fields => modeldb%fields%get_field_collection("cloud_fields")
@@ -752,7 +752,7 @@ subroutine create_model_data( modeldb, &
if ( transport_ageofair ) then
! Age-of-air needs initialising to zero in case this is a new run
! If picking up from a checkpoint, this will be overwritten
- call con_tracer_last_outer%get_field('ageofair', ageofair)
+ call pos_tracer_last_outer%get_field('ageofair', ageofair)
call init_ageofair( ageofair )
end if
@@ -1308,10 +1308,10 @@ subroutine create_model_data( modeldb, &
#endif
type(field_collection_type), pointer :: electric_fields
type(field_collection_type), pointer :: orography_fields
- type(field_collection_type), pointer :: adv_tracer_all_outer
- type(field_collection_type), pointer :: adv_tracer_last_outer
- type(field_collection_type), pointer :: con_tracer_all_outer
- type(field_collection_type), pointer :: con_tracer_last_outer
+ type(field_collection_type), pointer :: gen_tracer_all_outer
+ type(field_collection_type), pointer :: gen_tracer_last_outer
+ type(field_collection_type), pointer :: pos_tracer_all_outer
+ type(field_collection_type), pointer :: pos_tracer_last_outer
type(field_collection_type), pointer :: microphysics_fields
type(field_collection_type), pointer :: derived_fields
type(field_collection_type), pointer :: cloud_fields
@@ -1333,10 +1333,10 @@ subroutine create_model_data( modeldb, &
stph_fields => modeldb%fields%get_field_collection("stph_fields")
electric_fields => modeldb%fields%get_field_collection("electric_fields")
orography_fields => modeldb%fields%get_field_collection("orography_fields")
- adv_tracer_last_outer => modeldb%fields%get_field_collection("adv_tracer_last_outer")
- adv_tracer_all_outer => modeldb%fields%get_field_collection("adv_tracer_all_outer")
- con_tracer_last_outer => modeldb%fields%get_field_collection("con_tracer_last_outer")
- con_tracer_all_outer => modeldb%fields%get_field_collection("con_tracer_all_outer")
+ gen_tracer_last_outer => modeldb%fields%get_field_collection("gen_tracer_last_outer")
+ gen_tracer_all_outer => modeldb%fields%get_field_collection("gen_tracer_all_outer")
+ pos_tracer_last_outer => modeldb%fields%get_field_collection("pos_tracer_last_outer")
+ pos_tracer_all_outer => modeldb%fields%get_field_collection("pos_tracer_all_outer")
microphysics_fields => modeldb%fields%get_field_collection("microphysics_fields")
derived_fields => modeldb%fields%get_field_collection("derived_fields")
cloud_fields => modeldb%fields%get_field_collection("cloud_fields")
@@ -1349,10 +1349,10 @@ subroutine create_model_data( modeldb, &
call depository%clear()
call prognostic_fields%clear()
call diagnostic_fields%clear()
- call adv_tracer_last_outer%clear()
- call adv_tracer_all_outer%clear()
- call con_tracer_last_outer%clear()
- call con_tracer_all_outer%clear()
+ call gen_tracer_last_outer%clear()
+ call gen_tracer_all_outer%clear()
+ call pos_tracer_last_outer%clear()
+ call pos_tracer_all_outer%clear()
call derived_fields%clear()
call radiation_fields%clear()
call microphysics_fields%clear()
diff --git a/science/linear/integration-test/tl_test/tl_test_semi_imp_alg_mod.x90 b/science/linear/integration-test/tl_test/tl_test_semi_imp_alg_mod.x90
index 30bf004ec0..44a82ed84e 100644
--- a/science/linear/integration-test/tl_test/tl_test_semi_imp_alg_mod.x90
+++ b/science/linear/integration-test/tl_test/tl_test_semi_imp_alg_mod.x90
@@ -71,10 +71,10 @@ module tl_test_semi_imp_alg_mod
type( field_collection_type ), pointer :: diagnostic_fields => null()
type( field_type ), pointer :: mr(:) => null()
type( field_type ), pointer :: ls_mr(:) => null()
- type( field_collection_type ), pointer :: adv_tracer_all_outer
- type( field_collection_type ), pointer :: adv_tracer_last_outer
- type( field_collection_type ), pointer :: con_tracer_all_outer
- type( field_collection_type ), pointer :: con_tracer_last_outer
+ type( field_collection_type ), pointer :: gen_tracer_all_outer
+ type( field_collection_type ), pointer :: gen_tracer_last_outer
+ type( field_collection_type ), pointer :: pos_tracer_all_outer
+ type( field_collection_type ), pointer :: pos_tracer_last_outer
type( field_collection_type ), pointer :: derived_fields
type( field_collection_type ), pointer :: radiation_fields
type( field_collection_type ), pointer :: microphysics_fields
@@ -155,10 +155,10 @@ module tl_test_semi_imp_alg_mod
call moisture_fields%get_field("ls_moist_dyn", ls_moist_dyn_array)
ls_mr => ls_mr_array%bundle
ls_moist_dyn => ls_moist_dyn_array%bundle
- adv_tracer_all_outer => modeldb%fields%get_field_collection("adv_tracer_all_outer")
- adv_tracer_last_outer => modeldb%fields%get_field_collection("adv_tracer_last_outer")
- con_tracer_all_outer => modeldb%fields%get_field_collection("con_tracer_all_outer")
- con_tracer_last_outer => modeldb%fields%get_field_collection("con_tracer_last_outer")
+ gen_tracer_all_outer => modeldb%fields%get_field_collection("gen_tracer_all_outer")
+ gen_tracer_last_outer => modeldb%fields%get_field_collection("gen_tracer_last_outer")
+ pos_tracer_all_outer => modeldb%fields%get_field_collection("pos_tracer_all_outer")
+ pos_tracer_last_outer => modeldb%fields%get_field_collection("pos_tracer_last_outer")
derived_fields => modeldb%fields%get_field_collection("derived_fields")
radiation_fields => modeldb%fields%get_field_collection("radiation_fields")
microphysics_fields => modeldb%fields%get_field_collection("microphysics_fields")
From 672999a399a97363ff8b37db3a3a2e6ddd79a2a1 Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Wed, 29 Jul 2026 14:51:35 +0100
Subject: [PATCH 6/9] Implement full 3DTE Mk1, including TKE based leonard
term.
---
.../um-boundary_layer/HEAD/rose-meta.conf | 12 ++
.../source/algorithm/bl_exp1a_alg_mod.x90 | 8 +
.../source/kernel/bl_exp1a_kernel_mod.F90 | 33 ++-
.../source/support/um_physics_init_mod.f90 | 10 +-
.../lfric-gungho/HEAD/rose-meta.conf | 11 +
.../diffusion/leonard_term_alg_mod.x90 | 58 +++--
.../physics/slow_physics_alg_mod.X90 | 3 +
.../diffusion/leonard_term_kl_kernel_mod.F90 | 18 +-
.../diffusion/leonard_term_th_kernel_mod.F90 | 1 -
.../diffusion/leonard_term_u_kernel_mod.F90 | 32 +--
.../leonard_term_kl_kernel_mod_test.pf | 4 +-
.../leonard_term_th_kernel_mod_test.pf | 10 +-
.../leonard_term_u_kernel_mod_test.pf | 64 +++---
...tracer_smagorinsky_diff_kernel_mod_test.pf | 1 +
.../source/boundary_layer/bdy_expl2_1a.F90 | 53 +++--
.../source/boundary_layer/mym_ctl.F90 | 89 ++++----
.../source/boundary_layer/mym_length.F90 | 13 +-
.../source/boundary_layer/mym_option_mod.F90 | 12 +-
.../source/boundary_layer/mym_turbulence.F90 | 203 ++++++++++++++----
19 files changed, 447 insertions(+), 188 deletions(-)
diff --git a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
index 03f2a9e298..45b6627fbf 100644
--- a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
+++ b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
@@ -64,6 +64,7 @@ ns=namelist/Science/UM Boundary layer
sort-key=Panel-A10a
trigger=namelist:blayer=my_prod_adj: 'my3' ;
=namelist:blayer=my_simeq_solver: 'my3' ;
+ =namelist:mixing=leonard_tke: 'my3','my25' ;
value-titles=The first order eddy-diffusive model based on Deardorff (1980),
=The Mellor-Yamada level 2.5 model,
=The Mellor-Yamada level 3 model
@@ -850,6 +851,17 @@ ns=namelist/Science/UM Boundary layer
sort-key=Panel-A10a
type=integer
+[namelist:blayer=use_l_sq]
+compulsory=true
+description=Use squared value to blend length scales
+help=If this option is selected,
+ =turbulent length scale is computed by the harmonic mean of squared
+ =master length scale (Nakanishi 2001) and Smagorinsky length scale,
+ =instead of simple harmonic mean.
+ns=namelist/Science/UM Boundary layer
+sort-key=Panel-A10a
+type=logical
+
[namelist:blayer=zhloc_depth_fac]
compulsory=true
description=Fractional cloud height reached by local BL depth calculation
diff --git a/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90 b/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90
index 1cc937e841..45cb2df0ed 100644
--- a/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90
+++ b/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90
@@ -68,12 +68,15 @@ contains
!>@param[in,out] convection_fields Fields for convection scheme
!>@param[in] cloud_fields Fields for cloud scheme
!>@param[in,out] surface_fields Fields for surface scheme
+ !>@param[out] leonard_klm_tke Leonard term coefficient for momentum
+ !>@param[out] leonard_klh_tke Leonard term coefficient for heat
!>@param[in] model_clock Time in the model
subroutine bl_exp1a_alg(config, theta, rho, exner, mr_n, &
derived_fields, &
microphysics_fields, orography_fields, &
turbulence_fields, convection_fields, &
cloud_fields, surface_fields, &
+ leonard_klm_tke, leonard_klh_tke, &
model_clock)
use bl_exp1a_kernel_mod, only: bl_exp1a_kernel_type
@@ -92,6 +95,8 @@ contains
type( field_collection_type ), intent(in) :: convection_fields
type( field_collection_type ), intent(in) :: cloud_fields
type( field_collection_type ), intent(in) :: surface_fields
+ type( field_type ), intent( out ) :: leonard_klm_tke
+ type( field_type ), intent( out ) :: leonard_klh_tke
class( model_clock_type ), intent(in) :: model_clock
@@ -330,6 +335,8 @@ contains
call theta%copy_field_properties(rhogamw_wth)
call rho%copy_field_properties(fd_taux)
call rho%copy_field_properties(fd_tauy)
+ call theta%copy_field_properties(leonard_klm_tke)
+ call rho%copy_field_properties(leonard_klh_tke)
ncells = mesh%get_last_edge_cell()
@@ -360,6 +367,7 @@ contains
tke_bl, tsq_bl, qsq_bl, cov_bl, &
zhpar_shcu, &
rhogamu_w3, rhogamv_w3, &
+ leonard_klm_tke, leonard_klh_tke, &
bq_bl, bt_bl, &
moist_flux_bl, heat_flux_bl, dtrdz_tq_bl,&
fd_taux, fd_tauy, sea_u_current_ptr, &
diff --git a/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90 b/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90
index 98ea4eb02f..8d6a18403e 100644
--- a/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90
+++ b/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90
@@ -19,7 +19,7 @@ module bl_exp1a_kernel_mod
use empty_data_mod, only: empty_real_data
use fs_continuity_mod, only: W3, Wtheta
use kernel_mod, only: kernel_type
- use mixing_config_mod, only: smagorinsky, fullstress
+ use mixing_config_mod, only: smagorinsky, fullstress, leonard_tke
use blayer_config_mod, only: shcu_buoy, bdy_tke, bdy_tke_deardorff
use mym_option_mod, only: tke_levels
use microphysics_config_mod, only: prog_tnuc
@@ -36,7 +36,7 @@ module bl_exp1a_kernel_mod
!>
type, public, extends(kernel_type) :: bl_exp1a_kernel_type
private
- type(arg_type) :: meta_args(82) = (/ &
+ type(arg_type) :: meta_args(84) = (/ &
arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! theta_in_wth
arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! rho_in_w3
arg_type(GH_FIELD, GH_REAL, GH_READ, WTHETA), &! rho_in_wth
@@ -81,6 +81,8 @@ module bl_exp1a_kernel_mod
arg_type(GH_FIELD, GH_REAL, GH_READWRITE, ANY_DISCONTINUOUS_SPACE_1),&! zhpar_shcu_2d
arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! rhogamu_w3
arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! rhogamv_w3
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! leonard_klm_tke
+ arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &! leonard_klh_tke
arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! bq_bl
arg_type(GH_FIELD, GH_REAL, GH_WRITE, WTHETA), &! bt_bl
arg_type(GH_FIELD, GH_REAL, GH_READWRITE, W3), &! moist_flux_bl
@@ -178,6 +180,8 @@ module bl_exp1a_kernel_mod
!> @param[in,out] zhpar_shcu_2d Mixed layer height for non-gradient buoyancy flux
!> @param[in,out] rhogamu_w3 Counter Gradient Flux Term for U
!> @param[in,out] rhogamv_w3 Counter Gradient Flux Term for V
+ !> @param[in,out] leonard_klm_tke Leonard term coefficient for momentum
+ !> @param[in,out] leonard_klh_tke Leonard term coefficient for heat
!> @param[in,out] bq_bl Buoyancy parameter for moisture
!> @param[in,out] bt_bl Buoyancy parameter for heat
!> @param[in,out] moist_flux_bl Vertical moisture flux on BL levels
@@ -279,6 +283,8 @@ subroutine bl_exp1a_code(nlayers, seg_len, &
zhpar_shcu_2d, &
rhogamu_w3, &
rhogamv_w3, &
+ leonard_klm_tke, &
+ leonard_klh_tke, &
bq_bl, &
bt_bl, &
moist_flux_bl, &
@@ -377,6 +383,7 @@ subroutine bl_exp1a_code(nlayers, seg_len, &
tsq_bl, &
qsq_bl, &
cov_bl, &
+ leonard_klm_tke, &
bq_bl, bt_bl, &
dtrdz_tq_bl, &
gradrinr
@@ -386,7 +393,8 @@ subroutine bl_exp1a_code(nlayers, seg_len, &
heat_flux_bl, &
fd_taux, fd_tauy, &
rhogamu_w3, &
- rhogamv_w3
+ rhogamv_w3, &
+ leonard_klh_tke
real(kind=r_def), dimension(undf_w3), intent(in) :: exner_in_w3, &
u_in_w3, v_in_w3, &
height_w3, rdz_w3
@@ -481,6 +489,8 @@ subroutine bl_exp1a_code(nlayers, seg_len, &
real(r_bl), dimension(seg_len,1,2:bl_levels) :: rhogamu, rhogamv
+ real(r_bl), dimension(seg_len,1,bl_levels,2) :: leonard_kl_tke
+
! profile fields from level 0 upwards
real(r_bl), dimension(seg_len,1,0:nlayers) :: p_theta_levels, w, &
q, qcl, qcf
@@ -822,7 +832,7 @@ subroutine bl_exp1a_code(nlayers, seg_len, &
! OUT data required for tracer mixing :
kent, we_lim, t_frac, zrzi, kent_dsc, we_lim_dsc, t_frac_dsc, zrzi_dsc, &
! OUT data required elsewhere in UM system :
- zhsc,ntdsc,nbdsc,wstar,wthvs,uw0,vw0 &
+ zhsc,ntdsc,nbdsc,wstar,wthvs,uw0,vw0,leonard_kl_tke &
)
if ( smagorinsky ) then
@@ -981,6 +991,21 @@ subroutine bl_exp1a_code(nlayers, seg_len, &
cov_bl(map_wth(1,i) + k-1) = cov_trb(i,1,k)
end do
end do
+ if (leonard_tke) then
+ do k = 1, bl_levels
+ do i = 1, seg_len
+ leonard_klm_tke(map_wth(1,i) + k) = leonard_kl_tke(i,1,k,2)
+ leonard_klh_tke(map_w3(1,i) + k-1) = leonard_kl_tke(i,1,k,1)
+ end do
+ end do
+ do i = 1, seg_len
+ leonard_klm_tke(map_wth(1,i)) = 0.0_r_def
+ do k = bl_levels+1, nlayers
+ leonard_klm_tke(map_wth(1,i) + k) = 0.0_r_def
+ leonard_klh_tke(map_w3(1,i) + k-1) = 0.0_r_def
+ end do
+ end do
+ end if
end if
if (shcu_buoy) then
diff --git a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90 b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
index c0910456d3..874a6e0c57 100644
--- a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
+++ b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
@@ -44,6 +44,7 @@ module um_physics_init_mod
local_above_tkelvs, &
my_force_initialize, &
my_ini_dbdz_min_in => my_ini_dbdz_min, &
+ use_l_sq, &
my_simeq_solver, &
my_simeq_solver_bicgstab, &
my_simeq_solver_gauss, &
@@ -222,7 +223,8 @@ module um_physics_init_mod
method_1a_3d_smag, &
method_1a_3dte_mk1, &
mix_factor_in => mix_factor, &
- leonard_term
+ leonard_term, &
+ leonard_tke
use radiation_config_mod, only : topography, topography_horizon
@@ -402,7 +404,8 @@ subroutine um_physics_init()
my_ini_dbdz_min, l_adv_turb_field, l_my_condense, l_shcu_buoy, &
shcu_levels, wb_ng_max, my_lowest_pd_surf, no_pd_surf, businger, &
bh1991, l_my_prod_adj, my_z_limit_elb, tke_cm_mx, tke_cm_fa, &
- tke_dlen, ddf_length, simeq_solver, bicgstab, gauss
+ tke_dlen, ddf_length, l_use_l_sq, l_leonard_tke, &
+ simeq_solver, bicgstab, gauss
use cloud_inputs_mod, only: i_cld_vn, forced_cu, i_rhcpt, i_cld_area, &
rhcrit, ice_fraction_method,falliceshear_method, cff_spread_rate, &
l_subgrid_qv, ice_width, min_liq_overlap, i_eacf, not_mixph, &
@@ -1754,6 +1757,8 @@ subroutine um_physics_init()
! between tke_levels and bl_levels, however, hardwire
! this option off for now.
blending_option = off
+
+ l_use_l_sq = use_l_sq
end select
end if
@@ -1773,6 +1778,7 @@ subroutine um_physics_init()
! Leonard terms on or off
!-----------------------------------------------------------------------
l_leonard_term = leonard_term
+ l_leonard_tke = leonard_tke
!-----------------------------------------------------------------------
! UM Random Parameter scheme settings
diff --git a/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf b/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
index ea6272eb15..685f6ad39f 100644
--- a/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
+++ b/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
@@ -3702,6 +3702,16 @@ sort-key=Panel-A06
trigger=namelist:mixing=leonard_kl: .true. ;
type=logical
+[namelist:mixing=leonard_tke]
+compulsory=true
+description=Use Leonard term parameter derived from 1A BL scheme
+help=If this option is selected,
+ =Coefficient in Leonard term is determined in 1A BL scheme from turbulent
+ =length scale and closure constants.
+ns=namelist/Science/Dynamics/Mixing
+sort-key=Panel-A10a
+type=logical
+
[namelist:mixing=max_diff_factor]
compulsory=true
description=Maximum factor for capping Smagorinsky diffusivity coefficient
@@ -3730,6 +3740,7 @@ help=Options for Smagorinsky subgrid mixing scheme:
= and diffusivity.
= See UMDP 025 for further details.
sort-key=Panel-A10a
+trigger=namelist:blayer=use_l_sq: '3dte_mk1' ;
value-titles=3D Smagorinsky, 3D TKE
values='3d_smag', '3dte_mk1'
diff --git a/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90 b/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90
index b3079f19cb..da64332468 100644
--- a/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90
+++ b/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90
@@ -9,22 +9,28 @@ module leonard_term_alg_mod
use config_mod, only: config_type
use constants_mod, only: i_def, r_def
+ use extrusion_mod, only: SHIFTED
use field_mod, only: field_type
use field_collection_mod, only: field_collection_type
use integer_field_mod, only: integer_field_type
use mesh_mod, only: mesh_type
+ use mesh_collection_mod, only: mesh_collection
use mr_indices_mod, only: nummr, imr_v, imr_cl
use formulation_config_mod, only: moisture_formulation, &
moisture_formulation_dry
- use fs_continuity_mod, only: W1, W2, W3, Wtheta
+ use fs_continuity_mod, only: W1, W2, W2H, W3, Wtheta
+ use sci_w3_to_w2_average_kernel_mod, &
+ only: w3_to_w2_average_kernel_type
+ use sci_fem_constants_mod, only: get_rmultiplicity_fv
use sci_geometric_constants_mod, &
only: get_height_fv, get_panel_id, &
get_face_selector_ew, &
get_face_selector_ns
use physics_constants_mod, only: get_dtrdz_fd2
-
- use mixing_config_mod, only: leonard_kl
+ use function_space_mod, only: function_space_type
+ use function_space_collection_mod, &
+ only: function_space_collection
use timing_mod, only: start_timing, stop_timing, tik, LPROF
use log_mod, only: log_event, LOG_LEVEL_INFO
@@ -49,6 +55,8 @@ contains
!> @param[in] theta Potential temperature in wth space
!> @param[in] u 3D wind field
!> @param[in] rho Dry density in w3 space
+ !> @param[in] leonard_klm_tke Momentum coefficient based on BL scheme
+ !> @param[in] leonard_klh_tke Heat coefficient based on BL scheme
!> @param[in,out] turbulence_fields Fields for turbulence scheme
!> @param[in] derived_fields Group of derived fields
!> @param[in] dt The model timestep length
@@ -56,6 +64,7 @@ contains
subroutine leonard_term_alg(config, &
mt_inc_leonard, thetal_inc_leonard, &
u_inc_leonard, mr, theta, u, rho, &
+ leonard_klm_tke, leonard_klh_tke, &
turbulence_fields, derived_fields, &
dt, model_clock )
@@ -77,6 +86,8 @@ subroutine leonard_term_alg(config, &
type( field_type ), intent(in) :: theta
type( field_type ), intent(in) :: u
type( field_type ), intent(in) :: rho
+ type( field_type ), intent(in) :: leonard_klm_tke
+ type( field_type ), intent(in) :: leonard_klh_tke
type( field_collection_type ), intent(in) :: derived_fields
type( field_collection_type ), intent(inout) :: turbulence_fields
@@ -98,29 +109,38 @@ subroutine leonard_term_alg(config, &
type( field_type ), pointer :: height_w3 => null()
type( field_type ), pointer :: height_wth => null()
type( field_type ), pointer :: panel_id => null()
+ type( field_type ), pointer :: rmult => null()
type( integer_field_type ), pointer :: face_selector_ew
type( integer_field_type ), pointer :: face_selector_ns
! local variables
type(mesh_type), pointer :: mesh
+ type(mesh_type), pointer :: shifted_mesh
+ type(function_space_type), pointer :: w2h_sh_fs
integer(kind=i_def) :: mesh_id
+ integer(kind=i_def) :: shifted_mesh_id
integer(kind=i_def), parameter :: stencil_depth = 1
integer(tik) :: id
! Leonard term parameter
- type( field_type ) :: kl
+ type( field_type ) :: klh
+ type( field_type ) :: klm_sh_w2h
! liquid + ice water potential temperature
type( field_type ) :: thetal
! total water content
type( field_type ) :: mt
! w increment
type( field_type ) :: vel_w2v_inc_leonard
+ real( kind=r_def ) :: leonard_kl
if ( LPROF ) call start_timing( id, 'leonard_term' )
mesh => theta%get_mesh()
mesh_id = theta%get_mesh_id()
+ shifted_mesh => mesh_collection%get_mesh(mesh, SHIFTED)
+ shifted_mesh_id = shifted_mesh%get_id()
+ w2h_sh_fs => function_space_collection%get_fs(shifted_mesh, 0, 0, W2H)
! Unpack derived fields
call derived_fields%get_field('exner_in_wth', exner_in_wth)
@@ -142,20 +162,34 @@ subroutine leonard_term_alg(config, &
face_selector_ew => get_face_selector_ew(mesh)
face_selector_ns => get_face_selector_ns(mesh)
+ leonard_kl = config%mixing%leonard_kl()
+
! Set-up arrays for local fields
- call rho%copy_field_properties(kl)
call theta%copy_field_properties(thetal)
call theta%copy_field_properties(mt)
call theta%copy_field_properties(vel_w2v_inc_leonard)
-
+ call rho%copy_field_properties(klh)
+ call klm_sh_w2h%initialise(w2h_sh_fs)
+
+ if (config%mixing%leonard_tke()) then
+ rmult => get_rmultiplicity_fv(W2H, shifted_mesh_id)
+ call invoke( setval_c(klm_sh_w2h, 0.0_r_def), &
+ w3_to_w2_average_kernel_type( klm_sh_w2h, &
+ leonard_klm_tke, &
+ rmult ), &
+ inc_a_times_X(leonard_kl, klm_sh_w2h), &
+ a_times_X(klh, leonard_kl, leonard_klh_tke) )
+ else
+ call invoke( setval_c(klm_sh_w2h, leonard_kl), &
+ setval_c(klh, leonard_kl) )
+ end if
!--------------------------------------------------------------------
! Apply stability-limit to leonard_kl:
!--------------------------------------------------------------------
- call invoke( leonard_term_kl_kernel_type( kl, &
+ call invoke( leonard_term_kl_kernel_type( klh, &
velocity_w2v, &
stencil_depth, &
height_wth, &
- leonard_kl, &
dt, bl_levels), &
!--------------------------------------------------------------------
@@ -168,7 +202,7 @@ subroutine leonard_term_alg(config, &
w_physics, &
stencil_depth, &
dtrdz_tq_bl, &
- kl, &
+ klh, &
wetrho_in_w3, &
height_w3, &
planet_radius, &
@@ -185,6 +219,7 @@ subroutine leonard_term_alg(config, &
velocity_w2v, &
stencil_depth, &
vel_w2v_inc_leonard, &
+ klm_sh_w2h, &
dtrdz_fd2, &
height_w1, &
height_w2, &
@@ -194,7 +229,6 @@ subroutine leonard_term_alg(config, &
face_selector_ew, &
face_selector_ns, &
planet_radius, &
- leonard_kl, &
dt, bl_levels ), &
!--------------------------------------------------------------------
@@ -212,7 +246,7 @@ subroutine leonard_term_alg(config, &
velocity_w2v, &
stencil_depth, &
dtrdz_tq_bl, &
- kl, &
+ klh, &
rho, &
height_w3, &
planet_radius, &
@@ -231,7 +265,7 @@ subroutine leonard_term_alg(config, &
velocity_w2v, &
stencil_depth, &
dtrdz_tq_bl, &
- kl, &
+ klh, &
rho, &
height_w3, &
planet_radius, &
diff --git a/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90 b/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90
index addc7afe03..830faa1e76 100644
--- a/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90
+++ b/science/gungho/source/algorithm/physics/slow_physics_alg_mod.X90
@@ -281,6 +281,7 @@ contains
! ...for JULES & Boundary Layer
type( field_type ) :: recip_l_mo_sea, rhostar
type( field_type ) :: t1_sd_2d, q1_sd_2d
+ type( field_type ) :: leonard_klm_tke, leonard_klh_tke
! ...for spectral GWD
type( field_type ) :: du_spectral_gwd, dv_spectral_gwd
! ...for orog GWD
@@ -892,6 +893,7 @@ contains
microphysics_fields, orography_fields, &
turbulence_fields, convection_fields, cloud_fields, &
surface_fields, &
+ leonard_klm_tke, leonard_klh_tke, &
clock)
end if
end if
@@ -940,6 +942,7 @@ contains
call leonard_term_alg(modeldb%config, &
mt_inc_leonard, thetal_inc_leonard, &
u_inc_leonard, mr_n, theta, u, rho, &
+ leonard_klm_tke, leonard_klh_tke, &
turbulence_fields, derived_fields, &
dt, clock)
leonard_term_done = .true. ! Collect this increment later on
diff --git a/science/gungho/source/kernel/diffusion/leonard_term_kl_kernel_mod.F90 b/science/gungho/source/kernel/diffusion/leonard_term_kl_kernel_mod.F90
index 79a4312923..29c3ef53f0 100644
--- a/science/gungho/source/kernel/diffusion/leonard_term_kl_kernel_mod.F90
+++ b/science/gungho/source/kernel/diffusion/leonard_term_kl_kernel_mod.F90
@@ -12,6 +12,7 @@ module leonard_term_kl_kernel_mod
use argument_mod, only : arg_type, &
GH_FIELD, GH_SCALAR, GH_REAL, &
GH_READ, GH_WRITE, &
+ GH_READWRITE, &
CELL_COLUMN, STENCIL, CROSS, &
GH_INTEGER
use constants_mod, only : r_def, i_def
@@ -30,12 +31,11 @@ module leonard_term_kl_kernel_mod
type, public, extends(kernel_type) :: leonard_term_kl_kernel_type
private
- type(arg_type) :: meta_args(6) = (/ &
- arg_type(GH_FIELD, GH_REAL, GH_WRITE, W3), &
+ type(arg_type) :: meta_args(5) = (/ &
+ arg_type(GH_FIELD, GH_REAL, GH_READWRITE, W3), &
arg_type(GH_FIELD, GH_REAL, GH_READ, Wtheta, STENCIL(CROSS)), &
arg_type(GH_FIELD, GH_REAL, GH_READ, Wtheta), &
arg_type(GH_SCALAR, GH_REAL, GH_READ), &
- arg_type(GH_SCALAR, GH_REAL, GH_READ), &
arg_type(GH_SCALAR, GH_INTEGER, GH_READ) &
/)
integer :: operates_on = CELL_COLUMN
@@ -59,7 +59,6 @@ module leonard_term_kl_kernel_mod
!! @param[in] map_wt_stencil Array holding the dofmap for the stencil at the
!! base of the column for Wtheta
!! @param[in] height_wth Height of wth space levels above the surface
-!! @param[in] leonard_kl The user-specified Leonard term parameter
!! @param[in] dt The model timestep length
!! @param[in] bl_levels The number of boundary-layer levels
!! @param[in] ndf_w3 Number of degrees of freedom per cell for w3 space
@@ -73,7 +72,6 @@ subroutine leonard_term_kl_code( nlayers, &
velocity_w2v, &
map_wt_stencil_size, map_wt_stencil, &
height_wth, &
- leonard_kl, &
dt, bl_levels, &
ndf_w3, undf_w3, map_w3, &
ndf_wt, undf_wt, map_wt &
@@ -90,7 +88,6 @@ subroutine leonard_term_kl_code( nlayers, &
integer(kind=i_def), dimension(ndf_wt), intent(in) :: map_wt
integer(kind=i_def), dimension(ndf_w3), intent(in) :: map_w3
- real(kind=r_def), intent(in) :: leonard_kl
real(kind=r_def), intent(in) :: dt
real(kind=r_def), dimension(undf_w3), intent(inout) :: kl
real(kind=r_def), dimension(undf_wt), intent(in) :: height_wth
@@ -102,13 +99,10 @@ subroutine leonard_term_kl_code( nlayers, &
! If the full stencil isn't available, we must be at the domain edge.
! Simply set the increment to 0 for now, and exit the routine.
if (map_wt_stencil_size < 5_i_def) then
- do k = 0, bl_levels
- kl(map_w3(1) + k) = leonard_kl
- end do
return
end if
- ! Leonard term parameter is the min of the input leonard_kl
+ ! Leonard term parameter is the min of the input kl
! and the max stable value 6 * dz / ( dt * dw )
! For dw we use the maximum horizontal finite difference that
! contributes to the flux at each w3 point.
@@ -119,7 +113,7 @@ subroutine leonard_term_kl_code( nlayers, &
do k = 1, bl_levels - 1
kp = k + 1
- kl(map_w3(1) + k) = MIN( leonard_kl, &
+ kl(map_w3(1) + k) = MIN( kl(map_w3(1) + k), &
6.0_r_def * ( height_wth(map_wt(1) + kp) - &
height_wth(map_wt(1) + k) ) &
/ (dt * MAX( &
@@ -141,7 +135,7 @@ subroutine leonard_term_kl_code( nlayers, &
velocity_w2v(map_wt_stencil(1,1) + k) ), &
ABS( velocity_w2v(map_wt_stencil(1,5) + k) - &
velocity_w2v(map_wt_stencil(1,1) + k) ), &
- EPSILON( leonard_kl ) &
+ EPSILON( kl(map_w3(1) + k) ) &
) ) )
end do
diff --git a/science/gungho/source/kernel/diffusion/leonard_term_th_kernel_mod.F90 b/science/gungho/source/kernel/diffusion/leonard_term_th_kernel_mod.F90
index a420617ede..87c156ab46 100644
--- a/science/gungho/source/kernel/diffusion/leonard_term_th_kernel_mod.F90
+++ b/science/gungho/source/kernel/diffusion/leonard_term_th_kernel_mod.F90
@@ -17,7 +17,6 @@ module leonard_term_th_kernel_mod
use constants_mod, only : r_def, i_def
use fs_continuity_mod, only : Wtheta, W3
use kernel_mod, only : kernel_type
- use mixing_config_mod, only : leonard_kl
implicit none
diff --git a/science/gungho/source/kernel/diffusion/leonard_term_u_kernel_mod.F90 b/science/gungho/source/kernel/diffusion/leonard_term_u_kernel_mod.F90
index 290dc7c810..dee308938b 100644
--- a/science/gungho/source/kernel/diffusion/leonard_term_u_kernel_mod.F90
+++ b/science/gungho/source/kernel/diffusion/leonard_term_u_kernel_mod.F90
@@ -10,13 +10,15 @@
module leonard_term_u_kernel_mod
use argument_mod, only : arg_type, &
- GH_FIELD, GH_SCALAR, GH_REAL, &
- GH_READ, GH_WRITE, GH_WRITE, &
- CELL_COLUMN, STENCIL, REGION, &
+ GH_FIELD, GH_SCALAR, &
+ GH_INTEGER, GH_REAL, &
+ GH_READ, GH_WRITE, &
+ CELL_COLUMN, STENCIL, &
+ REGION, CROSS, &
ANY_DISCONTINUOUS_SPACE_9, &
ANY_DISCONTINUOUS_SPACE_3, &
ANY_DISCONTINUOUS_SPACE_2, &
- GH_INTEGER
+ ANY_DISCONTINUOUS_SPACE_1
use constants_mod, only : r_def, i_def
use fs_continuity_mod, only : Wtheta, W2, W1
use kernel_mod, only : kernel_type
@@ -40,6 +42,7 @@ module leonard_term_u_kernel_mod
STENCIL(REGION)), &
arg_type(GH_FIELD, GH_REAL, GH_READ, Wtheta, STENCIL(REGION)), &
arg_type(GH_FIELD, GH_REAL, GH_READ, Wtheta), &
+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1), &
arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_2), &
arg_type(GH_FIELD, GH_REAL, GH_READ, W1), &
arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_2), &
@@ -50,7 +53,6 @@ module leonard_term_u_kernel_mod
arg_type(GH_FIELD, GH_INTEGER, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &
arg_type(GH_SCALAR, GH_REAL, GH_READ), &
arg_type(GH_SCALAR, GH_REAL, GH_READ), &
- arg_type(GH_SCALAR, GH_REAL, GH_READ), &
arg_type(GH_SCALAR, GH_INTEGER, GH_READ) &
/)
integer :: operates_on = CELL_COLUMN
@@ -80,6 +82,7 @@ module leonard_term_u_kernel_mod
!> @param[in] map_wt_stencil Array holding the dofmap for the stencil at the
!> base of the column for Wtheta
!> @param[in] vel_w2v_inc Leonard term increment of velocity_w2v
+!> @param[in] klm_sh_w2h Leonard term coefficient for momentum
!> @param[in] dtrdz_fd2 Array of dt/(r*dz) at FD2 points
!> @param[in] height_w1 Height of w1 space levels above the surface
!> @param[in] height_w2 Height of w2 space levels above the surface
@@ -92,7 +95,6 @@ module leonard_term_u_kernel_mod
!> @param[in] face_selector_ns 2D field indicating which N/S faces to loop over
!! in this column
!> @param[in] planet_radius The planet radius
-!> @param[in] leonard_kl The user-specified Leonard term parameter
!> @param[in] dt The model timestep length
!> @param[in] bl_levels The number of boundary-layer levels
!> @param[in] ndf_w2 Number of degrees of freedom per cell for w2 space
@@ -101,6 +103,9 @@ module leonard_term_u_kernel_mod
!> @param[in] ndf_wt Number of degrees of freedom per cell for theta space
!> @param[in] undf_wt Number of unique degrees of freedom for theta space
!> @param[in] map_wt Cell dofmap for theta space
+!> @param[in] ndf_sh_w2h Number of dof per cell for shifted W2H space
+!> @param[in] undf_sh_w2h Number of unique dof for shifted W2H space
+!> @param[in] map_sh_w2h Cell dofmap for shifted W2H space
!> @param[in] ndf_w1 Number of degrees of freedom per cell for w1 space
!> @param[in] undf_w1 Number of unique degrees of freedom for w1 space
!> @param[in] map_w1 Cell dofmap for w1 space
@@ -117,6 +122,7 @@ subroutine leonard_term_u_code( nlayers, &
velocity_w2v, &
map_wt_stencil_size, map_wt_stencil, &
vel_w2v_inc, &
+ klm_sh_w2h, &
dtrdz_fd2, &
height_w1, &
height_w2, &
@@ -125,10 +131,10 @@ subroutine leonard_term_u_code( nlayers, &
map_pid_stencil_size, map_pid_stencil, &
face_selector_ew, face_selector_ns, &
planet_radius, &
- leonard_kl, &
dt, bl_levels, &
ndf_w2, undf_w2, map_w2, &
ndf_wt, undf_wt, map_wt, &
+ ndf_sh_w2h, undf_sh_w2h, map_sh_w2h, &
ndf_w1, undf_w1, map_w1, &
ndf_pid, undf_pid, map_pid, &
ndf_w3_2d, undf_w3_2d, map_w3_2d &
@@ -141,6 +147,7 @@ subroutine leonard_term_u_code( nlayers, &
integer(kind=i_def), intent(in) :: ndf_w1, undf_w1
integer(kind=i_def), intent(in) :: ndf_w2, undf_w2
integer(kind=i_def), intent(in) :: ndf_wt, undf_wt
+ integer(kind=i_def), intent(in) :: ndf_sh_w2h, undf_sh_w2h
integer(kind=i_def), intent(in) :: ndf_pid, undf_pid
integer(kind=i_def), intent(in) :: ndf_w3_2d, undf_w3_2d
integer(kind=i_def), intent(in) :: map_w2_stencil_size
@@ -152,6 +159,7 @@ subroutine leonard_term_u_code( nlayers, &
integer(kind=i_def), dimension(ndf_w1), intent(in) :: map_w1
integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2
integer(kind=i_def), dimension(ndf_wt), intent(in) :: map_wt
+ integer(kind=i_def), dimension(ndf_sh_w2h), intent(in) :: map_sh_w2h
integer(kind=i_def), dimension(ndf_pid), intent(in) :: map_pid
integer(kind=i_def), dimension(ndf_w3_2d), intent(in) :: map_w3_2d
@@ -159,13 +167,13 @@ subroutine leonard_term_u_code( nlayers, &
real(kind=r_def), dimension(undf_w2), intent(in) :: u_n
real(kind=r_def), dimension(undf_wt), intent(in) :: velocity_w2v
real(kind=r_def), dimension(undf_wt), intent(in) :: vel_w2v_inc
+ real(kind=r_def), dimension(undf_sh_w2h), intent(in) :: klm_sh_w2h
real(kind=r_def), dimension(undf_w2), intent(in) :: dtrdz_fd2
real(kind=r_def), dimension(undf_w1), intent(in) :: height_w1
real(kind=r_def), dimension(undf_w2), intent(in) :: height_w2
real(kind=r_def), dimension(undf_w2), intent(in) :: wetrho_in_w2
real(kind=r_def), dimension(undf_pid), intent(in) :: panel_id
real(kind=r_def), intent(in) :: planet_radius
- real(kind=r_def), intent(in) :: leonard_kl
real(kind=r_def), intent(in) :: dt
integer(kind=i_def), dimension(undf_w3_2d), intent(in) :: face_selector_ew
@@ -180,7 +188,7 @@ subroutine leonard_term_u_code( nlayers, &
! density at FD1 points
real(kind=r_def) :: rho_fd1
! Leonard term parameter at FD1 points
- real(kind=r_def), dimension(1:bl_levels,4) :: kl_fd1
+ real(kind=r_def), dimension(1:bl_levels) :: kl_fd1
! Leonard term vertical flux at FD1 points
real(kind=r_def), dimension(0:bl_levels,4) :: flux
! density * r^2 at FD1
@@ -348,7 +356,7 @@ subroutine leonard_term_u_code( nlayers, &
! Calculate kl at FD1 points,
! accounting for stability limit
do k = 1, bl_levels
- kl_fd1(k,df) = MIN( leonard_kl, &
+ kl_fd1(k) = MIN( klm_sh_w2h(map_sh_w2h(df) + k), &
6.0_r_def * ( height_w2(map_w2(df) + k) - &
height_w2(map_w2(df) + k-1) ) &
/ (dt * MAX( &
@@ -367,7 +375,7 @@ subroutine leonard_term_u_code( nlayers, &
velocity_w2v(true_wt_stencil(1,1) + k) ), &
ABS( velocity_w2v(true_wt_stencil(1,df2p1) + k) - &
velocity_w2v(true_wt_stencil(1,df2) + k) ), &
- EPSILON( leonard_kl ) &
+ EPSILON( klm_sh_w2h(map_sh_w2h(df) + k) ) &
) ) )
end do
@@ -408,7 +416,7 @@ subroutine leonard_term_u_code( nlayers, &
do k = 1, bl_levels
km = k - 1
- flux(k,df) = ( kl_fd1(k,df) / 12.0_r_def ) &
+ flux(k,df) = ( kl_fd1(k) / 12.0_r_def ) &
! 8 terms contribute to each direction, so scale by 1/8
* ( 1.0_r_def / 8.0_r_def ) * ( &
! Terms from gradient normal to face...
diff --git a/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
index 5e50b6c3cc..222c69b074 100644
--- a/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
@@ -52,6 +52,7 @@ contains
mix_factor = 0.2_r_def, &
method_1a = method_1a_3d_smag, &
method_9c = method_9c_3d_smag, &
+ leonard_tke = .false., &
smag_l_calc = smag_l_calc_UseDx, &
leonard_term = .false., &
leonard_kl = 4.0_r_def, &
@@ -155,7 +156,7 @@ contains
allocate(w(undf_wt))
allocate(kl(undf_w3))
w(:) = 1.0_r_def
- kl(:) = 0.0_r_def
+ kl(:) = leonard_kl
w(stencil_map_wt(1,1,cell-1)+k) = 3.0_r_def
@@ -165,7 +166,6 @@ contains
w, &
5, stencil_map_wt(:,:,cell), &
height_wth, &
- leonard_kl, &
dt, nlayers, &
ndf_w3, undf_w3, map_w3(:,cell), &
ndf_wt, undf_wt, map_wt(:,cell) &
diff --git a/science/gungho/unit-test/kernel/diffusion/leonard_term_th_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/leonard_term_th_kernel_mod_test.pf
index 891ed6c16f..8a128c7a11 100644
--- a/science/gungho/unit-test/kernel/diffusion/leonard_term_th_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/leonard_term_th_kernel_mod_test.pf
@@ -93,7 +93,7 @@ contains
real(r_def), allocatable :: w(:)
real(r_def), allocatable :: dtrdz(:)
real(r_def), allocatable :: rho(:)
- real(r_def), allocatable :: kl(:)
+ real(r_def), allocatable :: klh(:)
real(r_def), allocatable :: height_w3(:)
real(r_def), parameter :: planet_radius = 105_r_def
@@ -140,14 +140,14 @@ contains
allocate(w(undf_wt))
allocate(dtrdz(undf_wt))
allocate(rho(undf_w3))
- allocate(kl(undf_w3))
+ allocate(klh(undf_w3))
theta_inc(:) = 0.0_r_def
theta(:) = 300.0_r_def
w(:) = 1.0_r_def
dtrdz(:) = 0.001_r_def
rho(:) = 1.0_r_def
- kl(:) = 1.0_r_def
+ klh(:) = 1.0_r_def
cell = 5
k = 1
@@ -162,7 +162,7 @@ contains
w, &
5, stencil_map_wt(:,:,cell), &
dtrdz, &
- kl, &
+ klh, &
rho, &
height_w3, &
planet_radius, nlayers, &
@@ -182,7 +182,7 @@ contains
deallocate(w)
deallocate(dtrdz)
deallocate(rho)
- deallocate(kl)
+ deallocate(klh)
end subroutine test_all
diff --git a/science/gungho/unit-test/kernel/diffusion/leonard_term_u_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/leonard_term_u_kernel_mod_test.pf
index ed473de0a8..125f2ec154 100644
--- a/science/gungho/unit-test/kernel/diffusion/leonard_term_u_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/leonard_term_u_kernel_mod_test.pf
@@ -11,11 +11,13 @@ module leonard_term_u_kernel_mod_test
use get_unit_test_m3x3_q3x3x3_sizes_mod, only : get_w2_m3x3_q3x3x3_size, &
get_w1_m3x3_q3x3x3_size, &
get_wtheta_m3x3_q3x3x3_size, &
- get_w3_m3x3_q3x3x3_size
+ get_w3_m3x3_q3x3x3_size, &
+ get_w2h_m3x3_q3x3x3_size
use get_unit_test_m3x3_dofmap_mod, only : get_w2_m3x3_dofmap, &
get_w1_m3x3_dofmap, &
get_wtheta_m3x3_dofmap, &
get_w3_m3x3_dofmap, &
+ get_w2h_m3x3_dofmap, &
get_m3x3_stencil_dofmap_region
use funit
@@ -65,7 +67,7 @@ contains
integer(i_def) :: nlayers, ncells
integer(i_def) :: ndf_w2, undf_w2, ndf_wt, undf_wt, ndf_w1, undf_w1, &
- ndf_pid, undf_pid
+ ndf_sh_w2h, undf_sh_w2h, ndf_pid, undf_pid
integer(i_def) :: dim_space, dim_space_diff
integer(i_def) :: nqp_h, nqp_v
@@ -73,6 +75,7 @@ contains
integer(i_def), allocatable :: true_map_w2(:,:)
integer(i_def), allocatable :: map_wt(:,:)
integer(i_def), allocatable :: map_w1(:,:)
+ integer(i_def), allocatable :: map_sh_w2h(:,:)
integer(i_def), allocatable :: map_pid(:,:)
integer(i_def), allocatable :: stencil_map_w2(:,:,:)
integer(i_def), allocatable :: true_stencil_map_w2(:,:,:)
@@ -85,6 +88,7 @@ contains
real(r_def), allocatable :: u(:)
real(r_def), allocatable :: w(:)
real(r_def), allocatable :: w_inc(:)
+ real(r_def), allocatable :: klm_sh_w2h(:)
real(r_def), allocatable :: dtrdz(:)
real(r_def), allocatable :: rho(:)
real(r_def), allocatable :: height_w1(:)
@@ -114,6 +118,10 @@ contains
dim_space, dim_space_diff, &
nqp_h, nqp_v, &
nlayers )
+ call get_w2h_m3x3_q3x3x3_size( ndf_sh_w2h, undf_sh_w2h, ncells, &
+ dim_space, dim_space_diff, &
+ nqp_h, nqp_v, &
+ nlayers+1 )
call get_wtheta_m3x3_q3x3x3_size( ndf_wt, undf_wt, ncells, &
dim_space, dim_space_diff, &
nqp_h, nqp_v, &
@@ -133,6 +141,7 @@ contains
call get_w1_m3x3_dofmap(map_w1)
call get_w3_m3x3_dofmap(map_pid,1)
call get_m3x3_stencil_dofmap_region(stencil_map_pid, map_pid)
+ call get_w2h_m3x3_dofmap(map_sh_w2h)
! Compute coordinates
allocate(height_w1(undf_w1))
@@ -159,6 +168,7 @@ contains
allocate(u(undf_w2))
allocate(w(undf_wt))
allocate(w_inc(undf_wt))
+ allocate(klm_sh_w2h(undf_sh_w2h))
allocate(dtrdz(undf_w2))
allocate(rho(undf_w2))
allocate(panel_id(undf_pid))
@@ -169,6 +179,7 @@ contains
u(:) = 1.0_r_def
w(:) = 1.0_r_def
w_inc(:) = 0.0_r_def
+ klm_sh_w2h(:) = leonard_kl
dtrdz(:) = 0.001_r_def
rho(:) = 1.0_r_def
panel_id = 2.0_r_def
@@ -196,29 +207,30 @@ contains
u(true_stencil_map_w2(4,5:7,cell)+2) = -1.0_r_def
! Call the kernel
- call leonard_term_u_code( nlayers, &
- u_inc, &
- u, &
- 9, stencil_map_w2(:,:,cell), &
- w, &
- 9, stencil_map_wt(:,:,cell), &
- w_inc, &
- dtrdz, &
- height_w1, &
- height_w2, &
- rho, &
- panel_id, &
- 9, stencil_map_pid(:,:,cell), &
- face_selector_ew, &
- face_selector_ns, &
- planet_radius, &
- leonard_kl, &
- dt, nlayers, &
- ndf_w2, undf_w2, map_w2(:,cell), &
- ndf_wt, undf_wt, map_wt(:,cell), &
- ndf_w1, undf_w1, map_w1(:,cell), &
- ndf_pid, undf_pid, map_pid(:,cell), &
- ndf_pid, undf_pid, map_pid(:,cell) &
+ call leonard_term_u_code( nlayers, &
+ u_inc, &
+ u, &
+ 9, stencil_map_w2(:,:,cell), &
+ w, &
+ 9, stencil_map_wt(:,:,cell), &
+ w_inc, &
+ klm_sh_w2h, &
+ dtrdz, &
+ height_w1, &
+ height_w2, &
+ rho, &
+ panel_id, &
+ 9, stencil_map_pid(:,:,cell), &
+ face_selector_ew, &
+ face_selector_ns, &
+ planet_radius, &
+ dt, nlayers, &
+ ndf_w2, undf_w2, map_w2(:,cell), &
+ ndf_wt, undf_wt, map_wt(:,cell), &
+ ndf_sh_w2h, undf_sh_w2h, map_sh_w2h(:,cell), &
+ ndf_w1, undf_w1, map_w1(:,cell), &
+ ndf_pid, undf_pid, map_pid(:,cell), &
+ ndf_pid, undf_pid, map_pid(:,cell) &
)
answer = 0.1152_r_def
@@ -230,6 +242,7 @@ contains
deallocate(true_stencil_map_w2)
deallocate(map_wt)
deallocate(stencil_map_wt)
+ deallocate(map_sh_w2h)
deallocate(map_w1)
deallocate(height_w1)
deallocate(height_w2)
@@ -237,6 +250,7 @@ contains
deallocate(u_inc)
deallocate(w)
deallocate(w_inc)
+ deallocate(klm_sh_w2h)
deallocate(dtrdz)
deallocate(rho)
deallocate(panel_id)
diff --git a/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
index 53403c82e2..9cdf8ddbdc 100644
--- a/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
@@ -54,6 +54,7 @@ contains
mix_factor = 0.2_r_def, &
method_1a = method_1a_3d_smag, &
method_9c = method_9c_3d_smag, &
+ leonard_tke = .false., &
smag_l_calc = smag_l_calc_UseDx, &
leonard_term = .false., &
leonard_kl = 1.0_r_def, &
diff --git a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90 b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
index ed5f678d67..96c1ce0f54 100644
--- a/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
+++ b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90
@@ -57,7 +57,7 @@ subroutine bdy_expl2_1a ( &
! OUT data required for tracer mixing :
kent, we_lim, t_frac, zrzi, kent_dsc, we_lim_dsc, t_frac_dsc, zrzi_dsc, &
! OUT data required elsewhere in UM system :
- zhsc,ntdsc,nbdsc,wstar,wthvs,uw0,vw0 &
+ zhsc,ntdsc,nbdsc,wstar,wthvs,uw0,vw0,leonard_kl_tke &
)
use atm_fields_bounds_mod, only: pdims, tdims, tdims_l, &
@@ -76,6 +76,7 @@ subroutine bdy_expl2_1a ( &
use turb_diff_mod, only: &
l_subfilter_vert, l_subfilter_horiz, mix_factor, &
turb_startlev_vert, turb_endlev_vert
+use umPrintMgr, only: umPrint, umMessage
use water_constants_mod, only: lc
use parkind1, only: jprb, jpim
@@ -116,24 +117,24 @@ subroutine bdy_expl2_1a ( &
! IN RDZ(,1) is the reciprocal of
! the height of level 1, i.e. of
! the middle of layer 1. For
- ! K > 1, RDZ(,K) is the
+ ! k > 1, RDZ(,k) is the
! reciprocal of the vertical
- ! distance from level K-1 to
- ! level K.
+ ! distance from level k-1 to
+ ! level k.
rdz_charney_grid(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! IN RDZ(,1) is the reciprocal of
! the height of level 1,
! i.e. of the middle of layer 1
- ! For K > 1, RDZ(,K) is the
+ ! For k > 1, RDZ(,k) is the
! reciprocal of the vertical
- ! distance from level K-1 to
- ! level K.
+ ! distance from level k-1 to
+ ! level k.
z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
- ! IN Z_tq(*,K) is height of full
+ ! IN Z_tq(*,k) is height of full
! level k.
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels+1), &
- ! OUT Z_uv(*,K) is height of half
+ ! OUT Z_uv(*,k) is height of half
! level k-1/2.
u_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
! IN U on P-grid.
@@ -155,7 +156,7 @@ subroutine bdy_expl2_1a ( &
! IN Land fraction on all tiles
p_rho_levs(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end, &
pdims_s%k_start:bl_levels+1), &
- ! IN p_rho_levs(*,K) is pressure at half
+ ! IN p_rho_levs(*,k) is pressure at half
! level k-1/2.
pstar(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
! IN Surface pressure (Pascals).
@@ -235,8 +236,8 @@ subroutine bdy_expl2_1a ( &
! FQW(,1) is total water flux
! from surface, 'E'.
ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
- ! INOUT FTL(,K) contains net turbulent
-! sensible heat flux into layer K
+ ! INOUT FTL(,k) contains net turbulent
+! sensible heat flux into layer k
! from below; so FTL(,1) is the
! surface sensible heat, H. (W/m2)
rhokh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels)
@@ -283,11 +284,11 @@ subroutine bdy_expl2_1a ( &
rhogamu(pdims_s%i_start:pdims_s%i_end, &
pdims_s%j_start:pdims_s%j_end,2:bl_levels), &
! Counter gradient terms for u
- ! defined at theta level K-1
+ ! defined at theta level k-1
rhogamv(pdims_s%i_start:pdims_s%i_end, &
pdims_s%j_start:pdims_s%j_end,2:bl_levels), &
! Counter gradient terms for v
- ! defined at theta level K-1
+ ! defined at theta level k-1
tau_fd_x(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end, &
bl_levels), &
tau_fd_y(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end, &
@@ -372,6 +373,10 @@ subroutine bdy_expl2_1a ( &
vw0(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
! OUT V-component of surface wind stress
! on P-grid
+real(kind=r_bl), intent(out) :: &
+ leonard_kl_tke( tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, &
+ 1:bl_levels, 2 )
!-----------------------------------------------------------------------
! Symbolic constants (parameters) reqd in top-level routine :-
@@ -454,7 +459,7 @@ subroutine bdy_expl2_1a ( &
dtldz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! TL+gz/cp gradient between
- ! levels K and K-1
+ ! levels k and k-1
dqwdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! QW gradient between
@@ -462,20 +467,20 @@ subroutine bdy_expl2_1a ( &
2:bl_levels), &
! gradient of TL across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dqwdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! gradient of QW across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Gradient of u at theta levels.
- !(:,:,K) repserents the value on theta level K-1
+ !(:,:,k) represents the value on theta level k-1
dvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels)
! Gradient of v at theta levels.
- !(:,:,K) repserents the value on theta level K-1
+ !(:,:,k) repserents the value on theta level k-1
integer :: &
ntml_local(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end), &
@@ -681,7 +686,7 @@ subroutine bdy_expl2_1a ( &
! Calculate `buoyancy' gradient, DBDZ, on theta-levels
-! NOTE: DBDZ(K) is on theta-level K-1
+! NOTE: DBDZ(k) is on theta-level k-1
do k = 3, bl_levels
do j = pdims%j_start, pdims%j_end
do i = pdims%i_start, pdims%i_end
@@ -820,8 +825,7 @@ subroutine bdy_expl2_1a ( &
if (bdy_tke == mymodel25 .or. bdy_tke == mymodel3) then
call mym_ctl( &
!in levels/switches
- bl_levels, bdy_tke, &
- BL_diag, &
+ bl_levels, bdy_tke, BL_diag, &
!in fields
z_uv,z_tq, u_p, v_p, qw, tl, t, q, qcl, qcf, bq_gb, bt_gb, &
rho_mix, rho_wet_tq, fqw, ftl, &
@@ -830,7 +834,7 @@ subroutine bdy_expl2_1a ( &
! inout
e_trb, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh, zhpar_shcu, &
! out
- visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq)
+ visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq, leonard_kl_tke)
else if (bdy_tke == deardorff) then
call ddf_ctl( &
! IN levels/switches
@@ -1137,6 +1141,9 @@ subroutine bdy_expl2_1a ( &
!-----------------------------------------------------------------------
! Calculation of explicit fluxes of T,Q
!-----------------------------------------------------------------------
+write(umMessage,*)'Entering mym_ex_flux_tq.'
+call umPrint(umMessage)
+
call mym_ex_flux_tq( &
bl_levels, &
tl, qw, rhokh, rhogamt, rhogamq, rdz_charney_grid, &
diff --git a/science/physics_schemes/source/boundary_layer/mym_ctl.F90 b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
index 8203f91084..e40294c96c 100644
--- a/science/physics_schemes/source/boundary_layer/mym_ctl.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_ctl.F90
@@ -52,7 +52,7 @@ subroutine mym_ctl( &
! INOUT fields
e_trb, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh, zhpar_shcu, &
! OUT fields
- visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq)
+ visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq, leonard_kl_tke)
use atm_fields_bounds_mod, only: tdims, pdims, tdims_l, tdims_s
use bl_diags_mod, only: strnewbldiag
@@ -69,6 +69,7 @@ subroutine mym_ctl( &
use mym_initialize_mod, only: mym_initialize
use mym_shcu_buoy_mod, only: mym_shcu_buoy
use mym_turbulence_mod, only: mym_turbulence
+
implicit none
! Intent In Variables
@@ -84,10 +85,10 @@ subroutine mym_ctl( &
real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
- ! Z_UV(*,K) is height of u level k
+ ! Z_UV(*,k) is height of u level k
z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
- ! Z_TQ(*,K) is height of theta level k.
+ ! Z_TQ(*,k) is height of theta level k.
u_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
! U on P-grid.
v_p(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end,bl_levels), &
@@ -131,8 +132,8 @@ subroutine mym_ctl( &
! from surface, 'E'.
! defined on rho levels
ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
- ! FTL(,K) contains net turbulent
- ! sensible heat flux into layer K
+ ! FTL(,k) contains net turbulent
+ ! sensible heat flux into layer k
! from below; so FTL(,1) is the
! surface sensible heat, H. (W/m2)
! defined on rho levels
@@ -140,29 +141,29 @@ subroutine mym_ctl( &
2:bl_levels), &
! gradient of TL across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dqwdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! gradient of QW across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Gradient of u at theta levels.
- !(:,:,K) repserents the value on theta level K-1
+ !(:,:,k) represents the value on theta level k-1
dvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Gradient of v at theta levels.
- !(:,:,K) repserents the value on theta level K-1
+ !(:,:,k) represents the value on theta level k-1
dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Buoyancy gradient across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Modulus of wind shear at theta levels.
- ! (:,:,K) represents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! IN delta_x used by Smagorinsky
p_theta_levels(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
@@ -183,32 +184,38 @@ subroutine mym_ctl( &
real(kind=r_bl), intent(in out) :: &
e_trb(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
- ! TKE defined on theta levels K-1
+ ! TKE defined on theta levels k-1
tsq_trb(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end,bl_levels), &
! Self covariance of liquid potential temperature
- ! (thetal'**2) defined on theta levels K-1
+ ! (thetal'**2) defined on theta levels k-1
qsq_trb(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end,bl_levels), &
! Self covariance of total water
- ! (qw'**2) defined on theta levels K-1
+ ! (qw'**2) defined on theta levels k-1
cov_trb(tdims%i_start:tdims%i_end, &
tdims%j_start:tdims%j_end,bl_levels), &
! Correlation between thetal and qw
- ! (thetal'qw') defined on theta levels K-1
+ ! (thetal'qw') defined on theta levels k-1
rhokm(tdims_s%i_start:tdims_s%i_end, &
tdims_s%j_start:tdims_s%j_end,bl_levels), &
! Exchange coeffs for momentum
- ! between K and K-1 on rho levels.
- ! i.e. the coeffs are defined on theta level K-1.
+ ! between k and k-1 on rho levels.
+ ! i.e. the coeffs are defined on theta level k-1.
rhokh(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels), &
! Exchange coeffs for scalars
- ! between K and K-1 on theta levels.
+ ! between k and k-1 on theta levels.
! i.e. the coeffs are defined on rho levels
zhpar_shcu(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end)
! Height of mixed layer used to evaluate
! the non-gradient buoyancy flux
+! Note e_trb (etc.) is created with dimensions
+! (tdims%i_start:tdims%i_end, tdims%j_start:tdims%j_end,
+! tdims%k_start:tdims%k_end)
+! in set_atm_fields, and tdims%k_start:tdims%k_end = 0:model_levels
+! However, it is declared 0:bl_levels in atmos_physics2 and passed to
+! ni_bl_ctl thence here.
! Declaration of BL diagnostics.
type (strnewbldiag), intent(in out) :: BL_diag
@@ -220,11 +227,11 @@ subroutine mym_ctl( &
rhogamu(tdims_s%i_start:tdims_s%i_end, &
tdims_s%j_start:tdims_s%j_end,2:bl_levels), &
! Counter gradient terms for TAUX
- ! defined at theta level K-1
+ ! defined at theta level k-1
rhogamv(tdims_s%i_start:tdims_s%i_end, &
tdims_s%j_start:tdims_s%j_end,2:bl_levels), &
! Counter gradient terms for TAUY
- ! defined at theta level K-1
+ ! defined at theta level k-1
rhogamt(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
2:bl_levels), &
! Counter gradient terms for FTL
@@ -233,6 +240,10 @@ subroutine mym_ctl( &
2:bl_levels)
! Counter gradient terms for FQW
! defined at rho levels
+real(kind=r_bl), intent(out) :: &
+ leonard_kl_tke( tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, &
+ 1:bl_levels, 2 )
! Local Variables
integer :: &
@@ -262,54 +273,54 @@ subroutine mym_ctl( &
! reciprocal of Monin-Obukhov length
qke(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
bl_levels), &
- ! twice of TKE (denoted to q**2) on theta level K-1
+ ! twice of TKE (denoted to q**2) on theta level k-1
dbdz_l(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:tke_levels), &
! Buoyancy gradient across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
vt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! Buoyancy parameter for FTL (excluding g/thetav)
- ! on theta level K-1
+ ! on theta level k-1
vq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! Buoyancy parameter for FQW (excluding g/thetav)
- ! on theta level K-1
+ ! on theta level k-1
tv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
- ! Virtual temperature on theta level K-1
+ ! Virtual temperature on theta level k-1
exner(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
- ! exner function on theta level K-1
+ ! exner function on theta level k-1
gtr(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
- ! G/thetav on theta level K-1
+ ! G/thetav on theta level k-1
rhokh_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
- ! exchange coeffs for scalars on theta level K-1
+ ! exchange coeffs for scalars on theta level k-1
rhogamt_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
- ! counter gradient term for FTL on theta level K-1
+ ! counter gradient term for FTL on theta level k-1
rhogamq_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
- ! counter gradient term for FQW on theta level K-1
+ ! counter gradient term for FQW on theta level k-1
q1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! normalized excessive water from the saturation
- ! on theta level K-1
+ ! on theta level k-1
cld(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! cloud fraction derived by the bi-normal
- ! distribution on theta level K-1
+ ! distribution on theta level k-1
ql(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! condensed liquid water derived by the bi-normal
- ! distribution on theta level K-1
+ ! distribution on theta level k-1
wb_ng(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! buoyancy flux related to the skewness
- ! on theta level K-1
+ ! on theta level k-1
frac_shcu(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels)
! cloud fraction corrected by shallow cumulus
- ! process on theta level K-1
+ ! process on theta level k-1
integer(kind=jpim), parameter :: zhook_in = 0
integer(kind=jpim), parameter :: zhook_out = 1
@@ -329,7 +340,6 @@ subroutine mym_ctl( &
if (l_first) then
call mym_const_set
-
! IF the first value of e_trb has been set to be missing by the
! reconfiguration, the initialization for the whole domain
! is essential.
@@ -506,9 +516,6 @@ subroutine mym_ctl( &
bl_levels, z_tq, r_mosurf, pmz, phh)
end if
- ! Calculate diffusion coefficients and counter gradient terms,
- ! and integrate the prognostic variables.
-
call mym_turbulence( &
! IN levels/switches
bl_levels, levflag, BL_diag, &
@@ -520,7 +527,7 @@ subroutine mym_ctl( &
! INOUT fields
qke, tsq_trb, qsq_trb, cov_trb, rhokm, rhokh_tq, &
! OUT fields
- rhogamu, rhogamv, rhogamt_tq, rhogamq_tq)
+ rhogamu, rhogamv, rhogamt_tq, rhogamq_tq, leonard_kl_tke)
if (l_3dtke) then
do k = 1, bl_levels-1
@@ -533,7 +540,7 @@ subroutine mym_ctl( &
end do
end if
- ! multiply the density
+! multiply the density
do k = 2, bl_levels
do j = tdims%j_start, tdims%j_end
do i = tdims%i_start, tdims%i_end
diff --git a/science/physics_schemes/source/boundary_layer/mym_length.F90 b/science/physics_schemes/source/boundary_layer/mym_length.F90
index e70b4e16d6..7c819eee37 100644
--- a/science/physics_schemes/source/boundary_layer/mym_length.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_length.F90
@@ -49,7 +49,7 @@ subroutine mym_length( &
use mym_const_mod, only: my_alpha4, one_third, elt_min, my_alpha1, &
my_alpha2, my_alpha3
-use mym_option_mod, only: tke_levels, my_z_limit_elb, l_3dtke
+use mym_option_mod, only: tke_levels, my_z_limit_elb, l_3dtke, l_use_l_sq
use parkind1, only: jprb, jpim
use planet_constants_mod, only: vkman
use yomhook, only: lhook, dr_hook
@@ -114,8 +114,11 @@ subroutine mym_length( &
! mixing length related to surface (L_S)
ell, &
! additional mixing length for 3DTKE scheme (L_L)
+ ellt, &
+ ! temp mixing length for 3DTKE scheme
zeta
! non-dimensional length (height over MO length)
+
real(kind=r_bl) :: &
elt(row_length, rows), &
! mixing length related to vertical distribution
@@ -177,6 +180,7 @@ subroutine mym_length( &
do k = 2, tke_levels
do j = 1, rows
do i = 1, row_length
+
if (dbdz(i, j, k) > 0.0) then
rbv = 1.0 / sqrt(dbdz(i, j, k))
elb = my_alpha2 * qkw(i, j, k) * rbv &
@@ -199,7 +203,12 @@ subroutine mym_length( &
end if
if (l_3dtke) then
ell = mix_factor * delta_smag(i,j)
- el(i, j, k) = elb / ( elb / elt(i, j) + elb / els + elb / ell + 1.0)
+ if (l_use_l_sq) then
+ ellt = elb / ( elb / elt(i, j) + elb / els + 1.0)
+ el(i, j, k) = sqrt(1.0/(1.0/(ellt*ellt) + 1.0/(ell*ell)))
+ else
+ el(i, j, k) = elb / ( elb / elt(i, j) + elb / els + elb / ell + 1.0)
+ end if
else
el(i, j, k) = elb / ( elb / elt(i, j) + elb / els + 1.0)
end if
diff --git a/science/physics_schemes/source/boundary_layer/mym_option_mod.F90 b/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
index 15b06961a3..a244d38bb7 100644
--- a/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_option_mod.F90
@@ -16,7 +16,7 @@
!---------------------------------------------------------------------
module mym_option_mod
-use missing_data_mod, only: rmdi, imdi
+use missing_data_mod, only: rmdi, imdi
use control_max_sizes, only: max_bl_levels
use um_types, only: r_bl
@@ -31,7 +31,9 @@ module mym_option_mod
integer :: bdy_tke = imdi ! suggested mymodel3
integer, parameter :: &
! the first order scheme
- deardorff = 1, &
+ deardorff = 0, &
+! the improved Mellor-Yamada level 2 model
+ mymodel2 = 1, &
! the improved Mellor-Yamada level 2.5 model
mymodel25 = 2, &
! the improved Mellor-Yamada level 3 model
@@ -121,6 +123,12 @@ module mym_option_mod
! with correction based on Sun and Chang (1986)
non_local_like_length = 3
+! 20 If TRUE, use coefficient calculated in mym_turbulence for Leonard term.
+logical :: l_leonard_tke = .false.
+
+! 21 If TRUE, use squared form of length-scale blending.
+logical :: l_use_l_sq = .false.
+
! Switch to choose solver of simultaneous equations
integer :: simeq_solver = 1
integer, parameter :: &
diff --git a/science/physics_schemes/source/boundary_layer/mym_turbulence.F90 b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
index d2a0bd3169..eecd25eb77 100644
--- a/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
+++ b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90
@@ -41,6 +41,7 @@ module mym_turbulence_mod
implicit none
character(len=*), parameter, private :: ModuleName = 'MYM_TURBULENCE_MOD'
+
contains
subroutine mym_turbulence( &
@@ -54,18 +55,19 @@ subroutine mym_turbulence( &
! INOUT fields
qke, tsq, qsq, cov, dfm, dfh, &
! OUT fields
- dfu_cg, dfv_cg, dft_cg, dfq_cg)
+ dfu_cg, dfv_cg, dft_cg, dfq_cg, leonard_kl_tke)
use atm_fields_bounds_mod, only: tdims, pdims, tdims_l, tdims_s
use bl_diags_mod, only: strnewbldiag
use conversions_mod, only: pi
-use mym_const_mod, only: e1c,e2c,e3c,e4c,e5c,a1,a2,c1,b2,qke_max, &
+use mym_const_mod, only: e1c,e2c,e3c,e4c,e5c,a1,a2,c1,c5,b2,qke_max, &
coef_trbvar_diff,coef_trbvar_diff_tke,two_thirds,a1_2, &
b1,one_third,cc3
use mym_option_mod, only: &
my_lowest_pd_surf, l_my_extra_level, my_z_extra_fact, &
l_my_prod_adj, my_prod_adj_fact, tke_levels, &
- l_my_lowest_pd_surf_tqc
+ l_my_lowest_pd_surf_tqc, l_leonard_tke, &
+ deardorff, mymodel2, mymodel25, mymodel3
use model_domain_mod, only: model_type, mt_single_column
@@ -77,6 +79,7 @@ subroutine mym_turbulence( &
use mym_level2_mod, only: mym_level2
use mym_update_covariance_mod, only: mym_update_covariance
use mym_update_fields_mod, only: mym_update_fields
+
implicit none
! Intent IN Variables
@@ -85,16 +88,18 @@ subroutine mym_turbulence( &
! Max. no. of "boundary" levels
levflag
! to indicate the level of the MY model
+ ! 0: Deardorff
+ ! 1: level 2
! 2: level 2.5
! 3: level 3
real(kind=r_bl), intent(in) :: &
z_uv(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end, &
bl_levels+1), &
- ! Z_UV(*,K) is height of u level k
+ ! Z_UV(*,k) is height of u level k
z_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
- ! Z_TQ(*,K) is height of theta level k.
+ ! Z_TQ(*,k) is height of theta level k.
vq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! A buoyancy param on theta level k-1
vt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
@@ -109,42 +114,42 @@ subroutine mym_turbulence( &
! from surface, 'E'.
! Defined on rho levels.
ftl(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,bl_levels), &
- ! FTL(,K) contains net turbulent
- ! sensible heat flux into layer K
+ ! FTL(,k) contains net turbulent
+ ! sensible heat flux into layer k
! from below; so FTL(,1) is the
! surface sensible heat, H. (W/m2)
! Defined on rho levels.
wb_ng(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! buoyancy flux related to the skewness
- ! on theta K-1 levels
+ ! on theta k-1 levels
dbdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:tke_levels), &
! Buoyancy gradient across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dtldz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! gradient of TL across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dqwdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! gradient of QW across layer
! interface interpolated to theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dvdzm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Modulus of wind shear at theta levels.
- ! (:,:,K) repserents the value on theta level K-1
+ ! (:,:,k) represents the value on theta level k-1
dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Gradient of u at theta levels.
- !(:,:,K) repserents the value on theta level K-1
+ !(:,:,k) represents the value on theta level k-1
dvdz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! Gradient of v at theta levels.
- !(:,:,K) repserents the value on theta level K-1
+ !(:,:,k) rerserents the value on theta level k-1
delta_smag(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
! IN delta_x used by Smagorinsky
r_mosurf(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), &
@@ -162,26 +167,26 @@ subroutine mym_turbulence( &
real(kind=r_bl), intent(in out) :: &
qke(tdims_l%i_start:tdims_l%i_end,tdims_l%j_start:tdims_l%j_end, &
bl_levels), &
- ! twice of TKE (denoted to q**2) on theta level K-1
+ ! twice of TKE (denoted to q**2) on theta level k-1
tsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! Self covariance of liquid potential temperature
- ! (thetal'**2) defined on theta levels K-1
+ ! (thetal'**2) defined on theta levels k-1
qsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! Self covariance of total water
- ! (qw'**2) defined on theta levels K-1
+ ! (qw'**2) defined on theta levels k-1
cov(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
bl_levels), &
! Correlation between thetal and qw
- ! (thetal'qw') defined on theta levels K-1
+ ! (thetal'qw') defined on theta levels k-1
dfm(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
bl_levels), &
! diffusion coefficient for momentum
- ! on theta level K-1
+ ! on theta level k-1
dfh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, bl_levels)
! diffusion coefficient for scalars
- ! on theta level K-1
+ ! on theta level k-1
! Declaration of BL diagnostics.
type (strnewbldiag), intent(in out) :: BL_diag
@@ -191,19 +196,23 @@ subroutine mym_turbulence( &
dfu_cg(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
2:bl_levels), &
! counter gradient term for u
- ! on theta level K-1
+ ! on theta level k-1
dfv_cg(tdims_s%i_start:tdims_s%i_end,tdims_s%j_start:tdims_s%j_end, &
2:bl_levels), &
! counter gradient term for v
- ! on theta level K-1
+ ! on theta level k-1
dft_cg(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels), &
! counter gradient term for TL
- ! on theta level K-1
+ ! on theta level k-1
dfq_cg(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
2:bl_levels)
! counter gradient term for QW
- ! on theta level K-1
+ ! on theta level k-1
+real(kind=r_bl), intent(out) :: &
+ leonard_kl_tke( tdims%i_start:tdims%i_end, &
+ tdims%j_start:tdims%j_end, &
+ 1:bl_levels, 2 )
! Local variables
! Scalar
@@ -262,31 +271,31 @@ subroutine mym_turbulence( &
real(kind=r_bl) :: &
gm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
- ! square of wind shear on theta level K-1
+ ! square of wind shear on theta level k-1
! (a denominator of gradient Richardson number)
gh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
- ! - buoyancy gradient on theta level K-1
+ ! - buoyancy gradient on theta level k-1
! (a numerator of gradient Richardson number)
sm(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! Non-dimensional diffusion coefficients for
! momentum derived by level 2 scheme
- ! defined on theta level K-1
+ ! defined on theta level k-1
sh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,tke_levels), &
! Non-dimensional diffusion coefficients for
! scalars derived by level 2 scheme
- ! define on theta level K-1
+ ! define on theta level k-1
qkw(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
- ! q=sqrt(qke) on theta level K-1
+ ! q=sqrt(qke) on theta level k-1
elsq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! square of mixing length
gmel(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
- ! GM times the mixing length
+ ! GM times the mixing length squared
ghel(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
- ! GH times the mixing length
+ ! GH times the mixing length squared
qdiv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, &
tke_levels), &
! factor for flux correction: sqrt(q3sq/q2sq)
@@ -441,6 +450,7 @@ subroutine mym_turbulence( &
integer(kind=jpim), parameter :: zhook_out = 1
real(kind=jprb) :: zhook_handle
+
if (lhook) call dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle)
if (l_my_extra_level) then
k_start = 1
@@ -448,13 +458,31 @@ subroutine mym_turbulence( &
k_start = 2
end if
+if (l_leonard_tke) then
+ do k = 1, bl_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ leonard_kl_tke(i,j,k,1) = 1.0
+ leonard_kl_tke(i,j,k,2) = 1.0
+ end do
+ end do
+ end do
+end if
+
call mym_level2( &
- bl_levels,dbdz, dvdzm,gm, gh, sm, sh)
+ bl_levels, dbdz, dvdzm, gm, gh, sm, sh)
call mym_length( &
tdims%i_end,tdims%j_end,tdims_l%halo_i,tdims_l%halo_j,bl_levels, &
qke, z_uv, z_tq, dbdz, delta_smag, r_mosurf, fb_surf, qkw, el)
+
+! This section calculates 'growing turbulence' correction
+! qdiv = 1-alpha in UMDP 25,
+! limited sm and sh
+! and diagnostic Cu, Cv Cw, relative u,v,w contributions to TKE at level 2.5.
+! Note, these appear not to be used apart from Cw which is used to bound C3sq.
+
do k = 2, tke_levels
do j = tdims%j_start, tdims%j_end
do i = tdims%i_start, tdims%i_end
@@ -466,13 +494,27 @@ subroutine mym_turbulence( &
ghel(i, j, k) = gh(i, j, k) * elsq(i, j, k)
! adjust SM and SH by SQRT(q3sq / q2sq)
+ ! qdiv is 1-alpha in Sec 2.7.2
+ ! q2sq is L2 (equilibrium) q2 (or u_t in PAC notation) so
+ ! check is q2 is less than equilibrium, i.e. growing.
if ( q3sq(i, j, k) < q2sq ) then
+ ! Growing turbulence corrections as per Sec. 2.7.2
qdiv(i, j, k) = sqrt(q3sq(i, j, k) / q2sq)
sm(i, j, k) = sm(i, j, k) * qdiv(i, j, k)
sh(i, j, k) = sh(i, j, k) * qdiv(i, j, k)
+ ! Constants needed for final SM, SH
+ ! Note gm is just shear and gh bouyancy gradient at this point, so
+ ! GM = gm L^2 / u_t^2 = gmel / u_t^2
+ ! Hence these are L3 computation if qkw prognostic.
+ ! e1 etc. have units of u_t^2 (i.e. q3sq)
+ ! reden (the denominator) units of (u_t^2)^2
+ ! sm, sh are properly dimensionless.
+ ! e1= u_t^2[ 1 - (1-alpha^2) 9.0 a1 a2 (1-c2) G_H
+ ! + (1-alpha^2) 6.0 a1^2 G_M ] = u_t^2 E1
e1 = q3sq(i, j, k) &
- e1c * ghel(i, j, k) * qdiv(i, j, k) ** 2
+ ! e2 = u_t^2[ 1 - (1-alpha^2) 9.0 a1 a2 (1-c2) G_H]
e2(i, j, k) = q3sq(i, j, k) &
- e2c * ghel(i, j, k) * qdiv(i, j, k) ** 2
e3 = e1 + e3c * ghel(i, j, k) * qdiv(i, j, k) ** 2
@@ -482,6 +524,7 @@ subroutine mym_turbulence( &
eden = max(eden, 1.0e-20)
reden = 1.0 / eden
else
+ ! Constants needed for final SM, SH
e1 = q3sq(i, j, k) - e1c * ghel(i, j, k)
e2(i, j, k) = q3sq(i, j, k) - e2c * ghel(i, j, k)
e3 = e1 + e3c * ghel(i, j, k)
@@ -489,8 +532,8 @@ subroutine mym_turbulence( &
eden = e2(i, j, k) * e4 + e3 * e5c * gmel(i, j, k)
eden = max(eden, 1.0e-20)
reden = 1.0 / eden
-
qdiv(i, j, k) = 1.0
+ ! L3 sm, sh if L3 qkw
sm(i, j, k) = q3sq(i, j, k) * a1 * (e3 - 3.0 * c1 *e4) &
* reden
sh(i, j, k) = q3sq(i, j, k) &
@@ -504,14 +547,32 @@ subroutine mym_turbulence( &
* (e4 - 0.5 * e4c * ghel(i, j, k) * qdiv(i, j, k) ** 2)
cw25(i, j, k) = cu25(i, j, k) * e1
cu25(i, j, k) = 1.0 - cv25(i, j, k) - cw25(i, j, k)
+
end do
end do
end do
+if (l_leonard_tke) then
+ do k = 2, tke_levels
+ do j = tdims%j_start, tdims%j_end
+ do i = tdims%i_start, tdims%i_end
+ e1 = (el(i, j, k) / delta_smag(i,j))**2
+ leonard_kl_tke(i,j,k,1) = 36.0 * a2 * e1 &
+ * (sm(i, j, k) + (1.0 - c5) * sh(i, j, k) )
+ leonard_kl_tke(i,j,k,2) = 72.0 * a1 * e1 * (1.0 - c5) * sm(i, j, k)
+ end do
+ end do
+ end do
+endif
+! This section primarily computes L3 non-local terms, gamma_theta and gamma_q
+! and corresponding perturbations to diffusion coefficients, dfm, dfh.
-if ( levflag == 3 ) then
+if ( levflag == mymodel3 ) then
do k = 2, tke_levels
do j = tdims%j_start, tdims%j_end
do i = tdims%i_start, tdims%i_end
+
+ ! At L2, L2.5 C_theta = b2 * sh
+
t2sq = qdiv(i, j, k) * b2 * elsq(i, j, k) &
* sh(i, j, k) * dtldz(i, j, k) ** 2
r2sq = qdiv(i, j, k) * b2 * elsq(i, j, k) &
@@ -524,19 +585,29 @@ subroutine mym_turbulence( &
c3sq = sign( min( abs(c3sq), sqrt(t3sq*r3sq) ), c3sq )
+ ! t2sq = vt + vq = _2.5
t2sq = vt(i, j, k) * t2sq + vq(i, j, k) * c2sq(i, j, k)
+ ! r2sq = vt + vq = _2.5
r2sq = vt(i, j, k) * c2sq(i, j, k) + vq(i, j, k) * r2sq
+ ! c2sq = vt + vq = _2.5
c2sq(i, j, k) = max(vt(i, j, k) * t2sq + vq(i, j, k) * r2sq, &
0.0)
+ ! t3sq = vt + vq =
t3sq = vt(i, j, k) * t3sq + vq(i, j, k) * c3sq
+ ! r3sq = vt + vq =
r3sq = vt(i, j, k) * c3sq + vq(i, j, k) * r3sq
+ ! c3sq = vt + vq =
c3sq = max(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
! Limitation on q, instead of L/q
+ ! Note, gh = -db/dz so this applies when db/dz > 0.
+ ! We could use -ghel here.
if ( q3sq(i, j, k) < -gh(i, j, k) * elsq(i, j, k)) then
q3sq(i, j, k) = -elsq(i, j, k) * gh(i, j, k)
end if
+ ! Some duplication from above.
+
! Limitation on c3sq (0.12 =< cw =< 0.76)
! e2 = q^2 * phi2'
e2(i, j, k) = q3sq(i, j, k) &
@@ -549,7 +620,7 @@ subroutine mym_turbulence( &
eden = e2(i, j, k) * e4 &
+ e3 *e5c*gmel(i, j, k) * qdiv(i, j, k)**2
- ! wden = numerator in the square braket in (10a) in NN2006
+ ! wden = numerator in the square bracket in (10a) in NN2006
! times (1-c3) * (g/thetav)**2 * GH
wden = cc3*gtr(i, j, k) **2 &
* elsq(i, j, k)**2 / elsq(i, j, k) &
@@ -570,22 +641,33 @@ subroutine mym_turbulence( &
end if
end if
+ ! e1 has dimensions q^2
e1 = e2(i, j, k) + e5c*gmel(i, j, k) * qdiv(i, j, k) ** 2
+ ! eden has dimensions q^4
eden = max( eden, 1.0e-20 )
+
+ ! reden has dimensions q^-4
reden = 1.0 / eden
- e6c = 3.0 * a2 *cc3 * gtr(i, j, k) &
- * elsq(i, j, k) / elsq(i, j, k)
+ ! Surely elsq cancels?
+! e6c = 3.0 * a2 *cc3 * gtr(i, j, k) &
+! * elsq(i, j, k) / elsq(i, j, k)
+ e6c = 3.0 * a2 *cc3 * gtr(i, j, k)
! Calculate each term in Gamma_theta
+ ! coef is E_H g/theta_0 /ut^2 in UMDP 25
coef = - e1 * qdiv(i, j, k) * e6c * reden
+ ! Hence all Gamma coefficients are actually ~ut^(-2)
gamt_tsq(i, j, k) = coef * vt(i, j, k)
gamt_cov(i, j, k) = coef * vq(i, j, k)
+ ! This appears to be missing a vt but its built into t2sq
+ ! -Gamma_t_2.5 or T_theta
gamt_res(i, j, k) = - coef * t2sq
! Calculate each term in Gamma_q
gamq_qsq(i, j, k) = coef * vq(i, j, k)
gamq_cov(i, j, k) = coef * vt(i, j, k)
+ ! -Gamma_q_2.5
gamq_res(i, j, k) = - coef * r2sq
! for Sm' and Sh'd(Theta_V)/dz
@@ -677,10 +759,12 @@ subroutine mym_turbulence( &
do k = 2, tke_levels
do j = tdims%j_start, tdims%j_end
do i = tdims%i_start, tdims%i_end
+ ! Non-local difference term:
+ ! E_H g/theta_0 /ut^2 ( - _2.5)
gamt(i, j, k) = gamt_tsq(i, j, k) * tsq(i, j, k) &
+ gamt_cov(i, j, k) * cov(i, j, k) &
+ gamt_res(i, j, k)
-
+ ! E_H g/theta_0 /ut^2 ( - _2.5)
gamq(i, j, k) = gamq_qsq(i, j, k) * qsq(i, j, k) &
+ gamq_cov(i, j, k) * cov(i, j, k) &
+ gamq_res(i, j, k)
@@ -693,6 +777,9 @@ subroutine mym_turbulence( &
end do
end if ! IF L_MY_PROD_ADJ
+ ! gamt appears to be E_H/q^2 g/theta_v (beta_t (thetaL'_3^2 - thetaL'_2^2)
+ ! +beta_q (theta_L'qt'_3 - thetaL'qt'_2))
+ ! as per UMDP 25 eq.2.257
! Calculate production terms
do k = 2, tke_levels
do j = tdims%j_start, tdims%j_end
@@ -701,32 +788,55 @@ subroutine mym_turbulence( &
elq = el(i, j, k) * qkw(i, j, k)
elh = elq * qdiv(i, j, k)
+ ! TKE production
+ ! Using Level 2.5 coefficients
+ ! wb_ng is buoyancy flux related to the skewness (input)
+ ! Level 2 production
pdk(i, j, k) = elq * (sm(i, j, k) * gm(i, j, k) &
+ sh(i, j, k) * gh(i, j, k)) &
+ wb_ng(i,j,k)
+ ! pdt = elh * (sh * dtldz - Gamma_t_2.5) * dtl/dz
+ ! = (P_theta^0 + R_theta)/2
pdt(i, j, k) = elh &
* (sh(i, j, k) * dtldz(i, j, k) + gamt_res(i, j, k)) &
* dtldz(i, j, k)
+ ! pdt_tsq = (1-alpha) L u_t E_H g/theta_0 beta_t / ut^2 dtl/dz
+ ! = T_theta/2
pdt_tsq(i, j, k) = elh * gamt_tsq(i, j, k) * dtldz(i, j, k)
+ ! pdt_cov = (1-alpha) L u_t E_H g/theta_0 beta_q / ut^2 dtl/dz = p^tc/2
pdt_cov(i, j, k) = elh * gamt_cov(i, j, k) * dtldz(i, j, k)
+
+ ! pdq = elh * (sh * dqt/dz - Gamma_q_2.5) * dqt/dz
+ ! = (P_q^0 + R_q)/2
pdq(i, j, k) = elh &
* (sh(i, j, k) * dqwdz(i, j, k) + gamq_res(i, j, k)) &
* dqwdz(i, j, k)
+ ! pdq_qsq = (1-alpha) L u_t E_H g/theta_0 beta_q /ut^2 dqt/dz = Q_q/2
pdq_qsq(i, j, k) = elh * gamq_qsq(i, j, k) * dqwdz(i, j, k)
+ ! pdq_cov = (1-alpha) L u_t E_H g/theta_0 beta_t /ut^2 dqt/dz = p^qc/2
pdq_cov(i, j, k) = elh * gamq_cov(i, j, k) * dqwdz(i, j, k)
+ ! pdc = 0.5 * elh * ((sh * dtldz - Gamma_t_2.5) * dqt/dz
+ ! + (sh * dqt/dz - Gamma_q_2.5) * dtl/dz)
+ ! = (P_c^0 + R_c)/2
pdc(i, j, k) = 0.5 * elh &
* ((sh(i, j, k) * dtldz(i, j, k) &
+ gamt_res(i, j, k)) * dqwdz(i, j, k) &
+ (sh(i, j, k) * dqwdz(i, j, k) &
+ gamq_res(i, j, k)) * dtldz(i, j, k))
+ ! pdc_tsq = (1-alpha) L u_t E_H g/theta_0 beta_t / ut^2 * dqt/dz
+ ! = p^ct/2
pdc_tsq(i, j, k) = elh &
* gamt_tsq(i, j, k) * dqwdz(i, j, k) * 0.5
+ ! pdc_qsq = (1-alpha) L u_t E_H g/theta_0 beta_q /ut^2 dtl/dz = p^cq/2
pdc_qsq(i, j, k) = elh &
* gamq_qsq(i, j, k) * dtldz(i, j, k) * 0.5
+ ! pdc_cov = 0.5 * (1-alpha) L u_t (
+ ! E_H g/theta_0 beta_q / ut^2 dqt/dz
+ ! + E_H g/theta_0 beta_t /ut^2 dtl/dz) = C_c/2
pdc_cov(i, j, k) = 0.5 * elh &
* (gamt_cov(i, j, k) * dqwdz(i, j, k) &
+ gamq_cov(i, j, k) * dtldz(i, j, k))
@@ -774,7 +884,7 @@ subroutine mym_turbulence( &
end do
end do
end do
-end if ! test if levflag == 3
+end if ! test if levflag == mymodel3
! Overwrite production terms by ones calculated with surface fluxes
if (my_lowest_pd_surf > 0) then
@@ -890,7 +1000,7 @@ subroutine mym_turbulence( &
end do
end if
-if (levflag == 3) then
+if (levflag == mymodel3) then
! Integrate the covariances
if (imp_mode == full_impl) then
@@ -992,7 +1102,7 @@ subroutine mym_turbulence( &
end if ! if imp_mode == FULL_IMPL
else ! level 2.5
! In level 2.5, tsq, qsq, cov are diagnosed assuming balance between
- ! prodcution and dissipation.
+ ! production and dissipation.
do k = k_start, tke_levels
do j = tdims%j_start, tdims%j_end
do i = tdims%i_start, tdims%i_end
@@ -1009,7 +1119,7 @@ subroutine mym_turbulence( &
end do
end if
-if (levflag >= 2) then
+if (levflag >= mymodel25) then
! predict qke
if (my_lowest_pd_surf > 0) then
k_start_cor = k_start + 1
@@ -1017,7 +1127,7 @@ subroutine mym_turbulence( &
k_start_cor = k_start
end if
- if (levflag == 3 .and. &
+ if (levflag == mymodel3 .and. &
(imp_mode == half_impl .or. imp_mode == full_impl)) then
! add correction terms evaluated with integrated tsq, qsq and cov
do k = k_start_cor, tke_levels
@@ -1035,6 +1145,8 @@ subroutine mym_turbulence( &
c3sq = max(vt(i, j, k) * t3sq + vq(i, j, k) * r3sq, 0.0)
elq = el(i, j, k) * qkw(i, j, k)
+ ! Non-local TKE production from shear.
+ ! S_M' G_M = E_M (L/u_t^2 g/theta)^2
smd(i, j, k) = smd_coef(i, j, k) * (c3sq - c2sq(i, j, k))
pdk(i, j, k) = pdk(i, j, k) + elq &
@@ -1053,7 +1165,7 @@ subroutine mym_turbulence( &
end do
end do
end do
- end if ! if test levflag == 3
+ end if ! if test levflag == mymodel3
do k = k_start, tke_levels
do j = tdims%j_start, tdims%j_end
@@ -1067,6 +1179,7 @@ subroutine mym_turbulence( &
call mym_update_fields( &
bl_levels, coef_trbvar_diff_tke, z_uv, z_tq, dfm, rp, bp, qke)
+
else
! level 2
! diagnose qke
@@ -1079,7 +1192,7 @@ subroutine mym_turbulence( &
end do
end do
end do
-end if ! test if levflag >= 2
+end if ! test if levflag >= mymodel25
do k = 1, tke_levels
do j = tdims%j_start, tdims%j_end
From 0e029dce2678109df98e9c05123fe461c8273502 Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Tue, 11 Aug 2026 17:50:41 +0100
Subject: [PATCH 7/9] Add new tasks in rose-stem suite
---
.../app/lfric_atm/opt/rose-app-3dte.conf | 223 ++++++++++++++++++
.../common/lfric_atm/tasks_lfric_atm.cylc | 13 +
.../site/meto/groups/groups_lfric_atm.cylc | 2 +
.../meto/lfric_atm/tasks_lfric_atm_ex1a.cylc | 6 +
4 files changed, 244 insertions(+)
create mode 100644 rose-stem/app/lfric_atm/opt/rose-app-3dte.conf
diff --git a/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf b/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf
new file mode 100644
index 0000000000..a772cd9686
--- /dev/null
+++ b/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf
@@ -0,0 +1,223 @@
+[file:iodef.xml]
+source=$ROSE_SUITE_DIR/app/lfric_atm/file/iodef_ral.xml
+
+[namelist:aerosol]
+activation_scheme='off'
+glomap_mode='climatology'
+!!horiz_d=2.25
+n_radaer_step=4
+prec_file='precalc/RADAER_pcalc_wvbnd-avg.ukca'
+!!us_am=1.45
+
+[namelist:blayer]
+!!a_ent_2=0.056
+!!a_ent_shr=1.6
+adv_turb_field=.true.
+bdy_tke='my3'
+bl_levels=69
+!!bl_mix_w=.false.
+!!bl_res_inv='cosine_inv_flux'
+bl_scheme='1a'
+!!dec_thres_cloud=0.1
+!!dec_thres_cu=0.05
+!!dyn_diag='zi_l_cu'
+!!dzrad_disc_opt='level_ntm1'
+!!entr_smooth_dec='on'
+free_atm_mix='free_trop_layer'
+!!interp_local='cf_dbdz'
+!!kprof_cu='buoy_integ'
+!!l_converge_ga=.false.
+!!l_use_sml_dsc_fixes=.false.
+local_above_tkelvs=.true.
+my_condense=.true.
+my_force_initialize=.false.
+my_ini_dbdz_min=1.0e-5
+my_lowest_pd_surf='bh91'
+my_prod_adj=.true.
+my_simeq_solver='gauss'
+!!near_neut_z_on_l=1.6
+!!new_kcloudtop=.true.
+!!ng_stress='BG97_limited'
+noice_in_turb=.true.
+!!num_sweeps_bflux=3
+p_unstable=0.5
+sbl_opt='sharpest'
+!!sc_diag_opt='orig'
+sg_orog_mixing='shear_plus_lambda'
+shcu_buoy=.false.
+tke_levels=-1
+use_l_sq=.true.
+
+[namelist:cloud]
+!!bm_ez_opt='subcrit'
+cld_fsd_hill=.false.
+cloud_horizontal_ice_fsd=0.0
+cloud_horizontal_liq_fsd=0.65
+!!dbsdtbs_turb_0=1.5E-4
+!!ez_max=400.0
+!!fsd_conv_const=3.5
+!!fsd_min_conv_frac=0.0
+!!fsd_nonconv_ice_const=0.75
+!!fsd_nonconv_liq_const=1.0
+!!ice_width=0.02
+!!l_bm_sigma_s_grad=.false.
+!!l_bm_tweaks=.false.
+!!l_ensure_max_in_cloud_pc2=.false.
+!!max_sigmas=3.0
+!!min_sigx_ft=0.0
+!!pc2_erosion_numerics='implicit'
+!!pc2_homog_g_method='cf'
+!!pc2_init_logic='original'
+!!pc2_init_method='bimodal'
+!!pc2_turb_horiz=.false.
+rh_crit=0.960,0.940,0.920,0.900,0.890,0.880,0.870,0.860,0.850,0.840,
+ =0.840,0.830,0.820,0.810,56*0.800
+rh_crit_opt='namelist'
+scheme='smith'
+subgrid_qv=.false.
+!!turb_var_fac_bm=1.0
+use_fsd_eff_res=.false.
+
+[namelist:convection]
+!!c_mass_sh=0.03
+!!cape_timescale=1800.0
+!!cca_md_scaling=0.8
+!!cpress_term=0.3
+!!cv_scheme='gregory_rowntree'
+!!efrac=1.0
+!!ent_fac_sh=1.0
+!!l_conv_prog_dq=.true.
+!!l_conv_prog_dtheta=.true.
+!!number_of_convection_substeps=2
+!!orig_mdet_fac=1.5
+!!prog_ent_grad=-1.1
+!!prog_ent_int=-2.9
+!!prog_ent_max=2.5
+!!prog_ent_min=0.3
+!!r_det=0.5
+!!thpixs_mid=0.5
+
+[namelist:files]
+!!orography_mean_ancil_path='orography/gmted_ramp2/qrparm.orog'
+!!soil_rough_ancil_path='soil_roughness/prigent12/qrparm.soil_roughness'
+
+[namelist:jules_nvegparm]
+albsnc_nvg_io=0.4,0.06,0.8,0.8
+albsnf_nvg_io=0.18,0.06,-1.0,0.75
+ch_nvg_io=2.8e5,4.18e6,0.0,0.0
+
+[namelist:jules_pftparm(brd_leaf)]
+albsnc_max_io=1.5e-1
+z0hm_pft_io=1.00
+
+[namelist:jules_pftparm(c3_grass)]
+z0hm_pft_io=0.022
+z0v_io=0.1
+
+[namelist:jules_pftparm(c4_grass)]
+z0hm_pft_io=0.022
+z0v_io=0.1
+
+[namelist:jules_pftparm(ndl_leaf)]
+albsnc_max_io=1.5e-1
+z0hm_pft_io=1.00
+
+[namelist:jules_pftparm(shrub)]
+z0hm_pft_io=0.025
+z0v_io=0.4
+
+[namelist:jules_sea_seaice]
+buddy_sea='Off'
+
+[namelist:jules_snow]
+rho_snow_fresh=170.0
+
+[namelist:jules_surface]
+l_vary_z0m_soil=.false.
+srf_ex_cnv_gust=.false.
+
+[namelist:microphysics]
+!!aut_qc=2.47
+!!c_r_correl=0.9
+casim_cdnc_opt='fixed'
+!!ci_input=14.3
+!!cic_input=1024.0
+droplet_tpr=.true.
+!!graupel_scheme='none'
+!!heavy_rain_evap_fac=0.0
+!!l_mcr_precfrac=.false.
+!!l_proc_fluxes=.false.
+microphysics_casim=.true.
+!!mp_dz_scal=2.0
+ndrop_surf=10.0e6
+!!orog_rain=.true.
+!!prog_tnuc=.true.
+!!shape_rime=.true.
+turb_gen_mixph=.false.
+z_surf=50.0
+
+[namelist:mixed_solver]
+reference_reset_time=$DT
+
+[namelist:mixing]
+conservative_diffusion=.true.
+density_weighted=.true.
+fullstress=.true.
+leonard_kl=1.0
+leonard_term=.true.
+leonard_tke=.true.
+max_diff_factor=1.0
+method_1a='3dte_mk1'
+method_9c='blend_1dbl_fa'
+mix_factor=0.2
+smag_l_calc='UseDx'
+smagorinsky=.true.
+
+[namelist:multigrid]
+n_postsmooth=6
+
+[!!namelist:orographic_drag]
+
+[namelist:orography]
+orog_init_option='start_dump'
+
+[namelist:physics]
+!!convection_placement='fast'
+electric_placement='slow'
+!!orographic_drag_placement='slow'
+smagorinsky_placement='fast'
+!!spectral_gwd_placement='slow'
+
+[namelist:radiation]
+cloud_entrapment='zero'
+cloud_inhomogeneity='scaling'
+cloud_overlap='maximum_random'
+cloud_representation='liquid_and_ice'
+!!cloud_vertical_decorr=10000.0
+i_cloud_ice_type_lw=13
+i_cloud_ice_type_lwinc=13
+i_cloud_ice_type_sw=13
+i_cloud_ice_type_swinc=13
+i_cloud_liq_type_lwinc=5
+i_cloud_liq_type_swinc=5
+l_inc_radstep=.true.
+liu_aparam=0.07
+liu_bparam=-0.14
+n_horiz_ang=16
+n_horiz_layer=1
+n_inc_radstep=5
+n_radstep=15
+scatter_method_lwinc='approx'
+spectral_file_lwinc='spec/sp_lw_cloud9'
+spectral_file_swinc='spec/sp_sw_cloud9'
+topography='horizon'
+
+[namelist:section_choice]
+convection='none'
+electric='um'
+methane_oxidation=.false.
+orographic_drag='none'
+spectral_gwd='none'
+
+[!!namelist:spectral_gwd]
+!!cgw_scale_factor=0.86
diff --git a/rose-stem/site/common/lfric_atm/tasks_lfric_atm.cylc b/rose-stem/site/common/lfric_atm/tasks_lfric_atm.cylc
index 3eaf65f31b..5821b3dda1 100644
--- a/rose-stem/site/common/lfric_atm/tasks_lfric_atm.cylc
+++ b/rose-stem/site/common/lfric_atm/tasks_lfric_atm.cylc
@@ -815,6 +815,19 @@
"plot_str": "plot_map.py -ral $NODAL_DATA_DIR/lfric_diagnostics.nc $PLOT_DIR",
}) %}
+{% elif task_ns.conf_name == "3dte-seuk_MG" %}
+
+ {% do task_dict.update({
+ "opt_confs": ["l70_40km","3dte","ral_opts","hh_solve"],
+ "resolution": "seuk_MG",
+ "DT": 60,
+ "tsteps": 120,
+ "crun": 2,
+ "mpi_parts": 16,
+ "kgo_checks": ["checksum"],
+ "plot_str": "plot_map.py -ral $NODAL_DATA_DIR/lfric_diagnostics.nc $PLOT_DIR",
+ }) %}
+
{# ###################################################################### #}
{# Idealised jobs #}
{# ###################################################################### #}
diff --git a/rose-stem/site/meto/groups/groups_lfric_atm.cylc b/rose-stem/site/meto/groups/groups_lfric_atm.cylc
index 17717320f0..43226f4fb2 100644
--- a/rose-stem/site/meto/groups/groups_lfric_atm.cylc
+++ b/rose-stem/site/meto/groups/groups_lfric_atm.cylc
@@ -79,6 +79,7 @@
"lfric_atm_nwp_azspice_extra",
"lfric_atm_clim_gal9_chem-C12_azspice_gnu_fast-debug-32bit",
"lfric_atm_ral3-seuk_ls_and_jedi_azspice_gnu_fast-debug-32bit",
+ "lfric_atm_3dte-seuk_MG_azspice_gnu_fast-debug-32bit",
"lfric_atm_aquaplanet-C12_azspice_gnu_fast-debug-32bit",
"lfric_atm_thai_ben1-C48_MG_azspice_gnu_fast-debug-32bit",
"lfric_atm_hd209458b-C24_azspice_gnu_fast-debug-32bit",
@@ -190,6 +191,7 @@
"lfric_atm_nwp_ex1a_extra",
"lfric_atm_clim_gal9_chem-C12_ex1a_cce_fast-debug-32bit",
"lfric_atm_ral3-seuk_ls_and_jedi_ex1a_cce_fast-debug-32bit",
+ "lfric_atm_3dte-seuk_MG_ex1a_cce_fast-debug-32bit",
"lfric_atm_comp_tran_ref_3d_l120-BiP64x64-1500x1500_MG_ex1a_cce_fast-debug-32bit",
"lfric_atm_aquaplanet-C12_ex1a_cce_fast-debug-32bit",
"lfric_atm_thai_ben1-C48_MG_ex1a_cce_fast-debug-32bit",
diff --git a/rose-stem/site/meto/lfric_atm/tasks_lfric_atm_ex1a.cylc b/rose-stem/site/meto/lfric_atm/tasks_lfric_atm_ex1a.cylc
index 5238590dfb..370c9b8cf0 100644
--- a/rose-stem/site/meto/lfric_atm/tasks_lfric_atm_ex1a.cylc
+++ b/rose-stem/site/meto/lfric_atm/tasks_lfric_atm_ex1a.cylc
@@ -70,6 +70,12 @@
"memory": [24, "GB"],
}) %}
+{% elif task_ns.conf_name == "3dte-seuk_MG" %}
+
+ {% do task_dict.update({
+ "memory": [24, "GB"],
+ }) %}
+
{% elif task_ns.conf_name == "comp_tran_ref_3d_l120-BiP64x64-1500x1500_MG" %}
{% do task_dict.update({
From 5e3914be5b03062e42d8ef06ac05f2e504c55c2e Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Tue, 25 Aug 2026 10:03:53 +0100
Subject: [PATCH 8/9] Update KGO.
---
...m_3dte-seuk_MG_azspice_gnu_fast-debug-32bit.txt | 9 +++++++++
..._atm_3dte-seuk_MG_ex1a_cce_fast-debug-32bit.txt | 9 +++++++++
...pled_nwp_gal9-C48_ex1a_cce_fast-debug-64bit.txt | 14 +++++++-------
3 files changed, 25 insertions(+), 7 deletions(-)
create mode 100644 rose-stem/site/meto/kgos/lfric_atm/azspice/checksum_lfric_atm_3dte-seuk_MG_azspice_gnu_fast-debug-32bit.txt
create mode 100644 rose-stem/site/meto/kgos/lfric_atm/ex1a/checksum_lfric_atm_3dte-seuk_MG_ex1a_cce_fast-debug-32bit.txt
diff --git a/rose-stem/site/meto/kgos/lfric_atm/azspice/checksum_lfric_atm_3dte-seuk_MG_azspice_gnu_fast-debug-32bit.txt b/rose-stem/site/meto/kgos/lfric_atm/azspice/checksum_lfric_atm_3dte-seuk_MG_azspice_gnu_fast-debug-32bit.txt
new file mode 100644
index 0000000000..e9f7848e7b
--- /dev/null
+++ b/rose-stem/site/meto/kgos/lfric_atm/azspice/checksum_lfric_atm_3dte-seuk_MG_azspice_gnu_fast-debug-32bit.txt
@@ -0,0 +1,9 @@
+Inner product checksum rho = 483993DF
+Inner product checksum theta = 51354A16
+Inner product checksum u = 612F390F
+Inner product checksum mr1 = 40905A70
+Inner product checksum mr2 = 33826467
+Inner product checksum mr3 = 2FB455F3
+Inner product checksum mr4 = 33F4FB8A
+Inner product checksum mr5 = BEB6822
+Inner product checksum mr6 = 0
diff --git a/rose-stem/site/meto/kgos/lfric_atm/ex1a/checksum_lfric_atm_3dte-seuk_MG_ex1a_cce_fast-debug-32bit.txt b/rose-stem/site/meto/kgos/lfric_atm/ex1a/checksum_lfric_atm_3dte-seuk_MG_ex1a_cce_fast-debug-32bit.txt
new file mode 100644
index 0000000000..cbd593d455
--- /dev/null
+++ b/rose-stem/site/meto/kgos/lfric_atm/ex1a/checksum_lfric_atm_3dte-seuk_MG_ex1a_cce_fast-debug-32bit.txt
@@ -0,0 +1,9 @@
+Inner product checksum rho = 48399415
+Inner product checksum theta = 51354A3F
+Inner product checksum u = 612F3D09
+Inner product checksum mr1 = 40906404
+Inner product checksum mr2 = 33822456
+Inner product checksum mr3 = 2FB3ACAC
+Inner product checksum mr4 = 33F4FC84
+Inner product checksum mr5 = BEA357E
+Inner product checksum mr6 = 0
diff --git a/rose-stem/site/meto/kgos/lfric_coupled/ex1a/checksum_lfric_coupled_nwp_gal9-C48_ex1a_cce_fast-debug-64bit.txt b/rose-stem/site/meto/kgos/lfric_coupled/ex1a/checksum_lfric_coupled_nwp_gal9-C48_ex1a_cce_fast-debug-64bit.txt
index e87a088567..339c79f2a8 100644
--- a/rose-stem/site/meto/kgos/lfric_coupled/ex1a/checksum_lfric_coupled_nwp_gal9-C48_ex1a_cce_fast-debug-64bit.txt
+++ b/rose-stem/site/meto/kgos/lfric_coupled/ex1a/checksum_lfric_coupled_nwp_gal9-C48_ex1a_cce_fast-debug-64bit.txt
@@ -1,9 +1,9 @@
-Inner product checksum rho = 411B54EDFE88F36B
-Inner product checksum theta = 42735B55E4723BB2
-Inner product checksum u = 456F12D1620AF46E
-Inner product checksum mr1 = 403682F9FA8D2FF2
-Inner product checksum mr2 = 3F3F4DCDD3CCEC28
-Inner product checksum mr3 = 3F035046D05A7507
-Inner product checksum mr4 = 3F36F51E48AE691E
+Inner product checksum rho = 411B54EFB3659BD9
+Inner product checksum theta = 42735B57F8604204
+Inner product checksum u = 456F13FCA9405FC6
+Inner product checksum mr1 = 40368465EEEB04FB
+Inner product checksum mr2 = 3F409399478109AC
+Inner product checksum mr3 = 3F015CEEE266C61C
+Inner product checksum mr4 = 3F36F3871FE3D922
Inner product checksum mr5 = 0
Inner product checksum mr6 = 0
From b2498357224692741a8b03905a7e12f9f36dad18 Mon Sep 17 00:00:00 2001
From: mo-snishimoto <206237990+mo-snishimoto@users.noreply.github.com>
Date: Tue, 25 Aug 2026 18:04:35 +0100
Subject: [PATCH 9/9] Review comment
---
.../um-boundary_layer/HEAD/rose-meta.conf | 139 +++++++++++++-----
.../rose-meta/um-boundary_layer/versions.py | 90 ++++--------
.../init_turbulence_fields_alg_mod.x90 | 54 ++++---
.../source/support/um_physics_init_mod.f90 | 30 ++--
.../app/lfric_atm/opt/rose-app-3dte.conf | 6 +-
.../lfric-gungho/HEAD/rose-meta.conf | 55 +------
.../gungho/rose-meta/lfric-gungho/versions.py | 60 ++++++++
.../diffusion/leonard_term_alg_mod.x90 | 32 ++--
.../leonard_term_kl_kernel_mod_test.pf | 6 +-
...tracer_smagorinsky_diff_kernel_mod_test.pf | 6 +-
10 files changed, 263 insertions(+), 215 deletions(-)
diff --git a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
index 45b6627fbf..e628a11cbd 100644
--- a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
+++ b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf
@@ -17,7 +17,7 @@ help=The entrainment parametrization includes a term dependent on the
=on mixing between cloudy boundary layer air and cloud-free air entrained
=from above the boundary layer. LES studies suggest a value 0.056.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
range=0.0:1.0
sort-key=Panel-A08a
type=real
@@ -31,7 +31,7 @@ help=The entrainment parametrization includes a term dependent on the
=studies suggest a lower value would be more appropriate
=(Beare gives 1.6).
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
range=0.0:10.0
sort-key=Panel-A08
type=real
@@ -42,7 +42,7 @@ description=Advect prognostic variables in TKE scheme
help=If this switch is turned on,
=the prognostic variables are advected through the Semi-Lagrangian scheme.
=Suggested .TRUE.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=logical
@@ -60,11 +60,12 @@ help=The 1A TKE schemes consists of the following three models.
=model 12min (L70) is too long to run without computational instability,
=but it can run with a 5min timestep.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
trigger=namelist:blayer=my_prod_adj: 'my3' ;
=namelist:blayer=my_simeq_solver: 'my3' ;
- =namelist:mixing=leonard_tke: 'my3','my25' ;
+ =namelist:blayer=use_l_sq: 'my25','my3' ;
+ =namelist:mixing=leonard_tke: 'my25','my3' ;
value-titles=The first order eddy-diffusive model based on Deardorff (1980),
=The Mellor-Yamada level 2.5 model,
=The Mellor-Yamada level 3 model
@@ -91,7 +92,7 @@ description=Allow BL scheme to mix vertical velocity
help=Typically this is used in convective scale applications when horizontal
=mixing via the Smagorinsky scheme is also included.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A13
type=logical
@@ -107,7 +108,7 @@ help=When selected the thickness of the capping inversion is diagnosed
=Either a specified cosine shape is used or else the flux is that
=required to bring the theta_vl profile to a target piecewise linear shape.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A15
value-titles=None,Use a cosine flux profile,
=Use a target theta_vl profile
@@ -117,9 +118,7 @@ values='off','cosine_inv_flux','target_inv_profile'
compulsory=true
description=Boundary layer scheme version
!enumeration=true
-fail-if=(this == "'1a'") and (namelist:microphysics=turb_gen_mixph==".true.");
- =# turb_gen_mixph cannot be used with this boundary layer scheme.
- =(this == "'1a'") and (namelist:cloud=scheme=="'bimodal'");
+fail-if=(this == "'1a'") and (namelist:cloud=scheme=="'bimodal'");
=(this == "'1a'") and (namelist:cloud=pc2_init_method=="'bimodal'");
=# bimodal scheme cannot be used with this boundary layer scheme.
=(this == "'1a'") and (namelist:cloud=scheme=="'pc2'");
@@ -139,7 +138,8 @@ help=Version 9 is the long-standing "diagnostic K-profile" scheme,
!kind=default
ns=namelist/Science/UM Boundary layer
sort-key=Panel-A08a
-trigger=namelist:blayer=a_ent_2: '9c' ;
+trigger=namelist:blayer=blending_9c: '9c';
+ =namelist:blayer=a_ent_2: '9c' ;
=namelist:blayer=a_ent_shr: '9c' ;
=namelist:blayer=bl_res_inv: '9c' ;
=namelist:blayer=dec_thres_cloud: '9c' ;
@@ -148,6 +148,7 @@ trigger=namelist:blayer=a_ent_2: '9c' ;
=namelist:blayer=near_neut_z_on_l: '9c' ;
=namelist:blayer=dzrad_disc_opt: '9c' ;
=namelist:blayer=entr_smooth_dec: '9c' ;
+ =namelist:blayer=improved_tke_diag: '9c' ;
=namelist:blayer=interp_local: '9c' ;
=namelist:blayer=kprof_cu: '9c' ;
=namelist:blayer=l_converge_ga: '9c' ;
@@ -155,8 +156,12 @@ trigger=namelist:blayer=a_ent_2: '9c' ;
=namelist:blayer=new_kcloudtop: '9c' ;
=namelist:blayer=ng_stress: '9c' ;
=namelist:blayer=num_sweeps_bflux: '9c' ;
+ =namelist:blayer=reduce_fa_mix: '9c' ;
=namelist:blayer=sc_diag_opt: '9c' ;
+ =namelist:blayer=zhloc_depth_fac: '9c' ;
=namelist:blayer=bl_mix_w: '9c' ;
+ =namelist:microphysics=turb_gen_mixph: '9c' ;
+ =namelist:blayer=blending_1a: '1a';
=namelist:blayer=tke_levels: '1a' ;
=namelist:blayer=bdy_tke: '1a' ;
=namelist:blayer=adv_turb_field: '1a' ;
@@ -166,10 +171,66 @@ trigger=namelist:blayer=a_ent_2: '9c' ;
=namelist:blayer=my_force_initialize: '1a' ;
=namelist:blayer=my_ini_dbdz_min: '1a' ;
=namelist:blayer=my_lowest_pd_surf: '1a' ;
+ =namelist:blayer=my_prod_adj: '1a' ;
+ =namelist:blayer=my_simeq_solver: '1a' ;
+ =namelist:blayer=use_l_sq: '1a' ;
+ =namelist:mixing=leonard_tke: '1a' ;
value-titles=9C: Revised entrainment fluxes plus new scalar,
=1A: Prognostic TKE-based turbulent closure
values='9c','1a'
+[namelist:blayer=blending_1a]
+compulsory=true
+description=Hybrid method combining the 1A BL scheme and the Smagorinsky scheme
+!enumeration=true
+help=Options for Smagorinsky subgrid mixing scheme:
+ =_________________________________________________________________
+ =3D Smag
+ = Smagorinsky mixing scheme applied in horizontal and vertical.
+ =_________________________________________________________________
+ =3DTE Mk1
+ = The Mellor-Yamada level 2.5 and level 3 versions of the 1A family
+ = of higher order turbulence closure schemes have been modified to run as
+ = 3-dimensional schemes, using a mixing length that asymptotes to the
+ = Smagorinsky mixing length at very high resolution, and the computation
+ = of various constants modified to use of 3D (rather than 1D) shear.
+ = This option activates this change to the computation of eddy viscosity
+ = and diffusivity.
+ = See UMDP 025 for further details.
+ns=namelist/Science/UM Boundary layer/1A scheme
+sort-key=Panel-A10a
+trigger=namelist:blayer=use_l_sq: '3dte_mk1' ;
+value-titles=3D Smagorinsky, 3DTE Mk1
+values='3d_smag', '3dte_mk1'
+
+[namelist:blayer=blending_9c]
+compulsory=true
+description=Hybrid method combining the 9C BL scheme and the Smagorinsky scheme
+!enumeration=true
+help=Options for Smagorinsky subgrid mixing scheme:
+ =_________________________________________________________________
+ =3D Smag
+ = Smagorinsky mixing scheme applied in horizontal and vertical.
+ =_________________________________________________________________
+ =2D Smag + 1D BL
+ = Smagorinsky mixing scheme applied in horizontal.
+ = 1D BL scheme used in the vertical.
+ =_________________________________________________________________
+ =Blended scheme + Smag above
+ = Blended BL-Smagorinsky diffusion coefficient used for
+ = subgrid mixing in horizontal and vertical.
+ = Relaxes to 3D Smagorinsky above BL
+ =_________________________________________________________________
+ =Blended scheme + 1D BL above
+ = As above, but relaxes to 1D BL above BL
+ =
+ = WARNING: This option currently does not conserve energy and as
+ = a result may be unstable.
+ns=namelist/Science/UM Boundary layer/9C scheme
+sort-key=Panel-A02
+value-titles=3D Smagorinsky, 2D Smagorinsky + 1D BL, Blended scheme + Smag above, Blended scheme + 1D BL above
+values='3d_smag', '2d_smag', 'blend_smag_fa', 'blend_1dbl_fa'
+
[namelist:blayer=c_gust]
compulsory=true
description=Constant in the wind gust diagnostic
@@ -215,7 +276,7 @@ compulsory=true
description=Decoupling threshold for cloudy boundary layers
help=This is recommended to be set to 0.1
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
range=0.0:1.0
sort-key=Panel-A11a
type=real
@@ -225,7 +286,7 @@ compulsory=true
description=Decoupling threshold for cumulus
help=This is recommended to be set to 0.05
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
range=0.0:1.0
sort-key=Panel-A11b
type=real
@@ -258,7 +319,7 @@ help=In situations where surface conditions are close to neutral and the
=for all options (other than 0) the consistency of the provisional
=diagnosis of an unstable boundary layer in CONV_DIAG is checked
=against the surface flux diagnosed by the surface exchange routines.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A09
trigger=namelist:blayer=zhloc_depth_fac: 'ri_based';
value-titles=zi/L revised over sea,zi/L used in Cumulus over sea,Ri based
@@ -291,7 +352,7 @@ help=The buoyancy-flux integration used to find the depth of mixing in
= Option 2 also includes any SL and qw gradients occuring within the
= radiatively-cooled layer when calculating the buoyancy-flux
= integrated over it (these are ignored in option 1).
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A10
value-titles=1) Set base of layer at theta-level nt-1,
=2) Set base of layer smoothly 1.5 model-levels below cloud-top
@@ -308,7 +369,7 @@ help=Reduce the surface-driven contribution to cloud-top entrainment
=The second option also smoothly reduces the height-scale used to
=compute w* (which scales the surface-driven non-local mixing) from the
=Sc-top height to the SML-top height as a function of decoupling strength.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A10
value-titles=Off,
=Smoothly taper surface entrainment terms,
@@ -386,7 +447,7 @@ help=Tweaks to both local and non-local TKE
=contributions, to keep w_var consistent with rhokm, to ensure
=the ratio Km/sqrt(w_var) reflects the turbulence length-scale
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A11
type=logical
@@ -420,7 +481,7 @@ help=Due to the winds and scalar fields being on staggered vertical grids,
= theta-levels, combined with the gradient of total-water
= supersaturation qw - qsat(Tl) between the two levels.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A04
value-titles=Interpolate sl and qw gradients to compute dbdz on theta-levels,
=Compute dbdz on rho-levels and then interpolate to theta-levels
@@ -442,7 +503,7 @@ help=When this option is not used, a diagnosis of a cumulus regime means
=restrictive version of that allows the mixed layer top to be
=below the LCL
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A11
value-titles=Use the buoyancy flux integration algorithm,
=Use less restrictive buoyancy flux integration algorithm
@@ -454,7 +515,7 @@ description=Use gradient adjustment depth-dependence in b-flux integration
help=Improve accuracy of mixed-layer depths found via buoyancy-flux integration,
=by accounting for sensitivity of gradient adjustment to the depth.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A10
type=logical
@@ -498,7 +559,7 @@ help=This switch fixes, or mitigates, inadequacies in the original coding of
= The new version is more fool-proof, using flags explicitly set
= to indicate what has happened inside excf_nl_9c.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A10
type=logical
@@ -510,7 +571,7 @@ help=Diffusion coefficients between TKE_LEVELS + 1 and BL_LEVELS are not
=these diffusion coefficients are obtained through the local
=BL scheme. This is compatible to the original UM BL scheme
=with Z_NL_BL_LEVELS different from BL_LEVELS.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=logical
@@ -526,7 +587,7 @@ help=If this option is selected,
=If this option is not selected,
=buoyancy parameters calculated in the large scale cloud scheme
=(Smith or PC2) will be used in the TKE scheme. Suggested .TRUE.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=logical
@@ -540,7 +601,7 @@ help=By default, the initial values of the turbulent prognostic variables
=
=But when this switch is turned on, the initial fields are diagnosed
=in any case, including continuation run.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=logical
@@ -554,7 +615,7 @@ help=If the initial fields have negative or close-to-neutral vertical
=the minimum limit of the vertical buoyancy gradient (in s^(-2)) is
=imposed in the initialisation.
=Suggested value 1.0e-5.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
range=1.0e-10:1.0e+10
sort-key=Panel-A10a
type=real
@@ -585,7 +646,7 @@ help=The production terms of the prognostic variables at the lowest level
=roughness length or turn this option off.
=Suggested Belijaars and Holtslag (1991).
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
value-titles=Not use surface fluxes,
=With gradient functions by Businger(1971),
@@ -603,7 +664,7 @@ help=This option is highly recommended to turn on,
=sufficient computational stability is secured in NAE and UKV.
=The factors can be set on each level. Sometimes smaller values
=at the lower layer could be better to ensure computational stability.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=logical
@@ -620,7 +681,7 @@ help=The prognostic equations of turbulent second moments in level 3 are solved
=uses less memory and (generally) faster to compute than bcgstab.
=Suggested Gaussian elimination.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
value-titles=Use bi-conjugate gradient stabilized (BCGSTAB) method,
=Use gaussian elimination
@@ -631,7 +692,7 @@ compulsory=true
description=Threshold value of z/l below which to diagnose shear-driven BL
help=This is recommended to be set to 1.6
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
range=0.0:10.0
sort-key=Panel-A09a
type=real
@@ -643,7 +704,7 @@ help=This logical implements a new method to identify the cloud top in the
=radiative flux profile that results in a radiative flux jump estimation
= that has been found to be less resolution sensitive.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A10
type=logical
@@ -660,7 +721,7 @@ help=This switch allows the user to choose between different physics options
=2) BG97_original, the same as BG97_limited but with the stress profile
=applied across the whole boundary layer (as originally defined by
=Brown and Grant (1997)).
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
value-titles=Limited stress applied above the surface layer,
=Limited stress applied over full boundary layer depth
values='BG97_limited','BG97_original'
@@ -698,7 +759,7 @@ help=The depth reached by Decoupled StratoCumulus mixing
=and so determines the accuracy of the solution for the mixed-layer depths;
=each additional iteration reduces the error by a factor of 4.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
range=3:12
sort-key=Panel-A10
type=integer
@@ -733,7 +794,7 @@ help=Switch to decide where to keep the diffusion coefficient calculated
=turbulence scheme then the local coefficients are only reduced by
=applying the 1D weighting function,
=rather than set to zero.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A06
value-titles=Reduce in the levels spanning inversions and the LCL in cumulus,
=Reduce in the levels spanning inversions
@@ -773,7 +834,7 @@ help=This switch controls how the boundary-layer scheme decides which
= instead of using the conv_diag parcel top.
= 3) Diagnose Sc-top based on max total-water RH at all points
= instead of using the svl gradient.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
sort-key=Panel-A10
value-titles=Original svl gradient and shallow Cu-top method,
=Relax to use parcel top at all convection points,
@@ -815,7 +876,7 @@ help=If this switch is activated,
=if the convection scheme is turned on,
=conflicts between the convection scheme and this flux could occur.
=Suggested .TRUE.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
trigger=namelist:blayer=shcu_levels: .true.;
type=logical
@@ -827,7 +888,7 @@ help=The maximum level to calculate and add the non-gradient buoyancy flux
=can be set. It should correspond to a height of 3 to 5km.
=Suggested -1 to set to TKE levels.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=integer
@@ -847,7 +908,7 @@ help="TKE_LEVELS" is similar to "Z_NL_BL_LEVELS" in the original UM boundary
=It is recommended to use a level around 6km over the sea (e.g. 30
=in the current global L70 model). -1 will default to bl_levels.
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=integer
@@ -858,7 +919,7 @@ help=If this option is selected,
=turbulent length scale is computed by the harmonic mean of squared
=master length scale (Nakanishi 2001) and Smagorinsky length scale,
=instead of simple harmonic mean.
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/1A scheme
sort-key=Panel-A10a
type=logical
@@ -866,7 +927,7 @@ type=logical
compulsory=true
description=Fractional cloud height reached by local BL depth calculation
!kind=default
-ns=namelist/Science/UM Boundary layer
+ns=namelist/Science/UM Boundary layer/9C scheme
range=0.0:1.0
sort-key=Panel-A09a
type=real
diff --git a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
index 0eadf2266a..3e36d943ba 100644
--- a/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
+++ b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/versions.py
@@ -39,66 +39,40 @@ class vn32_t46(MacroUpgrade):
AFTER_TAG = "vn3.2_t46"
def upgrade(self, config, meta_config=None):
- # Commands From: rose-meta/um-boundary_layer
- boundary_layer = self.get_setting_value(
- config, ["namelist:section_choice", "boundary_layer"]
- )
mixing_method = self.get_setting_value(
config, ["namelist:mixing", "method"]
)
- self.remove_setting(config, ["namelist:mixing", "method"])
- if boundary_layer == "'um'":
- self.add_setting(
- config, ["namelist:blayer", "bl_scheme"], "'9c'"
- )
- self.add_setting(
- config, ["namelist:mixing", "method_9c"], mixing_method
- )
-
- conf_hash = {}
- conf_list = ["field_names", "enforce_min_value", "min_value"]
- # read list type namelists
- for conf in conf_list:
- conf_val = self.get_setting_value(
- config, ["namelist:transport", conf]
- ).split(",")
- conf_hash[conf] = []
- for value in conf_val:
- if "*" in value:
- num = int(value.split("*")[0])
- val = value.split("*")[1]
- for i in range(num):
- conf_hash[conf].append(val)
- else:
- conf_hash[conf].append(value)
- # modify namelist value according to condition
- if (
- "'con_tracer'" in conf_hash["field_names"]
- and "'adv_tracer'" in conf_hash["field_names"]
- ):
- i = conf_hash["field_names"].index("'con_tracer'")
- j = conf_hash["field_names"].index("'adv_tracer'")
- conf_hash["field_names"][i] = "'pos_tracer'"
- conf_hash["field_names"][j] = "'gen_tracer'"
- conf_hash["enforce_min_value"][i] = ".true."
- conf_hash["enforce_min_value"][j] = ".false."
- conf_hash["min_value"][i] = "0.0"
- conf_hash["min_value"][j] = "-99999999.0"
- elif "'con_tracer'" in conf_hash["field_names"]:
- i = conf_hash["field_names"].index("'con_tracer'")
- conf_hash["field_names"][i] = "'pos_tracer'"
- conf_hash["enforce_min_value"][i] = ".true."
- conf_hash["min_value"][i] = "0.0"
- elif "'adv_tracer'" in conf_hash["field_names"]:
- i = conf_hash["field_names"].index("'adv_tracer'")
- conf_hash["field_names"][i] = "'pos_tracer'"
- conf_hash["enforce_min_value"][i] = ".true."
- conf_hash["min_value"][i] = "0.0"
- # change namelist value
- for conf in conf_list:
- self.change_setting_value(
- config, ["namelist:transport", conf], ",".join(conf_hash[conf])
- )
-
+ self.add_setting(config, ["namelist:blayer", "bl_scheme"], "'9c'")
+ self.add_setting(
+ config, ["namelist:blayer", "blending_9c"], mixing_method
+ )
+ self.add_setting(
+ config, ["namelist:blayer", "blending_1a"], "'3dte_mk1'"
+ )
+ self.add_setting(
+ config, ["namelist:blayer", "adv_turb_field"], ".true."
+ )
+ self.add_setting(config, ["namelist:blayer", "bdy_tke"], "'my3'")
+ self.add_setting(
+ config, ["namelist:blayer", "local_above_tkelvs"], ".true."
+ )
+ self.add_setting(config, ["namelist:blayer", "my_condense"], ".true.")
+ self.add_setting(
+ config, ["namelist:blayer", "my_force_initialize"], ".false."
+ )
+ self.add_setting(
+ config, ["namelist:blayer", "my_ini_dbdz_min"], "1.0e-5"
+ )
+ self.add_setting(
+ config, ["namelist:blayer", "my_lowest_pd_surf"], "'bh91'"
+ )
+ self.add_setting(config, ["namelist:blayer", "my_prod_adj"], ".true.")
+ self.add_setting(
+ config, ["namelist:blayer", "my_simeq_solver"], "'gauss'"
+ )
+ self.add_setting(config, ["namelist:blayer", "shcu_buoy"], ".false.")
+ self.add_setting(config, ["namelist:blayer", "shcu_levels"], "-1")
+ self.add_setting(config, ["namelist:blayer", "tke_levels"], "-1")
+ self.add_setting(config, ["namelist:blayer", "use_l_sq"], ".true.")
return config, self.reports
diff --git a/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90 b/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90
index d2c417495c..9ceb6e2c12 100644
--- a/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90
+++ b/interfaces/physics_schemes_interface/source/algorithm/init_turbulence_fields_alg_mod.x90
@@ -36,34 +36,40 @@ contains
type(field_collection_type), intent(in) :: turbulence_fields
! Prognostic fields
- type( field_type ), pointer :: zh => null()
- type( field_type ), pointer :: z_lcl => null()
- type( integer_field_type ), pointer :: ntml => null()
- type( integer_field_type ), pointer :: cumulus => null()
- type( field_type ), pointer :: wvar => null()
- type( field_type ), pointer :: heat_flux_bl => null()
- type( field_type ), pointer :: moist_flux_bl => null()
- type( field_type ), pointer :: tke_bl => null()
- type( field_type ), pointer :: tsq_bl => null()
- type( field_type ), pointer :: qsq_bl => null()
- type( field_type ), pointer :: cov_bl => null()
- type( field_type ), pointer :: zhpar_shcu => null()
- type( field_type ), pointer :: rhokm_bl => null()
- type( field_type ), pointer :: rhokh_bl => null()
- type( field_type ), pointer :: dtrdz_tq_bl => null()
- type( field_type ), pointer :: zhsc => null()
- type( integer_field_type ), pointer :: level_ent => null()
- type( integer_field_type ), pointer :: level_ent_dsc => null()
- type( field_type ), pointer :: ent_we_lim => null()
- type( field_type ), pointer :: ent_t_frac => null()
- type( field_type ), pointer :: ent_zrzi => null()
- type( field_type ), pointer :: ent_we_lim_dsc => null()
- type( field_type ), pointer :: ent_t_frac_dsc => null()
- type( field_type ), pointer :: ent_zrzi_dsc => null()
+ type( field_type ), pointer :: zh
+ type( field_type ), pointer :: z_lcl
+ type( integer_field_type ), pointer :: ntml
+ type( integer_field_type ), pointer :: cumulus
+ type( field_type ), pointer :: wvar
+ type( field_type ), pointer :: heat_flux_bl
+ type( field_type ), pointer :: moist_flux_bl
+ type( field_type ), pointer :: tke_bl
+ type( field_type ), pointer :: tsq_bl
+ type( field_type ), pointer :: qsq_bl
+ type( field_type ), pointer :: cov_bl
+ type( field_type ), pointer :: zhpar_shcu
+ type( field_type ), pointer :: rhokm_bl
+ type( field_type ), pointer :: rhokh_bl
+ type( field_type ), pointer :: dtrdz_tq_bl
+ type( field_type ), pointer :: zhsc
+ type( integer_field_type ), pointer :: level_ent
+ type( integer_field_type ), pointer :: level_ent_dsc
+ type( field_type ), pointer :: ent_we_lim
+ type( field_type ), pointer :: ent_t_frac
+ type( field_type ), pointer :: ent_zrzi
+ type( field_type ), pointer :: ent_we_lim_dsc
+ type( field_type ), pointer :: ent_t_frac_dsc
+ type( field_type ), pointer :: ent_zrzi_dsc
type( field_type ), pointer :: dsldzm
type( field_type ), pointer :: mix_len_bm
type( field_type ), pointer :: gradrinr
+ nullify( zh, z_lcl, ntml, cumulus, wvar, heat_flux_bl, moist_flux_bl, &
+ tke_bl, tsq_bl, qsq_bl, cov_bl, zhpar_shcu, rhokm_bl, rhokh_bl, &
+ dtrdz_tq_bl, zhsc, level_ent, level_ent_dsc, ent_we_lim, &
+ ent_t_frac, ent_zrzi, ent_we_lim_dsc, ent_t_frac_dsc, &
+ ent_zrzi_dsc, dsldzm, mix_len_bm, gradrinr )
+
call turbulence_fields%get_field('zh', zh)
call turbulence_fields%get_field('z_lcl', z_lcl)
call turbulence_fields%get_field('ntml', ntml)
diff --git a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90 b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
index 874a6e0c57..2bed642eab 100644
--- a/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
+++ b/interfaces/physics_schemes_interface/source/support/um_physics_init_mod.f90
@@ -30,6 +30,12 @@ module um_physics_init_mod
us_am_in => us_am
use blayer_config_mod, only : bl_scheme, bl_scheme_9c, bl_scheme_1a, &
+ blending_9c, blending_9c_3d_smag, &
+ blending_9c_2d_smag, &
+ blending_9c_blend_smag_fa, &
+ blending_9c_blend_1dbl_fa, &
+ blending_1a, blending_1a_3d_smag, &
+ blending_1a_3dte_mk1, &
tke_levels_in => tke_levels, &
bdy_tke_in => bdy_tke, bdy_tke_my3, &
bdy_tke_my25, bdy_tke_deardorff, &
@@ -214,14 +220,6 @@ module um_physics_init_mod
heavy_rain_evap_fac
use mixing_config_mod, only : smagorinsky, &
- mixing_method_9c => method_9c, &
- method_9c_3d_smag, &
- method_9c_2d_smag, &
- method_9c_blend_smag_fa, &
- method_9c_blend_1dbl_fa, &
- mixing_method_1a => method_1a, &
- method_1a_3d_smag, &
- method_1a_3dte_mk1, &
mix_factor_in => mix_factor, &
leonard_term, &
leonard_tke
@@ -1717,23 +1715,23 @@ subroutine um_physics_init()
if ( bl_scheme == bl_scheme_9c ) then
! Options which are bespoke to the choice of scheme
- select case ( mixing_method_9c )
+ select case ( blending_9c )
- case( method_9c_3d_smag )
+ case( blending_9c_3d_smag )
l_subfilter_horiz = .true.
l_subfilter_vert = .true.
blending_option = off
non_local_bl = off
ng_stress = off
- case( method_9c_2d_smag )
+ case( blending_9c_2d_smag )
l_subfilter_horiz = .true.
l_subfilter_vert = .false.
blending_option = off
- case( method_9c_blend_smag_fa )
+ case( blending_9c_blend_smag_fa )
l_subfilter_horiz = .true.
l_subfilter_vert = .true.
blending_option = blend_allpoints
- case( method_9c_blend_1dbl_fa )
+ case( blending_9c_blend_1dbl_fa )
l_subfilter_horiz = .true.
l_subfilter_vert = .true.
blending_option = blend_gridindep_fa
@@ -1741,14 +1739,14 @@ subroutine um_physics_init()
else if ( bl_scheme == bl_scheme_1a ) then
- select case ( mixing_method_1a )
+ select case ( blending_1a )
- case( method_1a_3d_smag )
+ case( blending_1a_3d_smag )
l_3dtke = .false.
l_subfilter_horiz = .true.
l_subfilter_vert = .true.
blending_option = off
- case( method_1a_3dte_mk1 )
+ case( blending_1a_3dte_mk1 )
l_3dtke = .true.
l_subfilter_horiz = .true.
l_subfilter_vert = .false.
diff --git a/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf b/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf
index a772cd9686..260702093f 100644
--- a/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf
+++ b/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf
@@ -18,12 +18,15 @@ bl_levels=69
!!bl_mix_w=.false.
!!bl_res_inv='cosine_inv_flux'
bl_scheme='1a'
+blending_1a='3dte_mk1'
+!!blending_9c='blend_1dbl_fa'
!!dec_thres_cloud=0.1
!!dec_thres_cu=0.05
!!dyn_diag='zi_l_cu'
!!dzrad_disc_opt='level_ntm1'
!!entr_smooth_dec='on'
free_atm_mix='free_trop_layer'
+!!improved_tke_diag=.false.
!!interp_local='cf_dbdz'
!!kprof_cu='buoy_integ'
!!l_converge_ga=.false.
@@ -41,6 +44,7 @@ my_simeq_solver='gauss'
noice_in_turb=.true.
!!num_sweeps_bflux=3
p_unstable=0.5
+!!reduce_fa_mix='inv_only'
sbl_opt='sharpest'
!!sc_diag_opt='orig'
sg_orog_mixing='shear_plus_lambda'
@@ -167,8 +171,6 @@ leonard_kl=1.0
leonard_term=.true.
leonard_tke=.true.
max_diff_factor=1.0
-method_1a='3dte_mk1'
-method_9c='blend_1dbl_fa'
mix_factor=0.2
smag_l_calc='UseDx'
smagorinsky=.true.
diff --git a/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf b/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
index 685f6ad39f..6ae5db5451 100644
--- a/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
+++ b/science/gungho/rose-meta/lfric-gungho/HEAD/rose-meta.conf
@@ -3720,57 +3720,6 @@ help=Typical value is 1.0
sort-key=Panel-A10
type=real
-[namelist:mixing=method_1a]
-compulsory=true
-description=Smagorinsky subgrid mixing scheme option for 1A scheme
-!enumeration=true
-fail-if=this=='3dte_mk1' and namelist:blayer=bdy_tke=='deardorff'
-help=Options for Smagorinsky subgrid mixing scheme:
- =_________________________________________________________________
- =3D Smag
- = Smagorinsky mixing scheme applied in horizontal and vertical.
- =_________________________________________________________________
- =3D TKE
- = The Mellor-Yamada level 2.5 and level 3 versions of the 1A family
- = of higher order turbulence closure schemes have been modified to run as
- = 3-dimensional schemes, using a mixing length that asymptotes to the
- = Smagorinsky mixing length at very high resolution, and the computation
- = of various constants modified to use of 3D (rather than 1D) shear.
- = This option activates this change to the computation of eddy viscosity
- = and diffusivity.
- = See UMDP 025 for further details.
-sort-key=Panel-A10a
-trigger=namelist:blayer=use_l_sq: '3dte_mk1' ;
-value-titles=3D Smagorinsky, 3D TKE
-values='3d_smag', '3dte_mk1'
-
-[namelist:mixing=method_9c]
-compulsory=true
-description=Smagorinsky subgrid mixing scheme option for 9c scheme
-!enumeration=true
-help=Options for Smagorinsky subgrid mixing scheme:
- =_________________________________________________________________
- =3D Smag
- = Smagorinsky mixing scheme applied in horizontal and vertical.
- =_________________________________________________________________
- =2D Smag + 1D BL
- = Smagorinsky mixing scheme applied in horizontal.
- = 1D BL scheme used in the vertical.
- =_________________________________________________________________
- =Blended scheme + Smag above
- = Blended BL-Smagorinsky diffusion coefficient used for
- = subgrid mixing in horizontal and vertical.
- = Relaxes to 3D Smagorinsky above BL
- =_________________________________________________________________
- =Blended scheme + 1D BL above
- = As above, but relaxes to 1D BL above BL
- =
- = WARNING: This option currently does not conserve energy and as
- = a result may be unstable.
-sort-key=Panel-A05
-value-titles=3D Smagorinsky, 2D Smagorinsky + 1D BL, Blended scheme + Smag above, Blended scheme + 1D BL above
-values='3d_smag', '2d_smag', 'blend_smag_fa','blend_1dbl_fa'
-
[namelist:mixing=mix_factor]
compulsory=true
description=Smagorinsky mixing length constant
@@ -3803,8 +3752,8 @@ help=Apply Smagorinsky mixing to theta,
= WARNING: Current implementation assumes a Cartesian mesh.
!kind=default
sort-key=Panel-A03
-trigger=namelist:mixing=method_9c: .true. ;
- =namelist:mixing=method_1a: .true. ;
+trigger=namelist:blayer=blending_1a: .true. ;
+ =namelist:blayer=blending_9c: .true. ;
=namelist:mixing=mix_factor: .true. ;
=namelist:mixing=smag_l_calc: .true. ;
=namelist:mixing=max_diff_factor: .true.;
diff --git a/science/gungho/rose-meta/lfric-gungho/versions.py b/science/gungho/rose-meta/lfric-gungho/versions.py
index 01e65a2b91..9d28b6b163 100644
--- a/science/gungho/rose-meta/lfric-gungho/versions.py
+++ b/science/gungho/rose-meta/lfric-gungho/versions.py
@@ -31,3 +31,63 @@ def upgrade(self, config, meta_config=None):
# Add settings
return config, self.reports
"""
+
+class vn32_t46(MacroUpgrade):
+ """Upgrade macro for ticket #46 by Shusuke Nishimoto."""
+
+ BEFORE_TAG = "vn3.2"
+ AFTER_TAG = "vn3.2_t46"
+
+ def upgrade(self, config, meta_config=None):
+ self.remove_setting(config, ["namelist:mixing", "method"])
+ self.add_setting(config, ["namelist:mixing", "leonard_tke"], ".true.")
+ conf_hash = {}
+ conf_list = ["field_names", "enforce_min_value", "min_value"]
+ # read list type namelists
+ for conf in conf_list:
+ conf_val = self.get_setting_value(
+ config, ["namelist:transport", conf]
+ ).split(",")
+ conf_hash[conf] = []
+ for value in conf_val:
+ if "*" in value:
+ num = int(value.split("*")[0])
+ val = value.split("*")[1]
+ for i in range(num):
+ conf_hash[conf].append(val)
+ else:
+ conf_hash[conf].append(value)
+ # modify namelist value according to condition
+ if (
+ "'con_tracer'" in conf_hash["field_names"]
+ and "'adv_tracer'" in conf_hash["field_names"]
+ ):
+ # If both con and adv tracer exist, the former is replaced with
+ # pos tracer, and the latter is replaced with gen tracer.
+ i = conf_hash["field_names"].index("'con_tracer'")
+ j = conf_hash["field_names"].index("'adv_tracer'")
+ conf_hash["field_names"][i] = "'pos_tracer'"
+ conf_hash["field_names"][j] = "'gen_tracer'"
+ conf_hash["enforce_min_value"][i] = ".true."
+ conf_hash["enforce_min_value"][j] = ".false."
+ conf_hash["min_value"][i] = "0.0"
+ conf_hash["min_value"][j] = "-99999999.0"
+ elif "'con_tracer'" in conf_hash["field_names"]:
+ # If only con tracer exists, it is replaced with pos tracer.
+ i = conf_hash["field_names"].index("'con_tracer'")
+ conf_hash["field_names"][i] = "'pos_tracer'"
+ conf_hash["enforce_min_value"][i] = ".true."
+ conf_hash["min_value"][i] = "0.0"
+ elif "'adv_tracer'" in conf_hash["field_names"]:
+ # If only adv tracer exists, it is replaced with pos tracer.
+ i = conf_hash["field_names"].index("'adv_tracer'")
+ conf_hash["field_names"][i] = "'pos_tracer'"
+ conf_hash["enforce_min_value"][i] = ".true."
+ conf_hash["min_value"][i] = "0.0"
+ # change namelist value
+ for conf in conf_list:
+ self.change_setting_value(
+ config, ["namelist:transport", conf], ",".join(conf_hash[conf])
+ )
+
+ return config, self.reports
diff --git a/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90 b/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90
index da64332468..784246cee6 100644
--- a/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90
+++ b/science/gungho/source/algorithm/diffusion/leonard_term_alg_mod.x90
@@ -97,19 +97,19 @@ subroutine leonard_term_alg(config, &
class( model_clock_type ), intent(in) :: model_clock
! Temporary fields unpacked from collections
- type( field_type ), pointer :: exner_in_wth => null()
- type( field_type ), pointer :: wetrho_in_w2 => null()
- type( field_type ), pointer :: wetrho_in_w3 => null()
- type( field_type ), pointer :: w_physics => null()
- type( field_type ), pointer :: velocity_w2v => null()
- type( field_type ), pointer :: dtrdz_tq_bl => null()
- type( field_type ), pointer :: dtrdz_fd2 => null()
- type( field_type ), pointer :: height_w1 => null()
- type( field_type ), pointer :: height_w2 => null()
- type( field_type ), pointer :: height_w3 => null()
- type( field_type ), pointer :: height_wth => null()
- type( field_type ), pointer :: panel_id => null()
- type( field_type ), pointer :: rmult => null()
+ type( field_type ), pointer :: exner_in_wth
+ type( field_type ), pointer :: wetrho_in_w2
+ type( field_type ), pointer :: wetrho_in_w3
+ type( field_type ), pointer :: w_physics
+ type( field_type ), pointer :: velocity_w2v
+ type( field_type ), pointer :: dtrdz_tq_bl
+ type( field_type ), pointer :: dtrdz_fd2
+ type( field_type ), pointer :: height_w1
+ type( field_type ), pointer :: height_w2
+ type( field_type ), pointer :: height_w3
+ type( field_type ), pointer :: height_wth
+ type( field_type ), pointer :: panel_id
+ type( field_type ), pointer :: rmult
type( integer_field_type ), pointer :: face_selector_ew
type( integer_field_type ), pointer :: face_selector_ns
@@ -136,6 +136,12 @@ subroutine leonard_term_alg(config, &
if ( LPROF ) call start_timing( id, 'leonard_term' )
+ nullify( exner_in_wth, wetrho_in_w2, wetrho_in_w3, &
+ w_physics, velocity_w2v, dtrdz_tq_bl, dtrdz_fd2, &
+ height_w1, height_w2, height_w3, height_wth, &
+ panel_id, rmult, face_selector_ew, face_selector_ns, &
+ mesh, shifted_mesh, w2h_sh_fs )
+
mesh => theta%get_mesh()
mesh_id = theta%get_mesh_id()
shifted_mesh => mesh_collection%get_mesh(mesh, SHIFTED)
diff --git a/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
index 222c69b074..bd72fe726a 100644
--- a/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/leonard_term_kl_kernel_mod_test.pf
@@ -38,9 +38,7 @@ contains
feign_mixing_config
use finite_element_config_mod, only : cellshape_quadrilateral, &
coord_system_xyz, coord_space_wchi
- use mixing_config_mod, only : method_1a_3d_smag, &
- method_9c_3d_smag, &
- smag_l_calc, smag_l_calc_UseDx
+ use mixing_config_mod, only : smag_l_calc, smag_l_calc_UseDx
implicit none
@@ -50,8 +48,6 @@ contains
viscosity_mu = 0.0_r_def, &
smagorinsky = .false., &
mix_factor = 0.2_r_def, &
- method_1a = method_1a_3d_smag, &
- method_9c = method_9c_3d_smag, &
leonard_tke = .false., &
smag_l_calc = smag_l_calc_UseDx, &
leonard_term = .false., &
diff --git a/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf b/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
index 9cdf8ddbdc..4f4adab56e 100644
--- a/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
+++ b/science/gungho/unit-test/kernel/diffusion/tracer_smagorinsky_diff_kernel_mod_test.pf
@@ -37,9 +37,7 @@ contains
use sci_chi_transform_mod, only : init_chi_transforms
use feign_config_mod, only : feign_finite_element_config, &
feign_mixing_config
- use mixing_config_mod, only : method_1a_3d_smag, &
- method_9c_3d_smag, &
- smag_l_calc, &
+ use mixing_config_mod, only : smag_l_calc, &
smag_l_calc_UseDx
use finite_element_config_mod, only : cellshape_quadrilateral, &
coord_system_xyz, coord_space_wchi
@@ -52,8 +50,6 @@ contains
viscosity_mu = 0.0_r_def, &
smagorinsky = .false., &
mix_factor = 0.2_r_def, &
- method_1a = method_1a_3d_smag, &
- method_9c = method_9c_3d_smag, &
leonard_tke = .false., &
smag_l_calc = smag_l_calc_UseDx, &
leonard_term = .false., &