Line data Source code
1 : !-----------------------------------------------------------------------
2 : ! $Id$
3 : !===============================================================================
4 : module advance_xm_wpxp_module
5 :
6 : ! Description:
7 : ! Contains the CLUBB advance_xm_wpxp_module scheme.
8 :
9 : ! References:
10 : ! None
11 : !-----------------------------------------------------------------------
12 :
13 : implicit none
14 :
15 : private ! Default scope
16 :
17 : public :: advance_xm_wpxp
18 :
19 : private :: xm_wpxp_lhs, &
20 : xm_wpxp_rhs, &
21 : xm_wpxp_solve, &
22 : xm_wpxp_clipping_and_stats, &
23 : xm_term_ta_lhs, &
24 : wpxp_term_tp_lhs, &
25 : wpxp_terms_ac_pr2_lhs, &
26 : wpxp_term_pr1_lhs, &
27 : wpxp_terms_bp_pr3_rhs, &
28 : xm_correction_wpxp_cl, &
29 : damp_coefficient, &
30 : diagnose_upxp, &
31 : error_prints_xm_wpxp
32 :
33 : ! Parameter Constants
34 : integer, parameter, private :: &
35 : nsub = 2, & ! Number of subdiagonals in the LHS matrix
36 : nsup = 2, & ! Number of superdiagonals in the LHS matrix
37 : xm_wpxp_thlm = 1, & ! Named constant for thlm and wpthlp solving
38 : xm_wpxp_rtm = 2, & ! Named constant for rtm and wprtp solving
39 : xm_wpxp_scalar = 3, & ! Named constant for sclrm and wpsclrp solving
40 : xm_wpxp_um = 4, & ! Named constant for optional um and upwp solving
41 : xm_wpxp_vm = 5 ! Named constant for optional vm and vpwp solving
42 :
43 : integer, parameter :: &
44 : ndiags2 = 2, &
45 : ndiags3 = 3, &
46 : ndiags5 = 5
47 :
48 : contains
49 :
50 : !=============================================================================
51 352944 : subroutine advance_xm_wpxp( nz, ngrdcol, gr, dt, sigma_sqd_w, wm_zm, wm_zt, wp2, &
52 352944 : Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, Kh_zm, &
53 352944 : invrs_tau_C6_zm, tau_max_zm, Skw_zm, wp2rtp, rtpthvp, &
54 352944 : rtm_forcing, wprtp_forcing, rtm_ref, wp2thlp, &
55 352944 : thlpthvp, thlm_forcing, wpthlp_forcing, thlm_ref, &
56 352944 : rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, &
57 352944 : invrs_rho_ds_zt, thv_ds_zm, rtp2, thlp2, &
58 352944 : w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, &
59 352944 : mixt_frac_zm, l_implemented, em, wp2sclrp, &
60 352944 : sclrpthvp, sclrm_forcing, sclrp2, exner, rcm, &
61 352944 : p_in_Pa, thvm, Cx_fnc_Richardson, &
62 352944 : ice_supersat_frac, &
63 : pdf_implicit_coefs_terms, &
64 352944 : um_forcing, vm_forcing, ug, vg, wpthvp, &
65 352944 : fcor, um_ref, vm_ref, up2, vp2, &
66 352944 : uprcp, vprcp, rc_coef, &
67 : clubb_params, nu_vert_res_dep, &
68 : iiPDF_type, &
69 : penta_solve_method, &
70 : tridiag_solve_method, &
71 : l_predict_upwp_vpwp, &
72 : l_diffuse_rtm_and_thlm, &
73 : l_stability_correct_Kh_N2_zm, &
74 : l_godunov_upwind_wpxp_ta, &
75 : l_upwind_xm_ma, &
76 : l_uv_nudge, &
77 : l_tke_aniso, &
78 : l_diag_Lscale_from_tau, &
79 : l_use_C7_Richardson, &
80 : l_brunt_vaisala_freq_moist, &
81 : l_use_thvm_in_bv_freq, &
82 : l_lmm_stepping, &
83 : l_enable_relaxed_clipping, &
84 : l_linearize_pbl_winds, &
85 : l_mono_flux_lim_thlm, &
86 : l_mono_flux_lim_rtm, &
87 : l_mono_flux_lim_um, &
88 : l_mono_flux_lim_vm, &
89 : l_mono_flux_lim_spikefix, &
90 : order_xm_wpxp, order_xp2_xpyp, order_wp2_wp3, &
91 : stats_metadata, &
92 352944 : stats_zt, stats_zm, stats_sfc, &
93 352944 : rtm, wprtp, thlm, wpthlp, &
94 352944 : sclrm, wpsclrp, um, upwp, vm, vpwp, &
95 352944 : um_pert, vm_pert, upwp_pert, vpwp_pert )
96 :
97 : ! Description:
98 : ! Advance the mean and flux terms by one timestep.
99 :
100 : ! References:
101 : ! https://arxiv.org/pdf/1711.03675v1.pdf#nameddest=url:wpxp_eqns
102 : !
103 : ! Eqn. 16 & 17 on p. 3546 of
104 : ! ``A PDF-Based Model for Boundary Layer Clouds. Part I:
105 : ! Method and Model Description'' Golaz, et al. (2002)
106 : ! JAS, Vol. 59, pp. 3540--3551.
107 :
108 : ! See Also
109 : ! ``Equations for CLUBB'' Section 5:
110 : ! /Implicit solutions for the means and fluxes/
111 : !-----------------------------------------------------------------------
112 :
113 : use parameter_indices, only: &
114 : nparams, & ! Variable(s)
115 : iC6rt, &
116 : iC6rtb, &
117 : iC6rtc, &
118 : iC6thl, &
119 : iC6thlb, &
120 : iC6thlc, &
121 : iC6rt_Lscale0, &
122 : iC6thl_Lscale0, &
123 : iC7, &
124 : iC7b, &
125 : iC7c, &
126 : iC7_Lscale0, &
127 : ic_K6, &
128 : iwpxp_L_thresh, &
129 : ialtitude_threshold, &
130 : iC_uu_shr
131 :
132 : use parameters_tunable, only: &
133 : nu_vertical_res_dep ! Type(s)
134 :
135 : use constants_clubb, only: &
136 : fstderr, & ! Constant
137 : one, &
138 : one_half, &
139 : zero, &
140 : eps
141 :
142 : use parameters_model, only: &
143 : sclr_dim, & ! Variable(s)
144 : ts_nudge
145 :
146 : use grid_class, only: &
147 : grid, & ! Type
148 : ddzt ! Procedure(s)
149 :
150 : use grid_class, only: &
151 : zm2zt, & ! Procedure(s)
152 : zt2zm
153 :
154 : use model_flags, only: &
155 : iiPDF_new, & ! Variable(s)
156 : l_explicit_turbulent_adv_wpxp
157 :
158 : use mono_flux_limiter, only: &
159 : calc_turb_adv_range ! Procedure(s)
160 :
161 : use pdf_parameter_module, only: &
162 : implicit_coefs_terms ! Variable Type
163 :
164 : use clubb_precision, only: &
165 : core_rknd ! Variable(s)
166 :
167 : use error_code, only: &
168 : clubb_at_least_debug_level, & ! Procedure
169 : err_code, & ! Error Indicator
170 : clubb_fatal_error ! Constants
171 :
172 : use stats_type_utilities, only: &
173 : stat_begin_update, & ! Procedure(s)
174 : stat_end_update, &
175 : stat_update_var
176 :
177 : use stats_variables, only: &
178 : stats_metadata_type
179 :
180 : use sponge_layer_damping, only: &
181 : rtm_sponge_damp_settings, &
182 : thlm_sponge_damp_settings, &
183 : uv_sponge_damp_settings, &
184 : rtm_sponge_damp_profile, &
185 : thlm_sponge_damp_profile, &
186 : uv_sponge_damp_profile, &
187 : sponge_damp_xm ! Procedure(s)
188 :
189 : use stats_type, only: stats ! Type
190 :
191 : implicit none
192 :
193 : ! -------------------- Input Variables --------------------
194 :
195 : integer, intent(in) :: &
196 : nz, &
197 : ngrdcol
198 :
199 : type (grid), target, intent(in) :: gr
200 :
201 : real( kind = core_rknd ), intent(in) :: &
202 : dt ! Timestep [s]
203 :
204 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz) :: &
205 : sigma_sqd_w, & ! sigma_sqd_w on momentum levels [-]
206 : wm_zm, & ! w wind component on momentum levels [m/s]
207 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
208 : wp2, & ! w'^2 (momentum levels) [m^2/s^2]
209 : Lscale, & ! Turbulent mixing length [m]
210 : em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2]
211 : wp3_on_wp2, & ! Smoothed wp3 / wp2 on momentum levels [m/s]
212 : wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels [m/s]
213 : Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s]
214 : Kh_zm, & ! Eddy diffusivity on momentum levels
215 : invrs_tau_C6_zm, & ! Inverse time-scale on mom. levels applied to C6 term [1/s]
216 : tau_max_zm, & ! Max. allowable eddy dissipation time scale on m-levs [s]
217 : Skw_zm, & ! Skewness of w on momentum levels [-]
218 : wp2rtp, & ! <w'^2 r_t'> (thermodynamic levels) [m^2/s^2 kg/kg]
219 : rtpthvp, & ! r_t'th_v' (momentum levels) [(kg/kg) K]
220 : rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s]
221 : wprtp_forcing, & ! <w'r_t'> forcing (momentum levels) [(kg/kg)/s^2]
222 : rtm_ref, & ! rtm for nudging [kg/kg]
223 : wp2thlp, & ! <w'^2 th_l'> (thermodynamic levels) [m^2/s^2 K]
224 : thlpthvp, & ! th_l'th_v' (momentum levels) [K^2]
225 : thlm_forcing, & ! th_l forcing (thermodynamic levels) [K/s]
226 : wpthlp_forcing, & ! <w'th_l'> forcing (momentum levels) [K/s^2]
227 : thlm_ref, & ! thlm for nudging [K]
228 : rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3]
229 : rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3]
230 : invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg]
231 : invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg]
232 : thv_ds_zm, & ! Dry, base-state theta_v on moment. levs. [K]
233 : ! Added for clipping by Vince Larson 29 Sep 2007
234 : rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2]
235 : thlp2, & ! th_l'^2 (momentum levels) [K^2]
236 : ! End of Vince Larson's addition.
237 : w_1_zm, & ! Mean w (1st PDF component) [m/s]
238 : w_2_zm, & ! Mean w (2nd PDF component) [m/s]
239 : varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2]
240 : varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2]
241 : mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-]
242 :
243 : logical, intent(in) :: &
244 : l_implemented ! Flag for CLUBB being implemented in a larger model.
245 :
246 : ! Additional variables for passive scalars
247 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz,sclr_dim) :: &
248 : wp2sclrp, & ! <w'^2 sclr'> (thermodynamic levels) [Units vary]
249 : sclrpthvp, & ! <sclr' th_v'> (momentum levels) [Units vary]
250 : sclrm_forcing, & ! sclrm forcing (thermodynamic levels) [Units vary]
251 : sclrp2 ! For clipping Vince Larson [Units vary]
252 :
253 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz) :: &
254 : exner, & ! Exner function [-]
255 : rcm, & ! cloud water mixing ratio, r_c [kg/kg]
256 : p_in_Pa, & ! Air pressure [Pa]
257 : thvm, & ! Virutal potential temperature [K]
258 : Cx_fnc_Richardson,& ! Cx_fnc computed from Richardson_num [-]
259 : ice_supersat_frac
260 :
261 : type(implicit_coefs_terms), intent(in) :: &
262 : pdf_implicit_coefs_terms ! Implicit coefs / explicit terms [units vary]
263 :
264 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
265 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
266 : um_forcing, & ! <u> forcing term (thermodynamic levels) [m/s^2]
267 : vm_forcing, & ! <v> forcing term (thermodynamic levels) [m/s^2]
268 : ug, & ! <u> geostrophic wind (thermodynamic levels) [m/s]
269 : vg, & ! <v> geostrophic wind (thermodynamic levels) [m/s]
270 : wpthvp ! <w'thv'> (momentum levels) [m/s K]
271 :
272 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
273 : uprcp, & ! < u' r_c' > [(m kg)/(s kg)]
274 : vprcp, & ! < v' r_c' > [(m kg)/(s kg)]
275 : rc_coef ! Coefficient on X'r_c' in X'th_v' equation [K/(kg/kg)]
276 :
277 : real( kind = core_rknd ), dimension(ngrdcol), intent(in) :: &
278 : fcor ! Coriolis parameter [s^-1]
279 :
280 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
281 : um_ref, & ! Reference u wind component for nudging [m/s]
282 : vm_ref, & ! Reference v wind component for nudging [m/s]
283 : up2, & ! Variance of the u wind component [m^2/s^2]
284 : vp2 ! Variance of the v wind component [m^2/s^2]
285 :
286 : real( kind = core_rknd ), dimension(nparams), intent(in) :: &
287 : clubb_params ! Array of CLUBB's tunable parameters [units vary]
288 :
289 : type(nu_vertical_res_dep), intent(in) :: &
290 : nu_vert_res_dep ! Vertical resolution dependent nu values
291 :
292 : integer, intent(in) :: &
293 : iiPDF_type, & ! Selected option for the two-component normal (double
294 : ! Gaussian) PDF type to use for the w, rt, and theta-l (or
295 : ! w, chi, and eta) portion of CLUBB's multivariate,
296 : ! two-component PDF.
297 : penta_solve_method, & ! Method to solve then penta-diagonal system
298 : tridiag_solve_method ! Specifier for method to solve tridiagonal systems
299 :
300 : logical, intent(in) :: &
301 : l_predict_upwp_vpwp, & ! Flag to predict <u'w'> and <v'w'> along with <u> and <v>
302 : ! alongside the advancement of <rt>, <w'rt'>, <thl>,
303 : ! <wpthlp>, <sclr>, and <w'sclr'> in subroutine
304 : ! advance_xm_wpxp. Otherwise, <u'w'> and <v'w'> are still
305 : ! approximated by eddy diffusivity when <u> and <v> are
306 : ! advanced in subroutine advance_windm_edsclrm.
307 : l_diffuse_rtm_and_thlm, & ! This flag determines whether or not we want CLUBB to do
308 : ! diffusion on rtm and thlm
309 : l_stability_correct_Kh_N2_zm, & ! This flag determines whether or not we want CLUBB to apply
310 : ! a stability correction
311 : l_godunov_upwind_wpxp_ta, & ! This flag determines whether we want to use an upwind
312 : ! differencing approximation rather than a centered
313 : ! differencing for turbulent advection terms.
314 : ! It affects wpxp only.
315 : l_upwind_xm_ma, & ! This flag determines whether we want to use an upwind
316 : ! differencing approximation rather than a centered
317 : ! differencing for turbulent or mean advection terms.
318 : ! It affects rtm, thlm, sclrm, um and vm.
319 : l_uv_nudge, & ! For wind speed nudging
320 : l_tke_aniso, & ! For anisotropic turbulent kinetic energy, i.e. TKE = 1/2
321 : ! (u'^2 + v'^2 + w'^2)
322 : l_diag_Lscale_from_tau, & ! First diagnose dissipation time tau, and then diagnose the
323 : ! mixing length scale as Lscale = tau * tke
324 : l_use_C7_Richardson, & ! Parameterize C7 based on Richardson number
325 : l_brunt_vaisala_freq_moist, & ! Use a different formula for the Brunt-Vaisala frequency in
326 : ! saturated atmospheres (from Durran and Klemp, 1982)
327 : l_use_thvm_in_bv_freq, & ! Use thvm in the calculation of Brunt-Vaisala frequency
328 : l_lmm_stepping, & ! Apply Linear Multistep Method (LMM) Stepping
329 : l_enable_relaxed_clipping, & ! Flag to relax clipping on wpxp in xm_wpxp_clipping_and_stats
330 : l_linearize_pbl_winds, & ! Flag (used by E3SM) to linearize PBL winds
331 : l_mono_flux_lim_thlm, & ! Flag to turn on monotonic flux limiter for thlm
332 : l_mono_flux_lim_rtm, & ! Flag to turn on monotonic flux limiter for rtm
333 : l_mono_flux_lim_um, & ! Flag to turn on monotonic flux limiter for um
334 : l_mono_flux_lim_vm, & ! Flag to turn on monotonic flux limiter for vm
335 : l_mono_flux_lim_spikefix ! Flag to implement monotonic flux limiter code that
336 : ! eliminates spurious drying tendencies at model top
337 :
338 : integer, intent(in) :: &
339 : order_xm_wpxp, &
340 : order_xp2_xpyp, &
341 : order_wp2_wp3
342 :
343 : type (stats_metadata_type), intent(in) :: &
344 : stats_metadata
345 :
346 : ! -------------------- Input/Output Variables --------------------
347 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
348 : stats_zt, &
349 : stats_zm, &
350 : stats_sfc
351 :
352 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz) :: &
353 : rtm, & ! r_t (total water mixing ratio) [kg/kg]
354 : wprtp, & ! w'r_t' [(kg/kg) m/s]
355 : thlm, & ! th_l (liquid water potential temperature) [K]
356 : wpthlp ! w'th_l' [K m/s]
357 :
358 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz,sclr_dim) :: &
359 : sclrm, & ! [Units vary]
360 : wpsclrp ! [Units vary]
361 :
362 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
363 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz) :: &
364 : um, & ! <u>: mean west-east horiz. velocity (thermo. levs.) [m/s]
365 : upwp, & ! <u'w'>: momentum flux (momentum levels) [m^2/s^2]
366 : vm, & ! <v>: mean south-north horiz. velocity (thermo. levs.) [m/s]
367 : vpwp ! <v'w'>: momentum flux (momentum levels) [m^2/s^2]
368 :
369 : ! Variables used to track perturbed version of winds.
370 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(inout) :: &
371 : um_pert, & ! perturbed <u> [m/s]
372 : vm_pert, & ! perturbed <v> [m/s]
373 : upwp_pert, & ! perturbed <u'w'> [m^2/s^2]
374 : vpwp_pert ! perturbed <v'w'> [m^2/s^2]
375 :
376 : ! -------------------- Local Variables --------------------
377 :
378 : ! Parameter Constants
379 : logical, parameter :: &
380 : l_iter = .true. ! True when the means and fluxes are prognosed
381 :
382 : real( kind = core_rknd ) :: &
383 : C6rt, & ! CLUBB tunable parameter C6rt
384 : C6rtb, & ! CLUBB tunable parameter C6rtb
385 : C6rtc, & ! CLUBB tunable parameter C6rtc
386 : C6thl, & ! CLUBB tunable parameter C6thl
387 : C6thlb, & ! CLUBB tunable parameter C6thlb
388 : C6thlc, & ! CLUBB tunable parameter C6thlc
389 : C6rt_Lscale0, & ! CLUBB tunable parameter C6rt_Lscale0
390 : C6thl_Lscale0, & ! CLUBB tunable parameter C6thl_Lscale0
391 : C7, & ! CLUBB tunable parameter C7
392 : C7b, & ! CLUBB tunable parameter C7b
393 : C7c, & ! CLUBB tunable parameter C7c
394 : C7_Lscale0, & ! CLUBB tunable parameter C7_Lscale0
395 : c_K6, & ! CLUBB tunable parameter c_K6
396 : altitude_threshold, & ! CLUBB tunable parameter altitude_threshold
397 : wpxp_L_thresh ! CLUBB tunable parameter wpxp_L_thresh
398 :
399 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
400 705888 : C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc, C6_term
401 :
402 : ! Eddy Diffusion for wpthlp and wprtp.
403 705888 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: Kw6 ! wpxp eddy diff. [m^2/s]
404 :
405 : ! Variables used as part of the monotonic turbulent advection scheme.
406 : ! Find the lowermost and uppermost grid levels that can have an effect
407 : ! on the central thermodynamic level during the course of a time step,
408 : ! due to the effects of turbulent advection only.
409 : integer, dimension(ngrdcol,nz) :: &
410 705888 : low_lev_effect, & ! Index of the lowest level that has an effect.
411 705888 : high_lev_effect ! Index of the highest level that has an effect.
412 :
413 : ! Constant parameters as a function of Skw.
414 :
415 : integer :: &
416 : nrhs ! Number of RHS vectors
417 :
418 : ! Saved values of predictive fields, prior to being advanced, for use in
419 : ! print statements in case of fatal error.
420 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
421 705888 : rtm_old, & ! Saved value of r_t [kg/kg]
422 705888 : wprtp_old, & ! Saved value of w'r_t' [(kg/kg) m/s]
423 705888 : thlm_old, & ! Saved value of th_l [K]
424 705888 : wpthlp_old ! Saved value of w'th_l' [K m/s]
425 :
426 : ! Input/Output Variables
427 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim) :: &
428 705888 : sclrm_old, & ! Saved value of sclr [units vary]
429 705888 : wpsclrp_old ! Saved value of wpsclrp [units vary]
430 :
431 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
432 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
433 705888 : um_old, & ! Saved value of <u> [m/s]
434 705888 : upwp_old, & ! Saved value of <u'w'> [m^2/s^2]
435 705888 : vm_old, & ! Saved value of <v> [m/s]
436 705888 : vpwp_old ! Saved value of <v'w'> [m^2/s^2]
437 :
438 : ! LHS/RHS terms
439 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz) :: &
440 705888 : lhs_diff_zm, & ! Diffusion term for w'x'
441 705888 : lhs_diff_zt, & ! Diffusion term for w'x'
442 705888 : lhs_ma_zt, & ! Mean advection contributions to lhs
443 705888 : lhs_ma_zm ! Mean advection contributions to lhs
444 :
445 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz) :: &
446 705888 : lhs_ta_wprtp, & ! w'r_t' turbulent advection contributions to lhs
447 705888 : lhs_ta_wpthlp, & ! w'thl' turbulent advection contributions to lhs
448 705888 : lhs_ta_wpup, & ! w'u' turbulent advection contributions to lhs
449 705888 : lhs_ta_wpvp ! w'v' turbulent advection contributions to lhs
450 :
451 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz,sclr_dim) :: &
452 705888 : lhs_ta_wpsclrp ! w'sclr' turbulent advection contributions to lhs
453 :
454 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
455 705888 : rhs_ta_wprtp, & ! w'r_t' turbulent advection contributions to rhs
456 705888 : rhs_ta_wpthlp, & ! w'thl' turbulent advection contributions to rhs
457 705888 : rhs_ta_wpup, & ! w'u' turbulent advection contributions to rhs
458 705888 : rhs_ta_wpvp ! w'v' turbulent advection contributions to rhs
459 :
460 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim) :: &
461 705888 : rhs_ta_wpsclrp ! w'sclr' turbulent advection contributions to rhs
462 :
463 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz) :: &
464 705888 : lhs_tp, & ! Turbulent production terms of w'x'
465 705888 : lhs_ta_xm ! Turbulent advection terms of xm
466 :
467 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
468 705888 : lhs_ac_pr2, & ! Accumulation of w'x' and w'x' pressure term 2
469 705888 : lhs_pr1_wprtp, & ! Pressure term 1 for w'r_t' for all grid levels
470 705888 : lhs_pr1_wpthlp, & ! Pressure term 1 for w'thl' for all grid levels
471 705888 : lhs_pr1_wpsclrp ! Pressure term 1 for w'sclr' for all grid levels
472 :
473 : logical :: &
474 : l_scalar_calc ! True if sclr_dim > 0
475 :
476 : integer :: i, j, k
477 :
478 : ! Whether preturbed winds are being solved.
479 : logical :: l_perturbed_wind
480 :
481 : ! -------------------- Begin Code --------------------
482 :
483 : !$acc enter data create( C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc, C6_term, Kw6, &
484 : !$acc low_lev_effect, high_lev_effect, rtm_old, wprtp_old, thlm_old, &
485 : !$acc wpthlp_old, um_old, upwp_old, vm_old, &
486 : !$acc vpwp_old, lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, &
487 : !$acc lhs_ta_wprtp, lhs_ta_wpthlp, lhs_ta_wpup, lhs_ta_wpvp, &
488 : !$acc rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpup, &
489 : !$acc rhs_ta_wpvp, lhs_tp, lhs_ta_xm, lhs_ac_pr2, &
490 : !$acc lhs_pr1_wprtp, lhs_pr1_wpthlp )
491 :
492 : !$acc enter data if( sclr_dim > 0 ) &
493 : !$acc create( sclrm_old, wpsclrp_old, lhs_ta_wpsclrp, &
494 : !$acc rhs_ta_wpsclrp, lhs_pr1_wpsclrp )
495 :
496 352944 : l_perturbed_wind = l_predict_upwp_vpwp .and. l_linearize_pbl_winds
497 :
498 : ! Check whether monotonic flux limiter flags are set appropriately
499 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
500 352944 : if ( l_mono_flux_lim_rtm .and. .not. l_mono_flux_lim_spikefix ) then
501 0 : write(fstderr,*) "l_mono_flux_lim_rtm=T with l_mono_flux_lim_spikefix=F can lead to spikes aloft."
502 0 : err_code = clubb_fatal_error
503 0 : return
504 : end if
505 : end if
506 :
507 : ! Check whether the passive scalars are present.
508 352944 : if ( sclr_dim > 0 ) then
509 0 : l_scalar_calc = .true.
510 : else
511 352944 : l_scalar_calc = .false.
512 : end if
513 :
514 352944 : if ( iiPDF_type == iiPDF_new .and. ( .not. l_explicit_turbulent_adv_wpxp ) ) then
515 0 : nrhs = 1
516 : else
517 352944 : nrhs = 2 + sclr_dim
518 352944 : if ( l_predict_upwp_vpwp ) then
519 352944 : nrhs = nrhs + 2
520 352944 : if ( l_perturbed_wind ) then
521 0 : nrhs = nrhs + 2
522 : endif ! l_perturbed_wind
523 : endif ! l_predict_upwp_vpwp
524 : endif
525 :
526 : ! Save values of predictive fields to be printed in case of crash.
527 352944 : if ( l_lmm_stepping ) then
528 :
529 : !$acc parallel loop gang vector collapse(2) default(present)
530 0 : do k = 1, nz
531 0 : do i = 1, ngrdcol
532 0 : rtm_old(i,k) = rtm(i,k)
533 0 : wprtp_old(i,k) = wprtp(i,k)
534 0 : thlm_old(i,k) = thlm(i,k)
535 0 : wpthlp_old(i,k) = wpthlp(i,k)
536 : end do
537 : end do
538 : !$acc end parallel loop
539 :
540 0 : if ( sclr_dim > 0 ) then
541 : !$acc parallel loop gang vector collapse(3) default(present)
542 0 : do j = 1, sclr_dim
543 0 : do k = 1, nz
544 0 : do i = 1, ngrdcol
545 0 : sclrm_old(i,k,j) = sclrm(i,k,j)
546 0 : wpsclrp_old(i,k,j) = wpsclrp(i,k,j)
547 : end do
548 : end do
549 : end do
550 : !$acc end parallel loop
551 : end if ! sclr_dim > 0
552 :
553 0 : if ( l_predict_upwp_vpwp ) then
554 : !$acc parallel loop gang vector collapse(2) default(present)
555 0 : do k = 1, nz
556 0 : do i = 1, ngrdcol
557 0 : um_old(i,k) = um(i,k)
558 0 : upwp_old(i,k) = upwp(i,k)
559 0 : vm_old(i,k) = vm(i,k)
560 0 : vpwp_old(i,k) = vpwp(i,k)
561 : end do
562 : end do
563 : !$acc end parallel loop
564 : end if ! l_predict_upwp_vpwp
565 :
566 : end if ! l_lmm_stepping
567 :
568 : ! Unpack CLUBB tunable parameters
569 352944 : C6rt = clubb_params(iC6rt)
570 352944 : C6thl = clubb_params(iC6thl)
571 352944 : altitude_threshold = clubb_params(ialtitude_threshold)
572 352944 : wpxp_L_thresh = clubb_params(iwpxp_L_thresh)
573 :
574 352944 : if ( .not. l_diag_Lscale_from_tau ) then
575 :
576 : ! Unpack CLUBB tunable parameters
577 352944 : C6rtb = clubb_params(iC6rtb)
578 352944 : C6rtc = clubb_params(iC6rtc)
579 352944 : C6thlb = clubb_params(iC6thlb)
580 352944 : C6thlc = clubb_params(iC6thlc)
581 352944 : C6rt_Lscale0 = clubb_params(iC6rt_Lscale0)
582 352944 : C6thl_Lscale0 = clubb_params(iC6thl_Lscale0)
583 :
584 : ! Compute C6 as a function of Skw
585 : ! The if...then is just here to save compute time
586 352944 : if ( abs(C6rt-C6rtb) > abs(C6rt+C6rtb)*eps/2 ) then
587 : !$acc parallel loop gang vector collapse(2) default(present)
588 30353184 : do k = 1, nz
589 501287184 : do i = 1, ngrdcol
590 941868000 : C6rt_Skw_fnc(i,k) = C6rtb + ( C6rt - C6rtb ) &
591 1442802240 : * exp( -one_half * (Skw_zm(i,k)/C6rtc)**2 )
592 : end do
593 : end do
594 : !$acc end parallel loop
595 : else
596 : !$acc parallel loop gang vector collapse(2) default(present)
597 0 : do k = 1, nz
598 0 : do i = 1, ngrdcol
599 0 : C6rt_Skw_fnc(i,k) = C6rtb
600 : end do
601 : end do
602 : !$acc end parallel loop
603 : end if
604 :
605 352944 : if ( abs(C6thl-C6thlb) > abs(C6thl+C6thlb)*eps/2 ) then
606 : !$acc parallel loop gang vector collapse(2) default(present)
607 30353184 : do k = 1, nz
608 501287184 : do i = 1, ngrdcol
609 941868000 : C6thl_Skw_fnc(i,k) = C6thlb + ( C6thl - C6thlb ) &
610 1442802240 : * exp( -one_half * (Skw_zm(i,k)/C6thlc)**2 )
611 : end do
612 : end do
613 : !$acc end parallel loop
614 : else
615 : !$acc parallel loop gang vector collapse(2) default(present)
616 0 : do k = 1, nz
617 0 : do i = 1, ngrdcol
618 0 : C6thl_Skw_fnc(i,k) = C6thlb
619 : end do
620 : end do
621 : !$acc end parallel loop
622 : end if
623 :
624 : ! Damp C6 as a function of Lscale in stably stratified regions
625 : call damp_coefficient( nz, ngrdcol, gr, C6rt, C6rt_Skw_fnc, &
626 : C6rt_Lscale0, altitude_threshold, &
627 : wpxp_L_thresh, Lscale, &
628 352944 : C6rt_Skw_fnc )
629 :
630 : call damp_coefficient( nz, ngrdcol, gr, C6thl, C6thl_Skw_fnc, &
631 : C6thl_Lscale0, altitude_threshold, &
632 : wpxp_L_thresh, Lscale, &
633 352944 : C6thl_Skw_fnc )
634 :
635 : else ! l_diag_Lscale_from_tau
636 : !$acc parallel loop gang vector collapse(2) default(present)
637 0 : do k = 1, nz
638 0 : do i = 1, ngrdcol
639 0 : C6rt_Skw_fnc(i,k) = C6rt
640 0 : C6thl_Skw_fnc(i,k) = C6thl
641 : end do
642 : end do
643 : !$acc end parallel loop
644 : endif ! .not. l_diag_Lscale_from_tau
645 :
646 : ! Compute C7_Skw_fnc
647 352944 : if ( l_use_C7_Richardson ) then
648 :
649 : ! New formulation based on Richardson number
650 : !$acc parallel loop gang vector collapse(2) default(present)
651 0 : do k = 1, nz
652 0 : do i = 1, ngrdcol
653 0 : C7_Skw_fnc(i,k) = Cx_fnc_Richardson(i,k)
654 : end do
655 : end do
656 : !$acc end parallel loop
657 :
658 : else
659 :
660 : ! Unpack CLUBB tunable parameters
661 352944 : C7 = clubb_params(iC7)
662 352944 : C7b = clubb_params(iC7b)
663 352944 : C7c = clubb_params(iC7c)
664 352944 : C7_Lscale0 = clubb_params(iC7_Lscale0)
665 :
666 : ! Compute C7 as a function of Skw
667 352944 : if ( abs(C7-C7b) > abs(C7+C7b)*eps/2 ) then
668 : !$acc parallel loop gang vector collapse(2) default(present)
669 30353184 : do k = 1, nz
670 501287184 : do i = 1, ngrdcol
671 500934240 : C7_Skw_fnc(i,k) = C7b + ( C7 - C7b ) * exp( -one_half * (Skw_zm(i,k)/C7c)**2 )
672 : end do
673 : end do
674 : !$acc end parallel loop
675 : else
676 : !$acc parallel loop gang vector collapse(2) default(present)
677 0 : do k = 1, nz
678 0 : do i = 1, ngrdcol
679 0 : C7_Skw_fnc(i,k) = C7b
680 : end do
681 : end do
682 : !$acc end parallel loop
683 : endif
684 :
685 : ! Damp C7 as a function of Lscale in stably stratified regions
686 : call damp_coefficient( nz, ngrdcol, gr, C7, C7_Skw_fnc, &
687 : C7_Lscale0, altitude_threshold, &
688 : wpxp_L_thresh, Lscale, &
689 352944 : C7_Skw_fnc )
690 :
691 : end if ! l_use_C7_Richardson
692 :
693 :
694 352944 : if ( stats_metadata%l_stats_samp ) then
695 :
696 : !$acc update host( C7_Skw_fnc, C6rt_Skw_fnc, C6thl_Skw_fnc )
697 :
698 0 : do i = 1, ngrdcol
699 0 : call stat_update_var( stats_metadata%iC7_Skw_fnc, C7_Skw_fnc(i,:), & ! intent(in)
700 0 : stats_zm(i) ) ! intent(inout)
701 : call stat_update_var( stats_metadata%iC6rt_Skw_fnc, C6rt_Skw_fnc(i,:), & ! intent(in)
702 0 : stats_zm(i) ) ! intent(inout
703 : call stat_update_var( stats_metadata%iC6thl_Skw_fnc, C6thl_Skw_fnc(i,:), & ! intent(in)
704 0 : stats_zm(i) ) ! intent(inout)
705 : end do
706 :
707 : end if
708 :
709 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
710 : ! Assertion check for C7_Skw_fnc
711 : !$acc parallel loop gang vector collapse(2) default(present)
712 30353184 : do k = 1, nz
713 501287184 : do i = 1, ngrdcol
714 500934240 : if ( C7_Skw_fnc(i,k) > one .or. C7_Skw_fnc(i,k) < zero ) then
715 0 : err_code = clubb_fatal_error
716 : end if
717 : end do
718 : end do
719 : !$acc end parallel loop
720 :
721 352944 : if ( err_code == clubb_fatal_error ) then
722 0 : write(fstderr,*) "The C7_Skw_fnc variable is outside the valid range"
723 0 : return
724 : end if
725 : end if
726 :
727 : ! Define the Coefficent of Eddy Diffusivity for the wpthlp and wprtp.
728 : ! Kw6 is used for wpthlp and wprtp, which are located on momentum levels.
729 : ! Kw6 is located on thermodynamic levels.
730 : ! Kw6 = c_K6 * Kh_zt
731 352944 : c_K6 = clubb_params(ic_K6)
732 : !$acc parallel loop gang vector collapse(2) default(present)
733 30353184 : do k = 1, nz
734 501287184 : do i = 1, ngrdcol
735 500934240 : Kw6(i,k) = c_K6 * Kh_zt(i,k)
736 : end do
737 : end do
738 : !$acc end parallel loop
739 :
740 : ! Find the number of grid levels, both upwards and downwards, that can
741 : ! have an effect on the central thermodynamic level during the course of
742 : ! one time step due to turbulent advection. This is used as part of the
743 : ! monotonic turbulent advection scheme.
744 : call calc_turb_adv_range( nz, ngrdcol, gr, dt, &
745 : w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! intent(in)
746 : mixt_frac_zm, & ! intent(in)
747 : stats_metadata, & ! intent(in)
748 : stats_zm, & ! intent(inout)
749 352944 : low_lev_effect, high_lev_effect ) ! intent(out)
750 :
751 :
752 : ! Calculate 1st pressure terms for w'r_t', w'thl', and w'sclr'.
753 : call wpxp_term_pr1_lhs( nz, ngrdcol, C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc, & ! Intent(in)
754 : invrs_tau_C6_zm, l_scalar_calc, & ! Intent(in)
755 352944 : lhs_pr1_wprtp, lhs_pr1_wpthlp, lhs_pr1_wpsclrp ) ! Intent(out)
756 :
757 : !$acc parallel loop gang vector collapse(2) default(present)
758 30353184 : do k = 1, nz
759 501287184 : do i = 1, ngrdcol
760 500934240 : C6_term(i,k) = C6rt_Skw_fnc(i,k) * invrs_tau_C6_zm(i,k)
761 : end do
762 : end do
763 : !$acc end parallel loop
764 :
765 352944 : if ( stats_metadata%l_stats_samp ) then
766 : !$acc update host( C6_term )
767 0 : do i = 1, ngrdcol
768 0 : call stat_update_var( stats_metadata%iC6_term, C6_term(i,:), & ! intent(in)
769 0 : stats_zm(i) ) ! intent(inout)
770 : end do
771 : end if
772 :
773 : call calc_xm_wpxp_ta_terms( nz, ngrdcol, gr, wp2rtp, & ! intent(in)
774 : wp2thlp, wp2sclrp, & ! intent(in)
775 : rho_ds_zt, invrs_rho_ds_zm, rho_ds_zm, & ! intent(in)
776 : sigma_sqd_w, wp3_on_wp2_zt, & ! intent(in)
777 : pdf_implicit_coefs_terms, & ! intent(in)
778 : iiPDF_type, & ! intent(in)
779 : l_explicit_turbulent_adv_wpxp, l_predict_upwp_vpwp, & ! intent(in)
780 : l_scalar_calc, & ! intent(in)
781 : l_godunov_upwind_wpxp_ta, & ! intent(in)
782 : stats_metadata, & ! intent(in)
783 : stats_zt, & ! intent(inout)
784 : lhs_ta_wprtp, lhs_ta_wpthlp, lhs_ta_wpup, & ! intent(out)
785 : lhs_ta_wpvp, lhs_ta_wpsclrp, & ! intent(out)
786 : rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpup, & ! intent(out)
787 352944 : rhs_ta_wpvp, rhs_ta_wpsclrp ) ! intent(out)
788 :
789 : ! Calculate various terms that are the same between all LHS matricies
790 : call calc_xm_wpxp_lhs_terms( nz, ngrdcol, gr, Kh_zm, wm_zm, wm_zt, wp2, & ! In
791 : Kw6, C7_Skw_fnc, invrs_rho_ds_zt, & ! In
792 : invrs_rho_ds_zm, rho_ds_zt, & ! In
793 : rho_ds_zm, l_implemented, em, & ! In
794 : Lscale, thlm, exner, rtm, rcm, p_in_Pa, thvm, & ! In
795 : ice_supersat_frac, & ! In
796 : clubb_params, nu_vert_res_dep, & ! In
797 : l_diffuse_rtm_and_thlm, & ! In
798 : l_stability_correct_Kh_N2_zm, & ! In
799 : l_upwind_xm_ma, & ! In
800 : l_brunt_vaisala_freq_moist, & ! In
801 : l_use_thvm_in_bv_freq, & ! In
802 : lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, & ! Out
803 352944 : lhs_tp, lhs_ta_xm, lhs_ac_pr2 ) ! Out
804 :
805 : ! Setup and decompose matrix for each variable.
806 :
807 352944 : if ( ( iiPDF_type == iiPDF_new ) .and. ( .not. l_explicit_turbulent_adv_wpxp ) ) then
808 :
809 : ! LHS matrices are unique, multiple band solves required
810 : call solve_xm_wpxp_with_multiple_lhs( nz, ngrdcol, gr, dt, l_iter, nrhs, wm_zt, wp2, & ! In
811 : rtpthvp, rtm_forcing, wprtp_forcing, thlpthvp, & ! In
812 : thlm_forcing, wpthlp_forcing, rho_ds_zm, & ! In
813 : rho_ds_zt, invrs_rho_ds_zm, invrs_rho_ds_zt, & ! In
814 : thv_ds_zm, rtp2, thlp2, l_implemented, & ! In
815 : sclrpthvp, sclrm_forcing, sclrp2, & ! In
816 : low_lev_effect, high_lev_effect, C7_Skw_fnc, & ! In
817 : lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, & ! In
818 : lhs_ta_wprtp, lhs_ta_wpthlp, lhs_ta_wpsclrp, & ! In
819 : rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpsclrp, & ! In
820 : lhs_tp, lhs_ta_xm, lhs_ac_pr2, lhs_pr1_wprtp, & ! In
821 : lhs_pr1_wpthlp, lhs_pr1_wpsclrp, & ! In
822 : penta_solve_method, & ! In
823 : tridiag_solve_method, & ! In
824 : l_predict_upwp_vpwp, & ! In
825 : l_diffuse_rtm_and_thlm, & ! In
826 : l_upwind_xm_ma, & ! In
827 : l_tke_aniso, & ! In
828 : l_enable_relaxed_clipping, & ! In
829 : l_mono_flux_lim_thlm, & ! In
830 : l_mono_flux_lim_rtm, & ! In
831 : l_mono_flux_lim_um, & ! In
832 : l_mono_flux_lim_vm, & ! In
833 : l_mono_flux_lim_spikefix, & ! In
834 : order_xm_wpxp, order_xp2_xpyp, order_wp2_wp3, & ! In
835 : stats_metadata, & ! In
836 : stats_zt, stats_zm, stats_sfc, & ! In
837 0 : rtm, wprtp, thlm, wpthlp, sclrm, wpsclrp ) ! Out
838 : else
839 :
840 : ! LHS matrices are equivalent, only one solve required
841 : call solve_xm_wpxp_with_single_lhs( nz, ngrdcol, gr, dt, l_iter, nrhs, wm_zt, wp2, & ! In
842 : invrs_tau_C6_zm, tau_max_zm, & ! In
843 : rtpthvp, rtm_forcing, wprtp_forcing, thlpthvp, & ! In
844 : thlm_forcing, wpthlp_forcing, rho_ds_zm, & ! In
845 : rho_ds_zt, invrs_rho_ds_zm, invrs_rho_ds_zt, & ! In
846 : thv_ds_zm, rtp2, thlp2, l_implemented, & ! In
847 : sclrpthvp, sclrm_forcing, sclrp2, um_forcing, & ! In
848 : vm_forcing, ug, vg, uprcp, vprcp, rc_coef, fcor, & ! In
849 : up2, vp2, & ! In
850 : low_lev_effect, high_lev_effect, & ! In
851 : C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc, & ! In
852 : lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, & ! In
853 : lhs_ta_wprtp, & ! In
854 : rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpup, & ! In
855 : rhs_ta_wpvp, rhs_ta_wpsclrp, & ! In
856 : lhs_tp, lhs_ta_xm, lhs_ac_pr2, lhs_pr1_wprtp, & ! In
857 : lhs_pr1_wpthlp, lhs_pr1_wpsclrp, & ! In
858 : clubb_params(iC_uu_shr), & ! In
859 : penta_solve_method, & ! In
860 : tridiag_solve_method, & ! In
861 : l_predict_upwp_vpwp, & ! In
862 : l_diffuse_rtm_and_thlm, & ! In
863 : l_upwind_xm_ma, & ! In
864 : l_tke_aniso, & ! In
865 : l_enable_relaxed_clipping, & ! In
866 : l_perturbed_wind, & ! In
867 : l_mono_flux_lim_thlm, & ! In
868 : l_mono_flux_lim_rtm, & ! In
869 : l_mono_flux_lim_um, & ! In
870 : l_mono_flux_lim_vm, & ! In
871 : l_mono_flux_lim_spikefix, & ! In
872 : order_xm_wpxp, order_xp2_xpyp, order_wp2_wp3, & ! In
873 : stats_metadata, & ! In
874 : stats_zt, stats_zm, stats_sfc, & ! In
875 : rtm, wprtp, thlm, wpthlp, & ! Out
876 : sclrm, wpsclrp, um, upwp, vm, vpwp, & ! Out
877 352944 : um_pert, vm_pert, upwp_pert, vpwp_pert ) ! Out
878 : end if ! ( ( iiPDF_type == iiPDF_new ) .and. ( .not. l_explicit_turbulent_adv_wpxp ) )
879 :
880 352944 : if ( l_lmm_stepping ) then
881 :
882 : !$acc parallel loop gang vector collapse(2) default(present)
883 0 : do k = 1, nz
884 0 : do i = 1, ngrdcol
885 0 : thlm(i,k) = one_half * ( thlm_old(i,k) + thlm(i,k) )
886 0 : rtm(i,k) = one_half * ( rtm_old(i,k) + rtm(i,k) )
887 0 : wpthlp(i,k) = one_half * ( wpthlp_old(i,k) + wpthlp(i,k) )
888 0 : wprtp(i,k) = one_half * ( wprtp_old(i,k) + wprtp(i,k) )
889 : end do
890 : end do
891 : !$acc end parallel loop
892 :
893 0 : if ( sclr_dim > 0 ) then
894 : !$acc parallel loop gang vector collapse(3) default(present)
895 0 : do j = 1, sclr_dim
896 0 : do k = 1, nz
897 0 : do i = 1, ngrdcol
898 0 : sclrm(i,k,j) = one_half * ( sclrm_old(i,k,j) + sclrm(i,k,j) )
899 0 : wpsclrp(i,k,j) = one_half * ( wpsclrp_old(i,k,j) + wpsclrp(i,k,j) )
900 : end do
901 : end do
902 : end do
903 : !$acc end parallel loop
904 : endif ! sclr_dim > 0
905 :
906 0 : if ( l_predict_upwp_vpwp ) then
907 : !$acc parallel loop gang vector collapse(2) default(present)
908 0 : do k = 1, nz
909 0 : do i = 1, ngrdcol
910 0 : um(i,k) = one_half * ( um_old(i,k) + um(i,k) )
911 0 : vm(i,k) = one_half * ( vm_old(i,k) + vm(i,k) )
912 0 : upwp(i,k) = one_half * ( upwp_old(i,k) + upwp(i,k) )
913 0 : vpwp(i,k) = one_half * ( vpwp_old(i,k) + vpwp(i,k) )
914 : end do
915 : end do
916 : !$acc end parallel loop
917 : end if ! l_predict_upwp_vpwp
918 :
919 : end if ! l_lmm_stepping
920 :
921 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
922 352944 : if ( err_code == clubb_fatal_error ) then
923 :
924 : !$acc update host( sigma_sqd_w, wm_zm, wm_zt, wp2, Lscale, wp3_on_wp2, &
925 : !$acc wp3_on_wp2_zt, Kh_zt, Kh_zm, invrs_tau_C6_zm, Skw_zm, &
926 : !$acc wp2rtp, rtpthvp, rtm_forcing, wprtp_forcing, rtm_ref, wp2thlp, &
927 : !$acc thlpthvp, thlm_forcing, wpthlp_forcing, thlm_ref, rho_ds_zm, &
928 : !$acc rho_ds_zt, invrs_rho_ds_zm, invrs_rho_ds_zt, thv_ds_zm, rtp2, &
929 : !$acc thlp2, w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, &
930 : !$acc mixt_frac_zm, em, wp2sclrp, sclrpthvp, &
931 : !$acc sclrm_forcing, sclrp2, exner, rcm, p_in_Pa, thvm, &
932 : !$acc Cx_fnc_Richardson, um_forcing, vm_forcing, ug, vg, &
933 : !$acc wpthvp, fcor, um_ref, vm_ref, up2, vp2, uprcp, vprcp, rc_coef, &
934 : !$acc rtm, wprtp, thlm, wpthlp, sclrm, wpsclrp, um, upwp, vm, vpwp, &
935 : !$acc rtm_old,wprtp_old, thlm_old, wpthlp_old, sclrm_old, wpsclrp_old, &
936 : !$acc um_old, upwp_old, vm_old, vpwp_old )
937 :
938 0 : do i = 1, ngrdcol
939 0 : call error_prints_xm_wpxp( nz, gr%zm(i,:), gr%zt(i,:), & ! intent(in)
940 0 : dt, sigma_sqd_w(i,:), wm_zm(i,:), wm_zt(i,:), wp2(i,:), & ! intent(in)
941 0 : Lscale(i,:), wp3_on_wp2(i,:), wp3_on_wp2_zt(i,:), & ! intent(in)
942 0 : Kh_zt(i,:), Kh_zm(i,:), invrs_tau_C6_zm(i,:), Skw_zm(i,:), & ! intent(in)
943 0 : wp2rtp(i,:), rtpthvp(i,:), rtm_forcing(i,:), & ! intent(in)
944 0 : wprtp_forcing(i,:), rtm_ref(i,:), wp2thlp(i,:), & ! intent(in)
945 0 : thlpthvp(i,:), thlm_forcing(i,:), & ! intent(in)
946 0 : wpthlp_forcing(i,:), thlm_ref(i,:), rho_ds_zm(i,:), & ! intent(in)
947 0 : rho_ds_zt(i,:), invrs_rho_ds_zm(i,:), & ! intent(in)
948 0 : invrs_rho_ds_zt(i,:), thv_ds_zm(i,:), rtp2(i,:), & ! intent(in)
949 0 : thlp2(i,:), w_1_zm(i,:), w_2_zm(i,:), & ! intent(in)
950 0 : varnce_w_1_zm(i,:), varnce_w_2_zm(i,:), & ! intent(in)
951 0 : mixt_frac_zm(i,:), l_implemented, em(i,:), & ! intent(in)
952 0 : wp2sclrp(i,:,:), sclrpthvp(i,:,:), sclrm_forcing(i,:,:), & ! intent(in)
953 0 : sclrp2(i,:,:), exner(i,:), rcm(i,:), p_in_Pa(i,:), thvm(i,:), & ! intent(in)
954 0 : Cx_fnc_Richardson(i,:), & ! intent(in)
955 : pdf_implicit_coefs_terms, & ! intent(in)
956 0 : um_forcing(i,:), vm_forcing(i,:), ug(i,:), vg(i,:), & ! intent(in)
957 0 : wpthvp(i,:), fcor(i), um_ref(i,:), vm_ref(i,:), up2(i,:), & ! intent(in)
958 : vp2(i,:), uprcp(i,:), vprcp(i,:), rc_coef(i,:), rtm(i,:), & ! intent(in)
959 : wprtp(i,:), thlm(i,:), wpthlp(i,:), sclrm(i,:,:), wpsclrp(i,:,:), & ! intent(in)
960 : um(i,:), upwp(i,:), vm(i,:), vpwp(i,:), rtm_old(i,:), & ! intent(in)
961 : wprtp_old(i,:), thlm_old(i,:), wpthlp_old(i,:), & ! intent(in)
962 : sclrm_old(i,:,:), wpsclrp_old(i,:,:), um_old(i,:), & ! intent(in)
963 : upwp_old(i,:), vm_old(i,:), vpwp_old(i,:), & ! intent(in)
964 0 : l_predict_upwp_vpwp, l_lmm_stepping ) ! intent(in)
965 : end do
966 : end if
967 : end if
968 :
969 352944 : if ( rtm_sponge_damp_settings%l_sponge_damping ) then
970 :
971 : !$acc update host( rtm, rtm_ref )
972 :
973 0 : if ( stats_metadata%l_stats_samp ) then
974 0 : do i = 1, ngrdcol
975 0 : call stat_begin_update( nz, stats_metadata%irtm_sdmp, rtm(i,:) / dt, & ! intent(in)
976 0 : stats_zt(i) ) ! intent(inout)
977 : end do
978 : end if
979 :
980 0 : do i = 1, ngrdcol
981 0 : rtm(i,:) = sponge_damp_xm( nz, dt, gr%zt(i,:), gr%zm(i,:), &
982 0 : rtm_ref(i,:), rtm(i,:), rtm_sponge_damp_profile )
983 : end do
984 :
985 0 : if ( stats_metadata%l_stats_samp ) then
986 0 : do i = 1, ngrdcol
987 0 : call stat_end_update( nz, stats_metadata%irtm_sdmp, rtm(i,:) / dt, & ! intent(in)
988 0 : stats_zt(i) ) ! intent(inout)
989 : end do
990 : end if
991 :
992 : !$acc update device( rtm )
993 :
994 : endif ! rtm_sponge_damp_settings%l_sponge_damping
995 :
996 352944 : if ( thlm_sponge_damp_settings%l_sponge_damping ) then
997 :
998 : !$acc update host( thlm, thlm_ref )
999 :
1000 0 : if ( stats_metadata%l_stats_samp ) then
1001 0 : do i = 1, ngrdcol
1002 0 : call stat_begin_update( nz, stats_metadata%ithlm_sdmp, thlm(i,:) / dt, & ! intent(in)
1003 0 : stats_zt(i) ) ! intent(inout)
1004 : end do
1005 : end if
1006 :
1007 0 : do i = 1, ngrdcol
1008 0 : thlm(i,:) = sponge_damp_xm( nz, dt, gr%zt(i,:), gr%zm(i,:), &
1009 0 : thlm_ref(i,:), thlm(i,:), thlm_sponge_damp_profile )
1010 : end do
1011 :
1012 0 : if ( stats_metadata%l_stats_samp ) then
1013 0 : do i = 1, ngrdcol
1014 0 : call stat_end_update( nz, stats_metadata%ithlm_sdmp, thlm(i,:) / dt, & ! intent(in)
1015 0 : stats_zt(i) ) ! intent(inout)
1016 : end do
1017 : end if
1018 :
1019 : !$acc update device( thlm )
1020 :
1021 : end if ! thlm_sponge_damp_settings%l_sponge_damping
1022 :
1023 352944 : if ( l_predict_upwp_vpwp ) then
1024 :
1025 352944 : if ( uv_sponge_damp_settings%l_sponge_damping ) then
1026 :
1027 : !$acc update host( um, vm, um_ref, vm_ref )
1028 :
1029 0 : if ( stats_metadata%l_stats_samp ) then
1030 0 : do i = 1, ngrdcol
1031 0 : call stat_begin_update( nz, stats_metadata%ium_sdmp, um(i,:) / dt, & ! intent(in)
1032 0 : stats_zt(i) ) ! intent(inout)
1033 : call stat_begin_update( nz, stats_metadata%ivm_sdmp, vm(i,:) / dt, & ! intent(in)
1034 0 : stats_zt(i) ) ! intent(inout)
1035 : end do
1036 : end if
1037 :
1038 0 : do i = 1, ngrdcol
1039 0 : um(i,:) = sponge_damp_xm( nz, dt, gr%zt(i,:), gr%zm(i,:), &
1040 0 : um_ref(i,:), um(i,:), uv_sponge_damp_profile )
1041 : end do
1042 :
1043 0 : do i = 1, ngrdcol
1044 0 : vm(i,:) = sponge_damp_xm( nz, dt, gr%zt(i,:), gr%zm(i,:), &
1045 0 : vm_ref(i,:), vm(i,:), uv_sponge_damp_profile )
1046 : end do
1047 :
1048 0 : if ( stats_metadata%l_stats_samp ) then
1049 0 : do i = 1, ngrdcol
1050 0 : call stat_end_update( nz, stats_metadata%ium_sdmp, um(i,:) / dt, & ! intent(in)
1051 0 : stats_zt(i) ) ! intent(inout)
1052 : call stat_end_update( nz, stats_metadata%ivm_sdmp, vm(i,:) / dt, & ! intent(in)
1053 0 : stats_zt(i) ) ! intent(inout)
1054 : end do
1055 : end if
1056 :
1057 : !$acc update device( um, vm )
1058 :
1059 : end if ! uv_sponge_damp_settings%l_sponge_damping
1060 :
1061 : ! Adjust um and vm if nudging is turned on.
1062 352944 : if ( l_uv_nudge ) then
1063 :
1064 : ! Reflect nudging in budget
1065 0 : if ( stats_metadata%l_stats_samp ) then
1066 : !$acc update host( um, vm )
1067 0 : do i = 1, ngrdcol
1068 0 : call stat_begin_update( nz, stats_metadata%ium_ndg, um(i,:) / dt, & ! intent(in)
1069 0 : stats_zt(i) ) ! intent(inout)
1070 : call stat_begin_update( nz, stats_metadata%ivm_ndg, vm(i,:) / dt, & ! intent(in)
1071 0 : stats_zt(i) ) ! intent(inout)
1072 : end do
1073 : end if
1074 :
1075 : !$acc parallel loop gang vector collapse(2) default(present)
1076 0 : do k = 1, nz
1077 0 : do i = 1, ngrdcol
1078 0 : um(i,k) = um(i,k) - ( ( um(i,k) - um_ref(i,k) ) * (dt/ts_nudge) )
1079 0 : vm(i,k) = vm(i,k) - ( ( vm(i,k) - vm_ref(i,k) ) * (dt/ts_nudge) )
1080 : end do
1081 : end do
1082 : !$acc end parallel loop
1083 :
1084 : ! Reflect nudging in budget
1085 0 : if ( stats_metadata%l_stats_samp ) then
1086 : !$acc update host( um, vm )
1087 0 : do i = 1, ngrdcol
1088 0 : call stat_end_update( nz, stats_metadata%ium_ndg, um(i,:) / dt, & ! intent(in)
1089 0 : stats_zt(i) ) ! intent(inout)
1090 : call stat_end_update( nz, stats_metadata%ivm_ndg, vm(i,:) / dt, & ! intent(in)
1091 0 : stats_zt(i) ) ! intent(inout)
1092 : end do
1093 : end if
1094 :
1095 : end if ! l_uv_nudge
1096 :
1097 352944 : if ( stats_metadata%l_stats_samp ) then
1098 : !$acc update host( um_ref, vm_ref )
1099 0 : do i = 1, ngrdcol
1100 0 : call stat_update_var( stats_metadata%ium_ref, um_ref(i,:), & ! intent(in)
1101 0 : stats_zt(i) ) ! intent(inout)
1102 : call stat_update_var( stats_metadata%ivm_ref, vm_ref(i,:), & ! intent(in)
1103 0 : stats_zt(i) ) ! intent(inout)
1104 : end do
1105 : end if
1106 :
1107 : end if ! l_predict_upwp_vpwp
1108 :
1109 : !$acc exit data delete( C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc, C6_term, Kw6, &
1110 : !$acc low_lev_effect, high_lev_effect, rtm_old, wprtp_old, thlm_old, &
1111 : !$acc wpthlp_old, um_old, upwp_old, vm_old, &
1112 : !$acc vpwp_old, lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, &
1113 : !$acc lhs_ta_wprtp, lhs_ta_wpthlp, lhs_ta_wpup, lhs_ta_wpvp, &
1114 : !$acc rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpup, &
1115 : !$acc rhs_ta_wpvp, lhs_tp, lhs_ta_xm, lhs_ac_pr2, &
1116 : !$acc lhs_pr1_wprtp, lhs_pr1_wpthlp )
1117 :
1118 : !$acc exit data if( sclr_dim > 0 ) &
1119 : !$acc delete( sclrm_old, wpsclrp_old, lhs_ta_wpsclrp, &
1120 : !$acc rhs_ta_wpsclrp, lhs_pr1_wpsclrp )
1121 :
1122 : return
1123 :
1124 : end subroutine advance_xm_wpxp
1125 :
1126 : !======================================================================================
1127 352944 : subroutine xm_wpxp_lhs( nz, ngrdcol, l_iter, dt, wpxp, wm_zt, C7_Skw_fnc, & ! In
1128 : wpxp_upper_lim, wpxp_lower_lim, & ! In
1129 352944 : l_implemented, lhs_diff_zm, lhs_diff_zt, & ! In
1130 352944 : lhs_ma_zm, lhs_ma_zt, lhs_ta_wpxp, lhs_ta_xm, & ! In
1131 352944 : lhs_tp, lhs_pr1, lhs_ac_pr2, & ! In
1132 : l_diffuse_rtm_and_thlm, & ! In
1133 : stats_metadata, & ! In
1134 352944 : lhs ) ! Out
1135 : ! Description:
1136 : ! Compute LHS band diagonal matrix for xm and w'x'.
1137 : ! This subroutine computes the implicit portion of
1138 : ! the xm and w'x' equations.
1139 : !
1140 : !
1141 : ! Notes:
1142 : !
1143 : ! Boundary conditions:
1144 : ! The turbulent flux (wpxp) use fixed-point boundary conditions at both the
1145 : ! upper and lower boundaries. Therefore, anything set in the wpxp loop
1146 : ! at both the upper and lower boundaries would be overwritten here.
1147 : ! However, the wpxp loop does not extend to the boundary levels. An array
1148 : ! with a value of 1 at the main diagonal on the left-hand side and with
1149 : ! values of 0 at all other diagonals on the left-hand side will preserve the
1150 : ! right-hand side value at that level. The value of xm at level k = 1,
1151 : ! which is below the model surface, is preserved and then overwritten to
1152 : ! match the new value of xm at level k = 2.
1153 : !
1154 : ! xm(1) wpxp(1) ... wpxp(nzmax)
1155 : ! [ 0.0 0.0 0.0 ]
1156 : ! [ 0.0 0.0 0.0 ]
1157 : ! [ 1.0 1.0 ... 1.0 ]
1158 : ! [ 0.0 0.0 0.0 ]
1159 : ! [ 0.0 0.0 0.0 ]
1160 : !
1161 : !
1162 : ! LHS turbulent advection (ta) term:
1163 : ! An "over-implicit" weighted time step is applied to this term.
1164 : ! The weight of the implicit portion of this term is controlled by
1165 : ! the factor gamma_over_implicit_ts (abbreviated "gamma" in the
1166 : ! equation in order to balance a weight that is not equal to 1,
1167 : ! such that:
1168 : ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS;
1169 : ! where X is the variable that is being solved for in a predictive
1170 : ! equation (<w'x'> in this case), y(t) is the linearized portion of
1171 : ! the term that gets treated implicitly, and RHS is the portion of
1172 : ! the term that is always treated explicitly. A weight of greater
1173 : ! than 1 can be applied to make the term more numerically stable.
1174 : !
1175 : !
1176 : ! xm: Left-hand side (implicit xm portion of the code).
1177 : !
1178 : ! Thermodynamic subdiagonal (lhs index: t_km1_tdiag)
1179 : ! [ x xm(k-1,<t+1>) ]
1180 : ! Momentum subdiagonal (lhs index: t_km1_mdiag)
1181 : ! [ x wpxp(k-1,<t+1>) ]
1182 : ! Thermodynamic main diagonal (lhs index: t_k_tdiag)
1183 : ! [ x xm(k,<t+1>) ]
1184 : ! Momentum superdiagonal (lhs index: t_k_mdiag)
1185 : ! [ x wpxp(k,<t+1>) ]
1186 : ! Thermodynamic superdiagonal (lhs index: t_kp1_tdiag)
1187 : ! [ x xm(k+1,<t+1>) ]
1188 : !
1189 : !
1190 : ! w'x': Left-hand side (implicit w'x' portion of the code).
1191 : !
1192 : ! Momentum subdiagonal (lhs index: m_km1_mdiag)
1193 : ! [ x wpxp(k-1,<t+1>) ]
1194 : ! Thermodynamic subdiagonal (lhs index: m_k_tdiag)
1195 : ! [ x xm(k,<t+1>) ]
1196 : ! Momentum main diagonal (lhs index: m_k_mdiag)
1197 : ! [ x wpxp(k,<t+1>) ]
1198 : ! Thermodynamic superdiagonal (lhs index: m_kp1_tdiag)
1199 : ! [ x xm(k+1,<t+1>) ]
1200 : ! Momentum superdiagonal (lhs index: m_kp1_mdiag)
1201 : ! [ x wpxp(k+1,<t+1>) ]
1202 : !
1203 : !----------------------------------------------------------------------------------
1204 :
1205 : use constants_clubb, only: &
1206 : gamma_over_implicit_ts, & ! Constant(s)
1207 : one, &
1208 : zero
1209 :
1210 : use clubb_precision, only: &
1211 : core_rknd ! Variable(s)
1212 :
1213 : use clip_semi_implicit, only: &
1214 : clip_semi_imp_lhs ! Procedure(s)
1215 :
1216 : use stats_variables, only: &
1217 : stats_metadata_type
1218 :
1219 : implicit none
1220 :
1221 : !------------------- Input Variables -------------------
1222 : integer, intent(in) :: &
1223 : nz, &
1224 : ngrdcol
1225 :
1226 : real( kind = core_rknd ), intent(in) :: &
1227 : dt ! Timestep [s]
1228 :
1229 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz) :: &
1230 : wpxp, & ! w'x' (momentum levs) at timestep (t) [un vary]
1231 : wm_zt, & ! w wind component on thermo. levels [m/s]
1232 : C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-]
1233 : wpxp_upper_lim, & ! Keeps corrs. from becoming > 1 [un vary]
1234 : wpxp_lower_lim ! Keeps corrs. from becoming < -1 [un vary]
1235 :
1236 : logical, intent(in) :: &
1237 : l_implemented, & ! Flag for CLUBB being implemented in a larger model.
1238 : l_iter
1239 :
1240 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(in) :: &
1241 : lhs_diff_zm, & ! Diffusion term for w'x'
1242 : lhs_diff_zt, & ! Diffusion term for xm
1243 : lhs_ma_zt, & ! Mean advection contributions to lhs
1244 : lhs_ma_zm, & ! Mean advection contributions to lhs
1245 : lhs_ta_wpxp ! Turbulent advection contributions to lhs
1246 :
1247 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz), intent(in) :: &
1248 : lhs_tp, & ! Turbulent production terms of w'x'
1249 : lhs_ta_xm ! Turbulent advection terms of xm
1250 :
1251 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
1252 : lhs_ac_pr2, & ! Accumulation of w'x' and w'x' pressure term 2
1253 : lhs_pr1 ! Pressure term 1 for w'x'
1254 :
1255 : type (stats_metadata_type), intent(in) :: &
1256 : stats_metadata
1257 :
1258 : !------------------- Output Variable -------------------
1259 : real( kind = core_rknd ), intent(out), dimension(nsup+nsub+1,ngrdcol,2*nz) :: &
1260 : lhs ! Implicit contributions to wpxp/xm (band diag. matrix) (LAPACK)
1261 :
1262 : !------------------- Local Variables -------------------
1263 : ! Indices
1264 : integer :: k
1265 : integer :: k_xm, k_wpxp
1266 :
1267 : logical :: l_upper_thresh, l_lower_thresh ! flags for clip_semi_imp_lhs
1268 :
1269 : logical, intent(in) :: &
1270 : l_diffuse_rtm_and_thlm ! This flag determines whether or not we want CLUBB to do diffusion
1271 : ! on rtm and thlm
1272 :
1273 : real (kind = core_rknd) :: &
1274 : invrs_dt
1275 :
1276 : integer :: i
1277 :
1278 : !------------------- Begin Code -------------------
1279 :
1280 : ! Initializations/precalculations
1281 352944 : invrs_dt = 1.0_core_rknd / dt
1282 :
1283 : ! Lower boundary for xm, lhs(:,1)
1284 : !$acc parallel loop gang vector default(present)
1285 5893344 : do i = 1, ngrdcol
1286 5540400 : lhs(1,i,1) = 0.0_core_rknd
1287 5540400 : lhs(2,i,1) = 0.0_core_rknd
1288 5540400 : lhs(3,i,1) = 1.0_core_rknd
1289 5540400 : lhs(4,i,1) = 0.0_core_rknd
1290 5893344 : lhs(5,i,1) = 0.0_core_rknd
1291 : end do
1292 : !$acc end parallel loop
1293 :
1294 : ! Lower boundary for w'x', lhs(:,2)
1295 : !$acc parallel loop gang vector default(present)
1296 5893344 : do i = 1, ngrdcol
1297 5540400 : lhs(1,i,2) = 0.0_core_rknd
1298 5540400 : lhs(2,i,2) = 0.0_core_rknd
1299 5540400 : lhs(3,i,2) = 1.0_core_rknd
1300 5540400 : lhs(4,i,2) = 0.0_core_rknd
1301 5893344 : lhs(5,i,2) = 0.0_core_rknd
1302 : end do
1303 : !$acc end parallel loop
1304 :
1305 : ! Combine xm and w'x' terms into LHS
1306 : !$acc parallel loop gang vector collapse(2) default(present)
1307 30000240 : do k = 2, nz
1308 495393840 : do i = 1, ngrdcol
1309 :
1310 465393600 : k_xm = 2*k - 1 ! xm at odd index values
1311 465393600 : k_wpxp = 2*k ! w'x' at even index values
1312 :
1313 : ! ---- sum xm terms ----
1314 :
1315 465393600 : lhs(1,i,k_xm) = zero
1316 :
1317 465393600 : lhs(2,i,k_xm) = lhs_ta_xm(1,i,k)
1318 :
1319 465393600 : lhs(3,i,k_xm) = invrs_dt
1320 :
1321 465393600 : lhs(4,i,k_xm) = lhs_ta_xm(2,i,k)
1322 :
1323 465393600 : lhs(5,i,k_xm) = zero
1324 :
1325 : ! ---- sum w'x' terms ----
1326 :
1327 465393600 : lhs(1,i,k_wpxp) = lhs_ma_zm(1,i,k) + lhs_diff_zm(1,i,k) &
1328 465393600 : + gamma_over_implicit_ts * lhs_ta_wpxp(1,i,k)
1329 :
1330 465393600 : lhs(2,i,k_wpxp) = lhs_tp(1,i,k)
1331 :
1332 : lhs(3,i,k_wpxp) = lhs_ma_zm(2,i,k) + lhs_diff_zm(2,i,k) + lhs_ac_pr2(i,k) &
1333 465393600 : + gamma_over_implicit_ts * ( lhs_ta_wpxp(2,i,k) + lhs_pr1(i,k) )
1334 :
1335 465393600 : lhs(4,i,k_wpxp) = lhs_tp(2,i,k)
1336 :
1337 : lhs(5,i,k_wpxp) = lhs_ma_zm(3,i,k) + lhs_diff_zm(3,i,k) &
1338 495040896 : + gamma_over_implicit_ts * lhs_ta_wpxp(3,i,k)
1339 :
1340 : end do
1341 : end do
1342 : !$acc end parallel loop
1343 :
1344 : ! Upper boundary for w'x', , lhs(:,2*gr%nz)
1345 : ! These were set in the loop above for simplicity, so they must be set properly here
1346 : !$acc parallel loop gang vector default(present)
1347 5893344 : do i = 1, ngrdcol
1348 5540400 : lhs(1,i,2*nz) = 0.0_core_rknd
1349 5540400 : lhs(2,i,2*nz) = 0.0_core_rknd
1350 5540400 : lhs(3,i,2*nz) = 1.0_core_rknd
1351 5540400 : lhs(4,i,2*nz) = 0.0_core_rknd
1352 5893344 : lhs(5,i,2*nz) = 0.0_core_rknd
1353 : end do
1354 : !$acc end parallel loop
1355 :
1356 : ! LHS time tendency
1357 352944 : if ( l_iter ) then
1358 : !$acc parallel loop gang vector collapse(2) default(present)
1359 29647296 : do k = 2, nz-1
1360 489500496 : do i = 1, ngrdcol
1361 459853200 : k_wpxp = 2*k
1362 489147552 : lhs(3,i,k_wpxp) = lhs(3,i,k_wpxp) + invrs_dt
1363 : end do
1364 : end do
1365 : !$acc end parallel loop
1366 : end if
1367 :
1368 : ! Calculate diffusion terms for all thermodynamic grid level
1369 352944 : if ( l_diffuse_rtm_and_thlm ) then
1370 : !$acc parallel loop gang vector collapse(2) default(present)
1371 0 : do k = 2, nz
1372 0 : do i = 1, ngrdcol
1373 0 : k_xm = 2*k - 1
1374 0 : lhs(1,i,k_xm) = lhs(1,i,k_xm) + lhs_diff_zt(1,i,k)
1375 0 : lhs(3,i,k_xm) = lhs(3,i,k_xm) + lhs_diff_zt(2,i,k)
1376 0 : lhs(5,i,k_xm) = lhs(5,i,k_xm) + lhs_diff_zt(3,i,k)
1377 : end do
1378 : end do
1379 : !$acc end parallel loop
1380 : end if
1381 :
1382 : ! Calculate mean advection terms for all momentum grid level
1383 352944 : if ( .not. l_implemented ) then
1384 : !$acc parallel loop gang vector collapse(2) default(present)
1385 0 : do k = 2, nz
1386 0 : do i = 1, ngrdcol
1387 0 : k_xm = 2*k - 1
1388 0 : lhs(1,i,k_xm) = lhs(1,i,k_xm) + lhs_ma_zt(1,i,k)
1389 0 : lhs(3,i,k_xm) = lhs(3,i,k_xm) + lhs_ma_zt(2,i,k)
1390 0 : lhs(5,i,k_xm) = lhs(5,i,k_xm) + lhs_ma_zt(3,i,k)
1391 : end do
1392 : end do
1393 : !$acc end parallel loop
1394 : end if
1395 :
1396 352944 : return
1397 :
1398 : end subroutine xm_wpxp_lhs
1399 :
1400 : !=============================================================================================
1401 352944 : subroutine calc_xm_wpxp_lhs_terms( nz, ngrdcol, gr, Kh_zm, wm_zm, wm_zt, wp2, & ! In
1402 352944 : Kw6, C7_Skw_fnc, invrs_rho_ds_zt, & ! In
1403 352944 : invrs_rho_ds_zm, rho_ds_zt, & ! In
1404 352944 : rho_ds_zm, l_implemented, em, & ! In
1405 352944 : Lscale, thlm, exner, rtm, rcm, p_in_Pa, thvm, & ! In
1406 352944 : ice_supersat_frac, & ! In
1407 : clubb_params, nu_vert_res_dep, & ! In
1408 : l_diffuse_rtm_and_thlm, & ! In
1409 : l_stability_correct_Kh_N2_zm, & ! In
1410 : l_upwind_xm_ma, & ! In
1411 : l_brunt_vaisala_freq_moist, & ! In
1412 : l_use_thvm_in_bv_freq, & ! In
1413 352944 : lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, & ! Out
1414 352944 : lhs_tp, lhs_ta_xm, lhs_ac_pr2 ) ! Out
1415 : ! Description:
1416 : ! Calculate various xm and w'x' terms. These are general terms that are the same
1417 : ! for multiple LHS matrices, so we save computations by calculating them once
1418 : ! here, then reusing them where needed.
1419 : !
1420 : !-------------------------------------------------------------------------------------------
1421 :
1422 : use grid_class, only: &
1423 : grid, & ! Type
1424 : zm2zt, & ! Procedure(s)
1425 : zt2zm
1426 :
1427 : use parameter_indices, only: &
1428 : nparams, & ! Variable(s)
1429 : ilambda0_stability_coef, &
1430 : ibv_efold
1431 :
1432 : use parameters_tunable, only: &
1433 : nu_vertical_res_dep ! Type(s)
1434 :
1435 : use clubb_precision, only: &
1436 : core_rknd ! Variable(s)
1437 :
1438 : use advance_helper_module, only: &
1439 : calc_stability_correction
1440 :
1441 : use mean_adv, only: &
1442 : term_ma_zt_lhs, &
1443 : term_ma_zm_lhs
1444 :
1445 : use turbulent_adv_pdf, only: &
1446 : xpyp_term_ta_pdf_lhs
1447 :
1448 : use diffusion, only: &
1449 : diffusion_zt_lhs, &
1450 : diffusion_zm_lhs
1451 :
1452 : use constants_clubb, only: &
1453 : zero_threshold, &
1454 : zero
1455 :
1456 : implicit none
1457 :
1458 : !------------------- Input Variables -------------------
1459 : integer, intent(in) :: &
1460 : nz, &
1461 : ngrdcol
1462 :
1463 : type (grid), target, intent(in) :: gr
1464 :
1465 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz) :: &
1466 : Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/s]
1467 : Lscale, & ! Turbulent mixing length [m]
1468 : em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2]
1469 : thlm, & ! th_l (thermo. levels) [K]
1470 : exner, & ! Exner function [-]
1471 : rtm, & ! total water mixing ratio, r_t [-]
1472 : rcm, & ! cloud water mixing ratio, r_c [kg/kg]
1473 : p_in_Pa, & ! Air pressure [Pa]
1474 : thvm, & ! Virtual potential temperature [K]
1475 : wm_zm, & ! w wind component on momentum levels [m/s]
1476 : wm_zt, & ! w wind component on thermo. levels [m/s]
1477 : wp2, & ! w'^2 (momentum levels) [m^2/s^2]
1478 : Kw6, & ! Coef. of eddy diffusivity for w'x' [m^2/s]
1479 : C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-]
1480 : rho_ds_zm, & ! Dry, static density on momentum levs. [kg/m^3]
1481 : rho_ds_zt, &
1482 : invrs_rho_ds_zm, &
1483 : invrs_rho_ds_zt, & ! Inv. dry, static density at t-levs. [m^3/kg]
1484 : ice_supersat_frac
1485 :
1486 : logical, intent(in) :: &
1487 : l_implemented ! Flag for CLUBB being implemented in a larger model.
1488 :
1489 : real( kind = core_rknd ), dimension(nparams), intent(in) :: &
1490 : clubb_params ! Array of CLUBB's tunable parameters [units vary]
1491 :
1492 : type(nu_vertical_res_dep), intent(in) :: &
1493 : nu_vert_res_dep ! Vertical resolution dependent nu values
1494 :
1495 : logical, intent(in) :: &
1496 : l_diffuse_rtm_and_thlm, & ! This flag determines whether or not we want CLUBB to do
1497 : ! diffusion on rtm and thlm
1498 : l_stability_correct_Kh_N2_zm, & ! This flag determines whether or not we want CLUBB to apply
1499 : ! a stability correction
1500 : l_upwind_xm_ma, & ! This flag determines whether we want to use an upwind
1501 : ! differencing approximation rather than a centered
1502 : ! differencing for turbulent or mean advection terms.
1503 : ! It affects rtm, thlm, sclrm, um and vm.
1504 : l_brunt_vaisala_freq_moist, & ! Use a different formula for the Brunt-Vaisala frequency in
1505 : ! saturated atmospheres (from Durran and Klemp, 1982)
1506 : l_use_thvm_in_bv_freq ! Use thvm in the calculation of Brunt-Vaisala frequency
1507 :
1508 : !------------------- Output Variables -------------------
1509 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(out) :: &
1510 : lhs_diff_zm, & ! Diffusion term for w'x'
1511 : lhs_diff_zt, & ! Diffusion term for xm
1512 : lhs_ma_zt, & ! Mean advection contributions to lhs
1513 : lhs_ma_zm ! Mean advection contributions to lhs
1514 :
1515 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz), intent(out) :: &
1516 : lhs_tp, & ! Turbulent production terms of w'x'
1517 : lhs_ta_xm ! Turbulent advection terms of xm
1518 :
1519 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
1520 : lhs_ac_pr2 ! Accumulation of w'x' and w'x' pressure term 2
1521 :
1522 :
1523 : !------------------- Local Variables -------------------
1524 : real (kind = core_rknd), dimension(ngrdcol,nz) :: &
1525 705888 : Kh_N2_zm, &
1526 705888 : K_zm, & ! Coef. of eddy diffusivity at momentum level (k) [m^2/s]
1527 705888 : K_zt, & ! Eddy diffusivity coefficient, thermo. levels [m2/s]
1528 705888 : Kw6_zm ! Eddy diffusivity coefficient, momentum levels [m2/s]
1529 :
1530 : real (kind = core_rknd) :: &
1531 : constant_nu ! controls the magnitude of diffusion
1532 :
1533 : real (kind = core_rknd), dimension(ngrdcol) :: &
1534 705888 : zeros_array
1535 :
1536 : integer :: i, k, b
1537 :
1538 : !------------------- Begin Code -------------------
1539 :
1540 : !$acc enter data create( Kh_N2_zm, K_zm, K_zt, Kw6_zm, zeros_array )
1541 :
1542 : ! Initializations/precalculations
1543 352944 : constant_nu = 0.1_core_rknd
1544 352944 : Kw6_zm = zt2zm( nz, ngrdcol, gr, Kw6 )
1545 :
1546 : !$acc parallel loop gang vector collapse(2) default(present)
1547 30353184 : do k = 1, nz
1548 501287184 : do i = 1, ngrdcol
1549 500934240 : Kw6_zm(i,k) = max( Kw6_zm(i,k), zero_threshold )
1550 : end do
1551 : end do
1552 : !$acc end parallel loop
1553 :
1554 : ! Calculate turbulent advection terms of xm for all grid levels
1555 : call xm_term_ta_lhs( nz, ngrdcol, gr, & ! Intent(in)
1556 : rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
1557 352944 : lhs_ta_xm ) ! Intent(out)
1558 :
1559 :
1560 : ! Calculate turbulent production terms of w'x' for all grid level
1561 : call wpxp_term_tp_lhs( nz, ngrdcol, gr, wp2, & ! Intent(in)
1562 352944 : lhs_tp ) ! Intent(out)
1563 :
1564 : ! Calculate accumulation of w'x' and w'x' pressure term 2 of w'x' for all grid level
1565 : ! https://arxiv.org/pdf/1711.03675v1.pdf#nameddest=url:wpxp_pr
1566 : call wpxp_terms_ac_pr2_lhs( nz, ngrdcol, C7_Skw_fnc, & ! Intent(in)
1567 : wm_zt, gr%invrs_dzm, & ! Intent(in)
1568 352944 : lhs_ac_pr2 ) ! Intent(out)
1569 :
1570 : ! Calculate diffusion terms for all momentum grid level
1571 : call diffusion_zm_lhs( nz, ngrdcol, gr, Kw6, Kw6_zm, nu_vert_res_dep%nu6, & ! Intent(in)
1572 : invrs_rho_ds_zm, rho_ds_zt, & ! Intent(in)
1573 352944 : lhs_diff_zm ) ! Intent(out)
1574 :
1575 : ! Calculate mean advection terms for all momentum grid level
1576 : call term_ma_zm_lhs( nz, ngrdcol, wm_zm, & ! Intent(in)
1577 : gr%invrs_dzm, gr%weights_zm2zt, & ! In
1578 352944 : lhs_ma_zm ) ! Intent(out)
1579 :
1580 : ! Calculate diffusion terms for all thermodynamic grid level
1581 352944 : if ( l_diffuse_rtm_and_thlm ) then
1582 :
1583 0 : if ( l_stability_correct_Kh_N2_zm ) then
1584 :
1585 : call calc_stability_correction( nz, ngrdcol, gr, &
1586 : thlm, Lscale, em, &
1587 : exner, rtm, rcm, &
1588 : p_in_Pa, thvm, ice_supersat_frac, &
1589 : clubb_params(ilambda0_stability_coef), &
1590 : clubb_params(ibv_efold), &
1591 : l_brunt_vaisala_freq_moist, &
1592 : l_use_thvm_in_bv_freq,&
1593 0 : Kh_N2_zm )
1594 :
1595 : !$acc parallel loop gang vector collapse(2) default(present)
1596 0 : do k = 1, nz
1597 0 : do i = 1, ngrdcol
1598 0 : Kh_N2_zm(i,k) = Kh_zm(i,k) / Kh_N2_zm(i,k)
1599 : end do
1600 : end do
1601 : !$acc end parallel loop
1602 :
1603 : else
1604 : !$acc parallel loop gang vector collapse(2) default(present)
1605 0 : do k = 1, nz
1606 0 : do i = 1, ngrdcol
1607 0 : Kh_N2_zm(i,k) = Kh_zm(i,k)
1608 : end do
1609 : end do
1610 : !$acc end parallel loop
1611 : end if
1612 :
1613 0 : K_zt = zm2zt( nz, ngrdcol, gr, K_zm )
1614 :
1615 : !$acc parallel loop gang vector collapse(2) default(present)
1616 0 : do k = 1, nz
1617 0 : do i = 1, ngrdcol
1618 0 : K_zm(i,k) = Kh_N2_zm(i,k) + constant_nu
1619 0 : K_zt(i,k) = max( K_zt(i,k), zero_threshold )
1620 : end do
1621 : end do
1622 : !$acc end parallel loop
1623 :
1624 : !$acc parallel loop gang vector default(present)
1625 0 : do i = 1, ngrdcol
1626 0 : zeros_array(i) = zero
1627 : end do
1628 : !$acc end parallel loop
1629 :
1630 : call diffusion_zt_lhs( nz, ngrdcol, gr, K_zm, K_zt, zeros_array, & ! Intent(in)
1631 : invrs_rho_ds_zt, rho_ds_zm, & ! intent(in)
1632 0 : lhs_diff_zt ) ! Intent(out)
1633 :
1634 : end if
1635 :
1636 : ! Calculate mean advection terms for all thermodynamic grid level
1637 352944 : if ( .not. l_implemented ) then
1638 : call term_ma_zt_lhs( nz, ngrdcol, wm_zt, gr%weights_zt2zm, & ! intent(in)
1639 : gr%invrs_dzt, gr%invrs_dzm, & ! intent(in)
1640 : l_upwind_xm_ma, & ! Intent(in)
1641 0 : lhs_ma_zt ) ! Intent(out)
1642 : end if
1643 :
1644 : !$acc exit data delete( Kh_N2_zm, K_zm, K_zt, Kw6_zm, zeros_array )
1645 :
1646 352944 : return
1647 :
1648 : end subroutine calc_xm_wpxp_lhs_terms
1649 :
1650 : !=============================================================================
1651 1411776 : subroutine xm_wpxp_rhs( nz, ngrdcol, solve_type, l_iter, dt, xm, wpxp, & ! In
1652 1411776 : xm_forcing, wpxp_forcing, C7_Skw_fnc, & ! In
1653 1411776 : xpthvp, rhs_ta, thv_ds_zm, & ! In
1654 1411776 : lhs_pr1, lhs_ta_wpxp, & ! In
1655 : stats_metadata, & ! In
1656 1411776 : stats_zt, stats_zm, & ! In
1657 1411776 : rhs ) ! Out
1658 :
1659 : ! Description:
1660 : ! Compute RHS vector for xm and w'x'.
1661 : ! This subroutine computes the explicit portion of
1662 : ! the xm and w'x' equations.
1663 : !
1664 : ! Notes:
1665 : ! For LHS turbulent advection (ta) term.
1666 : ! An "over-implicit" weighted time step is applied to this term.
1667 : ! The weight of the implicit portion of this term is controlled by
1668 : ! the factor gamma_over_implicit_ts (abbreviated "gamma" in the
1669 : ! expression below). A factor is added to the right-hand side of
1670 : ! the equation in order to balance a weight that is not equal to 1,
1671 : ! such that:
1672 : ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS;
1673 : ! where X is the variable that is being solved for in a predictive
1674 : ! equation (<w'x'> in this case), y(t) is the linearized portion of
1675 : ! the term that gets treated implicitly, and RHS is the portion of
1676 : ! the term that is always treated explicitly. A weight of greater
1677 : ! than 1 can be applied to make the term more numerically stable.
1678 : !
1679 : ! --- THIS SUBROUTINE HAS BEEN OPTIMIZED ---
1680 : ! Significant changes to this routine may adversely affect computational speed
1681 : ! - Gunther Huebler, Aug. 2018, clubb:ticket:834
1682 : !----------------------------------------------------------------------------------
1683 :
1684 : use constants_clubb, only: &
1685 : gamma_over_implicit_ts, & ! Constant(s)
1686 : one, &
1687 : zero
1688 :
1689 : use turbulent_adv_pdf, only: &
1690 : xpyp_term_ta_pdf_lhs, & ! Procedure(s)
1691 : xpyp_term_ta_pdf_rhs
1692 :
1693 : use clubb_precision, only: &
1694 : core_rknd ! Variable(s)
1695 :
1696 : use clip_semi_implicit, only: &
1697 : clip_semi_imp_rhs ! Procedure(s)
1698 :
1699 : use stats_type_utilities, only: &
1700 : stat_update_var, & ! Procedure(s)
1701 : stat_update_var_pt, &
1702 : stat_begin_update_pt, &
1703 : stat_modify_pt
1704 :
1705 : use stats_variables, only: &
1706 : stats_metadata_type
1707 :
1708 : use advance_helper_module, only: &
1709 : set_boundary_conditions_rhs ! Procedure(s)
1710 :
1711 : use stats_type, only: stats ! Type
1712 :
1713 : implicit none
1714 :
1715 : !------------------- Input Variables -------------------
1716 : integer, intent(in) :: &
1717 : nz, &
1718 : ngrdcol
1719 :
1720 : integer, intent(in) :: &
1721 : solve_type ! Variables being solved for.
1722 :
1723 : logical, intent(in) :: l_iter
1724 :
1725 : real( kind = core_rknd ), intent(in) :: &
1726 : dt ! Timestep [s]
1727 :
1728 : ! For "over-implicit" weighted time step.
1729 : ! This vector holds output from the LHS (implicit) portion of a term at a
1730 : ! given vertical level. This output is weighted and applied to the RHS.
1731 : ! This is used if the implicit portion of the term is "over-implicit", which
1732 : ! means that the LHS contribution is given extra weight (>1) in order to
1733 : ! increase numerical stability. A weighted factor must then be applied to
1734 : ! the RHS in order to balance the weight.
1735 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(in) :: &
1736 : lhs_ta_wpxp ! Turbulent advection terms of w'x'
1737 :
1738 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
1739 : xm, & ! xm (thermodynamic levels) [x un]
1740 : wpxp, & ! <w'x'> (momentum levels) [{x un} m/s]
1741 : xm_forcing, & ! xm forcings (thermodynamic levels) [{x un}/s]
1742 : wpxp_forcing, & ! <w'x'> forcing (momentum levs) [{x un} m/s^2]
1743 : C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-]
1744 : xpthvp, & ! x'th_v' (momentum levels) [{x un} K]
1745 : thv_ds_zm, & ! Dry, base-state theta_v on mom. levs. [K]
1746 : lhs_pr1, & ! Pressure term 1 for w'x'
1747 : rhs_ta
1748 :
1749 : type (stats_metadata_type), intent(in) :: &
1750 : stats_metadata
1751 :
1752 : !------------------- InOut Variables -------------------
1753 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
1754 : stats_zt, &
1755 : stats_zm
1756 :
1757 : !------------------- Output Variable -------------------
1758 : real( kind = core_rknd ), intent(out), dimension(ngrdcol,2*nz) :: &
1759 : rhs ! Right-hand side of band diag. matrix. (LAPACK)
1760 :
1761 : !------------------- Local Variables -------------------
1762 :
1763 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
1764 2823552 : rhs_bp_pr3, & ! Buoyancy production of w'x' and w'x' pressure term 3
1765 2823552 : rhs_bp, & ! Buoyancy production of w'x' (stats only)
1766 2823552 : rhs_pr3 ! w'x' pressure term 3 (stats only)
1767 :
1768 : real( kind = core_rknd ) :: &
1769 : invrs_dt
1770 :
1771 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
1772 2823552 : zero_vector ! Vector of 0s
1773 :
1774 : ! Indices
1775 : integer :: k, k_xm, k_wpxp
1776 :
1777 : integer :: &
1778 : ixm_f, &
1779 : iwpxp_bp, &
1780 : iwpxp_pr3, &
1781 : iwpxp_f, &
1782 : iwpxp_sicl, &
1783 : iwpxp_ta, &
1784 : iwpxp_pr1
1785 :
1786 : integer :: i
1787 :
1788 : !------------------- Begin Code -------------------
1789 :
1790 : !$acc enter data create( rhs_bp_pr3 )
1791 :
1792 : ! Initialize output array and precalculate the reciprocal of dt
1793 1411776 : invrs_dt = 1.0_core_rknd / dt
1794 :
1795 : ! Calculate buoyancy production of w'x' and w'x' pressure term 3
1796 : call wpxp_terms_bp_pr3_rhs( nz, ngrdcol, C7_Skw_fnc, thv_ds_zm, xpthvp, & ! intent(in)
1797 1411776 : rhs_bp_pr3 ) ! intent(out)
1798 :
1799 : !$acc parallel loop gang vector default(present)
1800 23573376 : do i = 1, ngrdcol
1801 : ! Set lower boundary for xm
1802 22161600 : rhs(i,1) = xm(i,1)
1803 :
1804 : ! Set lower boundary for w'x'
1805 23573376 : rhs(i,2) = wpxp(i,1)
1806 : end do
1807 : !$acc end parallel loop
1808 :
1809 : ! Combine terms to calculate other values, rhs(3) to rhs(gr%nz-2)
1810 : !$acc parallel loop gang vector collapse(2) default(present)
1811 118589184 : do k = 2, nz-1
1812 1958001984 : do i = 1, ngrdcol
1813 :
1814 1839412800 : k_xm = 2*k - 1
1815 1839412800 : k_wpxp = 2*k
1816 :
1817 : ! RHS time tendency and forcings for xm
1818 : ! Note: xm forcings include the effects of microphysics,
1819 : ! cloud water sedimentation, radiation, and any
1820 : ! imposed forcings on xm.
1821 1839412800 : rhs(i,k_xm) = xm(i,k) * invrs_dt + xm_forcing(i,k)
1822 :
1823 :
1824 : ! Calculate rhs values for w'x' using precalculated terms
1825 1839412800 : rhs(i,k_wpxp) = rhs_bp_pr3(i,k) + wpxp_forcing(i,k) + rhs_ta(i,k) &
1826 : + ( one - gamma_over_implicit_ts ) &
1827 1839412800 : * ( - lhs_ta_wpxp(1,i,k) * wpxp(i,k+1) &
1828 : - lhs_ta_wpxp(2,i,k) * wpxp(i,k) &
1829 1839412800 : - lhs_ta_wpxp(3,i,k) * wpxp(i,k-1) &
1830 7474828608 : - lhs_pr1(i,k) * wpxp(i,k) )
1831 : end do
1832 : end do
1833 : !$acc end parallel loop
1834 :
1835 : !$acc parallel loop gang vector default(present)
1836 23573376 : do i = 1, ngrdcol
1837 : ! Upper boundary for xm
1838 22161600 : rhs(i,2*nz-1) = xm(i,nz) * invrs_dt + xm_forcing(i,nz)
1839 :
1840 : ! Upper boundary for w'x', rhs(2*gr%nz)
1841 23573376 : rhs(i,2*nz) = 0.0_core_rknd
1842 : end do
1843 : !$acc end parallel loop
1844 :
1845 : ! RHS time tendency.
1846 1411776 : if ( l_iter ) then
1847 : !$acc parallel loop gang vector collapse(2) default(present)
1848 118589184 : do k = 2, nz-1
1849 1958001984 : do i = 1, ngrdcol
1850 1839412800 : k_wpxp = 2*k
1851 1956590208 : rhs(i,k_wpxp) = rhs(i,k_wpxp) + wpxp(i,k) * invrs_dt
1852 : end do
1853 : end do
1854 : !$acc end parallel loop
1855 : end if
1856 :
1857 :
1858 1411776 : if ( stats_metadata%l_stats_samp ) then
1859 :
1860 : !$acc update host( lhs_ta_wpxp, xm, wpxp, xm_forcing, wpxp_forcing, &
1861 : !$acc C7_Skw_fnc, xpthvp, thv_ds_zm, lhs_pr1, rhs_ta, rhs )
1862 :
1863 0 : zero_vector = zero
1864 :
1865 0 : select case ( solve_type )
1866 : case ( xm_wpxp_rtm ) ! rtm/wprtp budget terms
1867 0 : ixm_f = stats_metadata%irtm_forcing
1868 0 : iwpxp_bp = stats_metadata%iwprtp_bp
1869 0 : iwpxp_pr3 = stats_metadata%iwprtp_pr3
1870 0 : iwpxp_f = stats_metadata%iwprtp_forcing
1871 0 : iwpxp_sicl = stats_metadata%iwprtp_sicl
1872 0 : iwpxp_ta = stats_metadata%iwprtp_ta
1873 0 : iwpxp_pr1 = stats_metadata%iwprtp_pr1
1874 : case ( xm_wpxp_thlm ) ! thlm/wpthlp budget terms
1875 0 : ixm_f = stats_metadata%ithlm_forcing
1876 0 : iwpxp_bp = stats_metadata%iwpthlp_bp
1877 0 : iwpxp_pr3 = stats_metadata%iwpthlp_pr3
1878 0 : iwpxp_f = stats_metadata%iwpthlp_forcing
1879 0 : iwpxp_sicl = stats_metadata%iwpthlp_sicl
1880 0 : iwpxp_ta = stats_metadata%iwpthlp_ta
1881 0 : iwpxp_pr1 = stats_metadata%iwpthlp_pr1
1882 : case ( xm_wpxp_um ) ! um/upwp budget terms
1883 0 : ixm_f = 0
1884 0 : iwpxp_bp = stats_metadata%iupwp_bp
1885 0 : iwpxp_pr3 = stats_metadata%iupwp_pr3
1886 0 : iwpxp_f = 0
1887 0 : iwpxp_sicl = 0
1888 0 : iwpxp_ta = stats_metadata%iupwp_ta
1889 0 : iwpxp_pr1 = stats_metadata%iupwp_pr1
1890 : case ( xm_wpxp_vm ) ! vm/vpwp budget terms
1891 0 : ixm_f = 0
1892 0 : iwpxp_bp = stats_metadata%ivpwp_bp
1893 0 : iwpxp_pr3 = stats_metadata%ivpwp_pr3
1894 0 : iwpxp_f = 0
1895 0 : iwpxp_sicl = 0
1896 0 : iwpxp_ta = stats_metadata%ivpwp_ta
1897 0 : iwpxp_pr1 = stats_metadata%ivpwp_pr1
1898 : case default ! this includes the sclrm case
1899 0 : ixm_f = 0
1900 0 : iwpxp_bp = 0
1901 0 : iwpxp_pr3 = 0
1902 0 : iwpxp_f = 0
1903 0 : iwpxp_sicl = 0
1904 0 : iwpxp_ta = 0
1905 0 : iwpxp_pr1 = 0
1906 : end select
1907 :
1908 : ! Statistics: explicit contributions for wpxp.
1909 :
1910 : ! w'x' term bp is completely explicit; call stat_update_var.
1911 : ! Note: To find the contribution of w'x' term bp, substitute 0 for the
1912 : ! C_7 skewness function input to function wpxp_terms_bp_pr3_rhs.
1913 : call wpxp_terms_bp_pr3_rhs( nz, ngrdcol, zero_vector, thv_ds_zm, xpthvp, & ! intent(in)
1914 0 : rhs_bp ) ! intent(out)
1915 :
1916 0 : do i = 1, ngrdcol
1917 0 : call stat_update_var( iwpxp_bp, rhs_bp(i,:), & ! intent(in)
1918 0 : stats_zm(i) ) ! intent(inout)
1919 : end do
1920 :
1921 : ! w'x' term pr3 is completely explicit; call stat_update_var.
1922 : ! Note: To find the contribution of w'x' term pr3, add 1 to the
1923 : ! C_7 skewness function input to function wpxp_terms_bp_pr2_rhs.
1924 : call wpxp_terms_bp_pr3_rhs( nz, ngrdcol, (one+C7_Skw_fnc), thv_ds_zm, xpthvp, & ! intent(in)
1925 0 : rhs_pr3 ) ! intent(out)
1926 :
1927 0 : do i = 1, ngrdcol
1928 0 : call stat_update_var( iwpxp_pr3, rhs_pr3(i,:), & ! intent(in)
1929 0 : stats_zm(i) ) ! intent(inout)
1930 : end do
1931 :
1932 0 : do k = 2, nz-1
1933 0 : do i = 1, ngrdcol
1934 :
1935 : ! w'x' forcing term is completely explicit; call stat_update_var_pt.
1936 0 : call stat_update_var_pt( iwpxp_f, k, wpxp_forcing(i,k), & ! intent(in)
1937 0 : stats_zm(i) ) ! intent(inout)
1938 :
1939 :
1940 : ! <w'x'> term ta has both implicit and explicit components; call
1941 : ! stat_begin_update_pt. Since stat_begin_update_pt automatically
1942 : ! subtracts the value sent in, reverse the sign on
1943 : ! xpyp_term_ta_pdf_rhs.
1944 0 : call stat_begin_update_pt( iwpxp_ta, k, -rhs_ta(i,k), & ! intent(in)
1945 0 : stats_zm(i) ) ! intent(inout)
1946 :
1947 : ! Note: An "over-implicit" weighted time step is applied to this term.
1948 : ! A weighting factor of greater than 1 may be used to make the
1949 : ! term more numerically stable (see note above for RHS
1950 : ! contribution from "over-implicit" weighted time step for LHS
1951 : ! turbulent advection (ta) term).
1952 : call stat_modify_pt( iwpxp_ta, k, & ! intent(in)
1953 : + ( one - gamma_over_implicit_ts ) &
1954 0 : * ( - lhs_ta_wpxp(1,i,k) * wpxp(i,k+1) &
1955 : - lhs_ta_wpxp(2,i,k) * wpxp(i,k) &
1956 0 : - lhs_ta_wpxp(3,i,k) * wpxp(i,k-1) ), & ! intent(in)
1957 0 : stats_zm(i) ) ! intent(inout)
1958 :
1959 : ! w'x' term pr1 is normally completely implicit. However, there is a
1960 : ! RHS contribution from the "over-implicit" weighted time step. A
1961 : ! weighting factor of greater than 1 may be used to make the term more
1962 : ! numerically stable (see note above for RHS contribution from
1963 : ! "over-implicit" weighted time step for LHS turbulent advection (ta)
1964 : ! term). Therefore, w'x' term pr1 has both implicit and explicit
1965 : ! components; call stat_begin_update_pt. Since stat_begin_update_pt
1966 : ! automatically subtracts the value sent in, reverse the sign on the
1967 : ! input value.
1968 : call stat_begin_update_pt( iwpxp_pr1, k, & ! intent(in)
1969 : - ( one - gamma_over_implicit_ts ) &
1970 0 : * ( - lhs_pr1(i,k) * wpxp(i,k) ), & ! intent(in)
1971 0 : stats_zm(i) ) ! intent(inout)
1972 : end do
1973 : end do
1974 :
1975 :
1976 : ! Statistics: explicit contributions for xm
1977 : ! (including microphysics/radiation).
1978 :
1979 : ! xm forcings term is completely explicit; call stat_update_var_pt.
1980 0 : do k = 2, nz
1981 0 : do i = 1, ngrdcol
1982 0 : call stat_update_var_pt( ixm_f, k, xm_forcing(i,k), & ! intent(in)
1983 0 : stats_zt(i) ) ! intent(inout)
1984 : end do
1985 : end do
1986 :
1987 : endif ! stats_metadata%l_stats_samp
1988 :
1989 : !$acc exit data delete( rhs_bp_pr3 )
1990 :
1991 1411776 : return
1992 :
1993 : end subroutine xm_wpxp_rhs
1994 :
1995 : !=============================================================================================
1996 352944 : subroutine calc_xm_wpxp_ta_terms( nz, ngrdcol, gr, wp2rtp, &
1997 352944 : wp2thlp, wp2sclrp, &
1998 352944 : rho_ds_zt, invrs_rho_ds_zm, rho_ds_zm, &
1999 352944 : sigma_sqd_w, wp3_on_wp2_zt, &
2000 : pdf_implicit_coefs_terms, &
2001 : iiPDF_type, &
2002 : l_explicit_turbulent_adv_wpxp, l_predict_upwp_vpwp, &
2003 : l_scalar_calc, &
2004 : l_godunov_upwind_wpxp_ta, &
2005 : stats_metadata, &
2006 352944 : stats_zt, &
2007 352944 : lhs_ta_wprtp, lhs_ta_wpthlp, lhs_ta_wpup, &
2008 352944 : lhs_ta_wpvp, lhs_ta_wpsclrp, &
2009 352944 : rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpup, &
2010 352944 : rhs_ta_wpvp, rhs_ta_wpsclrp )
2011 : !
2012 : ! Description: This subroutine calculates the turbulent advection terms for
2013 : ! the left and right hand side matrices. Solutions may be entirely
2014 : ! explicit, entirely implicit, or mixed between, depending on
2015 : ! various flags and the PDF type.
2016 : !---------------------------------------------------------------------------------------------
2017 :
2018 : use grid_class, only: &
2019 : grid, & ! Type
2020 : zt2zm, & ! Procedure(s)
2021 : zm2zt
2022 :
2023 : use clubb_precision, only: &
2024 : core_rknd ! Variable(s)
2025 :
2026 : use constants_clubb, only: &
2027 : one, &
2028 : zero, &
2029 : zero_threshold
2030 :
2031 : use parameters_model, only: &
2032 : sclr_dim ! Number of passive scalar variables
2033 :
2034 : use pdf_parameter_module, only: &
2035 : implicit_coefs_terms ! Variable Type
2036 :
2037 : use turbulent_adv_pdf, only: &
2038 : xpyp_term_ta_pdf_lhs, & ! Procedures
2039 : xpyp_term_ta_pdf_lhs_godunov, &
2040 : xpyp_term_ta_pdf_rhs
2041 :
2042 : use model_flags, only: &
2043 : iiPDF_ADG1, & ! Integer constants
2044 : iiPDF_new, &
2045 : iiPDF_new_hybrid
2046 :
2047 : use stats_variables, only: &
2048 : stats_metadata_type
2049 :
2050 : use stats_type_utilities, only: &
2051 : stat_update_var ! Procedure(s)
2052 :
2053 : use stats_type, only: &
2054 : stats ! Type
2055 :
2056 : implicit none
2057 :
2058 : !------------------- Input Variables -------------------
2059 : integer, intent(in) :: &
2060 : nz, &
2061 : ngrdcol
2062 :
2063 : type (grid), target, intent(in) :: gr
2064 :
2065 : type(implicit_coefs_terms), intent(in) :: &
2066 : pdf_implicit_coefs_terms ! Implicit coefs / explicit terms [units vary]
2067 :
2068 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2069 : wp2rtp, &
2070 : wp2thlp, &
2071 : rho_ds_zt, &
2072 : invrs_rho_ds_zm, &
2073 : rho_ds_zm, &
2074 : sigma_sqd_w, &
2075 : wp3_on_wp2_zt
2076 :
2077 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim), intent(in) :: &
2078 : wp2sclrp
2079 :
2080 : integer, intent(in) :: &
2081 : iiPDF_type ! Selected option for the two-component normal (double
2082 : ! Gaussian) PDF type to use for the w, rt, and theta-l (or
2083 : ! w, chi, and eta) portion of CLUBB's multivariate,
2084 : ! two-component PDF.
2085 :
2086 : logical, intent(in) :: &
2087 : l_explicit_turbulent_adv_wpxp, &
2088 : l_scalar_calc, &
2089 : l_predict_upwp_vpwp
2090 :
2091 : logical, intent(in) :: &
2092 : l_godunov_upwind_wpxp_ta ! This flag determines whether we want to use an upwind
2093 : ! differencing approximation rather than a centered
2094 : ! differencing for turbulent advection terms.
2095 : ! It affects wpxp only.
2096 :
2097 : logical, parameter :: &
2098 : l_dummy_false = .false. ! This flag is set to false in order to replace the flag
2099 : ! passed into the xpyp_term_ta_pdf_rhs subroutine.
2100 : ! This stems from removing the l_upwind_wpxp_ta flag.
2101 : ! More information on this can be found on issue #926
2102 : ! on the clubb repository.
2103 :
2104 : type (stats_metadata_type), intent(in) :: &
2105 : stats_metadata
2106 :
2107 : !------------------- Inout Variables -------------------
2108 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
2109 : stats_zt
2110 :
2111 : !------------------- Output Variables -------------------
2112 :
2113 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(out) :: &
2114 : lhs_ta_wprtp, &
2115 : lhs_ta_wpthlp, &
2116 : lhs_ta_wpup, &
2117 : lhs_ta_wpvp
2118 :
2119 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz,sclr_dim), intent(out) :: &
2120 : lhs_ta_wpsclrp
2121 :
2122 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
2123 : rhs_ta_wprtp, &
2124 : rhs_ta_wpthlp, &
2125 : rhs_ta_wpup, &
2126 : rhs_ta_wpvp
2127 :
2128 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim), intent(out) :: &
2129 : rhs_ta_wpsclrp
2130 :
2131 : !------------------- Local Variables -------------------
2132 :
2133 : ! Variables for turbulent advection of predictive variances and covariances.
2134 :
2135 : ! <w'^2 rt'> = coef_wp2rtp_implicit * <w'rt'> + term_wp2rtp_explicit
2136 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2137 705888 : coef_wp2rtp_implicit, & ! Coefficient that is multiplied by <w'rt'> [m/s]
2138 705888 : term_wp2rtp_explicit ! Term that is on the RHS [m^2/s^2 kg/kg]
2139 :
2140 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2141 705888 : coef_wp2rtp_implicit_zm, & ! coef_wp2rtp_implicit interp. to m-levs. [m/s]
2142 705888 : term_wp2rtp_explicit_zm ! term_wp2rtp_expl intrp m-levs [m^2/s^2 kg/kg]
2143 :
2144 : ! <w'^2 thl'> = coef_wp2thlp_implicit * <w'thl'> + term_wp2thlp_explicit
2145 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2146 705888 : coef_wp2thlp_implicit, & ! Coef. that is multiplied by <w'thl'> [m/s]
2147 705888 : term_wp2thlp_explicit ! Term that is on the RHS [m^2/s^2 K]
2148 :
2149 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2150 705888 : coef_wp2thlp_implicit_zm, & ! coef_wp2thlp_implicit interp. m-levs. [m/s]
2151 705888 : term_wp2thlp_explicit_zm ! term_wp2thlp_expl interp. m-levs [m^2/s^2 K]
2152 :
2153 : ! <w'^2 sclr'> = coef_wp2sclrp_implicit * <w'sclr'> + term_wp2sclrp_explicit
2154 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2155 705888 : term_wp2sclrp_explicit ! Term that is on the RHS [m^2/s^2(un. vary)]
2156 :
2157 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2158 705888 : term_wp2sclrp_explicit_zm ! term_wp2sclrp_expl intrp zm [m^2/s^2(un v)]
2159 :
2160 : ! Sign of turbulent velocity (used for "upwind" turbulent advection)
2161 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2162 705888 : sgn_t_vel_wprtp, & ! Sign of the turbulent velocity for <w'rt'> [-]
2163 705888 : sgn_t_vel_wpthlp ! Sign of the turbulent velocity for <w'thl'> [-]
2164 :
2165 : real ( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2166 705888 : sgn_t_vel_wpsclrp ! Sign of the turbulent velocity for <w'sclr'> [-]
2167 :
2168 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2169 705888 : a1, &
2170 705888 : a1_zt
2171 :
2172 : integer :: i, k, b, sclr
2173 :
2174 : !------------------- Begin Code -------------------
2175 :
2176 : !$acc enter data create( coef_wp2rtp_implicit, term_wp2rtp_explicit, coef_wp2rtp_implicit_zm, &
2177 : !$acc term_wp2rtp_explicit_zm, coef_wp2thlp_implicit, term_wp2thlp_explicit, &
2178 : !$acc coef_wp2thlp_implicit_zm, term_wp2thlp_explicit_zm, &
2179 : !$acc sgn_t_vel_wprtp, sgn_t_vel_wpthlp, &
2180 : !$acc a1, a1_zt )
2181 :
2182 : !$acc enter data if( sclr_dim > 0 ) &
2183 : !$acc create( term_wp2sclrp_explicit, term_wp2sclrp_explicit_zm, sgn_t_vel_wpsclrp )
2184 :
2185 : ! Set up the implicit coefficients and explicit terms for turbulent
2186 : ! advection of <w'rt'>, <w'thl'>, and <w'sclr'>.
2187 352944 : if ( l_explicit_turbulent_adv_wpxp ) then
2188 :
2189 : ! The turbulent advection of <w'x'> is handled explicitly
2190 :
2191 : ! The turbulent advection of <w'x'> is handled explicitly, the
2192 : ! terms are calculated only for the RHS matrices. The
2193 : ! term_wp2xp_explicit terms are equal to <w'x'> as calculated using PDF
2194 : ! parameters, which are general for any PDF type. The values of
2195 : ! <w'x'> are calculated on thermodynamic levels.
2196 :
2197 : ! These coefficients only need to be set if stats output is on
2198 0 : if ( stats_metadata%l_stats_samp ) then
2199 0 : coef_wp2rtp_implicit(:,:) = zero
2200 0 : coef_wp2thlp_implicit(:,:) = zero
2201 : end if
2202 :
2203 : ! The turbulent advection terms are handled entirely explicitly. Thus the LHS
2204 : ! terms can be set to zero.
2205 : !$acc parallel loop gang vector collapse(3) default(present)
2206 0 : do k = 1, nz
2207 0 : do i = 1, ngrdcol
2208 0 : do b = 1, ndiags3
2209 0 : lhs_ta_wprtp(b,i,k) = zero
2210 0 : lhs_ta_wpthlp(b,i,k) = zero
2211 : end do
2212 : end do
2213 : end do
2214 : !$acc end parallel loop
2215 :
2216 0 : if ( l_scalar_calc ) then
2217 : !$acc parallel loop gang vector default(present) collapse(4)
2218 0 : do sclr = 1, sclr_dim
2219 0 : do k = 1, nz
2220 0 : do i = 1, ngrdcol
2221 0 : do b = 1, ndiags3
2222 0 : lhs_ta_wpsclrp(b,i,k,sclr_dim) = zero
2223 : end do
2224 : end do
2225 : end do
2226 : end do
2227 : !$acc end parallel loop
2228 : end if
2229 :
2230 : !$acc parallel loop gang vector collapse(2) default(present)
2231 0 : do k = 1, nz
2232 0 : do i = 1, ngrdcol
2233 0 : term_wp2rtp_explicit(i,k) = wp2rtp(i,k)
2234 0 : term_wp2thlp_explicit(i,k) = wp2thlp(i,k)
2235 : end do
2236 : end do
2237 : !$acc end parallel loop
2238 :
2239 : ! Calculate the RHS turbulent advection term for <w'r_t'>
2240 : call xpyp_term_ta_pdf_rhs( nz, ngrdcol, gr, term_wp2rtp_explicit, & ! Intent(in)
2241 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2242 : invrs_rho_ds_zm, & ! Intent(in)
2243 : l_dummy_false, & ! Intent(in)
2244 : sgn_t_vel_wprtp, & ! Intent(in)
2245 : term_wp2rtp_explicit_zm, & ! Intent(in)
2246 0 : rhs_ta_wprtp ) ! Intent(out)
2247 :
2248 : ! Calculate the RHS turbulent advection term for <w'thl'>
2249 : call xpyp_term_ta_pdf_rhs( nz, ngrdcol, gr, term_wp2thlp_explicit, & ! Intent(in)
2250 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2251 : invrs_rho_ds_zm, & ! Intent(in)
2252 : l_dummy_false, & ! Intent(in)
2253 : sgn_t_vel_wpthlp, & ! Intent(in)
2254 : term_wp2thlp_explicit_zm, & ! Intent(in)
2255 0 : rhs_ta_wpthlp ) ! Intent(out)
2256 :
2257 0 : do sclr = 1, sclr_dim, 1
2258 :
2259 : !$acc parallel loop gang vector collapse(2) default(present)
2260 0 : do k = 1, nz
2261 0 : do i = 1, ngrdcol
2262 0 : term_wp2sclrp_explicit(i,k) = wp2sclrp(i,k,sclr)
2263 : end do
2264 : end do
2265 : !$acc end parallel loop
2266 :
2267 : ! Calculate the RHS turbulent advection term for <w'thl'>
2268 : call xpyp_term_ta_pdf_rhs( nz, ngrdcol, gr, term_wp2sclrp_explicit, & ! Intent(in)
2269 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2270 : invrs_rho_ds_zm, & ! Intent(in)
2271 : l_dummy_false, & ! Intent(in)
2272 : sgn_t_vel_wpsclrp, & ! Intent(in)
2273 : term_wp2sclrp_explicit_zm, & ! Intent(in)
2274 0 : lhs_ta_wpsclrp(:,:,:,sclr) ) ! Intent(out)
2275 :
2276 : end do ! i = 1, sclr_dim, 1
2277 :
2278 : else ! .not. l_explicit_turbulent_adv_xpyp
2279 :
2280 : ! The turbulent advection of <w'x'> is handled implicitly or
2281 : ! semi-implicitly.
2282 :
2283 352944 : if ( iiPDF_type == iiPDF_ADG1 ) then
2284 :
2285 : ! The ADG1 PDF is used.
2286 :
2287 : ! Calculate the implicit coefficients and explicit terms on
2288 : ! thermodynamic grid levels.
2289 :
2290 : ! Calculate a_1.
2291 : ! It is a variable that is a function of sigma_sqd_w (where
2292 : ! sigma_sqd_w is located on momentum levels).
2293 : !$acc parallel loop gang vector collapse(2) default(present)
2294 30353184 : do k = 1, nz
2295 501287184 : do i = 1, ngrdcol
2296 500934240 : a1(i,k) = one / ( one - sigma_sqd_w(i,k) )
2297 : end do
2298 : end do
2299 : !$acc end parallel loop
2300 :
2301 : ! Interpolate a_1 from momentum levels to thermodynamic levels. This
2302 : ! will be used for the <w'x'> turbulent advection (ta) term.
2303 352944 : a1_zt(:,:) = zm2zt( nz, ngrdcol, gr, a1 ) ! Positive def. quantity
2304 :
2305 :
2306 : !$acc parallel loop gang vector collapse(2) default(present)
2307 30353184 : do k = 1, nz
2308 501287184 : do i = 1, ngrdcol
2309 500934240 : a1_zt(i,k) = max( a1_zt(i,k), zero_threshold )
2310 : end do
2311 : end do
2312 : !$acc end parallel loop
2313 :
2314 : !$acc parallel loop gang vector collapse(2) default(present)
2315 30353184 : do k = 1, nz
2316 501287184 : do i = 1, ngrdcol
2317 470934000 : coef_wp2rtp_implicit(i,k) = a1_zt(i,k) * wp3_on_wp2_zt(i,k)
2318 500934240 : coef_wp2thlp_implicit(i,k) = coef_wp2rtp_implicit(i,k)
2319 : end do
2320 : end do
2321 : !$acc end parallel loop
2322 :
2323 352944 : if ( .not. l_godunov_upwind_wpxp_ta ) then
2324 :
2325 : ! Calculate the LHS turbulent advection term for <w'r_t'>
2326 : call xpyp_term_ta_pdf_lhs( nz, ngrdcol, gr, coef_wp2rtp_implicit, & ! Intent(in)
2327 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2328 : invrs_rho_ds_zm, & ! Intent(in)
2329 : l_dummy_false, & ! Intent(in)
2330 : sgn_t_vel_wprtp, & ! Intent(in)
2331 : coef_wp2rtp_implicit_zm, & ! Intent(in)
2332 352944 : lhs_ta_wprtp ) ! Intent(out)
2333 :
2334 : else
2335 :
2336 : ! Godunov-like method for the vertical discretization of ta term
2337 : !$acc parallel loop gang vector default(present) collapse(2)
2338 0 : do k = 1, nz
2339 0 : do i = 1, ngrdcol
2340 0 : coef_wp2rtp_implicit(i,k) = a1_zt(i,k) * wp3_on_wp2_zt(i,k)
2341 0 : coef_wp2thlp_implicit(i,k) = coef_wp2rtp_implicit(i,k)
2342 : end do
2343 : end do
2344 : !$acc end parallel loop
2345 :
2346 : call xpyp_term_ta_pdf_lhs_godunov( nz, ngrdcol, gr, & ! Intent(in)
2347 : coef_wp2rtp_implicit, & ! Intent(in)
2348 : invrs_rho_ds_zm, rho_ds_zm, & ! Intent(in)
2349 0 : lhs_ta_wprtp ) ! Intent(out)
2350 :
2351 : end if
2352 :
2353 : ! For ADG1, the LHS turbulent advection terms for
2354 : ! <w'r_t'>, <w'thl'>, <w'sclr'> are all equal
2355 : !$acc parallel loop gang vector default(present) collapse(3)
2356 30353184 : do k = 1, nz
2357 501287184 : do i = 1, ngrdcol
2358 1913736240 : do b = 1, ndiags3
2359 1883736000 : lhs_ta_wpthlp(b,i,k) = lhs_ta_wprtp(b,i,k)
2360 : end do
2361 : end do
2362 : end do
2363 : !$acc end parallel loop
2364 :
2365 352944 : if ( l_scalar_calc ) then
2366 : !$acc parallel loop gang vector default(present) collapse(4)
2367 0 : do sclr = 1, sclr_dim
2368 0 : do k = 1, nz
2369 0 : do i = 1, ngrdcol
2370 0 : do b = 1, ndiags3
2371 0 : lhs_ta_wpsclrp(b,i,k,sclr) = lhs_ta_wprtp(b,i,k)
2372 : end do
2373 : end do
2374 : end do
2375 : end do
2376 : !$acc end parallel loop
2377 : end if
2378 :
2379 352944 : if ( stats_metadata%l_stats_samp ) then
2380 : !$acc parallel loop gang vector collapse(2) default(present)
2381 0 : do k = 1, nz
2382 0 : do i = 1, ngrdcol
2383 0 : term_wp2rtp_explicit(i,k) = zero
2384 0 : term_wp2thlp_explicit(i,k) = zero
2385 : end do
2386 : end do
2387 : !$acc end parallel loop
2388 : end if
2389 :
2390 : ! The <w'r_t'>, <w'thl'>, <w'sclr'> turbulent advection terms are entirely implicit.
2391 : ! Set the RHS turbulent advection terms to 0
2392 : !$acc parallel loop gang vector collapse(2) default(present)
2393 30353184 : do k = 1, nz
2394 501287184 : do i = 1, ngrdcol
2395 470934000 : rhs_ta_wprtp(i,k) = zero
2396 500934240 : rhs_ta_wpthlp(i,k) = zero
2397 : end do
2398 : end do
2399 : !$acc end parallel loop
2400 :
2401 352944 : if ( l_scalar_calc ) then
2402 : !$acc parallel loop gang vector default(present) collapse(3)
2403 0 : do sclr = 1, sclr_dim
2404 0 : do k = 1, nz
2405 0 : do i = 1, ngrdcol
2406 0 : rhs_ta_wpsclrp(i,k,sclr) = zero
2407 : end do
2408 : end do
2409 : end do
2410 : !$acc end parallel loop
2411 : end if
2412 :
2413 352944 : if ( l_predict_upwp_vpwp ) then
2414 :
2415 : ! Predict <u> and <u'w'>, as well as <v> and <v'w'>.
2416 : ! These terms are equal to the <w'r_t'> terms as well in this case
2417 : !$acc parallel loop gang vector default(present) collapse(3)
2418 30353184 : do k = 1, nz
2419 501287184 : do i = 1, ngrdcol
2420 1913736240 : do b = 1, ndiags3
2421 1412802000 : lhs_ta_wpup(b,i,k) = lhs_ta_wprtp(b,i,k)
2422 1883736000 : lhs_ta_wpvp(b,i,k) = lhs_ta_wprtp(b,i,k)
2423 : end do
2424 : end do
2425 : end do
2426 : !$acc end parallel loop
2427 :
2428 : ! The <w'u'> and <w'v'> turbulent advection terms are entirely implicit.
2429 : ! Set the RHS turbulent advection terms to 0
2430 : !$acc parallel loop gang vector collapse(2) default(present)
2431 30353184 : do k = 1, nz
2432 501287184 : do i = 1, ngrdcol
2433 470934000 : rhs_ta_wpup(i,k) = zero
2434 500934240 : rhs_ta_wpvp(i,k) = zero
2435 : end do
2436 : end do
2437 : !$acc end parallel loop
2438 :
2439 : endif
2440 :
2441 0 : elseif ( iiPDF_type == iiPDF_new ) then
2442 :
2443 : ! The new PDF is used.
2444 :
2445 : ! Unpack the variables coef_wp2rtp_implicit, term_wp2rtp_explicit,
2446 : ! coef_wp2thlp_implicit, and term_wp2thlp_explicit from
2447 : ! pdf_implicit_coefs_terms. The PDF parameters and the resulting
2448 : ! implicit coefficients and explicit terms are calculated on
2449 : ! thermodynamic levels.
2450 0 : do i = 1, ngrdcol
2451 0 : coef_wp2rtp_implicit(i,:) = pdf_implicit_coefs_terms%coef_wp2rtp_implicit(i,:)
2452 0 : coef_wp2thlp_implicit(i,:) = pdf_implicit_coefs_terms%coef_wp2thlp_implicit(i,:)
2453 0 : term_wp2rtp_explicit(i,:) = pdf_implicit_coefs_terms%term_wp2rtp_explicit(i,:)
2454 0 : term_wp2thlp_explicit(i,:) = pdf_implicit_coefs_terms%term_wp2thlp_explicit(i,:)
2455 : end do
2456 :
2457 :
2458 : ! Calculate the LHS turbulent advection term for <w'rt'>
2459 : call xpyp_term_ta_pdf_lhs( nz, ngrdcol, gr, coef_wp2rtp_implicit, & ! Intent(in)
2460 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2461 : invrs_rho_ds_zm, & ! Intent(in)
2462 : l_dummy_false, & ! Intent(in)
2463 : sgn_t_vel_wprtp, & ! Intent(in)
2464 : coef_wp2rtp_implicit_zm, & ! Intent(in)
2465 0 : lhs_ta_wprtp ) ! Intent(out)
2466 :
2467 : ! Calculate the RHS turbulent advection term for <w'rt'>
2468 : call xpyp_term_ta_pdf_rhs( nz, ngrdcol, gr, term_wp2rtp_explicit, & ! Intent(in)
2469 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2470 : invrs_rho_ds_zm, & ! Intent(in)
2471 : l_dummy_false, & ! Intent(in)
2472 : sgn_t_vel_wprtp, & ! Intent(in)
2473 : term_wp2rtp_explicit_zm, & ! Intent(in)
2474 0 : rhs_ta_wprtp ) ! Intent(out)
2475 :
2476 :
2477 : ! Calculate the LHS turbulent advection term for <w'thl'>
2478 : call xpyp_term_ta_pdf_lhs( nz, ngrdcol, gr, coef_wp2thlp_implicit, & ! Intent(in)
2479 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2480 : invrs_rho_ds_zm, & ! Intent(in)
2481 : l_dummy_false, & ! Intent(in)
2482 : sgn_t_vel_wpthlp, & ! Intent(in)
2483 : coef_wp2thlp_implicit_zm, & ! Intent(in)
2484 0 : lhs_ta_wpthlp ) ! Intent(out)
2485 :
2486 : ! Calculate the RHS turbulent advection term for <w'thl'>
2487 : call xpyp_term_ta_pdf_rhs( nz, ngrdcol, gr, term_wp2thlp_explicit, & ! Intent(in)
2488 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2489 : invrs_rho_ds_zm, & ! Intent(in)
2490 : l_dummy_false, & ! Intent(in)
2491 : sgn_t_vel_wpthlp, & ! Intent(in)
2492 : term_wp2thlp_explicit_zm, & ! Intent(in)
2493 0 : rhs_ta_wpthlp ) ! Intent(out)
2494 :
2495 : ! The code for the scalar variables will be set up later.
2496 0 : lhs_ta_wpsclrp(:,:,:,:) = zero
2497 0 : rhs_ta_wpsclrp(:,:,:) = zero
2498 :
2499 0 : elseif ( iiPDF_type == iiPDF_new_hybrid ) then
2500 :
2501 : ! The new hybrid PDF is used.
2502 :
2503 : ! Unpack the variable coef_wp2rtp_implicit from the structure
2504 : ! pdf_implicit_coefs_terms. The values of coef_wp2thlp_implicit,
2505 : ! coef_wp2up_implicit, coef_wp2vp_implict, and coef_wp2sclrp_implicit
2506 : ! are all equal to coef_wp2rtp_implicit. The PDF parameters and the
2507 : ! resulting implicit coefficients are calculated on thermodynamic
2508 : ! levels.
2509 0 : do i = 1, ngrdcol
2510 0 : coef_wp2rtp_implicit(i,:) = pdf_implicit_coefs_terms%coef_wp2rtp_implicit(i,:)
2511 0 : coef_wp2thlp_implicit(i,:) = coef_wp2rtp_implicit(i,:)
2512 : end do
2513 :
2514 :
2515 : ! Calculate the LHS turbulent advection term for <w'rt'>
2516 : call xpyp_term_ta_pdf_lhs( nz, ngrdcol, gr, coef_wp2rtp_implicit, & ! Intent(in)
2517 : rho_ds_zt, rho_ds_zm, & ! Intent(in)
2518 : invrs_rho_ds_zm, & ! Intent(in)
2519 : l_dummy_false, & ! Intent(in)
2520 : sgn_t_vel_wprtp, & ! Intent(in)
2521 : coef_wp2rtp_implicit_zm, & ! Intent(in)
2522 0 : lhs_ta_wprtp ) ! Intent(out)
2523 :
2524 : ! For the new hybrid PDF, the LHS turbulent advection terms for
2525 : ! <w'r_t'>, <w'thl'>, and <w'sclr'> are all the same.
2526 0 : lhs_ta_wpthlp(:,:,:) = lhs_ta_wprtp(:,:,:)
2527 :
2528 0 : if ( l_scalar_calc ) then
2529 0 : do sclr = 1, sclr_dim
2530 0 : lhs_ta_wpsclrp(:,:,:,sclr) = lhs_ta_wprtp(:,:,:)
2531 : end do
2532 : end if
2533 :
2534 0 : if ( stats_metadata%l_stats_samp ) then
2535 0 : term_wp2rtp_explicit(:,:) = zero
2536 0 : term_wp2thlp_explicit(:,:) = zero
2537 : end if
2538 :
2539 : ! The <w'r_t'>, <w'thl'>, <w'sclr'> turbulent advection terms are
2540 : ! entirely implicit. Set the RHS turbulent advection terms to 0
2541 0 : rhs_ta_wprtp(:,:) = zero
2542 0 : rhs_ta_wpthlp(:,:) = zero
2543 0 : rhs_ta_wpsclrp(:,:,:) = zero
2544 :
2545 0 : if ( l_predict_upwp_vpwp ) then
2546 :
2547 : ! Predict <u> and <u'w'>, as well as <v> and <v'w'>.
2548 : ! These terms are equal to the <w'r_t'> terms as well in this case
2549 0 : lhs_ta_wpup(:,:,:) = lhs_ta_wprtp(:,:,:)
2550 0 : lhs_ta_wpvp(:,:,:) = lhs_ta_wprtp(:,:,:)
2551 :
2552 : ! The <w'u'> and <w'v'> turbulent advection terms are entirely
2553 : ! implicit. Set the RHS turbulent advection terms to 0
2554 0 : rhs_ta_wpup(:,:) = zero
2555 0 : rhs_ta_wpvp(:,:) = zero
2556 :
2557 : endif
2558 :
2559 : endif ! iiPDF_type
2560 :
2561 : endif ! l_explicit_turbulent_adv_xpyp
2562 :
2563 352944 : if ( stats_metadata%l_stats_samp ) then
2564 : !$acc update host( coef_wp2rtp_implicit, term_wp2rtp_explicit, &
2565 : !$acc coef_wp2thlp_implicit, term_wp2thlp_explicit )
2566 0 : do i = 1, ngrdcol
2567 0 : call stat_update_var( stats_metadata%icoef_wp2rtp_implicit, coef_wp2rtp_implicit(i,:), & ! intent(in)
2568 0 : stats_zt(i) ) ! intent(inout)
2569 : call stat_update_var( stats_metadata%iterm_wp2rtp_explicit, term_wp2rtp_explicit(i,:), & ! intent(in)
2570 0 : stats_zt(i) ) ! intent(inout)
2571 : call stat_update_var( stats_metadata%icoef_wp2thlp_implicit, coef_wp2thlp_implicit(i,:), & ! intent(in)
2572 0 : stats_zt(i) ) ! intent(inout)
2573 : call stat_update_var( stats_metadata%iterm_wp2thlp_explicit, term_wp2thlp_explicit(i,:), & ! intent(in)
2574 0 : stats_zt(i) ) ! intent(inout)
2575 : end do
2576 : endif
2577 :
2578 : !$acc exit data delete( coef_wp2rtp_implicit, term_wp2rtp_explicit, coef_wp2rtp_implicit_zm, &
2579 : !$acc term_wp2rtp_explicit_zm, coef_wp2thlp_implicit, term_wp2thlp_explicit, &
2580 : !$acc coef_wp2thlp_implicit_zm, term_wp2thlp_explicit_zm, &
2581 : !$acc sgn_t_vel_wprtp, sgn_t_vel_wpthlp, &
2582 : !$acc a1, a1_zt )
2583 :
2584 : !$acc exit data if( sclr_dim > 0 ) &
2585 : !$acc delete( term_wp2sclrp_explicit, term_wp2sclrp_explicit_zm, sgn_t_vel_wpsclrp )
2586 :
2587 352944 : end subroutine calc_xm_wpxp_ta_terms
2588 :
2589 : !==========================================================================================
2590 352944 : subroutine solve_xm_wpxp_with_single_lhs( nz, ngrdcol, gr, dt, l_iter, nrhs, wm_zt, wp2, &
2591 352944 : invrs_tau_C6_zm, tau_max_zm, &
2592 352944 : rtpthvp, rtm_forcing, wprtp_forcing, thlpthvp, &
2593 352944 : thlm_forcing, wpthlp_forcing, rho_ds_zm, &
2594 352944 : rho_ds_zt, invrs_rho_ds_zm, invrs_rho_ds_zt, &
2595 352944 : thv_ds_zm, rtp2, thlp2, l_implemented, &
2596 352944 : sclrpthvp, sclrm_forcing, sclrp2, um_forcing, &
2597 352944 : vm_forcing, ug, vg, uprcp, vprcp, rc_coef, fcor, &
2598 352944 : up2, vp2, &
2599 352944 : low_lev_effect, high_lev_effect, &
2600 352944 : C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc, &
2601 352944 : lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, &
2602 352944 : lhs_ta_wpxp, &
2603 352944 : rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpup, &
2604 352944 : rhs_ta_wpvp, rhs_ta_wpsclrp, &
2605 352944 : lhs_tp, lhs_ta_xm, lhs_ac_pr2, lhs_pr1_wprtp, &
2606 352944 : lhs_pr1_wpthlp, lhs_pr1_wpsclrp, &
2607 : C_uu_shr, &
2608 : penta_solve_method, &
2609 : tridiag_solve_method, &
2610 : l_predict_upwp_vpwp, &
2611 : l_diffuse_rtm_and_thlm, &
2612 : l_upwind_xm_ma, &
2613 : l_tke_aniso, &
2614 : l_enable_relaxed_clipping, &
2615 : l_perturbed_wind, &
2616 : l_mono_flux_lim_thlm, &
2617 : l_mono_flux_lim_rtm, &
2618 : l_mono_flux_lim_um, &
2619 : l_mono_flux_lim_vm, &
2620 : l_mono_flux_lim_spikefix, &
2621 : order_xm_wpxp, order_xp2_xpyp, order_wp2_wp3, &
2622 : stats_metadata, &
2623 352944 : stats_zt, stats_zm, stats_sfc, &
2624 352944 : rtm, wprtp, thlm, wpthlp, &
2625 352944 : sclrm, wpsclrp, um, upwp, vm, vpwp, &
2626 352944 : um_pert, vm_pert, upwp_pert, vpwp_pert )
2627 : !
2628 : ! Description: This subroutine solves all xm_wpxp when all the LHS matrices are equal.
2629 : ! The LHS matrices being equivalent allows for only a single solve, rather
2630 : ! than a seperate solve for each field.
2631 : !----------------------------------------------------------------------------------------
2632 :
2633 : use grid_class, only: &
2634 : grid, & ! Type
2635 : ddzt ! Procedure(s)
2636 :
2637 : use error_code, only: &
2638 : clubb_at_least_debug_level, & ! Procedure
2639 : err_code, & ! Error Indicator
2640 : clubb_fatal_error ! Constants
2641 :
2642 : use stats_type_utilities, only: &
2643 : stat_update_var ! Procedure(s)
2644 :
2645 : use stats_variables, only: &
2646 : stats_metadata_type
2647 :
2648 : use parameters_model, only: &
2649 : sclr_dim, & ! Variable(s)
2650 : sclr_tol
2651 :
2652 : use clubb_precision, only: &
2653 : core_rknd ! Variable(s)
2654 :
2655 : use constants_clubb, only: &
2656 : fstderr, & ! Constant
2657 : rt_tol, &
2658 : thl_tol, &
2659 : w_tol, &
2660 : w_tol_sqd, &
2661 : thl_tol_mfl, &
2662 : rt_tol_mfl, &
2663 : zero, &
2664 : one, &
2665 : ep1
2666 :
2667 : use stats_type, only: stats ! Type
2668 :
2669 : use model_flags, only: &
2670 : penta_bicgstab
2671 :
2672 : implicit none
2673 :
2674 : ! ------------------- Input Variables -------------------
2675 :
2676 : integer, intent(in) :: &
2677 : nz, &
2678 : ngrdcol
2679 :
2680 : type (grid), target, intent(in) :: gr
2681 :
2682 : real( kind = core_rknd ), intent(in) :: &
2683 : dt ! Timestep [s]
2684 :
2685 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz) :: &
2686 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
2687 : wp2, & ! w'^2 (momentum levels) [m^2/s^2]
2688 : invrs_tau_C6_zm, & ! Inverse tau on momentum levels applied to C6 term [1/s]
2689 : tau_max_zm, & ! Max. allowable eddy dissipation time scale on m-levs [s]
2690 : rtpthvp, & ! r_t'th_v' (momentum levels) [(kg/kg) K]
2691 : rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s]
2692 : wprtp_forcing, & ! <w'r_t'> forcing (momentum levels) [(kg/kg)/s^2]
2693 : thlpthvp, & ! th_l'th_v' (momentum levels) [K^2]
2694 : thlm_forcing, & ! th_l forcing (thermodynamic levels) [K/s]
2695 : wpthlp_forcing, & ! <w'th_l'> forcing (momentum levels) [K/s^2]
2696 : rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3]
2697 : rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3]
2698 : invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg]
2699 : invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg]
2700 : thv_ds_zm, & ! Dry, base-state theta_v on moment. levs. [K]
2701 : rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2]
2702 : thlp2 ! th_l'^2 (momentum levels) [K^2]
2703 :
2704 : logical, intent(in) :: &
2705 : l_implemented, & ! Flag for CLUBB being implemented in a larger model.
2706 : l_iter
2707 :
2708 : ! Additional variables for passive scalars
2709 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz,sclr_dim) :: &
2710 : sclrpthvp, & ! <sclr' th_v'> (momentum levels) [Units vary]
2711 : sclrm_forcing, & ! sclrm forcing (thermodynamic levels) [Units vary]
2712 : sclrp2 ! For clipping Vince Larson [Units vary]
2713 :
2714 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
2715 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2716 : um_forcing, & ! <u> forcing term (thermodynamic levels) [m/s^2]
2717 : vm_forcing, & ! <v> forcing term (thermodynamic levels) [m/s^2]
2718 : ug, & ! <u> geostrophic wind (thermodynamic levels) [m/s]
2719 : vg ! <v> geostrophic wind (thermodynamic levels) [m/s]
2720 :
2721 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2722 : uprcp, & ! < u' r_c' > [(m kg)/(s kg)]
2723 : vprcp, & ! < v' r_c' > [(m kg)/(s kg)]
2724 : rc_coef ! Coefficient on X'r_c' in X'th_v' equation [K/(kg/kg)]
2725 :
2726 : real( kind = core_rknd ), dimension(ngrdcol), intent(in) :: &
2727 : fcor ! Coriolis parameter [s^-1]
2728 :
2729 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2730 : up2, & ! Variance of the u wind component [m^2/s^2]
2731 : vp2 ! Variance of the v wind component [m^2/s^2]
2732 :
2733 : ! LHS/RHS terms
2734 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(in) :: &
2735 : lhs_diff_zm, & ! Diffusion term for w'x'
2736 : lhs_diff_zt, & ! Diffusion term for w'x'
2737 : lhs_ma_zt, & ! Mean advection contributions to lhs
2738 : lhs_ma_zm ! Mean advection contributions to lhs
2739 :
2740 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(in) :: &
2741 : lhs_ta_wpxp ! w'r_t' turbulent advection contributions to lhs
2742 :
2743 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2744 : rhs_ta_wprtp, & ! w'r_t' turbulent advection contributions to rhs
2745 : rhs_ta_wpthlp, & ! w'thl' turbulent advection contributions to rhs
2746 : rhs_ta_wpup, & ! w'u' turbulent advection contributions to rhs
2747 : rhs_ta_wpvp ! w'v' turbulent advection contributions to rhs
2748 :
2749 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim), intent(in) :: &
2750 : rhs_ta_wpsclrp ! w'sclr' turbulent advection contributions to rhs
2751 :
2752 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz), intent(in) :: &
2753 : lhs_tp, & ! Turbulent production terms of w'x'
2754 : lhs_ta_xm ! Turbulent advection terms of xm
2755 :
2756 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2757 : lhs_ac_pr2, & ! Accumulation of w'x' and w'x' pressure term 2
2758 : lhs_pr1_wprtp, & ! Pressure term 1 for w'r_t' for all grid levels
2759 : lhs_pr1_wpthlp, & ! Pressure term 1 for w'thl' for all grid levels
2760 : lhs_pr1_wpsclrp ! Pressure term 1 for w'sclr' for all grid levels
2761 :
2762 : ! Variables used as part of the monotonic turbulent advection scheme.
2763 : ! Find the lowermost and uppermost grid levels that can have an effect
2764 : ! on the central thermodynamic level during the course of a time step,
2765 : ! due to the effects of turbulent advection only.
2766 : integer, dimension(ngrdcol,nz), intent(in) :: &
2767 : low_lev_effect, & ! Index of the lowest level that has an effect.
2768 : high_lev_effect ! Index of the highest level that has an effect.
2769 :
2770 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2771 : C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc
2772 :
2773 : integer, intent(in) :: &
2774 : nrhs ! Number of RHS vectors
2775 :
2776 : real( kind = core_rknd ), intent(in) :: &
2777 : C_uu_shr ! CLUBB tunable parameter C_uu_shr
2778 :
2779 : integer, intent(in) :: &
2780 : penta_solve_method, & ! Method to solve then penta-diagonal system
2781 : tridiag_solve_method ! Specifier for method to solve tridiagonal systems,
2782 : ! used for monotonic flux limiter
2783 :
2784 : logical, intent(in) :: &
2785 : l_predict_upwp_vpwp, & ! Flag to predict <u'w'> and <v'w'> along
2786 : ! with <u> and <v> alongside the advancement
2787 : ! of <rt>, <w'rt'>, <thl>, <wpthlp>, <sclr>,
2788 : ! and <w'sclr'> in subroutine advance_xm_wpxp.
2789 : ! Otherwise, <u'w'> and <v'w'> are still
2790 : ! approximated by eddy diffusivity when <u>
2791 : ! and <v> are advanced in subroutine
2792 : ! advance_windm_edsclrm.
2793 : l_diffuse_rtm_and_thlm, & ! This flag determines whether or not we want
2794 : ! CLUBB to do diffusion on rtm and thlm
2795 : l_upwind_xm_ma, & ! This flag determines whether we want to use
2796 : ! an upwind differencing approximation rather
2797 : ! than a centered differencing for turbulent
2798 : ! or mean advection terms. It affects rtm,
2799 : ! thlm, sclrm, um and vm.
2800 : l_tke_aniso, & ! For anisotropic turbulent kinetic energy,
2801 : ! i.e. TKE = 1/2 (u'^2 + v'^2 + w'^2)
2802 : l_enable_relaxed_clipping, & ! Flag to relax clipping on wpxp in
2803 : ! xm_wpxp_clipping_and_stats
2804 : l_perturbed_wind, & ! Whether perturbed winds are being solved
2805 : l_mono_flux_lim_thlm, & ! Flag to turn on monotonic flux limiter for thlm
2806 : l_mono_flux_lim_rtm, & ! Flag to turn on monotonic flux limiter for rtm
2807 : l_mono_flux_lim_um, & ! Flag to turn on monotonic flux limiter for um
2808 : l_mono_flux_lim_vm, & ! Flag to turn on monotonic flux limiter for vm
2809 : l_mono_flux_lim_spikefix ! Flag to implement monotonic flux limiter code that
2810 : ! eliminates spurious drying tendencies at model top
2811 :
2812 : integer, intent(in) :: &
2813 : order_xm_wpxp, &
2814 : order_xp2_xpyp, &
2815 : order_wp2_wp3
2816 :
2817 : type (stats_metadata_type), intent(in) :: &
2818 : stats_metadata
2819 :
2820 : ! ------------------- Input/Output Variables -------------------
2821 :
2822 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz) :: &
2823 : rtm, & ! r_t (total water mixing ratio) [kg/kg]
2824 : wprtp, & ! w'r_t' [(kg/kg) m/s]
2825 : thlm, & ! th_l (liquid water potential temperature) [K]
2826 : wpthlp ! w'th_l' [K m/s]
2827 :
2828 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz,sclr_dim) :: &
2829 : sclrm, wpsclrp ! [Units vary]
2830 :
2831 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
2832 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz) :: &
2833 : um, & ! <u>: mean west-east horiz. velocity (thermo. levs.) [m/s]
2834 : upwp, & ! <u'w'>: momentum flux (momentum levels) [m^2/s^2]
2835 : vm, & ! <v>: mean south-north horiz. velocity (thermo. levs.) [m/s]
2836 : vpwp ! <v'w'>: momentum flux (momentum levels) [m^2/s^2]
2837 :
2838 : ! Variables used to track perturbed version of winds.
2839 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(inout) :: &
2840 : um_pert, & ! perturbed <u> [m/s]
2841 : vm_pert, & ! perturbed <v> [m/s]
2842 : upwp_pert, & ! perturbed <u'w'> [m^2/s^2]
2843 : vpwp_pert ! perturbed <v'w'> [m^2/s^2]
2844 :
2845 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
2846 : stats_zt, &
2847 : stats_zm, &
2848 : stats_sfc
2849 :
2850 : ! ------------------- Local Variables -------------------
2851 :
2852 : real( kind = core_rknd ), dimension(nsup+nsub+1,ngrdcol,2*nz) :: &
2853 705888 : lhs ! Implicit contributions to wpxp/xm (band diag. matrix) (LAPACK)
2854 :
2855 : ! Additional variables for passive scalars
2856 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim) :: &
2857 705888 : wpsclrp_forcing ! <w'sclr'> forcing (momentum levels) [m/s{un vary}]
2858 :
2859 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2860 705888 : um_tndcy, & ! <u> forcing term + coriolis (thermo levs) [m/s^2]
2861 705888 : vm_tndcy, & ! <v> forcing term + coriolis (thermo levs) [m/s^2]
2862 705888 : upwp_forcing, & ! <u'w'> extra RHS pressure term (mom levs) [m^2/s^3]
2863 705888 : vpwp_forcing, & ! <v'w'> extra RHS pressure term (mom levs) [m^2/s^3]
2864 705888 : upthvp, & ! <u'thv'> (momentum levels) [m/s K]
2865 705888 : vpthvp, & ! <v'thv'> (momentum levels) [m/s K]
2866 705888 : upthlp, & ! eastward horz turb flux of theta_l (mom levs) [m/s K]
2867 705888 : vpthlp, & ! northward horz turb flux of theta_l (mom levs) [m/s K]
2868 705888 : uprtp, & ! eastward horz turb flux of tot water (mom levs) [m/s kg/kg]
2869 705888 : vprtp, & ! northward horz turb flux of tot water (mom levs) [m/s kg/kg]
2870 705888 : tau_C6_zm ! Time-scale tau on momentum levels applied to C6 term [s]
2871 :
2872 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2873 705888 : upwp_forcing_pert, & ! perturbed extra RHS term (mom levs) [m^2/s^3]
2874 705888 : vpwp_forcing_pert, & ! perturbed extra RHS term (mom levs) [m^2/s^3]
2875 705888 : upthvp_pert, & ! perturbed <u'thv'> (momentum levels) [m/s K]
2876 705888 : vpthvp_pert, & ! perturbed <v'thv'> (momentum levels) [m/s K]
2877 705888 : upthlp_pert, & ! perturbed horz flux of theta_l (mom levs) [m/s K]
2878 705888 : vpthlp_pert, & ! perturbed horz flux of theta_l (mom levs) [m/s K]
2879 705888 : uprtp_pert, & ! perturbed horz flux of tot water (mom levs) [m/s kg/kg]
2880 705888 : vprtp_pert ! perturbed horz flux of tot water (mom levs) [m/s kg/kg]
2881 :
2882 : real( kind = core_rknd ), dimension(ngrdcol,2*nz,nrhs) :: &
2883 705888 : rhs, & ! Right-hand sides of band diag. matrix. (LAPACK)
2884 705888 : rhs_save, & ! Saved Right-hand sides of band diag. matrix. (LAPACK)
2885 705888 : solution, & ! solution vectors of band diag. matrix. (LAPACK)
2886 705888 : old_solution ! previous solutions
2887 :
2888 : ! Constant parameters as a function of Skw.
2889 :
2890 705888 : real( kind = core_rknd ), dimension(ngrdcol) :: rcond
2891 :
2892 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2893 705888 : zeros_vector, &
2894 705888 : ddzt_um, &
2895 705888 : ddzt_vm, &
2896 705888 : ddzt_um_pert, &
2897 352944 : ddzt_vm_pert
2898 :
2899 : integer :: i, k, j, n
2900 :
2901 : ! ------------------- Begin Code -------------------
2902 :
2903 : !$acc enter data create( lhs, um_tndcy, vm_tndcy, upwp_forcing, &
2904 : !$acc vpwp_forcing, upthvp, vpthvp, upthlp, vpthlp, uprtp, vprtp, &
2905 : !$acc tau_C6_zm, upwp_forcing_pert, vpwp_forcing_pert, upthvp_pert, &
2906 : !$acc vpthvp_pert, upthlp_pert, vpthlp_pert, uprtp_pert, vprtp_pert, &
2907 : !$acc rhs, rhs_save, solution, old_solution, rcond, zeros_vector, &
2908 : !$acc ddzt_um, ddzt_vm, ddzt_um_pert, ddzt_vm_pert )
2909 :
2910 : !$acc enter data if( sclr_dim > 0 ) create( wpsclrp_forcing )
2911 :
2912 : ! This is initialized solely for the purpose of avoiding a compiler
2913 : ! warning about uninitialized variables.
2914 : !$acc parallel loop gang vector collapse(2) default(present)
2915 30353184 : do k = 1, nz
2916 501287184 : do i = 1, ngrdcol
2917 500934240 : zeros_vector(i,k) = zero
2918 : end do
2919 : end do
2920 : !$acc end parallel loop
2921 :
2922 : ! Simple case, where the new PDF is
2923 : ! used, l_explicit_turbulent_adv_wpxp is enabled.
2924 :
2925 : ! Create the lhs once
2926 : call xm_wpxp_lhs( nz, ngrdcol, l_iter, dt, zeros_vector, wm_zt, C7_Skw_fnc, & ! In
2927 : zeros_vector, zeros_vector, & ! In
2928 : l_implemented, lhs_diff_zm, lhs_diff_zt, & ! In
2929 : lhs_ma_zm, lhs_ma_zt, lhs_ta_wpxp, lhs_ta_xm, & ! In
2930 : lhs_tp, lhs_pr1_wprtp, lhs_ac_pr2, & ! In
2931 : l_diffuse_rtm_and_thlm, & ! In
2932 : stats_metadata, & ! In
2933 352944 : lhs ) ! Out
2934 :
2935 : ! Compute the explicit portion of the r_t and w'r_t' equations.
2936 : ! Build the right-hand side vector.
2937 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! In
2938 : rtm_forcing, wprtp_forcing, C7_Skw_fnc, & ! In
2939 : rtpthvp, rhs_ta_wprtp, thv_ds_zm, & ! In
2940 : lhs_pr1_wprtp, lhs_ta_wpxp, & ! In
2941 : stats_metadata, & ! In
2942 : stats_zt, stats_zm, & ! Inout
2943 352944 : rhs(:,:,1) ) ! Out
2944 :
2945 : ! Compute the explicit portion of the th_l and w'th_l' equations.
2946 : ! Build the right-hand side vector.
2947 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! In
2948 : thlm_forcing, wpthlp_forcing, C7_Skw_fnc, & ! In
2949 : thlpthvp, rhs_ta_wpthlp, thv_ds_zm, & ! In
2950 : lhs_pr1_wpthlp, lhs_ta_wpxp, & ! In
2951 : stats_metadata, & ! In
2952 : stats_zt, stats_zm, & ! Inout
2953 352944 : rhs(:,:,2) ) ! Out
2954 :
2955 : ! ---> h1g, 2010-06-15
2956 : ! scalar transport, e.g, droplet and ice number concentration
2957 : ! are handled in " advance_sclrm_Nd_module.F90 "
2958 : #ifdef GFDL
2959 : do j = 1, 0, 1
2960 : #else
2961 352944 : do j = 1, sclr_dim, 1
2962 : #endif
2963 : ! <--- h1g, 2010-06-15
2964 :
2965 : ! Set <w'sclr'> forcing to 0 unless unless testing the wpsclrp code
2966 : ! using wprtp or wpthlp (then use wprtp_forcing or wpthlp_forcing).
2967 : !$acc parallel loop gang vector collapse(2) default(present)
2968 0 : do k = 1, nz
2969 0 : do i = 1, ngrdcol
2970 0 : wpsclrp_forcing(i,k,j) = zero
2971 : end do
2972 : end do
2973 : !$acc end parallel loop
2974 :
2975 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_scalar, l_iter, dt, sclrm(:,:,j), wpsclrp(:,:,j), & ! In
2976 : sclrm_forcing(:,:,j), & ! In
2977 : wpsclrp_forcing(:,:,j), C7_Skw_fnc, & ! In
2978 : sclrpthvp(:,:,j), rhs_ta_wpsclrp(:,:,j), thv_ds_zm, & ! In
2979 : lhs_pr1_wpsclrp, lhs_ta_wpxp, & ! In
2980 : stats_metadata, & ! In
2981 : stats_zt, stats_zm, & ! Inout
2982 352944 : rhs(:,:,2+j) ) ! Out
2983 : end do
2984 :
2985 352944 : if ( l_predict_upwp_vpwp ) then
2986 :
2987 : ! Predict <u> and <u'w'>, as well as <v> and <v'w'>.
2988 : ! Currently, this requires the ADG1 PDF with implicit turbulent advection.
2989 : ! l_explicit_turbulent_adv_wpxp = false
2990 : ! and ( iiPDF_type == iiPDF_ADG1 .or. iiPDF_type == iiPDF_new_hybrid )
2991 :
2992 : ! Coriolis term for <u> and <v>
2993 352944 : if ( .not. l_implemented ) then
2994 :
2995 : ! Only compute the Coriolis term if the model is running on its own,
2996 : ! and is not part of a larger, host model.
2997 : !$acc parallel loop gang vector collapse(2) default(present)
2998 0 : do k = 1, nz
2999 0 : do i = 1, ngrdcol
3000 0 : um_tndcy(i,k) = um_forcing(i,k) - fcor(i) * ( vg(i,k) - vm(i,k) )
3001 0 : vm_tndcy(i,k) = vm_forcing(i,k) + fcor(i) * ( ug(i,k) - um(i,k) )
3002 : end do
3003 : end do
3004 : !$acc end parallel loop
3005 :
3006 0 : if ( stats_metadata%l_stats_samp ) then
3007 :
3008 : !$acc update host( fcor, um_forcing, vm_forcing, vg, ug, vm, um )
3009 :
3010 0 : do i = 1, ngrdcol
3011 : ! um or vm term gf is completely explicit; call stat_update_var.
3012 0 : call stat_update_var( stats_metadata%ium_gf, - fcor(i) * vg(i,:), & ! intent(in)
3013 0 : stats_zt(i) ) ! intent(inout)
3014 0 : call stat_update_var( stats_metadata%ivm_gf, fcor(i) * ug(i,:), & ! intent(in)
3015 0 : stats_zt(i) ) ! intent(inout)
3016 :
3017 : ! um or vm term cf is completely explicit; call stat_update_var.
3018 0 : call stat_update_var( stats_metadata%ium_cf, fcor(i) * vm(i,:), & ! intent(in)
3019 0 : stats_zt(i) ) ! intent(inout)
3020 0 : call stat_update_var( stats_metadata%ivm_cf, - fcor(i) * um(i,:), & ! intent(in)
3021 0 : stats_zt(i) ) ! intent(inout)
3022 :
3023 : ! um or vm forcing term
3024 0 : call stat_update_var( stats_metadata%ium_f, um_forcing(i,:), & ! intent(in)
3025 0 : stats_zt(i) ) ! intent(inout)
3026 0 : call stat_update_var( stats_metadata%ivm_f, vm_forcing(i,:), & ! intent(in)
3027 0 : stats_zt(i) ) ! intent(inout)
3028 : end do
3029 : endif ! stats_metadata%l_stats_samp
3030 :
3031 : else ! implemented in a host model
3032 :
3033 : !$acc parallel loop gang vector collapse(2) default(present)
3034 30353184 : do k = 1, nz
3035 501287184 : do i = 1, ngrdcol
3036 470934000 : um_tndcy(i,k) = zero
3037 500934240 : vm_tndcy(i,k) = zero
3038 : end do
3039 : end do
3040 : !$acc end parallel loop
3041 :
3042 : end if ! .not. l_implemented
3043 :
3044 352944 : ddzt_um = ddzt( nz, ngrdcol, gr, um )
3045 352944 : ddzt_vm = ddzt( nz, ngrdcol, gr, vm )
3046 :
3047 : ! Add "extra term" and optional Coriolis term for <u'w'> and <v'w'>.
3048 : !$acc parallel loop gang vector collapse(2) default(present)
3049 30353184 : do k = 1, nz
3050 501287184 : do i = 1, ngrdcol
3051 470934000 : upwp_forcing(i,k) = C_uu_shr * wp2(i,k) * ddzt_um(i,k)
3052 500934240 : vpwp_forcing(i,k) = C_uu_shr * wp2(i,k) * ddzt_vm(i,k)
3053 : end do
3054 : end do
3055 : !$acc end parallel loop
3056 :
3057 352944 : if ( l_perturbed_wind ) then
3058 :
3059 0 : ddzt_um_pert = ddzt( nz, ngrdcol, gr, um_pert )
3060 0 : ddzt_vm_pert = ddzt( nz, ngrdcol, gr, vm_pert )
3061 :
3062 : !$acc parallel loop gang vector collapse(2) default(present)
3063 0 : do k = 1, nz
3064 0 : do i = 1, ngrdcol
3065 0 : upwp_forcing_pert(i,k) = C_uu_shr * wp2(i,k) * ddzt_um_pert(i,k)
3066 0 : vpwp_forcing_pert(i,k) = C_uu_shr * wp2(i,k) * ddzt_vm_pert(i,k)
3067 : end do
3068 : end do
3069 : !$acc end parallel loop
3070 :
3071 : endif ! l_perturbed_wind
3072 :
3073 352944 : if ( stats_metadata%l_stats_samp ) then
3074 :
3075 : !$acc update host( wp2, ddzt_um, ddzt_vm )
3076 :
3077 0 : do i = 1, ngrdcol
3078 0 : call stat_update_var( stats_metadata%iupwp_pr4, C_uu_shr * wp2(i,:) * ddzt_um(i,:), & ! intent(in)
3079 0 : stats_zm(i) ) ! intent(inout)
3080 0 : call stat_update_var( stats_metadata%ivpwp_pr4, C_uu_shr * wp2(i,:) * ddzt_vm(i,:), & ! intent(in)
3081 0 : stats_zm(i) ) ! intent(inout)
3082 : end do
3083 : end if ! stats_metadata%l_stats_samp
3084 :
3085 : ! need tau_C6_zm for these calls
3086 : !$acc parallel loop gang vector collapse(2) default(present)
3087 30353184 : do k = 1, nz
3088 501287184 : do i = 1, ngrdcol
3089 500934240 : tau_C6_zm(i,k) = min ( one / invrs_tau_C6_zm(i,k), tau_max_zm(i,k) )
3090 : end do
3091 : end do
3092 : !$acc end parallel loop
3093 :
3094 : call diagnose_upxp( nz, ngrdcol, gr, upwp, thlm, wpthlp, um, & ! Intent(in)
3095 : C6thl_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3096 352944 : upthlp ) ! Intent(out)
3097 :
3098 : call diagnose_upxp( nz, ngrdcol, gr, upwp, rtm, wprtp, um, & ! Intent(in)
3099 : C6rt_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3100 352944 : uprtp ) ! Intent(out)
3101 :
3102 : call diagnose_upxp( nz, ngrdcol, gr, vpwp, thlm, wpthlp, vm, & ! Intent(in)
3103 : C6thl_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3104 352944 : vpthlp ) ! Intent(out)
3105 :
3106 : call diagnose_upxp( nz, ngrdcol, gr, vpwp, rtm, wprtp, vm, & ! Intent(in)
3107 : C6rt_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3108 352944 : vprtp ) ! Intent(out)
3109 :
3110 352944 : if ( l_perturbed_wind ) then
3111 :
3112 : call diagnose_upxp( nz, ngrdcol, gr, upwp_pert, thlm, wpthlp, um_pert, & ! Intent(in)
3113 : C6thl_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3114 0 : upthlp_pert ) ! Intent(out)
3115 :
3116 : call diagnose_upxp( nz, ngrdcol, gr, upwp_pert, rtm, wprtp, um_pert, & ! Intent(in)
3117 : C6rt_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3118 0 : uprtp_pert ) ! Intent(out)
3119 :
3120 : call diagnose_upxp( nz, ngrdcol, gr, vpwp_pert, thlm, wpthlp, vm_pert, & ! Intent(in)
3121 : C6thl_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3122 0 : vpthlp_pert ) ! Intent(out)
3123 :
3124 : call diagnose_upxp( nz, ngrdcol, gr, vpwp_pert, rtm, wprtp, vm_pert, & ! Intent(in)
3125 : C6rt_Skw_fnc, tau_C6_zm, C7_Skw_fnc, & ! Intent(in)
3126 0 : vprtp_pert ) ! Intent(out)
3127 :
3128 : endif ! l_perturbed_wind
3129 :
3130 : ! Use a crude approximation for buoyancy terms <u'thv'> and <v'thv'>.
3131 : !upthvp = upwp * wpthvp / max( wp2, w_tol_sqd )
3132 : !vpthvp = vpwp * wpthvp / max( wp2, w_tol_sqd )
3133 : !upthvp = 0.3_core_rknd * ( upthlp + 200.0_core_rknd * uprtp ) &
3134 : ! + 200._core_rknd * sign( one, upwp) * sqrt( up2 * rcm**2 )
3135 : !vpthvp = 0.3_core_rknd * ( vpthlp + 200.0_core_rknd * vprtp ) &
3136 : ! + 200._core_rknd * sign( one, vpwp ) * sqrt( vp2 * rcm**2 )
3137 : !$acc parallel loop gang vector collapse(2) default(present)
3138 30353184 : do k = 1, nz
3139 501287184 : do i = 1, ngrdcol
3140 941868000 : upthvp(i,k) = upthlp(i,k) + ep1 * thv_ds_zm(i,k) * uprtp(i,k) &
3141 941868000 : + rc_coef(i,k) * uprcp(i,k)
3142 :
3143 : vpthvp(i,k) = vpthlp(i,k) + ep1 * thv_ds_zm(i,k) * vprtp(i,k) &
3144 500934240 : + rc_coef(i,k) * vprcp(i,k)
3145 : end do
3146 : end do
3147 : !$acc end parallel loop
3148 :
3149 352944 : if ( l_perturbed_wind ) then
3150 :
3151 : !$acc parallel loop gang vector collapse(2) default(present)
3152 0 : do k = 1, nz
3153 0 : do i = 1, ngrdcol
3154 0 : upthvp_pert(i,k) = upthlp_pert(i,k) &
3155 : + ep1 * thv_ds_zm(i,k) * uprtp_pert(i,k) &
3156 0 : + rc_coef(i,k) * uprcp(i,k)
3157 : vpthvp_pert(i,k) = vpthlp_pert(i,k) &
3158 : + ep1 * thv_ds_zm(i,k) * vprtp_pert(i,k) &
3159 0 : + rc_coef(i,k) * vprcp(i,k)
3160 : end do
3161 : end do
3162 : !$acc end parallel loop
3163 :
3164 : endif ! l_perturbed_wind
3165 :
3166 352944 : if ( stats_metadata%l_stats_samp ) then
3167 :
3168 : !$acc update host( upthlp, uprtp, vpthlp, vprtp, upthvp, vpthvp )
3169 :
3170 0 : do i = 1, ngrdcol
3171 0 : call stat_update_var( stats_metadata%iupthlp, upthlp(i,:), & ! intent(in)
3172 0 : stats_zm(i) ) ! intent(inout)
3173 0 : call stat_update_var( stats_metadata%iuprtp, uprtp(i,:), & ! intent(in)
3174 0 : stats_zm(i) ) ! intent(inout)
3175 0 : call stat_update_var( stats_metadata%ivpthlp, vpthlp(i,:), & ! intent(in)
3176 0 : stats_zm(i) ) ! intent(inout)
3177 0 : call stat_update_var( stats_metadata%ivprtp, vprtp(i,:), & ! intent(in)
3178 0 : stats_zm(i) ) ! intent(inout)
3179 0 : call stat_update_var( stats_metadata%iupthvp, upthvp(i,:), & ! intent(in)
3180 0 : stats_zm(i) ) ! intent(inout)
3181 0 : call stat_update_var( stats_metadata%ivpthvp, vpthvp(i,:), & ! intent(in)
3182 0 : stats_zm(i) ) ! intent(inout)
3183 : end do
3184 : end if ! stats_metadata%l_stats_samp
3185 :
3186 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_um, l_iter, dt, um, upwp, & ! In
3187 : um_tndcy, upwp_forcing, C7_Skw_fnc, & ! In
3188 : upthvp, rhs_ta_wpup, thv_ds_zm, & ! In
3189 : lhs_pr1_wprtp, lhs_ta_wpxp, & ! In
3190 : stats_metadata, & ! In
3191 : stats_zt, stats_zm, & ! Inout
3192 352944 : rhs(:,:,3+sclr_dim) ) ! Out
3193 :
3194 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_vm, l_iter, dt, vm, vpwp, & ! In
3195 : vm_tndcy, vpwp_forcing, C7_Skw_fnc, & ! In
3196 : vpthvp, rhs_ta_wpvp, thv_ds_zm, & ! In
3197 : lhs_pr1_wprtp, lhs_ta_wpxp, & ! In
3198 : stats_metadata, & ! In
3199 : stats_zt, stats_zm, & ! Inout
3200 352944 : rhs(:,:,4+sclr_dim) ) ! Out
3201 :
3202 352944 : if ( l_perturbed_wind ) then
3203 :
3204 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_um, l_iter, dt, um_pert, & ! In
3205 : upwp_pert, um_tndcy, upwp_forcing_pert, C7_Skw_fnc, & ! In
3206 : upthvp_pert, rhs_ta_wpup, thv_ds_zm, & ! In
3207 : lhs_pr1_wprtp, lhs_ta_wpxp, & ! In
3208 : stats_metadata, & ! In
3209 : stats_zt, stats_zm, & ! Inout
3210 0 : rhs(:,:,5+sclr_dim) ) ! Out
3211 :
3212 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_vm, l_iter, dt, vm_pert, & ! In
3213 : vpwp_pert, vm_tndcy, vpwp_forcing_pert, C7_Skw_fnc, & ! In
3214 : vpthvp_pert, rhs_ta_wpvp, thv_ds_zm, & ! In
3215 : lhs_pr1_wprtp, lhs_ta_wpxp, & ! In
3216 : stats_metadata, & ! In
3217 : stats_zt, stats_zm, & ! Inout
3218 0 : rhs(:,:,6+sclr_dim) ) ! Out
3219 :
3220 : endif ! l_perturbed_wind
3221 :
3222 : endif ! l_predict_upwp_vpwp
3223 :
3224 : ! Save the value of rhs, which will be overwritten with the solution as
3225 : ! part of the solving routine.
3226 : !$acc parallel loop gang vector collapse(3) default(present)
3227 1764720 : do n = 1, nrhs
3228 241766640 : do k = 1, 2*nz
3229 4008885696 : do i = 1, ngrdcol
3230 4007473920 : rhs_save(i,k,n) = rhs(i,k,n)
3231 : end do
3232 : end do
3233 : end do
3234 : !$acc end parallel loop
3235 :
3236 : ! Use the previous solution as an initial guess for the bicgstab method
3237 352944 : if ( penta_solve_method == penta_bicgstab ) then
3238 :
3239 : !$acc parallel loop gang vector collapse(2) default(present)
3240 0 : do k = 1, nz
3241 0 : do i = 1, ngrdcol
3242 0 : old_solution(i,2*k-1,1) = rtm(i,k)
3243 0 : old_solution(i,2*k ,1) = wprtp(i,k)
3244 0 : old_solution(i,2*k-1,2) = thlm(i,k)
3245 0 : old_solution(i,2*k ,2) = wpthlp(i,k)
3246 : end do
3247 : end do
3248 : !$acc end parallel loop
3249 :
3250 : !$acc parallel loop gang vector collapse(3) default(present)
3251 0 : do j = 1, sclr_dim
3252 0 : do k = 1, nz
3253 0 : do i = 1, ngrdcol
3254 0 : old_solution(i,2*k-1,2+j) = sclrm(i,k,j)
3255 0 : old_solution(i,2*k ,2+j) = wpsclrp(i,k,j)
3256 : end do
3257 : end do
3258 : end do
3259 : !$acc end parallel loop
3260 :
3261 0 : if ( l_predict_upwp_vpwp ) then
3262 : !$acc parallel loop gang vector collapse(2) default(present)
3263 0 : do k = 1, nz
3264 0 : do i = 1, ngrdcol
3265 0 : old_solution(i,2*k-1,3+sclr_dim) = um(i,k)
3266 0 : old_solution(i,2*k ,3+sclr_dim) = upwp(i,k)
3267 0 : old_solution(i,2*k-1,4+sclr_dim) = vm(i,k)
3268 0 : old_solution(i,2*k ,4+sclr_dim) = vpwp(i,k)
3269 : end do
3270 : end do
3271 : !$acc end parallel loop
3272 : end if
3273 :
3274 : end if
3275 :
3276 : ! Solve for all fields
3277 352944 : if ( stats_metadata%l_stats_samp .and. stats_metadata%ithlm_matrix_condt_num + stats_metadata%irtm_matrix_condt_num > 0 ) then
3278 : call xm_wpxp_solve( nz, ngrdcol, gr, nrhs, & ! Intent(in)
3279 : old_solution, & ! Intent(in)
3280 : penta_solve_method, & ! Intent(in)
3281 : lhs, rhs, & ! Intent(inout)
3282 0 : solution, rcond ) ! Intent(out)
3283 : else
3284 : call xm_wpxp_solve( nz, ngrdcol, gr, nrhs, & ! Intent(in)
3285 : old_solution, & ! Intent(in)
3286 : penta_solve_method, & ! Intent(in)
3287 : lhs, rhs, & ! Intent(inout)
3288 352944 : solution ) ! Intent(out)
3289 : end if
3290 :
3291 :
3292 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
3293 352944 : if ( err_code == clubb_fatal_error ) then
3294 :
3295 : !$acc update host( gr%zm, gr%zt, lhs, rhs_save )
3296 :
3297 0 : write(fstderr,*) "xm & wpxp LU decomp. failed"
3298 0 : write(fstderr,*) "General xm and wpxp LHS"
3299 :
3300 0 : do k = 1, nz
3301 0 : do i = 1, ngrdcol
3302 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, "height [m] = ", gr%zt(i,k), &
3303 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k-1)
3304 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, "height [m] = ", gr%zm(i,k), &
3305 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k)
3306 : end do
3307 : end do ! k = 1, nz
3308 :
3309 0 : do j = 1, nrhs
3310 0 : if ( j == 1 ) then
3311 0 : write(fstderr,*) "rtm and wprtp RHS"
3312 0 : elseif ( j == 2 ) then
3313 0 : write(fstderr,*) "thlm and wpthlp RHS"
3314 : else ! j > 2
3315 0 : if ( sclr_dim > 0 ) then
3316 0 : if ( j <= 2+sclr_dim ) then
3317 0 : write(fstderr,*) "sclrm and wpsclrp RHS for sclr", j-2
3318 : end if ! j <= 2+sclr_dim )
3319 : end if ! sclr_dim > 0
3320 0 : if ( l_predict_upwp_vpwp ) then
3321 0 : if ( j == 3+sclr_dim ) then
3322 0 : write(fstderr,*) "um and upwp RHS"
3323 0 : elseif ( j == 4+sclr_dim ) then
3324 0 : write(fstderr,*) "vm and vpwp RHS"
3325 : end if
3326 : end if ! l_predict_upwp_vpwp
3327 : end if
3328 0 : do k = 1, nz
3329 0 : do i = 1, ngrdcol
3330 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, &
3331 0 : "height [m] = ", gr%zt(i,k), &
3332 0 : "RHS = ", rhs_save(i,2*k-1,j)
3333 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, &
3334 0 : "height [m] = ", gr%zm(i,k), &
3335 0 : "RHS = ", rhs_save(i,2*k,j)
3336 : end do
3337 : end do ! k = 1, nz
3338 : end do ! j = 1, nrhs
3339 : return
3340 : end if
3341 : end if
3342 :
3343 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3344 : gr, xm_wpxp_rtm, dt, wp2, rtp2, wm_zt, & ! Intent(in)
3345 : rtm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in)
3346 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3347 : rt_tol**2, rt_tol, rcond, & ! Intent(in)
3348 : low_lev_effect, high_lev_effect, & ! Intent(in)
3349 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, & ! Intent(in)
3350 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3351 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3352 : l_implemented, solution(:,:,1), & ! Intent(in)
3353 : tridiag_solve_method, & ! Intent(in)
3354 : l_predict_upwp_vpwp, & ! Intent(in)
3355 : l_upwind_xm_ma, & ! Intent(in)
3356 : l_tke_aniso, & ! Intent(in)
3357 : l_enable_relaxed_clipping, & ! Intent(in)
3358 : l_mono_flux_lim_thlm, &
3359 : l_mono_flux_lim_rtm, &
3360 : l_mono_flux_lim_um, &
3361 : l_mono_flux_lim_vm, &
3362 : l_mono_flux_lim_spikefix, &
3363 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3364 : order_wp2_wp3, & ! Intent(in)
3365 : stats_metadata, & ! Intent(in)
3366 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3367 352944 : rtm, rt_tol_mfl, wprtp ) ! Intent(inout)
3368 :
3369 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
3370 352944 : if ( err_code == clubb_fatal_error ) then
3371 0 : write(fstderr,*) "rtm monotonic flux limiter: tridiag failed"
3372 0 : return
3373 : end if
3374 : end if
3375 :
3376 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3377 : gr, xm_wpxp_thlm, dt, wp2, thlp2, wm_zt, & ! Intent(in)
3378 : thlm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in)
3379 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3380 : thl_tol**2, thl_tol, rcond, & ! Intent(in)
3381 : low_lev_effect, high_lev_effect, & ! Intent(in)
3382 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, & ! Intent(in)
3383 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3384 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3385 : l_implemented, solution(:,:,2), & ! Intent(in)
3386 : tridiag_solve_method, & ! Intent(in)
3387 : l_predict_upwp_vpwp, & ! Intent(in)
3388 : l_upwind_xm_ma, & ! Intent(in)
3389 : l_tke_aniso, & ! Intent(in)
3390 : l_enable_relaxed_clipping, & ! Intent(in)
3391 : l_mono_flux_lim_thlm, &
3392 : l_mono_flux_lim_rtm, &
3393 : l_mono_flux_lim_um, &
3394 : l_mono_flux_lim_vm, &
3395 : l_mono_flux_lim_spikefix, &
3396 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3397 : order_wp2_wp3, & ! Intent(in)
3398 : stats_metadata, & ! Intent(in)
3399 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3400 352944 : thlm, thl_tol_mfl, wpthlp ) ! Intent(inout)
3401 :
3402 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
3403 352944 : if ( err_code == clubb_fatal_error ) then
3404 0 : write(fstderr,*) "thlm monotonic flux limiter: tridiag failed"
3405 0 : return
3406 : end if
3407 : end if
3408 :
3409 : ! ---> h1g, 2010-06-15
3410 : ! scalar transport, e.g, droplet and ice number concentration
3411 : ! are handled in " advance_sclrm_Nd_module.F90 "
3412 : #ifdef GFDL
3413 : do j = 1, 0, 1
3414 : #else
3415 352944 : do j = 1, sclr_dim, 1
3416 : #endif
3417 : ! <--- h1g, 2010-06-15
3418 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3419 : gr, xm_wpxp_scalar, dt, wp2, sclrp2(:,:,j), wm_zt, & ! Intent(in)
3420 : sclrm_forcing(:,:,j), & ! Intent(in)
3421 : rho_ds_zm, rho_ds_zt, & ! Intent(in)
3422 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3423 0 : sclr_tol(j)**2, sclr_tol(j), rcond, & ! Intent(in)
3424 : low_lev_effect, high_lev_effect, & ! Intent(in)
3425 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, & ! Intent(in)
3426 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3427 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3428 : l_implemented, solution(:,:,2+j), & ! Intent(in)
3429 : tridiag_solve_method, & ! Intent(in)
3430 : l_predict_upwp_vpwp, & ! Intent(in)
3431 : l_upwind_xm_ma, & ! Intent(in)
3432 : l_tke_aniso, & ! Intent(in)
3433 : l_enable_relaxed_clipping, & ! Intent(in)
3434 : l_mono_flux_lim_thlm, &
3435 : l_mono_flux_lim_rtm, &
3436 : l_mono_flux_lim_um, &
3437 : l_mono_flux_lim_vm, &
3438 : l_mono_flux_lim_spikefix, &
3439 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3440 : order_wp2_wp3, & ! Intent(in)
3441 : stats_metadata, & ! Intent(in)
3442 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3443 0 : sclrm(:,:,j), sclr_tol(j), wpsclrp(:,:,j) ) ! Intent(inout)
3444 :
3445 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
3446 0 : if ( err_code == clubb_fatal_error ) then
3447 0 : write(fstderr,*) "sclrm # ", j, "monotonic flux limiter: tridiag failed"
3448 0 : return
3449 : end if
3450 : end if
3451 :
3452 : end do ! 1..sclr_dim
3453 :
3454 352944 : if ( l_predict_upwp_vpwp ) then
3455 :
3456 : ! Predict <u> and <u'w'>, as well as <v> and <v'w'>.
3457 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3458 : gr, xm_wpxp_um, dt, wp2, up2, wm_zt, & ! Intent(in)
3459 : um_tndcy, rho_ds_zm, rho_ds_zt, & ! Intent(in)
3460 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3461 : w_tol_sqd, w_tol, rcond, & ! Intent(in)
3462 : low_lev_effect, high_lev_effect, & ! Intent(in)
3463 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, & ! Intent(in)
3464 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3465 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3466 : l_implemented, solution(:,:,3+sclr_dim), & ! Intent(in)
3467 : tridiag_solve_method, & ! Intent(in)
3468 : l_predict_upwp_vpwp, & ! Intent(in)
3469 : l_upwind_xm_ma, & ! Intent(in)
3470 : l_tke_aniso, & ! Intent(in)
3471 : l_enable_relaxed_clipping, & ! Intent(in)
3472 : l_mono_flux_lim_thlm, &
3473 : l_mono_flux_lim_rtm, &
3474 : l_mono_flux_lim_um, &
3475 : l_mono_flux_lim_vm, &
3476 : l_mono_flux_lim_spikefix, &
3477 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3478 : order_wp2_wp3, & ! Intent(in)
3479 : stats_metadata, & ! Intent(in)
3480 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3481 352944 : um, w_tol, upwp ) ! Intent(inout)
3482 :
3483 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
3484 352944 : if ( err_code == clubb_fatal_error ) then
3485 0 : write(fstderr,*) "um monotonic flux limiter: tridiag failed"
3486 0 : return
3487 : end if
3488 : end if
3489 :
3490 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3491 : gr, xm_wpxp_vm, dt, wp2, vp2, wm_zt, & ! Intent(in)
3492 : vm_tndcy, rho_ds_zm, rho_ds_zt, & ! Intent(in)
3493 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3494 : w_tol_sqd, w_tol, rcond, & ! Intent(in)
3495 : low_lev_effect, high_lev_effect, & ! Intent(in)
3496 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, & ! Intent(in)
3497 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3498 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3499 : l_implemented, solution(:,:,4+sclr_dim), & ! Intent(in)
3500 : tridiag_solve_method, & ! Intent(in)
3501 : l_predict_upwp_vpwp, & ! Intent(in)
3502 : l_upwind_xm_ma, & ! Intent(in)
3503 : l_tke_aniso, & ! Intent(in)
3504 : l_enable_relaxed_clipping, & ! Intent(in)
3505 : l_mono_flux_lim_thlm, &
3506 : l_mono_flux_lim_rtm, &
3507 : l_mono_flux_lim_um, &
3508 : l_mono_flux_lim_vm, &
3509 : l_mono_flux_lim_spikefix, &
3510 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3511 : order_wp2_wp3, & ! Intent(in)
3512 : stats_metadata, & ! Intent(in)
3513 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3514 352944 : vm, w_tol, vpwp ) ! Intent(inout)
3515 :
3516 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
3517 352944 : if ( err_code == clubb_fatal_error ) then
3518 0 : write(fstderr,*) "vm monotonic flux limiter: tridiag failed"
3519 0 : return
3520 : end if
3521 : end if
3522 :
3523 352944 : if ( l_perturbed_wind ) then
3524 :
3525 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3526 : gr, xm_wpxp_um, dt, wp2, up2, wm_zt, & ! Intent(in)
3527 : um_tndcy, rho_ds_zm, rho_ds_zt, & ! Intent(in)
3528 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3529 : w_tol_sqd, w_tol, rcond, & ! Intent(in)
3530 : low_lev_effect, high_lev_effect, & ! Intent(in)
3531 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, & ! Intent(in)
3532 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3533 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3534 : l_implemented, solution(:,:,5+sclr_dim), & ! Intent(in)
3535 : tridiag_solve_method, & ! Intent(in)
3536 : l_predict_upwp_vpwp, & ! Intent(in)
3537 : l_upwind_xm_ma, & ! Intent(in)
3538 : l_tke_aniso, & ! Intent(in)
3539 : l_enable_relaxed_clipping, & ! Intent(in)
3540 : l_mono_flux_lim_thlm, &
3541 : l_mono_flux_lim_rtm, &
3542 : l_mono_flux_lim_um, &
3543 : l_mono_flux_lim_vm, &
3544 : l_mono_flux_lim_spikefix, &
3545 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3546 : order_wp2_wp3, & ! Intent(in)
3547 : stats_metadata, & ! Intent(in)
3548 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3549 0 : um_pert, w_tol, upwp_pert ) ! Intent(inout)
3550 :
3551 0 : if ( clubb_at_least_debug_level( 0 ) ) then
3552 0 : if ( err_code == clubb_fatal_error ) then
3553 0 : write(fstderr,*) "um_pert monotonic flux limiter: tridiag failed"
3554 0 : return
3555 : end if
3556 : end if
3557 :
3558 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3559 : gr, xm_wpxp_vm, dt, wp2, vp2, wm_zt, & ! Intent(in)
3560 : vm_tndcy, rho_ds_zm, rho_ds_zt, & ! Intent(in)
3561 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3562 : w_tol_sqd, w_tol, rcond, & ! Intent(in)
3563 : low_lev_effect, high_lev_effect, & ! Intent(in)
3564 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, & ! Intent(in)
3565 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3566 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3567 : l_implemented, solution(:,:,6+sclr_dim), & ! Intent(in)
3568 : tridiag_solve_method, & ! Intent(in)
3569 : l_predict_upwp_vpwp, & ! Intent(in)
3570 : l_upwind_xm_ma, & ! Intent(in)
3571 : l_tke_aniso, & ! Intent(in)
3572 : l_enable_relaxed_clipping, & ! Intent(in)
3573 : l_mono_flux_lim_thlm, &
3574 : l_mono_flux_lim_rtm, &
3575 : l_mono_flux_lim_um, &
3576 : l_mono_flux_lim_vm, &
3577 : l_mono_flux_lim_spikefix, &
3578 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3579 : order_wp2_wp3, & ! Intent(in)
3580 : stats_metadata, & ! Intent(in)
3581 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3582 0 : vm_pert, w_tol, vpwp_pert ) ! Intent(inout)
3583 :
3584 0 : if ( clubb_at_least_debug_level( 0 ) ) then
3585 0 : if ( err_code == clubb_fatal_error ) then
3586 0 : write(fstderr,*) "vm_pert monotonic flux limiter: tridiag failed"
3587 0 : return
3588 : end if
3589 : end if
3590 :
3591 : endif ! l_perturbed_wind
3592 :
3593 : end if ! l_predict_upwp_vpwp
3594 :
3595 : !$acc exit data delete( lhs, um_tndcy, vm_tndcy, upwp_forcing, &
3596 : !$acc vpwp_forcing, upthvp, vpthvp, upthlp, vpthlp, uprtp, vprtp, &
3597 : !$acc tau_C6_zm, upwp_forcing_pert, vpwp_forcing_pert, upthvp_pert, &
3598 : !$acc vpthvp_pert, upthlp_pert, vpthlp_pert, uprtp_pert, vprtp_pert, &
3599 : !$acc rhs, rhs_save, solution, old_solution, rcond, zeros_vector, &
3600 : !$acc ddzt_um, ddzt_vm, ddzt_um_pert, ddzt_vm_pert )
3601 :
3602 : !$acc exit data if( sclr_dim > 0 ) delete( wpsclrp_forcing )
3603 :
3604 : end subroutine solve_xm_wpxp_with_single_lhs
3605 :
3606 : !==========================================================================================
3607 :
3608 0 : subroutine solve_xm_wpxp_with_multiple_lhs( nz, ngrdcol, gr, dt, l_iter, nrhs, wm_zt, wp2, &
3609 0 : rtpthvp, rtm_forcing, wprtp_forcing, thlpthvp, &
3610 0 : thlm_forcing, wpthlp_forcing, rho_ds_zm, &
3611 0 : rho_ds_zt, invrs_rho_ds_zm, invrs_rho_ds_zt, &
3612 0 : thv_ds_zm, rtp2, thlp2, l_implemented, &
3613 0 : sclrpthvp, sclrm_forcing, sclrp2, &
3614 0 : low_lev_effect, high_lev_effect, C7_Skw_fnc, &
3615 0 : lhs_diff_zm, lhs_diff_zt, lhs_ma_zt, lhs_ma_zm, &
3616 0 : lhs_ta_wprtp, lhs_ta_wpthlp, lhs_ta_wpsclrp, &
3617 0 : rhs_ta_wprtp, rhs_ta_wpthlp, rhs_ta_wpsclrp, &
3618 0 : lhs_tp, lhs_ta_xm, lhs_ac_pr2, lhs_pr1_wprtp, &
3619 0 : lhs_pr1_wpthlp, lhs_pr1_wpsclrp, &
3620 : penta_solve_method, &
3621 : tridiag_solve_method, &
3622 : l_predict_upwp_vpwp, &
3623 : l_diffuse_rtm_and_thlm, &
3624 : l_upwind_xm_ma, &
3625 : l_tke_aniso, &
3626 : l_enable_relaxed_clipping, &
3627 : l_mono_flux_lim_thlm, &
3628 : l_mono_flux_lim_rtm, &
3629 : l_mono_flux_lim_um, &
3630 : l_mono_flux_lim_vm, &
3631 : l_mono_flux_lim_spikefix, &
3632 : order_xm_wpxp, order_xp2_xpyp, order_wp2_wp3, &
3633 : stats_metadata, &
3634 0 : stats_zt, stats_zm, stats_sfc, &
3635 0 : rtm, wprtp, thlm, wpthlp, sclrm, wpsclrp )
3636 : !
3637 : ! Description: This subroutine solves all xm_wpxp when all the LHS matrices are NOT equal.
3638 : ! This means multiple solves are required, one for each unique LHS.
3639 : !
3640 : !----------------------------------------------------------------------------------------
3641 :
3642 : use grid_class, only: &
3643 : grid, & ! Type
3644 : ddzt ! Procedure(s)
3645 :
3646 : use error_code, only: &
3647 : clubb_at_least_debug_level, & ! Procedure
3648 : err_code, & ! Error Indicator
3649 : clubb_fatal_error ! Constants
3650 :
3651 : use stats_type_utilities, only: &
3652 : stat_update_var ! Procedure(s)
3653 :
3654 : use stats_variables, only: &
3655 : stats_metadata_type
3656 :
3657 : use parameters_model, only: &
3658 : sclr_dim, & ! Variable(s)
3659 : sclr_tol
3660 :
3661 : use clubb_precision, only: &
3662 : core_rknd ! Variable(s)
3663 :
3664 : use constants_clubb, only: &
3665 : fstderr, & ! Constant
3666 : rt_tol, &
3667 : thl_tol, &
3668 : thl_tol_mfl, &
3669 : rt_tol_mfl, &
3670 : zero
3671 :
3672 : use model_flags, only: &
3673 : penta_bicgstab
3674 :
3675 : use stats_type, only: stats ! Type
3676 :
3677 : implicit none
3678 :
3679 : ! ------------------- Input Variables -------------------
3680 : integer, intent(in) :: &
3681 : nz, &
3682 : ngrdcol
3683 :
3684 : type (grid), target, intent(in) :: gr
3685 :
3686 : real( kind = core_rknd ), intent(in) :: &
3687 : dt ! Timestep [s]
3688 :
3689 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz) :: &
3690 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
3691 : wp2, & ! w'^2 (momentum levels) [m^2/s^2]
3692 : rtpthvp, & ! r_t'th_v' (momentum levels) [(kg/kg) K]
3693 : rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s]
3694 : wprtp_forcing, & ! <w'r_t'> forcing (momentum levels) [(kg/kg)/s^2]
3695 : thlpthvp, & ! th_l'th_v' (momentum levels) [K^2]
3696 : thlm_forcing, & ! th_l forcing (thermodynamic levels) [K/s]
3697 : wpthlp_forcing, & ! <w'th_l'> forcing (momentum levels) [K/s^2]
3698 : rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3]
3699 : rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3]
3700 : invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg]
3701 : invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg]
3702 : thv_ds_zm, & ! Dry, base-state theta_v on moment. levs. [K]
3703 : rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2]
3704 : thlp2 ! th_l'^2 (momentum levels) [K^2]
3705 :
3706 : logical, intent(in) :: &
3707 : l_implemented, & ! Flag for CLUBB being implemented in a larger model.
3708 : l_iter
3709 :
3710 : ! Additional variables for passive scalars
3711 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz,sclr_dim) :: &
3712 : sclrpthvp, & ! <sclr' th_v'> (momentum levels) [Units vary]
3713 : sclrm_forcing, & ! sclrm forcing (thermodynamic levels) [Units vary]
3714 : sclrp2 ! For clipping Vince Larson [Units vary]
3715 :
3716 : ! LHS/RHS terms
3717 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(in) :: &
3718 : lhs_diff_zm, & ! Diffusion term for w'x'
3719 : lhs_diff_zt, & ! Diffusion term for w'x'
3720 : lhs_ma_zt, & ! Mean advection contributions to lhs
3721 : lhs_ma_zm ! Mean advection contributions to lhs
3722 :
3723 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(in) :: &
3724 : lhs_ta_wprtp, & ! w'r_t' turbulent advection contributions to lhs
3725 : lhs_ta_wpthlp ! w'thl' turbulent advection contributions to lhs
3726 :
3727 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz,sclr_dim), intent(in) :: &
3728 : lhs_ta_wpsclrp ! w'sclr' turbulent advection contributions to lhs
3729 :
3730 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
3731 : rhs_ta_wprtp, & ! w'r_t' turbulent advection contributions to rhs
3732 : rhs_ta_wpthlp ! w'thl' turbulent advection contributions to rhs
3733 :
3734 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim), intent(in) :: &
3735 : rhs_ta_wpsclrp ! w'sclr' turbulent advection contributions to rhs
3736 :
3737 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz), intent(in) :: &
3738 : lhs_tp, & ! Turbulent production terms of w'x'
3739 : lhs_ta_xm ! Turbulent advection terms of xm
3740 :
3741 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
3742 : lhs_ac_pr2, & ! Accumulation of w'x' and w'x' pressure term 2
3743 : lhs_pr1_wprtp, & ! Pressure term 1 for w'r_t' for all grid levels
3744 : lhs_pr1_wpthlp, & ! Pressure term 1 for w'thl' for all grid levels
3745 : lhs_pr1_wpsclrp ! Pressure term 1 for w'sclr' for all grid levels
3746 :
3747 : ! Variables used as part of the monotonic turbulent advection scheme.
3748 : ! Find the lowermost and uppermost grid levels that can have an effect
3749 : ! on the central thermodynamic level during the course of a time step,
3750 : ! due to the effects of turbulent advection only.
3751 : integer, dimension(ngrdcol,nz), intent(in) :: &
3752 : low_lev_effect, & ! Index of the lowest level that has an effect.
3753 : high_lev_effect ! Index of the highest level that has an effect.
3754 :
3755 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
3756 : C7_Skw_fnc
3757 :
3758 : integer, intent(in) :: &
3759 : nrhs ! Number of RHS vectors
3760 :
3761 : integer, intent(in) :: &
3762 : tridiag_solve_method ! Specifier for method to solve tridiagonal systems
3763 :
3764 : logical, intent(in) :: &
3765 : l_predict_upwp_vpwp, & ! Flag to predict <u'w'> and <v'w'> along
3766 : ! with <u> and <v> alongside the advancement
3767 : ! of <rt>, <w'rt'>, <thl>, <wpthlp>, <sclr>,
3768 : ! and <w'sclr'> in subroutine advance_xm_wpxp.
3769 : ! Otherwise, <u'w'> and <v'w'> are still
3770 : ! approximated by eddy diffusivity when <u>
3771 : ! and <v> are advanced in subroutine
3772 : ! advance_windm_edsclrm.
3773 : l_diffuse_rtm_and_thlm, & ! This flag determines whether or not we want
3774 : ! CLUBB to do diffusion on rtm and thlm
3775 : l_upwind_xm_ma, & ! This flag determines whether we want to use
3776 : ! an upwind differencing approximation rather
3777 : ! than a centered differencing for turbulent
3778 : ! or mean advection terms. It affects rtm,
3779 : ! thlm, sclrm, um and vm.
3780 : l_tke_aniso, & ! For anisotropic turbulent kinetic energy,
3781 : ! i.e. TKE = 1/2 (u'^2 + v'^2 + w'^2)
3782 : l_enable_relaxed_clipping, & ! Flag to relax clipping on wpxp in
3783 : ! xm_wpxp_clipping_and_stats
3784 : l_mono_flux_lim_thlm, & ! Flag to turn on monotonic flux limiter for thlm
3785 : l_mono_flux_lim_rtm, & ! Flag to turn on monotonic flux limiter for rtm
3786 : l_mono_flux_lim_um, & ! Flag to turn on monotonic flux limiter for um
3787 : l_mono_flux_lim_vm, & ! Flag to turn on monotonic flux limiter for vm
3788 : l_mono_flux_lim_spikefix ! Flag to implement monotonic flux limiter code that
3789 : ! eliminates spurious drying tendencies at model top
3790 :
3791 : integer, intent(in) :: &
3792 : penta_solve_method ! Method to solve then penta-diagonal system
3793 :
3794 : integer, intent(in) :: &
3795 : order_xm_wpxp, &
3796 : order_xp2_xpyp, &
3797 : order_wp2_wp3
3798 :
3799 : type (stats_metadata_type), intent(in) :: &
3800 : stats_metadata
3801 :
3802 : ! ------------------- Input/Output Variables -------------------
3803 :
3804 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
3805 : stats_zt, &
3806 : stats_zm, &
3807 : stats_sfc
3808 :
3809 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz) :: &
3810 : rtm, & ! r_t (total water mixing ratio) [kg/kg]
3811 : wprtp, & ! w'r_t' [(kg/kg) m/s]
3812 : thlm, & ! th_l (liquid water potential temperature) [K]
3813 : wpthlp ! w'th_l' [K m/s]
3814 :
3815 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz,sclr_dim) :: &
3816 : sclrm, wpsclrp ! [Units vary]
3817 :
3818 : ! ------------------- Local Variables -------------------
3819 :
3820 : real( kind = core_rknd ), dimension(nsup+nsub+1,ngrdcol,2*nz) :: &
3821 0 : lhs ! Implicit contributions to wpxp/xm (band diag. matrix) (LAPACK)
3822 :
3823 : real( kind = core_rknd ), dimension(ngrdcol,2*nz,nrhs) :: &
3824 0 : rhs, & ! Right-hand sides of band diag. matrix. (LAPACK)
3825 0 : rhs_save, & ! Saved Right-hand sides of band diag. matrix. (LAPACK)
3826 0 : solution, & ! solution vectors of band diag. matrix. (LAPACK)
3827 0 : old_solution ! previous solutions
3828 :
3829 : ! Additional variables for passive scalars
3830 : real( kind = core_rknd ), dimension(ngrdcol,nz,sclr_dim) :: &
3831 0 : wpsclrp_forcing ! <w'sclr'> forcing (momentum levels) [m/s{un vary}]
3832 :
3833 : ! Variables used for clipping of w'x' due to correlation
3834 : ! of w with x, such that:
3835 : ! corr_(w,x) = w'x' / [ sqrt(w'^2) * sqrt(x'^2) ];
3836 : ! -1 <= corr_(w,x) <= 1.
3837 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
3838 0 : wpxp_upper_lim, & ! Keeps correlations from becoming greater than 1.
3839 0 : wpxp_lower_lim ! Keeps correlations from becoming less than -1.
3840 :
3841 : ! Constant parameters as a function of Skw.
3842 :
3843 0 : real( kind = core_rknd ), dimension(ngrdcol) :: rcond
3844 :
3845 : integer :: i, j, k
3846 :
3847 : ! ------------------- Begin Code -------------------
3848 :
3849 : ! Compute the implicit portion of the r_t and w'r_t' equations.
3850 : ! Build the left-hand side matrix.
3851 : call xm_wpxp_lhs( nz, ngrdcol, l_iter, dt, wprtp, wm_zt, C7_Skw_fnc, & ! In
3852 : wpxp_upper_lim, wpxp_lower_lim, & ! In
3853 : l_implemented, lhs_diff_zm, lhs_diff_zt, & ! In
3854 : lhs_ma_zm, lhs_ma_zt, lhs_ta_wprtp, lhs_ta_xm, & ! In
3855 : lhs_tp, lhs_pr1_wprtp, lhs_ac_pr2, & ! In
3856 : l_diffuse_rtm_and_thlm, & ! In
3857 : stats_metadata, & ! In
3858 0 : lhs ) ! Out
3859 :
3860 : ! Compute the explicit portion of the r_t and w'r_t' equations.
3861 : ! Build the right-hand side vector.
3862 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! In
3863 : rtm_forcing, wprtp_forcing, C7_Skw_fnc, & ! In
3864 : rtpthvp, rhs_ta_wprtp, thv_ds_zm, & ! In
3865 : lhs_pr1_wprtp, lhs_ta_wprtp, & ! In
3866 : stats_metadata, & ! In
3867 : stats_zt, stats_zm, & ! Inout
3868 0 : rhs(:,:,1) ) ! Out
3869 :
3870 : ! Save the value of rhs, which will be overwritten with the solution as
3871 : ! part of the solving routine.
3872 0 : rhs_save = rhs
3873 :
3874 : ! Use the previous solution as an initial guess for the bicgstab method
3875 0 : if ( penta_solve_method == penta_bicgstab ) then
3876 0 : do k = 1, nz
3877 0 : old_solution(:,2*k-1,1) = rtm(:,k)
3878 0 : old_solution(:,2*k ,1) = wprtp(:,k)
3879 : end do
3880 : end if
3881 :
3882 : ! Solve r_t / w'r_t'
3883 0 : if ( stats_metadata%l_stats_samp .and. stats_metadata%irtm_matrix_condt_num > 0 ) then
3884 : call xm_wpxp_solve( nz, ngrdcol, gr, nrhs, & ! Intent(in)
3885 : old_solution, & ! Intent(in)
3886 : penta_solve_method, & ! Intent(in)
3887 : lhs, rhs, & ! Intent(inout)
3888 0 : solution, rcond ) ! Intent(out)
3889 : else
3890 : call xm_wpxp_solve( nz, ngrdcol, gr, nrhs, & ! Intent(in)
3891 : old_solution, & ! Intent(in)
3892 : penta_solve_method, & ! Intent(in)
3893 : lhs, rhs, & ! Intent(inout)
3894 0 : solution ) ! Intent(out)
3895 : end if
3896 :
3897 0 : if ( clubb_at_least_debug_level( 0 ) ) then
3898 0 : if ( err_code == clubb_fatal_error ) then
3899 0 : do i = 1, ngrdcol
3900 0 : write(fstderr,*) "Mean total water & total water flux LU decomp. failed"
3901 0 : write(fstderr,*) "rtm and wprtp LHS"
3902 0 : do k = 1, nz
3903 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, "height [m] = ", gr%zt(i,k), &
3904 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k-1)
3905 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, "height [m] = ", gr%zm(i,k), &
3906 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k)
3907 : end do ! k = 1, nz
3908 0 : write(fstderr,*) "rtm and wprtp RHS"
3909 0 : do k = 1, nz
3910 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, "height [m] = ", gr%zt(i,k), &
3911 0 : "RHS = ", rhs_save(i,2*k-1,1)
3912 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, "height [m] = ", gr%zm(i,k), &
3913 0 : "RHS = ", rhs_save(i,2*k,1)
3914 : end do ! k = 1, nz
3915 : end do
3916 : return
3917 : end if
3918 : end if
3919 :
3920 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
3921 : gr, xm_wpxp_rtm, dt, wp2, rtp2, wm_zt, & ! Intent(in)
3922 : rtm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in)
3923 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
3924 : rt_tol**2, rt_tol, rcond, & ! Intent(in)
3925 : low_lev_effect, high_lev_effect, & ! Intent(in)
3926 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wprtp, & ! Intent(in)
3927 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
3928 : lhs_tp, lhs_ta_xm, lhs_pr1_wprtp, & ! Intent(in)
3929 : l_implemented, solution(:,:,1), & ! Intent(in)
3930 : tridiag_solve_method, & ! Intent(in)
3931 : l_predict_upwp_vpwp, & ! Intent(in)
3932 : l_upwind_xm_ma, & ! Intent(in)
3933 : l_tke_aniso, & ! Intent(in)
3934 : l_enable_relaxed_clipping, & ! Intent(in)
3935 : l_mono_flux_lim_thlm, &
3936 : l_mono_flux_lim_rtm, &
3937 : l_mono_flux_lim_um, &
3938 : l_mono_flux_lim_vm, &
3939 : l_mono_flux_lim_spikefix, &
3940 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
3941 : order_wp2_wp3, & ! Intent(in)
3942 : stats_metadata, & ! Intent(in)
3943 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
3944 0 : rtm, rt_tol_mfl, wprtp ) ! Intent(inout)
3945 :
3946 0 : if ( clubb_at_least_debug_level( 0 ) ) then
3947 0 : if ( err_code == clubb_fatal_error ) then
3948 0 : write(fstderr,*) "rtm monotonic flux limiter: tridiag failed"
3949 0 : return
3950 : end if
3951 : end if
3952 :
3953 : ! Compute the implicit portion of the th_l and w'th_l' equations.
3954 : ! Build the left-hand side matrix.
3955 : call xm_wpxp_lhs( nz, ngrdcol, l_iter, dt, wpthlp, wm_zt, C7_Skw_fnc, & ! In
3956 : wpxp_upper_lim, wpxp_lower_lim, & ! In
3957 : l_implemented, lhs_diff_zm, lhs_diff_zt, & ! In
3958 : lhs_ma_zm, lhs_ma_zt, lhs_ta_wpthlp, lhs_ta_xm, & ! In
3959 : lhs_tp, lhs_pr1_wpthlp, lhs_ac_pr2, & ! In
3960 : l_diffuse_rtm_and_thlm, & ! In
3961 : stats_metadata, & ! In
3962 0 : lhs ) ! Out
3963 :
3964 : ! Compute the explicit portion of the th_l and w'th_l' equations.
3965 : ! Build the right-hand side vector.
3966 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! In
3967 : thlm_forcing, wpthlp_forcing, C7_Skw_fnc, & ! In
3968 : thlpthvp, rhs_ta_wpthlp, thv_ds_zm, & ! In
3969 : lhs_pr1_wpthlp, lhs_ta_wpthlp, & ! In
3970 : stats_metadata, & ! In
3971 : stats_zt, stats_zm, & ! Inout
3972 0 : rhs(:,:,1) ) ! Out
3973 :
3974 : ! Save the value of rhs, which will be overwritten with the solution as
3975 : ! part of the solving routine.
3976 0 : rhs_save = rhs
3977 :
3978 : ! Use the previous solution as an initial guess for the bicgstab method
3979 0 : if ( penta_solve_method == penta_bicgstab ) then
3980 0 : do k = 1, nz
3981 0 : old_solution(:,2*k-1,1) = thlm(:,k)
3982 0 : old_solution(:,2*k ,1) = wpthlp(:,k)
3983 : end do
3984 : end if
3985 :
3986 : ! Solve for th_l / w'th_l'
3987 0 : if ( stats_metadata%l_stats_samp .and. stats_metadata%ithlm_matrix_condt_num > 0 ) then
3988 : call xm_wpxp_solve( nz, ngrdcol, gr, nrhs, & ! Intent(in)
3989 : old_solution, & ! Intent(in)
3990 : penta_solve_method, & ! Intent(in)
3991 : lhs, rhs, & ! Intent(inout)
3992 0 : solution, rcond ) ! Intent(out)
3993 : else
3994 : call xm_wpxp_solve( nz, ngrdcol, gr, nrhs, & ! Intent(in)
3995 : old_solution, & ! Intent(in)
3996 : penta_solve_method, & ! Intent(in)
3997 : lhs, rhs, & ! Intent(inout)
3998 0 : solution ) ! Intent(out)
3999 : end if
4000 :
4001 0 : if ( clubb_at_least_debug_level( 0 ) ) then
4002 0 : if ( err_code == clubb_fatal_error ) then
4003 0 : do i = 1, ngrdcol
4004 0 : write(fstderr,*) "Liquid pot. temp & thetal flux LU decomp. failed"
4005 0 : write(fstderr,*) "thlm and wpthlp LHS"
4006 0 : do k = 1, nz
4007 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, "height [m] = ", gr%zt(i,k), &
4008 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k-1)
4009 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, "height [m] = ", gr%zm(i,k), &
4010 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k)
4011 : end do ! k = 1, nz
4012 0 : write(fstderr,*) "thlm and wpthlp RHS"
4013 0 : do k = 1, nz
4014 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, "height [m] = ", gr%zt(i,k), &
4015 0 : "RHS = ", rhs_save(i,2*k-1,1)
4016 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, "height [m] = ", gr%zm(i,k), &
4017 0 : "RHS = ", rhs_save(i,2*k,1)
4018 : end do ! k = 1, nz
4019 : end do
4020 : return
4021 : end if
4022 : end if
4023 :
4024 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
4025 : gr, xm_wpxp_thlm, dt, wp2, thlp2, wm_zt, & ! Intent(in)
4026 : thlm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in)
4027 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
4028 : thl_tol**2, thl_tol, rcond, & ! Intent(in)
4029 : low_lev_effect, high_lev_effect, & ! Intent(in)
4030 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpthlp, & ! Intent(in)
4031 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
4032 : lhs_tp, lhs_ta_xm, lhs_pr1_wpthlp, & ! Intent(in)
4033 : l_implemented, solution(:,:,1), & ! Intent(in)
4034 : tridiag_solve_method, & ! Intent(in)
4035 : l_predict_upwp_vpwp, & ! Intent(in)
4036 : l_upwind_xm_ma, & ! Intent(in)
4037 : l_tke_aniso, & ! Intent(in)
4038 : l_enable_relaxed_clipping, & ! Intent(in)
4039 : l_mono_flux_lim_thlm, &
4040 : l_mono_flux_lim_rtm, &
4041 : l_mono_flux_lim_um, &
4042 : l_mono_flux_lim_vm, &
4043 : l_mono_flux_lim_spikefix, &
4044 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
4045 : order_wp2_wp3, & ! Intent(in)
4046 : stats_metadata, & ! Intent(in)
4047 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
4048 0 : thlm, thl_tol_mfl, wpthlp ) ! Intent(inout)
4049 :
4050 0 : if ( clubb_at_least_debug_level( 0 ) ) then
4051 0 : if ( err_code == clubb_fatal_error ) then
4052 0 : write(fstderr,*) "thlm monotonic flux limiter: tridiag failed"
4053 0 : return
4054 : end if
4055 : end if
4056 :
4057 : ! Solve sclrm / wpsclrp
4058 : ! If sclr_dim is 0, then this loop will execute 0 times.
4059 : ! ---> h1g, 2010-06-15
4060 : ! scalar transport, e.g, droplet and ice number concentration
4061 : ! are handled in " advance_sclrm_Nd_module.F90 "
4062 : #ifdef GFDL
4063 : do j = 1, 0, 1
4064 : #else
4065 0 : do j = 1, sclr_dim, 1
4066 : #endif
4067 : ! <--- h1g, 2010-06-15
4068 :
4069 : ! Set <w'sclr'> forcing to 0 unless unless testing the wpsclrp code
4070 : ! using wprtp or wpthlp (then use wprtp_forcing or wpthlp_forcing).
4071 0 : wpsclrp_forcing(:,:,j) = zero
4072 :
4073 : ! Compute the implicit portion of the sclr and w'sclr' equations.
4074 : ! Build the left-hand side matrix.
4075 : call xm_wpxp_lhs( nz, ngrdcol, l_iter, dt, wpsclrp(:,:,j), wm_zt, C7_Skw_fnc, & ! In
4076 : wpxp_upper_lim, wpxp_lower_lim, & ! In
4077 : l_implemented, lhs_diff_zm, lhs_diff_zt, & ! In
4078 : lhs_ma_zm, lhs_ma_zt, lhs_ta_wpsclrp(:,:,:,j), lhs_ta_xm, & ! In
4079 : lhs_tp, lhs_pr1_wpsclrp, lhs_ac_pr2, & ! In
4080 : l_diffuse_rtm_and_thlm, & ! In
4081 : stats_metadata, & ! In
4082 0 : lhs ) ! Out
4083 :
4084 : ! Compute the explicit portion of the sclrm and w'sclr' equations.
4085 : ! Build the right-hand side vector.
4086 : call xm_wpxp_rhs( nz, ngrdcol, xm_wpxp_scalar, l_iter, dt, sclrm(:,:,j), wpsclrp(:,:,j), & ! In
4087 : sclrm_forcing(:,:,j), & ! In
4088 : wpsclrp_forcing(:,:,j), C7_Skw_fnc, & ! In
4089 : sclrpthvp(:,:,j), rhs_ta_wpsclrp(:,:,j), thv_ds_zm, & ! In
4090 : lhs_pr1_wpsclrp, lhs_ta_wpsclrp(:,:,:,j), & ! In
4091 : stats_metadata, & ! In
4092 : stats_zt, stats_zm, & ! Inout
4093 0 : rhs(:,:,1) ) ! Out
4094 :
4095 : ! Save the value of rhs, which will be overwritten with the solution as
4096 : ! part of the solving routine.
4097 0 : rhs_save = rhs
4098 :
4099 : ! Use the previous solution as an initial guess for the bicgstab method
4100 0 : if ( penta_solve_method == penta_bicgstab ) then
4101 0 : do k = 1, nz
4102 0 : old_solution(:,2*k-1,1) = sclrm(:,k,j)
4103 0 : old_solution(:,2*k ,1) = wpsclrp(:,k,j)
4104 : end do
4105 : end if
4106 :
4107 : ! Solve for sclrm / w'sclr'
4108 : call xm_wpxp_solve( nz, ngrdcol, gr, nrhs, & ! Intent(in)
4109 : old_solution, & ! Intent(in)
4110 : penta_solve_method, & ! Intent(in)
4111 : lhs, rhs, & ! Intent(inout)
4112 0 : solution ) ! Intent(out)
4113 :
4114 0 : if ( clubb_at_least_debug_level( 0 ) ) then
4115 0 : if ( err_code == clubb_fatal_error ) then
4116 0 : do i = 1, ngrdcol
4117 0 : write(fstderr,*) "Passive scalar # ", j, " LU decomp. failed."
4118 0 : write(fstderr,*) "sclrm and wpsclrp LHS"
4119 0 : do k = 1, nz
4120 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, "height [m] = ", gr%zt(i,k), &
4121 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k-1)
4122 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, "height [m] = ", gr%zm(i,k), &
4123 0 : "LHS = ", lhs(1:nsup+nsub+1,i,2*k)
4124 : end do ! k = 1, nz
4125 0 : write(fstderr,*) "sclrm and wpsclrp RHS"
4126 0 : do k = 1, nz
4127 0 : write(fstderr,*) "grid col = ",i,"zt level = ", k, "height [m] = ", gr%zt(i,k), &
4128 0 : "RHS = ", rhs_save(i,2*k-1,1)
4129 0 : write(fstderr,*) "grid col = ",i,"zm level = ", k, "height [m] = ", gr%zm(i,k), &
4130 0 : "RHS = ", rhs_save(i,2*k,1)
4131 : end do ! k = 1, nz
4132 : end do
4133 : return
4134 : end if
4135 : end if
4136 :
4137 : call xm_wpxp_clipping_and_stats( nz, ngrdcol, & ! Intent(in)
4138 : gr, xm_wpxp_scalar, dt, wp2, sclrp2(:,:,j), wm_zt, & ! Intent(in)
4139 : sclrm_forcing(:,:,j), & ! Intent(in)
4140 : rho_ds_zm, rho_ds_zt, & ! Intent(in)
4141 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in)
4142 0 : sclr_tol(j)**2, sclr_tol(j), rcond, & ! Intent(in)
4143 : low_lev_effect, high_lev_effect, & ! Intent(in)
4144 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpsclrp(:,:,:,j), & ! Intent(in)
4145 : lhs_diff_zm, C7_Skw_fnc, & ! Intent(in)
4146 : lhs_tp, lhs_ta_xm, lhs_pr1_wpsclrp, & ! Intent(in)
4147 : l_implemented, solution(:,:,1), & ! Intent(in)
4148 : tridiag_solve_method, & ! Intent(in)
4149 : l_predict_upwp_vpwp, & ! Intent(in)
4150 : l_upwind_xm_ma, & ! Intent(in)
4151 : l_tke_aniso, & ! Intent(in)
4152 : l_enable_relaxed_clipping, & ! Intent(in)
4153 : l_mono_flux_lim_thlm, &
4154 : l_mono_flux_lim_rtm, &
4155 : l_mono_flux_lim_um, &
4156 : l_mono_flux_lim_vm, &
4157 : l_mono_flux_lim_spikefix, &
4158 : order_xm_wpxp, order_xp2_xpyp, & ! Intent(in)
4159 : order_wp2_wp3, & ! Intent(in)
4160 : stats_metadata, & ! Intent(in)
4161 : stats_zt, stats_zm, stats_sfc, & ! intent(inout)
4162 0 : sclrm(:,:,j), sclr_tol(j), wpsclrp(:,:,j) ) ! Intent(inout)
4163 :
4164 0 : if ( clubb_at_least_debug_level( 0 ) ) then
4165 0 : if ( err_code == clubb_fatal_error ) then
4166 0 : write(fstderr,*) "sclrm # ", j, "monotonic flux limiter: tridiag failed"
4167 0 : return
4168 : end if
4169 : end if
4170 :
4171 : end do ! passive scalars
4172 :
4173 : end subroutine solve_xm_wpxp_with_multiple_lhs
4174 :
4175 : !=============================================================================
4176 352944 : subroutine xm_wpxp_solve( nz, ngrdcol, gr, nrhs, &
4177 352944 : old_solution, &
4178 : penta_solve_method, &
4179 352944 : lhs, rhs, &
4180 352944 : solution, rcond )
4181 :
4182 : ! Description:
4183 : ! Solve for xm / w'x' using the band diagonal solver.
4184 :
4185 : ! References:
4186 : ! None
4187 : !------------------------------------------------------------------------
4188 :
4189 : use grid_class, only: &
4190 : grid ! Type
4191 :
4192 : use matrix_solver_wrapper, only: &
4193 : band_solve ! Procedure(s)
4194 :
4195 : use clubb_precision, only: &
4196 : core_rknd ! Variable(s)
4197 :
4198 : use constants_clubb, only: &
4199 : fstderr ! Constant(s)
4200 :
4201 : use error_code, only: &
4202 : clubb_at_least_debug_level, & ! Procedure
4203 : err_code, & ! Error indicator
4204 : clubb_no_error ! Constant
4205 :
4206 : implicit none
4207 :
4208 : integer, intent(in) :: &
4209 : nz, &
4210 : ngrdcol
4211 :
4212 : type (grid), target, intent(in) :: gr
4213 :
4214 : !------------------------- Input Variables -------------------------
4215 : integer, intent(in) :: &
4216 : nrhs ! Number of rhs vectors
4217 :
4218 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,2*nz,nrhs) :: &
4219 : old_solution ! Old solution, used as an initial guess in the bicgstab method
4220 :
4221 : integer, intent(in) :: &
4222 : penta_solve_method ! Method to solve then penta-diagonal system
4223 :
4224 : !------------------------- Input/Output Variables -------------------------
4225 : real( kind = core_rknd ), intent(inout), dimension(nsup+nsub+1,ngrdcol,2*nz) :: &
4226 : lhs ! Implicit contributions to wpxp/xm (band diag. matrix in LAPACK storage)
4227 :
4228 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,2*nz,nrhs) :: &
4229 : rhs ! Right-hand side of band diag. matrix. (LAPACK storage)
4230 :
4231 : !------------------------- Output Variables -------------------------
4232 : real( kind = core_rknd ), intent(out), dimension(ngrdcol,2*nz,nrhs) :: &
4233 : solution ! Solution to band diagonal system (LAPACK storage)
4234 :
4235 : real( kind = core_rknd ), optional, dimension(ngrdcol), intent(out) :: &
4236 : rcond ! Est. of the reciprocal of the condition #
4237 :
4238 : !------------------------- Begin Code -------------------------
4239 :
4240 : ! Solve the system
4241 : call band_solve( "xm_wpxp", penta_solve_method, & ! Intent(in)
4242 : ngrdcol, nsup, nsub, 2*nz, nrhs, & ! Intent(in)
4243 : old_solution, & ! Intent(in)
4244 : lhs, rhs, & ! Intent(inout)
4245 352944 : solution, rcond ) ! Intent(out)
4246 :
4247 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
4248 352944 : if ( err_code /= clubb_no_error ) then
4249 0 : write(fstderr,*) "Error in xm_wpxp_solve"
4250 0 : return
4251 : end if
4252 : end if
4253 :
4254 : return
4255 :
4256 : end subroutine xm_wpxp_solve
4257 :
4258 : !===============================================================================
4259 1411776 : subroutine xm_wpxp_clipping_and_stats( &
4260 1411776 : nz, ngrdcol, gr, solve_type, dt, wp2, xp2, wm_zt, &
4261 1411776 : xm_forcing, rho_ds_zm, rho_ds_zt, &
4262 1411776 : invrs_rho_ds_zm, invrs_rho_ds_zt, &
4263 1411776 : xp2_threshold, xm_threshold, rcond, &
4264 1411776 : low_lev_effect, high_lev_effect, &
4265 1411776 : lhs_ma_zt, lhs_ma_zm, lhs_ta_wpxp, &
4266 1411776 : lhs_diff_zm, C7_Skw_fnc, &
4267 1411776 : lhs_tp, lhs_ta_xm, lhs_pr1, &
4268 1411776 : l_implemented, solution, &
4269 : tridiag_solve_method, &
4270 : l_predict_upwp_vpwp, &
4271 : l_upwind_xm_ma, &
4272 : l_tke_aniso, &
4273 : l_enable_relaxed_clipping, &
4274 : l_mono_flux_lim_thlm, &
4275 : l_mono_flux_lim_rtm, &
4276 : l_mono_flux_lim_um, &
4277 : l_mono_flux_lim_vm, &
4278 : l_mono_flux_lim_spikefix, &
4279 : order_xm_wpxp, order_xp2_xpyp, &
4280 : order_wp2_wp3, &
4281 : stats_metadata, &
4282 1411776 : stats_zt, stats_zm, stats_sfc, &
4283 1411776 : xm, xm_tol, wpxp )
4284 :
4285 : ! Description:
4286 : ! Clips and computes implicit stats for an artitrary xm and wpxp
4287 : !
4288 : ! References:
4289 : ! None
4290 : !-----------------------------------------------------------------------
4291 :
4292 : use grid_class, only: &
4293 : grid ! Type
4294 :
4295 : use clubb_precision, only: &
4296 : core_rknd ! Variable(s)
4297 :
4298 : use mono_flux_limiter, only: &
4299 : monotonic_turbulent_flux_limit ! Procedure(s)
4300 :
4301 : use pos_definite_module, only: &
4302 : pos_definite_adj ! Procedure(s)
4303 :
4304 : use clip_explicit, only: &
4305 : clip_covar, & ! Procedure(s)
4306 : clip_wprtp, & ! Variable(s)
4307 : clip_wpthlp, &
4308 : clip_upwp, &
4309 : clip_vpwp, &
4310 : clip_wpsclrp
4311 :
4312 : use model_flags, only: &
4313 : l_pos_def, & ! Logical for whether to apply the positive definite scheme to rtm
4314 : l_hole_fill, & ! Logical for whether to apply the hole filling scheme to thlm/rtm
4315 : l_clip_turb_adv ! Logical for whether to clip xm when wpxp is clipped
4316 :
4317 : use constants_clubb, only: &
4318 : fstderr, & ! Constant(s)
4319 : one, &
4320 : zero, &
4321 : eps, &
4322 : gamma_over_implicit_ts, &
4323 : num_hf_draw_points
4324 :
4325 : use fill_holes, only: &
4326 : fill_holes_vertical ! Procedure
4327 :
4328 : use error_code, only: &
4329 : clubb_at_least_debug_level ! Procedure
4330 :
4331 : use stats_type_utilities, only: &
4332 : stat_begin_update, & ! Procedure(s)
4333 : stat_update_var_pt, &
4334 : stat_end_update_pt, &
4335 : stat_end_update, &
4336 : stat_update_var, &
4337 : stat_modify
4338 :
4339 : use stats_variables, only: &
4340 : stats_metadata_type
4341 :
4342 : use stats_type, only: stats ! Type
4343 :
4344 : implicit none
4345 :
4346 : !--------------------------- Input Variables ---------------------------
4347 : integer, intent(in) :: &
4348 : nz, &
4349 : ngrdcol
4350 :
4351 : type (grid), target, intent(in) :: gr
4352 :
4353 : logical :: &
4354 : l_first_clip_ts, &
4355 : l_last_clip_ts
4356 :
4357 : integer, intent(in) :: &
4358 : solve_type ! Variables being solved for.
4359 :
4360 : real( kind = core_rknd ), intent(in) :: &
4361 : dt ! Timestep [s]
4362 :
4363 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,nz) :: &
4364 : wp2, & ! w'^2 (momentum levels) [m^2/s^2]
4365 : xp2, & ! x'^2 (momentum levels) [{xm units}^2]
4366 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
4367 : xm_forcing, & ! xm forcings (thermodynamic levels) [units vary]
4368 : rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3]
4369 : rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3]
4370 : invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg]
4371 : invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg]
4372 :
4373 : real( kind = core_rknd ), intent(in) :: &
4374 : xp2_threshold, & ! Minimum allowable value of x'^2 [units vary]
4375 : xm_threshold, & ! Minimum allowable value of xm [units vary]
4376 : xm_tol ! Minimum allowable deviation of xm [units vary]
4377 :
4378 : real( kind = core_rknd ), dimension(ngrdcol), intent(in) :: &
4379 : rcond ! Reciprocal of the estimated condition number (from computing A^-1)
4380 :
4381 : ! Variables used as part of the monotonic turbulent advection scheme.
4382 : ! Find the lowermost and uppermost grid levels that can have an effect
4383 : ! on the central thermodynamic level during the course of a time step,
4384 : ! due to the effects of turbulent advection only.
4385 : integer, dimension(ngrdcol,nz), intent(in) :: &
4386 : low_lev_effect, & ! Index of the lowest level that has an effect.
4387 : high_lev_effect ! Index of the highest level that has an effect.
4388 :
4389 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(in) :: &
4390 : lhs_diff_zm, & ! Diffusion term for w'x'
4391 : lhs_ma_zt, & ! Mean advection contributions to lhs
4392 : lhs_ma_zm, & ! Mean advection contributions to lhs
4393 : lhs_ta_wpxp ! Turbulent advection contributions to lhs
4394 :
4395 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz), intent(in) :: &
4396 : lhs_tp, & ! Turbulent production terms of w'x'
4397 : lhs_ta_xm ! Turbulent advection terms of xm
4398 :
4399 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
4400 : lhs_pr1 ! Pressure term 1 for w'x'
4401 :
4402 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
4403 : C7_Skw_fnc
4404 :
4405 : logical, intent(in) :: &
4406 : l_implemented ! Flag for CLUBB being implemented in a larger model.
4407 :
4408 : real( kind = core_rknd ), intent(in), dimension(ngrdcol,2*nz) :: &
4409 : solution ! The <t+1> value of xm and wpxp [units vary]
4410 :
4411 : integer, intent(in) :: &
4412 : tridiag_solve_method ! Specifier for method to solve tridiagonal systems
4413 :
4414 : logical, intent(in) :: &
4415 : l_predict_upwp_vpwp, & ! Flag to predict <u'w'> and <v'w'> along
4416 : ! with <u> and <v> alongside the advancement
4417 : ! of <rt>, <w'rt'>, <thl>, <wpthlp>, <sclr>,
4418 : ! and <w'sclr'> in subroutine advance_xm_wpxp.
4419 : ! Otherwise, <u'w'> and <v'w'> are still
4420 : ! approximated by eddy diffusivity when <u>
4421 : ! and <v> are advanced in subroutine
4422 : ! advance_windm_edsclrm.
4423 : l_upwind_xm_ma, & ! This flag determines whether we want to use
4424 : ! an upwind differencing approximation rather
4425 : ! than a centered differencing for turbulent
4426 : ! or mean advection terms. It affects rtm,
4427 : ! thlm, sclrm, um and vm.
4428 : l_tke_aniso, & ! For anisotropic turbulent kinetic energy,
4429 : ! i.e. TKE = 1/2 (u'^2 + v'^2 + w'^2)
4430 : l_enable_relaxed_clipping, & ! Flag to relax clipping on wpxp in
4431 : ! xm_wpxp_clipping_and_stats
4432 : l_mono_flux_lim_thlm, & ! Flag to turn on monotonic flux limiter for thlm
4433 : l_mono_flux_lim_rtm, & ! Flag to turn on monotonic flux limiter for rtm
4434 : l_mono_flux_lim_um, & ! Flag to turn on monotonic flux limiter for um
4435 : l_mono_flux_lim_vm, & ! Flag to turn on monotonic flux limiter for vm
4436 : l_mono_flux_lim_spikefix ! Flag to implement monotonic flux limiter code that
4437 : ! eliminates spurious drying tendencies at model top
4438 :
4439 : integer, intent(in) :: &
4440 : order_xm_wpxp, &
4441 : order_xp2_xpyp, &
4442 : order_wp2_wp3
4443 :
4444 : type (stats_metadata_type), intent(in) :: &
4445 : stats_metadata
4446 :
4447 : !--------------------------- Input/Output Variables ---------------------------
4448 : real( kind = core_rknd ), intent(inout), dimension(ngrdcol,nz) :: &
4449 : xm, & ! The mean x field [units vary]
4450 : wpxp ! The flux of x [units vary m/s]
4451 :
4452 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
4453 : stats_zt, &
4454 : stats_zm, &
4455 : stats_sfc
4456 :
4457 : !--------------------------- Local Variables ---------------------------
4458 : integer :: &
4459 : solve_type_cl ! solve_type used for clipping statistics.
4460 :
4461 : character(len=10) :: &
4462 : solve_type_str ! solve_type as a string for debug output purposes
4463 :
4464 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
4465 2823552 : xm_old ! Old value of xm for positive definite scheme [units vary]
4466 :
4467 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
4468 2823552 : wpxp_pd, xm_pd ! Change in xm and wpxp due to the pos. def. scheme
4469 :
4470 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
4471 2823552 : wpxp_chnge, & ! Net change in w'x' due to clipping [units vary]
4472 2823552 : xp2_relaxed ! Value of x'^2 * clip_factor [units vary]
4473 :
4474 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
4475 2823552 : zero_vector, &
4476 2823552 : wpxp_ac, &
4477 2823552 : wpxp_pr2
4478 :
4479 : ! Indices
4480 : integer :: &
4481 : k, i, km1, kp1, &
4482 : k_xm, k_wpxp
4483 :
4484 : integer :: &
4485 : ixm_ta, &
4486 : ixm_ma, &
4487 : ixm_matrix_condt_num, &
4488 : ixm_pd, &
4489 : ixm_cl, &
4490 : iwpxp_ma, &
4491 : iwpxp_ta, &
4492 : iwpxp_tp, &
4493 : iwpxp_ac, &
4494 : iwpxp_pr1, &
4495 : iwpxp_pr2, &
4496 : iwpxp_dp1, &
4497 : iwpxp_pd, &
4498 : iwpxp_sicl
4499 :
4500 : ! --------------------------- Begin code ---------------------------
4501 :
4502 : !$acc enter data create( xm_old, wpxp_pd, xm_pd, wpxp_chnge, xp2_relaxed )
4503 :
4504 1764720 : select case ( solve_type )
4505 :
4506 : case ( xm_wpxp_rtm ) ! rtm/wprtp budget terms
4507 352944 : ixm_ta = stats_metadata%irtm_ta
4508 352944 : ixm_ma = stats_metadata%irtm_ma
4509 352944 : ixm_pd = stats_metadata%irtm_pd
4510 352944 : ixm_cl = stats_metadata%irtm_cl
4511 352944 : iwpxp_ma = stats_metadata%iwprtp_ma
4512 352944 : iwpxp_ta = stats_metadata%iwprtp_ta
4513 352944 : iwpxp_tp = stats_metadata%iwprtp_tp
4514 352944 : iwpxp_ac = stats_metadata%iwprtp_ac
4515 352944 : iwpxp_pr1 = stats_metadata%iwprtp_pr1
4516 352944 : iwpxp_pr2 = stats_metadata%iwprtp_pr2
4517 352944 : iwpxp_dp1 = stats_metadata%iwprtp_dp1
4518 352944 : iwpxp_pd = stats_metadata%iwprtp_pd
4519 352944 : iwpxp_sicl = stats_metadata%iwprtp_sicl
4520 :
4521 : ! This is a diagnostic from inverting the matrix, not a budget
4522 352944 : ixm_matrix_condt_num = stats_metadata%irtm_matrix_condt_num
4523 :
4524 : case ( xm_wpxp_thlm ) ! thlm/wpthlp budget terms
4525 352944 : ixm_ta = stats_metadata%ithlm_ta
4526 352944 : ixm_ma = stats_metadata%ithlm_ma
4527 352944 : ixm_pd = 0
4528 352944 : ixm_cl = stats_metadata%ithlm_cl
4529 352944 : iwpxp_ma = stats_metadata%iwpthlp_ma
4530 352944 : iwpxp_ta = stats_metadata%iwpthlp_ta
4531 352944 : iwpxp_tp = stats_metadata%iwpthlp_tp
4532 352944 : iwpxp_ac = stats_metadata%iwpthlp_ac
4533 352944 : iwpxp_pr1 = stats_metadata%iwpthlp_pr1
4534 352944 : iwpxp_pr2 = stats_metadata%iwpthlp_pr2
4535 352944 : iwpxp_dp1 = stats_metadata%iwpthlp_dp1
4536 352944 : iwpxp_pd = 0
4537 352944 : iwpxp_sicl = stats_metadata%iwpthlp_sicl
4538 :
4539 : ! This is a diagnostic from inverting the matrix, not a budget
4540 352944 : ixm_matrix_condt_num = stats_metadata%ithlm_matrix_condt_num
4541 :
4542 : case ( xm_wpxp_um ) ! um/upwp budget terms
4543 352944 : ixm_ta = stats_metadata%ium_ta
4544 352944 : ixm_ma = stats_metadata%ium_ma
4545 352944 : ixm_pd = 0
4546 352944 : ixm_cl = 0
4547 352944 : iwpxp_ma = stats_metadata%iupwp_ma
4548 352944 : iwpxp_ta = stats_metadata%iupwp_ta
4549 352944 : iwpxp_tp = stats_metadata%iupwp_tp
4550 352944 : iwpxp_ac = stats_metadata%iupwp_ac
4551 352944 : iwpxp_pr1 = stats_metadata%iupwp_pr1
4552 352944 : iwpxp_pr2 = stats_metadata%iupwp_pr2
4553 352944 : iwpxp_dp1 = stats_metadata%iupwp_dp1
4554 352944 : iwpxp_pd = 0
4555 352944 : iwpxp_sicl = 0
4556 :
4557 : ! This is a diagnostic from inverting the matrix, not a budget
4558 352944 : ixm_matrix_condt_num = 0
4559 :
4560 : case ( xm_wpxp_vm ) ! vm/vpwp budget terms
4561 352944 : ixm_ta = stats_metadata%ivm_ta
4562 352944 : ixm_ma = stats_metadata%ivm_ma
4563 352944 : ixm_pd = 0
4564 352944 : ixm_cl = 0
4565 352944 : iwpxp_ma = stats_metadata%ivpwp_ma
4566 352944 : iwpxp_ta = stats_metadata%ivpwp_ta
4567 352944 : iwpxp_tp = stats_metadata%ivpwp_tp
4568 352944 : iwpxp_ac = stats_metadata%ivpwp_ac
4569 352944 : iwpxp_pr1 = stats_metadata%ivpwp_pr1
4570 352944 : iwpxp_pr2 = stats_metadata%ivpwp_pr2
4571 352944 : iwpxp_dp1 = stats_metadata%ivpwp_dp1
4572 352944 : iwpxp_pd = 0
4573 352944 : iwpxp_sicl = 0
4574 :
4575 : ! This is a diagnostic from inverting the matrix, not a budget
4576 352944 : ixm_matrix_condt_num = 0
4577 :
4578 : case default ! this includes the sclrm case
4579 0 : ixm_ta = 0
4580 0 : ixm_ma = 0
4581 0 : ixm_pd = 0
4582 0 : ixm_cl = 0
4583 0 : iwpxp_ma = 0
4584 0 : iwpxp_ta = 0
4585 0 : iwpxp_tp = 0
4586 0 : iwpxp_ac = 0
4587 0 : iwpxp_pr1 = 0
4588 0 : iwpxp_pr2 = 0
4589 0 : iwpxp_dp1 = 0
4590 0 : iwpxp_pd = 0
4591 0 : iwpxp_sicl = 0
4592 :
4593 1411776 : ixm_matrix_condt_num = 0
4594 :
4595 : end select
4596 :
4597 : ! Copy result into output arrays
4598 : !$acc parallel loop gang vector collapse(2) default(present)
4599 121412736 : do k=1, nz
4600 2005148736 : do i = 1, ngrdcol
4601 :
4602 1883736000 : k_xm = 2 * k - 1
4603 1883736000 : k_wpxp = 2 * k
4604 :
4605 1883736000 : xm_old(i,k) = xm(i,k)
4606 :
4607 1883736000 : xm(i,k) = solution(i,k_xm)
4608 2003736960 : wpxp(i,k) = solution(i,k_wpxp)
4609 :
4610 : end do
4611 : end do ! k=1..nz
4612 : !$acc end parallel loop
4613 :
4614 : ! Lower boundary condition on xm
4615 : !$acc parallel loop gang vector default(present)
4616 23573376 : do i = 1, ngrdcol
4617 23573376 : xm(i,1) = xm(i,2)
4618 : end do
4619 : !$acc end parallel loop
4620 :
4621 :
4622 1411776 : if ( stats_metadata%l_stats_samp ) then
4623 :
4624 : !$acc update host( wm_zt, rcond, &
4625 : !$acc lhs_diff_zm, lhs_ma_zt, lhs_ma_zm, &
4626 : !$acc lhs_ta_wpxp, lhs_tp, lhs_ta_xm, &
4627 : !$acc lhs_pr1, C7_Skw_fnc, xm, wpxp )
4628 :
4629 0 : zero_vector(:,:) = 0.0_core_rknd
4630 :
4631 : ! Note: To find the contribution of w'x' term ac,
4632 : ! substitute 0 for the C_7 skewness function input
4633 : ! to function wpxp_terms_ac_pr2_lhs.
4634 : call wpxp_terms_ac_pr2_lhs( nz, ngrdcol, zero_vector, & ! intent(in)
4635 : wm_zt, gr%invrs_dzm, & ! intent(in)
4636 0 : wpxp_ac ) ! intent(out)
4637 :
4638 : ! Note: To find the contribution of w'x' term pr2,
4639 : ! add 1 to the C_7 skewness function input
4640 : ! to function wpxp_terms_ac_pr2_lhs.
4641 : call wpxp_terms_ac_pr2_lhs( nz, ngrdcol, (one+C7_Skw_fnc), & ! intent(in)
4642 : wm_zt, gr%invrs_dzm, & ! intent(in)
4643 0 : wpxp_pr2 ) ! intent(out)
4644 :
4645 0 : do i = 1, ngrdcol
4646 :
4647 0 : if ( ixm_matrix_condt_num > 0 ) then
4648 : ! Est. of the condition number of the mean/flux LHS matrix
4649 0 : call stat_update_var_pt( ixm_matrix_condt_num, 1, one / rcond(i), & ! intent(in)
4650 0 : stats_sfc(i) ) ! intent(inout)
4651 : end if
4652 :
4653 : ! The xm loop runs between k = 2 and k = nz. The value of xm at
4654 : ! level k = 1, which is below the model surface, is simply set equal to
4655 : ! the value of xm at level k = 2 after the solve has been completed.
4656 : ! Thus, the statistical code will run from levels 2 through nz.
4657 :
4658 0 : do k = 2, nz
4659 :
4660 0 : km1 = max( k-1, 1 )
4661 0 : kp1 = min( k+1, nz )
4662 :
4663 : ! Finalize implicit contributions for xm
4664 :
4665 : ! xm term ma is completely implicit; call stat_update_var_pt.
4666 0 : if ( .not. l_implemented ) then
4667 : call stat_update_var_pt( ixm_ma, k, & ! intent(in)
4668 0 : (-lhs_ma_zt(3,i,k)) * xm(i,km1) &
4669 : + (-lhs_ma_zt(2,i,k)) * xm(i,k) &
4670 0 : + (-lhs_ma_zt(1,i,k)) * xm(i,kp1), & ! intent(in)
4671 0 : stats_zt(i) ) ! intent(inout)
4672 : end if
4673 :
4674 : ! xm term ta is completely implicit; call stat_update_var_pt.
4675 : call stat_update_var_pt( ixm_ta, k, & ! intent(in)
4676 0 : (-lhs_ta_xm(2,i,k)) * wpxp(i,km1) &
4677 : + (-lhs_ta_xm(1,i,k)) * wpxp(i,k), & ! intent(in)
4678 0 : stats_zt(i) ) ! intent(inout)
4679 :
4680 : enddo ! xm loop: 2..nz
4681 :
4682 : ! The wpxp loop runs between k = 2 and k = nz-1. The value of wpxp
4683 : ! is set to specified values at both the lowest level, k = 1, and the
4684 : ! highest level, k = nz. Thus, the statistical code will run from
4685 : ! levels 2 through nz-1.
4686 :
4687 0 : do k = 2, nz-1
4688 :
4689 0 : km1 = max( k-1, 1 )
4690 0 : kp1 = min( k+1, nz )
4691 :
4692 : ! Finalize implicit contributions for wpxp
4693 :
4694 : ! w'x' term ma is completely implicit; call stat_update_var_pt.
4695 : call stat_update_var_pt( iwpxp_ma, k, & ! intent(in)
4696 0 : (-lhs_ma_zm(3,i,k)) * wpxp(i,km1) &
4697 : + (-lhs_ma_zm(2,i,k)) * wpxp(i,k) &
4698 0 : + (-lhs_ma_zm(1,i,k)) * wpxp(i,kp1), & ! intent(in)
4699 0 : stats_zm(i) ) ! intent(inout)
4700 :
4701 :
4702 : call stat_end_update_pt( iwpxp_ta, k, & ! intent(in)
4703 0 : (-gamma_over_implicit_ts*lhs_ta_wpxp(3,i,k)) * wpxp(i,km1) &
4704 : + (-gamma_over_implicit_ts*lhs_ta_wpxp(2,i,k)) * wpxp(i,k) &
4705 : + (-gamma_over_implicit_ts*lhs_ta_wpxp(1,i,k)) * wpxp(i,kp1), & ! intent(in)
4706 0 : stats_zm(i) ) ! intent(inout)
4707 :
4708 : ! w'x' term tp is completely implicit; call stat_update_var_pt.
4709 : call stat_update_var_pt( iwpxp_tp, k, & ! intent(in)
4710 0 : (-lhs_tp(2,i,k)) * xm(i,k) &
4711 : + (-lhs_tp(1,i,k)) * xm(i,kp1), & ! intent(in)
4712 0 : stats_zm(i) ) ! intent(inout)
4713 :
4714 : ! w'x' term ac is completely implicit; call stat_update_var_pt.
4715 : call stat_update_var_pt( iwpxp_ac, k, & ! intent(in)
4716 0 : -wpxp_ac(i,k) * wpxp(i,k), & ! intent(in)
4717 0 : stats_zm(i) ) ! intent(inout)
4718 :
4719 : ! w'x' term pr1 is normally completely implicit. However, due to the
4720 : ! RHS contribution from the "over-implicit" weighted time step,
4721 : ! w'x' term pr1 has both implicit and explicit components;
4722 : ! call stat_end_update_pt.
4723 : ! Note: An "over-implicit" weighted time step is applied to this term.
4724 : ! A weighting factor of greater than 1 may be used to make the
4725 : ! term more numerically stable (see note above for LHS turbulent
4726 : ! advection (ta) term).
4727 : call stat_end_update_pt( iwpxp_pr1, k, & ! intent(in)
4728 0 : (-gamma_over_implicit_ts*lhs_pr1(i,k)) * wpxp(i,k), & ! intent(in)
4729 0 : stats_zm(i) ) ! intent(inout)
4730 :
4731 : call stat_update_var_pt( iwpxp_pr2, k, & ! intent(in)
4732 0 : -wpxp_pr2(i,k) * wpxp(i,k), & ! intent(in)
4733 0 : stats_zm(i) ) ! intent(inout)
4734 :
4735 : ! w'x' term dp1 is completely implicit; call stat_update_var_pt.
4736 : call stat_update_var_pt( iwpxp_dp1, k, & ! intent(in)
4737 0 : (-lhs_diff_zm(3,i,k)) * wpxp(i,km1) &
4738 : + (-lhs_diff_zm(2,i,k)) * wpxp(i,k) &
4739 : + (-lhs_diff_zm(1,i,k)) * wpxp(i,kp1), & ! intent(in)
4740 0 : stats_zm(i) ) ! intent(inout)
4741 :
4742 : end do ! wpxp loop: 2..nz-1
4743 :
4744 : end do
4745 :
4746 : end if ! stats_metadata%l_stats_samp
4747 :
4748 :
4749 : ! Apply a monotonic turbulent flux limiter to xm/w'x'.
4750 : if ( ( l_mono_flux_lim_thlm .and. solve_type == xm_wpxp_thlm ) .or. &
4751 : ( l_mono_flux_lim_rtm .and. solve_type == xm_wpxp_rtm ) .or. &
4752 1411776 : ( l_mono_flux_lim_um .and. solve_type == xm_wpxp_um ) .or. &
4753 : ( l_mono_flux_lim_vm .and. solve_type == xm_wpxp_vm ) ) then
4754 :
4755 : call monotonic_turbulent_flux_limit( nz, ngrdcol, gr, solve_type, dt, xm_old, & ! intent(in)
4756 : xp2, wm_zt, xm_forcing, & ! intent(in)
4757 : rho_ds_zm, rho_ds_zt, & ! intent(in)
4758 : invrs_rho_ds_zm, invrs_rho_ds_zt, & ! intent(in)
4759 : xp2_threshold, xm_tol, l_implemented, & ! intent(in)
4760 : low_lev_effect, high_lev_effect, & ! intent(in)
4761 : tridiag_solve_method, & ! intent(in)
4762 : l_upwind_xm_ma, & ! intent(in)
4763 : l_mono_flux_lim_spikefix, & ! intent(in)
4764 : stats_metadata, & ! intent(in)
4765 : stats_zt, stats_zm, & ! intent(inout)
4766 1411776 : xm, wpxp ) ! intent(inout)
4767 :
4768 : end if ! l_mono_flux_lim
4769 :
4770 : ! Apply a flux limiting positive definite scheme if the solution
4771 : ! for the mean field is negative and we're determining total water
4772 : if ( solve_type == xm_wpxp_rtm .and. l_pos_def ) then
4773 :
4774 : !$acc update host( xm, xm_old, wpxp )
4775 :
4776 : ! If any xm values are negative and the values at the previous
4777 : ! timestep were all non-negative, then call pos_definite_adj
4778 : if ( any( xm(:,:) < zero ) .and. .not. any( xm_old(:,:) < zero ) ) then
4779 :
4780 : call pos_definite_adj( nz, ngrdcol, gr, dt, "zt", & ! intent(in)
4781 : xm, wpxp, xm_old, & ! intent(inout)
4782 : xm_pd, wpxp_pd ) ! intent(out)
4783 : end if
4784 :
4785 : !$acc update device( xm, wpxp, xm_old )
4786 :
4787 : else
4788 : ! For stats purposes
4789 1411776 : if ( stats_metadata%l_stats_samp ) then
4790 0 : xm_pd(:,:) = zero
4791 0 : wpxp_pd(:,:) = zero
4792 : end if
4793 :
4794 : end if ! l_pos_def and solve_type == "rtm" and rtm <n+1> less than 0
4795 :
4796 1411776 : if ( stats_metadata%l_stats_samp ) then
4797 :
4798 : !$acc update host( xm )
4799 :
4800 0 : do i = 1, ngrdcol
4801 0 : call stat_update_var( iwpxp_pd, wpxp_pd(i,1:nz), & ! intent(in)
4802 0 : stats_zm(i) ) ! intent(inout)
4803 :
4804 0 : call stat_update_var( ixm_pd, xm_pd(i,1:nz), & ! intent(in)
4805 0 : stats_zt(i) ) ! intent(inout)
4806 :
4807 : ! Computed value before clipping
4808 0 : call stat_begin_update( nz, ixm_cl, xm(i,:) / dt, & ! Intent(in)
4809 0 : stats_zt(i) ) ! Intent(inout)
4810 : end do
4811 : end if
4812 :
4813 1411776 : if ( solve_type /= xm_wpxp_um .and. solve_type /= xm_wpxp_vm .and. l_hole_fill ) then
4814 :
4815 705888 : if ( clubb_at_least_debug_level( 3 ) ) then
4816 :
4817 : !$acc update host( xm )
4818 :
4819 0 : if ( any( xm < xm_threshold) ) then
4820 :
4821 0 : select case ( solve_type )
4822 : case ( xm_wpxp_rtm )
4823 0 : solve_type_str = "rtm"
4824 : case ( xm_wpxp_thlm )
4825 0 : solve_type_str = "thlm"
4826 : case default
4827 0 : solve_type_str = "scalars"
4828 : end select
4829 :
4830 0 : do i = 1, ngrdcol
4831 0 : do k = 1, nz
4832 0 : if ( xm(i,k) < xm_threshold ) then
4833 0 : write(fstderr,*) solve_type_str//" < ", xm_threshold, &
4834 0 : " in advance_xm_wpxp_module at k= ", k, "i=", i
4835 : end if
4836 : end do
4837 : end do
4838 :
4839 : end if
4840 : end if
4841 :
4842 : ! upper_hf_level = nz since we are filling the zt levels
4843 : call fill_holes_vertical( nz, ngrdcol, num_hf_draw_points, xm_threshold, nz, & ! In
4844 : gr%dzt, rho_ds_zt, & ! In
4845 705888 : xm ) ! InOut
4846 :
4847 : ! Hole filling does not affect the below ground level, perform a blunt clipping
4848 : ! here on that level to prevent small values of xm(1)
4849 : !$acc parallel loop gang vector default(present)
4850 11786688 : do i = 1, ngrdcol
4851 953654688 : if ( any( xm(i,:) < xm_threshold) ) then
4852 0 : xm(i,1) = max( xm(i,1), xm_tol )
4853 : end if
4854 : end do
4855 : !$acc end parallel loop
4856 :
4857 : end if
4858 :
4859 1411776 : if ( stats_metadata%l_stats_samp ) then
4860 : !$acc update host( xm )
4861 0 : do i = 1, ngrdcol
4862 0 : call stat_end_update( nz, ixm_cl, xm(i,:) / dt, & ! Intent(in)
4863 0 : stats_zt(i) ) ! Intent(inout)
4864 : end do
4865 : end if
4866 :
4867 : ! Clipping for w'x'
4868 : ! Clipping w'x' at each vertical level, based on the
4869 : ! correlation of w and x at each vertical level, such that:
4870 : ! corr_(w,x) = w'x' / [ sqrt(w'^2) * sqrt(x'^2) ];
4871 : ! -1 <= corr_(w,x) <= 1.
4872 : ! Since w'^2, x'^2, and w'x' are updated in different places
4873 : ! from each other, clipping for w'x' has to be done three times
4874 : ! (three times each for w'r_t', w'th_l', and w'sclr'). This is
4875 : ! the second instance of w'x' clipping.
4876 :
4877 : ! Compute a slightly larger value of rt'^2 for clipping purposes. This was
4878 : ! added to prevent a situation in which both the variance and flux are small
4879 : ! and the simulation gets "stuck" at the rt_tol^2 value.
4880 : ! See ticket #389 on the CLUBB TRAC for further details.
4881 : ! -dschanen 10 Jan 2011
4882 1411776 : if ( l_enable_relaxed_clipping ) then
4883 0 : if ( solve_type == xm_wpxp_rtm ) then
4884 :
4885 : !$acc parallel loop gang vector collapse(2) default(present)
4886 0 : do k = 1, nz
4887 0 : do i = 1, ngrdcol
4888 0 : xp2_relaxed(i,k) = max( 1e-7_core_rknd , xp2(i,k) )
4889 : end do
4890 : end do
4891 : !$acc end parallel loop
4892 :
4893 0 : else if ( solve_type == xm_wpxp_thlm ) then
4894 :
4895 : !$acc parallel loop gang vector collapse(2) default(present)
4896 0 : do k = 1, nz
4897 0 : do i = 1, ngrdcol
4898 0 : xp2_relaxed(i,k) = max( 0.01_core_rknd, xp2(i,k) )
4899 : end do
4900 : end do
4901 : !$acc end parallel loop
4902 :
4903 : else ! This includes the passive scalars
4904 :
4905 : !$acc parallel loop gang vector collapse(2) default(present)
4906 0 : do k = 1, nz
4907 0 : do i = 1, ngrdcol
4908 0 : xp2_relaxed(i,k) = max( 1e-7_core_rknd , xp2(i,k) )
4909 : end do
4910 : end do
4911 : !$acc end parallel loop
4912 :
4913 : end if
4914 :
4915 : else ! Don't relax clipping
4916 :
4917 : !$acc parallel loop gang vector collapse(2) default(present)
4918 121412736 : do k = 1, nz
4919 2005148736 : do i = 1, ngrdcol
4920 2003736960 : xp2_relaxed(i,k) = xp2(i,k)
4921 : end do
4922 : end do
4923 : !$acc end parallel loop
4924 :
4925 : end if
4926 :
4927 1411776 : if ( order_xm_wpxp < order_wp2_wp3 .and. order_xm_wpxp < order_xp2_xpyp ) then
4928 1411776 : l_first_clip_ts = .true.
4929 1411776 : l_last_clip_ts = .false.
4930 0 : elseif ( order_xm_wpxp > order_wp2_wp3 .and. order_xm_wpxp > order_xp2_xpyp ) then
4931 0 : l_first_clip_ts = .false.
4932 0 : l_last_clip_ts = .true.
4933 : else
4934 0 : l_first_clip_ts = .false.
4935 0 : l_last_clip_ts = .false.
4936 : endif
4937 :
4938 : ! Use solve_type to find solve_type_cl, which is used
4939 : ! in subroutine clip_covar.
4940 352944 : select case ( solve_type )
4941 : case ( xm_wpxp_rtm )
4942 352944 : solve_type_cl = clip_wprtp
4943 : case ( xm_wpxp_thlm )
4944 352944 : solve_type_cl = clip_wpthlp
4945 : case ( xm_wpxp_um )
4946 352944 : solve_type_cl = clip_upwp
4947 : case ( xm_wpxp_vm )
4948 352944 : solve_type_cl = clip_vpwp
4949 : case default
4950 1411776 : solve_type_cl = clip_wpsclrp
4951 : end select
4952 :
4953 1411776 : if ( solve_type /= xm_wpxp_um .and. solve_type /= xm_wpxp_vm ) then
4954 : call clip_covar( nz, ngrdcol, gr, solve_type_cl, l_first_clip_ts, & ! In
4955 : l_last_clip_ts, dt, wp2, xp2_relaxed, & ! In
4956 : l_predict_upwp_vpwp, & ! In
4957 : stats_metadata, & ! In
4958 : stats_zm, & ! intent(inout)
4959 705888 : wpxp, wpxp_chnge ) ! In/Out
4960 : else ! clipping for upwp or vpwp
4961 :
4962 705888 : if ( l_tke_aniso ) then
4963 : call clip_covar( nz, ngrdcol, gr, solve_type_cl, l_first_clip_ts, & ! In
4964 : l_last_clip_ts, dt, wp2, xp2, & ! In
4965 : l_predict_upwp_vpwp, & ! In
4966 : stats_metadata, & ! In
4967 : stats_zm, & ! intent(inout)
4968 705888 : wpxp, wpxp_chnge ) ! In/Out
4969 : else
4970 : call clip_covar( nz, ngrdcol, gr, solve_type_cl, l_first_clip_ts, & ! In
4971 : l_last_clip_ts, dt, wp2, wp2, & ! In
4972 : l_predict_upwp_vpwp, & ! In
4973 : stats_metadata, & ! In
4974 : stats_zm, & ! intent(inout)
4975 0 : wpxp, wpxp_chnge ) ! In/Out
4976 : end if ! l_tke_aniso
4977 : end if ! solve_type /= xm_wpxp_um .and. solve_type /= xm_wpxp_vm
4978 :
4979 : ! Adjusting xm based on clipping for w'x'.
4980 : if ( l_clip_turb_adv ) then
4981 : call xm_correction_wpxp_cl( nz, ngrdcol, solve_type, dt, & ! intent(in)
4982 : wpxp_chnge, gr%invrs_dzt, & ! intent(in)
4983 : stats_metadata, & ! intent(in)
4984 : stats_zt, & ! intent(inout)
4985 : xm ) ! intent(inout)
4986 : end if
4987 :
4988 : !$acc exit data delete( xm_old, wpxp_pd, xm_pd, wpxp_chnge, xp2_relaxed )
4989 :
4990 1411776 : return
4991 :
4992 : end subroutine xm_wpxp_clipping_and_stats
4993 :
4994 : !=============================================================================
4995 352944 : subroutine xm_term_ta_lhs( nz, ngrdcol, gr, &
4996 352944 : rho_ds_zm, invrs_rho_ds_zt, &
4997 352944 : lhs_ta_xm )
4998 :
4999 : ! Description:
5000 : ! Turbulent advection of xm: implicit portion of the code.
5001 : !
5002 : ! The d(xm)/dt equation contains a turbulent advection term:
5003 : !
5004 : ! - (1/rho_ds) * d( rho_ds * w'x' )/dz.
5005 : !
5006 : ! This term is solved for completely implicitly, such that:
5007 : !
5008 : ! - (1/rho_ds) * d( rho_ds * w'x'(t+1) )/dz.
5009 : !
5010 : ! Note: When the term is brought over to the left-hand side, the sign
5011 : ! is reversed and the leading "-" in front of the term is changed
5012 : ! to a "+".
5013 : !
5014 : ! The timestep index (t+1) means that the value of w'x' being used is from
5015 : ! the next timestep, which is being advanced to in solving the d(xm)/dt and
5016 : ! d(w'x')/dt equations.
5017 : !
5018 : ! This term is discretized as follows:
5019 : !
5020 : ! While the values of xm are found on the thermodynamic levels, the values
5021 : ! of w'x' are found on the momentum levels. Additionally, the values of
5022 : ! rho_ds_zm are found on the momentum levels, and the values of
5023 : ! invrs_rho_ds_zt are found on the thermodynamic levels. On the momentum
5024 : ! levels, the values of rho_ds_zm are multiplied by the values of w'x'. The
5025 : ! derivative of (rho_ds_zm * w'x') is taken over the intermediate (central)
5026 : ! thermodynamic level, where it is multiplied by invrs_rho_ds_zt, yielding
5027 : ! the desired results.
5028 : !
5029 : ! =====rho_ds_zm=====wpxp================================== m(k)
5030 : !
5031 : ! ------invrs_rho_ds_zt--------d(rho_ds*wpxp)/dz----------- t(k)
5032 : !
5033 : ! =====rho_ds_zm=====wpxp================================== m(k-1)
5034 : !
5035 : ! The vertical indices m(k), t(k), and m(k-1) correspond with altitudes
5036 : ! zm(k), zt(k), and zm(k-1), respectively. The letter "t" is used for
5037 : ! thermodynamic levels and the letter "m" is used for momentum levels.
5038 : !
5039 : ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) )
5040 :
5041 : ! References:
5042 : !-----------------------------------------------------------------------
5043 :
5044 : use grid_class, only: &
5045 : grid ! Type
5046 :
5047 : use constants_clubb, only: &
5048 : zero ! Constant(s)
5049 :
5050 : use clubb_precision, only: &
5051 : core_rknd ! Variable(s)
5052 :
5053 : implicit none
5054 :
5055 : integer, intent(in) :: &
5056 : nz, &
5057 : ngrdcol
5058 :
5059 : type (grid), target, intent(in) :: gr
5060 :
5061 : ! Constant parameters
5062 : integer, parameter :: &
5063 : k_mdiag = 1, & ! Momentum superdiagonal index.
5064 : km1_mdiag = 2 ! Momentum subdiagonal index.
5065 :
5066 : ! Input Variables
5067 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5068 : rho_ds_zm, & ! Dry, static density at momentum levels [kg/m^3]
5069 : invrs_rho_ds_zt ! Inverse dry, static density at thermo levs [m^3/kg]
5070 :
5071 : ! Return Variable
5072 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz), intent(out) :: &
5073 : lhs_ta_xm ! LHS coefficient of xm turbulent advection [1/m]
5074 :
5075 : ! Local Variable
5076 : integer :: i, k ! Vertical level index
5077 :
5078 : ! Set lower boundary condition to 0
5079 : !$acc parallel loop gang vector default(present)
5080 5893344 : do i = 1, ngrdcol
5081 5540400 : lhs_ta_xm(k_mdiag,i,1) = zero
5082 5893344 : lhs_ta_xm(km1_mdiag,i,1) = zero
5083 : end do
5084 : !$acc end parallel loop
5085 :
5086 : ! Calculate term at all other grid levels.
5087 : !$acc parallel loop gang vector collapse(2) default(present)
5088 30000240 : do k = 2, nz
5089 495393840 : do i = 1, ngrdcol
5090 :
5091 : ! Momentum superdiagonal [ x wpxp(k,<t+1>) ]
5092 930787200 : lhs_ta_xm(k_mdiag,i,k) = + invrs_rho_ds_zt(i,k) &
5093 1396180800 : * gr%invrs_dzt(i,k) * rho_ds_zm(i,k)
5094 :
5095 : ! Momentum subdiagonal [ x wpxp(k-1,<t+1>) ]
5096 : lhs_ta_xm(km1_mdiag,i,k) = - invrs_rho_ds_zt(i,k) &
5097 495040896 : * gr%invrs_dzt(i,k) * rho_ds_zm(i,k-1)
5098 : end do
5099 : end do ! k = 2, nz
5100 : !$acc end parallel loop
5101 :
5102 352944 : return
5103 :
5104 : end subroutine xm_term_ta_lhs
5105 :
5106 : !=============================================================================
5107 352944 : subroutine wpxp_term_tp_lhs( nz, ngrdcol, gr, wp2, &
5108 352944 : lhs_tp )
5109 :
5110 : ! Description:
5111 : ! Turbulent production of w'x': implicit portion of the code.
5112 : !
5113 : ! The d(w'x')/dt equation contains a turbulent production term:
5114 : !
5115 : ! - w'^2 d(xm)/dz.
5116 : !
5117 : ! This term is solved for completely implicitly, such that:
5118 : !
5119 : ! - w'^2 * d( xm(t+1) )/dz.
5120 : !
5121 : ! Note: When the term is brought over to the left-hand side, the sign
5122 : ! is reversed and the leading "-" in front of the term is changed
5123 : ! to a "+".
5124 : !
5125 : ! The timestep index (t+1) means that the value of xm being used is from the
5126 : ! next timestep, which is being advanced to in solving the d(w'x')/dt and
5127 : ! d(xm)/dt equations.
5128 : !
5129 : ! This term is discretized as follows:
5130 : !
5131 : ! The values of xm are found on thermodynamic levels, while the values of
5132 : ! w'^2 are found on momentum levels. The derivative of xm is taken over the
5133 : ! intermediate (central) momentum level, where it is multiplied by w'^2,
5134 : ! yielding the desired result.
5135 : !
5136 : ! ---------------------------xm---------------------------- t(k+1)
5137 : !
5138 : ! ==========wp2=====================d(xm)/dz=============== m(k)
5139 : !
5140 : ! ---------------------------xm---------------------------- t(k)
5141 : !
5142 : ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes
5143 : ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for
5144 : ! thermodynamic levels and the letter "m" is used for momentum levels.
5145 : !
5146 : ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) )
5147 :
5148 : ! References:
5149 : !-----------------------------------------------------------------------
5150 :
5151 : use grid_class, only: &
5152 : grid ! Type
5153 :
5154 : use constants_clubb, only: &
5155 : zero ! Constant(s)
5156 :
5157 : use clubb_precision, only: &
5158 : core_rknd ! Variable(s)
5159 :
5160 : implicit none
5161 :
5162 : integer, intent(in) :: &
5163 : nz, &
5164 : ngrdcol
5165 :
5166 : type (grid), target, intent(in) :: gr
5167 :
5168 : ! Constant parameters
5169 : integer, parameter :: &
5170 : kp1_tdiag = 1, & ! Thermodynamic superdiagonal index.
5171 : k_tdiag = 2 ! Thermodynamic subdiagonal index.
5172 :
5173 : ! Input Variables
5174 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5175 : wp2 ! w'^2 [m^2/s^2]
5176 :
5177 : ! Return Variable
5178 : real( kind = core_rknd ), dimension(ndiags2,ngrdcol,nz), intent(out) :: &
5179 : lhs_tp ! LHS coefficient of xm for turbulent production [1/s]
5180 :
5181 : ! Local Variable
5182 : integer :: i, k ! Vertical level index
5183 :
5184 : ! Set lower boundary to 0
5185 : !$acc parallel loop gang vector default(present)
5186 5893344 : do i = 1, ngrdcol
5187 5540400 : lhs_tp(1,i,1) = zero
5188 5893344 : lhs_tp(2,i,1) = zero
5189 : end do
5190 : !$acc end parallel loop
5191 :
5192 : ! Calculate term at all interior grid levels.
5193 : !$acc parallel loop gang vector collapse(2) default(present)
5194 29647296 : do k = 2, nz-1
5195 489500496 : do i = 1, ngrdcol
5196 :
5197 : ! Thermodynamic superdiagonal [ x xm(k+1,<t+1>) ]
5198 459853200 : lhs_tp(kp1_tdiag,i,k) = + wp2(i,k) * gr%invrs_dzm(i,k)
5199 :
5200 : ! Thermodynamic subdiagonal [ x xm(k,<t+1>) ]
5201 489147552 : lhs_tp(k_tdiag,i,k) = - wp2(i,k) * gr%invrs_dzm(i,k)
5202 :
5203 : end do
5204 : end do ! k = 2, nz-1
5205 : !$acc end parallel loop
5206 :
5207 : ! Set upper boundary to 0
5208 : !$acc parallel loop gang vector default(present)
5209 5893344 : do i = 1, ngrdcol
5210 5540400 : lhs_tp(1,i,nz) = 0.0_core_rknd
5211 5893344 : lhs_tp(2,i,nz) = 0.0_core_rknd
5212 : end do
5213 : !$acc end parallel loop
5214 :
5215 352944 : return
5216 :
5217 : end subroutine wpxp_term_tp_lhs
5218 :
5219 : !=============================================================================
5220 352944 : subroutine wpxp_terms_ac_pr2_lhs( nz, ngrdcol, C7_Skw_fnc, &
5221 352944 : wm_zt, invrs_dzm, &
5222 352944 : lhs_ac_pr2 )
5223 :
5224 : ! Description:
5225 : ! Accumulation of w'x' and w'x' pressure term 2: implicit portion of the
5226 : ! code.
5227 : !
5228 : ! The d(w'x')/dt equation contains an accumulation term:
5229 : !
5230 : ! - w'x' dw/dz;
5231 : !
5232 : ! and pressure term 2:
5233 : !
5234 : ! + C_7 w'x' dw/dz.
5235 : !
5236 : ! Both the w'x' accumulation term and pressure term 2 are completely
5237 : ! implicit. The accumulation term and pressure term 2 are combined and
5238 : ! solved together as:
5239 : !
5240 : ! - ( 1 - C_7 ) * w'x'(t+1) * dw/dz.
5241 : !
5242 : ! Note: When the term is brought over to the left-hand side, the sign
5243 : ! is reversed and the leading "-" in front of the term is changed
5244 : ! to a "+".
5245 : !
5246 : ! The timestep index (t+1) means that the value of w'x' being used is from
5247 : ! the next timestep, which is being advanced to in solving the d(w'x')/dt
5248 : ! equation.
5249 : !
5250 : ! The terms are discretized as follows:
5251 : !
5252 : ! The values of w'x' are found on momentum levels, while the values of wm_zt
5253 : ! (mean vertical velocity on thermodynamic levels) are found on
5254 : ! thermodynamic levels. The vertical derivative of wm_zt is taken over the
5255 : ! intermediate (central) momentum level. It is then multiplied by w'x'
5256 : ! (implicitly calculated at timestep (t+1)) and the coefficients to yield
5257 : ! the desired results.
5258 : !
5259 : ! -------wm_zt--------------------------------------------- t(k+1)
5260 : !
5261 : ! ===============d(wm_zt)/dz============wpxp=============== m(k)
5262 : !
5263 : ! -------wm_zt--------------------------------------------- t(k)
5264 : !
5265 : ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes
5266 : ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for
5267 : ! thermodynamic levels and the letter "m" is used for momentum levels.
5268 : !
5269 : ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) )
5270 :
5271 : ! References:
5272 : !-----------------------------------------------------------------------
5273 :
5274 : use constants_clubb, only: &
5275 : one, & ! Constant(s)
5276 : zero
5277 :
5278 : use clubb_precision, only: &
5279 : core_rknd ! Variable(s)
5280 :
5281 : implicit none
5282 :
5283 : ! Input Variables
5284 : integer, intent(in) :: &
5285 : nz, &
5286 : ngrdcol
5287 :
5288 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5289 : C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-]
5290 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
5291 : invrs_dzm ! Inverse of grid spacing [1/m]
5292 :
5293 : ! Return Variable
5294 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
5295 : lhs_ac_pr2 ! LHS coefficient of accumulation and pressure term 2 [1/s]
5296 :
5297 : ! Local Variable
5298 : integer :: i, k ! Vertical level index
5299 :
5300 : !$acc data copyin( C7_Skw_fnc, wm_zt, invrs_dzm ) &
5301 : !$acc copyout( lhs_ac_pr2 )
5302 :
5303 : ! Set lower boundary to 0
5304 : !$acc parallel loop gang vector default(present)
5305 5893344 : do i = 1, ngrdcol
5306 5893344 : lhs_ac_pr2(i,1) = zero
5307 : end do
5308 : !$acc end parallel loop
5309 :
5310 : ! Calculate term at all interior grid levels.
5311 : !$acc parallel loop gang vector collapse(2) default(present)
5312 29647296 : do k = 2, nz-1
5313 489500496 : do i = 1, ngrdcol
5314 : ! Momentum main diagonal: [ x wpxp(k,<t+1>) ]
5315 919706400 : lhs_ac_pr2(i,k) = ( one - C7_Skw_fnc(i,k) ) &
5316 1408853952 : * invrs_dzm(i,k) * ( wm_zt(i,k+1) - wm_zt(i,k) )
5317 : end do
5318 : end do ! k = 2, gr%nz-1
5319 : !$acc end parallel loop
5320 :
5321 : ! Set upper boundary to 0
5322 : !$acc parallel loop gang vector default(present)
5323 5893344 : do i = 1, ngrdcol
5324 5893344 : lhs_ac_pr2(i,nz) = zero
5325 : end do
5326 : !$acc end parallel loop
5327 :
5328 : !$acc end data
5329 :
5330 352944 : return
5331 :
5332 : end subroutine wpxp_terms_ac_pr2_lhs
5333 :
5334 : !=============================================================================
5335 352944 : subroutine wpxp_term_pr1_lhs( nz, ngrdcol, C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc, &
5336 352944 : invrs_tau_C6_zm, l_scalar_calc, &
5337 352944 : lhs_pr1_wprtp, lhs_pr1_wpthlp, &
5338 352944 : lhs_pr1_wpsclrp )
5339 :
5340 : ! Description
5341 : ! Pressure term 1 for w'x': implicit portion of the code.
5342 : !
5343 : ! The d(w'x')/dt equation contains pressure term 1:
5344 : !
5345 : ! - ( C_6 / tau_m ) w'x'.
5346 : !
5347 : ! This term is solved for completely implicitly, such that:
5348 : !
5349 : ! - ( C_6 / tau_m ) w'x'(t+1)
5350 : !
5351 : ! Note: When the term is brought over to the left-hand side, the sign
5352 : ! is reversed and the leading "-" in front of the term is changed
5353 : ! to a "+".
5354 : !
5355 : ! The timestep index (t+1) means that the value of w'x' being used is from
5356 : ! the next timestep, which is being advanced to in solving the d(w'x')/dt
5357 : ! equation.
5358 : !
5359 : ! The values of w'x' are found on the momentum levels. The values of the
5360 : ! C_6 skewness function and time-scale tau_m are also found on the momentum
5361 : ! levels.
5362 : !
5363 : !-----------------------------------------------------------------------
5364 :
5365 : use grid_class, only: &
5366 : grid ! Type
5367 :
5368 : use constants_clubb, only: &
5369 : zero ! Constant(s)
5370 :
5371 : use clubb_precision, only: &
5372 : core_rknd ! Variable(s)
5373 :
5374 : implicit none
5375 :
5376 : integer, intent(in) :: &
5377 : nz, &
5378 : ngrdcol
5379 :
5380 : !--------------------------- Input Variables ---------------------------
5381 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5382 : C6rt_Skw_fnc, & ! C_6rt parameter with Sk_w applied [-]
5383 : C6thl_Skw_fnc, & ! C_6thl parameter with Sk_w applied [-]
5384 : C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-]
5385 : invrs_tau_C6_zm ! Inverse time-scale tau at momentum levels [1/s]
5386 :
5387 : logical, intent(in) :: &
5388 : l_scalar_calc ! True if sclr_dim > 0
5389 :
5390 : !--------------------------- Output Variables ---------------------------
5391 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
5392 : lhs_pr1_wprtp, & ! LHS coefficient for w'r_t' pressure term 1 [1/s]
5393 : lhs_pr1_wpthlp, & ! LHS coefficient for w'thl' pressure term 1 [1/s]
5394 : lhs_pr1_wpsclrp ! LHS coefficient for w'sclr' pressure term 1 [1/s]
5395 :
5396 : !--------------------------- Local Variables ---------------------------
5397 : integer :: i, k
5398 :
5399 : !--------------------------- Begin Code ---------------------------
5400 :
5401 : !$acc parallel loop gang vector collapse(2) default(present)
5402 29647296 : do k = 2, nz-1
5403 489500496 : do i = 1, ngrdcol
5404 :
5405 : ! Momentum main diagonals: [ x wpxp(k,<t+1>) ]
5406 459853200 : lhs_pr1_wprtp(i,k) = C6rt_Skw_fnc(i,k) * invrs_tau_C6_zm(i,k)
5407 :
5408 : ! Momentum main diagonals: [ x wpxp(k,<t+1>) ]
5409 489147552 : lhs_pr1_wpthlp(i,k) = C6thl_Skw_fnc(i,k) * invrs_tau_C6_zm(i,k)
5410 :
5411 : end do
5412 : end do
5413 : !$acc end parallel loop
5414 :
5415 : !$acc parallel loop gang vector default(present)
5416 5893344 : do i = 1, ngrdcol
5417 :
5418 : ! Set lower boundary to 0
5419 5540400 : lhs_pr1_wprtp(i,1) = zero
5420 :
5421 : ! Set upper boundary to 0
5422 5540400 : lhs_pr1_wprtp(i,nz) = zero
5423 :
5424 : ! Set lower boundary to 0
5425 5540400 : lhs_pr1_wpthlp(i,1) = zero
5426 :
5427 : ! Set upper boundary to 0
5428 5893344 : lhs_pr1_wpthlp(i,nz) = zero
5429 :
5430 : end do
5431 : !$acc end parallel loop
5432 :
5433 352944 : if ( l_scalar_calc ) then
5434 :
5435 : !$acc parallel loop gang vector collapse(2) default(present)
5436 0 : do k = 2, nz-1
5437 0 : do i = 1, ngrdcol
5438 :
5439 : ! Momentum main diagonals: [ x wpxp(k,<t+1>) ]
5440 0 : lhs_pr1_wpsclrp(i,k) = C7_Skw_fnc(i,k) * invrs_tau_C6_zm(i,k)
5441 :
5442 : end do
5443 : end do
5444 : !$acc end parallel loop
5445 :
5446 : !$acc parallel loop gang vector default(present)
5447 0 : do i = 1, ngrdcol
5448 :
5449 : ! Set lower boundary to 0
5450 0 : lhs_pr1_wpsclrp(i,1) = zero
5451 :
5452 : ! Set upper boundary to 0
5453 0 : lhs_pr1_wpsclrp(i,nz) = zero
5454 :
5455 : end do
5456 : !$acc end parallel loop
5457 :
5458 : endif ! l_scalar_calc
5459 :
5460 352944 : return
5461 :
5462 : end subroutine wpxp_term_pr1_lhs
5463 :
5464 : !=============================================================================
5465 1411776 : subroutine wpxp_terms_bp_pr3_rhs( nz, ngrdcol, C7_Skw_fnc, thv_ds_zm, xpthvp, &
5466 1411776 : rhs_bp_pr3 )
5467 :
5468 : ! Description:
5469 : ! Buoyancy production of w'x' and w'x' pressure term 3: explicit portion of
5470 : ! the code.
5471 : !
5472 : ! The d(w'x')/dt equation contains a buoyancy production term:
5473 : !
5474 : ! + (g/thv_ds) x'th_v';
5475 : !
5476 : ! and pressure term 3:
5477 : !
5478 : ! - C_7 (g/thv_ds) x'th_v'.
5479 : !
5480 : ! Both the w'x' buoyancy production term and pressure term 3 are completely
5481 : ! explicit. The buoyancy production term and pressure term 3 are combined
5482 : ! and solved together as:
5483 : !
5484 : ! + ( 1 - C_7 ) * (g/thv_ds) * x'th_v'.
5485 :
5486 : ! References:
5487 : !-----------------------------------------------------------------------
5488 :
5489 : use constants_clubb, only: & ! Constants(s)
5490 : grav, & ! Gravitational acceleration [m/s^2]
5491 : one, &
5492 : zero
5493 :
5494 : use clubb_precision, only: &
5495 : core_rknd ! Variable(s)
5496 :
5497 : implicit none
5498 :
5499 : integer, intent(in) :: &
5500 : nz, &
5501 : ngrdcol
5502 :
5503 : !---------------------------- Input Variables ----------------------------
5504 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5505 : C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-]
5506 : thv_ds_zm, & ! Dry, base-state theta_v on mom. levs. [K]
5507 : xpthvp ! x'th_v' [K {xm units}]
5508 :
5509 : !---------------------------- Output Variables ----------------------------
5510 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
5511 : rhs_bp_pr3 ! RHS portion of bouyancy prod and pressure term 3
5512 :
5513 : !---------------------------- Local Variables ----------------------------
5514 : integer :: i, k ! Vertical level index
5515 :
5516 : !---------------------------- Begin Code ----------------------------
5517 :
5518 : !$acc data copyin( C7_Skw_fnc, thv_ds_zm, xpthvp ) &
5519 : !$acc copyout( rhs_bp_pr3 )
5520 :
5521 : ! Set lower boundary to 0
5522 : !$acc parallel loop gang vector default(present)
5523 23573376 : do i = 1, ngrdcol
5524 23573376 : rhs_bp_pr3(i,1) = zero
5525 : end do
5526 :
5527 : ! Calculate term at all interior grid levels.
5528 : !$acc parallel loop gang vector collapse(2) default(present)
5529 118589184 : do k = 2, nz-1
5530 1958001984 : do i = 1, ngrdcol
5531 1956590208 : rhs_bp_pr3(i,k) = ( grav / thv_ds_zm(i,k) ) * ( one - C7_Skw_fnc(i,k) ) * xpthvp(i,k)
5532 : end do
5533 : end do ! k = 2, nz-1
5534 :
5535 : ! Set upper boundary to 0
5536 : !$acc parallel loop gang vector default(present)
5537 23573376 : do i = 1, ngrdcol
5538 23573376 : rhs_bp_pr3(i,nz) = zero
5539 : end do
5540 :
5541 : !$acc end data
5542 :
5543 1411776 : return
5544 :
5545 : end subroutine wpxp_terms_bp_pr3_rhs
5546 :
5547 : !=============================================================================
5548 : subroutine xm_correction_wpxp_cl( nz, ngrdcol, solve_type, dt, &
5549 : wpxp_chnge, invrs_dzt, &
5550 : stats_metadata, &
5551 : stats_zt, &
5552 : xm )
5553 :
5554 : ! Description:
5555 : ! Corrects the value of xm if w'x' needed to be clipped, for xm is partially
5556 : ! based on the derivative of w'x' with respect to altitude.
5557 : !
5558 : ! The time-tendency equation for xm is:
5559 : !
5560 : ! d(xm)/dt = -w d(xm)/dz - d(w'x')/dz + d(xm)/dt|_ls;
5561 : !
5562 : ! where d(xm)/dt|_ls is the rate of change of xm over time due to radiation,
5563 : ! microphysics, and/or any other large-scale forcing(s).
5564 : !
5565 : ! The time-tendency equation for xm is solved in conjunction with the
5566 : ! time-tendency equation for w'x'. Both equations are solved together in a
5567 : ! semi-implicit manner. However, after both equations have been solved (and
5568 : ! thus both xm and w'x' have been advanced to the next timestep with
5569 : ! timestep index {t+1}), the value of covariance w'x' may be clipped at any
5570 : ! level in order to prevent the correlation of w and x from becoming greater
5571 : ! than 1 or less than -1.
5572 : !
5573 : ! The correlation between w and x is:
5574 : !
5575 : ! corr_(w,x) = w'x' / [ sqrt(w'^2) * sqrt(x'^2) ].
5576 : !
5577 : ! The correlation must always have a value between -1 and 1, such that:
5578 : !
5579 : ! -1 <= corr_(w,x) <= 1.
5580 : !
5581 : ! Therefore, there is an upper limit on w'x', such that:
5582 : !
5583 : ! w'x' <= [ sqrt(w'^2) * sqrt(x'^2) ];
5584 : !
5585 : ! and a lower limit on w'x', such that:
5586 : !
5587 : ! w'x' >= -[ sqrt(w'^2) * sqrt(x'^2) ].
5588 : !
5589 : ! The aforementioned time-tendency equation for xm is based on the value of
5590 : ! w'x' without being clipped (w'x'{t+1}_unclipped), such that:
5591 : !
5592 : ! d(xm)/dt = -w d(xm{t+1})/dz - d(w'x'{t+1}_unclipped)/dz + d(xm{t})/dt|_ls;
5593 : !
5594 : ! where the both the mean advection term, -w d(xm{t+1})/dz, and the
5595 : ! turbulent advection term, -d(w'x'{t+1}_unclipped)/dz, are solved
5596 : ! completely implicitly. The xm forcing term, +d(xm{t})/dt|_ls, is solved
5597 : ! completely explicitly.
5598 : !
5599 : ! However, if w'x' needs to be clipped after being advanced one timestep,
5600 : ! then xm needs to be altered to reflect the fact that w'x' has a different
5601 : ! value than the value used while both were being solved together. Ideally,
5602 : ! the xm time-tendency equation that should be used is:
5603 : !
5604 : ! d(xm)/dt = -w d(xm{t+1})/dz - d(w'x'{t+1}_clipped)/dz + d(xm{t})/dt|_ls.
5605 : !
5606 : ! However, w'x'{t+1}_clipped isn't known until after the w'x' and xm
5607 : ! equations have been solved together. However, a proper adjuster can be
5608 : ! applied to xm through the use of the following relationship:
5609 : !
5610 : ! w'x'{t+1}_clipped = w'x'{t+1}_unclipped + w'x'{t+1}_amount_clipped;
5611 : !
5612 : ! at any given vertical level.
5613 : !
5614 : ! When the expression above is substituted into the preceeding xm
5615 : ! time-tendency equation, the resulting equation for xm time-tendency is:
5616 : !
5617 : ! d(xm)/dt = -w d(xm{t+1})/dz - d(w'x'{t+1}_unclipped)/dz
5618 : ! - d(w'x'{t+1}_amount_clipped)/dz + d(xm{t})/dt|_ls.
5619 : !
5620 : ! Thus, the resulting xm time-tendency equation is the same as the original
5621 : ! xm time-tendency equation, but with added adjuster term:
5622 : !
5623 : ! -d(w'x'{t+1}_amount_clipped)/dz.
5624 : !
5625 : ! Since the adjuster term needs to be applied after xm has already been
5626 : ! solved, it needs to be multiplied by the timestep length and added on to
5627 : ! xm{t+1}, such that:
5628 : !
5629 : ! xm{t+1}_after_adjustment =
5630 : ! xm{t+1}_before_adjustment + ( -d(w'x'{t+1}_amount_clipped)/dz ) * dt.
5631 : !
5632 : ! The adjuster term is discretized as follows:
5633 : !
5634 : ! The values of w'x' are located on the momentum levels. Thus, the values
5635 : ! of w'x'_amount_clipped are also located on the momentum levels. The
5636 : ! values of xm are located on the thermodynamic levels. The derivatives
5637 : ! (d/dz) of w'x'_amount_clipped are taken over the intermediate
5638 : ! thermodynamic levels, where they are applied to xm.
5639 : !
5640 : ! =======wpxp_amount_clipped=============================== m(k)
5641 : !
5642 : ! -----------------------------d(wpxp_amount_clipped)/dz--- t(k)
5643 : !
5644 : ! =======wpxp_amount_clipped=============================== m(k-1)
5645 : !
5646 : ! The vertical indices m(k), t(k), and m(k-1) correspond with altitudes
5647 : ! zm(k), zt(k), and zm(k-1), respectively. The letter "t" is used for
5648 : ! thermodynamic levels and the letter "m" is used for momentum levels.
5649 : !
5650 : ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) )
5651 :
5652 : ! Note: The results of this xm adjustment are highly dependent on the
5653 : ! numerical stability and the smoothness of the w'^2 and x'^2 fields.
5654 : ! An unstable "sawtooth" profile for w'^2 and/or x'^2 causes an
5655 : ! unstable "sawtooth" profile for the upper and lower limits on w'x'.
5656 : ! In turn, this causes an unstable "sawtooth" profile for
5657 : ! w'x'_amount_clipped. Taking the derivative of that such a "noisy"
5658 : ! field and applying the results to xm causes the xm field to become
5659 : ! more "noisy" and unstable.
5660 :
5661 : ! References:
5662 : !-----------------------------------------------------------------------
5663 :
5664 : use clubb_precision, only: &
5665 : core_rknd ! Variable(s)
5666 :
5667 : use stats_type_utilities, only: &
5668 : stat_update_var ! Procedure(s)
5669 :
5670 : use stats_variables, only: &
5671 : stats_metadata_type
5672 :
5673 : use stats_type, only: stats ! Type
5674 :
5675 : use constants_clubb, only: &
5676 : eps ! Constant(s)
5677 :
5678 : implicit none
5679 :
5680 : !---------------------------- Input Variables ----------------------------
5681 : integer, intent(in) :: &
5682 : nz, &
5683 : ngrdcol
5684 :
5685 : integer, intent(in) :: &
5686 : solve_type ! Variable that is being solved for.
5687 :
5688 : real( kind = core_rknd ), intent(in) :: &
5689 : dt ! Model timestep [s]
5690 :
5691 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5692 : wpxp_chnge, & ! Amount of change in w'x' due to clipping [m/s {xm units}]
5693 : invrs_dzt ! Inverse of grid spacing [1/m]
5694 :
5695 : type (stats_metadata_type), intent(in) :: &
5696 : stats_metadata
5697 :
5698 : !---------------------------- Input/Output Variable ----------------------------
5699 : type (stats), dimension(ngrdcol), intent(inout) :: &
5700 : stats_zt
5701 :
5702 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(inout) :: &
5703 : xm ! xm (thermodynamic levels) [{xm units}]
5704 :
5705 : !---------------------------- Local Variables ----------------------------
5706 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
5707 : xm_tndcy_wpxp_cl ! d(xm)/dt due to clipping of w'x' [{xm units}/s]
5708 :
5709 : integer :: i, k ! Array index
5710 :
5711 : integer :: ixm_tacl ! Statistical index
5712 :
5713 : logical, dimension(ngrdcol) :: &
5714 : l_clipping_needed
5715 :
5716 : logical :: &
5717 : l_any_clipping_needed
5718 :
5719 : !---------------------------- Begin Code ----------------------------
5720 :
5721 : !$acc enter data create( xm_tndcy_wpxp_cl, l_clipping_needed, l_any_clipping_needed )
5722 :
5723 : l_any_clipping_needed = .false.
5724 :
5725 : !$acc parallel loop gang vector collapse(2) default(present)
5726 : do k = 1, nz
5727 : do i = 1, ngrdcol
5728 : if ( abs( wpxp_chnge(i,k) ) > eps ) then
5729 : l_clipping_needed(i) = .true.
5730 : l_any_clipping_needed = .true.
5731 : end if
5732 : end do
5733 : end do
5734 : !$acc end parallel loop
5735 :
5736 : !$acc update host( l_any_clipping_needed )
5737 :
5738 : if ( .not. l_any_clipping_needed ) then
5739 : return
5740 : end if
5741 :
5742 : select case ( solve_type )
5743 : case ( xm_wpxp_rtm )
5744 : ixm_tacl = stats_metadata%irtm_tacl
5745 : case ( xm_wpxp_thlm )
5746 : ixm_tacl = stats_metadata%ithlm_tacl
5747 : case default
5748 : ixm_tacl = 0
5749 : end select
5750 :
5751 : ! Adjusting xm based on clipping for w'x'.
5752 : ! Loop over all thermodynamic levels between the second-lowest and the
5753 : ! highest.
5754 : !$acc parallel loop gang vector collapse(2) default(present)
5755 : do k = 2, nz
5756 : do i = 1, ngrdcol
5757 : if ( l_clipping_needed(i) ) then
5758 : xm_tndcy_wpxp_cl(i,k) = - invrs_dzt(i,k) * ( wpxp_chnge(i,k) - wpxp_chnge(i,k-1) )
5759 : xm(i,k) = xm(i,k) + xm_tndcy_wpxp_cl(i,k) * dt
5760 : end if
5761 : end do
5762 : end do
5763 : !$acc end parallel loop
5764 :
5765 : if ( stats_metadata%l_stats_samp ) then
5766 :
5767 : !$acc update host( xm_tndcy_wpxp_cl )
5768 :
5769 : ! The adjustment to xm due to turbulent advection term clipping
5770 : ! (xm term tacl) is completely explicit; call stat_update_var.
5771 : do i = 1, ngrdcol
5772 : call stat_update_var( ixm_tacl, xm_tndcy_wpxp_cl(i,:), & ! intent(in)
5773 : stats_zt(i) ) ! intent(inout)
5774 : end do
5775 : endif
5776 :
5777 : !$acc exit data delete( xm_tndcy_wpxp_cl, l_clipping_needed, l_any_clipping_needed )
5778 :
5779 : return
5780 :
5781 : end subroutine xm_correction_wpxp_cl
5782 :
5783 :
5784 : !=============================================================================
5785 1058832 : subroutine damp_coefficient( nz, ngrdcol, gr, coefficient, Cx_Skw_fnc, &
5786 : max_coeff_value, altitude_threshold, &
5787 1058832 : threshold, Lscale, &
5788 1058832 : damped_value )
5789 :
5790 : ! Description:
5791 : ! Damps a given coefficient linearly based on the value of Lscale.
5792 : ! For additional information see CLUBB ticket #431.
5793 :
5794 : use grid_class, only: &
5795 : grid ! Type
5796 :
5797 : use clubb_precision, only: &
5798 : core_rknd ! Variable(s)
5799 :
5800 : implicit none
5801 :
5802 : integer, intent(in) :: &
5803 : nz, &
5804 : ngrdcol
5805 :
5806 : type (grid), target, intent(in) :: gr
5807 :
5808 : ! Input variables
5809 : real( kind = core_rknd ), intent(in) :: &
5810 : coefficient, & ! The coefficient to be damped
5811 : max_coeff_value, & ! Maximum value the damped coefficient should have
5812 : altitude_threshold, & ! Minimum altitude where damping should occur
5813 : threshold ! Value of Lscale below which the damping should occur
5814 :
5815 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5816 : Lscale, & ! Current value of Lscale
5817 : Cx_Skw_fnc ! Initial skewness function before damping
5818 :
5819 : ! Return Variable
5820 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: damped_value
5821 :
5822 : ! Local Variables
5823 : integer :: i, k
5824 :
5825 : !$acc parallel loop gang vector collapse(2) default(present)
5826 91059552 : do k = 1, nz
5827 1503861552 : do i = 1, ngrdcol
5828 :
5829 1502802720 : if ( Lscale(i,k) < threshold .and. gr%zt(i,k) > altitude_threshold ) then
5830 : damped_value(i,k) = max_coeff_value &
5831 : + ( ( coefficient - max_coeff_value ) / threshold ) &
5832 1227104751 : * Lscale(i,k)
5833 : else
5834 185697249 : damped_value(i,k) = Cx_Skw_fnc(i,k)
5835 : end if
5836 :
5837 : end do
5838 : end do
5839 : !$acc end parallel loop
5840 :
5841 1058832 : return
5842 :
5843 : end subroutine damp_coefficient
5844 : !-----------------------------------------------------------------------
5845 :
5846 : !=====================================================================================
5847 1411776 : subroutine diagnose_upxp( nz, ngrdcol, gr, ypwp, xm, wpxp, ym, &
5848 1411776 : C6x_Skw_fnc, tau_C6_zm, C7_Skw_fnc, &
5849 1411776 : ypxp )
5850 : ! Description:
5851 : ! Diagnose turbulent horizontal flux of a conserved scalar.
5852 : !
5853 : ! References:
5854 : ! Eqn. 7 of Andre et al. (1978)
5855 : ! Eqn. 4 of Bougeault et al. (1981)
5856 : ! github issue #841
5857 : !
5858 : !-------------------------------------------------------------------------------------
5859 :
5860 : use clubb_precision, only: &
5861 : core_rknd ! Variable(s)
5862 :
5863 : use constants_clubb, only: & ! Constants(s)
5864 : one ! 1.0_core_rknd
5865 :
5866 : use grid_class, only: &
5867 : grid, & ! Type
5868 : ddzt ! Procedure
5869 :
5870 : implicit none
5871 :
5872 : !------------------------------ Input Variables ------------------------------
5873 : integer, intent(in) :: &
5874 : nz, &
5875 : ngrdcol
5876 :
5877 : type (grid), target, intent(in) :: gr
5878 :
5879 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
5880 : ypwp, & ! momentum flux component, either upwp or vpwp [m^2/s^2]
5881 : xm, & ! grid-mean conserved thermodynamic variable, either thlm or rtm [varies]
5882 : wpxp, & ! vertical scalar flux, either wpthlp or wprtp [varies]
5883 : ym, & ! grid-mean velocity component, either um or vm [m/s]
5884 : C6x_Skw_fnc, & ! C_6 pressure parameter with effects of Sk_w incorporated (k) [-]
5885 : tau_C6_zm, & ! Time-scale tau on momentum levels applied to C6 term [s]
5886 : C7_Skw_fnc ! C_7 pressure parameter with effects of Sk_w incorporated (k) [-]
5887 :
5888 : !------------------------------ Return Variables ------------------------------
5889 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
5890 : ypxp ! horizontal flux of a conserved scalar, either upthlp, uprtp, vpthlp, or vprtp
5891 :
5892 : !------------------------------ Local Variables ------------------------------
5893 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
5894 2823552 : ddzt_xm, &
5895 2823552 : ddzt_ym
5896 :
5897 : integer :: i, k
5898 :
5899 : !----------------------------- Begin Code ------------------------------
5900 :
5901 : !$acc enter data create( ddzt_xm, ddzt_ym )
5902 :
5903 1411776 : ddzt_xm = ddzt( nz, ngrdcol, gr, xm )
5904 1411776 : ddzt_ym = ddzt( nz, ngrdcol, gr, ym )
5905 :
5906 : !$acc parallel loop gang vector collapse(2) default(present)
5907 121412736 : do k = 1, nz
5908 2005148736 : do i = 1, ngrdcol
5909 3767472000 : ypxp(i,k) = ( tau_C6_zm(i,k) / C6x_Skw_fnc(i,k) ) &
5910 : * ( - ypwp(i,k) * ddzt_xm(i,k) - (one - C7_Skw_fnc(i,k) ) &
5911 5771208960 : * ( wpxp(i,k) * ddzt_ym(i,k) ) )
5912 : end do
5913 : end do
5914 : !$acc end parallel loop
5915 :
5916 : !$acc exit data delete( ddzt_xm, ddzt_ym )
5917 :
5918 1411776 : return
5919 :
5920 : end subroutine diagnose_upxp
5921 :
5922 : !=============================================================================
5923 0 : subroutine error_prints_xm_wpxp( nz, zt, zm, &
5924 0 : dt, sigma_sqd_w, wm_zm, wm_zt, wp2, &
5925 0 : Lscale, wp3_on_wp2, wp3_on_wp2_zt, &
5926 0 : Kh_zt, Kh_zm, invrs_tau_C6_zm, Skw_zm, &
5927 0 : wp2rtp, rtpthvp, rtm_forcing, &
5928 0 : wprtp_forcing, rtm_ref, wp2thlp, &
5929 0 : thlpthvp, thlm_forcing, wpthlp_forcing, &
5930 0 : thlm_ref, rho_ds_zm, rho_ds_zt, &
5931 0 : invrs_rho_ds_zm, invrs_rho_ds_zt, &
5932 0 : thv_ds_zm, rtp2, thlp2, w_1_zm, w_2_zm, &
5933 0 : varnce_w_1_zm, varnce_w_2_zm, &
5934 0 : mixt_frac_zm, l_implemented, em, &
5935 0 : wp2sclrp, sclrpthvp, sclrm_forcing, &
5936 0 : sclrp2, exner, rcm, p_in_Pa, thvm, &
5937 0 : Cx_fnc_Richardson, &
5938 0 : pdf_implicit_coefs_terms, um_forcing, &
5939 0 : vm_forcing, ug, vg, wpthvp, fcor, &
5940 0 : um_ref, vm_ref, up2, vp2, uprcp, vprcp, &
5941 0 : rc_coef, rtm, wprtp, thlm, wpthlp, &
5942 0 : sclrm, wpsclrp, um, upwp, vm, vpwp, &
5943 0 : rtm_old, wprtp_old, thlm_old, &
5944 0 : wpthlp_old, sclrm_old, wpsclrp_old, &
5945 0 : um_old, upwp_old, vm_old, vpwp_old, &
5946 : l_predict_upwp_vpwp, l_lmm_stepping )
5947 :
5948 : ! Description:
5949 : ! Prints values of model fields when fatal errors (LU decomp.) occur.
5950 : ! All field that are passed into and out of subroutine advance_xm_wpxp are
5951 : ! printed. If additional fields are added to the call to subroutine
5952 : ! advance_xm_wpxp, they should also be added here.
5953 :
5954 : use constants_clubb, only: &
5955 : fstderr ! Variable(s)
5956 :
5957 : use parameters_model, only: &
5958 : sclr_dim ! Variable(s)
5959 :
5960 : use pdf_parameter_module, only: &
5961 : implicit_coefs_terms ! Variable Type(s)
5962 :
5963 : use clubb_precision, only: &
5964 : core_rknd ! Variable(s)
5965 :
5966 : implicit none
5967 :
5968 : ! Input Variables
5969 : integer, intent(in) :: &
5970 : nz
5971 :
5972 : real( kind = core_rknd ), intent(in) :: &
5973 : dt ! Timestep [s]
5974 :
5975 : real( kind = core_rknd ), intent(in), dimension(nz) :: &
5976 : zm, & ! Momentum grid
5977 : zt, & ! Thermo grid
5978 : sigma_sqd_w, & ! sigma_sqd_w on momentum levels [-]
5979 : wm_zm, & ! w wind component on momentum levels [m/s]
5980 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
5981 : wp2, & ! w'^2 (momentum levels) [m^2/s^2]
5982 : Lscale, & ! Turbulent mixing length [m]
5983 : em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2]
5984 : wp3_on_wp2, & ! Smoothed wp3 / wp2 on momentum levels [m/s]
5985 : wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels [m/s]
5986 : Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s]
5987 : Kh_zm, & ! Eddy diffusivity on momentum levels
5988 : invrs_tau_C6_zm, & ! Inverse time-scale tau on momentum levels applied to C6 term [1/s]
5989 : Skw_zm, & ! Skewness of w on momentum levels [-]
5990 : wp2rtp, & ! <w'^2 r_t'> (thermodynamic levels) [m^2/s^2 kg/kg]
5991 : rtpthvp, & ! r_t'th_v' (momentum levels) [(kg/kg) K]
5992 : rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s]
5993 : wprtp_forcing, & ! <w'r_t'> forcing (momentum levels) [(kg/kg)/s^2]
5994 : rtm_ref, & ! rtm for nudging [kg/kg]
5995 : wp2thlp, & ! <w'^2 th_l'> (thermodynamic levels) [m^2/s^2 K]
5996 : thlpthvp, & ! th_l'th_v' (momentum levels) [K^2]
5997 : thlm_forcing, & ! th_l forcing (thermodynamic levels) [K/s]
5998 : wpthlp_forcing, & ! <w'th_l'> forcing (momentum levels) [K/s^2]
5999 : thlm_ref, & ! thlm for nudging [K]
6000 : rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3]
6001 : rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3]
6002 : invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg]
6003 : invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg]
6004 : thv_ds_zm, & ! Dry, base-state theta_v on moment. levs. [K]
6005 : ! Added for clipping by Vince Larson 29 Sep 2007
6006 : rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2]
6007 : thlp2, & ! th_l'^2 (momentum levels) [K^2]
6008 : ! End of Vince Larson's addition.
6009 : w_1_zm, & ! Mean w (1st PDF component) [m/s]
6010 : w_2_zm, & ! Mean w (2nd PDF component) [m/s]
6011 : varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2]
6012 : varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2]
6013 : mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-]
6014 :
6015 : logical, intent(in) :: &
6016 : l_implemented ! Flag for CLUBB being implemented in a larger model.
6017 :
6018 : ! Additional variables for passive scalars
6019 : real( kind = core_rknd ), intent(in), dimension(nz,sclr_dim) :: &
6020 : wp2sclrp, & ! <w'^2 sclr'> (thermodynamic levels) [Units vary]
6021 : sclrpthvp, & ! <sclr' th_v'> (momentum levels) [Units vary]
6022 : sclrm_forcing, & ! sclrm forcing (thermodynamic levels) [Units vary]
6023 : sclrp2 ! For clipping Vince Larson [Units vary]
6024 :
6025 : real( kind = core_rknd ), intent(in), dimension(nz) :: &
6026 : exner, & ! Exner function [-]
6027 : rcm, & ! cloud water mixing ratio, r_c [kg/kg]
6028 : p_in_Pa, & ! Air pressure [Pa]
6029 : thvm, & ! Virutal potential temperature [K]
6030 : Cx_fnc_Richardson ! Cx_fnc computed from Richardson_num [-]
6031 :
6032 : type(implicit_coefs_terms), intent(in) :: &
6033 : pdf_implicit_coefs_terms ! Implicit coefs / explicit terms [units vary]
6034 :
6035 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
6036 : real( kind = core_rknd ), dimension(nz), intent(in) :: &
6037 : um_forcing, & ! <u> forcing term (thermodynamic levels) [m/s^2]
6038 : vm_forcing, & ! <v> forcing term (thermodynamic levels) [m/s^2]
6039 : ug, & ! <u> geostrophic wind (thermodynamic levels) [m/s]
6040 : vg, & ! <v> geostrophic wind (thermodynamic levels) [m/s]
6041 : wpthvp ! <w'thv'> (momentum levels) [m/s K]
6042 :
6043 : real( kind = core_rknd ), dimension(nz), intent(in) :: &
6044 : uprcp, & ! < u' r_c' > [(m kg)/(s kg)]
6045 : vprcp, & ! < v' r_c' > [(m kg)/(s kg)]
6046 : rc_coef ! Coefficient on X'r_c' in X'th_v' equation [K/(kg/kg)]
6047 :
6048 : real( kind = core_rknd ), intent(in) :: &
6049 : fcor ! Coriolis parameter [s^-1]
6050 :
6051 : real( kind = core_rknd ), dimension(nz), intent(in) :: &
6052 : um_ref, & ! Reference u wind component for nudging [m/s]
6053 : vm_ref, & ! Reference v wind component for nudging [m/s]
6054 : up2, & ! Variance of the u wind component [m^2/s^2]
6055 : vp2 ! Variance of the v wind component [m^2/s^2]
6056 :
6057 : real( kind = core_rknd ), intent(in), dimension(nz) :: &
6058 : rtm, & ! r_t (total water mixing ratio) [kg/kg]
6059 : wprtp, & ! w'r_t' [(kg/kg) m/s]
6060 : thlm, & ! th_l (liquid water potential temperature) [K]
6061 : wpthlp ! w'th_l' [K m/s]
6062 :
6063 : real( kind = core_rknd ), intent(in), dimension(nz,sclr_dim) :: &
6064 : sclrm, wpsclrp ! [Units vary]
6065 :
6066 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
6067 : real( kind = core_rknd ), intent(in), dimension(nz) :: &
6068 : um, & ! <u>: mean west-east horiz. velocity (thermo. levs.) [m/s]
6069 : upwp, & ! <u'w'>: momentum flux (momentum levels) [m^2/s^2]
6070 : vm, & ! <v>: mean south-north horiz. velocity (thermo. levs.) [m/s]
6071 : vpwp ! <v'w'>: momentum flux (momentum levels) [m^2/s^2]
6072 :
6073 : ! Saved values of predictive fields, prior to being advanced, for use in
6074 : ! print statements in case of fatal error.
6075 : real( kind = core_rknd ), dimension(nz), intent(in) :: &
6076 : rtm_old, & ! Saved value of r_t [kg/kg]
6077 : wprtp_old, & ! Saved value of w'r_t' [(kg/kg) m/s]
6078 : thlm_old, & ! Saved value of th_l [K]
6079 : wpthlp_old ! Saved value of w'th_l' [K m/s]
6080 :
6081 : ! Input/Output Variables
6082 : real( kind = core_rknd ), dimension(nz,sclr_dim), intent(in) :: &
6083 : sclrm_old, & ! Saved value of sclrm [units vary]
6084 : wpsclrp_old ! Saved value of wpsclrp [units vary]
6085 :
6086 : ! Variables used to predict <u> and <u'w'>, as well as <v> and <v'w'>.
6087 : real( kind = core_rknd ), dimension(nz), intent(in) :: &
6088 : um_old, & ! Saved value of <u> [m/s]
6089 : upwp_old, & ! Saved value of <u'w'> [m^2/s^2]
6090 : vm_old, & ! Saved value of <v> [m/s]
6091 : vpwp_old ! Saved value of <v'w'> [m^2/s^2]
6092 :
6093 : logical, intent(in) :: &
6094 : l_predict_upwp_vpwp, & ! Flag to predict <u'w'> and <v'w'> along with <u>
6095 : ! and <v> alongside the advancement of <rt>,
6096 : ! <w'rt'>, <thl>, <wpthlp>, <sclr>, and <w'sclr'>
6097 : ! in subroutine advance_xm_wpxp. Otherwise, <u'w'>
6098 : ! and <v'w'> are still approximated by eddy
6099 : ! diffusivity when <u> and <v> are advanced in
6100 : ! subroutine advance_windm_edsclrm.
6101 : l_lmm_stepping ! Apply Linear Multistep Method (LMM) Stepping
6102 :
6103 :
6104 0 : write(fstderr,*) "Error in advance_xm_wpxp", new_line('c')
6105 :
6106 0 : write(fstderr,*) "Intent(in)", new_line('c')
6107 :
6108 0 : write(fstderr,*) "zt = ", zt, new_line('c')
6109 0 : write(fstderr,*) "zm = ", zm, new_line('c')
6110 0 : write(fstderr,*) "dt = ", dt, new_line('c')
6111 0 : write(fstderr,*) "sigma_sqd_w = ", sigma_sqd_w, new_line('c')
6112 0 : write(fstderr,*) "wm_zm = ", wm_zm, new_line('c')
6113 0 : write(fstderr,*) "wm_zt = ", wm_zt, new_line('c')
6114 0 : write(fstderr,*) "wp2 = ", wp2, new_line('c')
6115 0 : write(fstderr,*) "Lscale = ", Lscale, new_line('c')
6116 0 : write(fstderr,*) "wp3_on_wp2 = ", wp3_on_wp2, new_line('c')
6117 0 : write(fstderr,*) "wp3_on_wp2_zt = ", wp3_on_wp2_zt, new_line('c')
6118 0 : write(fstderr,*) "Kh_zt = ", Kh_zt, new_line('c')
6119 0 : write(fstderr,*) "Kh_zm = ", Kh_zm, new_line('c')
6120 0 : write(fstderr,*) "invrs_tau_C6_zm = ", invrs_tau_C6_zm, new_line('c')
6121 0 : write(fstderr,*) "Skw_zm = ", Skw_zm, new_line('c')
6122 0 : write(fstderr,*) "wp2rtp = ", wp2rtp, new_line('c')
6123 0 : write(fstderr,*) "rtpthvp = ", rtpthvp, new_line('c')
6124 0 : write(fstderr,*) "rtm_forcing = ", rtm_forcing, new_line('c')
6125 0 : write(fstderr,*) "wprtp_forcing = ", wprtp_forcing, new_line('c')
6126 0 : write(fstderr,*) "rtm_ref = ", rtm_ref, new_line('c')
6127 0 : write(fstderr,*) "wp2thlp = ", wp2thlp, new_line('c')
6128 0 : write(fstderr,*) "thlpthvp = ", thlpthvp, new_line('c')
6129 0 : write(fstderr,*) "thlm_forcing = ", thlm_forcing, new_line('c')
6130 0 : write(fstderr,*) "wpthlp_forcing = ", wpthlp_forcing, new_line('c')
6131 0 : write(fstderr,*) "thlm_ref = ", thlm_ref, new_line('c')
6132 0 : write(fstderr,*) "rho_ds_zm = ", rho_ds_zm, new_line('c')
6133 0 : write(fstderr,*) "rho_ds_zt = ", rho_ds_zt, new_line('c')
6134 0 : write(fstderr,*) "invrs_rho_ds_zm = ", invrs_rho_ds_zm, new_line('c')
6135 0 : write(fstderr,*) "invrs_rho_ds_zt = ", invrs_rho_ds_zt, new_line('c')
6136 0 : write(fstderr,*) "thv_ds_zm = ", thv_ds_zm, new_line('c')
6137 0 : write(fstderr,*) "rtp2 = ", rtp2, new_line('c')
6138 0 : write(fstderr,*) "thlp2 = ", thlp2, new_line('c')
6139 0 : write(fstderr,*) "w_1_zm = ", w_1_zm, new_line('c')
6140 0 : write(fstderr,*) "w_2_zm = ", w_2_zm, new_line('c')
6141 0 : write(fstderr,*) "varnce_w_1_zm = ", varnce_w_1_zm, new_line('c')
6142 0 : write(fstderr,*) "varnce_w_2_zm = ", varnce_w_2_zm, new_line('c')
6143 0 : write(fstderr,*) "mixt_frac_zm = ", mixt_frac_zm, new_line('c')
6144 0 : write(fstderr,*) "l_implemented = ", l_implemented, new_line('c')
6145 0 : write(fstderr,*) "em = ", em, new_line('c')
6146 0 : write(fstderr,*) "exner = ", exner, new_line('c')
6147 0 : write(fstderr,*) "rcm = ", rcm, new_line('c')
6148 0 : write(fstderr,*) "p_in_Pa = ", p_in_Pa, new_line('c')
6149 0 : write(fstderr,*) "thvm = ", thvm, new_line('c')
6150 0 : write(fstderr,*) "Cx_fnc_Richardson = ", Cx_fnc_Richardson, new_line('c')
6151 0 : write(fstderr,*) "pdf_implicit_coefs_terms%coef_wp2rtp_implicit = ", &
6152 0 : pdf_implicit_coefs_terms%coef_wp2rtp_implicit, &
6153 0 : new_line('c')
6154 0 : write(fstderr,*) "pdf_implicit_coefs_terms%term_wp2rtp_explicit = ", &
6155 0 : pdf_implicit_coefs_terms%term_wp2rtp_explicit, &
6156 0 : new_line('c')
6157 0 : write(fstderr,*) "pdf_implicit_coefs_terms%coef_wp2thlp_implicit = ", &
6158 0 : pdf_implicit_coefs_terms%coef_wp2thlp_implicit, &
6159 0 : new_line('c')
6160 0 : write(fstderr,*) "pdf_implicit_coefs_terms%term_wp2thlp_explicit = ", &
6161 0 : pdf_implicit_coefs_terms%term_wp2thlp_explicit, &
6162 0 : new_line('c')
6163 :
6164 0 : if ( sclr_dim > 0 ) then
6165 0 : write(fstderr,*) "sclrp2 = ", sclrp2, new_line('c')
6166 0 : write(fstderr,*) "wp2sclrp = ", wp2sclrp, new_line('c')
6167 0 : write(fstderr,*) "sclrpthvp = ", sclrpthvp, new_line('c')
6168 0 : write(fstderr,*) "sclrm_forcing = ", sclrm_forcing, new_line('c')
6169 0 : write(fstderr,*) "pdf_implicit_coefs_terms%coef_wp2sclrp_implicit = ", &
6170 0 : pdf_implicit_coefs_terms%coef_wp2sclrp_implicit, &
6171 0 : new_line('c')
6172 0 : write(fstderr,*) "pdf_implicit_coefs_terms%term_wp2sclrp_explicit = ", &
6173 0 : pdf_implicit_coefs_terms%term_wp2sclrp_explicit, &
6174 0 : new_line('c')
6175 : endif
6176 :
6177 0 : if ( l_predict_upwp_vpwp ) then
6178 0 : write(fstderr,*) "um_forcing = ", um_forcing, new_line('c')
6179 0 : write(fstderr,*) "vm_forcing = ", vm_forcing, new_line('c')
6180 0 : write(fstderr,*) "ug = ", ug, new_line('c')
6181 0 : write(fstderr,*) "vg = ", vg, new_line('c')
6182 0 : write(fstderr,*) "wpthvp = ", wpthvp, new_line('c')
6183 0 : write(fstderr,*) "fcor = ", fcor, new_line('c')
6184 0 : write(fstderr,*) "um_ref = ", um_ref, new_line('c')
6185 0 : write(fstderr,*) "vm_ref = ", vm_ref, new_line('c')
6186 0 : write(fstderr,*) "up2 = ", up2, new_line('c')
6187 0 : write(fstderr,*) "vp2 = ", vp2, new_line('c')
6188 0 : write(fstderr,*) "uprcp = ", uprcp, new_line('c')
6189 0 : write(fstderr,*) "vprcp = ", vprcp, new_line('c')
6190 0 : write(fstderr,*) "rc_coef = ", rc_coef, new_line('c')
6191 0 : write(fstderr,*) "pdf_implicit_coefs_terms%coef_wp2up_implicit = ", &
6192 0 : pdf_implicit_coefs_terms%coef_wp2up_implicit, &
6193 0 : new_line('c')
6194 0 : write(fstderr,*) "pdf_implicit_coefs_terms%term_wp2up_explicit = ", &
6195 0 : pdf_implicit_coefs_terms%term_wp2up_explicit, &
6196 0 : new_line('c')
6197 0 : write(fstderr,*) "pdf_implicit_coefs_terms%coef_wp2vp_implicit = ", &
6198 0 : pdf_implicit_coefs_terms%coef_wp2vp_implicit, &
6199 0 : new_line('c')
6200 0 : write(fstderr,*) "pdf_implicit_coefs_terms%term_wp2vp_explicit = ", &
6201 0 : pdf_implicit_coefs_terms%term_wp2vp_explicit, &
6202 0 : new_line('c')
6203 : endif ! l_predict_upwp_vpwp
6204 :
6205 0 : write(fstderr,*) "Intent(inout)", new_line('c')
6206 :
6207 0 : if ( l_lmm_stepping ) &
6208 0 : write(fstderr,*) "rtm (pre-solve) = ", rtm_old, new_line('c')
6209 0 : write(fstderr,*) "rtm = ", rtm, new_line('c')
6210 0 : if ( l_lmm_stepping ) &
6211 0 : write(fstderr,*) "wprtp (pre-solve) = ", wprtp_old, new_line('c')
6212 0 : write(fstderr,*) "wprtp = ", wprtp, new_line('c')
6213 0 : if ( l_lmm_stepping ) &
6214 0 : write(fstderr,*) "thlm (pre-solve) = ", thlm_old, new_line('c')
6215 0 : write(fstderr,*) "thlm = ", thlm, new_line('c')
6216 0 : if ( l_lmm_stepping ) &
6217 0 : write(fstderr,*) "wpthlp (pre-solve) =", wpthlp_old, new_line('c')
6218 0 : write(fstderr,*) "wpthlp =", wpthlp, new_line('c')
6219 :
6220 0 : if ( sclr_dim > 0 ) then
6221 0 : if ( l_lmm_stepping ) &
6222 0 : write(fstderr,*) "sclrm (pre-solve) = ", sclrm_old, new_line('c')
6223 0 : write(fstderr,*) "sclrm = ", sclrm, new_line('c')
6224 0 : if ( l_lmm_stepping ) &
6225 0 : write(fstderr,*) "wpsclrp (pre-solve) = ", wpsclrp_old, new_line('c')
6226 0 : write(fstderr,*) "wpsclrp = ", wpsclrp, new_line('c')
6227 : endif
6228 :
6229 0 : if ( l_predict_upwp_vpwp ) then
6230 0 : if ( l_lmm_stepping ) &
6231 0 : write(fstderr,*) "um (pre-solve) = ", um_old, new_line('c')
6232 0 : write(fstderr,*) "um = ", um, new_line('c')
6233 0 : if ( l_lmm_stepping ) &
6234 0 : write(fstderr,*) "upwp (pre-solve) = ", upwp_old, new_line('c')
6235 0 : write(fstderr,*) "upwp = ", upwp, new_line('c')
6236 0 : if ( l_lmm_stepping ) &
6237 0 : write(fstderr,*) "vm (pre-solve) = ", vm_old, new_line('c')
6238 0 : write(fstderr,*) "vm = ", vm, new_line('c')
6239 0 : if ( l_lmm_stepping ) &
6240 0 : write(fstderr,*) "vpwp (pre-solve) = ", vpwp_old, new_line('c')
6241 0 : write(fstderr,*) "vpwp = ", vpwp, new_line('c')
6242 : end if ! l_predict_upwp_vpwp
6243 :
6244 0 : return
6245 :
6246 : end subroutine error_prints_xm_wpxp
6247 :
6248 : !=============================================================================
6249 :
6250 : end module advance_xm_wpxp_module
|