LCOV - code coverage report
Current view: top level - physics/clubb/src/CLUBB_core - mixing_length.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 177 399 44.4 %
Date: 2025-03-13 18:42:46 Functions: 2 3 66.7 %

          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

Generated by: LCOV version 1.14