Line data Source code
1 : !-----------------------------------------------------------------------
2 : ! $Id: mixing_length.F90 8664 2018-05-10 20:21:35Z huebler@uwm.edu $
3 : !===============================================================================
4 : module mixing_length
5 :
6 : implicit none
7 :
8 : private ! Default Scope
9 :
10 : public :: compute_mixing_length, &
11 : calc_Lscale_directly, &
12 : diagnose_Lscale_from_tau
13 :
14 : contains
15 :
16 : !=============================================================================
17 352944 : subroutine compute_mixing_length( nz, ngrdcol, gr, thvm, thlm, &
18 352944 : rtm, em, Lscale_max, p_in_Pa, &
19 352944 : exner, thv_ds, mu, lmin, l_implemented, &
20 : stats_metadata, &
21 352944 : Lscale, Lscale_up, Lscale_down )
22 :
23 : ! Description:
24 : ! Larson's 5th moist, nonlocal length scale
25 : !
26 : ! References:
27 : ! Section 3b ( /Eddy length formulation/ ) of
28 : ! ``A PDF-Based Model for Boundary Layer Clouds. Part I:
29 : ! Method and Model Description'' Golaz, et al. (2002)
30 : ! JAS, Vol. 59, pp. 3540--3551.
31 : !
32 : ! Notes:
33 : !
34 : ! The equation for the rate of change of theta_l and r_t of the parcel with
35 : ! respect to height, due to entrainment, is:
36 : !
37 : ! d(thl_par)/dz = - mu * ( thl_parcel - thl_environment );
38 : !
39 : ! d(rt_par)/dz = - mu * ( rt_parcel - rt_environment );
40 : !
41 : ! where mu is the entrainment rate,
42 : ! such that:
43 : !
44 : ! mu = (1/m)*(dm/dz);
45 : !
46 : ! where m is the mass of the parcel. The value of mu is set to be a
47 : ! constant.
48 : !
49 : ! The differential equations are solved for given the boundary condition
50 : ! and given the fact that the value of thl_environment and rt_environment
51 : ! are treated as changing linearly for a parcel of air from one grid level
52 : ! to the next.
53 : !
54 : ! For the special case where entrainment rate, mu, is set to 0,
55 : ! thl_parcel and rt_parcel remain constant
56 : !
57 : !
58 : ! The equation for Lscale_up is:
59 : !
60 : ! INT(z_i:z_i+Lscale_up) g * ( thv_par - thvm ) / thvm dz = -em(z_i);
61 : !
62 : ! and for Lscale_down
63 : !
64 : ! INT(z_i-Lscale_down:z_i) g * ( thv_par - thvm ) / thvm dz = em(z_i);
65 : !
66 : ! where thv_par is theta_v of the parcel, thvm is the mean
67 : ! environmental value of theta_v, z_i is the altitude that the parcel
68 : ! started from, and em is the mean value of TKE at
69 : ! altitude z_i (which gives the parcel its initial boost)
70 : !
71 : ! The increment of CAPE (convective air potential energy) for any two
72 : ! successive vertical levels is:
73 : !
74 : ! Upwards:
75 : ! CAPE_incr = INT(z_0:z_1) g * ( thv_par - thvm ) / thvm dz
76 : !
77 : ! Downwards:
78 : ! CAPE_incr = INT(z_(-1):z_0) g * ( thv_par - thvm ) / thvm dz
79 : !
80 : ! Thus, the derivative of CAPE with respect to height is:
81 : !
82 : ! dCAPE/dz = g * ( thv_par - thvm ) / thvm.
83 : !
84 : ! A purely trapezoidal rule is used between levels, and is considered
85 : ! to vary linearly at all altitudes. Thus, dCAPE/dz is considered to be
86 : ! of the form: A * (z-zo) + dCAPE/dz|_(z_0),
87 : ! where A = ( dCAPE/dz|_(z_1) - dCAPE/dz|_(z_0) ) / ( z_1 - z_0 )
88 : !
89 : ! The integral is evaluated to find the CAPE increment between two
90 : ! successive vertical levels. The result either adds to or depletes
91 : ! from the total amount of energy that keeps the parcel ascending/descending.
92 : !
93 : !
94 : ! IMPORTANT NOTE:
95 : ! This subroutine has been optimized by adding precalculations, rearranging
96 : ! equations to avoid divides, and modifying the algorithm entirely.
97 : ! -Gunther Huebler
98 : !
99 : ! The algorithm previously used looped over every grid level, following a
100 : ! a parcel up from its initial grid level to its max. The very nature of this
101 : ! algorithm is an N^2
102 : !--------------------------------------------------------------------------------
103 :
104 : ! mu = (1/M) dM/dz > 0. mu=0 for no entrainment.
105 : ! Siebesma recommends mu=2e-3, although most schemes use mu=1e-4
106 : ! When mu was fixed, we used the value mu = 6.e-4
107 :
108 : use constants_clubb, only: & ! Variable(s)
109 : Cp, & ! Dry air specific heat at constant pressure [J/kg/K]
110 : Rd, & ! Dry air gas constant [J/kg/K]
111 : ep, & ! Rd / Rv [-]
112 : ep1, & ! (1-ep)/ep [-]
113 : ep2, & ! 1/ep [-]
114 : Lv, & ! Latent heat of vaporiztion [J/kg/K]
115 : grav, & ! Gravitational acceleration [m/s^2]
116 : fstderr, &
117 : zero_threshold, &
118 : eps, &
119 : one_half, &
120 : one, &
121 : two, &
122 : zero
123 :
124 : use grid_class, only: &
125 : grid, & ! Type
126 : zm2zt ! Procedure(s)
127 :
128 : use numerical_check, only: &
129 : length_check ! Procedure(s)
130 :
131 : use clubb_precision, only: &
132 : core_rknd ! Variable(s)
133 :
134 : use error_code, only: &
135 : clubb_at_least_debug_level, & ! Procedure
136 : err_code, & ! Error Indicator
137 : clubb_fatal_error ! Constant
138 :
139 : use saturation, only: &
140 : sat_mixrat_liq ! Procedure(s)
141 :
142 : use stats_variables, only: &
143 : stats_metadata_type
144 :
145 : implicit none
146 :
147 : ! Constant Parameters
148 : real( kind = core_rknd ), parameter :: &
149 : zlmin = 0.1_core_rknd, & ! Minimum value for Lscale [m]
150 : Lscale_sfclyr_depth = 500._core_rknd ! [m]
151 :
152 : !--------------------------------- Input Variables ---------------------------------
153 : integer, intent(in) :: &
154 : nz, &
155 : ngrdcol
156 :
157 : type (grid), target, intent(in) :: &
158 : gr
159 :
160 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
161 : thvm, & ! Virtual potential temp. on themodynamic level [K]
162 : thlm, & ! Liquid potential temp. on themodynamic level [K]
163 : rtm, & ! Total water mixing ratio on themodynamic level [kg/kg]
164 : em, & ! em = 3/2 * w'^2; on momentum level [m^2/s^2]
165 : exner, & ! Exner function on thermodynamic level [-]
166 : p_in_Pa, & ! Pressure on thermodynamic level [Pa]
167 : thv_ds ! Dry, base-state theta_v on thermodynamic level [K]
168 : ! Note: thv_ds used as a reference theta_l here
169 :
170 : real( kind = core_rknd ), dimension(ngrdcol), intent(in) :: &
171 : Lscale_max ! Maximum allowable value for Lscale [m]
172 :
173 : real( kind = core_rknd ), dimension(ngrdcol), intent(in) :: &
174 : mu ! mu Fractional extrainment rate per unit altitude [1/m]
175 :
176 : real( kind = core_rknd ), intent(in) :: &
177 : lmin ! CLUBB tunable parameter lmin
178 :
179 : logical, intent(in) :: &
180 : l_implemented ! Flag for CLUBB being implemented in a larger model
181 :
182 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
183 : Lscale, & ! Mixing length [m]
184 : Lscale_up, & ! Mixing length up [m]
185 : Lscale_down ! Mixing length down [m]
186 :
187 : type (stats_metadata_type), intent(in) :: &
188 : stats_metadata
189 :
190 : !--------------------------------- Local Variables ---------------------------------
191 :
192 : integer :: i, j, k, start_index
193 :
194 : real( kind = core_rknd ) :: tke, CAPE_incr
195 :
196 : real( kind = core_rknd ) :: dCAPE_dz_j, dCAPE_dz_j_minus_1, dCAPE_dz_j_plus_1
197 :
198 : ! Temporary 2D arrays to store calculations to speed runtime
199 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
200 705888 : exp_mu_dzm, &
201 705888 : invrs_dzm_on_mu, &
202 705888 : grav_on_thvm, &
203 705888 : Lv_coef, &
204 705888 : entrain_coef, &
205 705888 : thl_par_j_precalc, &
206 705888 : rt_par_j_precalc, &
207 705888 : tl_par_1, &
208 705888 : rt_par_1, &
209 705888 : rsatl_par_1, &
210 705888 : thl_par_1, &
211 705888 : dCAPE_dz_1, &
212 705888 : s_par_1, &
213 705888 : rc_par_1, &
214 705888 : CAPE_incr_1, &
215 705888 : thv_par_1
216 :
217 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
218 705888 : tke_i
219 :
220 : ! Minimum value for Lscale that will taper off with height
221 : real( kind = core_rknd ) :: lminh
222 :
223 : ! Parcel quantities at grid level j
224 : real( kind = core_rknd ) :: thl_par_j, rt_par_j, rc_par_j, thv_par_j
225 :
226 : ! Used in latent heating calculation
227 : real( kind = core_rknd ) :: tl_par_j, rsatl_par_j, s_par_j
228 :
229 : ! Variables to make L nonlocal
230 : real( kind = core_rknd ) :: Lscale_up_max_alt, Lscale_down_min_alt
231 :
232 : ! Variables used to precalculate values
233 : real( kind = core_rknd ) :: &
234 : Lv2_coef, &
235 : tl_par_j_sqd, &
236 : invrs_dCAPE_diff, &
237 : invrs_Lscale_sfclyr_depth
238 :
239 : ! --------------------------------- Begin Code ---------------------------------
240 :
241 : !$acc enter data create( exp_mu_dzm, invrs_dzm_on_mu, grav_on_thvm, Lv_coef, &
242 : !$acc entrain_coef, thl_par_j_precalc, rt_par_j_precalc, &
243 : !$acc tl_par_1, rt_par_1, rsatl_par_1, thl_par_1, dCAPE_dz_1, &
244 : !$acc s_par_1, rc_par_1, CAPE_incr_1, thv_par_1, tke_i )
245 :
246 : !$acc parallel loop gang vector default(present)
247 5893344 : do i = 1, ngrdcol
248 5893344 : if ( abs(mu(i)) < eps ) then
249 0 : err_code = clubb_fatal_error
250 0 : print *, "mu = ", mu(i)
251 : end if
252 : end do
253 : !$acc end parallel loop
254 :
255 352944 : if ( err_code == clubb_fatal_error ) then
256 0 : write(fstderr,*) "Entrainment rate mu cannot be 0"
257 0 : error stop "Fatal error in subroutine compute_mixing_length"
258 : end if
259 :
260 : ! Calculate initial turbulent kinetic energy for each grid level
261 352944 : tke_i = zm2zt( nz, ngrdcol, gr, em )
262 :
263 : ! Initialize arrays and precalculate values for computational efficiency
264 : !$acc parallel loop gang vector collapse(2) default(present)
265 5893344 : do i = 1, ngrdcol
266 476827344 : do k = 1, nz
267 :
268 : ! Initialize up and down arrays
269 470934000 : Lscale_up(i,k) = zlmin
270 470934000 : Lscale_down(i,k) = zlmin
271 :
272 : ! Precalculate values to avoid unnecessary calculations later
273 470934000 : exp_mu_dzm(i,k) = exp( -mu(i) * gr%dzm(i,k) )
274 470934000 : invrs_dzm_on_mu(i,k) = ( gr%invrs_dzm(i,k) ) / mu(i)
275 470934000 : grav_on_thvm(i,k) = grav / thvm(i,k)
276 470934000 : Lv_coef(i,k) = Lv / ( exner(i,k) * cp ) - ep2 * thv_ds(i,k)
277 476474400 : entrain_coef(i,k) = ( one - exp_mu_dzm(i,k) ) * invrs_dzm_on_mu(i,k)
278 :
279 : end do
280 : end do
281 : !$acc end parallel loop
282 :
283 : !$acc parallel loop gang vector default(present)
284 5893344 : do i = 1, ngrdcol
285 :
286 : ! Avoid uninitialized memory (these values are not used in Lscale)
287 5540400 : Lscale_up(i,1) = zero
288 5893344 : Lscale_down(i,1) = zero
289 : end do
290 : !$acc end parallel loop
291 :
292 : ! Precalculations of single values to avoid unnecessary calculations later
293 : Lv2_coef = ep * Lv**2 / ( Rd * cp )
294 : invrs_Lscale_sfclyr_depth = one / Lscale_sfclyr_depth
295 :
296 :
297 : ! ---------------- Upwards Length Scale Calculation ----------------
298 :
299 : ! Precalculate values for upward Lscale, these are useful only if a parcel can rise
300 : ! more than one level. They are used in the equations that calculate thl and rt
301 : ! recursively for a parcel as it ascends
302 :
303 : !$acc parallel loop gang vector collapse(2) default(present)
304 5893344 : do i = 1, ngrdcol
305 465746544 : do j = 2, nz-1
306 :
307 1379559600 : thl_par_j_precalc(i,j) = thlm(i,j) - thlm(i,j-1) * exp_mu_dzm(i,j-1) &
308 1379559600 : - ( thlm(i,j) - thlm(i,j-1) ) * entrain_coef(i,j-1)
309 :
310 : rt_par_j_precalc(i,j) = rtm(i,j) - rtm(i,j-1) * exp_mu_dzm(i,j-1) &
311 465393600 : - ( rtm(i,j) - rtm(i,j-1) ) * entrain_coef(i,j-1)
312 : end do
313 : end do
314 : !$acc end parallel loop
315 :
316 : ! Calculate the initial change in TKE for each level. This is done for computational
317 : ! efficiency, it helps because there will be at least one calculation for each grid level,
318 : ! meaning the first one can be done for every grid level and therefore the calculations can
319 : ! be vectorized, clubb:ticket:834. After the initial calculation however, it is uncertain
320 : ! how many more iterations should be done for each individual grid level, and calculating
321 : ! one change in TKE for each level until all are exhausted will result in many unnessary
322 : ! and expensive calculations.
323 :
324 : ! Calculate initial thl, tl, and rt for parcels at each grid level
325 : !$acc parallel loop gang vector collapse(2) default(present)
326 5893344 : do i = 1, ngrdcol
327 465746544 : do j = 3, nz
328 :
329 459853200 : thl_par_1(i,j) = thlm(i,j) - ( thlm(i,j) - thlm(i,j-1) ) * entrain_coef(i,j-1)
330 :
331 459853200 : tl_par_1(i,j) = thl_par_1(i,j) * exner(i,j)
332 :
333 465393600 : rt_par_1(i,j) = rtm(i,j) - ( rtm(i,j) - rtm(i,j-1) ) * entrain_coef(i,j-1)
334 :
335 : end do
336 : end do
337 : !$acc end parallel loop
338 :
339 :
340 : ! Caclculate initial rsatl for parcels at each grid level
341 :
342 : ! The entire pressure and temperature arrays are passed as
343 : ! argument and the sub-arrays are choosen using
344 : ! start_index. This workaround is used to solve
345 : ! subarray issues with OpenACC.
346 : ! rsatl_par_1(i,3:) = sat_mixrat_liq_acc( nz-2, ngrdcol, p_in_Pa(i,3:), tl_par_1(i,3:) )
347 : ! since subarray 3:, the start_index is 3 and it is an optional argument
348 352944 : start_index = 3
349 352944 : rsatl_par_1 = sat_mixrat_liq( nz, ngrdcol, p_in_Pa, tl_par_1, start_index )
350 :
351 : ! Calculate initial dCAPE_dz and CAPE_incr for parcels at each grid level
352 : !$acc parallel loop gang vector default(present)
353 5893344 : do i = 1, ngrdcol
354 465393600 : do j = 3, nz
355 :
356 459853200 : tl_par_j_sqd = tl_par_1(i,j)**2
357 :
358 : ! s from Lewellen and Yoh 1993 (LY) eqn. 1
359 : ! s = ( rt - rsatl ) / ( 1 + beta * rsatl )
360 : ! and SD's beta (eqn. 8),
361 : ! beta = ep * ( Lv / ( Rd * tl ) ) * ( Lv / ( cp * tl ) )
362 : !
363 : ! Simplified by multiplying top and bottom by tl^2 to avoid a divide and precalculating
364 : ! ep * Lv**2 / ( Rd * cp )
365 : s_par_1(i,j) = ( rt_par_1(i,j) - rsatl_par_1(i,j) ) * tl_par_j_sqd &
366 459853200 : / ( tl_par_j_sqd + Lv2_coef * rsatl_par_1(i,j) )
367 :
368 459853200 : rc_par_1(i,j) = max( s_par_1(i,j), zero_threshold )
369 :
370 : ! theta_v of entraining parcel at grid level j
371 459853200 : thv_par_1(i,j) = thl_par_1(i,j) + ep1 * thv_ds(i,j) * rt_par_1(i,j) + Lv_coef(i,j) * rc_par_1(i,j)
372 :
373 :
374 : ! dCAPE/dz = g * ( thv_par - thvm ) / thvm.
375 459853200 : dCAPE_dz_1(i,j) = grav_on_thvm(i,j) * ( thv_par_1(i,j) - thvm(i,j) )
376 :
377 : ! CAPE_incr = INT(z_0:z_1) g * ( thv_par - thvm ) / thvm dz
378 : ! Trapezoidal estimate between grid levels, dCAPE at z_0 = 0 for this initial calculation
379 465393600 : CAPE_incr_1(i,j) = one_half * dCAPE_dz_1(i,j) * gr%dzm(i,j-1)
380 :
381 : end do
382 :
383 :
384 : ! Calculate Lscale_up for each grid level. If the TKE from a parcel has not been completely
385 : ! exhausted by the initial change then continue the exhaustion calculations here for a single
386 : ! grid level at a time until the TKE is exhausted.
387 :
388 5540400 : Lscale_up_max_alt = zero ! Set initial max value for Lscale_up to 0
389 460206144 : do k = 2, nz-2
390 :
391 : ! If the initial turbulent kinetic energy (tke) has not been exhausted for this grid level
392 454312800 : if ( tke_i(i,k) + CAPE_incr_1(i,k+1) > zero ) then
393 :
394 : ! Calculate new TKE for parcel
395 36177862 : tke = tke_i(i,k) + CAPE_incr_1(i,k+1)
396 :
397 : ! Set j to 2 levels above current Lscale_up level, this is because we've already
398 : ! determined that the parcel can rise at least 1 full level
399 36177862 : j = k + 2
400 :
401 : ! Set initial thl, rt, and dCAPE_dz to the values found by the intial calculations
402 36177862 : thl_par_j = thl_par_1(i,k+1)
403 36177862 : rt_par_j = rt_par_1(i,k+1)
404 36177862 : dCAPE_dz_j_minus_1 = dCAPE_dz_1(i,k+1)
405 :
406 :
407 : ! Continue change in TKE calculations until it is exhausted or the max grid
408 : ! level has been reached. j is the next grid level above the level that can
409 : ! be reached for a parcel starting at level k. If TKE is exhausted in this loop
410 : ! that means the parcel starting at k cannot reach level j, but has reached j-1
411 184244913 : do while ( j < nz )
412 :
413 : ! thl, rt of parcel are conserved except for entrainment
414 : !
415 : ! The values of thl_env and rt_env are treated as changing linearly for a parcel
416 : ! of air ascending from level j-1 to level j
417 :
418 : ! theta_l of the parcel starting at grid level k, and currenly
419 : ! at grid level j
420 : !
421 : ! d(thl_par)/dz = - mu * ( thl_par - thl_env )
422 184244913 : thl_par_j = thl_par_j_precalc(i,j) + thl_par_j * exp_mu_dzm(i,j-1)
423 :
424 :
425 : ! r_t of the parcel starting at grid level k, and currenly
426 : ! at grid level j
427 : !
428 : ! d(rt_par)/dz = - mu * ( rt_par - rt_env )
429 184244913 : rt_par_j = rt_par_j_precalc(i,j) + rt_par_j * exp_mu_dzm(i,j-1)
430 :
431 :
432 : ! Include effects of latent heating on Lscale_up 6/12/00
433 : ! Use thermodynamic formula of Bougeault 1981 JAS Vol. 38, 2416
434 : ! Probably should use properties of bump 1 in Gaussian, not mean!!!
435 :
436 184244913 : tl_par_j = thl_par_j*exner(i,j)
437 :
438 184244913 : rsatl_par_j = sat_mixrat_liq( p_in_Pa(i,j), tl_par_j )
439 :
440 184244913 : tl_par_j_sqd = tl_par_j**2
441 :
442 : ! s from Lewellen and Yoh 1993 (LY) eqn. 1
443 : ! s = ( rt - rsatl ) / ( 1 + beta * rsatl )
444 : ! and SD's beta (eqn. 8),
445 : ! beta = ep * ( Lv / ( Rd * tl ) ) * ( Lv / ( cp * tl ) )
446 : !
447 : ! Simplified by multiplying top and bottom by tl^2 to avoid a
448 : ! divide and precalculating ep * Lv**2 / ( Rd * cp )
449 : s_par_j = ( rt_par_j - rsatl_par_j ) * tl_par_j_sqd &
450 184244913 : / ( tl_par_j_sqd + Lv2_coef * rsatl_par_j )
451 :
452 184244913 : rc_par_j = max( s_par_j, zero_threshold )
453 :
454 : ! theta_v of entraining parcel at grid level j
455 : thv_par_j = thl_par_j + ep1 * thv_ds(i,j) * rt_par_j &
456 184244913 : + Lv_coef(i,j) * rc_par_j
457 :
458 : ! dCAPE/dz = g * ( thv_par - thvm ) / thvm.
459 184244913 : dCAPE_dz_j = grav_on_thvm(i,j) * ( thv_par_j - thvm(i,j) )
460 :
461 : ! CAPE_incr = INT(z_0:z_1) g * ( thv_par - thvm ) / thvm dz
462 : ! Trapezoidal estimate between grid levels j and j-1
463 184244913 : CAPE_incr = one_half * ( dCAPE_dz_j + dCAPE_dz_j_minus_1 ) * gr%dzm(i,j-1)
464 :
465 : ! Exit loop early if tke has been exhaused between level j and j+1
466 184244913 : if ( tke + CAPE_incr <= zero ) then
467 : exit
468 : end if
469 :
470 : ! Save previous dCAPE value for next cycle
471 148067051 : dCAPE_dz_j_minus_1 = dCAPE_dz_j
472 :
473 : ! Caclulate new TKE and increment j
474 148067051 : tke = tke + CAPE_incr
475 184244913 : j = j + 1
476 :
477 : enddo
478 :
479 :
480 : ! Add full grid level thickness for each grid level that was passed without the TKE
481 : ! being exhausted, difference between starting level (k) and last level passed (j-1)
482 36177862 : Lscale_up(i,k) = Lscale_up(i,k) + gr%zt(i,j-1) - gr%zt(i,k)
483 :
484 :
485 36177862 : if ( j < nz ) then
486 :
487 : ! Loop terminated early, meaning TKE was completely exhaused at grid level j.
488 : ! Add the thickness z - z_0 (where z_0 < z <= z_1) to Lscale_up.
489 :
490 36177862 : if ( abs( dCAPE_dz_j - dCAPE_dz_j_minus_1 ) * 2 <= &
491 : abs( dCAPE_dz_j + dCAPE_dz_j_minus_1 ) * eps ) then
492 :
493 : ! Special case where dCAPE/dz|_(z_1) - dCAPE/dz|_(z_0) = 0
494 : ! Find the remaining distance z - z_0 that it takes to
495 : ! exhaust the remaining TKE
496 :
497 0 : Lscale_up(i,k) = Lscale_up(i,k) + ( - tke / dCAPE_dz_j )
498 :
499 : else
500 :
501 : ! Case used for most scenarios where dCAPE/dz|_(z_1) /= dCAPE/dz|_(z_0)
502 : ! Find the remaining distance z - z_0 that it takes to exhaust the
503 : ! remaining TKE (tke_i), using the quadratic formula (only the
504 : ! negative (-) root works in this scenario).
505 36177862 : invrs_dCAPE_diff = one / ( dCAPE_dz_j - dCAPE_dz_j_minus_1 )
506 :
507 : Lscale_up(i,k) = Lscale_up(i,k) &
508 0 : - dCAPE_dz_j_minus_1 * invrs_dCAPE_diff * gr%dzm(i,j-1) &
509 : - sqrt( dCAPE_dz_j_minus_1**2 &
510 0 : - two * tke * gr%invrs_dzm(i,j-1) &
511 : * ( dCAPE_dz_j - dCAPE_dz_j_minus_1 ) ) &
512 36177862 : * invrs_dCAPE_diff * gr%dzm(i,j-1)
513 : endif
514 :
515 : end if
516 :
517 : else ! TKE for parcel at level (k) was exhaused before one full grid level
518 :
519 : ! Find the remaining distance z - z_0 that it takes to exhaust the
520 : ! remaining TKE (tke_i), using the quadratic formula. Simplified
521 : ! since dCAPE_dz_j_minus_1 = 0.0
522 : Lscale_up(i,k) = Lscale_up(i,k) - sqrt( - two * tke_i(i,k) &
523 0 : * gr%dzm(i,k) * dCAPE_dz_1(i,k+1) ) &
524 418134938 : / dCAPE_dz_1(i,k+1)
525 : endif
526 :
527 :
528 : ! If a parcel at a previous grid level can rise past the parcel at this grid level
529 : ! then this one should also be able to rise up to that height. This feature insures
530 : ! that the profile of Lscale_up will be smooth, thus reducing numerical instability.
531 459853200 : if ( gr%zt(i,k) + Lscale_up(i,k) < Lscale_up_max_alt ) then
532 :
533 : ! A lower starting parcel can ascend higher than this one, set height to the max
534 : ! that any lower starting parcel can ascend to
535 45320994 : Lscale_up(i,k) = Lscale_up_max_alt - gr%zt(i,k)
536 : else
537 :
538 : ! This parcel can ascend higher than any below it, save final height
539 : Lscale_up_max_alt = Lscale_up(i,k) + gr%zt(i,k)
540 : end if
541 :
542 :
543 : end do
544 : end do
545 : !$acc end parallel loop
546 :
547 : ! ---------------- Downwards Length Scale Calculation ----------------
548 :
549 : ! Precalculate values for downward Lscale, these are useful only if a parcel can descend
550 : ! more than one level. They are used in the equations that calculate thl and rt
551 : ! recursively for a parcel as it descends
552 : !$acc parallel loop gang vector collapse(2) default(present)
553 5893344 : do i = 1, ngrdcol
554 465746544 : do j = 2, nz-1
555 :
556 1379559600 : thl_par_j_precalc(i,j) = thlm(i,j) - thlm(i,j+1) * exp_mu_dzm(i,j) &
557 1379559600 : - ( thlm(i,j) - thlm(i,j+1) ) * entrain_coef(i,j)
558 :
559 : rt_par_j_precalc(i,j) = rtm(i,j) - rtm(i,j+1) * exp_mu_dzm(i,j) &
560 465393600 : - ( rtm(i,j) - rtm(i,j+1) ) * entrain_coef(i,j)
561 : end do
562 : end do
563 : !$acc end parallel loop
564 :
565 : ! Calculate the initial change in TKE for each level. This is done for computational
566 : ! efficiency, it helps because there will be at least one calculation for each grid level,
567 : ! meaning the first one can be done for every grid level and therefore the calculations can
568 : ! be vectorized, clubb:ticket:834. After the initial calculation however, it is uncertain
569 : ! how many more iterations should be done for each individual grid level, and calculating
570 : ! one change in TKE for each level until all are exhausted will result in many unnessary
571 : ! and expensive calculations.
572 :
573 : ! Calculate initial thl, tl, and rt for parcels at each grid level
574 : !$acc parallel loop gang vector collapse(2) default(present)
575 5893344 : do i = 1, ngrdcol
576 465746544 : do j = 2, nz-1
577 :
578 459853200 : thl_par_1(i,j) = thlm(i,j) - ( thlm(i,j) - thlm(i,j+1) ) * entrain_coef(i,j)
579 :
580 459853200 : tl_par_1(i,j) = thl_par_1(i,j) * exner(i,j)
581 :
582 465393600 : rt_par_1(i,j) = rtm(i,j) - ( rtm(i,j) - rtm(i,j+1) ) * entrain_coef(i,j)
583 :
584 : end do
585 : end do
586 : !$acc end parallel loop
587 :
588 : ! Caclculate initial rsatl for parcels at each grid level, this function is elemental
589 :
590 : ! The entire pressure and temperature arrays are passed as
591 : ! argument and the sub-arrays are choosen using
592 : ! start_index. This workaround is used to solve
593 : ! subarray issues with OpenACC.
594 : ! rsatl_par_1(i,2:) = sat_mixrat_liq_acc( nz-1, p_in_Pa(i,2:), tl_par_1(i,2:) )
595 : ! since subarray 2:, the start_index is 2 and it is an optional argument
596 352944 : start_index = 2
597 352944 : rsatl_par_1 = sat_mixrat_liq( nz, ngrdcol, p_in_Pa, tl_par_1, start_index )
598 :
599 : ! Calculate initial dCAPE_dz and CAPE_incr for parcels at each grid level
600 : !$acc parallel loop gang vector default(present)
601 5893344 : do i = 1, ngrdcol
602 465393600 : do j = 2, nz-1
603 :
604 459853200 : tl_par_j_sqd = tl_par_1(i,j)**2
605 :
606 : ! s from Lewellen and Yoh 1993 (LY) eqn. 1
607 : ! s = ( rt - rsatl ) / ( 1 + beta * rsatl )
608 : ! and SD's beta (eqn. 8),
609 : ! beta = ep * ( Lv / ( Rd * tl ) ) * ( Lv / ( cp * tl ) )
610 : !
611 : ! Simplified by multiplying top and bottom by tl^2 to avoid a divide and precalculating
612 : ! ep * Lv**2 / ( Rd * cp )
613 : s_par_1(i,j) = ( rt_par_1(i,j) - rsatl_par_1(i,j) ) * tl_par_j_sqd &
614 459853200 : / ( tl_par_j_sqd + Lv2_coef * rsatl_par_1(i,j) )
615 :
616 459853200 : rc_par_1(i,j) = max( s_par_1(i,j), zero_threshold )
617 :
618 : ! theta_v of entraining parcel at grid level j
619 459853200 : thv_par_1(i,j) = thl_par_1(i,j) + ep1 * thv_ds(i,j) * rt_par_1(i,j) + Lv_coef(i,j) * rc_par_1(i,j)
620 :
621 : ! dCAPE/dz = g * ( thv_par - thvm ) / thvm.
622 459853200 : dCAPE_dz_1(i,j) = grav_on_thvm(i,j) * ( thv_par_1(i,j) - thvm(i,j) )
623 :
624 : ! CAPE_incr = INT(z_0:z_1) g * ( thv_par - thvm ) / thvm dz
625 : ! Trapezoidal estimate between grid levels, dCAPE at z_0 = 0 for this initial calculation
626 465393600 : CAPE_incr_1(i,j) = one_half * dCAPE_dz_1(i,j) * gr%dzm(i,j)
627 :
628 : end do
629 :
630 :
631 : ! Calculate Lscale_down for each grid level. If the TKE from a parcel has not been completely
632 : ! exhausted by the initial change then continue the exhaustion calculations here for a single
633 : ! grid level at a time until the TKE is exhausted.
634 :
635 5540400 : Lscale_down_min_alt = gr%zt(i,nz) ! Set initial min value for Lscale_down to max zt
636 465746544 : do k = nz, 3, -1
637 :
638 : ! If the initial turbulent kinetic energy (tke) has not been exhausted for this grid level
639 459853200 : if ( tke_i(i,k) - CAPE_incr_1(i,k-1) > zero ) then
640 :
641 : ! Calculate new TKE for parcel
642 29950497 : tke = tke_i(i,k) - CAPE_incr_1(i,k-1)
643 :
644 : ! Set j to 2 levels below current Lscale_down level, this is because we've already
645 : ! determined that the parcel can descend at least 1 full level
646 29950497 : j = k - 2
647 :
648 : ! Set initial thl, rt, and dCAPE_dz to the values found by the intial calculations
649 29950497 : thl_par_j = thl_par_1(i,k-1)
650 29950497 : rt_par_j = rt_par_1(i,k-1)
651 29950497 : dCAPE_dz_j_plus_1 = dCAPE_dz_1(i,k-1)
652 :
653 :
654 : ! Continue change in TKE calculations until it is exhausted or the min grid
655 : ! level has been reached. j is the next grid level below the level that can
656 : ! be reached for a parcel starting at level k. If TKE is exhausted in this loop
657 : ! that means the parcel starting at k cannot sink to level j, but can sink to j+1
658 92885481 : do while ( j >= 2 )
659 :
660 : ! thl, rt of parcel are conserved except for entrainment
661 : !
662 : ! The values of thl_env and rt_env are treated as changing linearly for a parcel
663 : ! of air descending from level j to level j-1
664 :
665 : ! theta_l of the parcel starting at grid level k, and currenly
666 : ! at grid level j
667 : !
668 : ! d(thl_par)/dz = - mu * ( thl_par - thl_env )
669 72115351 : thl_par_j = thl_par_j_precalc(i,j) + thl_par_j * exp_mu_dzm(i,j)
670 :
671 :
672 : ! r_t of the parcel starting at grid level k, and currenly
673 : ! at grid level j
674 : !
675 : ! d(rt_par)/dz = - mu * ( rt_par - rt_env )
676 72115351 : rt_par_j = rt_par_j_precalc(i,j) + rt_par_j * exp_mu_dzm(i,j)
677 :
678 :
679 : ! Include effects of latent heating on Lscale_up 6/12/00
680 : ! Use thermodynamic formula of Bougeault 1981 JAS Vol. 38, 2416
681 : ! Probably should use properties of bump 1 in Gaussian, not mean!!!
682 :
683 72115351 : tl_par_j = thl_par_j*exner(i,j)
684 :
685 72115351 : rsatl_par_j = sat_mixrat_liq( p_in_Pa(i,j), tl_par_j )
686 :
687 72115351 : tl_par_j_sqd = tl_par_j**2
688 :
689 : ! s from Lewellen and Yoh 1993 (LY) eqn. 1
690 : ! s = ( rt - rsatl ) / ( 1 + beta * rsatl )
691 : ! and SD's beta (eqn. 8),
692 : ! beta = ep * ( Lv / ( Rd * tl ) ) * ( Lv / ( cp * tl ) )
693 : !
694 : ! Simplified by multiplying top and bottom by tl^2 to avoid a
695 : ! divide and precalculating ep * Lv**2 / ( Rd * cp )
696 : s_par_j = (rt_par_j - rsatl_par_j) * tl_par_j_sqd &
697 72115351 : / ( tl_par_j_sqd + Lv2_coef * rsatl_par_j )
698 :
699 72115351 : rc_par_j = max( s_par_j, zero_threshold )
700 :
701 : ! theta_v of entraining parcel at grid level j
702 72115351 : thv_par_j = thl_par_j + ep1 * thv_ds(i,j) * rt_par_j + Lv_coef(i,j) * rc_par_j
703 :
704 : ! dCAPE/dz = g * ( thv_par - thvm ) / thvm.
705 72115351 : dCAPE_dz_j = grav_on_thvm(i,j) * ( thv_par_j - thvm(i,j) )
706 :
707 : ! CAPE_incr = INT(z_0:z_1) g * ( thv_par - thvm ) / thvm dz
708 : ! Trapezoidal estimate between grid levels j+1 and j
709 72115351 : CAPE_incr = one_half * ( dCAPE_dz_j + dCAPE_dz_j_plus_1 ) * gr%dzm(i,j)
710 :
711 : ! Exit loop early if tke has been exhaused between level j+1 and j
712 72115351 : if ( tke - CAPE_incr <= zero ) then
713 : exit
714 : endif
715 :
716 : ! Save previous dCAPE value for next cycle
717 62934984 : dCAPE_dz_j_plus_1 = dCAPE_dz_j
718 :
719 : ! Caclulate new TKE and increment j
720 62934984 : tke = tke - CAPE_incr
721 72115351 : j = j - 1
722 :
723 : enddo
724 :
725 : ! Add full grid level thickness for each grid level that was passed without the TKE
726 : ! being exhausted, difference between starting level (k) and last level passed (j+1)
727 29950497 : Lscale_down(i,k) = Lscale_down(i,k) + gr%zt(i,k) - gr%zt(i,j+1)
728 :
729 :
730 29950497 : if ( j >= 2 ) then
731 :
732 : ! Loop terminated early, meaning TKE was completely exhaused at grid level j.
733 : ! Add the thickness z - z_0 (where z_0 < z <= z_1) to Lscale_up.
734 :
735 9180367 : if ( abs( dCAPE_dz_j - dCAPE_dz_j_plus_1 ) * 2 <= &
736 : abs( dCAPE_dz_j + dCAPE_dz_j_plus_1 ) * eps ) then
737 :
738 : ! Special case where dCAPE/dz|_(z_(-1)) - dCAPE/dz|_(z_0) = 0
739 : ! Find the remaining distance z_0 - z that it takes to
740 : ! exhaust the remaining TKE
741 :
742 0 : Lscale_down(i,k) = Lscale_down(i,k) + ( tke / dCAPE_dz_j )
743 :
744 : else
745 :
746 : ! Case used for most scenarios where dCAPE/dz|_(z_(-1)) /= dCAPE/dz|_(z_0)
747 : ! Find the remaining distance z_0 - z that it takes to exhaust the
748 : ! remaining TKE (tke_i), using the quadratic formula (only the
749 : ! negative (-) root works in this scenario) -- however, the
750 : ! negative (-) root is divided by another negative (-) factor,
751 : ! which results in an overall plus (+) sign in front of the
752 : ! square root term in the equation below).
753 9180367 : invrs_dCAPE_diff = one / ( dCAPE_dz_j - dCAPE_dz_j_plus_1 )
754 :
755 : Lscale_down(i,k) = Lscale_down(i,k) &
756 0 : - dCAPE_dz_j_plus_1 * invrs_dCAPE_diff * gr%dzm(i,j) &
757 : + sqrt( dCAPE_dz_j_plus_1**2 &
758 0 : + two * tke * gr%invrs_dzm(i,j) &
759 : * ( dCAPE_dz_j - dCAPE_dz_j_plus_1 ) ) &
760 9180367 : * invrs_dCAPE_diff * gr%dzm(i,j)
761 : endif
762 :
763 : end if
764 :
765 : else ! TKE for parcel at level (k) was exhaused before one full grid level
766 :
767 : ! Find the remaining distance z_0 - z that it takes to exhaust the
768 : ! remaining TKE (tke_i), using the quadratic formula. Simplified
769 : ! since dCAPE_dz_j_plus_1 = 0.0
770 429902703 : Lscale_down(i,k) = Lscale_down(i,k) + sqrt( two * tke_i(i,k) &
771 0 : * gr%dzm(i,k-1) * dCAPE_dz_1(i,k-1) ) &
772 429902703 : / dCAPE_dz_1(i,k-1)
773 : endif
774 :
775 : ! If a parcel at a previous grid level can descend past the parcel at this grid level
776 : ! then this one should also be able to descend down to that height. This feature insures
777 : ! that the profile of Lscale_down will be smooth, thus reducing numerical instability.
778 465393600 : if ( gr%zt(i,k) - Lscale_down(i,k) > Lscale_down_min_alt ) then
779 9950751 : Lscale_down(i,k) = gr%zt(i,k) - Lscale_down_min_alt
780 : else
781 : Lscale_down_min_alt = gr%zt(i,k) - Lscale_down(i,k)
782 : end if
783 :
784 : end do
785 : end do
786 : !$acc end parallel loop
787 :
788 : ! ---------------- Final Lscale Calculation ----------------
789 :
790 : !$acc parallel loop gang vector default(present)
791 5893344 : do i = 1, ngrdcol
792 470934000 : do k = 2, nz, 1
793 :
794 : ! Make lminh a linear function starting at value lmin at the bottom
795 : ! and going to zero at 500 meters in altitude.
796 465393600 : if( l_implemented ) then
797 :
798 : ! Within a host model, increase mixing length in 500 m layer above *ground*
799 0 : lminh = max( zero_threshold, Lscale_sfclyr_depth - ( gr%zt(i,k) - gr%zm(i,1) ) ) &
800 465393600 : * lmin * invrs_Lscale_sfclyr_depth
801 : else
802 :
803 : ! In standalone mode, increase mixing length in 500 m layer above *mean sea level*
804 0 : lminh = max( zero_threshold, Lscale_sfclyr_depth - gr%zt(i,k) ) &
805 0 : * lmin * invrs_Lscale_sfclyr_depth
806 : end if
807 :
808 465393600 : Lscale_up(i,k) = max( lminh, Lscale_up(i,k) )
809 465393600 : Lscale_down(i,k) = max( lminh, Lscale_down(i,k) )
810 :
811 : ! When L is large, turbulence is weakly damped
812 : ! When L is small, turbulence is strongly damped
813 : ! Use a geometric mean to determine final Lscale so that L tends to become small
814 : ! if either Lscale_up or Lscale_down becomes small.
815 470934000 : Lscale(i,k) = sqrt( Lscale_up(i,k) * Lscale_down(i,k) )
816 :
817 : enddo
818 :
819 : ! Set the value of Lscale at the upper and lower boundaries.
820 5540400 : Lscale(i,1) = Lscale(i,2)
821 5540400 : Lscale(i,nz) = Lscale(i,nz-1)
822 :
823 : ! Vince Larson limited Lscale to allow host
824 : ! model to take over deep convection. 13 Feb 2008.
825 476827344 : Lscale(i,:) = min( Lscale(i,:), Lscale_max(i) )
826 :
827 : end do
828 : !$acc end parallel loop
829 :
830 : ! Ensure that no Lscale values are NaN
831 352944 : if ( clubb_at_least_debug_level( 1 ) ) then
832 :
833 : !$acc update host( Lscale, Lscale_up, Lscale_down, &
834 : !$acc thvm, thlm, rtm, em, exner, p_in_Pa, thv_ds )
835 :
836 0 : do i = 1, ngrdcol
837 0 : call length_check( nz, Lscale(i,:), Lscale_up(i,:), Lscale_down(i,:) ) ! intent(in)
838 : end do
839 :
840 0 : if ( err_code == clubb_fatal_error ) then
841 :
842 0 : write(fstderr,*) "Errors in compute_mixing_length subroutine"
843 :
844 0 : write(fstderr,*) "Intent(in)"
845 :
846 0 : write(fstderr,*) "thvm = ", thvm
847 0 : write(fstderr,*) "thlm = ", thlm
848 0 : write(fstderr,*) "rtm = ", rtm
849 0 : write(fstderr,*) "em = ", em
850 0 : write(fstderr,*) "exner = ", exner
851 0 : write(fstderr,*) "p_in_Pa = ", p_in_Pa
852 0 : write(fstderr,*) "thv_ds = ", thv_ds
853 :
854 0 : write(fstderr,*) "Intent(out)"
855 :
856 0 : write(fstderr,*) "Lscale = ", Lscale
857 0 : write(fstderr,*) "Lscale_up = ", Lscale_up
858 0 : write(fstderr,*) "Lscale_down = ", Lscale_down
859 :
860 : endif ! Fatal error
861 :
862 : end if
863 :
864 : !$acc exit data delete( exp_mu_dzm, invrs_dzm_on_mu, grav_on_thvm, Lv_coef, &
865 : !$acc entrain_coef, thl_par_j_precalc, rt_par_j_precalc, &
866 : !$acc tl_par_1, rt_par_1, rsatl_par_1, thl_par_1, dCAPE_dz_1, &
867 : !$acc s_par_1, rc_par_1, CAPE_incr_1, thv_par_1, tke_i )
868 :
869 352944 : return
870 :
871 : end subroutine compute_mixing_length
872 :
873 : !===============================================================================
874 352944 : subroutine calc_Lscale_directly ( ngrdcol, nz, gr, &
875 352944 : l_implemented, p_in_Pa, exner, rtm, &
876 352944 : thlm, thvm, newmu, rtp2, thlp2, rtpthlp, &
877 352944 : pdf_params, em, thv_ds_zt, Lscale_max, lmin, &
878 : clubb_params, &
879 : l_Lscale_plume_centered, &
880 : stats_metadata, &
881 352944 : stats_zt, &
882 352944 : Lscale, Lscale_up, Lscale_down)
883 :
884 : use constants_clubb, only: &
885 : thl_tol, &
886 : rt_tol, &
887 : one_half, &
888 : one_third, &
889 : one, &
890 : three, &
891 : unused_var
892 :
893 : use parameter_indices, only: &
894 : nparams, &
895 : iLscale_mu_coef, &
896 : iLscale_pert_coef
897 :
898 : use grid_class, only: &
899 : grid ! Type
900 :
901 : use clubb_precision, only: &
902 : core_rknd
903 :
904 : use stats_variables, only: &
905 : stats_metadata_type
906 :
907 : use pdf_parameter_module, only: &
908 : pdf_parameter
909 :
910 : use stats_type_utilities, only: &
911 : stat_update_var
912 :
913 : use error_code, only: &
914 : clubb_at_least_debug_level, & ! Procedure
915 : err_code, & ! Error Indicator
916 : clubb_fatal_error ! Constant
917 :
918 : use constants_clubb, only: &
919 : fstderr ! Variable(s)
920 :
921 : use stats_type, only: &
922 : stats ! Type
923 :
924 : implicit none
925 :
926 : !--------------------------------- Input Variables ---------------------------------
927 : integer, intent(in) :: &
928 : nz, &
929 : ngrdcol
930 :
931 : type (grid), target, intent(in) :: &
932 : gr
933 :
934 : logical, intent(in) :: &
935 : l_implemented ! True if CLUBB is being run within a large-scale hostmodel,
936 : ! rather than a standalone single-column model.
937 :
938 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
939 : rtp2, &
940 : thlp2, &
941 : rtpthlp, &
942 : thlm, &
943 : thvm, &
944 : rtm, &
945 : em, &
946 : p_in_Pa, & ! Air pressure (thermodynamic levels) [Pa]
947 : exner, &
948 : thv_ds_zt
949 :
950 : real( kind = core_rknd ), dimension(ngrdcol), intent(in) :: &
951 : newmu, &
952 : Lscale_max
953 :
954 : real( kind = core_rknd ), intent(in) :: &
955 : lmin
956 :
957 : type (pdf_parameter), intent(in) :: &
958 : pdf_params ! PDF Parameters [units vary]
959 :
960 : real( kind = core_rknd ), dimension(nparams), intent(in) :: &
961 : clubb_params ! Array of CLUBB's tunable parameters [units vary]
962 :
963 : logical, intent(in) :: &
964 : l_Lscale_plume_centered ! Alternate that uses the PDF to compute the perturbed values
965 :
966 : type (stats_metadata_type), intent(in) :: &
967 : stats_metadata
968 :
969 : !--------------------------------- InOut Variables ---------------------------------
970 : type (stats), target, dimension(ngrdcol), intent(inout) :: &
971 : stats_zt
972 :
973 : !--------------------------------- Output Variables ---------------------------------
974 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
975 : Lscale, & ! Mixing length [m]
976 : Lscale_up, & ! Mixing length up [m]
977 : Lscale_down ! Mixing length down [m]
978 :
979 : !--------------------------------- Local Variables ---------------------------------
980 : integer :: k, i
981 :
982 : logical, parameter :: &
983 : l_avg_Lscale = .false. ! Lscale is calculated in subroutine compute_mixing_length
984 : ! if l_avg_Lscale is true, compute_mixing_length is called two additional
985 : ! times with
986 : ! perturbed values of rtm and thlm. An average value of Lscale
987 : ! from the three calls to compute_mixing_length is then calculated.
988 : ! This reduces temporal noise in RICO, BOMEX, LBA, and other cases.
989 :
990 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
991 352944 : sign_rtpthlp, & ! Sign of the covariance rtpthlp [-]
992 705888 : Lscale_pert_1, Lscale_pert_2, & ! For avg. calculation of Lscale [m]
993 352944 : thlm_pert_1, thlm_pert_2, & ! For avg. calculation of Lscale [K]
994 352944 : rtm_pert_1, rtm_pert_2, & ! For avg. calculation of Lscale [kg/kg]
995 352944 : thlm_pert_pos_rt, thlm_pert_neg_rt, & ! For avg. calculation of Lscale [K]
996 352944 : rtm_pert_pos_rt, rtm_pert_neg_rt ! For avg. calculation of Lscale [kg/kg]
997 :
998 : real( kind = core_rknd ), dimension(ngrdcol) :: &
999 352944 : mu_pert_1, mu_pert_2, &
1000 352944 : mu_pert_pos_rt, mu_pert_neg_rt ! For l_Lscale_plume_centered
1001 :
1002 : real( kind = core_rknd ) :: &
1003 : Lscale_mu_coef, Lscale_pert_coef
1004 :
1005 : !Lscale_weight Uncomment this if you need to use this vairable at some
1006 : !point.
1007 :
1008 : !--------------------------------- Begin Code ---------------------------------
1009 :
1010 : !$acc enter data create( sign_rtpthlp, Lscale_pert_1, Lscale_pert_2, &
1011 : !$acc thlm_pert_1, thlm_pert_2, rtm_pert_1, rtm_pert_2, &
1012 : !$acc thlm_pert_pos_rt, thlm_pert_neg_rt, rtm_pert_pos_rt, &
1013 : !$acc rtm_pert_neg_rt, &
1014 : !$acc mu_pert_1, mu_pert_2, mu_pert_pos_rt, mu_pert_neg_rt )
1015 :
1016 352944 : Lscale_mu_coef = clubb_params(iLscale_mu_coef)
1017 352944 : Lscale_pert_coef = clubb_params(iLscale_pert_coef)
1018 :
1019 352944 : if ( clubb_at_least_debug_level( 0 ) ) then
1020 :
1021 352944 : if ( l_Lscale_plume_centered .and. .not. l_avg_Lscale ) then
1022 0 : write(fstderr,*) "l_Lscale_plume_centered requires l_avg_Lscale"
1023 0 : write(fstderr,*) "Fatal error in advance_clubb_core"
1024 0 : err_code = clubb_fatal_error
1025 0 : return
1026 : end if
1027 :
1028 : end if
1029 :
1030 : if ( l_avg_Lscale .and. .not. l_Lscale_plume_centered ) then
1031 :
1032 : ! Call compute length two additional times with perturbed values
1033 : ! of rtm and thlm so that an average value of Lscale may be calculated.
1034 :
1035 : !$acc parallel loop gang vector collapse(2) default(present)
1036 : do k = 1, nz, 1
1037 : do i = 1, ngrdcol
1038 : sign_rtpthlp(i,k) = sign( one, rtpthlp(i,k) )
1039 : end do
1040 : end do
1041 : !$acc end parallel loop
1042 :
1043 : !$acc parallel loop gang vector collapse(2) default(present)
1044 : do k = 1, nz, 1
1045 : do i = 1, ngrdcol
1046 : rtm_pert_1(i,k) = rtm(i,k) + Lscale_pert_coef * sqrt( max( rtp2(i,k), rt_tol**2 ) )
1047 : end do
1048 : end do
1049 : !$acc end parallel loop
1050 :
1051 : !$acc parallel loop gang vector collapse(2) default(present)
1052 : do k = 1, nz, 1
1053 : do i = 1, ngrdcol
1054 : thlm_pert_1(i,k) = thlm(i,k) + sign_rtpthlp(i,k) * Lscale_pert_coef &
1055 : * sqrt( max( thlp2(i,k), thl_tol**2 ) )
1056 : end do
1057 : end do
1058 : !$acc end parallel loop
1059 :
1060 : !$acc parallel loop gang vector default(present)
1061 : do i = 1, ngrdcol
1062 : mu_pert_1(i) = newmu(i) / Lscale_mu_coef
1063 : end do
1064 : !$acc end parallel loop
1065 :
1066 : call compute_mixing_length( nz, ngrdcol, gr, thvm, thlm_pert_1, & ! In
1067 : rtm_pert_1, em, Lscale_max, p_in_Pa, & ! In
1068 : exner, thv_ds_zt, mu_pert_1, lmin, l_implemented, & ! In
1069 : stats_metadata, & ! In
1070 : Lscale_pert_1, Lscale_up, Lscale_down ) ! Out
1071 :
1072 :
1073 : !$acc parallel loop gang vector collapse(2) default(present)
1074 : do k = 1, nz, 1
1075 : do i = 1, ngrdcol
1076 : rtm_pert_2(i,k) = rtm(i,k) - Lscale_pert_coef * sqrt( max( rtp2(i,k), rt_tol**2 ) )
1077 : end do
1078 : end do
1079 : !$acc end parallel loop
1080 :
1081 : !$acc parallel loop gang vector collapse(2) default(present)
1082 : do k = 1, nz, 1
1083 : do i = 1, ngrdcol
1084 : thlm_pert_2(i,k) = thlm(i,k) - sign_rtpthlp(i,k) * Lscale_pert_coef &
1085 : * sqrt( max( thlp2(i,k), thl_tol**2 ) )
1086 : end do
1087 : end do
1088 : !$acc end parallel loop
1089 :
1090 : !$acc parallel loop gang vector default(present)
1091 : do i = 1, ngrdcol
1092 : mu_pert_2(i) = newmu(i) * Lscale_mu_coef
1093 : end do
1094 : !$acc end parallel loop
1095 :
1096 : call compute_mixing_length( nz, ngrdcol, gr, thvm, thlm_pert_2, & ! In
1097 : rtm_pert_2, em, Lscale_max, p_in_Pa, & ! In
1098 : exner, thv_ds_zt, mu_pert_2, lmin, l_implemented, & ! In
1099 : stats_metadata, & ! In
1100 : Lscale_pert_2, Lscale_up, Lscale_down ) ! Out
1101 :
1102 : else if ( l_avg_Lscale .and. l_Lscale_plume_centered ) then
1103 :
1104 : ! Take the values of thl and rt based one 1st or 2nd plume
1105 :
1106 : !$acc parallel loop gang vector collapse(2) default(present)
1107 : do k = 1, nz
1108 : do i = 1, ngrdcol
1109 : sign_rtpthlp(i,k) = sign( one, rtpthlp(i,k) )
1110 : end do
1111 : end do
1112 : !$acc end parallel loop
1113 :
1114 : !$acc parallel loop gang vector collapse(2) default(present)
1115 : do k = 1, nz
1116 : do i = 1, ngrdcol
1117 :
1118 : if ( pdf_params%rt_1(i,k) > pdf_params%rt_2(i,k) ) then
1119 :
1120 : rtm_pert_pos_rt(i,k) = pdf_params%rt_1(i,k) &
1121 : + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_1(i,k), rt_tol**2 ) )
1122 :
1123 : thlm_pert_pos_rt(i,k) = pdf_params%thl_1(i,k) + ( sign_rtpthlp(i,k) * Lscale_pert_coef &
1124 : * sqrt( max( pdf_params%varnce_thl_1(i,k), thl_tol**2 ) ) )
1125 :
1126 : thlm_pert_neg_rt(i,k) = pdf_params%thl_2(i,k) - ( sign_rtpthlp(i,k) * Lscale_pert_coef &
1127 : * sqrt( max( pdf_params%varnce_thl_2(i,k), thl_tol**2 ) ) )
1128 :
1129 : rtm_pert_neg_rt(i,k) = pdf_params%rt_2(i,k) &
1130 : - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_2(i,k), rt_tol**2 ) )
1131 :
1132 : !Lscale_weight = pdf_params%mixt_frac(i,k)
1133 :
1134 : else
1135 :
1136 : rtm_pert_pos_rt(i,k) = pdf_params%rt_2(i,k) &
1137 : + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_2(i,k), rt_tol**2 ) )
1138 :
1139 : thlm_pert_pos_rt(i,k) = pdf_params%thl_2(i,k) + ( sign_rtpthlp(i,k) * Lscale_pert_coef &
1140 : * sqrt( max( pdf_params%varnce_thl_2(i,k), thl_tol**2 ) ) )
1141 :
1142 : thlm_pert_neg_rt(i,k) = pdf_params%thl_1(i,k) - ( sign_rtpthlp(i,k) * Lscale_pert_coef &
1143 : * sqrt( max( pdf_params%varnce_thl_1(i,k), thl_tol**2 ) ) )
1144 :
1145 : rtm_pert_neg_rt(i,k) = pdf_params%rt_1(i,k) &
1146 : - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_1(i,k), rt_tol**2 ) )
1147 :
1148 : !Lscale_weight = 1.0_core_rknd - pdf_params%mixt_frac(i,k)
1149 :
1150 : end if
1151 :
1152 : end do
1153 : end do
1154 : !$acc end parallel loop
1155 :
1156 : !$acc parallel loop gang vector default(present)
1157 : do i = 1, ngrdcol
1158 : mu_pert_pos_rt(i) = newmu(i) / Lscale_mu_coef
1159 : mu_pert_neg_rt(i) = newmu(i) * Lscale_mu_coef
1160 : end do
1161 : !$acc end parallel loop
1162 :
1163 : ! Call length with perturbed values of thl and rt
1164 : call compute_mixing_length( nz, ngrdcol, gr, thvm, thlm_pert_pos_rt, & ! In
1165 : rtm_pert_pos_rt, em, Lscale_max, p_in_Pa, & ! In
1166 : exner, thv_ds_zt, mu_pert_pos_rt, lmin, l_implemented, & ! In
1167 : stats_metadata, & ! In
1168 : Lscale_pert_1, Lscale_up, Lscale_down ) ! Out
1169 :
1170 : call compute_mixing_length( nz, ngrdcol, gr, thvm, thlm_pert_neg_rt, & ! In
1171 : rtm_pert_neg_rt, em, Lscale_max, p_in_Pa, & ! In
1172 : exner, thv_ds_zt, mu_pert_neg_rt, lmin, l_implemented, & ! In
1173 : stats_metadata, & ! In
1174 : Lscale_pert_2, Lscale_up, Lscale_down ) ! Out
1175 : else
1176 : !$acc parallel loop gang vector collapse(2) default(present)
1177 30353184 : do k = 1, nz
1178 501287184 : do i = 1, ngrdcol
1179 470934000 : Lscale_pert_1(i,k) = unused_var ! Undefined
1180 500934240 : Lscale_pert_2(i,k) = unused_var ! Undefined
1181 : end do
1182 : end do
1183 : !$acc end parallel loop
1184 : end if ! l_avg_Lscale
1185 :
1186 352944 : if ( stats_metadata%l_stats_samp ) then
1187 : !$acc update host( Lscale_pert_1, Lscale_pert_2 )
1188 0 : do i = 1, ngrdcol
1189 0 : call stat_update_var( stats_metadata%iLscale_pert_1, Lscale_pert_1(i,:), & ! intent(in)
1190 0 : stats_zt(i) ) ! intent(inout)
1191 : call stat_update_var( stats_metadata%iLscale_pert_2, Lscale_pert_2(i,:), & ! intent(in)
1192 0 : stats_zt(i) ) ! intent(inout)
1193 : end do
1194 : end if ! stats_metadata%l_stats_samp
1195 :
1196 :
1197 : ! ********** NOTE: **********
1198 : ! This call to compute_mixing_length must be last. Otherwise, the values
1199 : ! of
1200 : ! Lscale_up and Lscale_down in stats will be based on perturbation length
1201 : ! scales
1202 : ! rather than the mean length scale.
1203 :
1204 : ! Diagnose CLUBB's turbulent mixing length scale.
1205 : call compute_mixing_length( nz, ngrdcol, gr, thvm, thlm, & ! In
1206 : rtm, em, Lscale_max, p_in_Pa, & ! In
1207 : exner, thv_ds_zt, newmu, lmin, l_implemented, & ! In
1208 : stats_metadata, & ! In
1209 352944 : Lscale, Lscale_up, Lscale_down ) ! Out
1210 :
1211 : if ( l_avg_Lscale ) then
1212 : if ( l_Lscale_plume_centered ) then
1213 : ! Weighted average of mean, pert_1, & pert_2
1214 : ! Lscale = 0.5_core_rknd * ( Lscale + Lscale_weight*Lscale_pert_1 &
1215 : ! + (1.0_core_rknd-Lscale_weight)*Lscale_pert_2
1216 : ! )
1217 : ! Weighted average of just the perturbed values
1218 : ! Lscale = Lscale_weight*Lscale_pert_1 +
1219 : ! (1.0_core_rknd-Lscale_weight)*Lscale_pert_2
1220 :
1221 : ! Un-weighted average of just the perturbed values
1222 : !$acc parallel loop gang vector collapse(2) default(present)
1223 : do k = 1, nz
1224 : do i = 1, ngrdcol
1225 : Lscale(i,k) = one_half *( Lscale_pert_1(i,k) + Lscale_pert_2(i,k) )
1226 : end do
1227 : end do
1228 : !$acc end parallel loop
1229 : else
1230 : !$acc parallel loop gang vector collapse(2) default(present)
1231 : do k = 1, nz
1232 : do i = 1, ngrdcol
1233 : Lscale(i,k) = one_third * ( Lscale(i,k) + Lscale_pert_1(i,k) + Lscale_pert_2(i,k) )
1234 : end do
1235 : end do
1236 : !$acc end parallel loop
1237 : end if
1238 : end if
1239 :
1240 : !$acc exit data delete( sign_rtpthlp, Lscale_pert_1, Lscale_pert_2, &
1241 : !$acc thlm_pert_1, thlm_pert_2, rtm_pert_1, rtm_pert_2, &
1242 : !$acc thlm_pert_pos_rt, thlm_pert_neg_rt, rtm_pert_pos_rt, &
1243 : !$acc rtm_pert_neg_rt, &
1244 : !$acc mu_pert_1, mu_pert_2, mu_pert_pos_rt, mu_pert_neg_rt )
1245 :
1246 352944 : return
1247 :
1248 : end subroutine calc_Lscale_directly
1249 :
1250 :
1251 :
1252 : !===============================================================================
1253 :
1254 0 : subroutine diagnose_Lscale_from_tau( nz, ngrdcol, gr, &
1255 0 : upwp_sfc, vpwp_sfc, um, vm, & !intent in
1256 0 : exner, p_in_Pa, & !intent in
1257 0 : rtm, thlm, thvm, & !intent in
1258 0 : rcm, ice_supersat_frac, &! intent in
1259 0 : em, sqrt_em_zt, & ! intent in
1260 : ufmin, tau_const, & ! intent in
1261 0 : sfc_elevation, Lscale_max, & ! intent in
1262 : clubb_params, & ! intent in
1263 : l_e3sm_config, & ! intent in
1264 : l_brunt_vaisala_freq_moist, & !intent in
1265 : l_use_thvm_in_bv_freq, &! intent in
1266 : l_smooth_Heaviside_tau_wpxp, & ! intent in
1267 : l_modify_limiters_for_cnvg_test, & ! intent in
1268 0 : brunt_vaisala_freq_sqd, brunt_vaisala_freq_sqd_mixed, & ! intent out
1269 0 : brunt_vaisala_freq_sqd_dry, brunt_vaisala_freq_sqd_moist, & ! intent out
1270 0 : Ri_zm, & ! intent out
1271 0 : invrs_tau_zt, invrs_tau_zm, & ! intent out
1272 0 : invrs_tau_sfc, invrs_tau_no_N2_zm, invrs_tau_bkgnd, & ! intent out
1273 0 : invrs_tau_shear, invrs_tau_N2_iso, & ! intent out
1274 0 : invrs_tau_wp2_zm, invrs_tau_xp2_zm, & ! intent out
1275 0 : invrs_tau_wp3_zm, invrs_tau_wp3_zt, invrs_tau_wpxp_zm, & ! intent out
1276 0 : tau_max_zm, tau_max_zt, tau_zm, tau_zt, & !intent out
1277 0 : Lscale, Lscale_up, Lscale_down)! intent out
1278 : ! Description:
1279 : ! Diagnose inverse damping time scales (invrs_tau_...) and turbulent mixing length (Lscale)
1280 : ! References:
1281 : ! Guo et al.(2021, JAMES)
1282 : !--------------------------------------------------------------------------------------------------
1283 :
1284 : use advance_helper_module, only: &
1285 : calc_brunt_vaisala_freq_sqd, &
1286 : smooth_heaviside_peskin, &
1287 : smooth_min, smooth_max
1288 :
1289 : use constants_clubb, only: &
1290 : one_fourth, &
1291 : one_half, &
1292 : vonk, &
1293 : zero, &
1294 : one, &
1295 : two, &
1296 : em_min, &
1297 : zero_threshold, &
1298 : eps
1299 :
1300 : use grid_class, only: &
1301 : grid, & ! Type
1302 : zt2zm, &
1303 : zm2zt, &
1304 : zm2zt2zm, &
1305 : zt2zm2zt, &
1306 : ddzt
1307 :
1308 : use clubb_precision, only: &
1309 : core_rknd
1310 :
1311 : use parameter_indices, only: &
1312 : nparams, & ! Variable(s)
1313 : iC_invrs_tau_bkgnd, &
1314 : iC_invrs_tau_shear, &
1315 : iC_invrs_tau_sfc, &
1316 : iC_invrs_tau_N2, &
1317 : iC_invrs_tau_N2_wp2 , &
1318 : iC_invrs_tau_N2_wpxp, &
1319 : iC_invrs_tau_N2_xp2, &
1320 : iC_invrs_tau_wpxp_N2_thresh, &
1321 : iC_invrs_tau_N2_clear_wp3, &
1322 : iC_invrs_tau_wpxp_Ri, &
1323 : ialtitude_threshold, &
1324 : ibv_efold, &
1325 : iwpxp_Ri_exp, &
1326 : iz_displace
1327 :
1328 : use error_code, only: &
1329 : err_code, &
1330 : clubb_fatal_error, &
1331 : clubb_at_least_debug_level
1332 :
1333 : implicit none
1334 :
1335 : !--------------------------------- Input Variables ---------------------------------
1336 : integer, intent(in) :: &
1337 : nz, &
1338 : ngrdcol
1339 :
1340 : type (grid), target, intent(in) :: &
1341 : gr
1342 :
1343 : real( kind = core_rknd ), dimension(ngrdcol), intent(in) :: &
1344 : upwp_sfc, &
1345 : vpwp_sfc
1346 :
1347 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(in) :: &
1348 : um, &
1349 : vm, &
1350 : exner, &
1351 : p_in_Pa, &
1352 : rtm, &
1353 : thlm, &
1354 : thvm, &
1355 : rcm, &
1356 : ice_supersat_frac, &
1357 : em, &
1358 : sqrt_em_zt
1359 :
1360 : real(kind = core_rknd), intent(in) :: &
1361 : ufmin, &
1362 : tau_const
1363 :
1364 : real(kind = core_rknd), dimension(ngrdcol), intent(in) :: &
1365 : sfc_elevation, &
1366 : Lscale_max
1367 :
1368 : real( kind = core_rknd ), dimension(nparams), intent(in) :: &
1369 : clubb_params ! Array of CLUBB's tunable parameters [units vary]
1370 :
1371 : logical, intent(in) :: &
1372 : l_e3sm_config, &
1373 : l_brunt_vaisala_freq_moist, & ! Use a different formula for the Brunt-Vaisala frequency in
1374 : ! saturated atmospheres (from Durran and Klemp, 1982)
1375 : l_use_thvm_in_bv_freq, & ! Use thvm in the calculation of Brunt-Vaisala frequency
1376 : l_smooth_Heaviside_tau_wpxp ! Use the smoothed Heaviside 'Peskin' function
1377 : ! to compute invrs_tau_wpxp_zm
1378 :
1379 : ! Flag to activate modifications on limiters for convergence test
1380 : ! (smoothed max and min for Cx_fnc_Richardson in advance_helper_module.F90)
1381 : ! (remove the clippings on brunt_vaisala_freq_sqd_smth in mixing_length.F90)
1382 : ! (reduce threshold on limiters for Ri_zm in mixing_length.F90)
1383 : logical, intent(in) :: &
1384 : l_modify_limiters_for_cnvg_test
1385 :
1386 : !--------------------------------- Output Variables ---------------------------------
1387 : real( kind = core_rknd ), dimension(ngrdcol,nz), intent(out) :: &
1388 : brunt_vaisala_freq_sqd, &
1389 : brunt_vaisala_freq_sqd_mixed, &
1390 : brunt_vaisala_freq_sqd_dry, &
1391 : brunt_vaisala_freq_sqd_moist, &
1392 : Ri_zm, &
1393 : invrs_tau_zt, &
1394 : invrs_tau_zm, &
1395 : invrs_tau_sfc, &
1396 : invrs_tau_no_N2_zm, &
1397 : invrs_tau_bkgnd, &
1398 : invrs_tau_shear, &
1399 : invrs_tau_N2_iso, &
1400 : invrs_tau_wp2_zm, &
1401 : invrs_tau_xp2_zm, &
1402 : invrs_tau_wp3_zm, &
1403 : invrs_tau_wp3_zt, &
1404 : invrs_tau_wpxp_zm, &
1405 : tau_max_zm, &
1406 : tau_max_zt, &
1407 : tau_zm, &
1408 : tau_zt, &
1409 : Lscale, &
1410 : Lscale_up, &
1411 : Lscale_down
1412 :
1413 : !--------------------------------- Local Variables ---------------------------------
1414 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
1415 0 : brunt_freq_pos, &
1416 0 : brunt_vaisala_freq_sqd_smth, & ! smoothed Buoyancy frequency squared, N^2 [s^-2]
1417 0 : brunt_freq_out_cloud, &
1418 0 : smooth_thlm, &
1419 0 : bvf_thresh, & ! temporatory array
1420 0 : H_invrs_tau_wpxp_N2 ! Heaviside function for clippings of invrs_tau_wpxp_N2
1421 :
1422 : real( kind = core_rknd ), dimension(ngrdcol) :: &
1423 0 : ustar
1424 :
1425 : real( kind = core_rknd ) :: &
1426 : C_invrs_tau_bkgnd, &
1427 : C_invrs_tau_shear, &
1428 : C_invrs_tau_sfc, &
1429 : C_invrs_tau_N2, &
1430 : C_invrs_tau_N2_wp2 , &
1431 : C_invrs_tau_N2_wpxp, &
1432 : C_invrs_tau_N2_xp2, &
1433 : C_invrs_tau_wpxp_N2_thresh, &
1434 : C_invrs_tau_N2_clear_wp3, &
1435 : C_invrs_tau_wpxp_Ri, &
1436 : altitude_threshold, &
1437 : wpxp_Ri_exp, &
1438 : z_displace
1439 :
1440 : real( kind = core_rknd ), parameter :: &
1441 : min_max_smth_mag = 1.0e-9_core_rknd, & ! "base" smoothing magnitude before scaling
1442 : ! for the respective data structure. See
1443 : ! https://github.com/larson-group/clubb/issues/965#issuecomment-1119816722
1444 : ! for a plot on how output behaves with varying min_max_smth_mag
1445 : heaviside_smth_range = 1.0e-0_core_rknd ! range where Heaviside function is smoothed
1446 :
1447 : logical, parameter :: l_smooth_min_max = .false. ! whether to apply smooth min and max functions
1448 :
1449 : real( kind = core_rknd ), dimension(ngrdcol,nz) :: &
1450 0 : ddzt_um, &
1451 0 : ddzt_vm, &
1452 0 : ddzt_umvm_sqd, &
1453 0 : ddzt_umvm_sqd_clipped, &
1454 0 : norm_ddzt_umvm, &
1455 0 : smooth_norm_ddzt_umvm, &
1456 0 : brunt_vaisala_freq_clipped, &
1457 0 : ice_supersat_frac_zm, &
1458 0 : invrs_tau_shear_smooth, &
1459 0 : Ri_zm_clipped, &
1460 0 : Ri_zm_smooth, &
1461 0 : em_clipped, &
1462 0 : tau_zm_unclipped, &
1463 0 : tau_zt_unclipped, &
1464 0 : tmp_calc, &
1465 0 : tmp_calc_max, &
1466 0 : tmp_calc_min_max
1467 :
1468 : integer :: i, k
1469 :
1470 : !--------------------------------- Begin Code ---------------------------------
1471 :
1472 : !$acc enter data create( brunt_freq_pos, brunt_vaisala_freq_sqd_smth, brunt_freq_out_cloud, &
1473 : !$acc smooth_thlm, bvf_thresh, H_invrs_tau_wpxp_N2, ustar, &
1474 : !$acc ddzt_um, ddzt_vm, norm_ddzt_umvm, smooth_norm_ddzt_umvm, &
1475 : !$acc brunt_vaisala_freq_clipped, &
1476 : !$acc ice_supersat_frac_zm, invrs_tau_shear_smooth, &
1477 : !$acc ddzt_umvm_sqd, tau_zt )
1478 :
1479 : !$acc enter data if( l_smooth_min_max .or. l_modify_limiters_for_cnvg_test ) &
1480 : !$acc create( Ri_zm_clipped, ddzt_umvm_sqd_clipped, &
1481 : !$acc tau_zm_unclipped, tau_zt_unclipped, Ri_zm_smooth, em_clipped, &
1482 : !$acc tmp_calc, tmp_calc_max, tmp_calc_min_max )
1483 :
1484 : ! Unpack z_displace first because it's needed for the error check
1485 0 : z_displace = clubb_params(iz_displace)
1486 :
1487 : !$acc parallel loop gang vector default(present)
1488 0 : do i = 1, ngrdcol
1489 0 : if ( gr%zm(i,1) - sfc_elevation(i) + z_displace < eps ) then
1490 0 : err_code = clubb_fatal_error
1491 : end if
1492 : end do
1493 : !$acc end parallel loop
1494 :
1495 0 : if ( clubb_at_least_debug_level(0) ) then
1496 0 : if ( err_code == clubb_fatal_error ) then
1497 0 : error stop "Lowest zm grid level is below ground in CLUBB."
1498 : end if
1499 : end if
1500 :
1501 : ! Smooth thlm by interpolating to zm then back to zt
1502 0 : smooth_thlm = zt2zm2zt( nz, ngrdcol, gr, thlm )
1503 :
1504 : call calc_brunt_vaisala_freq_sqd( nz, ngrdcol, gr, smooth_thlm, & ! intent(in)
1505 : exner, rtm, rcm, p_in_Pa, thvm, & ! intent(in)
1506 : ice_supersat_frac, & ! intent(in)
1507 : l_brunt_vaisala_freq_moist, & ! intent(in)
1508 : l_use_thvm_in_bv_freq, & ! intent(in)
1509 : clubb_params(ibv_efold), & ! intent(in)
1510 : brunt_vaisala_freq_sqd, & ! intent(out)
1511 : brunt_vaisala_freq_sqd_mixed,& ! intent(out)
1512 : brunt_vaisala_freq_sqd_dry, & ! intent(out)
1513 0 : brunt_vaisala_freq_sqd_moist ) ! intent(out)
1514 :
1515 : ! Unpack tunable parameters
1516 0 : C_invrs_tau_bkgnd = clubb_params(iC_invrs_tau_bkgnd)
1517 0 : C_invrs_tau_shear = clubb_params(iC_invrs_tau_shear)
1518 0 : C_invrs_tau_sfc = clubb_params(iC_invrs_tau_sfc)
1519 0 : C_invrs_tau_N2 = clubb_params(iC_invrs_tau_N2)
1520 0 : C_invrs_tau_N2_wp2 = clubb_params(iC_invrs_tau_N2_wp2)
1521 0 : C_invrs_tau_N2_wpxp = clubb_params(iC_invrs_tau_N2_wpxp)
1522 0 : C_invrs_tau_N2_xp2 = clubb_params(iC_invrs_tau_N2_xp2)
1523 0 : C_invrs_tau_wpxp_N2_thresh = clubb_params(iC_invrs_tau_wpxp_N2_thresh)
1524 0 : C_invrs_tau_N2_clear_wp3 = clubb_params(iC_invrs_tau_N2_clear_wp3)
1525 0 : C_invrs_tau_wpxp_Ri = clubb_params(iC_invrs_tau_wpxp_Ri)
1526 0 : altitude_threshold = clubb_params(ialtitude_threshold)
1527 0 : wpxp_Ri_exp = clubb_params(iwpxp_Ri_exp)
1528 :
1529 : if ( l_smooth_min_max ) then
1530 :
1531 : !$acc parallel loop gang vector default(present)
1532 : do i = 1, ngrdcol
1533 : ustar(i) = smooth_max( ( upwp_sfc(i)**2 + vpwp_sfc(i)**2 )**one_fourth, ufmin, min_max_smth_mag )
1534 : end do
1535 : !$acc end parallel loop
1536 :
1537 : else
1538 :
1539 : !$acc parallel loop gang vector default(present)
1540 0 : do i = 1, ngrdcol
1541 0 : ustar(i) = max( ( upwp_sfc(i)**2 + vpwp_sfc(i)**2 )**one_fourth, ufmin )
1542 : end do
1543 : !$acc end parallel loop
1544 :
1545 : end if
1546 :
1547 : !$acc parallel loop gang vector collapse(2) default(present)
1548 0 : do k = 1, nz
1549 0 : do i = 1, ngrdcol
1550 0 : invrs_tau_bkgnd(i,k) = C_invrs_tau_bkgnd / tau_const
1551 : end do
1552 : end do
1553 : !$acc end parallel loop
1554 :
1555 0 : ddzt_um = ddzt( nz, ngrdcol, gr, um )
1556 0 : ddzt_vm = ddzt( nz, ngrdcol, gr, vm )
1557 :
1558 : !$acc parallel loop gang vector collapse(2) default(present)
1559 0 : do k = 1, nz
1560 0 : do i = 1, ngrdcol
1561 0 : ddzt_umvm_sqd(i,k) = ddzt_um(i,k)**2 + ddzt_vm(i,k)**2
1562 0 : norm_ddzt_umvm(i,k) = sqrt( ddzt_umvm_sqd(i,k) )
1563 : end do
1564 : end do
1565 : !$acc end parallel loop
1566 :
1567 0 : smooth_norm_ddzt_umvm = zm2zt2zm( nz, ngrdcol, gr, norm_ddzt_umvm )
1568 :
1569 : !$acc parallel loop gang vector collapse(2) default(present)
1570 0 : do k = 1, nz
1571 0 : do i = 1, ngrdcol
1572 0 : invrs_tau_shear_smooth(i,k) = C_invrs_tau_shear * smooth_norm_ddzt_umvm(i,k)
1573 : end do
1574 : end do
1575 : !$acc end parallel loop
1576 :
1577 : ! Enforce that invrs_tau_shear is positive
1578 : invrs_tau_shear = smooth_max( nz, ngrdcol, invrs_tau_shear_smooth, &
1579 0 : zero_threshold, min_max_smth_mag )
1580 :
1581 : !$acc parallel loop gang vector collapse(2) default(present)
1582 0 : do k = 1, nz
1583 0 : do i = 1, ngrdcol
1584 0 : invrs_tau_sfc(i,k) = C_invrs_tau_sfc &
1585 0 : * ( ustar(i) / vonk ) / ( gr%zm(i,k) - sfc_elevation(i) + z_displace )
1586 : !C_invrs_tau_sfc * ( wp2 / vonk /ustar ) / ( gr%zm(1,:) -sfc_elevation + z_displace )
1587 : end do
1588 : end do
1589 : !$acc end parallel loop
1590 :
1591 : !$acc parallel loop gang vector collapse(2) default(present)
1592 0 : do k = 1, nz
1593 0 : do i = 1, ngrdcol
1594 0 : invrs_tau_no_N2_zm(i,k) = invrs_tau_bkgnd(i,k) + invrs_tau_sfc(i,k) + invrs_tau_shear(i,k)
1595 : end do
1596 : end do
1597 : !$acc end parallel loop
1598 :
1599 : !The min function below smooths the slope discontinuity in brunt freq
1600 : ! and thereby allows tau to remain large in Sc layers in which thlm may
1601 : ! be slightly stably stratified.
1602 0 : if ( l_modify_limiters_for_cnvg_test ) then
1603 :
1604 : !Remove the limiters to improve the solution convergence
1605 0 : brunt_vaisala_freq_sqd_smth = zm2zt2zm( nz,ngrdcol,gr, brunt_vaisala_freq_sqd_mixed )
1606 :
1607 : else ! default method
1608 :
1609 : if ( l_smooth_min_max ) then
1610 :
1611 : !$acc parallel loop gang vector collapse(2) default(present)
1612 : do k = 1, nz
1613 : do i = 1, ngrdcol
1614 : tmp_calc(i,k) = 1.e8_core_rknd * abs(brunt_vaisala_freq_sqd_mixed(i,k))**3
1615 : end do
1616 : end do
1617 : !$acc end parallel loop
1618 :
1619 : brunt_vaisala_freq_clipped = smooth_min( nz, ngrdcol, &
1620 : brunt_vaisala_freq_sqd_mixed, &
1621 : tmp_calc, &
1622 : 1.0e-4_core_rknd * min_max_smth_mag)
1623 :
1624 : brunt_vaisala_freq_sqd_smth = zm2zt2zm( nz, ngrdcol, gr, brunt_vaisala_freq_clipped )
1625 :
1626 : else
1627 :
1628 : !$acc parallel loop gang vector collapse(2) default(present)
1629 0 : do k = 1, nz
1630 0 : do i = 1, ngrdcol
1631 0 : brunt_vaisala_freq_clipped(i,k) = min( brunt_vaisala_freq_sqd_mixed(i,k), &
1632 0 : 1.e8_core_rknd * abs(brunt_vaisala_freq_sqd_mixed(i,k))**3)
1633 : end do
1634 : end do
1635 : !$acc end parallel loop
1636 :
1637 0 : brunt_vaisala_freq_sqd_smth = zm2zt2zm( nz, ngrdcol, gr, brunt_vaisala_freq_clipped )
1638 :
1639 : end if
1640 :
1641 : end if
1642 :
1643 0 : if ( l_modify_limiters_for_cnvg_test ) then
1644 :
1645 : !$acc parallel loop gang vector collapse(2) default(present)
1646 0 : do k = 1, nz
1647 0 : do i = 1, ngrdcol
1648 0 : Ri_zm_clipped(i,k) = max( 0.0_core_rknd, brunt_vaisala_freq_sqd_smth(i,k) ) &
1649 0 : / max( ddzt_umvm_sqd(i,k), 1.0e-12_core_rknd )
1650 : end do
1651 : end do
1652 : !$acc end parallel loop
1653 :
1654 0 : Ri_zm = zm2zt2zm( nz, ngrdcol, gr, Ri_zm_clipped )
1655 :
1656 : else ! default method
1657 :
1658 : if ( l_smooth_min_max ) then
1659 :
1660 : brunt_vaisala_freq_clipped = smooth_max( nz, ngrdcol, 1.0e-7_core_rknd, brunt_vaisala_freq_sqd_smth, &
1661 : 1.0e-4_core_rknd * min_max_smth_mag )
1662 :
1663 : ddzt_umvm_sqd_clipped = smooth_max( nz, ngrdcol, ddzt_umvm_sqd, 1.0e-7_core_rknd, &
1664 : 1.0e-6_core_rknd * min_max_smth_mag )
1665 :
1666 : !$acc parallel loop gang vector collapse(2) default(present)
1667 : do k = 1, nz
1668 : do i = 1, ngrdcol
1669 : Ri_zm(i,k) = brunt_vaisala_freq_clipped(i,k) / ddzt_umvm_sqd_clipped(i,k)
1670 : end do
1671 : end do
1672 : !$acc end parallel loop
1673 :
1674 : else
1675 :
1676 : !$acc parallel loop gang vector collapse(2) default(present)
1677 0 : do k = 1, nz
1678 0 : do i = 1, ngrdcol
1679 0 : Ri_zm(i,k) = max( 1.0e-7_core_rknd, brunt_vaisala_freq_sqd_smth(i,k) ) &
1680 0 : / max( ddzt_umvm_sqd(i,k), 1.0e-7_core_rknd )
1681 : end do
1682 : end do
1683 : !$acc end parallel loop
1684 :
1685 : end if
1686 :
1687 : end if
1688 :
1689 : if ( l_smooth_min_max ) then
1690 :
1691 : brunt_vaisala_freq_clipped = smooth_max( nz, ngrdcol, zero_threshold, &
1692 : brunt_vaisala_freq_sqd_smth, &
1693 : 1.0e-4_core_rknd * min_max_smth_mag )
1694 :
1695 : !$acc parallel loop gang vector collapse(2) default(present)
1696 : do k = 1, nz
1697 : do i = 1, ngrdcol
1698 : brunt_freq_pos(i,k) = sqrt( brunt_vaisala_freq_clipped(i,k) )
1699 : end do
1700 : end do
1701 : !$acc end parallel loop
1702 :
1703 : else
1704 :
1705 : !$acc parallel loop gang vector collapse(2) default(present)
1706 0 : do k = 1, nz
1707 0 : do i = 1, ngrdcol
1708 0 : brunt_freq_pos(i,k) = sqrt( max( zero_threshold, brunt_vaisala_freq_sqd_smth(i,k) ) )
1709 : end do
1710 : end do
1711 : !$acc end parallel loop
1712 :
1713 : end if
1714 :
1715 0 : ice_supersat_frac_zm = zt2zm( nz, ngrdcol, gr, ice_supersat_frac )
1716 :
1717 : if ( l_smooth_min_max ) then
1718 :
1719 : ! roll this back as well once checks have passed
1720 : !$acc parallel loop gang vector collapse(2) default(present)
1721 : do k = 1, nz
1722 : do i = 1, ngrdcol
1723 : tmp_calc(i,k) = one - ice_supersat_frac_zm(i,k) / 0.001_core_rknd
1724 : end do
1725 : end do
1726 : !$acc end parallel loop
1727 :
1728 : tmp_calc_max = smooth_max( nz, ngrdcol, zero_threshold, tmp_calc, &
1729 : min_max_smth_mag)
1730 :
1731 : tmp_calc_min_max = smooth_min( nz, ngrdcol, one, tmp_calc_max, &
1732 : min_max_smth_mag )
1733 :
1734 : !$acc parallel loop gang vector collapse(2) default(present)
1735 : do k = 1, nz
1736 : do i = 1, ngrdcol
1737 : brunt_freq_out_cloud(i,k) = brunt_freq_pos(i,k) * tmp_calc_min_max(i,k)
1738 : end do
1739 : end do
1740 : !$acc end parallel loop
1741 :
1742 : else
1743 :
1744 : !$acc parallel loop gang vector collapse(2) default(present)
1745 0 : do k = 1, nz
1746 0 : do i = 1, ngrdcol
1747 0 : brunt_freq_out_cloud(i,k) &
1748 : = brunt_freq_pos(i,k) &
1749 : * min(one, max(zero_threshold, &
1750 0 : one - ( ( ice_supersat_frac_zm(i,k) / 0.001_core_rknd) )))
1751 : end do
1752 : end do
1753 : !$acc end parallel loop
1754 :
1755 : end if
1756 :
1757 : !$acc parallel loop gang vector collapse(2) default(present)
1758 0 : do k = 1, nz
1759 0 : do i = 1, ngrdcol
1760 0 : if ( gr%zt(i,k) < altitude_threshold ) then
1761 0 : brunt_freq_out_cloud(i,k) = zero
1762 : end if
1763 : end do
1764 : end do
1765 : !$acc end parallel loop
1766 :
1767 : ! This time scale is used optionally for the return-to-isotropy term. It
1768 : ! omits invrs_tau_sfc based on the rationale that the isotropization
1769 : ! rate shouldn't be enhanced near the ground.
1770 : !$acc parallel loop gang vector collapse(2) default(present)
1771 0 : do k = 1, nz
1772 0 : do i = 1, ngrdcol
1773 0 : invrs_tau_N2_iso(i,k) = invrs_tau_bkgnd(i,k) + invrs_tau_shear(i,k) &
1774 0 : + C_invrs_tau_N2_wp2 * brunt_freq_pos(i,k)
1775 :
1776 : invrs_tau_wp2_zm(i,k) = invrs_tau_no_N2_zm(i,k) + &
1777 : C_invrs_tau_N2 * brunt_freq_pos(i,k) + &
1778 0 : C_invrs_tau_N2_wp2 * brunt_freq_out_cloud(i,k)
1779 :
1780 0 : invrs_tau_zm(i,k) = invrs_tau_no_N2_zm(i,k) + C_invrs_tau_N2 * brunt_freq_pos(i,k)
1781 : end do
1782 : end do
1783 : !$acc end parallel loop
1784 :
1785 :
1786 0 : if ( l_e3sm_config ) then
1787 :
1788 : !$acc parallel loop gang vector collapse(2) default(present)
1789 0 : do k = 1, nz
1790 0 : do i = 1, ngrdcol
1791 0 : invrs_tau_zm(i,k) = one_half * invrs_tau_zm(i,k)
1792 : end do
1793 : end do
1794 : !$acc end parallel loop
1795 :
1796 : !$acc parallel loop gang vector collapse(2) default(present)
1797 0 : do k = 1, nz
1798 0 : do i = 1, ngrdcol
1799 0 : invrs_tau_xp2_zm(i,k) = invrs_tau_no_N2_zm(i,k) &
1800 : + C_invrs_tau_N2_xp2 * brunt_freq_pos(i,k) & ! 0
1801 : + C_invrs_tau_sfc * two &
1802 0 : * sqrt(em(i,k)) / ( gr%zm(i,k) - sfc_elevation(i) + z_displace ) ! small
1803 : end do
1804 : end do
1805 : !$acc end parallel loop
1806 :
1807 : if ( l_smooth_min_max ) then
1808 :
1809 : brunt_vaisala_freq_clipped = smooth_max( nz, ngrdcol, 1.0e-7_core_rknd, &
1810 : brunt_vaisala_freq_sqd_smth, &
1811 : 1.0e-4_core_rknd * min_max_smth_mag )
1812 :
1813 : !$acc parallel loop gang vector collapse(2) default(present)
1814 : do k = 1, nz
1815 : do i = 1, ngrdcol
1816 : tmp_calc(i,k) = sqrt( ddzt_umvm_sqd(i,k) / brunt_vaisala_freq_clipped(i,k) )
1817 : end do
1818 : end do
1819 : !$acc end parallel loop
1820 :
1821 : tmp_calc_max = smooth_max( nz, ngrdcol, tmp_calc, &
1822 : 0.3_core_rknd, 0.3_core_rknd * min_max_smth_mag )
1823 :
1824 : tmp_calc_min_max = smooth_min( nz, ngrdcol, tmp_calc_max, &
1825 : one, min_max_smth_mag )
1826 :
1827 : !$acc parallel loop gang vector collapse(2) default(present)
1828 : do k = 1, nz
1829 : do i = 1, ngrdcol
1830 : invrs_tau_xp2_zm(i,k) = tmp_calc_min_max(i,k) * invrs_tau_xp2_zm(i,k)
1831 : end do
1832 : end do
1833 : !$acc end parallel loop
1834 :
1835 : else
1836 :
1837 : !$acc parallel loop gang vector collapse(2) default(present)
1838 0 : do k = 1, nz
1839 0 : do i = 1, ngrdcol
1840 0 : invrs_tau_xp2_zm(i,k) &
1841 : = min( max( sqrt( ddzt_umvm_sqd(i,k) &
1842 : / max( 1.0e-7_core_rknd, brunt_vaisala_freq_sqd_smth(i,k) ) ), &
1843 : 0.3_core_rknd ), one ) &
1844 0 : * invrs_tau_xp2_zm(i,k)
1845 : end do
1846 : end do
1847 : !$acc end parallel loop
1848 :
1849 : end if
1850 :
1851 : !$acc parallel loop gang vector collapse(2) default(present)
1852 0 : do k = 1, nz
1853 0 : do i = 1, ngrdcol
1854 0 : invrs_tau_wpxp_zm(i,k) = two * invrs_tau_zm(i,k) &
1855 0 : + C_invrs_tau_N2_wpxp * brunt_freq_out_cloud(i,k)
1856 : end do
1857 : end do
1858 : !$acc end parallel loop
1859 :
1860 : else ! l_e3sm_config = false
1861 :
1862 : !$acc parallel loop gang vector collapse(2) default(present)
1863 0 : do k = 1, nz
1864 0 : do i = 1, ngrdcol
1865 0 : invrs_tau_xp2_zm(i,k) = invrs_tau_no_N2_zm(i,k) + &
1866 : C_invrs_tau_N2 * brunt_freq_pos(i,k) + &
1867 0 : C_invrs_tau_N2_xp2 * brunt_freq_out_cloud(i,k)
1868 : end do
1869 : end do
1870 : !$acc end parallel loop
1871 :
1872 0 : ice_supersat_frac_zm = zt2zm( nz, ngrdcol, gr, ice_supersat_frac )
1873 :
1874 : ! !$acc parallel loop gang vector collapse(2) default(present)
1875 : ! do k = 1, nz
1876 : ! do i = 1, ngrdcol
1877 : ! if ( ice_supersat_frac_zm(i,k) <= 0.01_core_rknd &
1878 : ! .and. invrs_tau_xp2_zm(i,k) >= 0.003_core_rknd ) then
1879 : ! invrs_tau_xp2_zm(i,k) = 0.003_core_rknd
1880 : ! end if
1881 : ! end do
1882 : ! end do
1883 : ! !$acc end parallel loop
1884 :
1885 : !$acc parallel loop gang vector collapse(2) default(present)
1886 0 : do k = 1, nz
1887 0 : do i = 1, ngrdcol
1888 0 : invrs_tau_wpxp_zm(i,k) = invrs_tau_no_N2_zm(i,k) + &
1889 : C_invrs_tau_N2 * brunt_freq_pos(i,k) + &
1890 0 : C_invrs_tau_N2_wpxp * brunt_freq_out_cloud(i,k)
1891 : end do
1892 : end do
1893 : !$acc end parallel loop
1894 :
1895 : end if ! l_e3sm_config
1896 :
1897 0 : if ( l_smooth_Heaviside_tau_wpxp ) then
1898 :
1899 : !$acc parallel loop gang vector collapse(2) default(present)
1900 0 : do k = 1, nz
1901 0 : do i = 1, ngrdcol
1902 0 : bvf_thresh(i,k) = brunt_vaisala_freq_sqd_smth(i,k) / C_invrs_tau_wpxp_N2_thresh - one
1903 : end do
1904 : end do
1905 : !$acc end parallel loop
1906 :
1907 0 : H_invrs_tau_wpxp_N2 = smooth_heaviside_peskin( nz, ngrdcol, bvf_thresh, heaviside_smth_range )
1908 :
1909 : else ! l_smooth_Heaviside_tau_wpxp = .false.
1910 :
1911 : !$acc parallel loop gang vector collapse(2) default(present)
1912 0 : do k = 1, nz
1913 0 : do i = 1, ngrdcol
1914 0 : if ( brunt_vaisala_freq_sqd_smth(i,k) > C_invrs_tau_wpxp_N2_thresh ) then
1915 0 : H_invrs_tau_wpxp_N2(i,k) = one
1916 : else
1917 0 : H_invrs_tau_wpxp_N2(i,k) = zero
1918 : end if
1919 : end do
1920 : end do
1921 : !$acc end parallel loop
1922 :
1923 : end if ! l_smooth_Heaviside_tau_wpxp
1924 :
1925 : if ( l_smooth_min_max ) then
1926 :
1927 : Ri_zm_smooth = smooth_max( nz, ngrdcol, Ri_zm, zero, &
1928 : 2.0_core_rknd * min_max_smth_mag )
1929 :
1930 : Ri_zm_smooth = smooth_min( nz, ngrdcol, C_invrs_tau_wpxp_Ri * Ri_zm_smooth**wpxp_Ri_exp, &
1931 : 2.0_core_rknd, 2.0_core_rknd * min_max_smth_mag )
1932 :
1933 : !$acc parallel loop gang vector collapse(2) default(present)
1934 : do k = 1, nz
1935 : do i = 1, ngrdcol
1936 :
1937 : if ( gr%zt(i,k) > altitude_threshold ) then
1938 : invrs_tau_wpxp_zm(i,k) = invrs_tau_wpxp_zm(i,k) &
1939 : * ( one + H_invrs_tau_wpxp_N2(i,k) &
1940 : * Ri_zm_smooth(i,k) )
1941 :
1942 : end if
1943 : end do
1944 : end do
1945 : !$acc end parallel loop
1946 :
1947 : else ! l_smooth_min_max
1948 :
1949 : !$acc parallel loop gang vector collapse(2) default(present)
1950 0 : do k = 1, nz
1951 0 : do i = 1, ngrdcol
1952 0 : if ( gr%zt(i,k) > altitude_threshold ) then
1953 0 : invrs_tau_wpxp_zm(i,k) = invrs_tau_wpxp_zm(i,k) &
1954 : * ( one + H_invrs_tau_wpxp_N2(i,k) &
1955 : * min( C_invrs_tau_wpxp_Ri &
1956 0 : * max( Ri_zm(i,k), zero)**wpxp_Ri_exp, 2.0_core_rknd ))
1957 : end if
1958 : end do
1959 : end do
1960 : !$acc end parallel loop
1961 :
1962 : end if
1963 :
1964 : !$acc parallel loop gang vector collapse(2) default(present)
1965 0 : do k = 1, nz
1966 0 : do i = 1, ngrdcol
1967 0 : invrs_tau_wp3_zm(i,k) = invrs_tau_wp2_zm(i,k) &
1968 0 : + C_invrs_tau_N2_clear_wp3 * brunt_freq_out_cloud(i,k)
1969 : end do
1970 : end do
1971 : !$acc end parallel loop
1972 :
1973 : ! Calculate the maximum allowable value of time-scale tau,
1974 : ! which depends of the value of Lscale_max.
1975 : if ( l_smooth_min_max ) then
1976 :
1977 : em_clipped = smooth_max( nz, ngrdcol, em, em_min, min_max_smth_mag )
1978 :
1979 : !$acc parallel loop gang vector collapse(2) default(present)
1980 : do k = 1, nz
1981 : do i = 1, ngrdcol
1982 : tau_max_zt(i,k) = Lscale_max(i) / sqrt_em_zt(i,k)
1983 : tau_max_zm(i,k) = Lscale_max(i) / sqrt( em_clipped(i,k) )
1984 : end do
1985 : end do
1986 : !$acc end parallel loop
1987 :
1988 : else
1989 :
1990 : !$acc parallel loop gang vector collapse(2) default(present)
1991 0 : do k = 1, nz
1992 0 : do i = 1, ngrdcol
1993 0 : tau_max_zt(i,k) = Lscale_max(i) / sqrt_em_zt(i,k)
1994 0 : tau_max_zm(i,k) = Lscale_max(i) / sqrt( max( em(i,k), em_min ) )
1995 : end do
1996 : end do
1997 : !$acc end parallel loop
1998 :
1999 : end if
2000 :
2001 : if ( l_smooth_min_max ) then
2002 :
2003 : !$acc parallel loop gang vector collapse(2) default(present)
2004 : do k = 1, nz
2005 : do i = 1, ngrdcol
2006 : tau_zm_unclipped(i,k) = one / invrs_tau_zm(i,k)
2007 : end do
2008 : end do
2009 : !$acc end parallel loop
2010 :
2011 : tau_zm = smooth_min( nz, ngrdcol, tau_zm_unclipped, &
2012 : tau_max_zm, 1.0e3_core_rknd * min_max_smth_mag )
2013 :
2014 : tau_zt_unclipped = zm2zt( nz, ngrdcol, gr, tau_zm )
2015 :
2016 : tau_zt = smooth_min( nz, ngrdcol, tau_zt_unclipped, tau_max_zt, 1.0e3_core_rknd * min_max_smth_mag )
2017 :
2018 : else
2019 :
2020 : !$acc parallel loop gang vector collapse(2) default(present)
2021 0 : do k = 1, nz
2022 0 : do i = 1, ngrdcol
2023 0 : tau_zm(i,k) = min( one / invrs_tau_zm(i,k), tau_max_zm(i,k) )
2024 : end do
2025 : end do
2026 : !$acc end parallel loop
2027 :
2028 0 : tau_zt = zm2zt( nz, ngrdcol, gr, tau_zm )
2029 :
2030 : !$acc parallel loop gang vector collapse(2) default(present)
2031 0 : do k = 1, nz
2032 0 : do i = 1, ngrdcol
2033 0 : tau_zt(i,k) = min( tau_zt(i,k), tau_max_zt(i,k) )
2034 : end do
2035 : end do
2036 : !$acc end parallel loop
2037 :
2038 : end if
2039 :
2040 0 : invrs_tau_zt = zm2zt( nz, ngrdcol, gr, invrs_tau_zm )
2041 0 : invrs_tau_wp3_zt = zm2zt( nz, ngrdcol, gr, invrs_tau_wp3_zm )
2042 :
2043 : !$acc parallel loop gang vector collapse(2) default(present)
2044 0 : do k = 1, nz
2045 0 : do i = 1, ngrdcol
2046 :
2047 0 : Lscale(i,k) = tau_zt(i,k) * sqrt_em_zt(i,k)
2048 :
2049 : ! Lscale_up and Lscale_down aren't calculated with this option.
2050 : ! They are set to 0 for stats output.
2051 0 : Lscale_up(i,k) = zero
2052 0 : Lscale_down(i,k) = zero
2053 :
2054 : end do
2055 : end do
2056 : !$acc end parallel loop
2057 :
2058 : !$acc exit data delete( brunt_freq_pos, brunt_vaisala_freq_sqd_smth, brunt_freq_out_cloud, &
2059 : !$acc smooth_thlm, bvf_thresh, H_invrs_tau_wpxp_N2, ustar, &
2060 : !$acc ddzt_um, ddzt_vm, norm_ddzt_umvm, smooth_norm_ddzt_umvm, &
2061 : !$acc brunt_vaisala_freq_clipped, &
2062 : !$acc ice_supersat_frac_zm, invrs_tau_shear_smooth, &
2063 : !$acc ddzt_umvm_sqd, tau_zt )
2064 :
2065 : !$acc exit data if( l_smooth_min_max .or. l_modify_limiters_for_cnvg_test ) &
2066 : !$acc delete( Ri_zm_clipped, ddzt_umvm_sqd_clipped, &
2067 : !$acc tau_zm_unclipped, tau_zt_unclipped, Ri_zm_smooth, em_clipped, &
2068 : !$acc tmp_calc, tmp_calc_max, tmp_calc_min_max )
2069 :
2070 0 : return
2071 :
2072 : end subroutine diagnose_Lscale_from_tau
2073 :
2074 : end module mixing_length
|