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