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