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 1e117100ae..9589bd31cb 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, @@ -1000,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/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/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/HEAD/rose-meta.conf b/interfaces/physics_schemes_interface/rose-meta/um-boundary_layer/HEAD/rose-meta.conf index 4947c61cfe..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,11 +31,46 @@ 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 +[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/1A scheme +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/1A scheme +sort-key=Panel-A10a +trigger=namelist:blayer=my_prod_adj: 'my3' ; + =namelist:blayer=my_simeq_solver: 'my3' ; + =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 +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 @@ -57,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 @@ -73,12 +108,129 @@ 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 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: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=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' ; + =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=improved_tke_diag: '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=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' ; + =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' ; + =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 @@ -124,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 @@ -134,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 @@ -167,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 @@ -200,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 @@ -217,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, @@ -295,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 @@ -329,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 @@ -351,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 @@ -363,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 @@ -407,16 +559,140 @@ 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 +[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/1A scheme +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/1A scheme +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/1A scheme +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/1A scheme +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/1A scheme +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/1A scheme +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/1A scheme +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 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 @@ -428,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 @@ -445,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' @@ -483,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 @@ -518,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 @@ -558,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, @@ -589,11 +865,69 @@ 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/1A scheme +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/1A scheme +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/1A scheme +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/1A scheme +sort-key=Panel-A10a +type=logical + [namelist:blayer=zhloc_depth_fac] 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 01e65a2b91..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 @@ -31,3 +31,48 @@ 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): + mixing_method = self.get_setting_value( + config, ["namelist:mixing", "method"] + ) + 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/bl_exp1a_alg_mod.x90 b/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90 new file mode 100644 index 0000000000..45cb2df0ed --- /dev/null +++ b/interfaces/physics_schemes_interface/source/algorithm/bl_exp1a_alg_mod.x90 @@ -0,0 +1,481 @@ +!------------------------------------------------------------------------------- +! (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[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 + 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 + type( field_type ), intent( out ) :: leonard_klm_tke + type( field_type ), intent( out ) :: leonard_klh_tke + + 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) + call theta%copy_field_properties(leonard_klm_tke) + call rho%copy_field_properties(leonard_klh_tke) + + 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, & + 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, & + 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..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 @@ -27,45 +27,59 @@ 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 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 :: 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) 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 +89,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 +112,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 +126,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..8d6a18403e --- /dev/null +++ b/interfaces/physics_schemes_interface/source/kernel/bl_exp1a_kernel_mod.F90 @@ -0,0 +1,1260 @@ +!----------------------------------------------------------------------------- +! (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, 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 + 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(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 + 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), &! 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 + 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] 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 + !> @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, & + 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, & + 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, & + leonard_klm_tke, & + 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, & + 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 + 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 + + 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 + ! 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,leonard_kl_tke & + ) + + 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 + 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 + 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..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 @@ -29,7 +29,32 @@ 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, & + 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, & + 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, & + use_l_sq, & + 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, & cbl_mix_fac, & @@ -194,14 +219,10 @@ 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, & - leonard_term + use mixing_config_mod, only : smagorinsky, & + mix_factor_in => mix_factor, & + leonard_term, & + leonard_tke use radiation_config_mod, only : topography, topography_horizon @@ -292,6 +313,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 +324,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 +382,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 +396,14 @@ 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, 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, & @@ -645,8 +677,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 +692,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,60 +709,7 @@ 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 - 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) @@ -768,17 +726,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 +744,185 @@ 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 + 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 + tke_cm_mx = 0.1_r_bl + tke_cm_fa = 0.1_r_bl + tke_dlen = ddf_length + + end if end if ! ---------------------------------------------------------------- @@ -1601,31 +1712,59 @@ 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 ( blending_9c ) + + case( blending_9c_3d_smag ) + l_subfilter_horiz = .true. + l_subfilter_vert = .true. + blending_option = off + non_local_bl = off + ng_stress = off + case( blending_9c_2d_smag ) + l_subfilter_horiz = .true. + l_subfilter_vert = .false. + blending_option = off + case( blending_9c_blend_smag_fa ) + l_subfilter_horiz = .true. + l_subfilter_vert = .true. + blending_option = blend_allpoints + case( blending_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 ( blending_1a ) + + case( blending_1a_3d_smag ) + l_3dtke = .false. + l_subfilter_horiz = .true. + l_subfilter_vert = .true. + blending_option = off + case( blending_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 + + l_use_l_sq = use_l_sq + end select + + end if else ! not Smagorinsky + l_3dtke = .false. + ! Switches for Smagorinsky being off blending_option = off l_subfilter_horiz = .false. @@ -1637,6 +1776,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/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/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/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..260702093f --- /dev/null +++ b/rose-stem/app/lfric_atm/opt/rose-app-3dte.conf @@ -0,0 +1,225 @@ +[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' +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. +!!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 +!!reduce_fa_mix='inv_only' +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 +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/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 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({ 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..6ae5db5451 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 @@ -3690,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 @@ -3698,33 +3720,6 @@ help=Typical value is 1.0 sort-key=Panel-A10 type=real -[namelist:mixing=method] -compulsory=true -description=Smagorinsky subgrid mixing scheme option -!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 @@ -3757,7 +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: .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.; @@ -5389,7 +5385,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/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 b3079f19cb..784246cee6 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 @@ -86,41 +97,56 @@ 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 :: 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 ! 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' ) + 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) + 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 +168,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 +208,7 @@ subroutine leonard_term_alg(config, & w_physics, & stencil_depth, & dtrdz_tq_bl, & - kl, & + klh, & wetrho_in_w3, & height_w3, & planet_radius, & @@ -185,6 +225,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 +235,6 @@ subroutine leonard_term_alg(config, & face_selector_ew, & face_selector_ns, & planet_radius, & - leonard_kl, & dt, bl_levels ), & !-------------------------------------------------------------------- @@ -212,7 +252,7 @@ subroutine leonard_term_alg(config, & velocity_w2v, & stencil_depth, & dtrdz_tq_bl, & - kl, & + klh, & rho, & height_w3, & planet_radius, & @@ -231,7 +271,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 3b306f65c3..830faa1e76 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, & @@ -279,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 @@ -874,15 +877,25 @@ 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, & + leonard_klm_tke, leonard_klh_tke, & + clock) + end if end if !-------------------------------------------------------------------- @@ -929,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/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 6c2ffd64dc..0274b6bf15 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, & @@ -542,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) @@ -551,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 @@ -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_pos), 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_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_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_gen), ckp=checkpoint_flag, & + empty = is_empty)) + !======================================================================== ! Fields owned by the convection scheme !======================================================================== @@ -785,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))) !======================================================================== @@ -814,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)) @@ -1199,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 @@ -1368,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)) @@ -1454,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 @@ -1498,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. @@ -1507,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 @@ -1530,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, & @@ -1641,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. @@ -1684,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 @@ -1898,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/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 81a5e5c019..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,8 +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_3d_smag, & - smag_l_calc, smag_l_calc_UseDx + use mixing_config_mod, only : smag_l_calc, smag_l_calc_UseDx implicit none @@ -49,13 +48,14 @@ contains viscosity_mu = 0.0_r_def, & smagorinsky = .false., & mix_factor = 0.2_r_def, & - method = method_3d_smag, & + leonard_tke = .false., & 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, & @@ -152,7 +152,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 @@ -162,7 +162,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/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..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,7 +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_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 @@ -50,13 +50,14 @@ contains viscosity_mu = 0.0_r_def, & smagorinsky = .false., & mix_factor = 0.2_r_def, & - method = method_3d_smag, & + leonard_tke = .false., & 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/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") 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..96c1ce0f54 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/bdy_expl2_1a.F90 @@ -0,0 +1,1290 @@ +! *****************************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: r_bl + +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, & +! 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, & + zh_prev,ho2r2_orog,sd_orog, & +! 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, 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,leonard_kl_tke & + ) + +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, & + 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: & + 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: & + 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 + +! Declaration of new BL diagnostics. +type (strnewbldiag), intent(in out) :: BL_diag + +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, & + 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=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, & + 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=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) + + u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end), & + ! IN Surface friction velocity + ! (m/s) + 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 + 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=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 + 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=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) + 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=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). + 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=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=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, & + 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=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),& + ! 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 + ! 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=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), & + ! 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=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 + 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 :- + +! 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=r_bl) :: & + 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), & + 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=r_bl), allocatable :: visc_h_rho (:,:,:) + ! visc_h on rho levels + +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 + ! 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 + ! 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) 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) 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) 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 + +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=r_bl) :: & + 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=r_bl) :: & + lambda_min + ! Min value of length scale LAMBDA. + +! Local scalars :- +real(kind=r_bl) :: & + weight1, & + weight2, & + weight3, & + r_weight1, & + zpr, & + ! z/sigma_h + slope, & + ! subgrid orographic slope + grcp ! G/CP + +integer :: & + i,j, & + ! LOCAL Loop counter (horizontal field index). + k,ient, & + ! LOCAL Loop counter (vertical level index). + 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 +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 + 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 + 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 + 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 + + +! 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 / (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) & + + 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 + + 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 + +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 + + +!------------------------------------------------------------------ +! call main subroutines +!------------------------------------------------------------------ +if (bdy_tke == mymodel25 .or. bdy_tke == mymodel3) then + call mym_ctl( & + !in levels/switches + 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, 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 + visc_m, visc_h, rhogamu, rhogamv, rhogamt, rhogamq, leonard_kl_tke) +else if (bdy_tke == deardorff) then + call ddf_ctl( & + ! IN levels/switches + 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, delta_smag, & + 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) ) + ri(i, j, k) = max(min(ri(i,j,k),max_ri),-max_ri) + 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,BL_diag, & + ! IN fields + 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 + 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 = 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) + 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) .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 + + ! 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) = 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 + + 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) = 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 + + 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 = 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) + 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 +!----------------------------------------------------------------------- +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, & + 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 + 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 + +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..869519b49f --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/ddf_ctl.F90 @@ -0,0 +1,692 @@ +! *****************************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: r_bl + +implicit none + +character(len=*), parameter, private :: ModuleName = 'DDF_CTL_MOD' +contains + +subroutine ddf_ctl( & +! IN levels/switches + 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, 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 +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 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 + +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_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 + 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), & + ! 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=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 + 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 + ! Loop indexes + +real(kind=r_bl) :: & + 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=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, & + 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=r_bl), parameter :: & + c_corr = 2.0 + ! coefficient appeared in parameterizing the width + ! of the bi-normal distribution function + +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' + +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) 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, 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 + 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 + zhpar_shcu(i, j) = z_tq(i, j, tke_levels-1) + end do + end do + end if + 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, 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 + coef_cm = tke_cm_mx + else + coef_cm = tke_cm_fa + 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 + +! 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, & + 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, 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, 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 + 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 / (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) + 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 / (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 + +! 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 + + +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..e2e750664a --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/ddf_initialize.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 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: r_bl + +implicit none + +character(len=*), parameter, private :: ModuleName = 'DDF_INITIALIZE_MOD' +contains + +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, & + 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=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_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 + 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), & + ! 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=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 :: & + i, j, k, ll, & + itr_ini + +real(kind=r_bl) :: & + r_pr, & + elq, & + sm, & + sh, & + gm, & + gh + +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, & + 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=r_bl), 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, 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 + 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, 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 + 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_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 + + 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..ce6a37aca1 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/ddf_mix_length.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 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: r_bl + +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, delta_smag, 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=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), & + ! 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 + 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), & + ! 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=r_bl), 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=r_bl) :: & + 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=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 + +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, 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 + 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..1b0230f7b4 --- /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: r_bl + +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=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 + ! 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=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 + 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=r_bl) :: & + zeta, & + ! non-dimensional height + tmp + ! work variable + +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=r_bl), 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=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 + +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..dacc47757c --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_condensation.F90 @@ -0,0 +1,426 @@ +! *****************************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: r_bl + +implicit none + +character(len=*), parameter, private :: ModuleName = 'MYM_CONDENSATION_MOD' +contains + +subroutine mym_condensation( & +! IN levels/switches + 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 +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 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=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), & + ! 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 + +! Declaration of BL diagnostics. +type (strnewbldiag), intent(in out) :: BL_diag + +! Intent OUT Variables +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 + ! 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 + ! loop indexes +real(kind=r_bl) :: & + 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=r_bl) :: & + 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=r_bl), 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=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' + +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 + + +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..4e92facfe0 --- /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: r_bl + +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=r_bl) :: & + 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..b3a1a1d876 --- /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: r_bl + +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..e40294c96c --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_ctl.F90 @@ -0,0 +1,647 @@ +! *****************************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: r_bl + +implicit none + +character(len=*), parameter, private :: ModuleName = 'MYM_CTL_MOD' +contains + +subroutine mym_ctl( & +! IN levels/switches + 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, 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 + 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 +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 + +! 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=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_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) 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) 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) 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) 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) 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 + 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) + 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 + +! Intent INOUT variables +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 + 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 +! 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 + +! Intent Out Variables +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, & + 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 +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 :: & + i, j, k + ! loop indexes + +logical, save :: & + l_first = .true. + ! flag to indicate if it is the first execution +real(kind=r_bl) :: & + 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=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) + 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) 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 + 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) 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, delta_smag, & + ! 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 + + 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 + +! 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, & + 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, & + 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 + +call mym_turbulence( & +! IN levels/switches + 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, delta_smag, & + 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, leonard_kl_tke) + +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 / (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) + 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 / (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 + 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 + +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..496b26ff82 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_diff_matcoef.F90 @@ -0,0 +1,210 @@ +! *****************************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: r_bl + +implicit none + +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) + +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 + +! Intent IN Variables +integer, intent(in) :: & + bl_levels + ! Max. no. of "boundary" level + +real(kind=r_bl), intent(in) :: & + coef + ! factor for the diffusion coefficients to those for + ! momentum + +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_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 + +! Intent OUT variables +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), & + ! 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=r_bl) :: & + km_m1, & + ! diffusion coefficient on lower level by one + km_p1 + ! diffusion coefficient on upper level by one + +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 + 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) + +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 / (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 + +! 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) & + / (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 + 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..eea8a4c311 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_errfunc.F90 @@ -0,0 +1,136 @@ +! *****************************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: r_bl + +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=r_bl), intent(in) :: x(nn) ! input array + +real(kind=r_bl), intent(out) :: y(nn) ! output array + +! Local Variables +integer :: i ! Loop index + +real(kind=r_bl), 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=r_bl) :: & + x01, & + ! x with upper limit + 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=r_bl), parameter :: & + 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 + +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 + 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) = x01 * ( & + + c01 & + - c03 * x02 & + + c05 * x04 & + - c07 * x06 & + + c09 * x08 & + - c11 * x10 & + + c13 * x12) + if (x01 > 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..24fc7e19ca --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_ex_flux_tq.F90 @@ -0,0 +1,144 @@ +! *****************************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: r_bl + +implicit none + +character(len=*), parameter, private :: ModuleName = 'MYM_EX_FLUX_TQ_MOD' +contains + +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 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 + +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), & + ! 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=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 + ! 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=r_bl) :: & + 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 + +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..95fb47cd5e --- /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: r_bl + +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=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 + ! 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=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 + ! 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=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) + 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..410b3954fb --- /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: r_bl + +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=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 + 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 + ! 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 + +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) + 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..b53f81b76d --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_initialize.F90 @@ -0,0 +1,505 @@ +! *****************************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: r_bl, 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, delta_smag, & +! 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=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_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) + 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=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 + 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=r_bl) :: & + phm, & + ! gradient function at the surface + elq + ! mixing length * qkw + +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) + 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=r_bl) :: & + 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 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 + 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, 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 + 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, z_uv, z_tq, dfm, & + aa_qke, bb_qke, cc_qke) + + 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 + 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_r_bl),& + 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_r_bl),& + 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..7c819eee37 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_length.F90 @@ -0,0 +1,228 @@ +! *****************************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: r_bl + +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, delta_smag, 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, l_use_l_sq +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) :: & + 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=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 + 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 + 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) + ! Surface buoyancy flux over + ! density (m^2/s^3) + +! Intent OUT Variables +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) + ! mixing length on theta level K-1 + +! Local variables + +integer :: & + i, j, k + ! Loop indexes +real(kind=r_bl) :: & + 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) + 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 + ! of TKE (L_T) + vsc(row_length, rows) + ! work arrays + +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 + +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) + 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 + 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..64632bd686 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_level2.F90 @@ -0,0 +1,144 @@ +! *****************************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: r_bl + +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=r_bl), 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=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) + 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=r_bl) :: & + ri, & + ! gradient Richardson Number + 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 + +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 ) + ri = min( ri, ri_max ) + ! 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_option_mod.F90 b/science/physics_schemes/source/boundary_layer/mym_option_mod.F90 index 348dccb562..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,9 +16,9 @@ !--------------------------------------------------------------------- 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: real_umphys +use um_types, only: r_bl implicit none @@ -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 @@ -62,7 +64,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 +85,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 +102,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 @@ -121,6 +123,20 @@ 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 :: & +! 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 !======================================================================= @@ -136,14 +152,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 new file mode 100644 index 0000000000..f0f1b34ea3 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_shcu_buoy.F90 @@ -0,0 +1,902 @@ +! *****************************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: r_bl, real_eps + +implicit none + +character(len=*), parameter, private :: ModuleName = 'MYM_SHCU_BUOY_MOD' +contains + +subroutine mym_shcu_buoy( & +! IN levels/switches + bl_levels, & + 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 +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 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=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), & + ! surface friction velocity + pstar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) + ! surface pressure (Pa) + +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 + 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=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), & + ! 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 + +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 + +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 + ! (:,:,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' + +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), & + ! 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=r_bl) :: & + 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=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), & + ! 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=r_bl) :: & + 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=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 + +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) + !----------------------------------------------------------------------- + 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)) * & + ( 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 + +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..128e36d01a --- /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: r_bl + +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=r_bl), 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=r_bl), 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..3a403f7191 --- /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: r_bl + +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=r_bl), 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=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(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_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 new file mode 100644 index 0000000000..9d69b41ad7 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_solve_simeq.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 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: r_bl + +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, 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 +integer, intent(in) :: & + bl_levels + ! Max. no. of "boundary" level + +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), & + 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=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 + ! (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=r_bl) :: & + ! 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=r_bl), parameter :: & + eps = 1.0e-15 + ! convergence creteria + +real(kind=r_bl), 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 + + 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. + 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..cd93d202d0 --- /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: r_bl + +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=r_bl), intent(in) :: & + eps + ! convergence condition + +real(kind=r_bl), 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=r_bl), 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=r_bl) :: & + 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=r_bl) :: & + 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_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 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..67ff6790d1 --- /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: r_bl + +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=r_bl), 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=r_bl), 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..d2177443bb --- /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: r_bl + +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=r_bl), 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=r_bl), 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=r_bl) :: & + wk + ! work variables + +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 + +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..eecd25eb77 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_turbulence.F90 @@ -0,0 +1,1258 @@ +! *****************************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: r_bl + +implicit none + +character(len=*), parameter, private :: ModuleName = 'MYM_TURBULENCE_MOD' + +contains + +subroutine mym_turbulence( & +! IN levels/switches + bl_levels, levflag, BL_diag, & +! IN fields + z_uv, z_tq, & + vq, vt, gtr, fqw, ftl, wb_ng, & + 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, 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,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_leonard_tke, & + deardorff, mymodel2, mymodel25, mymodel3 + +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 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 + ! 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_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) 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) 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) 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 + dudz(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, & + 2:bl_levels), & + ! Gradient of u at theta levels. + !(:,:,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) 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), & + ! 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 + +! Intent INOUT Variables +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 + 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=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 + ! 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 +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 +integer :: & + i, j, k, k_start, k_start_cor + ! Loop indexes + +real(kind=r_bl) :: & + 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=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) + 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 squared + ghel(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end, & + tke_levels), & + ! 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) + 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=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.) + 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' + +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 + +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) + +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 + 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) + ! 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 + 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 + ! 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) + 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 + ! 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) & + * 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 (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 == 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) & + * 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 + 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) & + - 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 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) & + * 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 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 + + ! 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 + 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 + ! 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) + + 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 + + ! 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 + do i = tdims%i_start, tdims%i_end + + 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)) + + 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 == mymodel3 + +! 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_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 + +if (levflag == mymodel3) then + ! Integrate the covariances + + if (imp_mode == full_impl) then + call mym_update_covariance( & + ! 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 + 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, z_uv, z_tq, dfm, rp_tsq, bp_tsq,tsq) + + call mym_update_fields( & + bl_levels, coef_trbvar_diff, z_uv, z_tq, dfm, rp_qsq, bp_qsq,qsq) + + 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) + + end if ! if imp_mode == FULL_IMPL +else ! level 2.5 + ! In level 2.5, tsq, qsq, cov are diagnosed assuming balance between + ! 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 + 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 >= mymodel25) 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 == 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 + 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) + ! 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 & + * (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 == mymodel3 + + 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, z_uv, z_tq, 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 >= mymodel25 + +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 + +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..f763c9a070 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_update_covariance.F90 @@ -0,0 +1,270 @@ +! *****************************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: r_bl + +implicit none + +character(len=*), parameter, private :: ModuleName = 'MYM_UPDATE_COVARIANCE_MOD' +contains + +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, 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) :: & + bl_levels + ! Max. no. of "boundary" level + +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_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) + 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=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 + ! (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=r_bl) :: & + elem + ! work variables + +real(kind=r_bl) :: & + disp_coef + ! coefficients of the prognostic variables in + ! dissipation terms + +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), & + ! 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, z_uv, z_tq, 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..494f24f028 --- /dev/null +++ b/science/physics_schemes/source/boundary_layer/mym_update_fields.F90 @@ -0,0 +1,122 @@ +! *****************************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: r_bl + +implicit none + +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) + +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=r_bl), intent(in) :: & + coef + ! factor for the diffusion coefficients to those for + ! momentum + +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, & + 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 + 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=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 :: & + i, j, k, k_start + ! Loop indexes + +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 + +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, z_uv, z_tq, 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