Line data Source code
1 : !-----------------------------------------------------------------------
2 : ! $Id$
3 : !===============================================================================
4 : module mono_flux_limiter
5 :
6 : implicit none
7 :
8 : private ! Default Scope
9 :
10 : public :: monotonic_turbulent_flux_limit, &
11 : calc_turb_adv_range
12 :
13 : private :: mfl_xm_lhs, &
14 : mfl_xm_rhs, &
15 : mfl_xm_solve, &
16 : mean_vert_vel_up_down
17 :
18 : ! Private named constants to avoid string comparisons
19 : ! NOTE: These values must match the values for xm_wpxp_thlm
20 : ! and xm_wpxp_rtm given in advance_xm_wpxp_module!
21 : integer, parameter, private :: &
22 : mono_flux_thlm = 1, & ! Named constant for thlm mono_flux calls
23 : mono_flux_rtm = 2, & ! Named constant for rtm mono_flux calls
24 : mono_flux_um = 4, & ! Named constant for um mono_flux calls
25 : mono_flux_vm = 5 ! Named constant for vm mono_flux calls
26 :
27 : integer, parameter :: &
28 : ndiags3 = 3
29 :
30 : contains
31 :
32 : !=============================================================================
33 1411776 : subroutine monotonic_turbulent_flux_limit( nz, ngrdcol, gr, solve_type, dt, xm_old, &
34 1411776 : xp2, wm_zt, xm_forcing, &
35 1411776 : rho_ds_zm, rho_ds_zt, &
36 1411776 : invrs_rho_ds_zm, invrs_rho_ds_zt, &
37 : xp2_threshold, xm_tol, l_implemented, &
38 1411776 : low_lev_effect, high_lev_effect, &
39 : tridiag_solve_method, &
40 : l_upwind_xm_ma, &
41 : l_mono_flux_lim_spikefix, &
42 : stats_metadata, &
43 1411776 : stats_zt, stats_zm, &
44 1411776 : xm, wpxp )
45 :
46 : ! Description:
47 : ! Limits the value of w'x' and corrects the value of xm when the xm turbulent
48 : ! advection term is not monotonic. A monotonic turbulent advection scheme
49 : ! will not create new extrema for variable x, based only on turbulent
50 : ! advection (not considering mean advection and xm forcings).
51 : !
52 : ! Montonic turbulent advection
53 : ! ----------------------------
54 : !
55 : ! A monotonic turbulent advection scheme does not allow new extrema for
56 : ! variable x to be created (by means of turbulent advection). In a
57 : ! monotonic turbulent advection scheme, when only the effects of turbulent
58 : ! advection are considered (neglecting forcings and mean advection), the
59 : ! value of variable x at a given point should not increase above the
60 : ! greatest value of variable x at nearby points, nor decrease below the
61 : ! smallest value of variable x at nearby points. Nearby points are points
62 : ! that are close enough to the given point so that the value of variable x
63 : ! at the given point is effected by the values of variable x at the nearby
64 : ! points by means of transfer by turbulent winds during a time step. Again,
65 : ! a monotonic scheme insures that advection only transfers around values of
66 : ! variable x and does not create new extrema for variable x. A monotonic
67 : ! turbulent advection scheme is useful because the turbulent advection term
68 : ! (w'x') may go numerically unstable, resulting in large instabilities in
69 : ! the mean field (xm). A monotonic turbulent advection scheme will limit
70 : ! the change in xm, and also in w'x'.
71 : !
72 : ! The following example illustrates the concept of monotonic turbulent
73 : ! advection. Three successive vertical grid levels are shown (k-1, k, and
74 : ! k+1). Three point values of theta-l are listed at every vertical grid
75 : ! level. All three vertical levels have a mean theta-l (thlm) of 288.0 K.
76 : ! A circulation is occuring (in the direction of the arrows) in the vertical
77 : ! (w wind component) and in the horizontal (u and/or v wind components),
78 : ! such that the mean value of vertical velocity (wmm) is 0, but there is a
79 : ! turbulent component such that w'^2 > 0.
80 : !
81 : ! level = k+1 || --- 287.0 K --- 288.0 K --- 289.0 K --- || thlm = 288.0
82 : ! || / \--------------------->| ||
83 : ! || | | || wmm = 0; wp2 > 0
84 : ! || |<---------------------\ / ||
85 : ! level = k || --- 288.0 K --- 288.0 K --- 288.0 K --- || thlm = 288.0
86 : ! || |<---------------------/ \ ||
87 : ! || | | || wmm = 0; wp2 > 0
88 : ! || \ /--------------------->| ||
89 : ! level = k-1 || --- 287.5 K --- 288.0 K --- 288.5 K --- || thlm = 288.0
90 : !
91 : ! Neglecting any contributions from thlm forcings (effects of radiation,
92 : ! microphysics, large-scale horizontal advection, etc.), the values of
93 : ! theta-l as shown will be altered by only turbulent advection. As a side
94 : ! note, the contribution of mean advection will be 0 since wmm = 0. The
95 : ! diagram shows that the value of theta-l at the point on the right at level
96 : ! k will increase. However, the values of theta-l at the other two points
97 : ! at level k will remain the same. Thus, the value of thlm at level k will
98 : ! become greater than 288.0 K. In the same manner, the values of thlm at
99 : ! the other two vertical levels (k-1 and k+1) will become smaller than
100 : ! 288.0 K. However, the monotonic turbulent advection scheme insures that
101 : ! any theta-l point value cannot become smaller than the smallest theta-l
102 : ! point value (287.0 K) or larger than the largest theta-l point value
103 : ! (289.0 K). Since all theta-l point values must fall between 287.0 K and
104 : ! 289.0 K, the level averages of theta-l (thlm) must fall between 287.0 K
105 : ! and 289.0 K. Thus, any values of the turbulent flux, w'th_l', that would
106 : ! cause thlm to rise above 289.0 K or fall below 287.0 K, not considering
107 : ! the effect of other terms on thlm (such as forcings), are faulty and need
108 : ! to be limited appropriately. The values of thlm also need to be corrected
109 : ! appropriately.
110 : !
111 : ! Formula for the limitation of w'x' and xm
112 : ! -----------------------------------------
113 : !
114 : ! The equation for change in the mean field, xm, over time is:
115 : !
116 : ! d(xm)/dt = -w*d(xm)/dz - (1/rho_ds) * d( rho_ds * w'x' )/dz + xm_forcing;
117 : !
118 : ! where w*d(xm)/dz is the mean advection component,
119 : ! (1/rho_ds) * d( rho_ds * w'x' )/dz is the turbulent advection component,
120 : ! and xm_forcing is the xm forcing component. The d(xm)/dt time tendency
121 : ! component is discretized as:
122 : !
123 : ! xm(k,<t+1>)/dt = xm(k,<t>)/dt - w*d(xm)/dz
124 : ! - (1/rho_ds) * d( rho_ds * w'x' )/dz + xm_forcing.
125 : !
126 : ! The value of xm after it has been advanced to timestep (t+1) must be in an
127 : ! appropriate range based on the values of xm at timestep (t), the amount of
128 : ! xm forcings applied over the ensuing time step, and the amount of mean
129 : ! advection applied over the ensuing time step. This is exactly the same
130 : ! thing as saying that the value of xm(k,<t+1>), with the contribution of
131 : ! turbulent advection included, must fall into a certain range based on the
132 : ! value of xm(k,<t+1>) without the contribution of the turbulent advection
133 : ! component over the last time step. The following inequality is used to
134 : ! limit the value of xm(k,<t+1>):
135 : !
136 : ! MIN{ xm(k-1,<t>) + dt*xm_forcing(k-1) - dt*wm_zt(k-1)*d(xm)/dz|_(k-1)
137 : ! - x_max_dev_low(k-1,<t>),
138 : ! xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
139 : ! - x_max_dev_low(k,<t>),
140 : ! xm(k+1,<t>) + dt*xm_forcing(k+1) - dt*wm_zt(k+1)*d(xm)/dz|_(k+1)
141 : ! - x_max_dev_low(k+1,<t>) }
142 : ! <= xm(k,<t+1>) <=
143 : ! MAX{ xm(k-1,<t>) + dt*xm_forcing(k-1) - dt*wm_zt(k-1)*d(xm)/dz|_(k-1)
144 : ! + x_max_dev_high(k-1,<t>),
145 : ! xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
146 : ! + x_max_dev_high(k,<t>),
147 : ! xm(k+1,<t>) + dt*xm_forcing(k+1) - dt*wm_zt(k+1)*d(xm)/dz|_(k+1)
148 : ! + x_max_dev_high(k+1,<t>) };
149 : !
150 : ! where x_max_dev_low is the absolute value of the deviation from the mean
151 : ! of the smallest point value of variable x at the given vertical level and
152 : ! timestep; and where x_max_dev_high is the deviation from the mean of the
153 : ! largest point value of variable x at the given vertical level and
154 : ! timestep. For example, at vertical level (k+1) and timestep (t):
155 : !
156 : ! x_max_dev_low(k+1,<t>) = | MIN( x(k+1,<t>) ) - xm(k+1,<t>) |;
157 : ! x_max_dev_high(k+1,<t>) = MAX( x(k+1,<t>) ) - xm(k+1,<t>).
158 : !
159 : ! The inequality shown above only takes into account values from the central
160 : ! level, one-level-below the central level, and one-level-above the central
161 : ! level. This is the minimal amount of vertical levels that can have their
162 : ! values taken into consideration. Any vertical level that can have it's
163 : ! properties advect to the given level during the course of a single time
164 : ! step can be taken into consideration. However, only three levels will be
165 : ! considered in this example for the sake of simplicity.
166 : !
167 : ! The inequality will be written in more simple terms:
168 : !
169 : ! xm_lower_lim_allowable(k) <= xm(k,<t+1>) <= xm_upper_lim_allowable(k).
170 : !
171 : ! The inequality can now be related to the turbulent flux, w'x'(k,<t+1>),
172 : ! through a substitution that is made for xm(k,<t+1>), such that:
173 : !
174 : ! xm(k,<t+1>) = xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
175 : ! - dt * (1/rho_ds) * d( rho_ds * w'x' )/dz|_(k).
176 : !
177 : ! The inequality becomes:
178 : !
179 : ! xm_lower_lim_allowable(k)
180 : ! <=
181 : ! xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
182 : ! - dt * (1/rho_ds) * d( rho_ds * w'x' )/dz|_(k)
183 : ! <=
184 : ! xm_upper_lim_allowable(k).
185 : !
186 : ! The inequality is rearranged, and the turbulent advection term,
187 : ! d(w'x')/dz, is discretized:
188 : !
189 : ! xm_lower_lim_allowable(k)
190 : ! - [ xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) ]
191 : ! <=
192 : ! - dt * (1/rho_ds_zt(k))
193 : ! * invrs_dzt(k)
194 : ! * [ rho_ds_zm(k) * w'x'(k,<t+1>)
195 : ! - rho_ds_zm(k-1) * w'x'(k-1,<t+1>) ]
196 : ! <=
197 : ! xm_upper_lim_allowable(k)
198 : ! - [ xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) ];
199 : !
200 : ! where invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ).
201 : !
202 : ! Multiplying the inequality by -rho_ds_zt(k)/(dz*invrs_dzt(k)):
203 : !
204 : ! rho_ds_zt(k)/(dz*invrs_dzt(k))
205 : ! * [ xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
206 : ! - xm_lower_lim_allowable(k) ]
207 : ! >=
208 : ! rho_ds_zm(k) * w'x'(k,<t+1>) - rho_ds_zm(k-1) * w'x'(k-1,<t+1>)
209 : ! >=
210 : ! rho_ds_zt(k)/(dz*invrs_dzt(k))
211 : ! * [ xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
212 : ! - xm_upper_lim_allowable(k) ].
213 : !
214 : ! Note: The inequality symbols have been flipped due to multiplication
215 : ! involving a (-) sign.
216 : !
217 : ! Adding rho_ds_zm(k-1) * w'x'(k-1,<t+1>) to the inequality:
218 : !
219 : ! rho_ds_zt(k)/(dz*invrs_dzt(k))
220 : ! * [ xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
221 : ! - xm_lower_lim_allowable(k) ]
222 : ! + rho_ds_zm(k-1) * w'x'(k-1,<t+1>)
223 : ! >= rho_ds_zm(k) * w'x'(k,<t+1>) >=
224 : ! rho_ds_zt(k)/(dz*invrs_dzt(k))
225 : ! * [ xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
226 : ! - xm_upper_lim_allowable(k) ]
227 : ! + rho_ds_zm(k-1) * w'x'(k-1,<t+1>).
228 : !
229 : ! The inequality is then rearranged to be based around w'x'(k,<t+1>):
230 : !
231 : ! (1/rho_ds_zm(k))
232 : ! * [ rho_ds_zt(k)/(dt*invrs_dzt(k))
233 : ! * { xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
234 : ! - xm_lower_lim_allowable(k) }
235 : ! + rho_ds_zm(k-1) * w'x'(k-1,<t+1>) ]
236 : ! >= w'x'(k,<t+1>) >=
237 : ! (1/rho_ds_zm(k))
238 : ! * [ rho_ds_zt(k)/(dt*invrs_dzt(k))
239 : ! * { xm(k,<t>) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k)
240 : ! - xm_upper_lim_allowable(k) }
241 : ! + rho_ds_zm(k-1) * w'x'(k-1,<t+1>) ].
242 : !
243 : ! The values of w'x' are found on the momentum levels, while the values of
244 : ! xm are found on the thermodynamic levels. Additionally, the values of
245 : ! rho_ds_zm are found on the momentum levels, and the values of rho_ds_zt
246 : ! are found on the thermodynamic levels. The inequality is applied to
247 : ! w'x'(k,<t+1>) from vertical levels 2 through the second-highest level
248 : ! (gr%nz-1). The value of w'x' at level 1 is a set surface (or lowest
249 : ! level) flux. The value of w'x' at the highest level is also a set value,
250 : ! and therefore is not altered.
251 : !
252 : ! Approximating maximum and minimum values of x at any given vertical level
253 : ! -------------------------------------------------------------------------
254 : !
255 : ! The CLUBB code provides means, variances, and covariances for certain
256 : ! variables at all vertical levels. However, there is no way to find the
257 : ! maximum or minimum point value of any variable on any vertical level.
258 : ! Without that information, x_max_dev_low and x_max_dev_high can't be found,
259 : ! and the inequality above is useless. However, there is a way to
260 : ! approximate the maximum and minimum point values at any given vertical
261 : ! level. The maximum and minimum point values can be approximated through
262 : ! the use of the variance, x'^2.
263 : !
264 : ! Just as the mean value of x, which is xm, and the turbulent flux of x,
265 : ! which is w'x', are known, so is the variance of x, which is x'^2. The
266 : ! standard deviation of x is the square root of the variance of x. The
267 : ! distribution of x along the horizontal plane (at vertical level k) is
268 : ! approximated to be the sum of two normal (or Gaussian) distributions.
269 : ! Most of the values in a normal distribution are found within 2 standard
270 : ! deviations from the mean. Thus, the maximum point value of x along the
271 : ! horizontal plance at any vertical level can be approximated as:
272 : ! xm + 2*sqrt(x'^2). Likewise, the minimum value of x along the horizontal
273 : ! plane at any vertical level can be approximated as: xm - 2*sqrt(x'^2).
274 : !
275 : ! The values of x'^2 are found on the momentum levels. The values of xm
276 : ! are found on the thermodynamic levels. Thus, the values of x'^2 are
277 : ! interpolated to the thermodynamic levels in order to find the maximum
278 : ! and minimum point values of variable x.
279 : !
280 : ! The one downfall of this method is that instabilities can arise in the
281 : ! model where unphysically large values of x'^2 are produced. Thus, this
282 : ! allows for an unphysically large deviation of xm from its values at the
283 : ! previous time step due to turbulent advection. Thus, for purposes of
284 : ! determining the maximum and minimum point values of x, a upper limit
285 : ! is placed on x'^2, in order to limit the standard deviation of x. This
286 : ! limit is only applied in this subroutine, and is not applied to x'^2
287 : ! elsewhere in the model code.
288 :
289 : ! References:
290 : !-----------------------------------------------------------------------
291 :
292 : use grid_class, only: &
293 : grid, & ! Type
294 : zm2zt ! Procedure(s)
295 :
296 : use constants_clubb, only: &
297 : zero_threshold, &
298 : eps, &
299 : fstderr
300 :
301 : use error_code, only: &
302 : clubb_at_least_debug_level, & ! Procedure
303 : err_code, & ! Error Indicator
304 : clubb_fatal_error ! Constant
305 :
306 : use clubb_precision, only: &
307 : core_rknd ! Variable(s)
308 :
309 : use advance_helper_module, only: &
310 : vertical_integral ! Procedure(s)
311 :
312 : use stats_type_utilities, only: &
313 : stat_begin_update, & ! Procedure(s)
314 : stat_end_update, &
315 : stat_update_var
316 :
317 : use stats_variables, only: &
318 : stats_metadata_type
319 :
320 : use stats_type, only: stats ! Type
321 :
322 : implicit none
323 :
324 : ! Constant Parameters
325 :
326 : ! Flag for using a semi-implicit, tridiagonal method to solve for xm(t+1)
327 : ! when xm(t+1) needs to be changed.
328 : logical, parameter :: l_mfl_xm_imp_adj = .true.
329 :
330 : !----------------------- Input Variables -----------------------
331 : integer, intent(in) :: &
332 : nz, &
333 : ngrdcol
334 :
335 : type (grid), target, intent(in) :: gr
336 :
337 : integer, intent(in) :: &
338 : solve_type ! Variables being solved for.
339 :
340 : real( kind = core_rknd ), intent(in) :: &
341 : dt ! Model timestep length [s]
342 :
343 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
344 : xm_old, & ! xm at previous time step (thermo. levs.) [units vary]
345 : xp2, & ! x'^2 (momentum levels) [units vary]
346 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
347 : xm_forcing, & ! xm forcings (thermodynamic levels) [units vary]
348 : rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3]
349 : rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3]
350 : invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg]
351 : invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg]
352 :
353 : real( kind = core_rknd ), intent(in) :: &
354 : xp2_threshold, & ! Lower limit of x'^2 [units vary]
355 : xm_tol ! Lower limit of maxdev [units vary]
356 :
357 : logical, intent(in) :: &
358 : l_implemented ! Flag for CLUBB being implemented in a larger model.
359 :
360 : integer, dimension(ngrdcol,nz), intent(in) :: &
361 : low_lev_effect, & ! Index of lowest level that has an effect (for lev. k)
362 : high_lev_effect ! Index of highest level that has an effect (for lev. k)
363 :
364 : integer, intent(in) :: &
365 : tridiag_solve_method ! Specifier for method to solve tridiagonal systems
366 :
367 : logical, intent(in) :: &
368 : l_upwind_xm_ma, & ! This flag determines whether we want to use an upwind differencing
369 : ! approximation rather than a centered differencing for turbulent or
370 : ! mean advection terms. It affects rtm, thlm, sclrm, um and vm.
371 : l_mono_flux_lim_spikefix ! Flag to implement monotonic flux limiter code that
372 : ! eliminates spurious drying tendencies at model top
373 :
374 : type (stats_metadata_type), intent(in) :: &
375 : stats_metadata
376 :
377 : !----------------------- Input/Output Variables -----------------------
378 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
379 : stats_zt, &
380 : stats_zm
381 :
382 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(inout) :: &
383 : xm, & ! xm at current time step (thermodynamic levels) [units vary]
384 : wpxp ! w'x' (momentum levels) [units vary]
385 :
386 : !----------------------- Local Variables -----------------------
387 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
388 2823552 : xp2_zt, & ! x'^2 interpolated to thermodynamic levels [units vary]
389 2823552 : xm_enter_mfl, & ! xm as it enters the MFL [units vary]
390 2823552 : xm_without_ta, & ! Value of xm without turb. adv. contrib. [units vary]
391 2823552 : wpxp_net_adjust ! Net amount of adjustment needed on w'x' [units vary]
392 :
393 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
394 2823552 : min_x_allowable_lev, & ! Smallest usuable value of x at lev k [units vary]
395 2823552 : max_x_allowable_lev, & ! Largest usuable value of x at lev k [units vary]
396 2823552 : min_x_allowable, & ! Smallest usuable x within k +/- num_levs [units vary]
397 2823552 : max_x_allowable, & ! Largest usuable x within k +/- num_levs [units vary]
398 2823552 : wpxp_mfl_max, & ! Upper limit on w'x'(k) [units vary]
399 2823552 : wpxp_mfl_min ! Lower limit on w'x'(k) [units vary]
400 :
401 : real( kind = core_rknd ) :: &
402 : max_xp2, & ! Maximum allowable x'^2 [units vary]
403 : max_dev, & ! Determines approximate upper/lower limit of x [units vary]
404 : m_adv_term, & ! Contribution of mean advection to d(xm)/dt [units vary]
405 : xm_density_weighted, & ! Density weighted xm at domain top [units vary]
406 : xm_adj_coef, & ! Coeffecient to eliminate spikes at domain top [units vary]
407 : xm_vert_integral, & ! Vertical integral of xm [units_vary]
408 : dxm_dt_mfl_adjust, & ! Rate of change of adjustment to xm [units vary]
409 : dz ! zm grid spacing at top of domain [m]
410 :
411 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz) :: &
412 2823552 : lhs_mfl_xm ! Left hand side of tridiagonal matrix
413 :
414 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
415 2823552 : rhs_mfl_xm ! Right hand side of tridiagonal matrix equation
416 :
417 : integer :: &
418 : k, km1, i, j ! Array indices
419 :
420 : ! integer, parameter :: &
421 : ! num_levs = 10 ! Number of levels above and below level k to look for
422 : ! ! maxima and minima of variable x.
423 :
424 : integer :: &
425 : low_lev, & ! Lowest level (from level k) to look for x minima and maxima
426 : high_lev ! Highest level (from level k) to look for x minima and maxima
427 :
428 : integer :: &
429 : iwpxp_mfl, &
430 : ixm_mfl
431 :
432 : logical, dimension(ngrdcol) :: &
433 2823552 : l_adjustment_needed ! Indicates if we need an adjustment for a column
434 :
435 : logical:: &
436 : l_any_adjustment_needed
437 :
438 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
439 2823552 : xm_mfl
440 :
441 : !---------------------------- Begin Code ----------------------------
442 :
443 : !$acc enter data create( xp2_zt, xm_enter_mfl, xm_without_ta, wpxp_net_adjust, &
444 : !$acc min_x_allowable_lev, max_x_allowable_lev, min_x_allowable, &
445 : !$acc max_x_allowable, wpxp_mfl_max, wpxp_mfl_min, lhs_mfl_xm, &
446 : !$acc rhs_mfl_xm, l_adjustment_needed, xm_mfl )
447 :
448 1764720 : select case( solve_type )
449 : case ( mono_flux_rtm ) ! rtm/wprtp
450 352944 : iwpxp_mfl = stats_metadata%iwprtp_mfl
451 352944 : ixm_mfl = stats_metadata%irtm_mfl
452 352944 : max_xp2 = 5.0e-6_core_rknd
453 : case ( mono_flux_thlm ) ! thlm/wpthlp
454 352944 : iwpxp_mfl = stats_metadata%iwpthlp_mfl
455 352944 : ixm_mfl = stats_metadata%ithlm_mfl
456 352944 : max_xp2 = 5.0_core_rknd
457 : case ( mono_flux_um ) ! um/upwp
458 352944 : iwpxp_mfl = stats_metadata%iupwp_mfl
459 352944 : ixm_mfl = stats_metadata%ium_mfl
460 352944 : max_xp2 = 10.0_core_rknd
461 : case ( mono_flux_vm ) ! vm/vpwp
462 352944 : iwpxp_mfl = stats_metadata%ivpwp_mfl
463 352944 : ixm_mfl = stats_metadata%ivm_mfl
464 352944 : max_xp2 = 10.0_core_rknd
465 : case default ! passive scalars are involved
466 0 : iwpxp_mfl = 0
467 0 : ixm_mfl = 0
468 1411776 : max_xp2 = 5.0_core_rknd
469 : end select
470 :
471 :
472 1411776 : if ( stats_metadata%l_stats_samp ) then
473 : !$acc update host( wpxp, xm )
474 0 : do i = 1, ngrdcol
475 0 : call stat_begin_update( nz, iwpxp_mfl, wpxp(i,:) / dt, & ! intent(in)
476 0 : stats_zm(i) ) ! intent(inout)
477 : call stat_begin_update( nz, ixm_mfl, xm(i,:) / dt, & ! intent(in)
478 0 : stats_zt(i) ) ! intent(inout)
479 : end do
480 : endif
481 1411776 : if ( stats_metadata%l_stats_samp .and. solve_type == mono_flux_thlm ) then
482 : !$acc update host( xm, xm_old, wpxp )
483 0 : do i = 1, ngrdcol
484 0 : call stat_update_var( stats_metadata%ithlm_enter_mfl, xm(i,:), & ! intent(in)
485 0 : stats_zt(i) ) ! intent(inout)
486 : call stat_update_var( stats_metadata%ithlm_old, xm_old(i,:), & ! intent(in)
487 0 : stats_zt(i) ) ! intent(inout)
488 : call stat_update_var( stats_metadata%iwpthlp_enter_mfl, wpxp(i,:), & ! intent(in)
489 0 : stats_zm(i) ) ! intent(inout)
490 : end do
491 1411776 : elseif ( stats_metadata%l_stats_samp .and. solve_type == mono_flux_rtm ) then
492 : !$acc update host( xm, xm_old, wpxp )
493 0 : do i = 1, ngrdcol
494 0 : call stat_update_var( stats_metadata%irtm_enter_mfl, xm(i,:), & ! intent(in)
495 0 : stats_zt(i) ) ! intent(inout)
496 : call stat_update_var( stats_metadata%irtm_old, xm_old(i,:), & ! intent(in)
497 0 : stats_zt(i) ) ! intent(inout)
498 : call stat_update_var( stats_metadata%iwprtp_enter_mfl, wpxp(i,:), & ! intent(in)
499 0 : stats_zm(i) ) ! intent(inout)
500 : end do
501 : endif
502 :
503 :
504 : !$acc parallel loop gang vector collapse(2) default(present)
505 121412736 : do k = 1, nz
506 2005148736 : do i = 1, ngrdcol
507 : ! Initialize arrays.
508 1883736000 : wpxp_net_adjust(i,k) = 0.0_core_rknd
509 :
510 : ! Store the value of xm as it enters the mfl
511 2003736960 : xm_enter_mfl(i,k) = xm(i,k)
512 : end do
513 : end do
514 : !$acc end parallel loop
515 :
516 : ! Interpolate x'^2 to thermodynamic levels.
517 1411776 : xp2_zt(:,:) = zm2zt( nz, ngrdcol, gr, xp2(:,:) )
518 :
519 : ! Place an upper limit on xp2_zt.
520 : ! For purposes of this subroutine, an upper limit has been placed on the
521 : ! variance, x'^2. This does not effect the value of x'^2 anywhere else in
522 : ! the model code. The upper limit is a reasonable upper limit. This is
523 : ! done to prevent unphysically large standard deviations caused by numerical
524 : ! instabilities in the x'^2 profile.
525 : !$acc parallel loop gang vector collapse(2) default(present)
526 121412736 : do k = 1, nz
527 2005148736 : do i = 1, ngrdcol
528 2003736960 : xp2_zt(i,k) = min( max( xp2_zt(i,k), xp2_threshold ), max_xp2 )
529 : end do
530 : end do
531 : !$acc end parallel loop
532 :
533 : ! Find the maximum and minimum usuable values of variable x at each
534 : ! vertical level. Start from level 2, which is the first level above
535 : ! the ground (or above the model surface). This computation needs to be
536 : ! performed for all vertical levels above the ground (or model surface).
537 : !$acc parallel loop gang vector collapse(2) default(present)
538 120000960 : do k = 2, nz, 1
539 1981575360 : do i = 1, ngrdcol
540 :
541 1861574400 : km1 = max( k-1, 1 )
542 : !kp1 = min( k+1, gr%nz )
543 :
544 : ! Most values are found within +/- 2 standard deviations from the mean.
545 : ! Use +/- 2 standard deviations from the mean as the maximum/minimum
546 : ! values.
547 : ! max_dev = 2.0_core_rknd*stnd_dev_x
548 :
549 : ! Set a minimum on max_dev
550 1861574400 : max_dev = max(2.0_core_rknd * sqrt( xp2_zt(i,k) ), xm_tol)
551 :
552 : ! Calculate the contribution of the mean advection term:
553 : ! m_adv_term = -wm_zt(k)*d(xm)/dz|_(k).
554 : ! Note: mean advection is not applied to xm at level gr%nz.
555 : !if ( .not. l_implemented .and. k < gr%nz ) then
556 : ! tmp(1:3) = term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(1,k), k )
557 : ! m_adv_term = - tmp(1) * xm(kp1) &
558 : ! - tmp(2) * xm(k) &
559 : ! - tmp(3) * xm(km1)
560 : !else
561 : ! m_adv_term = 0.0_core_rknd
562 : !endif
563 :
564 : ! Shut off to avoid using new, possibly corrupt mean advection term
565 1861574400 : m_adv_term = 0.0_core_rknd
566 :
567 : ! Find the value of xm without the contribution from the turbulent
568 : ! advection term.
569 : ! Note: the contribution of xm_forcing at level gr%nz should be 0.
570 : xm_without_ta(i,k) = xm_old(i,k) + dt*xm_forcing(i,k) &
571 1861574400 : + dt*m_adv_term
572 :
573 : ! Find the minimum usuable value of variable x at each vertical level.
574 1861574400 : if ( solve_type /= mono_flux_um .and. solve_type /= mono_flux_vm ) then
575 :
576 : ! Since variable x must be one of theta_l, r_t, or a scalar, all of
577 : ! which are positive definite quantities, the value must be >= 0.
578 : min_x_allowable_lev(i,k) &
579 930787200 : = max( xm_without_ta(i,k) - max_dev, zero_threshold )
580 :
581 : else ! solve_type == mono_flux_um .or. solve_type == mono_flux_vm
582 :
583 : ! Variable x must be one of u or v.
584 930787200 : min_x_allowable_lev(i,k) = xm_without_ta(i,k) - max_dev
585 :
586 : endif ! solve_type /= mono_flux_um .and. solve_type /= mono_flux_vm
587 :
588 : ! Find the maximum usuable value of variable x at each vertical level.
589 1980163584 : max_x_allowable_lev(i,k) = xm_without_ta(i,k) + max_dev
590 : end do
591 : end do
592 : !$acc end parallel loop
593 :
594 : ! Boundary condition on xm_without_ta
595 : !$acc parallel loop gang vector default(present)
596 23573376 : do i = 1, ngrdcol
597 22161600 : xm_without_ta(i,1) = xm(i,1)
598 22161600 : min_x_allowable_lev(i,1) = min_x_allowable_lev(i,2)
599 23573376 : max_x_allowable_lev(i,1) = max_x_allowable_lev(i,2)
600 : end do
601 : !$acc end parallel loop
602 :
603 : ! Find the maximum and minimum usuable values of x that can effect the value
604 : ! of x at level k. Then, find the upper and lower limits of w'x'. Reset
605 : ! the value of w'x' if it is outside of those limits, and store the amount
606 : ! of adjustment that was needed to w'x'.
607 : ! The values of w'x' at level 1 and at level gr%nz are set values and
608 : ! are not altered.
609 :
610 : ! Find the smallest value of all relevant level minima for variable x.
611 : !$acc parallel loop gang vector collapse(2) default(present)
612 118589184 : do k = 2, nz-1
613 1958001984 : do i = 1, ngrdcol
614 :
615 1839412800 : low_lev = max( low_lev_effect(i,k), 2 )
616 1839412800 : high_lev = min( high_lev_effect(i,k), nz )
617 :
618 1839412800 : min_x_allowable(i,k) = min_x_allowable_lev(i,low_lev)
619 :
620 4209303416 : do j = low_lev, high_lev
621 4092126008 : min_x_allowable(i,k) = min( min_x_allowable(i,k), min_x_allowable_lev(i,j) )
622 : end do
623 :
624 : end do
625 : end do
626 : !$acc end parallel loop
627 :
628 : ! Find the largest value of all relevant level maxima for variable x.
629 : !$acc parallel loop gang vector collapse(2) default(present)
630 118589184 : do k = 2, nz-1
631 1958001984 : do i = 1, ngrdcol
632 :
633 1839412800 : low_lev = max( low_lev_effect(i,k), 2 )
634 1839412800 : high_lev = min( high_lev_effect(i,k), nz )
635 :
636 1839412800 : max_x_allowable(i,k) = max_x_allowable_lev(i,low_lev)
637 :
638 4209303416 : do j = low_lev, high_lev
639 4092126008 : max_x_allowable(i,k) = max( max_x_allowable(i,k), max_x_allowable_lev(i,j) )
640 : end do
641 : end do
642 : end do
643 : !$acc end parallel loop
644 :
645 : !$acc parallel loop gang vector collapse(2) default(present)
646 118589184 : do k = 2, nz-1, 1
647 1958001984 : do i = 1, ngrdcol
648 :
649 : ! Find the upper limit for w'x' for a monotonic turbulent flux.
650 : ! The following "if" statement ensures there are no "spikes" at the top of the column,
651 : ! which can cause unphysical rtm and thlm tendencies over the height of the column.
652 : ! The fix essentially turns off the monotonic flux limiter for these special cases,
653 : ! but tests show that it still performs well otherwise and runs stably.
654 : if ( l_mono_flux_lim_spikefix .and. solve_type == mono_flux_rtm &
655 3678825600 : .and. abs( wpxp(i,k-1) ) > 1 / ( dt * gr%invrs_dzt(i,k) ) &
656 1839412800 : * ( xm_without_ta(i,k) - min_x_allowable(i,k) ) &
657 7357651200 : .and. wpxp(i,k-1) < 0.0_core_rknd ) then
658 37310 : wpxp_mfl_max(i,k) = 0.0_core_rknd
659 : else
660 : wpxp_mfl_max(i,k) &
661 : = invrs_rho_ds_zm(i,k) &
662 : * ( ( rho_ds_zt(i,k) / (dt*gr%invrs_dzt(i,k)) ) &
663 : * ( xm_without_ta(i,k) - min_x_allowable(i,k) ) &
664 1839375490 : + rho_ds_zm(i,k-1) * wpxp(i,k-1) )
665 : endif
666 :
667 : ! Find the lower limit for w'x' for a monotonic turbulent flux.
668 : wpxp_mfl_min(i,k) &
669 : = invrs_rho_ds_zm(i,k) &
670 0 : * ( ( rho_ds_zt(i,k) / (dt*gr%invrs_dzt(i,k)) ) &
671 : * ( xm_without_ta(i,k) - max_x_allowable(i,k) ) &
672 1839412800 : + rho_ds_zm(i,k-1) * wpxp(i,k-1) )
673 :
674 1956590208 : if ( wpxp(i,k) > wpxp_mfl_max(i,k) ) then
675 :
676 : ! This block of print statements can be uncommented for debugging.
677 : !print *, "k = ", k
678 : !print *, "wpxp too large (mfl)"
679 : !print *, "xm(t) = ", xm_old(k)
680 : !print *, "xm(t+1) entering mfl = ", xm(k)
681 : !print *, "xm(t+1) without ta = ", xm_without_ta(k)
682 : !print *, "max x allowable = ", max_x_allowable(k)
683 : !print *, "min x allowable = ", min_x_allowable(k)
684 : !print *, "1/rho_ds_zm(k) = ", invrs_rho_ds_zm(k)
685 : !print *, "rho_ds_zt(k) = ", rho_ds_zt(k)
686 : !print *, "rho_ds_zt(k)*(delta_zt/dt) = ", &
687 : ! real( rho_ds_zt(k) / (dt*gr%invrs_dzt(1,k)) )
688 : !print *, "xm without ta - min x allow = ", &
689 : ! xm_without_ta(k) - min_x_allowable(k)
690 : !print *, "rho_ds_zm(km1) = ", rho_ds_zm(km1)
691 : !print *, "wpxp(km1) = ", wpxp(km1)
692 : !print *, "rho_ds_zm(km1) * wpxp(km1) = ", rho_ds_zm(km1) * wpxp(km1)
693 : !print *, "wpxp upper lim = ", wpxp_mfl_max(k)
694 : !print *, "wpxp before adjustment = ", wpxp(k)
695 :
696 : ! Determine the net amount of adjustment needed for w'x'.
697 130109 : wpxp_net_adjust(i,k) = wpxp_mfl_max(i,k) - wpxp(i,k)
698 :
699 : ! Reset the value of w'x' to the upper limit allowed by the
700 : ! monotonic flux limiter.
701 130109 : wpxp(i,k) = wpxp_mfl_max(i,k)
702 :
703 1839282691 : elseif ( wpxp(i,k) < wpxp_mfl_min(i,k) ) then
704 :
705 : ! This block of print statements can be uncommented for debugging.
706 : !print *, "k = ", k
707 : !print *, "wpxp too small (mfl)"
708 : !print *, "xm(t) = ", xm_old(k)
709 : !print *, "xm(t+1) entering mfl = ", xm(k)
710 : !print *, "xm(t+1) without ta = ", xm_without_ta(k)
711 : !print *, "max x allowable = ", max_x_allowable(k)
712 : !print *, "min x allowable = ", min_x_allowable(k)
713 : !print *, "1/rho_ds_zm(k) = ", invrs_rho_ds_zm(k)
714 : !print *, "rho_ds_zt(k) = ", rho_ds_zt(k)
715 : !print *, "rho_ds_zt(k)*(delta_zt/dt) = ", &
716 : ! real( rho_ds_zt(k) / (dt*gr%invrs_dzt(1,k)) )
717 : !print *, "xm without ta - max x allow = ", &
718 : ! xm_without_ta(k) - max_x_allowable(k)
719 : !print *, "rho_ds_zm(km1) = ", rho_ds_zm(km1)
720 : !print *, "wpxp(km1) = ", wpxp(km1)
721 : !print *, "rho_ds_zm(km1) * wpxp(km1) = ", rho_ds_zm(km1) * wpxp(km1)
722 : !print *, "wpxp lower lim = ", wpxp_mfl_min(k)
723 : !print *, "wpxp before adjustment = ", wpxp(k)
724 :
725 : ! Determine the net amount of adjustment needed for w'x'.
726 188614 : wpxp_net_adjust(i,k) = wpxp_mfl_min(i,k) - wpxp(i,k)
727 :
728 : ! Reset the value of w'x' to the lower limit allowed by the
729 : ! monotonic flux limiter.
730 188614 : wpxp(i,k) = wpxp_mfl_min(i,k)
731 :
732 : ! This block of code can be uncommented for debugging.
733 : !else
734 : !
735 : ! ! wpxp(k) is okay.
736 : ! if ( wpxp_net_adjust(km1) /= 0.0_core_rknd ) then
737 : ! print *, "k = ", k
738 : ! print *, "wpxp is in an acceptable range (mfl)"
739 : ! print *, "xm(t) = ", xm_old(k)
740 : ! print *, "xm(t+1) entering mfl = ", xm(k)
741 : ! print *, "xm(t+1) without ta = ", xm_without_ta(k)
742 : ! print *, "max x allowable = ", max_x_allowable(k)
743 : ! print *, "min x allowable = ", min_x_allowable(k)
744 : ! print *, "1/rho_ds_zm(k) = ", invrs_rho_ds_zm(k)
745 : ! print *, "rho_ds_zt(k) = ", rho_ds_zt(k)
746 : ! print *, "rho_ds_zt(k)*(delta_zt/dt) = ", &
747 : ! real( rho_ds_zt(k) / (dt*gr%invrs_dzt(1,k)) )
748 : ! print *, "xm without ta - min x allow = ", &
749 : ! xm_without_ta(k) - min_x_allowable(k)
750 : ! print *, "xm without ta - max x allow = ", &
751 : ! xm_without_ta(k) - max_x_allowable(k)
752 : ! print *, "rho_ds_zm(km1) = ", rho_ds_zm(km1)
753 : ! print *, "wpxp(km1) = ", wpxp(km1)
754 : ! print *, "rho_ds_zm(km1) * wpxp(km1) = ", &
755 : ! rho_ds_zm(km1) * wpxp(km1)
756 : ! print *, "wpxp upper lim = ", wpxp_mfl_max(k)
757 : ! print *, "wpxp lower lim = ", wpxp_mfl_min(k)
758 : ! print *, "wpxp (stays the same) = ", wpxp(k)
759 : ! endif
760 : !
761 : endif
762 : end do
763 : end do
764 : !$acc end parallel loop
765 :
766 : ! Boundary conditions
767 : !$acc parallel loop gang vector default(present)
768 23573376 : do i = 1, ngrdcol
769 22161600 : min_x_allowable(i,1) = 0._core_rknd
770 22161600 : max_x_allowable(i,1) = 0._core_rknd
771 :
772 22161600 : min_x_allowable(i,nz) = 0._core_rknd
773 22161600 : max_x_allowable(i,nz) = 0._core_rknd
774 :
775 22161600 : wpxp_mfl_min(i,1) = 0._core_rknd
776 22161600 : wpxp_mfl_max(i,1) = 0._core_rknd
777 :
778 22161600 : wpxp_mfl_min(i,nz) = 0._core_rknd
779 23573376 : wpxp_mfl_max(i,nz) = 0._core_rknd
780 : end do
781 : !$acc end parallel loop
782 :
783 1411776 : if ( stats_metadata%l_stats_samp .and. solve_type == mono_flux_thlm ) then
784 : !$acc update host( xm_without_ta, min_x_allowable, wpxp_mfl_min, &
785 : !$acc wpxp_mfl_max, max_x_allowable )
786 0 : do i = 1, ngrdcol
787 0 : call stat_update_var( stats_metadata%ithlm_without_ta, xm_without_ta(i,:), & ! intent(in)
788 0 : stats_zt(i) ) ! intent(inout)
789 : call stat_update_var( stats_metadata%ithlm_mfl_min, min_x_allowable(i,:), & ! intent(in)
790 0 : stats_zt(i) ) ! intent(inout)
791 : call stat_update_var( stats_metadata%ithlm_mfl_max, max_x_allowable(i,:), & ! intent(in)
792 0 : stats_zt(i) ) ! intent(inout)
793 : call stat_update_var( stats_metadata%iwpthlp_mfl_min, wpxp_mfl_min(i,:), & ! intent(in)
794 0 : stats_zm(i) ) ! intent(inout)
795 : call stat_update_var( stats_metadata%iwpthlp_mfl_max, wpxp_mfl_max(i,:), & ! intent(in)
796 0 : stats_zm(i) ) ! intent(inout)
797 : end do
798 1411776 : elseif ( stats_metadata%l_stats_samp .and. solve_type == mono_flux_rtm ) then
799 : !$acc update host( xm_without_ta, min_x_allowable, max_x_allowable, &
800 : !$acc wpxp_mfl_min, wpxp_mfl_max )
801 0 : do i = 1, ngrdcol
802 0 : call stat_update_var( stats_metadata%irtm_without_ta, xm_without_ta(i,:), & ! intent(in)
803 0 : stats_zt(i) ) ! intent(inout)
804 : call stat_update_var( stats_metadata%irtm_mfl_min, min_x_allowable(i,:), & ! intent(in)
805 0 : stats_zt(i) ) ! intent(inout)
806 : call stat_update_var( stats_metadata%irtm_mfl_max, max_x_allowable(i,:), & ! intent(in)
807 0 : stats_zt(i) ) ! intent(inout)
808 : call stat_update_var( stats_metadata%iwprtp_mfl_min, wpxp_mfl_min(i,:), & ! intent(in)
809 0 : stats_zm(i) ) ! intent(inout)
810 : call stat_update_var( stats_metadata%iwprtp_mfl_max, wpxp_mfl_max(i,:), & ! intent(in)
811 0 : stats_zm(i) ) ! intent(inout)
812 : end do
813 : endif
814 :
815 23573376 : l_any_adjustment_needed = .false.
816 :
817 : !$acc parallel loop gang vector default(present)
818 23573376 : do i = 1, ngrdcol
819 23573376 : l_adjustment_needed(i) = .false.
820 : end do
821 : !$acc end parallel loop
822 :
823 : !$acc parallel loop gang vector collapse(2) default(present) &
824 : !$acc reduction(.or.:l_any_adjustment_needed)
825 23573376 : do i = 1, ngrdcol
826 1907309376 : do k = 1, nz
827 1905897600 : if ( abs(wpxp_net_adjust(i,k)) > eps ) then
828 318723 : l_adjustment_needed(i) = .true.
829 318723 : l_any_adjustment_needed = .true.
830 : end if
831 : end do
832 : end do
833 : !$acc end parallel loop
834 :
835 1411776 : if ( l_any_adjustment_needed ) then
836 :
837 : ! Reset the value of xm to compensate for the change to w'x'.
838 :
839 : if ( l_mfl_xm_imp_adj ) then
840 :
841 : ! A tridiagonal matrix is used to semi-implicitly re-solve for the
842 : ! values of xm at timestep index (t+1).
843 :
844 : ! Set up the left-hand side of the tridiagonal matrix equation.
845 : call mfl_xm_lhs( nz, ngrdcol, dt, gr%weights_zt2zm, & ! intent(in)
846 : gr%invrs_dzt, gr%invrs_dzm, & ! intent(in)
847 : wm_zt, l_implemented, l_upwind_xm_ma, & ! intent(in)
848 29400 : lhs_mfl_xm ) ! intent(out)
849 :
850 : ! Set up the right-hand side of tridiagonal matrix equation.
851 : call mfl_xm_rhs( nz, ngrdcol, dt, xm_old, wpxp, xm_forcing, & ! intent(in)
852 : gr%invrs_dzt, rho_ds_zm, invrs_rho_ds_zt, & ! intent(in)
853 29400 : rhs_mfl_xm ) ! intent(out)
854 :
855 : ! Solve the tridiagonal matrix equation.
856 : call mfl_xm_solve( nz, ngrdcol, solve_type, tridiag_solve_method, & ! intent(in)
857 : lhs_mfl_xm, rhs_mfl_xm, & ! intent(inout)
858 29400 : xm_mfl ) ! intent(inout)
859 :
860 : ! If an adjustment is for a column
861 : !$acc parallel loop gang vector collapse(2) default(present)
862 2528400 : do k = 1, nz
863 41859600 : do i = 1, ngrdcol
864 41830200 : if ( l_adjustment_needed(i) ) then
865 11842795 : xm(i,k) = xm_mfl(i,k)
866 : end if
867 : end do
868 : end do
869 : !$acc end parallel loop
870 :
871 : ! Check for errors
872 29400 : if ( clubb_at_least_debug_level( 0 ) ) then
873 29400 : if ( err_code == clubb_fatal_error ) return
874 : end if
875 :
876 : else ! l_mfl_xm_imp_adj = .false.
877 :
878 : ! An explicit adjustment is made to the values of xm at timestep
879 : ! index (t+1), which is based upon the array of the amounts of w'x'
880 : ! adjustments.
881 :
882 : !$acc parallel loop gang vector collapse(2) default(present)
883 : do k = 2, nz, 1
884 : do i = 1, ngrdcol
885 :
886 : if ( l_adjustment_needed(i) ) then
887 :
888 : ! The rate of change of the adjustment to xm due to the monotonic
889 : ! flux limiter.
890 : dxm_dt_mfl_adjust = - invrs_rho_ds_zt(i,k) * gr%invrs_dzt(i,k) &
891 : * ( rho_ds_zm(i,k) * wpxp_net_adjust(i,k) &
892 : - rho_ds_zm(i,k-1) * wpxp_net_adjust(i,k-1) )
893 :
894 : ! The net change to xm due to the monotonic flux limiter is the
895 : ! rate of change multiplied by the time step length. Add the
896 : ! product to xm to find the new xm resulting from the monotonic
897 : ! flux limiter.
898 : xm(i,k) = xm(i,k) + dxm_dt_mfl_adjust * dt
899 : end if
900 :
901 : end do
902 : end do
903 : !$acc end parallel loop
904 :
905 : ! Boundary condition on xm
906 : !$acc parallel loop gang vector default(present)
907 : do i = 1, ngrdcol
908 : xm(i,1) = xm(i,2)
909 : end do
910 : !$acc end parallel loop
911 :
912 : endif ! l_mfl_xm_imp_adj
913 :
914 : ! This code can be uncommented for debugging.
915 : !do k = 1, gr%nz, 1
916 : ! print *, "k = ", k, "xm(t) = ", xm_old(k), "new xm(t+1) = ", xm(k)
917 : !enddo
918 :
919 : !Ensure there are no spikes at the top of the domain
920 : !$acc parallel loop gang vector default(present)
921 492120 : do i = 1, ngrdcol
922 :
923 492120 : if (abs( xm(i,nz) - xm_enter_mfl(i,nz) ) > 10._core_rknd * xm_tol) then
924 126 : dz = gr%zm(i,nz) - gr%zm(i,nz - 1)
925 :
926 : xm_density_weighted = rho_ds_zt(i,nz) &
927 : * (xm(i,nz) - xm_enter_mfl(i,nz)) &
928 126 : * dz
929 :
930 10584 : xm_vert_integral = sum(rho_ds_zt(i,2:nz-1) * xm(i,2:nz-1) * gr%dzt(i,2:nz-1) )
931 :
932 : !Check to ensure the vertical integral is not zero to avoid a divide
933 : !by zero error
934 126 : if ( abs(xm_vert_integral) < eps ) then
935 0 : write(fstderr,*) "Vertical integral of xm is zero;", &
936 0 : "mfl will remove spike at top of domain,", &
937 0 : "but it will not conserve xm."
938 :
939 : !Remove the spike at the top of the domain
940 0 : xm(i,nz) = xm_enter_mfl(i,nz)
941 : else
942 126 : xm_adj_coef = xm_density_weighted / xm_vert_integral
943 :
944 : !xm_adj_coef can not be smaller than -1
945 126 : if (xm_adj_coef < -0.99_core_rknd) then
946 : write(fstderr,*) "xm_adj_coef in mfl less than -0.99, " &
947 0 : // "mx_adj_coef set to -0.99"
948 0 : xm_adj_coef = -0.99_core_rknd
949 : endif
950 :
951 : !Apply the adjustment
952 10836 : xm(i,:) = xm(i,:) * (1._core_rknd + xm_adj_coef)
953 :
954 : !Remove the spike at the top of the domain
955 126 : xm(i,nz) = xm_enter_mfl(i,nz)
956 :
957 : !This code can be uncommented to ensure conservation
958 : !if (abs(sum(rho_ds_zt(2:gr%nz) * xm(2:gr%nz) / gr%invrs_dzt(2:gr%nz)) - &
959 : ! sum(rho_ds_zt(2:gr%nz) * xm_enter_mfl(2:gr%nz) / gr%invrs_dzt(2:gr%nz)))&
960 : ! > (1000 * xm_tol)) then
961 : ! write(fstderr,*) "NON-CONSERVATION in MFL", trim( solve_type ), &
962 : ! abs(sum(rho_ds_zt(2:gr%nz) * xm(2:gr%nz) / gr%invrs_dzt(2:gr%nz)) - &
963 : ! sum(rho_ds_zt(2:gr%nz) * xm_enter_mfl(2:gr%nz) / &
964 : ! gr%invrs_dzt(2:gr%nz)))
965 : !
966 : ! write(fstderr,*) "XM_ENTER_MFL=", xm_enter_mfl
967 : ! write(fstderr,*) "XM_AFTER_SPIKE_REMOVAL", xm
968 : ! write(fstderr,*) "XM_TOL", xm_tol
969 : ! write(fstderr,*) "XM_ADJ_COEF", xm_adj_coef
970 : !endif
971 :
972 : endif ! xm_vert_integral < eps
973 : endif ! spike at domain top
974 : end do
975 : !$acc end parallel loop
976 :
977 : end if
978 :
979 1411776 : if ( stats_metadata%l_stats_samp ) then
980 : !$acc update host( wpxp, xm )
981 0 : do i = 1, ngrdcol
982 :
983 0 : call stat_end_update( nz, iwpxp_mfl, wpxp(i,:) / dt, & ! intent(in)
984 0 : stats_zm(i) ) ! intent(inout)
985 :
986 : call stat_end_update( nz, ixm_mfl, xm(i,:) / dt, & ! intent(in)
987 0 : stats_zt(i) ) ! intent(inout)
988 :
989 0 : if ( solve_type == mono_flux_thlm ) then
990 : call stat_update_var( stats_metadata%ithlm_exit_mfl, xm(i,:), & ! intent(in)
991 0 : stats_zt(i) ) ! intent(inout)
992 : call stat_update_var( stats_metadata%iwpthlp_exit_mfl, wpxp(i,:), & ! intent(in)
993 0 : stats_zm(i) ) ! intent(inout)
994 0 : elseif ( solve_type == mono_flux_rtm ) then
995 : call stat_update_var( stats_metadata%irtm_exit_mfl, xm(i,:), & ! intent(in)
996 0 : stats_zt(i) ) ! intent(inout)
997 : call stat_update_var( stats_metadata%iwprtp_exit_mfl, wpxp(i,:), & ! intent(in)
998 0 : stats_zm(i) ) ! intent(inout)
999 : endif
1000 : end do
1001 : endif
1002 :
1003 : !$acc exit data delete( xp2_zt, xm_enter_mfl, xm_without_ta, wpxp_net_adjust, &
1004 : !$acc min_x_allowable_lev, max_x_allowable_lev, min_x_allowable, &
1005 : !$acc max_x_allowable, wpxp_mfl_max, wpxp_mfl_min, lhs_mfl_xm, &
1006 : !$acc rhs_mfl_xm, l_adjustment_needed, xm_mfl )
1007 :
1008 : return
1009 :
1010 : end subroutine monotonic_turbulent_flux_limit
1011 :
1012 : !=============================================================================
1013 29400 : subroutine mfl_xm_lhs( nz, ngrdcol, dt, weights_zt2zm, &
1014 29400 : invrs_dzt, invrs_dzm, &
1015 29400 : wm_zt, l_implemented, l_upwind_xm_ma, &
1016 29400 : lhs )
1017 :
1018 : ! Description:
1019 : ! This subroutine is part of the process of re-solving for xm at timestep
1020 : ! index (t+1). This is done because the original solving process produced
1021 : ! values outside of what is deemed acceptable by the monotonic flux limiter.
1022 : ! Unlike the original formulation for advancing xm one timestep, which
1023 : ! combines w'x' and xm in a band-diagonal solver, this formulation uses a
1024 : ! tridiagonal solver to solve for only the value of xm(t+1), for w'x'(t+1)
1025 : ! is known.
1026 : !
1027 : ! Subroutine mfl_xm_lhs sets up the left-hand side of the matrix equation.
1028 :
1029 : use grid_class, only: &
1030 : grid ! Type
1031 :
1032 : use mean_adv, only: &
1033 : term_ma_zt_lhs ! Procedure(s)
1034 :
1035 : use clubb_precision, only: &
1036 : core_rknd ! Variable(s)
1037 :
1038 : implicit none
1039 :
1040 : ! Constant parameters
1041 : integer, parameter :: &
1042 : t_above = 1, & ! Index for upper thermodynamic level grid weight.
1043 : t_below = 2 ! Index for lower thermodynamic level grid weight.
1044 :
1045 : integer, parameter :: &
1046 : k_tdiag = 2 ! Thermodynamic main diagonal index.
1047 :
1048 : !---------------------------- Input Variables ----------------------------
1049 : integer, intent(in) :: &
1050 : nz, &
1051 : ngrdcol
1052 :
1053 : real( kind = core_rknd ), intent(in) :: &
1054 : dt ! Model timestep length [s]
1055 :
1056 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
1057 : wm_zt, & ! w wind component on thermodynamic levels [m/s]
1058 : invrs_dzt, &
1059 : invrs_dzm
1060 :
1061 : real( kind = core_rknd ), dimension(ngrdcol,nz,t_above:t_below), intent(in) :: &
1062 : weights_zt2zm
1063 :
1064 : logical, intent(in) :: &
1065 : l_implemented ! Flag for CLUBB being implemented in a larger model.
1066 :
1067 : logical, intent(in) :: &
1068 : l_upwind_xm_ma ! This flag determines whether we want to use an upwind differencing
1069 : ! approximation rather than a centered differencing for turbulent or
1070 : ! mean advection terms. It affects rtm, thlm, sclrm, um and vm.
1071 :
1072 : !---------------------------- Output Variables ----------------------------
1073 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(out) :: &
1074 : lhs ! Left hand side of tridiagonal matrix
1075 :
1076 : !---------------------------- Local Variables ----------------------------
1077 : integer :: i, k, b ! Array index
1078 :
1079 : !---------------------------- Begin Code ----------------------------
1080 :
1081 : ! The xm loop runs between k = 2 and k = nz. The value of xm at
1082 : ! level k = 1, which is below the model surface, is simply set equal to the
1083 : ! value of xm at level k = 2 after the solve has been completed.
1084 :
1085 : ! Setup LHS of the tridiagonal system
1086 :
1087 : ! LHS xm mean advection (ma) term.
1088 29400 : if ( .not. l_implemented ) then
1089 :
1090 : call term_ma_zt_lhs( nz, ngrdcol, wm_zt, weights_zt2zm, & ! intent(in)
1091 : invrs_dzt, invrs_dzm, & ! intent(in)
1092 : l_upwind_xm_ma, & ! intent(in)
1093 0 : lhs ) ! intent(out)
1094 : else
1095 : !$acc parallel loop gang vector collapse(3) default(present)
1096 2528400 : do k = 1, nz
1097 41859600 : do i = 1, ngrdcol
1098 159823800 : do b = 1, ndiags3
1099 157324800 : lhs(b,i,k) = 0.0_core_rknd
1100 : end do
1101 : end do
1102 : end do
1103 : !$acc end parallel loop
1104 : endif
1105 :
1106 : !$acc parallel loop gang vector collapse(2) default(present)
1107 2499000 : do k = 2, nz, 1
1108 41367480 : do i = 1, ngrdcol
1109 : ! LHS xm time tendency.
1110 41338080 : lhs(k_tdiag,i,k) = lhs(k_tdiag,i,k) + 1.0_core_rknd / dt
1111 : end do
1112 : end do ! xm loop: 2..nz
1113 : !$acc end parallel loop
1114 :
1115 : ! Boundary conditions.
1116 :
1117 : ! Lower boundary
1118 : !$acc parallel loop gang vector collapse(2) default(present)
1119 2528400 : do k = 1, nz
1120 41859600 : do i = 1, ngrdcol
1121 157324800 : lhs(:,i,1) = 0.0_core_rknd
1122 41830200 : lhs(k_tdiag,i,1) = 1.0_core_rknd
1123 : end do
1124 : end do
1125 : !$acc end parallel loop
1126 :
1127 29400 : return
1128 :
1129 : end subroutine mfl_xm_lhs
1130 :
1131 : !=============================================================================
1132 29400 : subroutine mfl_xm_rhs( nz, ngrdcol, dt, xm_old, wpxp, xm_forcing, &
1133 29400 : invrs_dzt, rho_ds_zm, invrs_rho_ds_zt, &
1134 29400 : rhs )
1135 :
1136 : ! Description:
1137 : ! This subroutine is part of the process of re-solving for xm at timestep
1138 : ! index (t+1). This is done because the original solving process produced
1139 : ! values outside of what is deemed acceptable by the monotonic flux limiter.
1140 : ! Unlike the original formulation for advancing xm one timestep, which
1141 : ! combines w'x' and xm in a band-diagonal solver, this formulation uses a
1142 : ! tridiagonal solver to solve for only the value of xm(t+1), for w'x'(t+1)
1143 : ! is known.
1144 : !
1145 : ! Subroutine mfl_xm_rhs sets up the right-hand side of the matrix equation.
1146 :
1147 : use clubb_precision, only: &
1148 : core_rknd ! Variable(s)
1149 :
1150 : implicit none
1151 :
1152 : !---------------------------- Input Variables ----------------------------
1153 : integer, intent(in) :: &
1154 : nz, &
1155 : ngrdcol
1156 :
1157 : real( kind = core_rknd ), intent(in) :: &
1158 : dt ! Model timestep length [s]
1159 :
1160 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
1161 : invrs_dzt, & ! The inverse spacing between momentum grid levels;
1162 : ! centered over thermodynamic grid levels.
1163 : xm_old, & ! xm; timestep (t) (thermodynamic levels) [units vary]
1164 : wpxp, & ! w'x'; timestep (t+1); limited (m-levs.) [units vary]
1165 : xm_forcing, & ! xm forcings (thermodynamic levels) [units vary]
1166 : rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3]
1167 : invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg]
1168 :
1169 : !---------------------------- Output Variable ----------------------------
1170 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
1171 : rhs ! Right hand side of tridiagonal matrix equation
1172 :
1173 : !---------------------------- Local Variables ----------------------------
1174 : integer :: i, k ! Array indices
1175 :
1176 : !---------------------------- Begin Code ----------------------------
1177 :
1178 : ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at
1179 : ! level k = 1, which is below the model surface, is simply set equal to the
1180 : ! value of xm at level k = 2 after the solve has been completed.
1181 :
1182 : !$acc parallel loop gang vector collapse(2) default(present)
1183 2499000 : do k = 2, nz, 1
1184 41367480 : do i = 1, ngrdcol
1185 :
1186 : ! RHS xm time tendency.
1187 38868480 : rhs(i,k) = xm_old(i,k) / dt
1188 :
1189 : ! RHS xm turbulent advection (ta) term.
1190 : ! Note: Normally, the turbulent advection (ta) term is treated
1191 : ! implicitly when advancing xm one timestep, as both xm and w'x'
1192 : ! are advanced together from timestep index (t) to timestep
1193 : ! index (t+1). However, in this case, both xm and w'x' have
1194 : ! already been advanced one timestep. However, w'x'(t+1) has been
1195 : ! limited after the fact, and therefore it's values at timestep
1196 : ! index (t+1) are known. Thus, in re-solving for xm(t+1), the
1197 : ! derivative of w'x'(t+1) can be placed on the right-hand side of
1198 : ! the d(xm)/dt equation.
1199 : rhs(i,k) = rhs(i,k) &
1200 : - invrs_rho_ds_zt(i,k) * invrs_dzt(i,k) &
1201 38868480 : * ( rho_ds_zm(i,k) * wpxp(i,k) - rho_ds_zm(i,k-1) * wpxp(i,k-1) )
1202 :
1203 : ! RHS xm forcings.
1204 : ! Note: xm forcings include the effects of microphysics,
1205 : ! cloud water sedimentation, radiation, and any
1206 : ! imposed forcings on xm.
1207 41338080 : rhs(i,k) = rhs(i,k) + xm_forcing(i,k)
1208 :
1209 : end do
1210 : end do ! xm loop: 2..gr%nz
1211 : !$acc end parallel loop
1212 :
1213 : ! Boundary conditions
1214 :
1215 : ! Lower Boundary
1216 : ! The value of xm at the lower boundary will remain the same. However, the
1217 : ! value of xm at the lower boundary gets overwritten after the matrix is
1218 : ! solved for the next timestep, such that xm(1) = xm(2).
1219 : !$acc parallel loop gang vector default(present)
1220 492120 : do i = 1, ngrdcol
1221 492120 : rhs(i,1) = xm_old(i,1)
1222 : end do
1223 : !$acc end parallel loop
1224 :
1225 29400 : return
1226 :
1227 : end subroutine mfl_xm_rhs
1228 :
1229 : !=============================================================================
1230 29400 : subroutine mfl_xm_solve( nz, ngrdcol, solve_type, tridiag_solve_method, &
1231 29400 : lhs, rhs, &
1232 29400 : xm )
1233 :
1234 : ! Description:
1235 : ! This subroutine is part of the process of re-solving for xm at timestep
1236 : ! index (t+1). This is done because the original solving process produced
1237 : ! values outside of what is deemed acceptable by the monotonic flux limiter.
1238 : ! Unlike the original formulation for advancing xm one timestep, which
1239 : ! combines w'x' and xm in a band-diagonal solver, this formulation uses a
1240 : ! tridiagonal solver to solve for only the value of xm(t+1), for w'x'(t+1)
1241 : ! is known.
1242 : !
1243 : ! Subroutine mfl_xm_solve solves the tridiagonal matrix equation for xm at
1244 : ! timestep index (t+1).
1245 :
1246 : use matrix_solver_wrapper, only: &
1247 : tridiag_solve ! Procedure(s)
1248 :
1249 : use clubb_precision, only: &
1250 : core_rknd
1251 :
1252 : use error_code, only: &
1253 : clubb_at_least_debug_level, & ! Procedure
1254 : err_code, & ! Error Indicator
1255 : clubb_fatal_error ! Constant
1256 :
1257 : implicit none
1258 :
1259 : ! Constant parameters
1260 : integer, parameter :: &
1261 : kp1_tdiag = 1, & ! Thermodynamic superdiagonal index.
1262 : k_tdiag = 2, & ! Thermodynamic main diagonal index.
1263 : km1_tdiag = 3 ! Thermodynamic subdiagonal index.
1264 :
1265 : !---------------------------- Input Variables ----------------------------
1266 : integer, intent(in) :: &
1267 : nz, &
1268 : ngrdcol
1269 :
1270 : integer, intent(in) :: &
1271 : solve_type ! Variables being solved for.
1272 :
1273 : integer, intent(in) :: &
1274 : tridiag_solve_method ! Specifier for method to solve tridiagonal systems
1275 :
1276 : !---------------------------- InOut Variables ----------------------------
1277 : real( kind = core_rknd ), dimension(ndiags3,ngrdcol,nz), intent(inout) :: &
1278 : lhs ! Left hand side of tridiagonal matrix
1279 :
1280 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(inout) :: &
1281 : rhs ! Right hand side of tridiagonal matrix equation
1282 :
1283 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(inout) :: &
1284 : xm ! Value of variable being solved for at timestep (t+1) [units vary]
1285 :
1286 : !---------------------------- Local Variable ----------------------------
1287 : character(len=10) :: &
1288 : solve_type_str ! solve_type as a string for debug output purposes
1289 :
1290 : integer :: i
1291 :
1292 : !---------------------------- Begin Code ----------------------------
1293 :
1294 32652 : select case( solve_type )
1295 : case ( mono_flux_rtm )
1296 3252 : solve_type_str = "rtm"
1297 : case ( mono_flux_thlm )
1298 13704 : solve_type_str = "thlm"
1299 : case default
1300 29400 : solve_type_str = "scalars"
1301 : end select
1302 :
1303 : ! Solve for xm at timestep index (t+1) using the tridiagonal solver.
1304 : call tridiag_solve( solve_type_str, tridiag_solve_method, & ! Intent(in)
1305 : ngrdcol, nz, & ! Intent(in)
1306 : lhs, rhs, & ! Intent(inout)
1307 29400 : xm ) ! Intent(out)
1308 :
1309 : ! Check for errors
1310 29400 : if ( clubb_at_least_debug_level( 0 ) ) then
1311 29400 : if ( err_code == clubb_fatal_error ) then
1312 : return
1313 : end if
1314 : end if
1315 :
1316 : ! Boundary condition on xm
1317 : !$acc parallel loop gang vector default(present)
1318 492120 : do i = 1, ngrdcol
1319 492120 : xm(i,1) = xm(i,2)
1320 : end do
1321 : !$acc end parallel loop
1322 :
1323 : return
1324 : end subroutine mfl_xm_solve
1325 :
1326 : !=============================================================================
1327 352944 : subroutine calc_turb_adv_range( nz, ngrdcol, gr, dt, &
1328 352944 : w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, &
1329 352944 : mixt_frac_zm, &
1330 : stats_metadata, &
1331 352944 : stats_zm, &
1332 352944 : low_lev_effect, high_lev_effect )
1333 :
1334 : ! Description:
1335 : ! Calculates the lowermost and uppermost thermodynamic grid levels that can
1336 : ! effect the base (or central) thermodynamic level through the effects of
1337 : ! turbulent advection over the course of one time step. This is used as
1338 : ! part of the monotonic turbulent advection scheme.
1339 : !
1340 : ! One method is to use the vertical velocity at each level to determine the
1341 : ! amount of time that it takes to travel across that particular grid level.
1342 : ! The method is to keep on advancing one grid level until either (a) the
1343 : ! total sum of time taken reaches or exceeds the model time step length,
1344 : ! (b) the top or bottom of the model is reached, or (c) a level is reached
1345 : ! where the vertical velocity component (with turbulence included) is
1346 : ! oriented completely opposite of the direction of travel towards the base
1347 : ! (or central) thermodynamic level. An example of situation (c) would be,
1348 : ! while starting from a higher altitude and searching downward for all
1349 : ! upward vertical velocity components, encountering a strong downdraft
1350 : ! where the vertical velocity at every single point is oriented downward.
1351 : ! Such a situation would occur when the mean vertical velocity (wm_zm)
1352 : ! exceeds any turbulent component (w') that would be oriented upwards.
1353 : !
1354 : ! Another method is to simply set the thickness (in meters) of the layer
1355 : ! that turbulent advection is allowed to act over, for purposes of the
1356 : ! monotonic turbulent advection scheme. The lowermost and uppermost
1357 : ! grid level that can effect the base (or central) thermodynamic level
1358 : ! is computed based on the thickness and altitude of each level.
1359 :
1360 : ! References:
1361 : !-----------------------------------------------------------------------
1362 :
1363 : use grid_class, only: &
1364 : grid ! Type
1365 :
1366 : use clubb_precision, only: &
1367 : core_rknd ! Variable(s)
1368 :
1369 : use stats_type, only: &
1370 : stats ! Type
1371 :
1372 : use stats_variables, only: &
1373 : stats_metadata_type
1374 :
1375 : implicit none
1376 :
1377 : ! Constant parameters
1378 : logical, parameter :: &
1379 : l_constant_thickness = .false. ! Toggle constant or variable thickness.
1380 :
1381 : real( kind = core_rknd ), parameter :: &
1382 : const_thick = 150.0_core_rknd ! Constant thickness value [m]
1383 :
1384 : !------------------------- Input Variables -------------------------
1385 : integer, intent(in) :: &
1386 : nz, &
1387 : ngrdcol
1388 :
1389 : type (grid), target, intent(in) :: gr
1390 :
1391 : real( kind = core_rknd ), intent(in) :: &
1392 : dt ! Model timestep length [s]
1393 :
1394 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
1395 : w_1_zm, & ! Mean w (1st PDF component) [m/s]
1396 : w_2_zm, & ! Mean w (2nd PDF component) [m/s]
1397 : varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2]
1398 : varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2]
1399 : mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-]
1400 :
1401 : type (stats_metadata_type), intent(in) :: &
1402 : stats_metadata
1403 :
1404 : !------------------------- Inout Variables -------------------------
1405 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
1406 : stats_zm
1407 :
1408 : !------------------------- Output Variables -------------------------
1409 : integer, dimension(ngrdcol,nz), intent(out) :: &
1410 : low_lev_effect, & ! Index of lowest level that has an effect (for lev. k)
1411 : high_lev_effect ! Index of highest level that has an effect (for lev. k)
1412 :
1413 : !------------------------- Local Variables -------------------------
1414 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
1415 705888 : vert_vel_up, & ! Average upwards vertical velocity component [m/s]
1416 705888 : vert_vel_down, & ! Average downwards vertical velocity component [m/s]
1417 705888 : w_min ! Minimum velocity to affect adjacent levels [m/s]
1418 :
1419 : real(kind = core_rknd ) :: &
1420 : dt_one_grid_lev, & ! Amount of time to travel one grid box [s]
1421 : dt_all_grid_levs, & ! Running count of amount of time taken to travel [s]
1422 : invrs_dt ! Inverse of timestep, used to reduce divides [1/s]
1423 :
1424 : integer :: k, i, j
1425 :
1426 : !------------------------- Begin Code -------------------------
1427 :
1428 : !$acc enter data create( vert_vel_up, vert_vel_down, w_min )
1429 :
1430 : if ( l_constant_thickness ) then ! thickness is a constant value.
1431 :
1432 : ! The value of w'x' may only be altered between levels 3 and gr%nz-2.
1433 : do k = 3, nz-2, 1
1434 : do i = 1, ngrdcol
1435 :
1436 : ! Compute the number of levels that effect the central thermodynamic
1437 : ! level through upwards motion (traveling from lower levels to reach
1438 : ! the central thermodynamic level).
1439 :
1440 : ! Start with the index of the thermodynamic level immediately below
1441 : ! the central thermodynamic level.
1442 : j = k - 1
1443 :
1444 : do ! loop downwards until answer is found.
1445 :
1446 : if ( gr%zt(i,k) - gr%zt(i,j) >= const_thick ) then
1447 :
1448 : ! Stop, the current grid level is the lowest level that can
1449 : ! be considered.
1450 : low_lev_effect(i,k) = j
1451 :
1452 : exit
1453 :
1454 : else
1455 :
1456 : ! Thermodynamic level 1 cannot be considered because it is
1457 : ! located below the surface or below the bottom of the model.
1458 : ! The lowest level that can be considered is thermodynamic
1459 : ! level 2.
1460 : if ( j == 2 ) then
1461 :
1462 : ! The current level (level 2) is the lowest level that can
1463 : ! be considered.
1464 : low_lev_effect(i,k) = j
1465 :
1466 : exit
1467 :
1468 : else
1469 :
1470 : ! Increment to the next vertical level down.
1471 : j = j - 1
1472 :
1473 : end if
1474 :
1475 : end if
1476 :
1477 : end do ! downwards loop
1478 :
1479 : end do
1480 : end do ! k = 3, gr%nz-2
1481 :
1482 : ! Compute the number of levels that effect the central thermodynamic
1483 : ! level through downwards motion (traveling from higher levels to
1484 : ! reach the central thermodynamic level).
1485 :
1486 : do k = 3, nz-2, 1
1487 : do i = 1, ngrdcol
1488 :
1489 : ! Start with the index of the thermodynamic level immediately above
1490 : ! the central thermodynamic level.
1491 : j = k + 1
1492 :
1493 : do ! loop upwards until answer is found.
1494 :
1495 : if ( gr%zt(i,j) - gr%zt(i,k) >= const_thick ) then
1496 :
1497 : ! Stop, the current grid level is the highest level that can
1498 : ! be considered.
1499 : high_lev_effect(i,k) = j
1500 :
1501 : exit
1502 :
1503 : else
1504 :
1505 : ! The highest level that can be considered is thermodynamic
1506 : ! level gr%nz.
1507 : if ( j == nz ) then
1508 :
1509 : ! The current level (level gr%nz) is the highest level
1510 : ! that can be considered.
1511 : high_lev_effect(i,k) = j
1512 :
1513 : exit
1514 :
1515 : else
1516 :
1517 : ! Increment to the next vertical level up.
1518 : j = j + 1
1519 :
1520 : end if
1521 :
1522 : end if
1523 :
1524 : end do ! upwards loop
1525 :
1526 : end do
1527 : end do ! k = 3, gr%nz-2
1528 :
1529 : else ! thickness based on vertical velocity and time step length.
1530 :
1531 352944 : invrs_dt = 1.0_core_rknd / dt
1532 :
1533 : !$acc parallel loop gang vector collapse(2) default(present)
1534 30353184 : do k = 1, nz
1535 501287184 : do i = 1, ngrdcol
1536 500934240 : w_min(i,k) = gr%dzm(i,k) * invrs_dt
1537 : end do
1538 : end do
1539 : !$acc end parallel loop
1540 :
1541 : ! Find the average upwards vertical velocity and the average downwards
1542 : ! vertical velocity.
1543 : ! Note: A level that has all vertical wind moving downwards will have a
1544 : ! vert_vel_up value that is 0, and vice versa.
1545 : call mean_vert_vel_up_down( nz, ngrdcol, &
1546 : w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! In
1547 : mixt_frac_zm, 0.0_core_rknd, w_min, & ! In
1548 : stats_metadata, & ! In
1549 : stats_zm, & ! intent(inout)
1550 352944 : vert_vel_down, vert_vel_up ) ! intent(out)
1551 :
1552 : ! The value of w'x' may only be altered between levels 3 and gr%nz-2.
1553 : !$acc parallel loop gang vector collapse(2) default(present)
1554 28941408 : do k = 3, nz-2, 1
1555 477713808 : do i = 1, ngrdcol
1556 :
1557 : ! Compute the number of levels that effect the central thermodynamic
1558 : ! level through upwards motion (traveling from lower levels to reach
1559 : ! the central thermodynamic level).
1560 :
1561 : ! Initialize the overall delta t counter to 0.
1562 448772400 : dt_all_grid_levs = 0.0_core_rknd
1563 :
1564 : ! Start with the index of the thermodynamic level immediately below
1565 : ! the central thermodynamic level.
1566 486772754 : do j = k-1, 2, -1
1567 :
1568 455208033 : low_lev_effect(i,k) = j
1569 :
1570 : ! Continue if there is some component of upwards vertical velocity.
1571 504435325 : if ( vert_vel_up(i,j) > 0.0_core_rknd ) then
1572 :
1573 : ! Compute the amount of time it takes to travel one grid level
1574 : ! upwards: delta_t = delta_z / vert_vel_up.
1575 55662925 : dt_one_grid_lev = gr%dzm(i,j) / vert_vel_up(i,j)
1576 :
1577 :
1578 : ! Total time elapsed for crossing all grid levels that have been
1579 : ! passed, thus far.
1580 55662925 : dt_all_grid_levs = dt_all_grid_levs + dt_one_grid_lev
1581 :
1582 : ! Stop if has taken more than one model time step (overall) to
1583 : ! travel the entire extent of the current vertical grid level.
1584 55662925 : if ( dt_all_grid_levs >= dt ) then
1585 :
1586 : ! The current level is the lowest level that can be
1587 : ! considered.
1588 : exit
1589 :
1590 : endif
1591 :
1592 : ! Stop if there isn't a component of upwards vertical velocity.
1593 : else
1594 :
1595 : ! The current level cannot be considered. The lowest level that
1596 : ! can be considered is one-level-above the current level.
1597 399545108 : low_lev_effect(i,k) = j + 1
1598 :
1599 399545108 : exit
1600 :
1601 : endif
1602 :
1603 : enddo ! downwards loop
1604 :
1605 : end do
1606 : enddo ! k = 3, gr%nz-2
1607 : !$acc end parallel loop
1608 :
1609 :
1610 : ! Compute the number of levels that effect the central thermodynamic
1611 : ! level through downwards motion (traveling from higher levels to
1612 : ! reach the central thermodynamic level).
1613 :
1614 : !$acc parallel loop gang vector collapse(2) default(present)
1615 28941408 : do k = 3, nz-2, 1
1616 477713808 : do i = 1, ngrdcol
1617 :
1618 : ! Initialize the overall delta t counter to 0.
1619 448772400 : dt_all_grid_levs = 0.0_core_rknd
1620 :
1621 : ! Start with the index of the thermodynamic level immediately above
1622 : ! the central thermodynamic level.
1623 483293202 : do j = k+1, nz
1624 :
1625 454703461 : high_lev_effect(i,k) = j
1626 :
1627 : ! Continue if there is some component of downwards vertical velocity.
1628 490894177 : if ( vert_vel_down(i,j-1) < 0.0_core_rknd ) then
1629 :
1630 : ! Compute the amount of time it takes to travel one grid level
1631 : ! downwards: delta_t = - delta_z / vert_vel_down.
1632 : ! Note: There is a (-) sign in front of delta_z because the
1633 : ! distance traveled is downwards. Since vert_vel_down
1634 : ! has a negative value, dt_one_grid_lev will be a
1635 : ! positive value.
1636 42121777 : dt_one_grid_lev = -gr%dzm(i,j-1) / vert_vel_down(i,j-1)
1637 :
1638 : ! Total time elapsed for crossing all grid levels that have been
1639 : ! passed, thus far.
1640 42121777 : dt_all_grid_levs = dt_all_grid_levs + dt_one_grid_lev
1641 :
1642 : ! Stop if has taken more than one model time step (overall) to
1643 : ! travel the entire extent of the current vertical grid level.
1644 42121777 : if ( dt_all_grid_levs >= dt ) then
1645 :
1646 : ! The current level is the highest level that can be
1647 : ! considered.
1648 : exit
1649 :
1650 : endif
1651 :
1652 : ! Stop if there isn't a component of downwards vertical velocity.
1653 : else
1654 :
1655 : ! The current level cannot be considered. The highest level
1656 : ! that can be considered is one-level-below the current level.
1657 412581684 : high_lev_effect(i,k) = j - 1
1658 :
1659 412581684 : exit
1660 :
1661 : end if
1662 :
1663 : end do ! upwards loop
1664 :
1665 : end do
1666 : enddo ! k = 3, gr%nz-2
1667 : !$acc end parallel loop
1668 :
1669 : end if ! l_constant_thickness
1670 :
1671 :
1672 : ! Information for levels 1, 2, gr%nz-1, and gr%nz is not needed.
1673 : ! However, set the values at these levels for purposes of not having odd
1674 : ! values in the arrays.
1675 : !$acc parallel loop gang vector default(present)
1676 5893344 : do i = 1, ngrdcol
1677 5540400 : low_lev_effect(i,1) = 1
1678 5540400 : high_lev_effect(i,1) = 1
1679 5540400 : low_lev_effect(i,2) = 2
1680 5540400 : high_lev_effect(i,2) = 2
1681 5540400 : low_lev_effect(i,nz-1) = nz-1
1682 5540400 : high_lev_effect(i,nz-1) = nz
1683 5540400 : low_lev_effect(i,nz) = nz
1684 5893344 : high_lev_effect(i,nz) = nz
1685 : end do
1686 : !$acc end parallel loop
1687 :
1688 : !$acc exit data delete( vert_vel_up, vert_vel_down, w_min )
1689 :
1690 352944 : return
1691 :
1692 : end subroutine calc_turb_adv_range
1693 :
1694 : !=============================================================================
1695 352944 : subroutine mean_vert_vel_up_down( nz, ngrdcol, &
1696 352944 : w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, &
1697 352944 : mixt_frac_zm, w_ref, w_min, &
1698 : stats_metadata, &
1699 352944 : stats_zm, &
1700 352944 : mean_w_down, mean_w_up )
1701 :
1702 : ! Description
1703 : ! The values of vertical velocity, along a horizontal plane at any given
1704 : ! vertical level, are not allowed by CLUBB to be uniform. In other words,
1705 : ! there must be some variance in vertical velocity. This subroutine
1706 : ! calculates the mean of all values of vertical velocity, at any given
1707 : ! vertical level, that are greater than a certain reference velocity. This
1708 : ! subroutine also calculates the mean of all values of vertical velocity, at
1709 : ! any given vertical level, that are less than a certain reference velocity.
1710 : ! The reference velocity is usually 0 m/s, in which case this subroutine
1711 : ! calculates the average positive (upward) velocity and the average negative
1712 : ! (downward) velocity. However, the reference velocity may be other values,
1713 : ! such as wm_zm, which is the overall mean vertical velocity. If the
1714 : ! reference velocity is wm_zm, this subroutine calculates the average of all
1715 : ! values of w that are on the positive ("upward") side of the mean and the
1716 : ! average of all values of w that are on the negative ("downward") side of
1717 : ! the mean. These mean positive and negative vertical velocities are useful
1718 : ! in determining how long, on average, it takes a parcel of air, being
1719 : ! driven by subgrid updrafts or downdrafts, to traverse the length of the
1720 : ! vertical grid level.
1721 : !
1722 : ! Method
1723 : ! ------
1724 : !
1725 : ! The CLUBB model uses a joint PDF of vertical velocity, liquid water
1726 : ! potential temperature, and total water mixing ratio to determine subgrid
1727 : ! variability.
1728 : !
1729 : ! The values of vertical velocity, w, along an undefined horizontal plane
1730 : ! at any vertical level, are considered to approximately follow a
1731 : ! distribution that is a mixture of two normal (or Gaussian) distributions.
1732 : ! The values of w that are a part of the 1st normal distribution are
1733 : ! referred to as w_1, and the values of w that are part of the 2nd normal
1734 : ! distribution are referred to as w_2. Note that these distributions
1735 : ! overlap, and there are many values of w that are found in both w_1 and w_2.
1736 : !
1737 : ! The probability density function (PDF) for w, P(w), is:
1738 : !
1739 : ! P(w) = mixt_frac*P(w_1) + (1-mixt_frac)*P(w_2);
1740 : !
1741 : ! where "mixt_frac" is the weight of the 1st normal distribution, and P(w_1) and
1742 : ! P(w_2) are the equations for the 1st and 2nd normal distributions,
1743 : ! respectively:
1744 : !
1745 : ! P(w_1) = 1 / ( sigma_w_1 * sqrt(2*PI) )
1746 : ! * EXP[ -(w_1-mu_w_1)^2 / (2*sigma_w_1^2) ]; and
1747 : !
1748 : ! P(w_2) = 1 / ( sigma_w_2 * sqrt(2*PI) )
1749 : ! * EXP[ -(w_2-mu_w_2)^2 / (2*sigma_w_2^2) ].
1750 : !
1751 : ! The mean of the 1st normal distribution is mu_w_1, and the standard
1752 : ! deviation of the 1st normal distribution is sigma_w_1. The mean of the
1753 : ! 2nd normal distribution is mu_w_2, and the standard deviation of the 2nd
1754 : ! normal distribution is sigma_w_2.
1755 : !
1756 : ! The average value of w, distributed according to the probability
1757 : ! distribution, between limits alpha and beta, is:
1758 : !
1759 : ! <w|_(alpha:beta)> = INT(alpha:beta) w P(w) dw.
1760 : !
1761 : ! The average value of w over a certain domain is used to determine the
1762 : ! average positive and negative (as compared to the reference velocity)
1763 : ! values of w at any vertical level.
1764 : !
1765 : ! Average Negative Vertical Velocity
1766 : ! ----------------------------------
1767 : !
1768 : ! The average of all values of w in the distribution that are below the
1769 : ! reference velocity, w|_ref, is the mean value of w over the domain
1770 : ! -inf <= w <= w|_ref, such that:
1771 : !
1772 : ! <w|_(-inf:w|_ref)> = INT(-inf:w|_ref) w P(w) dw.
1773 : ! = mixt_frac * INT(-inf:w|_ref) w_1 P(w_1) dw_1
1774 : ! + (1-mixt_frac) * INT(-inf:w|_ref) w_2 P(w_2) dw_2.
1775 : !
1776 : ! For each normal distribution in the mixture of normal distribution, i
1777 : ! (where "i" can be 1 or 2):
1778 : !
1779 : ! INT(-inf:w|_ref) wi P(wi) dwi =
1780 : ! - ( sigma_wi / sqrt(2*PI) ) * EXP[ -(w|_ref-mu_wi)^2 / (2*sigma_wi^2) ]
1781 : ! + mu_wi * (1/2)*[ 1 + erf( (w|_ref-mu_wi) / (sqrt(2)*sigma_wi) ) ];
1782 : !
1783 : ! where mu_wi is the mean of w for the ith normal distribution, sigma_wi is
1784 : ! the standard deviations of w for the ith normal distribution, and erf( )
1785 : ! is the error function.
1786 : !
1787 : ! The mean of all values of w <= w|_ref is:
1788 : !
1789 : ! <w|_(-inf:w|_ref)> =
1790 : ! mixt_frac * { - ( sigma_w_1 / sqrt(2*PI) )
1791 : ! * EXP[ -(w|_ref-mu_w_1)^2 / (2*sigma_w_1^2) ]
1792 : ! + mu_w_1 * (1/2)
1793 : ! *[1 + erf( (w|_ref-mu_w_1) / (sqrt(2)*sigma_w_1) )] }
1794 : ! + (1-mixt_frac) * { - ( sigma_w_2 / sqrt(2*PI) )
1795 : ! * EXP[ -(w|_ref-mu_w_2)^2 / (2*sigma_w_2^2) ]
1796 : ! + mu_w_2 * (1/2)
1797 : ! *[1 + erf( (w|_ref-mu_w_2) / (sqrt(2)*sigma_w_2) )] }.
1798 : !
1799 : ! Average Positive Vertical Velocity
1800 : ! ----------------------------------
1801 : !
1802 : ! The average of all values of w in the distribution that are above the
1803 : ! reference velocity, w|_ref, is the mean value of w over the domain
1804 : ! w|_ref <= w <= inf, such that:
1805 : !
1806 : ! <w|_(w|_ref:inf)> = INT(w|_ref:inf) w P(w) dw.
1807 : ! = mixt_frac * INT(w|_ref:inf) w_1 P(w_1) dw_1
1808 : ! + (1-mixt_frac) * INT(w|_ref:inf) w_2 P(w_2) dw_2.
1809 : !
1810 : ! For each normal distribution in the mixture of normal distribution, i
1811 : ! (where "i" can be 1 or 2):
1812 : !
1813 : ! INT(w|_ref:inf) wi P(wi) dwi =
1814 : ! ( sigma_wi / sqrt(2*PI) ) * EXP[ -(w|_ref-mu_wi)^2 / (2*sigma_wi^2) ]
1815 : ! + mu_wi * (1/2)*[ 1 - erf( (w|_ref-mu_wi) / (sqrt(2)*sigma_wi) ) ];
1816 : !
1817 : ! where mu_wi is the mean of w for the ith normal distribution, sigma_wi is
1818 : ! the standard deviations of w for the ith normal distribution, and erf( )
1819 : ! is the error function.
1820 : !
1821 : ! The mean of all values of w >= w|_ref is:
1822 : !
1823 : ! <w|_(w|_ref:inf)> =
1824 : ! mixt_frac * { ( sigma_w_1 / sqrt(2*PI) )
1825 : ! * EXP[ -(w|_ref-mu_w_1)^2 / (2*sigma_w_1^2) ]
1826 : ! + mu_w_1 * (1/2)
1827 : ! *[1 - erf( (w|_ref-mu_w_1) / (sqrt(2)*sigma_w_1) )] }
1828 : ! + (1-mixt_frac) * { ( sigma_w_2 / sqrt(2*PI) )
1829 : ! * EXP[ -(w|_ref-mu_w_2)^2 / (2*sigma_w_2^2) ]
1830 : ! + mu_w_2 * (1/2)
1831 : ! *[1 - erf( (w|_ref-mu_w_2) / (sqrt(2)*sigma_w_2) )] }.
1832 : !
1833 : ! Special Limitations:
1834 : ! --------------------
1835 : !
1836 : ! A normal distribution has a domain from -inf to inf. However, the mixture
1837 : ! of normal distributions is an approximation of the distribution of values
1838 : ! of w along a horizontal plane at any given vertical level. Vertical
1839 : ! velocity, w, has absolute minimum and maximum values (that cannot be
1840 : ! predicted by the PDF). The absolute maximum and minimum for each normal
1841 : ! distribution is most likely found within 2 or 3 standard deviations of the
1842 : ! mean for the relevant normal distribution. In other words, for each
1843 : ! normal distribution in the mixture of normal distributions, all the values
1844 : ! of w are found within 2 or 3 standard deviations on both sides of the
1845 : ! mean. Therefore, if one (or both) of the normal distributions has a mean
1846 : ! that is more than 3 standard deviations away from the reference velocity,
1847 : ! then that entire w distribution is found on ONE side of the reference
1848 : ! velocity.
1849 : !
1850 : ! Therefore:
1851 : !
1852 : ! a) where mu_wi + 3*sigma_wi <= w|_ref:
1853 : !
1854 : ! The entire ith normal distribution of w is on the negative side of
1855 : ! w|_ref; and
1856 : !
1857 : ! INT(-inf:w|_ref) wi P(wi) dwi = mu_wi; and
1858 : ! INT(inf:w|_ref) wi P(wi) dwi = 0.
1859 : !
1860 : ! b) where mu_wi - 3*sigma_wi >= w|_ref:
1861 : !
1862 : ! The entire ith normal distribution of w is on the positive side of
1863 : ! w|_ref; and
1864 : !
1865 : ! INT(-inf:w|_ref) wi P(wi) dwi = 0; and
1866 : ! INT(inf:w|_ref) wi P(wi) dwi = mu_wi.
1867 : !
1868 : ! Notes: A value of 3 standard deviations above and below the mean of the
1869 : ! ith normal distribution was chosen for the approximate maximum and
1870 : ! minimum values of the ith normal distribution because 99.7% of
1871 : ! values in a normal distribution are found within 3 standard
1872 : ! deviations from the mean (compared to 95.4% for 2 standard
1873 : ! deviations). The value of 3 standard deviations provides for a
1874 : ! reasonable estimate of the absolute maximum and minimum of w, while
1875 : ! covering a great majority of the normal distribution.
1876 : !
1877 : ! In addition to approximating the up and down components of w
1878 : ! by checking if the pdfs are greater than 3 standard deviations
1879 : ! from the mean, there is now a case to approximate when w is
1880 : ! too small in general. The input array, w_min, contains the
1881 : ! minimum values of vertical velocity that would be required
1882 : ! at a given grid level for that grid box to be able to affect
1883 : ! the adjacent levels. If the magnitude of w at a given level
1884 : ! is less than 3 standard deviations below w_min for that level,
1885 : ! then there is no significant portion of the air from that grid
1886 : ! box that is capable of interacting with the next level, and
1887 : ! the upward and downward components for that pdf are set to 0.
1888 : !
1889 : ! References:
1890 : !-----------------------------------------------------------------------
1891 :
1892 : use grid_class, only: &
1893 : grid ! Type
1894 :
1895 : use stats_type_utilities, only: &
1896 : stat_update_var ! Procedure(s)
1897 :
1898 : use stats_variables, only: &
1899 : stats_metadata_type
1900 :
1901 : use clubb_precision, only: &
1902 : core_rknd ! Variable(s)
1903 :
1904 : use stats_type, only: stats ! Type
1905 :
1906 : implicit none
1907 :
1908 : !------------------------- Input Variables -------------------------
1909 : integer, intent(in) :: &
1910 : nz, &
1911 : ngrdcol
1912 :
1913 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
1914 : w_1_zm, & ! Mean w (1st PDF component) [m/s]
1915 : w_2_zm, & ! Mean w (2nd PDF component) [m/s]
1916 : varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2]
1917 : varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2]
1918 : mixt_frac_zm, & ! Weight of 1st PDF component (Sk_w dependent) [-]
1919 : w_min ! Minimum velocity to affect adjacent level [m/s]
1920 :
1921 : real( kind = core_rknd ), intent(in) :: &
1922 : w_ref ! Reference velocity, w|_ref (normally = 0) [m/s]
1923 :
1924 : type (stats_metadata_type), intent(in) :: &
1925 : stats_metadata
1926 :
1927 : !------------------------- Inout Variables -------------------------
1928 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
1929 : stats_zm
1930 :
1931 : !------------------------- Output Variables -------------------------
1932 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
1933 : mean_w_down, & ! Overall mean w (<= w|_ref) [m/s]
1934 : mean_w_up ! Overall mean w (>= w|_ref) [m/s]
1935 :
1936 : !------------------------- Local Variables -------------------------
1937 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
1938 705888 : mean_w_down_1st, & ! Mean w (<= w|_ref) from 1st normal distribution [m/s]
1939 705888 : mean_w_down_2nd, & ! Mean w (<= w|_ref) from 2nd normal distribution [m/s]
1940 705888 : mean_w_up_1st, & ! Mean w (>= w|_ref) from 1st normal distribution [m/s]
1941 705888 : mean_w_up_2nd ! Mean w (>= w|_ref) from 2nd normal distribution [m/s]
1942 :
1943 : integer :: i, k
1944 :
1945 : !------------------------- Begin Code -------------------------
1946 :
1947 : !$acc enter data create( mean_w_down_1st, mean_w_down_2nd, mean_w_up_1st, mean_w_up_2nd )
1948 :
1949 : call calc_mean_w_up_down_component( nz, ngrdcol, & ! intent(in)
1950 : w_1_zm, varnce_w_1_zm, & ! intent(in)
1951 : w_ref, w_min, & ! intent(in)
1952 352944 : mean_w_down_1st, mean_w_up_1st ) ! intent(out)
1953 :
1954 : call calc_mean_w_up_down_component( nz, ngrdcol, & ! intent(in)
1955 : w_2_zm, varnce_w_2_zm, & ! intent(in)
1956 : w_ref, w_min, & ! intent(in)
1957 352944 : mean_w_down_2nd, mean_w_up_2nd ) ! intent(out)
1958 :
1959 : ! Overall mean of downwards w.
1960 : !$acc parallel loop gang vector collapse(2) default(present)
1961 30353184 : do k = 1, nz
1962 501287184 : do i = 1, ngrdcol
1963 941868000 : mean_w_down(i,k) = mixt_frac_zm(i,k) * mean_w_down_1st(i,k) &
1964 1442802240 : + ( 1.0_core_rknd - mixt_frac_zm(i,k) ) * mean_w_down_2nd(i,k)
1965 : end do
1966 : end do
1967 : !$acc end parallel loop
1968 :
1969 : ! Overall mean of upwards w.
1970 : !$acc parallel loop gang vector collapse(2) default(present)
1971 30353184 : do k = 1, nz
1972 501287184 : do i = 1, ngrdcol
1973 941868000 : mean_w_up(i,k) = mixt_frac_zm(i,k) * mean_w_up_1st(i,k) &
1974 1442802240 : + ( 1.0_core_rknd - mixt_frac_zm(i,k) ) * mean_w_up_2nd(i,k)
1975 : end do
1976 : end do
1977 : !$acc end parallel loop
1978 :
1979 352944 : if ( stats_metadata%l_stats_samp ) then
1980 : !$acc update host( mean_w_up, mean_w_down )
1981 0 : do i = 1, ngrdcol
1982 0 : call stat_update_var( stats_metadata%imean_w_up, mean_w_up(i,:), & ! intent(in)
1983 0 : stats_zm(i) ) ! intent(inout)
1984 :
1985 : call stat_update_var( stats_metadata%imean_w_down, mean_w_down(i,:), & ! intent(in)
1986 0 : stats_zm(i) ) ! intent(inout)
1987 : end do
1988 : end if ! stats_metadata%l_stats_samp
1989 :
1990 : !$acc exit data delete( mean_w_down_1st, mean_w_down_2nd, mean_w_up_1st, mean_w_up_2nd )
1991 :
1992 352944 : return
1993 :
1994 : end subroutine mean_vert_vel_up_down
1995 :
1996 : !=============================================================================
1997 705888 : subroutine calc_mean_w_up_down_component( nz, ngrdcol, &
1998 705888 : w_i_zm, varnce_w_i, &
1999 705888 : w_ref, w_min, &
2000 705888 : mean_w_down_i, mean_w_up_i )
2001 :
2002 : ! Description: This procedure is used to split the PDF component of
2003 : ! vertical velocity into upward and downward components.
2004 : !
2005 : ! The method used is described in the description of
2006 : ! mean_vert_vel_up_down, which calls this function.
2007 : !
2008 : ! Notes: The calculation has been updated to optionally use intel's
2009 : ! mkl_vml functions to allow vectorized calculations. Not all
2010 : ! grid levels require expensive calculations though, so the
2011 : ! strategy is as follows
2012 : ! 1. Keep track of which levels do need the calculation
2013 : ! 2. Store those the relavent values from those levels in
2014 : ! a contigous array
2015 : ! 3. Perform vectorized calculation on contiguous arrays
2016 : ! using mkl_vml functions
2017 : ! 4. Unpack results from contiguous array into output array
2018 : ! Enabling this faster version requires compilation with MKL, by
2019 : ! using -DMKL as a compiler flag
2020 : !
2021 : !-----------------------------------------------------------------------
2022 :
2023 : use grid_class, only: &
2024 : grid ! Type
2025 :
2026 : use constants_clubb, only: &
2027 : sqrt_2pi, & ! Constant(s)
2028 : sqrt_2, &
2029 : one
2030 : #ifdef MKL
2031 : use constants_clubb, only: &
2032 : one_half ! Constant(s)
2033 : #endif
2034 :
2035 : use clubb_precision, only: &
2036 : core_rknd ! Variable(s)
2037 :
2038 : implicit none
2039 :
2040 : integer, intent(in) :: &
2041 : nz, &
2042 : ngrdcol
2043 :
2044 : !------------------------- Input Variables -------------------------
2045 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
2046 : w_i_zm, & ! Mean of w [m/s]
2047 : varnce_w_i, & ! Variance of w [m^2/s^2]
2048 : w_min ! Minimum velocity required to affect adjacent level [m/s]
2049 :
2050 : real( kind = core_rknd ), intent(in) :: &
2051 : w_ref ! Reference velocity, w|_ref (normally = 0) [m/s]
2052 :
2053 : !------------------------- Output Variables -------------------------
2054 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
2055 : mean_w_down_i, & ! Mean w (<= w|_ref) from normal distribution [m/s]
2056 : mean_w_up_i ! Mean w (>= w|_ref) from normal distribution [m/s]
2057 :
2058 : !------------------------- Local Variables -------------------------
2059 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
2060 1411776 : erf_cache, & ! erf/cdfnorm values
2061 1411776 : exp_cache ! exp() values
2062 :
2063 : real( kind = core_rknd ) :: &
2064 : sigma_w_i, & ! Variance of w (1st PDF component) [m^2/s^2]
2065 : invrs_sqrt_2pi ! The inverse of sqrt(2*pi), calculated to save divide operations
2066 :
2067 : integer :: i, k ! Vertical loop index
2068 :
2069 : !------------------------- Begin Code -------------------------
2070 :
2071 : !$acc enter data create( erf_cache, exp_cache )
2072 :
2073 705888 : invrs_sqrt_2pi = one / sqrt_2pi
2074 :
2075 : ! Loop over momentum levels from 2 to nz-1. Levels 1 and nz
2076 : ! are not needed.
2077 : !$acc parallel loop gang vector collapse(2) default(present)
2078 59294592 : do k = 2, nz-1
2079 979000992 : do i = 1, ngrdcol
2080 :
2081 : ! Standard deviation of w for the normal distribution.
2082 919706400 : sigma_w_i = sqrt( varnce_w_i(i,k) )
2083 :
2084 978295104 : if( abs( w_i_zm(i,k) ) + 3.0_core_rknd*sigma_w_i <= w_min(i,k) ) then
2085 :
2086 : ! The entire normal is too weak to affect adjacent grid levels
2087 : ! w is considered to be 0 in both up and down directions
2088 829270123 : mean_w_down_i(i,k) = 0.0_core_rknd
2089 829270123 : mean_w_up_i(i,k) = 0.0_core_rknd
2090 :
2091 90436277 : elseif ( w_i_zm(i,k) + 3._core_rknd*sigma_w_i <= w_ref ) then
2092 :
2093 : ! The entire normal is on the negative side of w|_ref.
2094 172741 : mean_w_down_i(i,k) = w_i_zm(i,k)
2095 172741 : mean_w_up_i(i,k) = 0.0_core_rknd
2096 :
2097 90263536 : elseif ( w_i_zm(i,k) - 3._core_rknd*sigma_w_i >= w_ref ) then
2098 :
2099 : ! The entire normal is on the positive side of w|_ref.
2100 11295947 : mean_w_down_i(i,k) = 0.0_core_rknd
2101 11295947 : mean_w_up_i(i,k) = w_i_zm(i,k)
2102 :
2103 : else ! The normal has significant values on both sides of w_ref.
2104 :
2105 : ! MKL functions are unavailable, use these scalar calculations instead
2106 :
2107 78967589 : exp_cache(i,k) = exp( -(w_ref-w_i_zm(i,k))**2 / (2.0_core_rknd*sigma_w_i**2) )
2108 :
2109 78967589 : erf_cache(i,k) = erf( (w_ref-w_i_zm(i,k)) / (sqrt_2*sigma_w_i ) )
2110 :
2111 : mean_w_down_i(i,k) = - sigma_w_i * invrs_sqrt_2pi * exp_cache(i,k) &
2112 78967589 : + w_i_zm(i,k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache(i,k))
2113 :
2114 : mean_w_up_i(i,k) = + sigma_w_i * invrs_sqrt_2pi * exp_cache(i,k) &
2115 78967589 : + w_i_zm(i,k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache(i,k))
2116 :
2117 : end if
2118 :
2119 : end do
2120 : end do ! k = 2, gr%nz
2121 : !$acc end parallel loop
2122 :
2123 : ! Upper and lower levels are not used, set to 0 to besafe and avoid NaN problems
2124 : !$acc parallel loop gang vector default(present)
2125 11786688 : do i = 1, ngrdcol
2126 11080800 : mean_w_down_i(i,1) = 0.0_core_rknd
2127 11080800 : mean_w_up_i(i,1) = 0.0_core_rknd
2128 :
2129 11080800 : mean_w_down_i(i,nz) = 0.0_core_rknd
2130 11786688 : mean_w_up_i(i,nz) = 0.0_core_rknd
2131 : end do
2132 : !$acc end parallel loop
2133 :
2134 : !$acc exit data delete( erf_cache, exp_cache )
2135 :
2136 705888 : return
2137 :
2138 : end subroutine calc_mean_w_up_down_component
2139 :
2140 : !===============================================================================
2141 :
2142 : end module mono_flux_limiter
|