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