LCOV - code coverage report
Current view: top level - physics/clubb/src/CLUBB_core - mono_flux_limiter.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 263 315 83.5 %
Date: 2025-03-13 18:42:46 Functions: 7 7 100.0 %

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

Generated by: LCOV version 1.14