LCOV - code coverage report
Current view: | top level - physics/pumas - micro_pumas_v1.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 1615 | 1930 | 83.7 %
Date: | 2024-12-17 17:57:11 |  | Functions: | 5 | 7 | 71.4 %

              Line data    Source code
           1             : module micro_pumas_v1
           2             : !---------------------------------------------------------------------------------
           3             : ! Parameterization of Unified Microphysics Across Scales version 1 (PUMASv1)
           4             : !
           5             : ! References:
           6             : !
           7             : !           Gettelman, A., H. Morrison, T. Eidhammer, K. Thayer-Calder, J. Sun,
           8             : !
           9             : !           R. Forbes, Z. McGraw, J. Zhu, T. Storelvmo, and J. Dennis (2023):
          10             : !
          11             : !           Importance of Ice Nucleation and Precipitation on Climate with the
          12             : !
          13             : !           Parameterization of Unified Microphysics Across Scales version 1
          14             : !
          15             : !           (PUMASv1). Geosci. Model Dev., 16, 1735-1754.
          16             : !
          17             : !           https://doi.org/10.5194/gmd-16-1735-2023
          18             : !
          19             : !
          20             : ! for questions contact Hugh Morrison, Andrew Gettelman
          21             : ! e-mail: morrison@ucar.edu, andrew@ucar.edu
          22             : !---------------------------------------------------------------------------------
          23             : !
          24             : ! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice
          25             : ! microphysics in cooperation with the MG liquid microphysics. This is
          26             : ! controlled by the do_cldice variable.
          27             : !
          28             : ! If do_cldice is false, then MG microphysics should not update CLDICE or
          29             : ! NUMICE; it is assumed that the other microphysics scheme will have updated
          30             : ! CLDICE and NUMICE. The other microphysics should handle the following
          31             : ! processes that would have been done by MG:
          32             : !   - Detrainment (liquid and ice)
          33             : !   - Homogeneous ice nucleation
          34             : !   - Heterogeneous ice nucleation
          35             : !   - Bergeron process
          36             : !   - Melting of ice
          37             : !   - Freezing of cloud drops
          38             : !   - Autoconversion (ice -> snow)
          39             : !   - Growth/Sublimation of ice
          40             : !   - Sedimentation of ice
          41             : !
          42             : ! This option has not been updated since the introduction of prognostic
          43             : ! precipitation, and probably should be adjusted to cover snow as well.
          44             : !
          45             : !---------------------------------------------------------------------------------
          46             : ! Version 3.O based on micro_mg2_0.F90 and WRF3.8.1 module_mp_morr_two_moment.F
          47             : !---------------------------------------------------------------------------------
          48             : ! Based on micro_mg (restructuring of former cldwat2m_micro)
          49             : ! Author: Andrew Gettelman, Hugh Morrison.
          50             : ! Contributions from: Xiaohong Liu and Steve Ghan
          51             : ! December 2005-May 2010
          52             : ! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008)
          53             : !                 Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010)
          54             : ! for questions contact Hugh Morrison, Andrew Gettelman
          55             : ! e-mail: morrison@ucar.edu, andrew@ucar.edu
          56             : !---------------------------------------------------------------------------------
          57             : ! Code comments added by HM, 093011
          58             : ! General code structure:
          59             : !
          60             : ! Code is divided into two main subroutines:
          61             : !   subroutine micro_pumas_init --> initializes microphysics routine, should be called
          62             : !                                  once at start of simulation
          63             : !   subroutine micro_pumas_tend --> main microphysics routine to be called each time step
          64             : !                                this also calls several smaller subroutines to calculate
          65             : !                                microphysical processes and other utilities
          66             : !
          67             : ! List of external functions:
          68             : !   qsat_water --> for calculating saturation vapor pressure with respect to liquid water
          69             : !   qsat_ice --> for calculating saturation vapor pressure with respect to ice
          70             : !   gamma   --> standard mathematical gamma function
          71             : ! .........................................................................
          72             : ! List of inputs through use statement in fortran90:
          73             : ! Variable Name                      Description                Units
          74             : ! .........................................................................
          75             : ! gravit          acceleration due to gravity                    m s-2
          76             : ! rair            dry air gas constant for air                  J kg-1 K-1
          77             : ! tmelt           temperature of melting point for water          K
          78             : ! cpair           specific heat at constant pressure for dry air J kg-1 K-1
          79             : ! rh2o            gas constant for water vapor                  J kg-1 K-1
          80             : ! latvap          latent heat of vaporization                   J kg-1
          81             : ! latice          latent heat of fusion                         J kg-1
          82             : ! qsat_water      external function for calculating liquid water
          83             : !                 saturation vapor pressure/humidity              -
          84             : ! qsat_ice        external function for calculating ice
          85             : !                 saturation vapor pressure/humidity              pa
          86             : ! rhmini          relative humidity threshold parameter for
          87             : !                 nucleating ice                                  -
          88             : ! .........................................................................
          89             : ! NOTE: List of all inputs/outputs passed through the call/subroutine statement
          90             : !       for micro_pumas_tend is given below at the start of subroutine micro_pumas_tend.
          91             : !---------------------------------------------------------------------------------
          92             :
          93             : ! Procedures required:
          94             : ! 1) An implementation of the gamma function (if not intrinsic).
          95             : ! 2) saturation vapor pressure and specific humidity over water
          96             : ! 3) svp over ice
          97             :
          98             : #ifndef HAVE_GAMMA_INTRINSICS
          99             : use shr_spfn_mod, only: gamma => shr_spfn_gamma
         100             : #endif
         101             :
         102             : use wv_sat_methods, only: &
         103             :      qsat_water => wv_sat_qsat_water_vect, &
         104             :      qsat_ice => wv_sat_qsat_ice_vect
         105             :
         106             : ! Parameters from the utilities module.
         107             : use micro_pumas_utils, only: &
         108             :      r8, &
         109             :      pi, &
         110             :      omsm, &
         111             :      qsmall, &
         112             :      mincld, &
         113             :      rhosn, &
         114             :      rhoi, &
         115             :      rhow, &
         116             :      rhows, &
         117             :      ac, bc, &
         118             :      ai, bi, &
         119             :      aj, bj, &
         120             :      ar, br, &
         121             :      as, bs, &
         122             :      ag, bg, &
         123             :      ah, bh, &
         124             :      rhog,rhoh, &
         125             :      mi0, &
         126             :      rising_factorial, &
         127             :      VLENS
         128             :
         129             : implicit none
         130             : private
         131             : save
         132             :
         133             : public :: &
         134             :      micro_pumas_init, &
         135             :      micro_pumas_get_cols, &
         136             :      micro_pumas_tend
         137             :
         138             : ! Switches for specification rather than prediction of droplet and crystal number
         139             : ! note: number will be adjusted as needed to keep mean size within bounds,
         140             : ! even when specified droplet or ice number is used
         141             : !
         142             : ! If constant cloud ice number is set (nicons = .true.),
         143             : ! then all microphysical processes except mass transfer due to ice nucleation
         144             : ! (mnuccd) are based on the fixed cloud ice number. Calculation of
         145             : ! mnuccd follows from the prognosed ice crystal number ni.
         146             :
         147             : logical :: nccons ! nccons = .true. to specify constant cloud droplet number
         148             : logical :: nicons ! nicons = .true. to specify constant cloud ice number
         149             : logical :: ngcons ! ngcons = .true. to specify constant graupel number
         150             : logical :: nrcons ! constant rain number
         151             : logical :: nscons ! constant snow number
         152             :
         153             : ! specified ice and droplet number concentrations
         154             : ! note: these are local in-cloud values, not grid-mean
         155             : real(r8) :: ncnst  ! droplet num concentration when nccons=.true. (m-3)
         156             : real(r8) :: ninst  ! ice num concentration when nicons=.true. (m-3)
         157             : real(r8) :: ngnst   ! graupel num concentration when ngcons=.true. (m-3)
         158             : real(r8) :: nrnst
         159             : real(r8) :: nsnst
         160             :
         161             : ! IFS Switches....
         162             : ! Switch to turn off evaporation of sedimenting condensate
         163             : ! Found to interact badly in some models with diagnostic cloud fraction
         164             : logical :: evap_sed_off
         165             :
         166             : ! Remove RH conditional from ice nucleation
         167             : logical :: icenuc_rh_off
         168             :
         169             : ! Internally: Meyers Ice Nucleation
         170             : logical :: icenuc_use_meyers
         171             :
         172             : ! Scale evaporation as IFS does (*0.3)
         173             : logical :: evap_scl_ifs
         174             :
         175             : ! Evap RH threhold following ifs
         176             : logical :: evap_rhthrsh_ifs
         177             :
         178             : ! Rain freezing at 0C following ifs
         179             :
         180             : logical :: rainfreeze_ifs
         181             :
         182             : ! Snow sedimentation = 1 m/s
         183             :
         184             : logical :: ifs_sed
         185             :
         186             : ! Precipitation fall speed, prevent zero velocity if precip above
         187             :
         188             : logical :: precip_fall_corr
         189             :
         190             : !--ag
         191             :
         192             : !=========================================================
         193             : ! Private module parameters
         194             : !=========================================================
         195             :
         196             : !Range of cloudsat reflectivities (dBz) for analytic simulator
         197             : real(r8), parameter :: csmin = -30._r8
         198             : real(r8), parameter :: csmax = 26._r8
         199             : real(r8), parameter :: mindbz = -99._r8
         200             : real(r8), parameter :: minrefl = 1.26e-10_r8    ! minrefl = 10._r8**(mindbz/10._r8)
         201             :
         202             : integer, parameter  :: MG_PRECIP_FRAC_INCLOUD = 101
         203             : integer, parameter  :: MG_PRECIP_FRAC_OVERLAP = 102
         204             :
         205             : ! Reflectivity min for 10cm (Rain) radar reflectivity
         206             : real(r8), parameter :: minrefl10 = 1.e-26_r8
         207             :
         208             : ! autoconversion size threshold for cloud ice to snow (m)
         209             : real(r8) :: dcs
         210             :
         211             : ! minimum mass of new crystal due to freezing of cloud droplets done
         212             : ! externally (kg)
         213             : real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3
         214             :
         215             : ! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation.
         216             : real(r8), parameter :: sublim_factor =0.0_r8      !number sublimation factor.
         217             :
         218             : ! Parameters related to GPU computing
         219             : integer, parameter :: RQUEUE = 101    ! GPU stream ID for rain
         220             : integer, parameter :: SQUEUE = 102    ! GPU stream ID for snow
         221             : integer, parameter :: LQUEUE = 103    ! GPU stream ID for liquid
         222             : integer, parameter :: IQUEUE = 104    ! GPU stream ID for ice
         223             : integer, parameter :: GQUEUE = 105    ! GPU stream ID for hail/graupel
         224             :
         225             : !=========================================================
         226             : ! Constants set in initialization
         227             : !=========================================================
         228             :
         229             : ! Set using arguments to micro_pumas_init
         230             : real(r8) :: g           ! gravity
         231             : real(r8) :: r           ! dry air gas constant
         232             : real(r8) :: rv          ! water vapor gas constant
         233             : real(r8) :: cpp         ! specific heat of dry air
         234             : real(r8) :: tmelt       ! freezing point of water (K)
         235             :
         236             : ! latent heats of:
         237             : real(r8) :: xxlv        ! vaporization
         238             : real(r8) :: xlf         ! freezing
         239             : real(r8) :: xxls        ! sublimation
         240             :
         241             : real(r8) :: rhmini      ! Minimum rh for ice cloud fraction > 0.
         242             :
         243             : ! flags
         244             : logical :: microp_uniform
         245             : logical :: do_cldice
         246             : logical :: use_hetfrz_classnuc
         247             : logical :: do_hail
         248             : logical :: do_graupel
         249             :
         250             : real(r8) :: rhosu       ! typical 850mn air density
         251             :
         252             : real(r8) :: icenuct     ! ice nucleation temperature: currently -5 degrees C
         253             :
         254             : real(r8) :: snowmelt    ! what temp to melt all snow: currently 2 degrees C
         255             : real(r8) :: rainfrze    ! what temp to freeze all rain: currently -5 degrees C
         256             :
         257             : ! additional constants to help speed up code
         258             : real(r8) :: gamma_br_plus1
         259             : real(r8) :: gamma_br_plus4
         260             : real(r8) :: gamma_bs_plus1
         261             : real(r8) :: gamma_bs_plus4
         262             : real(r8) :: gamma_bi_plus1
         263             : real(r8) :: gamma_bi_plus4
         264             : real(r8) :: gamma_bj_plus1
         265             : real(r8) :: gamma_bj_plus4
         266             : real(r8) :: gamma_bg_plus1
         267             : real(r8) :: gamma_bg_plus4
         268             : real(r8) :: xxlv_squared
         269             : real(r8) :: xxls_squared
         270             :
         271             : character(len=16)  :: micro_mg_precip_frac_method  ! type of precipitation fraction method
         272             : real(r8)           :: micro_mg_berg_eff_factor     ! berg efficiency factor
         273             :
         274             : real(r8)           :: micro_mg_accre_enhan_fact     ! accretion enhancment factor
         275             : real(r8)           :: micro_mg_autocon_fact     ! autoconversion prefactor
         276             : real(r8)           :: micro_mg_autocon_nd_exp     ! autoconversion Nd exponent factor
         277             : real(r8)           :: micro_mg_autocon_lwp_exp  !autoconversion LWP exponent
         278             : real(r8)           :: micro_mg_homog_size ! size of freezing homogeneous ice
         279             : real(r8)           :: micro_mg_vtrmi_factor
         280             : real(r8)           :: micro_mg_vtrms_factor
         281             : real(r8)           :: micro_mg_effi_factor
         282             : real(r8)           :: micro_mg_iaccr_factor
         283             : real(r8)           :: micro_mg_max_nicons
         284             :
         285             : logical            :: remove_supersat      ! If true, remove supersaturation after sedimentation loop
         286             : character(len=16)  :: warm_rain            ! 'tau','emulated','sb2001' or 'kk2000'
         287             :
         288             : !Parameters for Implicit Sedimentation Calculation
         289             : real(r8), parameter :: vfactor = 1.0        ! Rain/Snow/Graupel Factor
         290             : real(r8), parameter :: vfac_drop = 1.0      ! Cloud Liquid Factor
         291             : real(r8), parameter :: vfac_ice  = 1.0      ! Cloud Ice Factor
         292             :
         293             : logical           :: do_implicit_fall !   = .true.
         294             :
         295             : logical           :: accre_sees_auto  != .true.
         296             :
         297             : !$acc declare create (nccons,nicons,ngcons,nrcons,nscons,ncnst,ninst,ngnst,    &
         298             : !$acc                 nrnst,nsnst,evap_sed_off,icenuc_rh_off,evap_scl_ifs,     &
         299             : !$acc                 icenuc_use_meyers,evap_rhthrsh_ifs,rainfreeze_ifs,       &
         300             : !$acc                 ifs_sed,precip_fall_corr,dcs,                            &
         301             : !$acc                 g,r,rv,cpp,tmelt,xxlv,xlf,xxls,rhmini,microp_uniform,    &
         302             : !$acc                 do_cldice,use_hetfrz_classnuc,do_hail,do_graupel,rhosu,  &
         303             : !$acc                 icenuct,snowmelt,rainfrze,xxlv_squared,xxls_squared,     &
         304             : !$acc                 gamma_br_plus1,gamma_br_plus4,gamma_bs_plus1,            &
         305             : !$acc                 gamma_bs_plus4,gamma_bi_plus1,gamma_bi_plus4,            &
         306             : !$acc                 gamma_bj_plus1,gamma_bj_plus4,gamma_bg_plus1,            &
         307             : !$acc                 gamma_bg_plus4,micro_mg_berg_eff_factor,                 &
         308             : !$acc                 micro_mg_accre_enhan_fact,micro_mg_autocon_fact,         &
         309             : !$acc                 micro_mg_autocon_nd_exp,micro_mg_autocon_lwp_exp,        &
         310             : !$acc                 micro_mg_homog_size,micro_mg_vtrmi_factor,               &
         311             : !$acc                 micro_mg_vtrms_factor,                                   &
         312             : !$acc                 micro_mg_effi_factor,micro_mg_iaccr_factor,              &
         313             : !$acc                 micro_mg_max_nicons,remove_supersat,do_implicit_fall,    &
         314             : !$acc                 accre_sees_auto)
         315             :
         316             : !===============================================================================
         317             : contains
         318             : !===============================================================================
         319             :
         320        1536 : subroutine micro_pumas_init( &
         321             :      kind, gravit, rair, rh2o, cpair,    &
         322             :      tmelt_in, latvap, latice,           &
         323             :      rhmini_in, micro_mg_dcs,            &
         324             :      micro_mg_do_hail_in,micro_mg_do_graupel_in, &
         325             :      microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, &
         326           0 :      micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, &
         327             :      micro_mg_accre_enhan_fact_in, micro_mg_autocon_fact_in, &
         328             :      micro_mg_autocon_nd_exp_in, micro_mg_autocon_lwp_exp_in, micro_mg_homog_size_in, &
         329             :      micro_mg_vtrmi_factor_in, micro_mg_vtrms_factor_in, micro_mg_effi_factor_in, &
         330             :      micro_mg_iaccr_factor_in, micro_mg_max_nicons_in, &
         331             :      remove_supersat_in, warm_rain_in, &
         332             :      micro_mg_evap_sed_off_in, micro_mg_icenuc_rh_off_in, micro_mg_icenuc_use_meyers_in, &
         333             :      micro_mg_evap_scl_ifs_in, micro_mg_evap_rhthrsh_ifs_in, &
         334             :      micro_mg_rainfreeze_ifs_in,  micro_mg_ifs_sed_in, micro_mg_precip_fall_corr, &
         335             :      micro_mg_accre_sees_auto_in, micro_mg_implicit_fall_in, &
         336             :      nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in, &
         337             :      nrcons_in, nrnst_in, nscons_in, nsnst_in, &
         338             :      stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, &
         339             :      stochastic_emulated_filename_output_scale, &
         340        1536 :      iulog, errstring)
         341             :
         342             :   use micro_pumas_utils, only: micro_pumas_utils_init
         343             :   use pumas_stochastic_collect_tau, only: pumas_stochastic_kernel_init
         344             :   use tau_neural_net_quantile, only:  initialize_tau_emulators
         345             :
         346             :   !-----------------------------------------------------------------------
         347             :   !
         348             :   ! Purpose:
         349             :   ! initialize constants for MG microphysics
         350             :   !
         351             :   ! Author: Andrew Gettelman Dec 2005
         352             :   !
         353             :   !-----------------------------------------------------------------------
         354             :
         355             :   integer,  intent(in)  :: kind         ! Kind used for reals
         356             :   real(r8), intent(in)  :: gravit
         357             :   real(r8), intent(in)  :: rair
         358             :   real(r8), intent(in)  :: rh2o
         359             :   real(r8), intent(in)  :: cpair
         360             :   real(r8), intent(in)  :: tmelt_in     ! Freezing point of water (K)
         361             :   real(r8), intent(in)  :: latvap
         362             :   real(r8), intent(in)  :: latice
         363             :   real(r8), intent(in)  :: rhmini_in    ! Minimum rh for ice cloud fraction > 0.
         364             :   real(r8), intent(in)  :: micro_mg_dcs
         365             :
         366             : !MG3 dense precipitating ice. Note, only 1 can be true, or both false.
         367             :   logical,  intent(in)  :: micro_mg_do_graupel_in    ! .true. = configure with graupel
         368             :                                                    ! .false. = no graupel (hail possible)
         369             :   logical,  intent(in)  :: micro_mg_do_hail_in    ! .true. = configure with hail
         370             :                                                    ! .false. = no hail (graupel possible)
         371             :   logical,  intent(in)  :: microp_uniform_in    ! .true. = configure uniform for sub-columns
         372             :                                             ! .false. = use w/o sub-columns (standard)
         373             :   logical,  intent(in)  :: do_cldice_in     ! .true. = do all processes (standard)
         374             :                                             ! .false. = skip all processes affecting
         375             :                                             !           cloud ice
         376             :   logical,  intent(in)  :: use_hetfrz_classnuc_in ! use heterogeneous freezing
         377             :
         378             :   character(len=16),intent(in)  :: micro_mg_precip_frac_method_in  ! type of precipitation fraction method
         379             :   real(r8),         intent(in)  :: micro_mg_berg_eff_factor_in     ! berg efficiency factor
         380             :   real(r8),         intent(in)  :: micro_mg_accre_enhan_fact_in     !accretion enhancment factor
         381             :   real(r8),         intent(in) ::  micro_mg_autocon_fact_in    !autconversion prefactor
         382             :   real(r8),         intent(in) ::  micro_mg_autocon_nd_exp_in !autconversion exponent factor
         383             :   real(r8),         intent(in) ::  micro_mg_autocon_lwp_exp_in    !autconversion exponent factor
         384             :   real(r8),         intent(in) ::  micro_mg_homog_size_in  ! size of homoegenous freezing ice
         385             :   real(r8),         intent(in)  :: micro_mg_vtrmi_factor_in    !factor for ice fall velocity
         386             :   real(r8),         intent(in)  :: micro_mg_vtrms_factor_in    !factor for snow fall velocity
         387             :   real(r8),         intent(in)  :: micro_mg_effi_factor_in    !factor for ice effective radius
         388             :   real(r8),         intent(in)  :: micro_mg_iaccr_factor_in  ! ice accretion factor
         389             :   real(r8),         intent(in)  :: micro_mg_max_nicons_in ! maximum number ice crystal allowed
         390             :
         391             :   logical,  intent(in)  ::  remove_supersat_in ! If true, remove supersaturation after sedimentation loop
         392             :   character(len=*),  intent(in)  ::  warm_rain_in
         393             :
         394             : ! IFS-like Switches
         395             :
         396             :   logical, intent(in) :: micro_mg_evap_sed_off_in ! Turn off evaporation/sublimation based on cloud fraction for sedimenting condensate
         397             :
         398             :   logical, intent(in) :: micro_mg_icenuc_rh_off_in ! Remove RH conditional from ice nucleation
         399             :   logical, intent(in) :: micro_mg_icenuc_use_meyers_in ! Internally: Meyers Ice Nucleation
         400             :   logical, intent(in) :: micro_mg_evap_scl_ifs_in ! Scale evaporation as IFS does (*0.3)
         401             :   logical, intent(in) :: micro_mg_evap_rhthrsh_ifs_in ! Evap RH threhold following ifs
         402             :   logical, intent(in) :: micro_mg_rainfreeze_ifs_in ! Rain freezing temp following ifs
         403             :   logical, intent(in) :: micro_mg_ifs_sed_in ! snow sedimentation = 1m/s following ifs
         404             :   logical, intent(in) :: micro_mg_precip_fall_corr ! ensure rain fall speed non-zero if rain above in column
         405             :
         406             :   logical, intent(in) :: micro_mg_accre_sees_auto_in ! autoconverted rain is passed to accretion
         407             :
         408             :   logical, intent(in) :: micro_mg_implicit_fall_in !Implicit fall speed (sedimentation) calculation for hydrometors
         409             :
         410             :
         411             :
         412             :   logical, intent(in)   :: nccons_in
         413             :   logical, intent(in)   :: nicons_in
         414             :   real(r8), intent(in)  :: ncnst_in
         415             :   real(r8), intent(in)  :: ninst_in
         416             :
         417             :   logical, intent(in)   :: ngcons_in
         418             :   real(r8), intent(in)  :: ngnst_in
         419             :   logical, intent(in)   :: nrcons_in
         420             :   real(r8), intent(in)  :: nrnst_in
         421             :   logical, intent(in)   :: nscons_in
         422             :   real(r8), intent(in)  :: nsnst_in
         423             :
         424             :   character(len=*), intent(in) :: stochastic_emulated_filename_quantile, &
         425             :                                   stochastic_emulated_filename_input_scale, &
         426             :                                   stochastic_emulated_filename_output_scale ! Files for emulated machine learning
         427             :
         428             :   integer, intent(in) :: iulog
         429             :   character(128), intent(out) :: errstring    ! Output status (non-blank for error return)
         430             :
         431             :   !-----------------------------------------------------------------------
         432             :
         433        1536 :   dcs = micro_mg_dcs
         434             :
         435             :   ! Initialize subordinate utilities module.
         436             :   call micro_pumas_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, &
         437        1536 :        dcs, errstring)
         438             :
         439        1536 :   if (trim(errstring) /= "") return
         440             :
         441             :   ! declarations for MG code (transforms variable names)
         442             :
         443        1536 :   g= gravit                 ! gravity
         444        1536 :   r= rair                   ! dry air gas constant: note units(phys_constants are in J/K/kmol)
         445        1536 :   rv= rh2o                  ! water vapor gas constant
         446        1536 :   cpp = cpair               ! specific heat of dry air
         447        1536 :   tmelt = tmelt_in
         448        1536 :   rhmini = rhmini_in
         449        1536 :   micro_mg_precip_frac_method = micro_mg_precip_frac_method_in
         450        1536 :   micro_mg_berg_eff_factor    = micro_mg_berg_eff_factor_in
         451        1536 :   micro_mg_accre_enhan_fact   =  micro_mg_accre_enhan_fact_in
         452        1536 :   micro_mg_autocon_fact  = micro_mg_autocon_fact_in
         453        1536 :   micro_mg_autocon_nd_exp = micro_mg_autocon_nd_exp_in
         454        1536 :   micro_mg_autocon_lwp_exp = micro_mg_autocon_lwp_exp_in
         455        1536 :   micro_mg_homog_size   = micro_mg_homog_size_in
         456        1536 :   micro_mg_vtrmi_factor = micro_mg_vtrmi_factor_in
         457        1536 :   micro_mg_vtrms_factor = micro_mg_vtrms_factor_in
         458        1536 :   micro_mg_effi_factor = micro_mg_effi_factor_in
         459        1536 :   micro_mg_iaccr_factor = micro_mg_iaccr_factor_in
         460        1536 :   micro_mg_max_nicons = micro_mg_max_nicons_in
         461        1536 :   remove_supersat          = remove_supersat_in
         462        1536 :   warm_rain                = warm_rain_in
         463        1536 :   do_implicit_fall   = micro_mg_implicit_fall_in
         464        1536 :   accre_sees_auto = micro_mg_accre_sees_auto_in
         465             :
         466        1536 :   nccons = nccons_in
         467        1536 :   nicons = nicons_in
         468        1536 :   ncnst  = ncnst_in
         469        1536 :   ninst  = ninst_in
         470        1536 :   ngcons = ngcons_in
         471        1536 :   ngnst  = ngnst_in
         472        1536 :   nscons = nscons_in
         473        1536 :   nsnst  = nsnst_in
         474        1536 :   nrcons = nrcons_in
         475        1536 :   nrnst  = nrnst_in
         476             :
         477             :   ! latent heats
         478             :
         479        1536 :   xxlv = latvap         ! latent heat vaporization
         480        1536 :   xlf  = latice         ! latent heat freezing
         481        1536 :   xxls = xxlv + xlf     ! latent heat of sublimation
         482             :
         483             :   ! flags
         484        1536 :   microp_uniform = microp_uniform_in
         485        1536 :   do_cldice  = do_cldice_in
         486        1536 :   use_hetfrz_classnuc = use_hetfrz_classnuc_in
         487        1536 :   do_hail = micro_mg_do_hail_in
         488        1536 :   do_graupel = micro_mg_do_graupel_in
         489        1536 :   evap_sed_off = micro_mg_evap_sed_off_in
         490        1536 :   icenuc_rh_off = micro_mg_icenuc_rh_off_in
         491        1536 :   icenuc_use_meyers = micro_mg_icenuc_use_meyers_in
         492        1536 :   evap_scl_ifs = micro_mg_evap_scl_ifs_in
         493        1536 :   evap_rhthrsh_ifs = micro_mg_evap_rhthrsh_ifs_in
         494        1536 :   rainfreeze_ifs = micro_mg_rainfreeze_ifs_in
         495        1536 :   ifs_sed = micro_mg_ifs_sed_in
         496        1536 :   precip_fall_corr = micro_mg_precip_fall_corr
         497             :   ! typical air density at 850 mb
         498             :
         499        1536 :   rhosu = 85000._r8/(rair * tmelt)
         500             :
         501             :   ! Maximum temperature at which snow is allowed to exist
         502        1536 :   snowmelt = tmelt + 2._r8
         503             :   ! Minimum temperature at which rain is allowed to exist
         504        1536 :    if (rainfreeze_ifs) then
         505           0 :       rainfrze = tmelt
         506             :    else
         507        1536 :       rainfrze = tmelt - 40._r8
         508             :    end if
         509             :
         510             :
         511             :   ! Ice nucleation temperature
         512        1536 :   icenuct  = tmelt - 5._r8
         513             :
         514             :   ! Define constants to help speed up code (this limits calls to gamma function)
         515        1536 :   gamma_br_plus1=gamma(1._r8+br)
         516        1536 :   gamma_br_plus4=gamma(4._r8+br)
         517        1536 :   gamma_bs_plus1=gamma(1._r8+bs)
         518        1536 :   gamma_bs_plus4=gamma(4._r8+bs)
         519        1536 :   gamma_bi_plus1=gamma(1._r8+bi)
         520        1536 :   gamma_bi_plus4=gamma(4._r8+bi)
         521        1536 :   gamma_bj_plus1=gamma(1._r8+bj)
         522        1536 :   gamma_bj_plus4=gamma(4._r8+bj)
         523        1536 :   gamma_bg_plus1=gamma(1._r8)
         524        1536 :   gamma_bg_plus4=gamma(4._r8)
         525        1536 :   if (do_hail) then
         526           0 :      gamma_bg_plus1 = gamma(1._r8+bh)
         527           0 :      gamma_bg_plus4 = gamma(4._r8+bh)
         528             :   end if
         529        1536 :   if (do_graupel) then
         530        1536 :      gamma_bg_plus1 = gamma(1._r8+bg)
         531        1536 :      gamma_bg_plus4 = gamma(4._r8+bg)
         532             :   end if
         533             :
         534        1536 :   xxlv_squared=xxlv**2
         535        1536 :   xxls_squared=xxls**2
         536             :
         537             :   !$acc update device (nccons,nicons,ngcons,nrcons,nscons,ncnst,ninst,ngnst,   &
         538             :   !$acc                nrnst,nsnst,evap_sed_off,icenuc_rh_off,evap_scl_ifs,    &
         539             :   !$acc                icenuc_use_meyers,evap_rhthrsh_ifs,rainfreeze_ifs,      &
         540             :   !$acc                ifs_sed,precip_fall_corr,dcs,                           &
         541             :   !$acc                g,r,rv,cpp,tmelt,xxlv,xlf,xxls,rhmini,microp_uniform,   &
         542             :   !$acc                do_cldice,use_hetfrz_classnuc,do_hail,do_graupel,rhosu, &
         543             :   !$acc                icenuct,snowmelt,rainfrze,xxlv_squared,xxls_squared,    &
         544             :   !$acc                gamma_br_plus1,gamma_br_plus4,gamma_bs_plus1,           &
         545             :   !$acc                gamma_bs_plus4,gamma_bi_plus1,gamma_bi_plus4,           &
         546             :   !$acc                gamma_bj_plus1,gamma_bj_plus4,gamma_bg_plus1,           &
         547             :   !$acc                gamma_bg_plus4,micro_mg_berg_eff_factor,                &
         548             :   !$acc                micro_mg_accre_enhan_fact,micro_mg_autocon_fact,        &
         549             :   !$acc                micro_mg_autocon_nd_exp,micro_mg_autocon_lwp_exp,       &
         550             :   !$acc                micro_mg_homog_size,micro_mg_vtrmi_factor,              &
         551             :   !$acc                micro_mg_vtrms_factor,                                  &
         552             :   !$acc                micro_mg_effi_factor,micro_mg_iaccr_factor,             &
         553             :   !$acc                micro_mg_max_nicons,remove_supersat,do_implicit_fall,   &
         554             :   !$acc                accre_sees_auto)
         555             :
         556        1536 :   if (trim(warm_rain) == 'emulated') then
         557             :       call initialize_tau_emulators(stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, &
         558           0 :                                     stochastic_emulated_filename_output_scale, iulog, errstring)
         559             :   end if
         560             :
         561        3072 : end subroutine micro_pumas_init
         562             :
         563             : !===============================================================================
         564             : !microphysics routine for each timestep goes here...
         565             :
         566     4467528 : subroutine micro_pumas_tend ( &
         567             :      mgncol,             nlev,               deltatin,           &
         568     4467528 :      t,                            q,                            &
         569     4467528 :      qcn,                          qin,                          &
         570     4467528 :      ncn,                          nin,                          &
         571     4467528 :      qrn,                          qsn,                          &
         572     4467528 :      nrn,                          nsn,                          &
         573     4467528 :      qgr,                          ngr,                          &
         574     8935056 :      relvar,                       accre_enhan,                  &
         575     8935056 :      p,                            pdel, pint,                   &
         576     4467528 :      cldn,    liqcldf,        icecldf,       qsatfac,            &
         577     4467528 :      qcsinksum_rate1ord,                                         &
         578     4467528 :      naai,                         npccn,                        &
         579     4467528 :      rndst,                        nacon,                        &
         580     4467528 :      tlat,                         qvlat,                        &
         581     4467528 :      qctend,                       qitend,                       &
         582     4467528 :      nctend,                       nitend,                       &
         583     4467528 :      qrtend,                       qstend,                       &
         584     4467528 :      nrtend,                       nstend,                       &
         585     4467528 :      qgtend,                       ngtend,                       &
         586     4467528 :      effc,               effc_fn,            effi,               &
         587     4467528 :      sadice,                       sadsnow,                      &
         588     4467528 :      prect,                        preci,                        &
         589     4467528 :      nevapr,                       am_evp_st,                    &
         590     4467528 :      prain,                                                      &
         591     4467528 :      cmeout,                       deffi,                        &
         592     4467528 :      pgamrad,                      lamcrad,                      &
         593     4467528 :      qsout,                        dsout,                        &
         594     8935056 :      qgout,     ngout,             dgout,                        &
         595     4467528 :      lflx,               iflx,                                   &
         596     4467528 :      gflx,                                                       &
         597     4467528 :      rflx,               sflx,               qrout,              &
         598     4467528 :      reff_rain,          reff_snow,          reff_grau,          &
         599     4467528 :      nrout,                        nsout,                        &
         600     4467528 :      refl,               arefl,              areflz,             &
         601     4467528 :      frefl,              csrfl,              acsrfl,             &
         602     4467528 :      fcsrfl,        refl10cm, reflz10cm,     rercld,             &
         603     4467528 :      ncai,                         ncal,                         &
         604     4467528 :      qrout2,                       qsout2,                       &
         605     4467528 :      nrout2,                       nsout2,                       &
         606     4467528 :      drout2,                       dsout2,                       &
         607     8935056 :      qgout2,        ngout2,        dgout2,    freqg,                   &
         608     4467528 :      freqs,                        freqr,                        &
         609     4467528 :      nfice,                        qcrat,                        &
         610             :      proc_rates,                                                 &
         611           0 :      errstring, & ! Below arguments are "optional" (pass null pointers to omit).
         612     4467528 :      tnd_qsnow,          tnd_nsnow,          re_ice,             &
         613     4467528 :      prer_evap,                                                      &
         614     4467528 :      frzimm,             frzcnt,             frzdep)
         615             :
         616        1536 :   use pumas_stochastic_collect_tau, only: ncd, pumas_stochastic_collect_tau_tend
         617             :   use tau_neural_net_quantile, only: tau_emulated_cloud_rain_interactions
         618             :   use cam_logfile,    only: iulog
         619             :   use ML_fixer_check, only: ML_fixer_calc
         620             :
         621             :   ! Constituent properties.
         622             :   use micro_pumas_utils, only: &
         623             :        mg_liq_props, &
         624             :        mg_ice_props, &
         625             :        mg_rain_props, &
         626             :        mg_graupel_props, &
         627             :        mg_hail_props, &
         628             :        mg_snow_props
         629             :
         630             :   ! Size calculation functions.
         631             :   use micro_pumas_utils, only: &
         632             :        size_dist_param_liq, &
         633             :        size_dist_param_basic, &
         634             :        avg_diameter, &
         635             :        avg_diameter_vec
         636             :
         637             :   ! Microphysical processes.
         638             :   use micro_pumas_utils, only: &
         639             :        ice_deposition_sublimation, &
         640             :        sb2001v2_liq_autoconversion,&
         641             :        sb2001v2_accre_cld_water_rain,&
         642             :        kk2000_liq_autoconversion, &
         643             :        ice_autoconversion, &
         644             :        immersion_freezing, &
         645             :        contact_freezing, &
         646             :        snow_self_aggregation, &
         647             :        accrete_cloud_water_snow, &
         648             :        secondary_ice_production, &
         649             :        accrete_rain_snow, &
         650             :        heterogeneous_rain_freezing, &
         651             :        accrete_cloud_water_rain, &
         652             :        self_collection_rain, &
         653             :        accrete_cloud_ice_snow, &
         654             :        evaporate_sublimate_precip, &
         655             :        bergeron_process_snow, &
         656             :        graupel_collecting_snow, &
         657             :        graupel_collecting_rain, &
         658             :        graupel_collecting_cld_water, &
         659             :        graupel_riming_liquid_snow, &
         660             :        graupel_rain_riming_snow, &
         661             :        graupel_rime_splintering, &
         662             :        vapor_deposition_onto_snow, &
         663             :        evaporate_sublimate_precip_graupel
         664             :
         665             :   use micro_pumas_diags, only: proc_rates_type
         666             :
         667             :   !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL
         668             :   ! e-mail: morrison@ucar.edu, andrew@ucar.edu
         669             :
         670             :   ! input arguments
         671             :   integer,  intent(in) :: mgncol         ! number of microphysics columns
         672             :   integer,  intent(in) :: nlev           ! number of layers
         673             :   real(r8), intent(in) :: deltatin       ! time step (s)
         674             :   real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K)
         675             :   real(r8), intent(in) :: q(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg)
         676             :
         677             :   ! note: all input cloud variables are grid-averaged
         678             :   real(r8), intent(in) :: qcn(mgncol,nlev)       ! cloud water mixing ratio (kg/kg)
         679             :   real(r8), intent(in) :: qin(mgncol,nlev)       ! cloud ice mixing ratio (kg/kg)
         680             :   real(r8), intent(in) :: ncn(mgncol,nlev)       ! cloud water number conc (1/kg)
         681             :   real(r8), intent(in) :: nin(mgncol,nlev)       ! cloud ice number conc (1/kg)
         682             :
         683             :   real(r8), intent(in) :: qrn(mgncol,nlev)       ! rain mixing ratio (kg/kg)
         684             :   real(r8), intent(in) :: qsn(mgncol,nlev)       ! snow mixing ratio (kg/kg)
         685             :   real(r8), intent(in) :: nrn(mgncol,nlev)       ! rain number conc (1/kg)
         686             :   real(r8), intent(in) :: nsn(mgncol,nlev)       ! snow number conc (1/kg)
         687             :   real(r8), intent(in) :: qgr(mgncol,nlev)       ! graupel/hail mixing ratio (kg/kg)
         688             :   real(r8), intent(in) :: ngr(mgncol,nlev)       ! graupel/hail number conc (1/kg)
         689             :
         690             :   real(r8), intent(in) :: relvar(mgncol,nlev)      ! cloud water relative variance (-)
         691             :   real(r8), intent(in) :: accre_enhan(mgncol,nlev) ! optional accretion
         692             :                                              ! enhancement factor (-)
         693             :
         694             :   real(r8), intent(in) :: p(mgncol,nlev)        ! air pressure (pa)
         695             :   real(r8), intent(in) :: pdel(mgncol,nlev)     ! pressure difference across level (pa)
         696             :   real(r8), intent(in) :: pint(mgncol,nlev+1)   ! pressure at interfaces
         697             :
         698             :   real(r8), intent(in) :: cldn(mgncol,nlev)      ! cloud fraction (no units)
         699             :   real(r8), intent(in) :: liqcldf(mgncol,nlev)   ! liquid cloud fraction (no units)
         700             :   real(r8), intent(in) :: icecldf(mgncol,nlev)   ! ice cloud fraction (no units)
         701             :   real(r8), intent(in) :: qsatfac(mgncol,nlev)   ! subgrid cloud water saturation scaling factor (no units)
         702             :
         703             :   ! used for scavenging
         704             :   ! Inputs for aerosol activation
         705             :   real(r8), intent(in) :: naai(mgncol,nlev)     ! ice nucleation number (from microp_aero_ts) (1/kg*s)
         706             :   real(r8), intent(in) :: npccn(mgncol,nlev)   ! ccn activated number tendency (from microp_aero_ts) (1/kg*s)
         707             :
         708             :   ! Note that for these variables, the dust bin is assumed to be the last index.
         709             :   ! (For example, in CAM, the last dimension is always size 4.)
         710             :   real(r8), intent(in) :: rndst(:,:,:)  ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m)
         711             :   real(r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing  (from microp_aero_ts) (1/m^3)
         712             :
         713             :   ! output arguments
         714             :
         715             :   real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for
         716             :   ! direct cw to precip conversion
         717             :   real(r8), intent(out) :: tlat(mgncol,nlev)         ! latent heating rate       (W/kg)
         718             :   real(r8), intent(out) :: qvlat(mgncol,nlev)        ! microphysical tendency qv (1/s)
         719             :   real(r8), intent(out) :: qctend(mgncol,nlev)       ! microphysical tendency qc (1/s)
         720             :   real(r8), intent(out) :: qitend(mgncol,nlev)       ! microphysical tendency qi (1/s)
         721             :   real(r8), intent(out) :: nctend(mgncol,nlev)       ! microphysical tendency nc (1/(kg*s))
         722             :   real(r8), intent(out) :: nitend(mgncol,nlev)       ! microphysical tendency ni (1/(kg*s))
         723             :
         724             :   real(r8), intent(out) :: qrtend(mgncol,nlev)       ! microphysical tendency qr (1/s)
         725             :   real(r8), intent(out) :: qstend(mgncol,nlev)       ! microphysical tendency qs (1/s)
         726             :   real(r8), intent(out) :: nrtend(mgncol,nlev)       ! microphysical tendency nr (1/(kg*s))
         727             :   real(r8), intent(out) :: nstend(mgncol,nlev)       ! microphysical tendency ns (1/(kg*s))
         728             :   real(r8), intent(out) :: qgtend(mgncol,nlev)       ! microphysical tendency qg (1/s)
         729             :   real(r8), intent(out) :: ngtend(mgncol,nlev)       ! microphysical tendency ng (1/(kg*s))
         730             :
         731             :   real(r8), intent(out) :: effc(mgncol,nlev)         ! droplet effective radius (micron)
         732             :   real(r8), intent(out) :: effc_fn(mgncol,nlev)      ! droplet effective radius, assuming nc = 1.e8 kg-1
         733             :   real(r8), intent(out) :: effi(mgncol,nlev)         ! cloud ice effective radius (micron)
         734             :   real(r8), intent(out) :: sadice(mgncol,nlev)       ! cloud ice surface area density (cm2/cm3)
         735             :   real(r8), intent(out) :: sadsnow(mgncol,nlev)      ! cloud snow surface area density (cm2/cm3)
         736             :   real(r8), intent(out) :: prect(mgncol)             ! surface precip rate (m/s)
         737             :   real(r8), intent(out) :: preci(mgncol)             ! cloud ice/snow precip rate (m/s)
         738             :   real(r8), intent(out) :: nevapr(mgncol,nlev)       ! evaporation rate of rain + snow (1/s)
         739             :   real(r8), intent(out) :: am_evp_st(mgncol,nlev)    ! stratiform evaporation area (frac)
         740             :   real(r8), intent(out) :: prain(mgncol,nlev)        ! production of rain + snow (1/s)
         741             :   real(r8), intent(out) :: cmeout(mgncol,nlev)       ! evap/sub of cloud (1/s)
         742             :   real(r8), intent(out) :: deffi(mgncol,nlev)        ! ice effective diameter for optics (radiation) (micron)
         743             :   real(r8), intent(out) :: pgamrad(mgncol,nlev)      ! ice gamma parameter for optics (radiation) (no units)
         744             :   real(r8), intent(out) :: lamcrad(mgncol,nlev)      ! slope of droplet distribution for optics (radiation) (1/m)
         745             :   real(r8), intent(out) :: qsout(mgncol,nlev)        ! snow mixing ratio (kg/kg)
         746             :   real(r8), intent(out) :: dsout(mgncol,nlev)        ! snow diameter (m)
         747             :   real(r8), intent(out) :: lflx(mgncol,nlev+1)       ! grid-box average liquid condensate flux (kg m^-2 s^-1)
         748             :   real(r8), intent(out) :: iflx(mgncol,nlev+1)       ! grid-box average ice condensate flux (kg m^-2 s^-1)
         749             :   real(r8), intent(out) :: rflx(mgncol,nlev+1)       ! grid-box average rain flux (kg m^-2 s^-1)
         750             :   real(r8), intent(out) :: sflx(mgncol,nlev+1)       ! grid-box average snow flux (kg m^-2 s^-1)
         751             :   real(r8), intent(out) :: gflx(mgncol,nlev+1)       ! grid-box average graupel/hail flux (kg m^-2 s^-1)
         752             :
         753             :   real(r8), intent(out) :: qrout(mgncol,nlev)        ! grid-box average rain mixing ratio (kg/kg)
         754             :   real(r8), intent(out) :: reff_rain(mgncol,nlev)    ! rain effective radius (micron)
         755             :   real(r8), intent(out) :: reff_snow(mgncol,nlev)    ! snow effective radius (micron)
         756             :   real(r8), intent(out) :: reff_grau(mgncol,nlev)    ! graupel effective radius (micron)
         757             :
         758             :   real(r8), intent(out) :: nrout(mgncol,nlev)        ! rain number concentration (1/m3)
         759             :   real(r8), intent(out) :: nsout(mgncol,nlev)        ! snow number concentration (1/m3)
         760             :   real(r8), intent(out) :: refl(mgncol,nlev)         ! analytic radar reflectivity (94GHZ, cloud radar)
         761             :   real(r8), intent(out) :: arefl(mgncol,nlev)        ! average reflectivity will zero points outside valid range
         762             :   real(r8), intent(out) :: areflz(mgncol,nlev)       ! average reflectivity in z.
         763             :   real(r8), intent(out) :: frefl(mgncol,nlev)        ! fractional occurrence of radar reflectivity
         764             :   real(r8), intent(out) :: csrfl(mgncol,nlev)        ! cloudsat reflectivity
         765             :   real(r8), intent(out) :: acsrfl(mgncol,nlev)       ! cloudsat average
         766             :   real(r8), intent(out) :: fcsrfl(mgncol,nlev)       ! cloudsat fractional occurrence of radar reflectivity
         767             :   real(r8), intent(out) :: refl10cm(mgncol,nlev)     ! 10cm (rain) analytic radar reflectivity
         768             :   real(r8), intent(out) :: reflz10cm(mgncol,nlev)    ! 10cm (rain) analytic radar reflectivity
         769             :   real(r8), intent(out) :: rercld(mgncol,nlev)       ! effective radius calculation for rain + cloud
         770             :   real(r8), intent(out) :: ncai(mgncol,nlev)         ! output number conc of ice nuclei available (1/m3)
         771             :   real(r8), intent(out) :: ncal(mgncol,nlev)         ! output number conc of CCN (1/m3)
         772             :   real(r8), intent(out) :: qrout2(mgncol,nlev)       ! copy of qrout as used to compute drout2
         773             :   real(r8), intent(out) :: qsout2(mgncol,nlev)       ! copy of qsout as used to compute dsout2
         774             :   real(r8), intent(out) :: nrout2(mgncol,nlev)       ! copy of nrout as used to compute drout2
         775             :   real(r8), intent(out) :: nsout2(mgncol,nlev)       ! copy of nsout as used to compute dsout2
         776             :   real(r8), intent(out) :: drout2(mgncol,nlev)       ! mean rain particle diameter (m)
         777             :   real(r8), intent(out) :: dsout2(mgncol,nlev)       ! mean snow particle diameter (m)
         778             :   real(r8), intent(out) :: freqs(mgncol,nlev)        ! fractional occurrence of snow
         779             :   real(r8), intent(out) :: freqr(mgncol,nlev)        ! fractional occurrence of rain
         780             :   real(r8), intent(out) :: nfice(mgncol,nlev)        ! fractional occurrence of ice
         781             :   real(r8), intent(out) :: qcrat(mgncol,nlev)        ! limiter for qc process rates (1=no limit --> 0. no qc)
         782             :   real(r8), intent(out) :: qgout(mgncol,nlev)        ! graupel/hail mixing ratio (kg/kg)
         783             :   real(r8), intent(out) :: dgout(mgncol,nlev)        ! graupel/hail diameter (m)
         784             :   real(r8), intent(out) :: ngout(mgncol,nlev)        ! graupel/hail number concentration (1/m3)
         785             :   real(r8), intent(out) :: qgout2(mgncol,nlev)       ! copy of qgout as used to compute dgout2
         786             :   real(r8), intent(out) :: ngout2(mgncol,nlev)       ! copy of ngout as used to compute dgout2
         787             :   real(r8), intent(out) :: dgout2(mgncol,nlev)       ! mean graupel/hail particle diameter (m)
         788             :   real(r8), intent(out) :: freqg(mgncol,nlev)        ! fractional occurrence of graupel
         789             :
         790             :   real(r8), intent(out) :: prer_evap(mgncol,nlev)
         791             :
         792             :   type (proc_rates_type), intent(inout)  :: proc_rates
         793             :
         794             :   character(128),   intent(out) :: errstring  ! output status (non-blank for error return)
         795             :
         796             :   ! Tendencies calculated by external schemes that can replace MG's native
         797             :   ! process tendencies.
         798             :
         799             :   ! Used with CARMA cirrus microphysics
         800             :   ! (or similar external microphysics model)
         801             :   real(r8), intent(in) :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s)
         802             :   real(r8), intent(in) :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s)
         803             :   real(r8), intent(in) :: re_ice(:,:)    ! ice effective radius (m)
         804             :
         805             :   ! From external ice nucleation.
         806             :   real(r8), intent(in) :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3)
         807             :   real(r8), intent(in) :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3)
         808             :   real(r8), intent(in) :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3)
         809             :
         810             :   ! local workspace
         811             :   ! all units mks unless otherwise stated
         812             :
         813             :   ! local copies of input variables
         814     8935056 :   real(r8) :: qc(mgncol,nlev)      ! cloud liquid mixing ratio (kg/kg)
         815     8935056 :   real(r8) :: qi(mgncol,nlev)      ! cloud ice mixing ratio (kg/kg)
         816     8935056 :   real(r8) :: nc(mgncol,nlev)      ! cloud liquid number concentration (1/kg)
         817     8935056 :   real(r8) :: ni(mgncol,nlev)      ! cloud liquid number concentration (1/kg)
         818     8935056 :   real(r8) :: qr(mgncol,nlev)      ! rain mixing ratio (kg/kg)
         819     8935056 :   real(r8) :: qs(mgncol,nlev)      ! snow mixing ratio (kg/kg)
         820     8935056 :   real(r8) :: nr(mgncol,nlev)      ! rain number concentration (1/kg)
         821     8935056 :   real(r8) :: ns(mgncol,nlev)      ! snow number concentration (1/kg)
         822     8935056 :   real(r8) :: qg(mgncol,nlev)      ! graupel mixing ratio (kg/kg)
         823     8935056 :   real(r8) :: ng(mgncol,nlev)      ! graupel number concentration (1/kg)
         824             :   real(r8) :: rhogtmp              ! hail or graupel density (kg m-3)
         825             :
         826             :   ! general purpose variables
         827             :   real(r8) :: deltat            ! sub-time step (s)
         828             :   real(r8) :: rdeltat           ! reciprocal of sub-time step (1/s)
         829             :
         830             :   ! physical properties of the air at a given point
         831     8935056 :   real(r8) :: rho(mgncol,nlev)    ! density (kg m-3)
         832     8935056 :   real(r8) :: dv(mgncol,nlev)     ! diffusivity of water vapor
         833     8935056 :   real(r8) :: mu(mgncol,nlev)     ! viscosity
         834     8935056 :   real(r8) :: sc(mgncol,nlev)     ! schmidt number
         835     8935056 :   real(r8) :: rhof(mgncol,nlev)   ! density correction factor for fallspeed
         836             :
         837             :   ! cloud fractions
         838     8935056 :   real(r8) :: precip_frac(mgncol,nlev) ! precip fraction assuming maximum overlap
         839     8935056 :   real(r8) :: cldm(mgncol,nlev)   ! cloud fraction
         840     8935056 :   real(r8) :: icldm(mgncol,nlev)  ! ice cloud fraction
         841     8935056 :   real(r8) :: lcldm(mgncol,nlev)  ! liq cloud fraction
         842     8935056 :   real(r8) :: qsfm(mgncol,nlev)   ! subgrid cloud water saturation scaling factor
         843             :
         844             :   ! mass mixing ratios
         845     8935056 :   real(r8) :: qcic(mgncol,nlev)   ! in-cloud cloud liquid
         846     8935056 :   real(r8) :: qiic(mgncol,nlev)   ! in-cloud cloud ice
         847     8935056 :   real(r8) :: qsic(mgncol,nlev)   ! in-precip snow
         848     8935056 :   real(r8) :: qric(mgncol,nlev)   ! in-precip rain
         849     8935056 :   real(r8) :: qgic(mgncol,nlev)   ! in-precip graupel/hail
         850             :
         851             :   ! number concentrations
         852     8935056 :   real(r8) :: ncic(mgncol,nlev)   ! in-cloud droplet
         853     8935056 :   real(r8) :: niic(mgncol,nlev)   ! in-cloud cloud ice
         854     8935056 :   real(r8) :: nsic(mgncol,nlev)   ! in-precip snow
         855     8935056 :   real(r8) :: nric(mgncol,nlev)   ! in-precip rain
         856     8935056 :   real(r8) :: ngic(mgncol,nlev)   ! in-precip graupel/hail
         857             :
         858             :   ! Size distribution parameters for:
         859             :   ! cloud ice
         860     8935056 :   real(r8) :: lami(mgncol,nlev)   ! slope
         861     8935056 :   real(r8) :: n0i(mgncol,nlev)    ! intercept
         862             :   ! cloud liquid
         863     8935056 :   real(r8) :: lamc(mgncol,nlev)   ! slope
         864     8935056 :   real(r8) :: pgam(mgncol,nlev)   ! spectral width parameter
         865             :   ! snow
         866     8935056 :   real(r8) :: lams(mgncol,nlev)   ! slope
         867     8935056 :   real(r8) :: n0s(mgncol,nlev)    ! intercept
         868             :   ! rain
         869     8935056 :   real(r8) :: lamr(mgncol,nlev)   ! slope
         870     8935056 :   real(r8) :: n0r(mgncol,nlev)    ! intercept
         871             :   ! graupel/hail
         872     8935056 :   real(r8) :: lamg(mgncol,nlev)   ! slope
         873     8935056 :   real(r8) :: n0g(mgncol,nlev)    ! intercept
         874             :   real(r8) :: bgtmp               ! tmp fall speed parameter
         875             :
         876             :   ! Rates/tendencies due to:
         877             :
         878             :   ! Instantaneous snow melting
         879     8935056 :   real(r8) :: minstsm(mgncol,nlev)    ! mass mixing ratio
         880     8935056 :   real(r8) :: ninstsm(mgncol,nlev)    ! number concentration
         881             :   ! Instantaneous graupel melting
         882     8935056 :   real(r8) :: minstgm(mgncol,nlev)    ! mass mixing ratio
         883     8935056 :   real(r8) :: ninstgm(mgncol,nlev)    ! number concentration
         884             :
         885             :   ! Instantaneous rain freezing
         886     8935056 :   real(r8) :: minstrf(mgncol,nlev)    ! mass mixing ratio
         887     8935056 :   real(r8) :: ninstrf(mgncol,nlev)    ! number concentration
         888             :
         889             :   ! deposition of cloud ice
         890     8935056 :   real(r8) :: vap_dep(mgncol,nlev)    ! deposition from vapor to ice PMC 12/3/12
         891             :   ! sublimation of cloud ice
         892     8935056 :   real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12
         893             :   ! vapor deposition onto
         894     8935056 :   real(r8) :: vap_deps(mgncol,nlev) ! Vapor deposition onto snow.
         895             :
         896             :   ! ice nucleation
         897     8935056 :   real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing
         898     8935056 :   real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio
         899             :   ! freezing of cloud water
         900     8935056 :   real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio
         901     8935056 :   real(r8) :: nnuccc(mgncol,nlev) ! number concentration
         902             :   ! contact freezing of cloud water
         903     8935056 :   real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio
         904     8935056 :   real(r8) :: nnucct(mgncol,nlev) ! number concentration
         905             :   ! deposition nucleation in mixed-phase clouds (from external scheme)
         906     8935056 :   real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio
         907     8935056 :   real(r8) :: nnudep(mgncol,nlev) ! number concentration
         908             :   ! ice multiplication
         909     8935056 :   real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio
         910     8935056 :   real(r8) :: nsacwi(mgncol,nlev) ! number concentration
         911             :   ! autoconversion of cloud droplets
         912     8935056 :   real(r8) :: prc(mgncol,nlev)    ! mass mixing ratio
         913     8935056 :   real(r8) :: nprc(mgncol,nlev)   ! number concentration (rain)
         914     8935056 :   real(r8) :: nprc1(mgncol,nlev)  ! number concentration (cloud droplets)
         915             :   ! self-aggregation of snow
         916     8935056 :   real(r8) :: nsagg(mgncol,nlev)  ! number concentration
         917             :   ! self-collection of rain
         918     8935056 :   real(r8) :: nragg(mgncol,nlev)  ! number concentration
         919             :   ! collection of droplets by snow
         920     8935056 :   real(r8) :: psacws(mgncol,nlev)     ! mass mixing ratio
         921     8935056 :   real(r8) :: npsacws(mgncol,nlev)    ! number concentration
         922             :   ! collection of rain by snow
         923     8935056 :   real(r8) :: pracs(mgncol,nlev)  ! mass mixing ratio
         924     8935056 :   real(r8) :: npracs(mgncol,nlev) ! number concentration
         925             :   ! freezing of rain
         926     8935056 :   real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio
         927     8935056 :   real(r8) :: nnuccr(mgncol,nlev) ! number concentration
         928             :   ! freezing of rain to form ice (mg add 4/26/13)
         929     8935056 :   real(r8) :: mnuccri(mgncol,nlev)    ! mass mixing ratio
         930     8935056 :   real(r8) :: nnuccri(mgncol,nlev)    ! number concentration
         931             :   ! accretion of droplets by rain
         932     8935056 :   real(r8) :: pra(mgncol,nlev)    ! mass mixing ratio
         933     8935056 :   real(r8) :: npra(mgncol,nlev)   ! number concentration
         934             :   ! autoconversion of cloud ice to snow
         935     8935056 :   real(r8) :: prci(mgncol,nlev)   ! mass mixing ratio
         936     8935056 :   real(r8) :: nprci(mgncol,nlev)  ! number concentration
         937             :   ! accretion of cloud ice by snow
         938     8935056 :   real(r8) :: prai(mgncol,nlev)   ! mass mixing ratio
         939     8935056 :   real(r8) :: nprai(mgncol,nlev)  ! number concentration
         940             :   ! evaporation of rain
         941     8935056 :   real(r8) :: pre(mgncol,nlev)    ! mass mixing ratio
         942             :   ! sublimation of snow
         943     8935056 :   real(r8) :: prds(mgncol,nlev)   ! mass mixing ratio
         944             :   ! number evaporation
         945     8935056 :   real(r8) :: nsubi(mgncol,nlev)  ! cloud ice
         946     8935056 :   real(r8) :: nsubc(mgncol,nlev)  ! droplet
         947     8935056 :   real(r8) :: nsubs(mgncol,nlev)  ! snow
         948     8935056 :   real(r8) :: nsubr(mgncol,nlev)  ! rain
         949             :   ! bergeron process
         950     8935056 :   real(r8) :: berg(mgncol,nlev)   ! mass mixing ratio (cloud ice)
         951     8935056 :   real(r8) :: bergs(mgncol,nlev)  ! mass mixing ratio (snow)
         952             :
         953             :   !graupel/hail processes
         954     8935056 :   real(r8) :: npracg(mgncol,nlev)  ! change n collection rain by graupel  (precipf)
         955     8935056 :   real(r8) :: nscng(mgncol,nlev)   ! change n conversion to graupel due to collection droplets by snow (lcldm)
         956     8935056 :   real(r8) :: ngracs(mgncol,nlev)  ! change n conversion to graupel due to collection rain by snow (precipf)
         957     8935056 :   real(r8) :: nmultg(mgncol,nlev)  ! ice mult due to acc droplets by graupel  (lcldm)
         958     8935056 :   real(r8) :: nmultrg(mgncol,nlev) ! ice mult due to acc rain by graupel  (precipf)
         959     8935056 :   real(r8) :: npsacwg(mgncol,nlev) ! change n collection droplets by graupel (lcldm)
         960             :
         961     8935056 :   real(r8) :: psacr(mgncol,nlev)   ! conversion due to coll of snow by rain (precipf)
         962     8935056 :   real(r8) :: pracg(mgncol,nlev)   ! change in q collection rain by graupel  (precipf)
         963     8935056 :   real(r8) :: psacwg(mgncol,nlev)  ! change in q collection droplets by graupel (lcldm)
         964     8935056 :   real(r8) :: pgsacw(mgncol,nlev)  ! conversion q to graupel due to collection droplets by snow  (lcldm)
         965     8935056 :   real(r8) :: pgracs(mgncol,nlev)  ! conversion q to graupel due to collection rain by snow (precipf)
         966     8935056 :   real(r8) :: prdg(mgncol,nlev)    ! dep of graupel (precipf)
         967     8935056 :   real(r8) :: qmultg(mgncol,nlev)  ! change q due to ice mult droplets/graupel  (lcldm)
         968     8935056 :   real(r8) :: qmultrg(mgncol,nlev) ! change q due to ice mult rain/graupel (precipf)
         969             :
         970             :
         971             :   ! fallspeeds
         972             :   ! number-weighted
         973     8935056 :   real(r8) :: uns(mgncol,nlev)    ! snow
         974     8935056 :   real(r8) :: unr(mgncol,nlev)    ! rain
         975     8935056 :   real(r8) :: ung(mgncol,nlev)    ! graupel/hail
         976             :
         977             :   ! air density corrected fallspeed parameters
         978     8935056 :   real(r8) :: arn(mgncol,nlev)    ! rain
         979     8935056 :   real(r8) :: asn(mgncol,nlev)    ! snow
         980     8935056 :   real(r8) :: agn(mgncol,nlev)    ! graupel
         981     8935056 :   real(r8) :: acn(mgncol,nlev)    ! cloud droplet
         982     8935056 :   real(r8) :: ain(mgncol,nlev)    ! cloud ice
         983     8935056 :   real(r8) :: ajn(mgncol,nlev)    ! cloud small ice
         984             :
         985             :   ! Mass of liquid droplets used with external heterogeneous freezing.
         986     8935056 :   real(r8) :: mi0l(mgncol,nlev)
         987             :
         988             :   ! saturation vapor pressures
         989     8935056 :   real(r8) :: esl(mgncol,nlev)    ! liquid
         990     8935056 :   real(r8) :: esi(mgncol,nlev)    ! ice
         991     8935056 :   real(r8) :: esnA(mgncol,nlev)   ! checking for RH after rain evap
         992             :
         993             :   ! saturation vapor mixing ratios
         994     8935056 :   real(r8) :: qvl(mgncol,nlev)    ! liquid
         995     8935056 :   real(r8) :: qvi(mgncol,nlev)    ! ice
         996     8935056 :   real(r8) :: qvnA(mgncol,nlev), qvnAI(mgncol,nlev) ! checking for RH after rain evap
         997             :
         998             :   ! relative humidity
         999     8935056 :   real(r8) :: relhum(mgncol,nlev)
        1000             :
        1001             :   ! parameters for cloud water and cloud ice sedimentation calculations
        1002     8935056 :   real(r8) :: fc(mgncol,nlev)
        1003     8935056 :   real(r8) :: fnc(mgncol,nlev)
        1004     8935056 :   real(r8) :: fi(mgncol,nlev)
        1005     8935056 :   real(r8) :: fni(mgncol,nlev)
        1006     8935056 :   real(r8) :: fg(mgncol,nlev)
        1007     8935056 :   real(r8) :: fng(mgncol,nlev)
        1008     8935056 :   real(r8) :: fr(mgncol,nlev)
        1009     8935056 :   real(r8) :: fnr(mgncol,nlev)
        1010     8935056 :   real(r8) :: fs(mgncol,nlev)
        1011     8935056 :   real(r8) :: fns(mgncol,nlev)
        1012             :
        1013             :   real(r8) :: rthrsh     ! rain rate threshold for reflectivity calculation
        1014             :
        1015             :   ! dummy variables
        1016             :   real(r8) :: dum, dum1, dum2, dum3, dum4, qtmp
        1017     8935056 :   real(r8) :: dum1A(mgncol,nlev), dum2A(mgncol,nlev), dum3A(mgncol,nlev)
        1018     8935056 :   real(r8) :: dumni0, dumni0A2D(mgncol,nlev)
        1019     8935056 :   real(r8) :: dumns0, dumns0A2D(mgncol,nlev)
        1020             :   ! dummies for checking RH
        1021     8935056 :   real(r8) :: ttmpA(mgncol,nlev), qtmpAI(mgncol,nlev)
        1022             :   ! dummies for conservation check
        1023             :   real(r8) :: ratio, tmpnr,tmpp
        1024             :   real(r8) :: tmpfrz
        1025             :   ! dummies for in-cloud variables
        1026     8935056 :   real(r8) :: dumc(mgncol,nlev)   ! qc
        1027     8935056 :   real(r8) :: dumnc(mgncol,nlev)  ! nc
        1028     8935056 :   real(r8) :: dumi(mgncol,nlev)   ! qi
        1029     8935056 :   real(r8) :: dumni(mgncol,nlev)  ! ni
        1030     8935056 :   real(r8) :: dumr(mgncol,nlev)   ! rain mixing ratio
        1031     8935056 :   real(r8) :: dumnr(mgncol,nlev)  ! rain number concentration
        1032     8935056 :   real(r8) :: dums(mgncol,nlev)   ! snow mixing ratio
        1033     8935056 :   real(r8) :: dumns(mgncol,nlev)  ! snow number concentration
        1034     8935056 :   real(r8) :: dumg(mgncol,nlev)   ! graupel mixing ratio
        1035     8935056 :   real(r8) :: dumng(mgncol,nlev)  ! graupel number concentration
        1036             :   ! Array dummy variable
        1037     8935056 :   real(r8) :: dum_2D(mgncol,nlev)
        1038     8935056 :   real(r8) :: pdel_inv(mgncol,nlev)
        1039             :
        1040             :   ! loop array variables
        1041             :   ! "i" and "k" are column/level iterators for internal (MG) variables
        1042             :   ! "n" is used for other looping (currently just sedimentation)
        1043             :   integer i, k, n
        1044             :
        1045             :   integer mdust
        1046             :   integer :: precip_frac_method
        1047             :
        1048             :   ! Varaibles to scale fall velocity between small and regular ice regimes.
        1049             :   real(r8) :: irad
        1050             :   real(r8) :: ifrac
        1051             :
        1052             :   !Variables for accretion seeing autoconverted liquid
        1053     8935056 :   real(r8) :: rtmp(mgncol,nlev) ! dummy for rain + autoconversion
        1054     8935056 :   real(r8) :: ctmp(mgncol,nlev) ! dummy for liq - autoconversion
        1055     8935056 :   real(r8) :: ntmp(mgncol,nlev) ! dummy for liq - autoconversion number
        1056             :
        1057             :   ! Variables for height calculation (used in Implicit Fall Speed)
        1058     8935056 :   real(r8) :: zint(mgncol,nlev+1) ! interface height
        1059             :   real(r8) :: H   !Scale height
        1060             :
        1061             :   ! temporary local variables for asynchronous GPU run
        1062             :   ! ice
        1063     8935056 :   real(r8) :: prect_i(mgncol)
        1064     8935056 :   real(r8) :: tlat_i(mgncol,nlev)
        1065     8935056 :   real(r8) :: qvlat_i(mgncol,nlev)
        1066     8935056 :   real(r8) :: preci_i(mgncol)
        1067             :   ! liq
        1068     8935056 :   real(r8) :: prect_l(mgncol)
        1069     8935056 :   real(r8) :: tlat_l(mgncol,nlev)
        1070     8935056 :   real(r8) :: qvlat_l(mgncol,nlev)
        1071             :   ! rain
        1072     8935056 :   real(r8) :: prect_r(mgncol)
        1073             :   ! snow
        1074     8935056 :   real(r8) :: prect_s(mgncol)
        1075     8935056 :   real(r8) :: preci_s(mgncol)
        1076             :   ! graupel
        1077     8935056 :   real(r8) :: prect_g(mgncol)
        1078     8935056 :   real(r8) :: preci_g(mgncol)
        1079             :
        1080             :   ! number of sub-steps for loops over "n" (for sedimentation)
        1081             :   ! ice
        1082     8935056 :   integer nstep_i(mgncol)
        1083     8935056 :   real(r8) :: rnstep_i(mgncol)
        1084             :   ! liq
        1085     8935056 :   integer nstep_l(mgncol)
        1086     8935056 :   real(r8) :: rnstep_l(mgncol)
        1087             :   ! rain
        1088     8935056 :   integer nstep_r(mgncol)
        1089     8935056 :   real(r8) :: rnstep_r(mgncol)
        1090             :   ! snow
        1091     8935056 :   integer nstep_s(mgncol)
        1092     8935056 :   real(r8) :: rnstep_s(mgncol)
        1093             :   ! graupel
        1094     8935056 :   integer nstep_g(mgncol)
        1095     4467528 :   real(r8) :: rnstep_g(mgncol)
        1096             :
        1097             :   !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        1098             :
        1099             :   ! Initialize scale height (H) for interface height calculation
        1100             :   ! needed for Implicit Fall Speed
        1101     4467528 :   H=0._r8
        1102             :
        1103             :   ! Return error message
        1104     4467528 :   errstring = ' '
        1105             :
        1106             :   ! Process inputs
        1107             :
        1108             :   ! assign variable deltat to deltatin
        1109     4467528 :   deltat  = deltatin
        1110     4467528 :   rdeltat = 1._r8 / deltat
        1111             :
        1112     4467528 :   if (trim(micro_mg_precip_frac_method) == 'in_cloud') then
        1113             :      precip_frac_method = MG_PRECIP_FRAC_INCLOUD
        1114           0 :   else if(trim(micro_mg_precip_frac_method) == 'max_overlap') then
        1115             :      precip_frac_method = MG_PRECIP_FRAC_OVERLAP
        1116             :   endif
        1117             :
        1118             :   !......................................................................
        1119             :   !       graupel/hail density set (Hail = 400, Graupel = 500 from M2005)
        1120     4467528 :   bgtmp=0._r8
        1121     4467528 :   rhogtmp=0._r8
        1122     4467528 :   if (do_hail) then
        1123           0 :      bgtmp = bh
        1124           0 :      rhogtmp = rhoh
        1125             :   end if
        1126     4467528 :   if (do_graupel) then
        1127     4467528 :      bgtmp = bg
        1128     4467528 :      rhogtmp = rhog
        1129             :   end if
        1130             :
        1131             :   ! set mdust as the number of dust bins for use later in contact freezing subroutine
        1132     4467528 :   mdust = size(rndst,3)
        1133             :
        1134             :   !$acc data copyin  (t,q,qcn,qin,ncn,nin,qrn,qsn,nrn,nsn,qgr,ngr,relvar,     &
        1135             :   !$acc               accre_enhan,p,pdel,pint,cldn,liqcldf,icecldf,qsatfac,   &
        1136             :   !$acc               naai,npccn,rndst,nacon,tnd_qsnow,tnd_nsnow,re_ice,      &
        1137             :   !$acc               frzimm,frzcnt,frzdep,mg_liq_props,mg_ice_props,         &
        1138             :   !$acc               mg_rain_props,mg_graupel_props,mg_hail_props,           &
        1139             :   !$acc               mg_snow_props,proc_rates)                               &
        1140             :   !$acc      copyout (qcsinksum_rate1ord,tlat,qvlat,qctend,qitend,nctend,     &
        1141             :   !$acc               nitend,qrtend,qstend,nrtend,nstend,qgtend,ngtend,       &
        1142             :   !$acc               effc,effc_fn,effi,sadice,sadsnow,prect,preci,           &
        1143             :   !$acc               nevapr,proc_rates%evapsnow,am_evp_st,prain,             &
        1144             :   !$acc               proc_rates%prodsnow,cmeout,                             &
        1145             :   !$acc               deffi,pgamrad,lamcrad,qsout,dsout,lflx,iflx,rflx,       &
        1146             :   !$acc               sflx,gflx,qrout,reff_rain,reff_snow,reff_grau,          &
        1147             :   !$acc               proc_rates%qcsevap,proc_rates%qisevap,proc_rates%qvres, &
        1148             :   !$acc               proc_rates%cmeitot,proc_rates%vtrmc,proc_rates%vtrmi,   &
        1149             :   !$acc               proc_rates%umr,proc_rates%ums,                          &
        1150             :   !$acc               proc_rates%umg,proc_rates%qgsedten,proc_rates%qcsedten, &
        1151             :   !$acc               proc_rates%qisedten,proc_rates%qrsedten,                &
        1152             :   !$acc               proc_rates%qssedten,proc_rates%pratot,                  &
        1153             :   !$acc               proc_rates%prctot,proc_rates%mnuccctot,                 &
        1154             :   !$acc               proc_rates%mnuccttot,proc_rates%msacwitot,              &
        1155             :   !$acc               proc_rates%psacwstot,proc_rates%bergstot,               &
        1156             :   !$acc               proc_rates%vapdepstot,proc_rates%bergtot,               &
        1157             :   !$acc               proc_rates%melttot,proc_rates%meltstot,                 &
        1158             :   !$acc               proc_rates%meltgtot,proc_rates%mnudeptot,               &
        1159             :   !$acc               proc_rates%homotot,                                     &
        1160             :   !$acc               proc_rates%qcrestot,proc_rates%prcitot,                 &
        1161             :   !$acc               proc_rates%praitot,proc_rates%qirestot,                 &
        1162             :   !$acc               proc_rates%mnuccrtot,proc_rates%mnuccritot,             &
        1163             :   !$acc               proc_rates%pracstot,proc_rates%meltsdttot,              &
        1164             :   !$acc               proc_rates%frzrdttot,proc_rates%mnuccdtot,              &
        1165             :   !$acc               proc_rates%pracgtot,proc_rates%psacwgtot,               &
        1166             :   !$acc               proc_rates%pgsacwtot,proc_rates%pgracstot,              &
        1167             :   !$acc               proc_rates%prdgtot,proc_rates%qmultgtot,                &
        1168             :   !$acc               proc_rates%qmultrgtot,proc_rates%psacrtot,              &
        1169             :   !$acc               proc_rates%npracgtot,proc_rates%nscngtot,               &
        1170             :   !$acc               proc_rates%ngracstot,proc_rates%nmultgtot,              &
        1171             :   !$acc               proc_rates%nmultrgtot,proc_rates%npsacwgtot,            &
        1172             :   !$acc               nrout,nsout,refl,arefl,                                 &
        1173             :   !$acc               areflz,frefl,csrfl,acsrfl,fcsrfl,refl10cm,reflz10cm,    &
        1174             :   !$acc               rercld,ncai,ncal,qrout2,qsout2,nrout2,nsout2,drout2,    &
        1175             :   !$acc               dsout2,freqs,freqr,nfice,qcrat,qgout,dgout,ngout,       &
        1176             :   !$acc               qgout2,ngout2,dgout2,freqg,prer_evap,                   &
        1177             :   !$acc               proc_rates%nnuccctot,proc_rates%nnuccttot,              &
        1178             :   !$acc               proc_rates%nnuccdtot,proc_rates%nnudeptot,              &
        1179             :   !$acc               proc_rates%nhomotot,proc_rates%nnuccrtot,               &
        1180             :   !$acc               proc_rates%nnuccritot,proc_rates%nsacwitot,             &
        1181             :   !$acc               proc_rates%npratot,proc_rates%npsacwstot,               &
        1182             :   !$acc               proc_rates%npraitot,proc_rates%npracstot,               &
        1183             :   !$acc               proc_rates%nprctot,proc_rates%nprcitot,                 &
        1184             :   !$acc               proc_rates%ncsedten,proc_rates%nisedten,                &
        1185             :   !$acc               proc_rates%nrsedten,proc_rates%nssedten,                &
        1186             :   !$acc               proc_rates%ngsedten,proc_rates%nmelttot,                &
        1187             :   !$acc               proc_rates%nmeltstot,proc_rates%nmeltgtot,              &
        1188             :   !$acc               proc_rates%nraggtot,proc_rates%scale_qc,                &
        1189             :   !$acc               proc_rates%scale_nc,proc_rates%scale_qr,                &
        1190             :   !$acc               proc_rates%scale_nr,proc_rates%amk_c,proc_rates%ank_c,  &
        1191             :   !$acc               proc_rates%amk_r,proc_rates%ank_r,proc_rates%amk,       &
        1192             :   !$acc               proc_rates%ank,proc_rates%amk_out,proc_rates%ank_out,   &
        1193             :   !$acc               proc_rates%qc_out_TAU,proc_rates%nc_out_TAU,            &
        1194             :   !$acc               proc_rates%qr_out_TAU,proc_rates%nr_out_TAU,            &
        1195             :   !$acc               proc_rates%qc_in_TAU,proc_rates%nc_in_TAU,              &
        1196             :   !$acc               proc_rates%qr_in_TAU,proc_rates%nr_in_TAU,              &
        1197             :   !$acc               proc_rates%lamc_out,proc_rates%lamr_out,                &
        1198             :   !$acc               proc_rates%pgam_out,proc_rates%n0r_out,                 &
        1199             :   !$acc               proc_rates%qctend_KK2000,proc_rates%nctend_KK2000,      &
        1200             :   !$acc               proc_rates%qrtend_KK2000,proc_rates%nrtend_KK2000,      &
        1201             :   !$acc               proc_rates%qctend_SB2001,proc_rates%nctend_SB2001,      &
        1202             :   !$acc               proc_rates%qrtend_SB2001,proc_rates%nrtend_SB2001,      &
        1203             :   !$acc               proc_rates%qctend_TAU,proc_rates%nctend_TAU,            &
        1204             :   !$acc               proc_rates%qrtend_TAU,proc_rates%nrtend_TAU,            &
        1205             :   !$acc               proc_rates%gmnnn_lmnnn_TAU)                             &
        1206             :   !$acc      create  (qc,qi,nc,ni,qr,qs,nr,ns,qg,ng,rho,dv,mu,sc,rhof,        &
        1207             :   !$acc               precip_frac,cldm,icldm,lcldm,qsfm,qcic,qiic,qsic,qric,  &
        1208             :   !$acc               qgic,ncic,niic,nsic,nric,ngic,lami,n0i,lamc,pgam,lams,  &
        1209             :   !$acc               n0s,lamr,n0r,lamg,n0g,minstsm,ninstsm,minstgm,ninstgm,  &
        1210             :   !$acc               minstrf,ninstrf,vap_dep,ice_sublim,vap_deps,nnuccd,     &
        1211             :   !$acc               mnuccd,mnuccc,nnuccc,mnucct,nnucct,mnudep,nnudep,       &
        1212             :   !$acc               msacwi,nsacwi,prc,nprc,nprc1,nsagg,nragg,psacws,        &
        1213             :   !$acc               npsacws,pracs,npracs,mnuccr,nnuccr,mnuccri,nnuccri,pra, &
        1214             :   !$acc               npra,prci,nprci,prai,nprai,pre,prds,nsubi,nsubc,nsubs,  &
        1215             :   !$acc               nsubr,berg,bergs,npracg,nscng,ngracs,nmultg,nmultrg,    &
        1216             :   !$acc               npsacwg,psacr,pracg,psacwg,pgsacw,pgracs,prdg,qmultg,   &
        1217             :   !$acc               qmultrg,uns,unr,ung,arn,asn,agn,acn,ain,ajn,mi0l,esl,   &
        1218             :   !$acc               esi,esnA,qvl,qvi,qvnA,qvnAI,relhum,fc,fnc,fi,fni,fg,    &
        1219             :   !$acc               fng,fr,fnr,fs,fns,dum1A,dum2A,dum3A,dumni0A2D,          &
        1220             :   !$acc               dumns0A2D,ttmpA,qtmpAI,dumc,dumnc,dumi,dumni,dumr,      &
        1221             :   !$acc               dumnr,dums,dumns,dumg,dumng,dum_2D,pdel_inv,rtmp,ctmp,  &
        1222             :   !$acc               ntmp,zint,nstep_i,rnstep_i,nstep_l,rnstep_l,nstep_r,    &
        1223             :   !$acc               rnstep_r,nstep_s,rnstep_s,nstep_g,rnstep_g,prect_i,     &
        1224             :   !$acc               tlat_i,qvlat_i,preci_i,prect_l,tlat_l,qvlat_l,prect_r,  &
        1225             :   !$acc               prect_s,preci_s,prect_g,preci_g)
        1226             :
        1227             :   ! Copies of input concentrations that may be changed internally.
        1228             :
        1229             :   !$acc parallel vector_length(VLENS) default(present)
        1230             :   !$acc loop gang vector collapse(2)
        1231   379739880 :   do k = 1,nlev
        1232  6270643080 :      do i = 1,mgncol
        1233  5890903200 :         qc(i,k) = qcn(i,k)
        1234  5890903200 :         nc(i,k) = ncn(i,k)
        1235  5890903200 :         qi(i,k) = qin(i,k)
        1236  5890903200 :         ni(i,k) = nin(i,k)
        1237  5890903200 :         qr(i,k) = qrn(i,k)
        1238  5890903200 :         nr(i,k) = nrn(i,k)
        1239  5890903200 :         qs(i,k) = qsn(i,k)
        1240  5890903200 :         ns(i,k) = nsn(i,k)
        1241  5890903200 :         qg(i,k) = qgr(i,k)
        1242  6266175552 :         ng(i,k) = ngr(i,k)
        1243             :      end do
        1244             :   end do
        1245             :   !$acc end parallel
        1246             :
        1247             :   ! cldn: used to set cldm, unused for subcolumns
        1248             :   ! liqcldf: used to set lcldm, unused for subcolumns
        1249             :   ! icecldf: used to set icldm, unused for subcolumns
        1250             :
        1251     4467528 :   if (microp_uniform) then
        1252             :      ! subcolumns, set cloud fraction variables to one
        1253             :      ! if cloud water or ice is present, if not present
        1254             :      ! set to mincld (mincld used instead of zero, to prevent
        1255             :      ! possible division by zero errors).
        1256             :
        1257             :      !$acc parallel vector_length(VLENS) default(present)
        1258             :      !$acc loop gang vector collapse(2)
        1259           0 :      do k=1,nlev
        1260           0 :        do i=1,mgncol
        1261           0 :           if (qc(i,k) >= qsmall) then
        1262           0 :              lcldm(i,k) = 1._r8
        1263             :           else
        1264           0 :              lcldm(i,k) = mincld
        1265             :           end if
        1266             :
        1267           0 :           if (qi(i,k) >= qsmall) then
        1268           0 :              icldm(i,k) = 1._r8
        1269             :           else
        1270           0 :              icldm(i,k) = mincld
        1271             :           end if
        1272             :
        1273           0 :           cldm(i,k) = max(icldm(i,k), lcldm(i,k))
        1274           0 :           qsfm(i,k) = 1._r8
        1275             :         end do
        1276             :      end do
        1277             :      !$acc end parallel
        1278             :   else
        1279             :      ! get cloud fraction, check for minimum
        1280             :
        1281             :      !$acc parallel vector_length(VLENS) default(present)
        1282             :      !$acc loop gang vector collapse(2)
        1283   379739880 :      do k=1,nlev
        1284  6270643080 :         do i=1,mgncol
        1285  5890903200 :           cldm(i,k) = max(cldn(i,k),mincld)
        1286  5890903200 :           lcldm(i,k) = max(liqcldf(i,k),mincld)
        1287  5890903200 :           icldm(i,k) = max(icecldf(i,k),mincld)
        1288  6266175552 :           qsfm(i,k) = qsatfac(i,k)
        1289             :         end do
        1290             :      end do
        1291             :      !$acc end parallel
        1292             :   end if
        1293             :
        1294             :   ! Initialize local variables
        1295             :
        1296             :   ! local physical properties
        1297             :
        1298             :   !$acc parallel vector_length(VLENS) default(present)
        1299             :   !$acc loop gang vector collapse(2)
        1300   379739880 :   do k=1,nlev
        1301  6270643080 :      do i=1,mgncol
        1302  5890903200 :         rho(i,k) = p(i,k)/(r*t(i,k))
        1303  5890903200 :         dv(i,k) = 8.794E-5_r8 * t(i,k)**1.81_r8 / p(i,k)
        1304  5890903200 :         mu(i,k) = 1.496E-6_r8 * t(i,k)**1.5_r8 / (t(i,k) + 120._r8)
        1305  5890903200 :         sc(i,k) = mu(i,k)/(rho(i,k)*dv(i,k))
        1306             :
        1307             :         ! air density adjustment for fallspeed parameters
        1308             :         ! includes air density correction factor to the
        1309             :         ! power of 0.54 following Heymsfield and Bansemer 2007
        1310             :
        1311  5890903200 :         rhof(i,k)=(rhosu/rho(i,k))**0.54_r8
        1312             :
        1313  5890903200 :         arn(i,k)=ar*rhof(i,k)
        1314  5890903200 :         asn(i,k)=as*rhof(i,k)
        1315             :         ! Hail use ah*rhof graupel use ag*rhof
        1316             :         ! Note that do_hail and do_graupel can't both be true
        1317  5890903200 :         if (do_hail) then
        1318           0 :            agn(i,k) = ah*rhof(i,k)
        1319             :         end if
        1320  5890903200 :         if (do_graupel) then
        1321  5890903200 :            agn(i,k) = ag*rhof(i,k)
        1322             :         end if
        1323  5890903200 :         acn(i,k)=g*rhow/(18._r8*mu(i,k))
        1324  5890903200 :         ain(i,k)=ai*(rhosu/rho(i,k))**0.35_r8
        1325  6266175552 :         ajn(i,k)=aj*(rhosu/rho(i,k))**0.35_r8
        1326             :      end do
        1327             :   end do
        1328             :   !$acc end parallel
        1329             :
        1330             :   !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        1331             :   ! Get humidity and saturation vapor pressures
        1332             :
        1333     4467528 :   call qsat_water(t, p, esl, qvl, mgncol*nlev)
        1334     4467528 :   call qsat_ice(t, p, esi, qvi, mgncol*nlev)
        1335             :
        1336             :   !$acc parallel vector_length(VLENS) default(present)
        1337             :   !$acc loop gang vector collapse(2)
        1338   379739880 :   do k=1,nlev
        1339  6270643080 :      do i=1,mgncol
        1340             :         ! make sure when above freezing that esi=esl, not active yet
        1341  5890903200 :         if (t(i,k) >= tmelt) then
        1342  1123427798 :            esi(i,k)=esl(i,k)
        1343  1123427798 :            qvi(i,k)=qvl(i,k)
        1344             :         else
        1345             :            ! Scale the water saturation values to reflect subgrid scale
        1346             :            ! ice cloud fraction, where ice clouds begin forming at a
        1347             :            ! gridbox average relative humidity of rhmini (not 1).
        1348             :            !
        1349             :            ! NOTE: For subcolumns and other non-subgrid clouds, qsfm willi
        1350             :            ! be 1.
        1351  4767475402 :            qvi(i,k) = qsfm(i,k) * qvi(i,k)
        1352  4767475402 :            esi(i,k) = qsfm(i,k) * esi(i,k)
        1353  4767475402 :            qvl(i,k) = qsfm(i,k) * qvl(i,k)
        1354  4767475402 :            esl(i,k) = qsfm(i,k) * esl(i,k)
        1355             :         end if
        1356             :
        1357  6266175552 :         relhum(i,k) = q(i,k) / max(qvl(i,k), qsmall)
        1358             :
        1359             :      end do
        1360             :   end do
        1361             :   !$acc end parallel
        1362             :
        1363             :   ! initialize microphysics output
        1364             :
        1365             :   !$acc parallel vector_length(VLENS) default(present)
        1366             :   !$acc loop gang vector collapse(2)
        1367   379739880 :   do k=1,nlev
        1368  6270643080 :      do i=1,mgncol
        1369  5890903200 :         proc_rates%qcsevap(i,k)            = 0._r8
        1370  5890903200 :         proc_rates%qisevap(i,k)            = 0._r8
        1371  5890903200 :         proc_rates%qvres(i,k)              = 0._r8
        1372  5890903200 :         proc_rates%cmeitot(i,k)            = 0._r8
        1373  5890903200 :         proc_rates%vtrmc(i,k)              = 0._r8
        1374  5890903200 :         proc_rates%vtrmi(i,k)              = 0._r8
        1375  5890903200 :         proc_rates%qcsedten(i,k)           = 0._r8
        1376  5890903200 :         proc_rates%qisedten(i,k)           = 0._r8
        1377  5890903200 :         proc_rates%qrsedten(i,k)           = 0._r8
        1378  5890903200 :         proc_rates%qssedten(i,k)           = 0._r8
        1379  5890903200 :         proc_rates%qgsedten(i,k)           = 0._r8
        1380             :
        1381  5890903200 :         proc_rates%pratot(i,k)             = 0._r8
        1382  5890903200 :         proc_rates%prctot(i,k)             = 0._r8
        1383  5890903200 :         proc_rates%mnuccctot(i,k)          = 0._r8
        1384  5890903200 :         proc_rates%mnuccttot(i,k)          = 0._r8
        1385  5890903200 :         proc_rates%msacwitot(i,k)          = 0._r8
        1386  5890903200 :         proc_rates%psacwstot(i,k)          = 0._r8
        1387  5890903200 :         proc_rates%bergstot(i,k)           = 0._r8
        1388  5890903200 :         proc_rates%vapdepstot(i,k)         = 0._r8
        1389  5890903200 :         proc_rates%bergtot(i,k)            = 0._r8
        1390  5890903200 :         proc_rates%melttot(i,k)            = 0._r8
        1391             :
        1392  5890903200 :         proc_rates%mnudeptot(i,k)          = 0._r8
        1393  5890903200 :         proc_rates%meltstot(i,k)           = 0._r8
        1394  5890903200 :         proc_rates%meltgtot(i,k)           = 0._r8
        1395  5890903200 :         proc_rates%homotot(i,k)            = 0._r8
        1396  5890903200 :         proc_rates%qcrestot(i,k)           = 0._r8
        1397  5890903200 :         proc_rates%prcitot(i,k)            = 0._r8
        1398  5890903200 :         proc_rates%praitot(i,k)            = 0._r8
        1399  5890903200 :         proc_rates%qirestot(i,k)           = 0._r8
        1400  5890903200 :         proc_rates%mnuccrtot(i,k)          = 0._r8
        1401  5890903200 :         proc_rates%mnuccritot(i,k)         = 0._r8
        1402  5890903200 :         proc_rates%pracstot(i,k)           = 0._r8
        1403  5890903200 :         proc_rates%meltsdttot(i,k)         = 0._r8
        1404  5890903200 :         proc_rates%frzrdttot(i,k)          = 0._r8
        1405  5890903200 :         proc_rates%mnuccdtot(i,k)          = 0._r8
        1406  5890903200 :         proc_rates%psacrtot(i,k)           = 0._r8
        1407  5890903200 :         proc_rates%pracgtot(i,k)           = 0._r8
        1408  5890903200 :         proc_rates%psacwgtot(i,k)          = 0._r8
        1409  5890903200 :         proc_rates%pgsacwtot(i,k)          = 0._r8
        1410  5890903200 :         proc_rates%pgracstot(i,k)          = 0._r8
        1411  5890903200 :         proc_rates%prdgtot(i,k)            = 0._r8
        1412  5890903200 :         proc_rates%qmultgtot(i,k)          = 0._r8
        1413  5890903200 :         proc_rates%qmultrgtot(i,k)         = 0._r8
        1414  5890903200 :         proc_rates%npracgtot(i,k)          = 0._r8
        1415  5890903200 :         proc_rates%nscngtot(i,k)           = 0._r8
        1416  5890903200 :         proc_rates%ngracstot(i,k)          = 0._r8
        1417  5890903200 :         proc_rates%nmultgtot(i,k)          = 0._r8
        1418  5890903200 :         proc_rates%nmultrgtot(i,k)         = 0._r8
        1419  5890903200 :         proc_rates%npsacwgtot(i,k)         = 0._r8
        1420             :
        1421  5890903200 :         proc_rates%nnuccctot(i,k)          = 0._r8
        1422  5890903200 :         proc_rates%nnuccttot(i,k)          = 0._r8
        1423  5890903200 :         proc_rates%nnuccdtot(i,k)          = 0._r8
        1424  5890903200 :         proc_rates%nnudeptot(i,k)          = 0._r8
        1425  5890903200 :         proc_rates%nhomotot(i,k)           = 0._r8
        1426  5890903200 :         proc_rates%nnuccrtot(i,k)          = 0._r8
        1427  5890903200 :         proc_rates%nnuccritot(i,k)         = 0._r8
        1428  5890903200 :         proc_rates%nsacwitot(i,k)          = 0._r8
        1429  5890903200 :         proc_rates%npratot(i,k)            = 0._r8
        1430  5890903200 :         proc_rates%npsacwstot(i,k)         = 0._r8
        1431  5890903200 :         proc_rates%npraitot(i,k)           = 0._r8
        1432  5890903200 :         proc_rates%npracstot(i,k)          = 0._r8
        1433  5890903200 :         proc_rates%nprctot(i,k)            = 0._r8
        1434  5890903200 :         proc_rates%nraggtot(i,k)           = 0._r8
        1435  5890903200 :         proc_rates%nprcitot(i,k)           = 0._r8
        1436  5890903200 :         proc_rates%ncsedten(i,k)           = 0._r8
        1437  5890903200 :         proc_rates%nisedten(i,k)           = 0._r8
        1438  5890903200 :         proc_rates%nrsedten(i,k)           = 0._r8
        1439  5890903200 :         proc_rates%nssedten(i,k)           = 0._r8
        1440  5890903200 :         proc_rates%ngsedten(i,k)           = 0._r8
        1441  5890903200 :         proc_rates%nmelttot(i,k)           = 0._r8
        1442  5890903200 :         proc_rates%nmeltstot(i,k)          = 0._r8
        1443  5890903200 :         proc_rates%nmeltgtot(i,k)          = 0._r8
        1444             :
        1445             : !need to zero these out to be totally switchable (for conservation)
        1446  5890903200 :         psacr(i,k)              = 0._r8
        1447  5890903200 :         pracg(i,k)              = 0._r8
        1448  5890903200 :         psacwg(i,k)             = 0._r8
        1449  5890903200 :         pgsacw(i,k)             = 0._r8
        1450  5890903200 :         pgracs(i,k)             = 0._r8
        1451  5890903200 :         prdg(i,k)               = 0._r8
        1452  5890903200 :         qmultg(i,k)             = 0._r8
        1453  5890903200 :         qmultrg(i,k)            = 0._r8
        1454  5890903200 :         npracg(i,k)             = 0._r8
        1455  5890903200 :         nscng(i,k)              = 0._r8
        1456  5890903200 :         ngracs(i,k)             = 0._r8
        1457  5890903200 :         nmultg(i,k)             = 0._r8
        1458  5890903200 :         nmultrg(i,k)            = 0._r8
        1459  5890903200 :         npsacwg(i,k)            = 0._r8
        1460  5890903200 :         prc(i,k)                = 0._r8
        1461  5890903200 :         nprc(i,k)               = 0._r8
        1462  5890903200 :         nprc1(i,k)              = 0._r8
        1463  5890903200 :         pra(i,k)                = 0._r8
        1464  6266175552 :         npra(i,k)               = 0._r8
        1465             :      end do
        1466             :   end do
        1467             :   !$acc end parallel
        1468             :
        1469             :   !$acc parallel vector_length(VLENS) default(present)
        1470             :   !$acc loop gang vector collapse(2)
        1471   384207408 :   do k=1,nlev+1
        1472  6345240408 :      do i=1,mgncol
        1473  5961033000 :         rflx(i,k)               = 0._r8
        1474  5961033000 :         sflx(i,k)               = 0._r8
        1475  5961033000 :         lflx(i,k)               = 0._r8
        1476  5961033000 :         iflx(i,k)               = 0._r8
        1477  5961033000 :         gflx(i,k)               = 0._r8
        1478  6340772880 :         zint(i,k)               = 0._r8
        1479             :      end do
        1480             :   end do
        1481             :   !$acc end parallel
        1482             :
        1483             :   ! initialize precip at surface
        1484             :
        1485             :   !$acc parallel vector_length(VLENS) default(present)
        1486             :   !$acc loop gang vector
        1487    74597328 :   do i=1,mgncol
        1488    70129800 :      prect(i)                   = 0._r8
        1489    70129800 :      preci(i)                   = 0._r8
        1490    70129800 :      prect_i(i)                 = 0._r8
        1491    70129800 :      preci_i(i)                 = 0._r8
        1492    70129800 :      prect_l(i)                 = 0._r8
        1493    70129800 :      prect_r(i)                 = 0._r8
        1494    70129800 :      prect_s(i)                 = 0._r8
        1495    70129800 :      preci_s(i)                 = 0._r8
        1496    70129800 :      prect_g(i)                 = 0._r8
        1497    74597328 :      preci_g(i)                 = 0._r8
        1498             :   end do
        1499             :   !$acc end parallel
        1500             :
        1501             :   !$acc parallel vector_length(VLENS) default(present)
        1502             :   !$acc loop gang vector collapse(2)
        1503   379739880 :   do k=1,nlev
        1504  6270643080 :      do i=1,mgncol
        1505             :         ! initialize precip output
        1506  5890903200 :         qrout(i,k)              = 0._r8
        1507  5890903200 :         qsout(i,k)              = 0._r8
        1508  5890903200 :         nrout(i,k)              = 0._r8
        1509  5890903200 :         nsout(i,k)              = 0._r8
        1510  5890903200 :         qgout(i,k)              = 0._r8
        1511  5890903200 :         ngout(i,k)              = 0._r8
        1512             :
        1513             :         ! initialize rain size
        1514  5890903200 :         rercld(i,k)             = 0._r8
        1515             :
        1516  5890903200 :         qcsinksum_rate1ord(i,k) = 0._r8
        1517             :
        1518             :         ! initialize variables for trop_mozart
        1519  5890903200 :         nevapr(i,k)             = 0._r8
        1520  5890903200 :         prer_evap(i,k)          = 0._r8
        1521  5890903200 :         proc_rates%evapsnow(i,k)           = 0._r8
        1522  5890903200 :         am_evp_st(i,k)          = 0._r8
        1523  5890903200 :         prain(i,k)              = 0._r8
        1524  5890903200 :         proc_rates%prodsnow(i,k)           = 0._r8
        1525  5890903200 :         cmeout(i,k)             = 0._r8
        1526             :
        1527  5890903200 :         precip_frac(i,k)        = mincld
        1528  5890903200 :         lamc(i,k)               = 0._r8
        1529  5890903200 :         lamg(i,k)               = 0._r8
        1530             :
        1531             :         ! Interim variables for accretion
        1532  5890903200 :         rtmp(i,k)               = 0._r8
        1533  5890903200 :         ctmp(i,k)               = 0._r8
        1534  5890903200 :         ntmp(i,k)               = 0._r8
        1535             :
        1536             :         ! initialize microphysical tendencies
        1537  5890903200 :         tlat(i,k)               = 0._r8
        1538  5890903200 :         qvlat(i,k)              = 0._r8
        1539  5890903200 :         qctend(i,k)             = 0._r8
        1540  5890903200 :         qitend(i,k)             = 0._r8
        1541  5890903200 :         qstend(i,k)             = 0._r8
        1542  5890903200 :         qrtend(i,k)             = 0._r8
        1543  5890903200 :         nctend(i,k)             = 0._r8
        1544  5890903200 :         nitend(i,k)             = 0._r8
        1545  5890903200 :         nrtend(i,k)             = 0._r8
        1546  5890903200 :         nstend(i,k)             = 0._r8
        1547  5890903200 :         qgtend(i,k)             = 0._r8
        1548  5890903200 :         ngtend(i,k)             = 0._r8
        1549             :
        1550             :         ! initialize in-cloud and in-precip quantities to zero
        1551  5890903200 :         qcic(i,k)               = 0._r8
        1552  5890903200 :         qiic(i,k)               = 0._r8
        1553  5890903200 :         qsic(i,k)               = 0._r8
        1554  5890903200 :         qric(i,k)               = 0._r8
        1555  5890903200 :         qgic(i,k)               = 0._r8
        1556             :
        1557  5890903200 :         ncic(i,k)               = 0._r8
        1558  5890903200 :         niic(i,k)               = 0._r8
        1559  5890903200 :         nsic(i,k)               = 0._r8
        1560  5890903200 :         nric(i,k)               = 0._r8
        1561  6266175552 :         ngic(i,k)               = 0._r8
        1562             :      end do
        1563             :   end do
        1564             :   !$acc end parallel
        1565             :
        1566             :   !$acc parallel vector_length(VLENS) default(present)
        1567             :   !$acc loop gang vector collapse(2)
        1568   379739880 :   do k=1,nlev
        1569  6270643080 :      do i=1,mgncol
        1570             :         ! initialize vapor_deposition
        1571  5890903200 :         vap_dep(i,k)            = 0._r8
        1572  5890903200 :         vap_deps(i,k)           = 0._r8
        1573             :
        1574             :         ! initialize precip fallspeeds to zero
        1575  5890903200 :         proc_rates%ums(i,k)     = 0._r8
        1576  5890903200 :         uns(i,k)                = 0._r8
        1577  5890903200 :         proc_rates%umr(i,k)     = 0._r8
        1578  5890903200 :         unr(i,k)                = 0._r8
        1579  5890903200 :         proc_rates%umg(i,k)     = 0._r8
        1580  5890903200 :         ung(i,k)                = 0._r8
        1581             :
        1582             :         ! initialize limiter for output
        1583  5890903200 :         qcrat(i,k)              = 1._r8
        1584             :
        1585             :         ! Many outputs have to be initialized here at the top to work around
        1586             :         ! ifort problems, even if they are always overwritten later.
        1587  5890903200 :         effc(i,k)               = 10._r8
        1588  5890903200 :         lamcrad(i,k)            = 0._r8
        1589  5890903200 :         pgamrad(i,k)            = 0._r8
        1590  5890903200 :         effc_fn(i,k)            = 10._r8
        1591  5890903200 :         effi(i,k)               = 25._r8
        1592  5890903200 :         effi(i,k)               = effi(i,k)*micro_mg_effi_factor
        1593  5890903200 :         sadice(i,k)             = 0._r8
        1594  5890903200 :         sadsnow(i,k)            = 0._r8
        1595  5890903200 :         deffi(i,k)              = 50._r8
        1596             :
        1597  5890903200 :         qrout2(i,k)             = 0._r8
        1598  5890903200 :         nrout2(i,k)             = 0._r8
        1599  5890903200 :         drout2(i,k)             = 0._r8
        1600  5890903200 :         qsout2(i,k)             = 0._r8
        1601  5890903200 :         nsout2(i,k)             = 0._r8
        1602  5890903200 :         dsout(i,k)              = 0._r8
        1603  5890903200 :         dsout2(i,k)             = 0._r8
        1604  5890903200 :         qgout2(i,k)             = 0._r8
        1605  5890903200 :         ngout2(i,k)             = 0._r8
        1606  5890903200 :         freqg(i,k)              = 0._r8
        1607  5890903200 :         freqr(i,k)              = 0._r8
        1608  5890903200 :         freqs(i,k)              = 0._r8
        1609             :
        1610  5890903200 :         reff_rain(i,k)          = 0._r8
        1611  5890903200 :         reff_snow(i,k)          = 0._r8
        1612  5890903200 :         reff_grau(i,k)          = 0._r8
        1613             :
        1614  5890903200 :         refl(i,k)               = -9999._r8
        1615  5890903200 :         arefl(i,k)              = 0._r8
        1616  5890903200 :         areflz(i,k)             = 0._r8
        1617  5890903200 :         frefl(i,k)              = 0._r8
        1618  5890903200 :         csrfl(i,k)              = 0._r8
        1619  5890903200 :         acsrfl(i,k)             = 0._r8
        1620  5890903200 :         fcsrfl(i,k)             = 0._r8
        1621             :
        1622  5890903200 :         refl10cm(i,k)           = -9999._r8
        1623  5890903200 :         reflz10cm(i,k)          =  0._r8
        1624             :
        1625  5890903200 :         ncal(i,k)               = 0._r8
        1626  5890903200 :         ncai(i,k)               = 0._r8
        1627  5890903200 :         nfice(i,k)              = 0._r8
        1628             :
        1629  5890903200 :         pdel_inv(i,k)           = 1._r8/pdel(i,k)
        1630  5890903200 :         tlat_i(i,k)             = 0._r8
        1631  5890903200 :         qvlat_i(i,k)            = 0._r8
        1632  5890903200 :         tlat_l(i,k)             = 0._r8
        1633  5890903200 :         qvlat_l(i,k)            = 0._r8
        1634             :
        1635  5890903200 :         nnudep(i,k)             = 0._r8
        1636  5890903200 :         mnudep(i,k)             = 0._r8
        1637  5890903200 :         nragg(i,k)              = 0._r8
        1638             :
        1639  5890903200 :         proc_rates%qctend_KK2000(i,k) = 0._r8
        1640  5890903200 :         proc_rates%nctend_KK2000(i,k) = 0._r8
        1641  5890903200 :         proc_rates%qrtend_KK2000(i,k) = 0._r8
        1642  5890903200 :         proc_rates%nrtend_KK2000(i,k) = 0._r8
        1643  5890903200 :         proc_rates%lamc_out(i,k)      = 0._r8
        1644  5890903200 :         proc_rates%lamr_out(i,k)      = 0._r8
        1645  5890903200 :         proc_rates%pgam_out(i,k)      = 0._r8
        1646  6266175552 :         proc_rates%n0r_out(i,k)       = 0._r8
        1647             :      end do
        1648             :   end do
        1649             :   !$acc end parallel
        1650             :
        1651     4467528 :   if (trim(warm_rain) == 'sb2001') then
        1652             :      !$acc parallel vector_length(VLENS) default(present)
        1653             :      !$acc loop gang vector collapse(2)
        1654           0 :      do k=1,nlev
        1655           0 :         do i=1,mgncol
        1656           0 :            proc_rates%qctend_SB2001(i,k) = 0._r8
        1657           0 :            proc_rates%nctend_SB2001(i,k) = 0._r8
        1658           0 :            proc_rates%qrtend_SB2001(i,k) = 0._r8
        1659           0 :            proc_rates%nrtend_SB2001(i,k) = 0._r8
        1660             :         end do
        1661             :      end do
        1662             :      !$acc end parallel
        1663             :   end if
        1664             :
        1665     4467528 :   if (trim(warm_rain) == 'tau' .or. trim(warm_rain) == 'emulated') then
        1666             :      !$acc parallel vector_length(VLENS) default(present)
        1667             :      !$acc loop gang vector collapse(2)
        1668           0 :      do k=1,nlev
        1669           0 :         do i=1,mgncol
        1670           0 :            proc_rates%qctend_TAU(i,k) = 0._r8
        1671           0 :            proc_rates%nctend_TAU(i,k) = 0._r8
        1672           0 :            proc_rates%qrtend_TAU(i,k) = 0._r8
        1673           0 :            proc_rates%nrtend_TAU(i,k) = 0._r8
        1674           0 :            proc_rates%qc_out_TAU(i,k) = 0._r8
        1675           0 :            proc_rates%nc_out_TAU(i,k) = 0._r8
        1676           0 :            proc_rates%qr_out_TAU(i,k) = 0._r8
        1677           0 :            proc_rates%nr_out_TAU(i,k) = 0._r8
        1678           0 :            proc_rates%qc_in_TAU(i,k) = 0._r8
        1679           0 :            proc_rates%nc_in_TAU(i,k) = 0._r8
        1680           0 :            proc_rates%qr_in_TAU(i,k) = 0._r8
        1681           0 :            proc_rates%nr_in_TAU(i,k) = 0._r8
        1682           0 :            proc_rates%gmnnn_lmnnn_TAU(i,k) = 0._r8
        1683             :         end do
        1684             :      end do
        1685             :      !$acc end parallel
        1686             :   end if
        1687             :
        1688             :   !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        1689             :   ! droplet activation
        1690             :   ! get provisional droplet number after activation. This is used for
        1691             :   ! all microphysical process calculations, for consistency with update of
        1692             :   ! droplet mass before microphysics
        1693             :
        1694             :   ! calculate potential for droplet activation if cloud water is present
        1695             :   ! tendency from activation (npccn) is read in from companion routine
        1696             :
        1697             :   ! output activated liquid and ice (convert from #/kg -> #/m3)
        1698             :   !--------------------------------------------------
        1699             :
        1700             :   !$acc parallel vector_length(VLENS) default(present)
        1701             :   !$acc loop gang vector collapse(2)
        1702   379739880 :   do k=1,nlev
        1703  6270643080 :      do i=1,mgncol
        1704  5890903200 :         if (qc(i,k) >= qsmall) then
        1705   512413729 :            nc(i,k) = max(nc(i,k) + npccn(i,k)*deltat, 0._r8)
        1706   512413729 :            ncal(i,k) = npccn(i,k)
        1707             :         else
        1708  5378489471 :            ncal(i,k) = 0._r8
        1709             :         end if
        1710             :
        1711  5890903200 :         if (t(i,k) < icenuct) then
        1712  4574163907 :            ncai(i,k) = naai(i,k)*deltat*rho(i,k)
        1713             :         else
        1714  1316739293 :            ncai(i,k) = 0._r8
        1715             :         end if
        1716             :
        1717             :   !===============================================
        1718             :
        1719             :   ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5%
        1720             :   !
        1721             :   ! NOTE: If using gridbox average values, condensation will not occur until rh=1,
        1722             :   ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid
        1723             :   ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus
        1724             :   ! the nucleation threshold should also be 1.05 and not rhmini + 0.05.
        1725             :   !-------------------------------------------------------
        1726             :
        1727  6266175552 :         if (do_cldice) then
        1728  5890903200 :            if (icenuc_rh_off) then
        1729           0 :               if (naai(i,k) > 0._r8 .and. t(i,k) < icenuct) then
        1730             :                  !if NAAI > 0. then set numice = naai (as before)
        1731             :                  !note: this is gridbox averaged
        1732           0 :                  nnuccd(i,k) = naai(i,k)*icldm(i,k)
        1733           0 :                  nnuccd(i,k) = max(nnuccd(i,k),0._r8)
        1734             :
        1735             :                  !Calc mass of new particles using new crystal mass...
        1736             :                  !also this will be multiplied by mtime as nnuccd is...
        1737           0 :                  mnuccd(i,k) = nnuccd(i,k) * mi0
        1738             :               else
        1739           0 :                  nnuccd(i,k) = 0._r8
        1740           0 :                  mnuccd(i,k) = 0._r8
        1741             :               end if
        1742             :            else
        1743  5890903200 :               if (naai(i,k) > 0._r8 .and. t(i,k) < icenuct .and. &
        1744             :                  relhum(i,k)*esl(i,k)/esi(i,k) > 1.05_r8) then
        1745             :                  !if NAAI > 0. then set numice = naai (as before)
        1746             :                  !note: this is gridbox averaged
        1747   136479667 :                  nnuccd(i,k) = naai(i,k)*icldm(i,k)
        1748   136479667 :                  nnuccd(i,k) = max(nnuccd(i,k),0._r8)
        1749             :
        1750             :                  !Calc mass of new particles using new crystal mass...
        1751             :                  !also this will be multiplied by mtime as nnuccd is...
        1752   136479667 :                  mnuccd(i,k) = nnuccd(i,k) * mi0
        1753             :               else
        1754  5754423533 :                  nnuccd(i,k) = 0._r8
        1755  5754423533 :                  mnuccd(i,k) = 0._r8
        1756             :               end if
        1757             :            end if
        1758             :         end if
        1759             :      end do
        1760             :   end do
        1761             :   !$acc end parallel
        1762             :
        1763             :   !=============================================================================
        1764             :
        1765             :   !$acc parallel vector_length(VLENS) default(present)
        1766             :   !$acc loop gang vector collapse(2)
        1767   379739880 :   do k=1,nlev
        1768  6270643080 :      do i=1,mgncol
        1769             :         ! calculate instantaneous precip processes (melting and homogeneous freezing)
        1770             :         ! melting of snow at +2 C
        1771  5890903200 :         if (t(i,k) > snowmelt) then
        1772  1042844582 :            if (qs(i,k) > 0._r8) then
        1773             :               ! make sure melting snow doesn't reduce temperature below threshold
        1774  1042844450 :               dum = -xlf/cpp*qs(i,k)
        1775  1042844450 :               if (t(i,k)+dum < snowmelt) then
        1776      417972 :                  dum = (t(i,k)-snowmelt)*cpp/xlf
        1777      417972 :                  dum = dum/qs(i,k)
        1778      417972 :                  dum = max(0._r8,dum)
        1779      417972 :                  dum = min(1._r8,dum)
        1780             :               else
        1781             :                  dum = 1._r8
        1782             :               end if
        1783             :
        1784  1042844450 :               minstsm(i,k) = dum*qs(i,k)
        1785  1042844450 :               ninstsm(i,k) = dum*ns(i,k)
        1786             :
        1787  1042844450 :               dum1=-xlf*minstsm(i,k)*rdeltat
        1788  1042844450 :               tlat(i,k)=tlat(i,k)+dum1
        1789  1042844450 :               proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
        1790  1042844450 :               proc_rates%meltstot(i,k)=minstsm(i,k)*rdeltat
        1791             :
        1792  1042844450 :               qs(i,k) = max(qs(i,k) - minstsm(i,k), 0._r8)
        1793  1042844450 :               ns(i,k) = max(ns(i,k) - ninstsm(i,k), 0._r8)
        1794  1042844450 :               qr(i,k) = max(qr(i,k) + minstsm(i,k), 0._r8)
        1795  1042844450 :               nr(i,k) = max(nr(i,k) + ninstsm(i,k), 0._r8)
        1796             :            end if
        1797             :         end if
        1798             :
        1799             :         ! melting of graupel at +2 C
        1800             :
        1801  5890903200 :         if (t(i,k) > snowmelt) then
        1802  1042844582 :            if (qg(i,k) > 0._r8) then
        1803             :
        1804             :               ! make sure melting graupel doesn't reduce temperature below threshold
        1805  1042844453 :               dum = -xlf/cpp*qg(i,k)
        1806  1042844453 :               if (t(i,k)+dum < snowmelt) then
        1807      176077 :                  dum = (t(i,k)-snowmelt)*cpp/xlf
        1808      176077 :                  dum = dum/qg(i,k)
        1809      176077 :                  dum = max(0._r8,dum)
        1810      176077 :                  dum = min(1._r8,dum)
        1811             :               else
        1812             :                  dum = 1._r8
        1813             :               end if
        1814             :
        1815  1042844453 :               minstgm(i,k) = dum*qg(i,k)
        1816  1042844453 :               ninstgm(i,k) = dum*ng(i,k)
        1817             :
        1818  1042844453 :               dum1=-xlf*minstgm(i,k)*rdeltat
        1819  1042844453 :               tlat(i,k)=tlat(i,k)+dum1
        1820  1042844453 :               proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
        1821  1042844453 :               proc_rates%meltgtot(i,k)=minstgm(i,k)*rdeltat
        1822             :
        1823  1042844453 :               qg(i,k) = max(qg(i,k) - minstgm(i,k), 0._r8)
        1824  1042844453 :               ng(i,k) = max(ng(i,k) - ninstgm(i,k), 0._r8)
        1825  1042844453 :               qr(i,k) = max(qr(i,k) + minstgm(i,k), 0._r8)
        1826  1042844453 :               nr(i,k) = max(nr(i,k) + ninstgm(i,k), 0._r8)
        1827             :            end if
        1828             :         end if
        1829             :
        1830             :         ! freezing of rain at -5 C
        1831             :
        1832  6266175552 :         if (t(i,k) < rainfrze) then
        1833             :
        1834  3233807170 :            if (qr(i,k) > 0._r8) then
        1835             :
        1836             :               ! make sure freezing rain doesn't increase temperature above threshold
        1837  3233228109 :               dum = xlf/cpp*qr(i,k)
        1838  3233228109 :               if (t(i,k)+dum > rainfrze) then
        1839           7 :                  dum = -(t(i,k)-rainfrze)*cpp/xlf
        1840           7 :                  dum = dum/qr(i,k)
        1841           7 :                  dum = max(0._r8,dum)
        1842           7 :                  dum = min(1._r8,dum)
        1843             :               else
        1844             :                  dum = 1._r8
        1845             :               end if
        1846             :
        1847  3233228109 :               minstrf(i,k) = dum*qr(i,k)
        1848  3233228109 :               ninstrf(i,k) = dum*nr(i,k)
        1849             :
        1850             :               ! heating tendency
        1851  3233228109 :               dum1 = xlf*minstrf(i,k)*rdeltat
        1852  3233228109 :               tlat(i,k)=tlat(i,k)+dum1
        1853  3233228109 :               proc_rates%frzrdttot(i,k)=proc_rates%frzrdttot(i,k) + dum1
        1854             :
        1855  3233228109 :               qr(i,k) = max(qr(i,k) - minstrf(i,k), 0._r8)
        1856  3233228109 :               nr(i,k) = max(nr(i,k) - ninstrf(i,k), 0._r8)
        1857             :
        1858             :               ! freeze rain to graupel not snow.
        1859  3233228109 :               if(do_hail.or.do_graupel) then
        1860  3233228109 :                  qg(i,k) = max(qg(i,k) + minstrf(i,k), 0._r8)
        1861  3233228109 :                  ng(i,k) = max(ng(i,k) + ninstrf(i,k), 0._r8)
        1862             :               else
        1863           0 :                  qs(i,k) = max(qs(i,k) + minstrf(i,k), 0._r8)
        1864           0 :                  ns(i,k) = max(ns(i,k) + ninstrf(i,k), 0._r8)
        1865             :               end if
        1866             :            end if
        1867             :         end if
        1868             :      end do
        1869             :   end do
        1870             :   !$acc end parallel
        1871             :
        1872             :   !$acc parallel vector_length(VLENS) default(present)
        1873             :   !$acc loop gang vector collapse(2)
        1874   379739880 :   do k=1,nlev
        1875  6270643080 :     do i=1,mgncol
        1876             :         ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations
        1877             :         !-------------------------------------------------------
        1878             :         ! for microphysical process calculations
        1879             :         ! units are kg/kg for mixing ratio, 1/kg for number conc
        1880             :
        1881  5890903200 :         if (qc(i,k).ge.qsmall) then
        1882             :            ! limit in-cloud values to 0.005 kg/kg
        1883   512413729 :            qcic(i,k)=min(qc(i,k)/lcldm(i,k),5.e-3_r8)
        1884   512413729 :            ncic(i,k)=max(nc(i,k)/lcldm(i,k),0._r8)
        1885             :
        1886             :            ! specify droplet concentration
        1887   512413729 :            if (nccons) then
        1888           0 :               ncic(i,k)=ncnst/rho(i,k)
        1889             :            end if
        1890             :         else
        1891  5378489471 :            qcic(i,k)=0._r8
        1892  5378489471 :            ncic(i,k)=0._r8
        1893             :         end if
        1894             :
        1895  5890903200 :         if (qi(i,k).ge.qsmall) then
        1896             :            ! limit in-cloud values to 0.005 kg/kg
        1897  1341873208 :            qiic(i,k)=min(qi(i,k)/icldm(i,k),5.e-3_r8)
        1898  1341873208 :            niic(i,k)=max(ni(i,k)/icldm(i,k),0._r8)
        1899             :
        1900             :            ! switch for specification of cloud ice number
        1901  1341873208 :            if (nicons) then
        1902           0 :               niic(i,k)=ninst/rho(i,k)
        1903             :            end if
        1904             :         else
        1905  4549029992 :            qiic(i,k)=0._r8
        1906  4549029992 :            niic(i,k)=0._r8
        1907             :         end if
        1908             :
        1909             :   !========================================================================
        1910             :
        1911             :   ! for sub-columns cldm has already been set to 1 if cloud
        1912             :   ! water or ice is present, so precip_frac will be correctly set below
        1913             :   ! and nothing extra needs to be done here
        1914             :
        1915  6266175552 :         precip_frac(i,k) = cldm(i,k)
        1916             :      end do
        1917             :   end do
        1918             :   !$acc end parallel
        1919             :
        1920     4467528 :   if (precip_frac_method == MG_PRECIP_FRAC_INCLOUD) then
        1921             :      !$acc parallel vector_length(VLENS) default(present)
        1922             :      !$acc loop gang vector
        1923    74597328 :      do i=1,mgncol
        1924             :         !$acc loop seq
        1925  5895370728 :         do k=2,nlev
        1926  5890903200 :            if (qc(i,k) < qsmall .and. qi(i,k) < qsmall) then
        1927  4161758578 :               precip_frac(i,k) = precip_frac(i,k-1)
        1928             :            end if
        1929             :         end do
        1930             :      end do
        1931             :      !$acc end parallel
        1932           0 :   else if (precip_frac_method == MG_PRECIP_FRAC_OVERLAP) then
        1933             :      ! calculate precip fraction based on maximum overlap assumption
        1934             :
        1935             :      ! if rain or snow mix ratios are smaller than threshold,
        1936             :      ! then leave precip_frac as cloud fraction at current level
        1937             :
        1938             :      !$acc parallel vector_length(VLENS) default(present)
        1939             :      !$acc loop gang vector
        1940           0 :      do i=1,mgncol
        1941             :         !$acc loop seq
        1942           0 :         do k=2,nlev
        1943           0 :            if (qr(i,k-1) >= qsmall .or. qs(i,k-1) >= qsmall .or. qg(i,k-1) >= qsmall) then
        1944           0 :               precip_frac(i,k)=max(precip_frac(i,k-1),precip_frac(i,k))
        1945             :            end if
        1946             :         end do
        1947             :      end do
        1948             :      !$acc end parallel
        1949             :   end if
        1950             :
        1951             :   !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        1952             :   ! get size distribution parameters based on in-cloud cloud water
        1953             :   ! these calculations also ensure consistency between number and mixing ratio
        1954             :   !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        1955             :
        1956             :   ! cloud liquid
        1957             :   !-------------------------------------------
        1958     4467528 :   call size_dist_param_liq(mg_liq_props, qcic, ncic, rho, pgam, lamc, mgncol, nlev)
        1959             :
        1960             :
        1961             :   !$acc parallel vector_length(VLENS) default(present)
        1962             :   !$acc loop gang vector collapse(2)
        1963   379739880 :   do k=1,nlev
        1964  6270643080 :      do i=1,mgncol
        1965             :         ! assign qric based on prognostic qr, using assumed precip fraction
        1966             :         ! note: this could be moved above for consistency with qcic and qiic calculations
        1967  5890903200 :         qric(i,k) = qr(i,k)/precip_frac(i,k)
        1968  5890903200 :         nric(i,k) = nr(i,k)/precip_frac(i,k)
        1969             :
        1970             :         ! limit in-precip mixing ratios to 10 g/kg
        1971  5890903200 :         qric(i,k)=min(qric(i,k),0.01_r8)
        1972             :
        1973             :         ! add autoconversion to precip from above to get provisional rain mixing ratio
        1974             :         ! and number concentration (qric and nric)
        1975             :
        1976  5890903200 :         if (qric(i,k).lt.qsmall) then
        1977  4455952799 :            qric(i,k)=0._r8
        1978  4455952799 :            nric(i,k)=0._r8
        1979             :         end if
        1980             :
        1981             :         ! make sure number concentration is a positive number to avoid
        1982             :         ! taking root of negative later
        1983             :
        1984  6266175552 :         nric(i,k)=max(nric(i,k),0._r8)
        1985             :      end do
        1986             :   end do
        1987             :   !$acc end parallel
        1988             :
        1989             :   ! get size distribution parameters for rain
        1990             :   !......................................................................
        1991             :
        1992     4467528 :   call size_dist_param_basic(mg_rain_props, qric, nric, lamr, mgncol, nlev, n0=n0r)
        1993             :
        1994             :   ! Save off size distribution parameters for output
        1995             :   !$acc parallel vector_length(VLENS) default(present)
        1996             :   !$acc loop gang vector collapse(2)
        1997   379739880 :   do k=1,nlev
        1998  6270643080 :      do i=1,mgncol
        1999  5890903200 :         proc_rates%pgam_out(i,k)=pgam(i,k)
        2000  5890903200 :         proc_rates%n0r_out(i,k)=n0r(i,k)
        2001  5890903200 :         proc_rates%lamc_out(i,k)=lamc(i,k)
        2002  6266175552 :         proc_rates%lamr_out(i,k)=lamr(i,k)
        2003             :      end do
        2004             :   end do
        2005             :   !$acc end parallel
        2006             :
        2007             :   !========================================================================
        2008             :   ! autoconversion of cloud liquid water to rain
        2009             :   ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc
        2010             :   ! minimum qc of 1 x 10^-8 prevents floating point error
        2011             :
        2012             :   call kk2000_liq_autoconversion(microp_uniform, qcic, ncic, rho, relvar, &
        2013             :                       proc_rates%qctend_KK2000, proc_rates%nrtend_KK2000, &
        2014             :                       proc_rates%nctend_KK2000, micro_mg_autocon_fact, &
        2015             :                       micro_mg_autocon_nd_exp, micro_mg_autocon_lwp_exp, &
        2016     4467528 :                       mgncol*nlev)
        2017             :
        2018             :   ! Write to pumas tendency arrays if kk2000 is active, otherwise just record diagnostics
        2019             :
        2020     4467528 :   if ( trim(warm_rain) == 'kk2000' ) then
        2021             :      !$acc parallel vector_length(VLENS) default(present)
        2022             :      !$acc loop gang vector collapse(2)
        2023   379739880 :      do k=1,nlev
        2024  6270643080 :         do i=1,mgncol
        2025  5890903200 :            prc(i,k)=proc_rates%qctend_KK2000(i,k)
        2026  5890903200 :            nprc1(i,k)=proc_rates%nctend_KK2000(i,k)
        2027  5890903200 :            nprc(i,k)=proc_rates%nrtend_KK2000(i,k)
        2028  6266175552 :            proc_rates%qrtend_KK2000(i,k)=-proc_rates%qctend_KK2000(i,k)
        2029             :         end do
        2030             :      end do
        2031             :      !$acc end parallel
        2032             :   end if
        2033             :
        2034     4467528 :   if ( trim(warm_rain) == 'tau' ) then
        2035             :      call pumas_stochastic_collect_tau_tend(deltatin,t,rho,qcn,qrn,qcic,ncic,qric, &
        2036             :                                       nric,lcldm,precip_frac,pgam,lamc,n0r,lamr,   &
        2037             :                                       proc_rates%qc_out_TAU,proc_rates%nc_out_TAU, &
        2038             :                                       proc_rates%qr_out_TAU,proc_rates%nr_out_TAU, &
        2039             :                                       qctend,nctend,qrtend,nrtend, &
        2040             :                                       proc_rates%qctend_TAU,proc_rates%nctend_TAU, &
        2041             :                                       proc_rates%qrtend_TAU,proc_rates%nrtend_TAU, &
        2042             :                                       proc_rates%scale_qc,proc_rates%scale_nc, &
        2043             :                                       proc_rates%scale_qr,proc_rates%scale_nr, &
        2044             :                                       proc_rates%amk_c,proc_rates%ank_c, &
        2045             :                                       proc_rates%amk_r,proc_rates%ank_r, &
        2046             :                                       proc_rates%amk, proc_rates%ank, &
        2047             :                                       proc_rates%amk_out, proc_rates%ank_out, &
        2048           0 :                                       proc_rates%gmnnn_lmnnn_TAU,mgncol,nlev)
        2049             :
        2050             :      !$acc parallel vector_length(VLENS) default(present)
        2051             :      !$acc loop gang vector collapse(2)
        2052           0 :      do k=1,nlev
        2053           0 :         do i=1,mgncol
        2054           0 :            proc_rates%qc_in_TAU(i,k)=qcic(i,k)
        2055           0 :            proc_rates%nc_in_TAU(i,k)=ncic(i,k)
        2056           0 :            proc_rates%qr_in_TAU(i,k)=qric(i,k)
        2057           0 :            proc_rates%nr_in_TAU(i,k)=nric(i,k)
        2058             :            ! PUMAS expects prc and nprc1 (cloud rates) are positive
        2059           0 :            prc(i,k)= -proc_rates%qctend_TAU(i,k)
        2060           0 :            nprc1(i,k)= -proc_rates%nctend_TAU(i,k)
        2061             :
        2062             :            ! PUMAS expects nprc to be positive. Negative nrtend_TAU is from self collection, so put it into nragg
        2063           0 :            if ( proc_rates%nrtend_TAU(i,k) > 0._r8 ) then
        2064           0 :               nprc(i,k)= proc_rates%nrtend_TAU(i,k)
        2065             :            else
        2066           0 :               nragg(i,k) = proc_rates%nrtend_TAU(i,k)
        2067             :            end if
        2068             :         end do
        2069             :      end do
        2070             :      !$acc end parallel
        2071             :
        2072     4467528 :   else if (trim(warm_rain) == 'emulated') then
        2073             :      ! JS - 08/22/2023: this code block only works on CPU
        2074             :
        2075             :      !$acc update self(qcic,ncic,qric,nric,rho,lcldm,precip_frac, &
        2076             :      !$acc             proc_rates%qctend_TAU,proc_rates%qrtend_TAU, &
        2077             :      !$acc             proc_rates%nctend_TAU,proc_rates%nrtend_TAU, &
        2078             :      !$acc             qc,nc,qr,nr,prc,nprc1,nprc,nragg)
        2079             :
        2080           0 :      do k=1,nlev
        2081             :         call tau_emulated_cloud_rain_interactions(qcic(1:mgncol,k), ncic(1:mgncol,k), &
        2082             :                                                   qric(1:mgncol,k), nric(1:mgncol,k), &
        2083             :                                                   rho(1:mgncol,k), lcldm(1:mgncol,k), &
        2084             :                                                   precip_frac(1:mgncol,k), mgncol, qsmall, &
        2085           0 :                                                   proc_rates%qctend_TAU(1:mgncol,k), &
        2086           0 :                                                   proc_rates%qrtend_TAU(1:mgncol,k), &
        2087           0 :                                                   proc_rates%nctend_TAU(1:mgncol,k), &
        2088           0 :                                                   proc_rates%nrtend_TAU(1:mgncol,k))
        2089             :
        2090             :         call ML_fixer_calc(mgncol, deltatin, qc(1:mgncol,k), nc(1:mgncol,k), &
        2091           0 :                            qr(1:mgncol,k), nr(1:mgncol,k), &
        2092           0 :                            proc_rates%qctend_TAU(1:mgncol,k),&
        2093           0 :                            proc_rates%nctend_TAU(1:mgncol,k), &
        2094           0 :                            proc_rates%qrtend_TAU(1:mgncol,k), &
        2095           0 :                            proc_rates%nrtend_TAU(1:mgncol,k), &
        2096           0 :                            proc_rates%ML_fixer(1:mgncol,k), &
        2097           0 :                            proc_rates%QC_fixer(1:mgncol,k), &
        2098           0 :                            proc_rates%NC_fixer(1:mgncol,k), &
        2099           0 :                            proc_rates%QR_fixer(1:mgncol,k), &
        2100           0 :                            proc_rates%NR_fixer(1:mgncol,k))
        2101             :
        2102             :         ! PUMAS expects prc and nprc1 (cloud rates) are positive
        2103           0 :         prc(1:mgncol,k)= -proc_rates%qctend_TAU(1:mgncol,k)
        2104           0 :         nprc1(1:mgncol,k)= -proc_rates%nctend_TAU(1:mgncol,k)
        2105             :
        2106             :         ! PUMAS expects nprc to be positive. Negative nrtend_TAU is from self
        2107             :         ! collection, so put it into nragg
        2108           0 :         do i=1,mgncol
        2109           0 :            if (proc_rates%nrtend_TAU(i,k).gt.0._r8) then
        2110           0 :               nprc(i,k)= proc_rates%nrtend_TAU(i,k)
        2111             :            else
        2112           0 :               nragg(i,k)= proc_rates%nrtend_TAU(i,k)
        2113             :            end if
        2114             :         end do
        2115             :
        2116             :      end do
        2117             :
        2118             :      !$acc update device(proc_rates%qctend_TAU,proc_rates%qrtend_TAU, &
        2119             :      !$acc               proc_rates%nctend_TAU,proc_rates%nrtend_TAU, &
        2120             :      !$acc               prc,nprc1,nprc,nragg)
        2121             :
        2122             :   end if
        2123             :
        2124             :   ! Alternative autoconversion
        2125     4467528 :   if (trim(warm_rain) == 'sb2001') then
        2126             :      call sb2001v2_liq_autoconversion(pgam,qcic,ncic,qric,rho,relvar, &
        2127             :                                       proc_rates%qctend_SB2001, &
        2128             :                                       proc_rates%nrtend_SB2001, &
        2129             :                                       proc_rates%nctend_SB2001, &
        2130           0 :                                       mgncol*nlev)
        2131             :
        2132             :      !$acc parallel vector_length(VLENS) default(present)
        2133             :      !$acc loop gang vector collapse(2)
        2134           0 :      do k=1,nlev
        2135           0 :         do i=1,mgncol
        2136           0 :            prc(i,k)=proc_rates%qctend_SB2001(i,k)
        2137           0 :            nprc(i,k)=proc_rates%nrtend_SB2001(i,k)
        2138           0 :            nprc1(i,k)=proc_rates%nctend_SB2001(i,k)
        2139           0 :            proc_rates%qrtend_SB2001(i,k)= -proc_rates%qctend_SB2001(i,k)
        2140             :         end do
        2141             :      end do
        2142             :      !$acc end parallel
        2143             :   end if
        2144             :
        2145             :   ! Get size distribution parameters for cloud ice
        2146     4467528 :   call size_dist_param_basic(mg_ice_props, qiic, niic, lami, mgncol, nlev, n0=n0i)
        2147             :
        2148             :   !.......................................................................
        2149             :   ! Autoconversion of cloud ice to snow
        2150             :   ! similar to Ferrier (1994)
        2151     4467528 :   if (do_cldice) then
        2152     4467528 :      call ice_autoconversion(t, qiic, lami, n0i, dcs, prci, nprci, mgncol*nlev)
        2153             :   else
        2154             :      ! Add in the particles that we have already converted to snow, and
        2155             :      ! don't do any further autoconversion of ice.
        2156             :
        2157             :      !$acc parallel vector_length(VLENS) default(present)
        2158             :      !$acc loop gang vector collapse(2)
        2159           0 :      do k=1,nlev
        2160           0 :         do i=1,mgncol
        2161           0 :            prci(i,k)  = tnd_qsnow(i,k) / cldm(i,k)
        2162           0 :            nprci(i,k) = tnd_nsnow(i,k) / cldm(i,k)
        2163             :         end do
        2164             :      end do
        2165             :      !$acc end parallel
        2166             :   end if
        2167             :
        2168             :   ! note, currently we don't have this
        2169             :   ! inside the do_cldice block, should be changed later
        2170             :   ! assign qsic based on prognostic qs, using assumed precip fraction
        2171             :
        2172             :   !$acc parallel vector_length(VLENS) default(present)
        2173             :   !$acc loop gang vector collapse(2)
        2174   379739880 :   do k=1,nlev
        2175  6270643080 :      do i=1,mgncol
        2176  5890903200 :         qsic(i,k) = qs(i,k)/precip_frac(i,k)
        2177  5890903200 :         nsic(i,k) = ns(i,k)/precip_frac(i,k)
        2178             :
        2179             :         ! limit in-precip mixing ratios to 10 g/kg
        2180  5890903200 :         qsic(i,k)=min(qsic(i,k),0.01_r8)
        2181             :
        2182             :         ! if precip mix ratio is zero so should number concentration
        2183  5890903200 :         if (qsic(i,k) < qsmall) then
        2184  4300794524 :            qsic(i,k)=0._r8
        2185  4300794524 :            nsic(i,k)=0._r8
        2186             :         end if
        2187             :
        2188             :         ! make sure number concentration is a positive number to avoid
        2189             :         ! taking root of negative later
        2190  5890903200 :         nsic(i,k)=max(nsic(i,k),0._r8)
        2191             :
        2192             :         ! also do this for graupel, which is assumed to be 'precip_frac'
        2193  5890903200 :         qgic(i,k) = qg(i,k)/precip_frac(i,k)
        2194  5890903200 :         ngic(i,k) = ng(i,k)/precip_frac(i,k)
        2195             :
        2196             :         ! limit in-precip mixing ratios to 10 g/kg
        2197  5890903200 :         qgic(i,k)=min(qgic(i,k),0.01_r8)
        2198             :
        2199             :         ! if precip mix ratio is zero so should number concentration
        2200  5890903200 :         if (qgic(i,k) < qsmall) then
        2201  5130310782 :            qgic(i,k)=0._r8
        2202  5130310782 :            ngic(i,k)=0._r8
        2203             :         end if
        2204             :
        2205             :         ! make sure number concentration is a positive number to avoid
        2206             :         ! taking root of negative later
        2207  6266175552 :         ngic(i,k)=max(ngic(i,k),0._r8)
        2208             :      end do
        2209             :   end do
        2210             :   !$acc end parallel
        2211             :
        2212             :   !$acc parallel vector_length(VLENS) default(present)
        2213             :   !$acc loop gang vector collapse(2)
        2214   379739880 :   do k=1,nlev
        2215  6270643080 :      do i=1,mgncol
        2216  6266175552 :         if (lamr(i,k) >= qsmall) then
        2217  1434950401 :            dum_2D(i,k)= lamr(i,k)**br
        2218             :            ! provisional rain number and mass weighted mean fallspeed (m/s)
        2219  1434950401 :            unr(i,k) = min(arn(i,k)*gamma_br_plus1/dum_2D(i,k),9.1_r8*rhof(i,k))
        2220  1434950401 :            proc_rates%umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*dum_2D(i,k)),9.1_r8*rhof(i,k))
        2221             :         else
        2222  4455952799 :            proc_rates%umr(i,k) = 0._r8
        2223  4455952799 :            unr(i,k) = 0._r8
        2224             :         end if
        2225             :      end do
        2226             :   end do
        2227             :   !$acc end parallel
        2228             :
        2229             :   !......................................................................
        2230             :   ! snow
        2231     4467528 :   call size_dist_param_basic(mg_snow_props, qsic, nsic, lams, mgncol, nlev, n0=n0s)
        2232             :
        2233             :   !$acc parallel vector_length(VLENS) default(present)
        2234             :   !$acc loop gang vector collapse(2)
        2235   379739880 :   do k=1,nlev
        2236  6270643080 :      do i=1,mgncol
        2237  6266175552 :         if (ifs_sed) then
        2238           0 :            if (lams(i,k) > 0._r8) then
        2239           0 :               proc_rates%ums(i,k) = 1._r8
        2240           0 :               uns(i,k) = 1._r8
        2241             :            else
        2242           0 :               proc_rates%ums(i,k) = 0._r8
        2243           0 :               uns(i,k) = 0._r8
        2244             :            end if
        2245             :         else
        2246  5890903200 :            if (lams(i,k) > 0._r8) then
        2247  1590108676 :               dum_2D(i,k) = lams(i,k)**bs
        2248             :               ! provisional snow number and mass weighted mean fallspeed (m/s)
        2249  1590108676 :               proc_rates%ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*dum_2D(i,k)),1.2_r8*rhof(i,k))
        2250  1590108676 :               proc_rates%ums(i,k) = proc_rates%ums(i,k)*micro_mg_vtrms_factor
        2251  1590108676 :               uns(i,k) = min(asn(i,k)*gamma_bs_plus1/dum_2D(i,k),1.2_r8*rhof(i,k))
        2252             :            else
        2253  4300794524 :               proc_rates%ums(i,k) = 0._r8
        2254  4300794524 :               uns(i,k) = 0._r8
        2255             :            end if
        2256             :         end if
        2257             :      end do
        2258             :   end do
        2259             :   !$acc end parallel
        2260             :
        2261             :   !  graupel/hail size distributions and properties
        2262             :
        2263     4467528 :   if (do_hail) then
        2264           0 :      call size_dist_param_basic(mg_hail_props, qgic, ngic, lamg, mgncol, nlev, n0=n0g)
        2265             :   end if
        2266     4467528 :   if (do_graupel) then
        2267     4467528 :      call size_dist_param_basic(mg_graupel_props, qgic, ngic, lamg, mgncol, nlev, n0=n0g)
        2268             :   end if
        2269             :
        2270             :   !$acc parallel vector_length(VLENS) default(present)
        2271             :   !$acc loop gang vector collapse(2)
        2272   379739880 :   do k=1,nlev
        2273  6270643080 :      do i=1,mgncol
        2274  6266175552 :         if (lamg(i,k) > 0._r8) then
        2275   760592418 :            dum_2D(i,k) = lamg(i,k)**bgtmp
        2276             :            ! provisional graupel/hail number and mass weighted mean fallspeed (m/s)
        2277   760592418 :            proc_rates%umg(i,k) = min(agn(i,k)*gamma_bg_plus4/(6._r8*dum_2D(i,k)),20._r8*rhof(i,k))
        2278   760592418 :            ung(i,k) = min(agn(i,k)*gamma_bg_plus1/dum_2D(i,k),20._r8*rhof(i,k))
        2279             :         else
        2280  5130310782 :            proc_rates%umg(i,k) = 0._r8
        2281  5130310782 :            ung(i,k) = 0._r8
        2282             :         end if
        2283             :      end do
        2284             :   end do
        2285             :   !$acc end parallel
        2286             :
        2287     4467528 :   if (do_cldice) then
        2288     4467528 :      if (.not. use_hetfrz_classnuc) then
        2289             :         ! heterogeneous freezing of cloud water via Bigg, 1953
        2290             :         !----------------------------------------------
        2291     4467528 :         call immersion_freezing(microp_uniform, t, pgam, lamc, qcic, ncic, relvar, mnuccc, nnuccc, mgncol*nlev)
        2292             :
        2293             :         ! make sure number of droplets frozen does not exceed available ice nuclei concentration
        2294             :         ! this prevents 'runaway' droplet freezing
        2295             :
        2296             :         !$acc parallel vector_length(VLENS) default(present)
        2297             :         !$acc loop gang vector collapse(2)
        2298   379739880 :         do k=1,nlev
        2299  6270643080 :            do i=1,mgncol
        2300  5890903200 :               if (qcic(i,k).ge.qsmall .and. t(i,k).lt.269.15_r8 .and. &
        2301   375272352 :                    nnuccc(i,k)*lcldm(i,k).gt.nnuccd(i,k)) then
        2302             :                  ! scale mixing ratio of droplet freezing with limit
        2303    74690812 :                  mnuccc(i,k)=mnuccc(i,k)*(nnuccd(i,k)/(nnuccc(i,k)*lcldm(i,k)))
        2304    74690812 :                  nnuccc(i,k)=nnuccd(i,k)/lcldm(i,k)
        2305             :               end if
        2306             :            end do
        2307             :         end do
        2308             :         !$acc end parallel
        2309             :
        2310             :         call contact_freezing(microp_uniform, t, p, rndst, nacon, pgam, lamc, qcic, ncic, &
        2311 50169612168 :                               relvar, mnucct, nnucct, mgncol*nlev, mdust)
        2312             :      else
        2313             :         ! Mass of droplets frozen is the average droplet mass, except
        2314             :         ! with two limiters: concentration must be at least 1/cm^3, and
        2315             :         ! mass must be at least the minimum defined above.
        2316             :
        2317             :         !$acc parallel vector_length(VLENS) default(present)
        2318             :         !$acc loop gang vector collapse(2)
        2319           0 :         do k=1,nlev
        2320           0 :            do i=1,mgncol
        2321           0 :               mi0l(i,k) = qcic(i,k)/max(ncic(i,k), 1.0e6_r8/rho(i,k))
        2322           0 :               mi0l(i,k) = max(mi0l_min, mi0l(i,k))
        2323           0 :               if (qcic(i,k) >= qsmall) then
        2324           0 :                  nnuccc(i,k) = frzimm(i,k)*1.0e6_r8/rho(i,k)
        2325           0 :                  mnuccc(i,k) = nnuccc(i,k)*mi0l(i,k)
        2326           0 :                  nnucct(i,k) = frzcnt(i,k)*1.0e6_r8/rho(i,k)
        2327           0 :                  mnucct(i,k) = nnucct(i,k)*mi0l(i,k)
        2328           0 :                  nnudep(i,k) = frzdep(i,k)*1.0e6_r8/rho(i,k)
        2329           0 :                  mnudep(i,k) = nnudep(i,k)*mi0
        2330             :               else
        2331           0 :                  nnuccc(i,k) = 0._r8
        2332           0 :                  mnuccc(i,k) = 0._r8
        2333           0 :                  nnucct(i,k) = 0._r8
        2334           0 :                  mnucct(i,k) = 0._r8
        2335           0 :                  nnudep(i,k) = 0._r8
        2336           0 :                  mnudep(i,k) = 0._r8
        2337             :               end if
        2338             :            end do
        2339             :         end do
        2340             :         !$acc end parallel
        2341             :      end if
        2342             :   else
        2343             :      !$acc parallel vector_length(VLENS) default(present)
        2344             :      !$acc loop gang vector collapse(2)
        2345           0 :      do k=1,nlev
        2346           0 :         do i=1,mgncol
        2347           0 :            mnuccc(i,k)=0._r8
        2348           0 :            nnuccc(i,k)=0._r8
        2349           0 :            mnucct(i,k)=0._r8
        2350           0 :            nnucct(i,k)=0._r8
        2351           0 :            mnudep(i,k)=0._r8
        2352           0 :            nnudep(i,k)=0._r8
        2353             :         end do
        2354             :      end do
        2355             :      !$acc end parallel
        2356             :   end if
        2357             :
        2358             :
        2359     4467528 :   call snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg, mgncol*nlev)
        2360             :
        2361             :   call accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, pgam, &
        2362     4467528 :                                 lamc, lams, n0s, psacws, npsacws, mgncol*nlev)
        2363             :
        2364             :   !$acc parallel vector_length(VLENS) default(present)
        2365             :   !$acc loop gang vector collapse(2)
        2366   379739880 :   do k=1,nlev
        2367  6270643080 :      do i=1,mgncol
        2368  5890903200 :         psacws(i,k) = psacws(i,k)*micro_mg_iaccr_factor
        2369  6266175552 :         npsacws(i,k) = npsacws(i,k)*micro_mg_iaccr_factor
        2370             :      end do
        2371             :   end do
        2372             :   !$acc end parallel
        2373             :
        2374     4467528 :   if (do_cldice) then
        2375     4467528 :      call secondary_ice_production(t, psacws, msacwi, nsacwi, mgncol*nlev)
        2376             :   else
        2377             :      !$acc parallel vector_length(VLENS) default(present)
        2378             :      !$acc loop gang vector collapse(2)
        2379           0 :      do k=1,nlev
        2380           0 :         do i=1,mgncol
        2381           0 :            nsacwi(i,k) = 0.0_r8
        2382           0 :            msacwi(i,k) = 0.0_r8
        2383             :         end do
        2384             :      end do
        2385             :      !$acc end parallel
        2386             :   end if
        2387             :
        2388             :   call accrete_rain_snow(t, rho, proc_rates%umr, proc_rates%ums, unr, uns, qric, qsic, lamr, &
        2389     4467528 :                          n0r, lams, n0s, pracs, npracs, mgncol*nlev)
        2390             :
        2391     4467528 :   call heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr, mgncol*nlev)
        2392             :
        2393     4467528 :   if (trim(warm_rain) == 'sb2001') then
        2394           0 :      call sb2001v2_accre_cld_water_rain(qcic, ncic, qric, rho, relvar, pra, npra, mgncol*nlev)
        2395             :      !$acc parallel vector_length(VLENS) default(present)
        2396             :      !$acc loop gang vector collapse(2)
        2397           0 :      do k=1,nlev
        2398           0 :         do i=1,mgncol
        2399           0 :            proc_rates%nctend_SB2001(i,k)=proc_rates%nctend_SB2001(i,k)+npra(i,k)
        2400           0 :            proc_rates%qctend_SB2001(i,k)=proc_rates%qctend_SB2001(i,k)+pra(i,k)
        2401           0 :            proc_rates%nrtend_SB2001(i,k)=proc_rates%nrtend_SB2001(i,k)+npra(i,k)  !Sign should be same as prc?
        2402           0 :            proc_rates%qrtend_SB2001(i,k)=proc_rates%qrtend_SB2001(i,k)-pra(i,k)
        2403             :         end do
        2404             :      end do
        2405             :      !$acc end parallel
        2406             :   end if
        2407             :
        2408     4467528 :   if (trim(warm_rain) == 'kk2000') then
        2409             :      !$acc parallel vector_length(VLENS) default(present)
        2410             :      !$acc loop gang vector collapse(2)
        2411   379739880 :      do k = 1,nlev
        2412  6270643080 :         do i = 1,mgncol
        2413  5890903200 :            rtmp(i,k) = qric(i,k)
        2414  5890903200 :            ctmp(i,k) = qcic(i,k)
        2415  5890903200 :            ntmp(i,k) = ncic(i,k)
        2416             :
        2417             :            !Option: include recently autoconverted rain (prc, nprc) in accretion
        2418  6266175552 :            if (accre_sees_auto) then
        2419  5890903200 :               rtmp(i,k) = rtmp(i,k) + prc(i,k)*deltat
        2420  5890903200 :               ctmp(i,k) = ctmp(i,k) - prc(i,k)*deltat
        2421  5890903200 :               ntmp(i,k) = ntmp(i,k) - nprc(i,k)*deltat
        2422             :            endif
        2423             :         end do
        2424             :      end do
        2425             :      !$acc end parallel
        2426             :
        2427             :      call accrete_cloud_water_rain(microp_uniform,rtmp,ctmp,ntmp,relvar, &
        2428     4467528 :                                    accre_enhan,pra,npra,mgncol*nlev)
        2429             :
        2430             :      !$acc parallel vector_length(VLENS) default(present)
        2431             :      !$acc loop gang vector collapse(2)
        2432   379739880 :      do k = 1,nlev
        2433  6270643080 :         do i = 1,mgncol
        2434  5890903200 :            proc_rates%nctend_KK2000(i,k)=proc_rates%nctend_KK2000(i,k)+npra(i,k)
        2435  5890903200 :            proc_rates%qctend_KK2000(i,k)=proc_rates%qctend_KK2000(i,k)+pra(i,k)
        2436  5890903200 :            proc_rates%nrtend_KK2000(i,k)=proc_rates%nrtend_KK2000(i,k)+npra(i,k)  !Sign consistent with prc,nprc
        2437  6266175552 :            proc_rates%qrtend_KK2000(i,k)=proc_rates%qrtend_KK2000(i,k)-pra(i,k)
        2438             :         end do
        2439             :      end do
        2440             :      !$acc end parallel
        2441             :   endif
        2442             :
        2443             :   !$acc parallel vector_length(VLENS) default(present)
        2444             :   !$acc loop gang vector collapse(2)
        2445   379739880 :   do k=1,nlev
        2446  6270643080 :      do i=1,mgncol
        2447  5890903200 :         pra(i,k) = pra(i,k)*micro_mg_accre_enhan_fact
        2448  6266175552 :         npra(i,k) = npra(i,k)*micro_mg_accre_enhan_fact
        2449             :      end do
        2450             :   end do
        2451             :   !$acc end parallel
        2452             :
        2453     4467528 :   if (trim(warm_rain) == 'kk2000' .or. trim(warm_rain) == 'sb2001') then
        2454     4467528 :      call self_collection_rain(rho, qric, nric, nragg, mgncol*nlev)
        2455             :   end if
        2456             :
        2457     4467528 :   if (do_cldice) then
        2458     4467528 :      call accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, lams, n0s, prai, nprai, mgncol*nlev)
        2459             :   else
        2460             :      !$acc parallel vector_length(VLENS) default(present)
        2461             :      !$acc loop gang vector collapse(2)
        2462           0 :      do k=1,nlev
        2463           0 :         do i=1,mgncol
        2464           0 :            prai(i,k) = 0._r8
        2465           0 :            nprai(i,k) = 0._r8
        2466             :         end do
        2467             :      end do
        2468             :      !$acc end parallel
        2469             :   end if
        2470             :
        2471     4467528 :   call bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, qcic, qsic, lams, n0s, bergs, mgncol*nlev)
        2472             :   !$acc parallel vector_length(VLENS) default(present)
        2473             :   !$acc loop gang vector collapse(2)
        2474   379739880 :   do k=1,nlev
        2475  6270643080 :      do i=1,mgncol
        2476  6266175552 :         bergs(i,k)=bergs(i,k)*micro_mg_berg_eff_factor
        2477             :      end do
        2478             :   end do
        2479             :   !$acc end parallel
        2480             :
        2481             :
        2482             :   call vapor_deposition_onto_snow(t, q, qs, ns, precip_frac, rho, dv, qvl, &
        2483     4467528 :       qvi, asn, mu, sc, vap_deps, mgncol*nlev)
        2484             :
        2485             :
        2486     4467528 :   if (do_cldice) then
        2487             :      call ice_deposition_sublimation(t, q, qi, ni, icldm, rho, dv, qvl, qvi, &
        2488     4467528 :                                      berg, vap_dep, ice_sublim, mgncol*nlev)
        2489             :      !$acc parallel vector_length(VLENS) default(present)
        2490             :      !$acc loop gang vector collapse(2)
        2491   379739880 :      do k=1,nlev
        2492  6270643080 :         do i=1,mgncol
        2493  5890903200 :            berg(i,k)=berg(i,k)*micro_mg_berg_eff_factor
        2494  5890903200 :            if (ice_sublim(i,k) < 0._r8 .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then
        2495   148195522 :               nsubi(i,k) = sublim_factor*ice_sublim(i,k) / qi(i,k) * ni(i,k) / icldm(i,k)
        2496             :            else
        2497  5742707678 :               nsubi(i,k) = 0._r8
        2498             :            end if
        2499             :
        2500             :            ! bergeron process should not reduce nc unless
        2501             :            ! all ql is removed (which is handled elsewhere)
        2502             :            !in fact, nothing in this entire file makes nsubc nonzero.
        2503  6266175552 :            nsubc(i,k) = 0._r8
        2504             :
        2505             :         end do
        2506             :      end do
        2507             :      !$acc end parallel
        2508             :   end if !do_cldice
        2509             :
        2510             : ! Process rate calls for graupel
        2511             : !===================================================================
        2512             :
        2513     4467528 :   if (do_hail.or.do_graupel) then
        2514             :      call graupel_collecting_snow(qsic, qric, proc_rates%umr, proc_rates%ums, rho, &
        2515     4467528 :                                   lamr, n0r, lams, n0s, psacr, mgncol*nlev)
        2516             :
        2517     4467528 :      call graupel_collecting_cld_water(qgic, qcic, ncic, rho, n0g, lamg, bgtmp, agn, psacwg, npsacwg, mgncol*nlev)
        2518             :
        2519             :      !$acc parallel vector_length(VLENS) default(present)
        2520             :      !$acc loop gang vector collapse(2)
        2521   379739880 :      do k=1,nlev
        2522  6270643080 :         do i=1,mgncol
        2523  5890903200 :            psacwg(i,k) = psacwg(i,k)*micro_mg_iaccr_factor
        2524  6266175552 :            npsacwg(i,k) = npsacwg(i,k)*micro_mg_iaccr_factor
        2525             :         end do
        2526             :      end do
        2527             :      !$acc end parallel
        2528             :
        2529             :      call graupel_riming_liquid_snow(psacws, qsic, qcic, nsic, rho, rhosn, rhogtmp, asn, &
        2530     4467528 :                                      lams, n0s, deltat, pgsacw, nscng, mgncol*nlev)
        2531             :
        2532             :      call graupel_collecting_rain(qric, qgic, proc_rates%umg, proc_rates%umr, ung, unr, rho, n0r, &
        2533     4467528 :                                   lamr, n0g, lamg, pracg, npracg, mgncol*nlev)
        2534             :
        2535             :      !$acc parallel vector_length(VLENS) default(present)
        2536             :      !$acc loop gang vector collapse(2)
        2537   379739880 :      do k=1,nlev
        2538  6270643080 :         do i=1,mgncol
        2539  5890903200 :            pracg(i,k) = pracg(i,k)*micro_mg_iaccr_factor
        2540  6266175552 :            npracg(i,k) = npracg(i,k)*micro_mg_iaccr_factor
        2541             :         end do
        2542             :      end do
        2543             :      !$acc end parallel
        2544             :
        2545             : !AG note: Graupel rain riming snow changes
        2546             : !    pracs, npracs, (accretion of rain by snow)  psacr (collection of snow by rain)
        2547             :
        2548             :      call graupel_rain_riming_snow(pracs, npracs, psacr, qsic, qric, nric, nsic, &
        2549     4467528 :                                    n0s, lams, n0r, lamr, deltat, pgracs, ngracs, mgncol*nlev)
        2550             :
        2551     4467528 :      call graupel_rime_splintering(t, qcic, qric, qgic, psacwg, pracg, qmultg, nmultg, qmultrg, nmultrg,mgncol*nlev)
        2552             :
        2553             :
        2554             :      call evaporate_sublimate_precip_graupel(t, rho, dv, mu, sc, q, qvl, qvi, lcldm, precip_frac, arn, asn, agn, &
        2555             :                                              bgtmp, qcic, qiic, qric, qsic, qgic, lamr, n0r, lams, n0s, lamg, n0g, &
        2556     4467528 :                                              pre, prds, prdg, am_evp_st, mgncol*nlev, evap_rhthrsh_ifs)
        2557             :   else
        2558             :      ! Routine without Graupel (original)
        2559             :      call evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, lcldm, precip_frac, arn, asn, qcic, qiic, &
        2560           0 :                                      qric, qsic, lamr, n0r, lams, n0s, pre, prds, am_evp_st, mgncol*nlev, evap_rhthrsh_ifs)
        2561             :   end if ! end do_graupel/hail loop
        2562             :
        2563             : ! scale precip evaporation to match IFS 'new' version (option 2)
        2564     4467528 :   if (evap_scl_ifs) then
        2565             :      !$acc parallel vector_length(VLENS) default(present)
        2566             :      !$acc loop gang vector collapse(2)
        2567           0 :      do k=1,nlev
        2568           0 :         do i=1,mgncol
        2569           0 :            pre(i,k)= 0.15_r8 * pre(i,k)
        2570             :         end do
        2571             :      end do
        2572             :      !$acc end parallel
        2573             :   end if
        2574             :
        2575             :   !$acc parallel vector_length(VLENS) default(present)
        2576             :   !$acc loop gang vector collapse(2)
        2577   379739880 :   do k=1,nlev
        2578  6270643080 :      do i=1,mgncol
        2579             :         ! conservation to ensure no negative values of cloud water/precipitation
        2580             :         ! in case microphysical process rates are large
        2581             :         !===================================================================
        2582             :
        2583             :         ! note: for check on conservation, processes are multiplied by omsm
        2584             :         ! to prevent problems due to round off error
        2585             :
        2586             :         ! conservation of qc
        2587             :         !-------------------------------------------------------------------
        2588 11781806400 :         dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ &
        2589             :              psacws(i,k)+bergs(i,k)+qmultg(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)+ &
        2590 11781806400 :              berg(i,k))*deltat
        2591  5890903200 :         if (dum.gt.qc(i,k)) then
        2592             :            ratio = qc(i,k)*rdeltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ &
        2593             :                 msacwi(i,k)+psacws(i,k)+bergs(i,k)+qmultg(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)+&
        2594  1342331399 :                 berg(i,k))*omsm
        2595  1342331399 :            qmultg(i,k)=qmultg(i,k)*ratio
        2596  1342331399 :            psacwg(i,k)=psacwg(i,k)*ratio
        2597  1342331399 :            pgsacw(i,k)=pgsacw(i,k)*ratio
        2598  1342331399 :            prc(i,k) = prc(i,k)*ratio
        2599  1342331399 :            pra(i,k) = pra(i,k)*ratio
        2600  1342331399 :            mnuccc(i,k) = mnuccc(i,k)*ratio
        2601  1342331399 :            mnucct(i,k) = mnucct(i,k)*ratio
        2602  1342331399 :            msacwi(i,k) = msacwi(i,k)*ratio
        2603  1342331399 :            psacws(i,k) = psacws(i,k)*ratio
        2604  1342331399 :            bergs(i,k) = bergs(i,k)*ratio
        2605  1342331399 :            berg(i,k) = berg(i,k)*ratio
        2606  1342331399 :            qcrat(i,k) = ratio
        2607             :         else
        2608  4548571801 :            qcrat(i,k) = 1._r8
        2609             :         end if
        2610             :         !PMC 12/3/12: ratio is also frac of step w/ liquid.
        2611             :         !thus we apply berg for "ratio" of timestep and vapor
        2612             :         !deposition for the remaining frac of the timestep.
        2613  5890903200 :         if (qc(i,k) >= qsmall) then
        2614   512413729 :            vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k))
        2615   512413729 :            vap_deps(i,k) = vap_deps(i,k)*(1._r8-qcrat(i,k))
        2616             :         end if
        2617             :
        2618             :         !=================================================================
        2619             :         ! apply limiter to ensure that ice/snow sublimation and rain evap
        2620             :         ! don't push conditions into supersaturation, and ice deposition/nucleation don't
        2621             :         ! push conditions into sub-saturation
        2622             :         ! note this is done after qc conservation since we don't know how large
        2623             :         ! vap_dep is before then
        2624             :         ! estimates are only approximate since other process terms haven't been limited
        2625             :         ! for conservation yet
        2626             :
        2627             :         ! first limit ice deposition/nucleation vap_dep + mnuccd + vap_deps
        2628  5890903200 :         mnuccd(i,k) = max(0._r8,mnuccd(i,k))
        2629  5890903200 :         vap_dep(i,k) = max(0._r8,vap_dep(i,k))
        2630  5890903200 :         vap_deps(i,k) = max(0._r8,vap_deps(i,k))
        2631             :
        2632  5890903200 :         dum1 = vap_dep(i,k) + mnuccd(i,k) + vap_deps(i,k)
        2633  6266175552 :         if (dum1 > 1.e-20_r8) then
        2634   471953685 :            dum = (q(i,k)-qvi(i,k))/(1._r8 + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)**2))*rdeltat
        2635   471953685 :            dum = max(dum,0._r8)
        2636   471953685 :            if (dum1 > dum) then
        2637             :               ! Allocate the limited "dum" tendency to mnuccd and vap_dep
        2638             :               ! processes. Don't divide by cloud fraction; these are grid-
        2639             :               ! mean rates.
        2640    11391544 :               mnuccd(i,k) = dum*mnuccd(i,k)/dum1
        2641    11391544 :               vap_dep(i,k) = dum*vap_dep(i,k)/dum1
        2642    11391544 :               vap_deps(i,k) = dum*vap_deps(i,k)/dum1
        2643             :
        2644             :            end if
        2645             :         end if
        2646             :      end do
        2647             :   end do
        2648             :   !$acc end parallel
        2649             :
        2650             :   !$acc parallel vector_length(VLENS) default(present)
        2651             :   !$acc loop gang vector collapse(2)
        2652   379739880 :   do k=1,nlev
        2653  6270643080 :      do i=1,mgncol
        2654             :         !===================================================================
        2655             :         ! conservation of nc
        2656             :         !-------------------------------------------------------------------
        2657 11781806400 :         dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ &
        2658 11781806400 :                npsacws(i,k)-nsubc(i,k)+npsacwg(i,k))*lcldm(i,k)*deltat
        2659             :
        2660  5890903200 :         if (dum.gt.nc(i,k)) then
        2661             :            ratio = nc(i,k)*rdeltat/((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+&
        2662   194991117 :                    npsacws(i,k)-nsubc(i,k)+npsacwg(i,k))*lcldm(i,k))*omsm
        2663   194991117 :            npsacwg(i,k) = npsacwg(i,k)*ratio
        2664   194991117 :            nprc1(i,k)   = nprc1(i,k)*ratio
        2665   194991117 :            npra(i,k)    = npra(i,k)*ratio
        2666   194991117 :            nnuccc(i,k)  = nnuccc(i,k)*ratio
        2667   194991117 :            nnucct(i,k)  = nnucct(i,k)*ratio
        2668   194991117 :            npsacws(i,k) = npsacws(i,k)*ratio
        2669   194991117 :            nsubc(i,k)   = nsubc(i,k)*ratio
        2670             :         end if
        2671  5890903200 :         mnuccri(i,k)=0._r8
        2672  5890903200 :         nnuccri(i,k)=0._r8
        2673             :
        2674  6266175552 :         if (do_cldice) then
        2675             :            ! freezing of rain to produce ice if mean rain size is smaller than Dcs
        2676  5890903200 :            if (lamr(i,k) > qsmall) then
        2677  1434950401 :               if (1._r8/lamr(i,k) < Dcs) then
        2678  1391415819 :                  mnuccri(i,k)=mnuccr(i,k)
        2679  1391415819 :                  nnuccri(i,k)=nnuccr(i,k)
        2680  1391415819 :                  mnuccr(i,k)=0._r8
        2681  1391415819 :                  nnuccr(i,k)=0._r8
        2682             :               end if
        2683             :            end if
        2684             :         end if
        2685             :      end do
        2686             :   end do
        2687             :   !$acc end parallel
        2688             :
        2689             :   !$acc parallel vector_length(VLENS) default(present)
        2690             :   !$acc loop gang vector collapse(2)
        2691   379739880 :   do k=1,nlev
        2692  6270643080 :      do i=1,mgncol
        2693             :         ! conservation of rain mixing ratio
        2694             :         !-------------------------------------------------------------------
        2695 11781806400 :         dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k) &
        2696             :              +qmultrg(i,k)+pracg(i,k)+pgracs(i,k))*precip_frac(i,k)- &
        2697 11781806400 :              (pra(i,k)+prc(i,k))*lcldm(i,k))*deltat
        2698             :         ! note that qrtend is included below because of instantaneous freezing/melt
        2699  5890903200 :         if (dum.gt.qr(i,k).and. &
        2700             :              (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)+qmultrg(i,k)+pracg(i,k)+pgracs(i,k)).ge.qsmall) then
        2701             :            ratio = (qr(i,k)*rdeltat+(pra(i,k)+prc(i,k))*lcldm(i,k))/   &
        2702             :                 precip_frac(i,k)/(-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k) &
        2703   613226772 :                 +qmultrg(i,k)+pracg(i,k)+pgracs(i,k))*omsm
        2704   613226772 :            qmultrg(i,k)= qmultrg(i,k)*ratio
        2705   613226772 :            pracg(i,k)=pracg(i,k)*ratio
        2706   613226772 :            pgracs(i,k)=pgracs(i,k)*ratio
        2707   613226772 :            pre(i,k)=pre(i,k)*ratio
        2708   613226772 :            pracs(i,k)=pracs(i,k)*ratio
        2709   613226772 :            mnuccr(i,k)=mnuccr(i,k)*ratio
        2710   613226772 :            mnuccri(i,k)=mnuccri(i,k)*ratio
        2711             :         end if
        2712             :
        2713             :         ! conservation of rain number
        2714             :         !-------------------------------------------------------------------
        2715             :         ! Add evaporation of rain number.
        2716  5890903200 :         if (pre(i,k) < 0._r8) then
        2717   721992020 :            nsubr(i,k) = pre(i,k)*nr(i,k)/qr(i,k)
        2718             :         else
        2719  5168911180 :            nsubr(i,k) = 0._r8
        2720             :         end if
        2721             :
        2722             :         dum = ((-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k)+npracg(i,k)+ngracs(i,k)) &
        2723  5890903200 :              *precip_frac(i,k)- nprc(i,k)*lcldm(i,k))*deltat
        2724             :
        2725             :         ! Added a check to trap for division by zero errors
        2726             :
        2727  5890903200 :         tmpnr = -nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k)+npracg(i,k)+ngracs(i,k)
        2728  5890903200 :         tmpp  = nr(i,k)*rdeltat + nprc(i,k)*lcldm(i,k)
        2729             :
        2730  6266175552 :         if (dum.gt.nr(i,k) .and. tmpnr.gt.0._r8 .and. tmpp.gt.0._r8 .and. precip_frac(i,k).gt.0._r8) then
        2731             :            ratio = (nr(i,k)*rdeltat+nprc(i,k)*lcldm(i,k))/precip_frac(i,k)/ &
        2732   710146797 :                 (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k)+npracg(i,k)+ngracs(i,k))*omsm
        2733             :
        2734   710146797 :            npracg(i,k)=npracg(i,k)*ratio
        2735   710146797 :            ngracs(i,k)=ngracs(i,k)*ratio
        2736   710146797 :            nragg(i,k)=nragg(i,k)*ratio
        2737   710146797 :            npracs(i,k)=npracs(i,k)*ratio
        2738   710146797 :            nnuccr(i,k)=nnuccr(i,k)*ratio
        2739   710146797 :            nsubr(i,k)=nsubr(i,k)*ratio
        2740   710146797 :            nnuccri(i,k)=nnuccri(i,k)*ratio
        2741             :         end if
        2742             :      end do
        2743             :   end do
        2744             :   !$acc end parallel
        2745             :
        2746     4467528 :   if (do_cldice) then
        2747             :      !$acc parallel vector_length(VLENS) default(present)
        2748             :      !$acc loop gang vector collapse(2)
        2749   379739880 :      do k=1,nlev
        2750  6270643080 :         do i=1,mgncol
        2751             :            ! conservation of qi
        2752             :            !-------------------------------------------------------------------
        2753 11781806400 :            dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k)-qmultg(i,k))*lcldm(i,k)+(prci(i,k)+ &
        2754             :                 prai(i,k))*icldm(i,k)+(-qmultrg(i,k)-mnuccri(i,k))*precip_frac(i,k) &
        2755 11781806400 :                 -ice_sublim(i,k)-vap_dep(i,k)-berg(i,k)-mnuccd(i,k))*deltat
        2756  5890903200 :            if (dum.gt.qi(i,k)) then
        2757             :               ratio = (qi(i,k)*rdeltat+vap_dep(i,k)+berg(i,k)+mnuccd(i,k)+ &
        2758             :                    (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k)+ &
        2759             :                    (qmultrg(i,k)+mnuccri(i,k))*precip_frac(i,k))/ &
        2760   656096697 :                    ((prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k))*omsm
        2761   656096697 :               prci(i,k) = prci(i,k)*ratio
        2762   656096697 :               prai(i,k) = prai(i,k)*ratio
        2763   656096697 :               ice_sublim(i,k) = ice_sublim(i,k)*ratio
        2764             :            end if
        2765             :
        2766             :            ! conservation of ni
        2767             :            !-------------------------------------------------------------------
        2768  5890903200 :            if (use_hetfrz_classnuc) then
        2769           0 :               tmpfrz = nnuccc(i,k)
        2770             :            else
        2771             :               tmpfrz = 0._r8
        2772             :            end if
        2773             :            dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k)-nmultg(i,k))*lcldm(i,k)+(nprci(i,k)+ &
        2774             :                 nprai(i,k)-nsubi(i,k))*icldm(i,k)+(-nmultrg(i,k)-nnuccri(i,k))*precip_frac(i,k)- &
        2775  5890903200 :                 nnuccd(i,k))*deltat
        2776  6266175552 :            if (dum.gt.ni(i,k)) then
        2777             :               ratio = (ni(i,k)*rdeltat+nnuccd(i,k)+ &
        2778             :                  (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k)+ &
        2779             :                  (nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k))/ &
        2780   229069389 :                  ((nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k))*omsm
        2781   229069389 :               nprci(i,k) = nprci(i,k)*ratio
        2782   229069389 :               nprai(i,k) = nprai(i,k)*ratio
        2783   229069389 :               nsubi(i,k) = nsubi(i,k)*ratio
        2784             :            end if
        2785             :         end do
        2786             :      end do
        2787             :      !$acc end parallel
        2788             :   end if
        2789             :
        2790             :   !$acc parallel vector_length(VLENS) default(present)
        2791             :   !$acc loop gang vector collapse(2)
        2792   379739880 :   do k=1,nlev
        2793  6270643080 :      do i=1,mgncol
        2794             :         ! conservation of snow mixing ratio
        2795             :         !-------------------------------------------------------------------
        2796  5890903200 :         if (do_hail .or. do_graupel) then
        2797             :         ! NOTE: mnuccr is moved to graupel when active
        2798             :         ! psacr is a positive value, but a loss for snow
        2799             :         !HM: psacr is positive in dum (two negatives)
        2800 11781806400 :            dum = (-(prds(i,k)+pracs(i,k)-psacr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) &
        2801 17672709600 :              -(bergs(i,k)+psacws(i,k))*lcldm(i,k) - vap_deps(i,k))*deltat
        2802             :         else
        2803           0 :            dum = (-(prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) &
        2804           0 :              -(bergs(i,k)+psacws(i,k))*lcldm(i,k) - vap_deps(i,k))*deltat
        2805             :         end if
        2806  5890903200 :         if (dum.gt.qs(i,k).and.(psacr(i,k)-prds(i,k)).ge.qsmall) then
        2807   270432578 :            if (do_hail .or. do_graupel) then
        2808             :               ratio = (qs(i,k)*rdeltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ &
        2809             :                    (bergs(i,k)+psacws(i,k))*lcldm(i,k)+vap_deps(i,k)+pracs(i,k)*precip_frac(i,k))/ &
        2810   270432578 :                    precip_frac(i,k)/(psacr(i,k)-prds(i,k))*omsm
        2811   270432578 :               psacr(i,k)=psacr(i,k)*ratio
        2812             :            else
        2813             :               ratio = (qs(i,k)*rdeltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ &
        2814             :                    (bergs(i,k)+psacws(i,k))*lcldm(i,k)+vap_deps(i,k)+(pracs(i,k)+mnuccr(i,k))*precip_frac(i,k))/ &
        2815           0 :                    precip_frac(i,k)/(-prds(i,k))*omsm
        2816             :            end if
        2817   270432578 :            prds(i,k)=prds(i,k)*ratio
        2818             :         end if
        2819             :
        2820             :         ! conservation of snow number
        2821             :         !-------------------------------------------------------------------
        2822             :         ! calculate loss of number due to sublimation
        2823             :         ! for now neglect sublimation of ns
        2824  5890903200 :         nsubs(i,k)=0._r8
        2825  5890903200 :         if (do_hail .or. do_graupel) then
        2826  5890903200 :            dum = ((-nsagg(i,k)-nsubs(i,k)+ngracs(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k)+nscng(i,k)*lcldm(i,k))*deltat
        2827             :         else
        2828           0 :            dum = ((-nsagg(i,k)-nsubs(i,k)-nnuccr(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k))*deltat
        2829             :         end if
        2830  6266175552 :         if (dum.gt.ns(i,k)) then
        2831   161385097 :            if (do_hail .or. do_graupel) then
        2832             :               ratio = (ns(i,k)*rdeltat+nprci(i,k)*icldm(i,k))/precip_frac(i,k)/ &
        2833   161385097 :                    (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)+lcldm(i,k)/precip_frac(i,k)*nscng(i,k))*omsm
        2834   161385097 :               nscng(i,k)=nscng(i,k)*ratio
        2835   161385097 :               ngracs(i,k)=ngracs(i,k)*ratio
        2836             :            else
        2837             :               ratio = (ns(i,k)*rdeltat+nnuccr(i,k)* &
        2838             :                    precip_frac(i,k)+nprci(i,k)*icldm(i,k))/precip_frac(i,k)/ &
        2839           0 :                    (-nsubs(i,k)-nsagg(i,k))*omsm
        2840             :            endif
        2841   161385097 :            nsubs(i,k)=nsubs(i,k)*ratio
        2842   161385097 :            nsagg(i,k)=nsagg(i,k)*ratio
        2843             :         end if
        2844             :      end do
        2845             :   end do
        2846             :   !$acc end parallel
        2847             :
        2848             : ! Graupel Conservation Checks
        2849             : !-------------------------------------------------------------------
        2850             :
        2851     4467528 :   if (do_hail.or.do_graupel) then
        2852             :      ! conservation of graupel mass
        2853             :      !-------------------------------------------------------------------
        2854             :      !$acc parallel vector_length(VLENS) default(present)
        2855             :      !$acc loop gang vector collapse(2)
        2856   379739880 :      do k=1,nlev
        2857  6270643080 :         do i=1,mgncol
        2858 11781806400 :            dum= ((-pracg(i,k)-pgracs(i,k)-prdg(i,k)-psacr(i,k)-mnuccr(i,k))*precip_frac(i,k) &
        2859 11781806400 :                 + (-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k))*deltat
        2860  6266175552 :            if (dum.gt.qg(i,k)) then
        2861             :               ! note: prdg is always negative (like prds), so it needs to be subtracted in ratio
        2862             :               ratio = (qg(i,k)*rdeltat + (pracg(i,k)+pgracs(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) &
        2863    61338013 :                        + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)) / ((-prdg(i,k))*precip_frac(i,k)) * omsm
        2864    61338013 :               prdg(i,k)= prdg(i,k)*ratio
        2865             :            end if
        2866             :         end do
        2867             :      end do
        2868             :      !$acc end parallel
        2869             :      ! conservation of graupel number: not needed, no sinks
        2870             :      !-------------------------------------------------------------------
        2871             :   end if
        2872             :
        2873             :   !$acc parallel vector_length(VLENS) default(present)
        2874             :   !$acc loop gang vector collapse(2)
        2875   379739880 :   do k=1,nlev
        2876  6270643080 :      do i=1,mgncol
        2877             :         ! next limit ice and snow sublimation and rain evaporation
        2878             :         ! get estimate of q and t at end of time step
        2879             :         ! don't include other microphysical processes since they haven't
        2880             :         ! been limited via conservation checks yet
        2881 11781806400 :         qtmpAI(i,k)=q(i,k)-(ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+vap_deps(i,k)+ &
        2882 11781806400 :                 (pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k))*deltat
        2883             :         ttmpA(i,k)=t(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ &
        2884  6266175552 :              ((prds(i,k)+prdg(i,k))*precip_frac(i,k)+vap_dep(i,k)+vap_deps(i,k)+ice_sublim(i,k)+mnuccd(i,k))*xxls)*deltat/cpp
        2885             :      end do
        2886             :   end do
        2887             :   !$acc end parallel
        2888             :
        2889             :   ! use rhw to allow ice supersaturation
        2890     4467528 :   call qsat_water(ttmpA, p, esnA, qvnAI, mgncol*nlev)
        2891             :
        2892             :   !$acc parallel vector_length(VLENS) default(present)
        2893             :   !$acc loop gang vector collapse(2)
        2894   379739880 :   do k=1,nlev
        2895  6270643080 :      do i=1,mgncol
        2896  6266175552 :         if ((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then
        2897             :            ! modify ice/precip evaporation rate if q > qsat
        2898  1584660241 :            if (qtmpAI(i,k) > qvnAI(i,k)) then
        2899       14711 :               dum1A(i,k)=pre(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k))
        2900       14711 :               dum2A(i,k)=prds(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k))
        2901       14711 :               dum3A(i,k)=prdg(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k))
        2902             :               ! recalculate q and t after vap_dep and mnuccd but without evap or sublim
        2903       14711 :               ttmpA(i,k)=t(i,k)+((vap_dep(i,k)+vap_deps(i,k)+mnuccd(i,k))*xxls)*deltat/cpp
        2904       14711 :               dum_2D(i,k)=q(i,k)-(vap_dep(i,k)+vap_deps(i,k)+mnuccd(i,k))*deltat
        2905             :            end if
        2906             :         end if
        2907             :      end do
        2908             :   end do
        2909             :   !$acc end parallel
        2910             :
        2911             :   ! use rhw to allow ice supersaturation
        2912     4467528 :   call qsat_water(ttmpA, p, esnA, qvnA, mgncol*nlev)
        2913             :
        2914             :   !$acc parallel vector_length(VLENS) default(present)
        2915             :   !$acc loop gang vector collapse(2)
        2916   379739880 :   do k=1,nlev
        2917  6270643080 :      do i=1,mgncol
        2918  6266175552 :         if ((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then
        2919             :            ! modify ice/precip evaporation rate if q > qsat
        2920  1584660241 :            if (qtmpAI(i,k) > qvnAI(i,k)) then
        2921       14711 :               dum=(dum_2D(i,k)-qvnA(i,k))/(1._r8 + xxlv_squared*qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))
        2922       14711 :               dum=min(dum,0._r8)
        2923             :               ! modify rates if needed, divide by precip_frac to get local (in-precip) value
        2924       14711 :               pre(i,k)=dum*dum1A(i,k)*rdeltat/precip_frac(i,k)
        2925             :            end if
        2926             :         end if
        2927             :      end do
        2928             :   end do
        2929             :   !$acc end parallel
        2930             :
        2931             :   ! do separately using RHI for prds and ice_sublim
        2932     4467528 :   call qsat_ice(ttmpA, p, esnA, qvnA, mgncol*nlev)
        2933             :
        2934             :   !$acc parallel vector_length(VLENS) default(present)
        2935             :   !$acc loop gang vector collapse(2)
        2936   379739880 :   do k=1,nlev
        2937  6270643080 :      do i=1,mgncol
        2938  5890903200 :         if ((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then
        2939             :            ! modify ice/precip evaporation rate if q > qsat
        2940  1584660241 :            if (qtmpAI(i,k) > qvnAI(i,k)) then
        2941       14711 :               dum=(dum_2D(i,k)-qvnA(i,k))/(1._r8 + xxls_squared*qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))
        2942       14711 :               dum=min(dum,0._r8)
        2943             :               ! modify rates if needed, divide by precip_frac to get local (in-precip) value
        2944       14711 :               prds(i,k) = dum*dum2A(i,k)*rdeltat/precip_frac(i,k)
        2945       14711 :               prdg(i,k) = dum*dum3A(i,k)*rdeltat/precip_frac(i,k)
        2946             :               ! don't divide ice_sublim by cloud fraction since it is grid-averaged
        2947       14711 :               dum1A(i,k) = (1._r8-dum1A(i,k)-dum2A(i,k)-dum3A(i,k))
        2948       14711 :               ice_sublim(i,k) = dum*dum1A(i,k)*rdeltat
        2949             :            end if
        2950             :         end if
        2951             :
        2952             :         ! get tendencies due to microphysical conversion processes
        2953             :         !==========================================================
        2954             :         ! note: tendencies are multiplied by appropriate cloud/precip
        2955             :         ! fraction to get grid-scale values
        2956             :         ! note: vap_dep is already grid-average values
        2957             :
        2958             :         ! The net tendencies need to be added to rather than overwritten,
        2959             :         ! because they may have a value already set for instantaneous
        2960             :         ! melting/freezing.
        2961             :         qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k)-&
        2962             :              vap_dep(i,k)-vap_deps(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) &
        2963  5890903200 :              -prdg(i,k)*precip_frac(i,k)
        2964             :         tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ &
        2965             :              ((prds(i,k)+prdg(i,k))*precip_frac(i,k)+vap_dep(i,k)+vap_deps(i,k)+ice_sublim(i,k)+ &
        2966             :              mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ &
        2967             :              ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+psacwg(i,k)+ &
        2968             :              qmultg(i,k)+pgsacw(i,k))*lcldm(i,k)+ &
        2969             :              (mnuccr(i,k)+pracs(i,k)+mnuccri(i,k)+pracg(i,k)+pgracs(i,k)+qmultrg(i,k))*precip_frac(i,k)+ &
        2970  5890903200 :              berg(i,k))*xlf)
        2971             :         qctend(i,k) = qctend(i,k)+ &
        2972             :              (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- &
        2973  5890903200 :              psacws(i,k)-bergs(i,k)-qmultg(i,k)-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k)-berg(i,k)
        2974             :
        2975  5890903200 :         if (do_cldice) then
        2976             :            qitend(i,k) = qitend(i,k)+ &
        2977             :                 (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k)+(-prci(i,k)- &
        2978             :                 prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ &
        2979  5890903200 :                 mnuccd(i,k)+(mnuccri(i,k)+qmultrg(i,k))*precip_frac(i,k)
        2980             :         end if
        2981             :
        2982             :         qrtend(i,k) = qrtend(i,k)+ &
        2983             :              (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- &
        2984  5890903200 :              mnuccr(i,k)-mnuccri(i,k)-qmultrg(i,k)-pracg(i,k)-pgracs(i,k))*precip_frac(i,k)
        2985             :
        2986  6266175552 :         if (do_hail.or.do_graupel) then
        2987             :            qgtend(i,k) = qgtend(i,k) + (pracg(i,k)+pgracs(i,k)+prdg(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) &
        2988  5890903200 :                 + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)
        2989             :            qstend(i,k) = qstend(i,k)+ &
        2990             :                 (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ &
        2991  5890903200 :                 pracs(i,k)-psacr(i,k))*precip_frac(i,k)+vap_deps(i,k)
        2992             :         else
        2993             :            !necessary since mnuccr moved to graupel
        2994             :            qstend(i,k) = qstend(i,k)+ &
        2995             :                 (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ &
        2996           0 :                 pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)+vap_deps(i,k)
        2997             :         end if
        2998             :      end do
        2999             :   end do
        3000             :   !$acc end parallel
        3001             :
        3002             :   !$acc parallel vector_length(VLENS) default(present)
        3003             :   !$acc loop gang vector collapse(2)
        3004   379739880 :   do k=1,nlev
        3005  6270643080 :      do i=1,mgncol
        3006  5890903200 :         cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + vap_deps(i,k)
        3007             :         ! add output for cmei (accumulate)
        3008  5890903200 :         proc_rates%cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + vap_deps(i,k)
        3009             :         !-------------------------------------------------------------------
        3010             :         ! evaporation/sublimation is stored here as positive term
        3011             :         ! Add to evapsnow via prdg
        3012  5890903200 :         proc_rates%evapsnow(i,k) = (-prds(i,k)-prdg(i,k))*precip_frac(i,k)
        3013  5890903200 :         nevapr(i,k) = -pre(i,k)*precip_frac(i,k)
        3014  5890903200 :         prer_evap(i,k) = -pre(i,k)*precip_frac(i,k)
        3015             :         ! change to make sure prain is positive: do not remove snow from
        3016             :         ! prain used for wet deposition
        3017             :         prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- &
        3018  5890903200 :              mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k)
        3019  5890903200 :         if (do_hail .or. do_graupel) then
        3020           0 :            proc_rates%prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(&
        3021  5890903200 :                 pracs(i,k))*precip_frac(i,k)+vap_deps(i,k)
        3022             :         else
        3023           0 :            proc_rates%prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(&
        3024           0 :                 pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)+vap_deps(i,k)
        3025             :         end if
        3026             :         ! following are used to calculate 1st order conversion rate of cloud water
        3027             :         !    to rain and snow (1/s), for later use in aerosol wet removal routine
        3028             :         ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc
        3029             :         !    used to calculate pra, prc, ... in this routine
        3030             :         ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow }
        3031             :         !                      (no cloud ice or bergeron terms)
        3032  5890903200 :         qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)
        3033             :         ! Avoid zero/near-zero division.
        3034             :         qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / &
        3035  6266175552 :              max(qc(i,k),1.0e-30_r8)
        3036             :      end do
        3037             :   end do
        3038             :   !$acc end parallel
        3039             :
        3040             :   !$acc parallel vector_length(VLENS) default(present)
        3041             :   !$acc loop gang vector collapse(2)
        3042   379739880 :   do k=1,nlev
        3043  6270643080 :      do i=1,mgncol
        3044             :         ! microphysics output, note this is grid-averaged
        3045  5890903200 :         proc_rates%pratot(i,k)     = pra(i,k)*lcldm(i,k)
        3046  5890903200 :         proc_rates%prctot(i,k)     = prc(i,k)*lcldm(i,k)
        3047  5890903200 :         proc_rates%mnuccctot(i,k)  = mnuccc(i,k)*lcldm(i,k)
        3048  5890903200 :         proc_rates%mnudeptot(i,k)  = mnudep(i,k)*lcldm(i,k)
        3049  5890903200 :         proc_rates%mnuccttot(i,k)  = mnucct(i,k)*lcldm(i,k)
        3050  5890903200 :         proc_rates%msacwitot(i,k)  = msacwi(i,k)*lcldm(i,k)
        3051  5890903200 :         proc_rates%psacwstot(i,k)  = psacws(i,k)*lcldm(i,k)
        3052  5890903200 :         proc_rates%bergstot(i,k)   = bergs(i,k)*lcldm(i,k)
        3053  5890903200 :         proc_rates%vapdepstot(i,k) = vap_deps(i,k)
        3054  5890903200 :         proc_rates%bergtot(i,k)    = berg(i,k)
        3055  5890903200 :         proc_rates%prcitot(i,k)    = prci(i,k)*icldm(i,k)
        3056  5890903200 :         proc_rates%praitot(i,k)    = prai(i,k)*icldm(i,k)
        3057  5890903200 :         proc_rates%mnuccdtot(i,k)  = mnuccd(i,k)*icldm(i,k)
        3058  5890903200 :         proc_rates%pracstot(i,k)   = pracs(i,k)*precip_frac(i,k)
        3059  5890903200 :         proc_rates%mnuccrtot(i,k)  = mnuccr(i,k)*precip_frac(i,k)
        3060  5890903200 :         proc_rates%mnuccritot(i,k) = mnuccri(i,k)*precip_frac(i,k)
        3061  5890903200 :         proc_rates%psacrtot(i,k)   = psacr(i,k)*precip_frac(i,k)
        3062  5890903200 :         proc_rates%pracgtot(i,k)   = pracg(i,k)*precip_frac(i,k)
        3063  5890903200 :         proc_rates%psacwgtot(i,k)  = psacwg(i,k)*lcldm(i,k)
        3064  5890903200 :         proc_rates%pgsacwtot(i,k)  = pgsacw(i,k)*lcldm(i,k)
        3065  5890903200 :         proc_rates%pgracstot(i,k)  = pgracs(i,k)*precip_frac(i,k)
        3066  5890903200 :         proc_rates%prdgtot(i,k)    = prdg(i,k)*precip_frac(i,k)
        3067  5890903200 :         proc_rates%qmultgtot(i,k)  = qmultg(i,k)*lcldm(i,k)
        3068  5890903200 :         proc_rates%qmultrgtot(i,k) = qmultrg(i,k)*precip_frac(i,k)
        3069  5890903200 :         proc_rates%npracgtot(i,k)  = npracg(i,k)*precip_frac(i,k)
        3070  5890903200 :         proc_rates%nscngtot(i,k)   = nscng(i,k)*lcldm(i,k)
        3071  5890903200 :         proc_rates%ngracstot(i,k)  = ngracs(i,k)*precip_frac(i,k)
        3072  5890903200 :         proc_rates%nmultgtot(i,k)  = nmultg(i,k)*lcldm(i,k)
        3073  5890903200 :         proc_rates%nmultrgtot(i,k) = nmultrg(i,k)*precip_frac(i,k)
        3074  5890903200 :         proc_rates%npsacwgtot(i,k) = npsacwg(i,k)*lcldm(i,k)
        3075             :
        3076  5890903200 :         proc_rates%nnuccctot(i,k) = nnuccc(i,k)*lcldm(i,k)
        3077  5890903200 :         proc_rates%nnuccttot(i,k) = nnucct(i,k)*lcldm(i,k)
        3078  5890903200 :         proc_rates%nnuccdtot(i,k) = nnuccd(i,k)*icldm(i,k)
        3079  5890903200 :         proc_rates%nnudeptot(i,k) = nnudep(i,k)*lcldm(i,k)
        3080  5890903200 :         proc_rates%nnuccrtot(i,k) = nnuccr(i,k)*precip_frac(i,k)
        3081  5890903200 :         proc_rates%nnuccritot(i,k) = nnuccri(i,k)*precip_frac(i,k)
        3082  5890903200 :         proc_rates%nsacwitot(i,k) = nsacwi(i,k)*lcldm(i,k)
        3083  5890903200 :         proc_rates%npratot(i,k) = npra(i,k)*lcldm(i,k)
        3084  5890903200 :         proc_rates%npsacwstot(i,k) = npsacws(i,k)*lcldm(i,k)
        3085  5890903200 :         proc_rates%npraitot(i,k) = nprai(i,k)*icldm(i,k)
        3086  5890903200 :         proc_rates%npracstot(i,k) = npracs(i,k)*precip_frac(i,k)
        3087  5890903200 :         proc_rates%nprctot(i,k) = nprc(i,k)*lcldm(i,k)
        3088  5890903200 :         proc_rates%nraggtot(i,k) = nragg(i,k)*precip_frac(i,k)
        3089  5890903200 :         proc_rates%nprcitot(i,k) = nprci(i,k)*icldm(i,k)
        3090  5890903200 :         proc_rates%nmeltstot(i,k) = ninstsm(i,k)/deltat
        3091  6266175552 :         proc_rates%nmeltgtot(i,k) = ninstgm(i,k)/deltat
        3092             :      end do
        3093             :   end do
        3094             :   !$acc end parallel
        3095             :
        3096             :   !$acc parallel vector_length(VLENS) default(present)
        3097             :   !$acc loop gang vector collapse(2)
        3098   379739880 :   do k=1,nlev
        3099  6270643080 :      do i=1,mgncol
        3100 11781806400 :         nctend(i,k) = nctend(i,k)+&
        3101             :            (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) &
        3102 11781806400 :            -npra(i,k)-nprc1(i,k)-npsacwg(i,k))*lcldm(i,k)
        3103             :
        3104  5890903200 :         if (do_cldice) then
        3105  5890903200 :            if (use_hetfrz_classnuc) then
        3106           0 :               tmpfrz = nnuccc(i,k)
        3107             :            else
        3108             :               tmpfrz = 0._r8
        3109             :            end if
        3110             :            nitend(i,k) = nitend(i,k)+ nnuccd(i,k)+ &
        3111             :                 (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- &
        3112  5890903200 :                 nprai(i,k))*icldm(i,k)+(nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k)
        3113             :         end if
        3114             :
        3115  5890903200 :         if(do_graupel.or.do_hail) then
        3116             :            nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ &
        3117  5890903200 :                 nsagg(i,k)-ngracs(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(i,k)-nscng(i,k)*lcldm(i,k)
        3118  5890903200 :            ngtend(i,k) = ngtend(i,k)+nscng(i,k)*lcldm(i,k)+(ngracs(i,k)+nnuccr(i,k))*precip_frac(i,k)
        3119             :         else
        3120             :            !necessary since mnuccr moved to graupel
        3121             :            nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ &
        3122           0 :                 nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(i,k)
        3123             :         end if
        3124             :
        3125             :         nrtend(i,k) = nrtend(i,k)+ &
        3126             :              nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) &
        3127  5890903200 :              -nnuccri(i,k)+nragg(i,k)-npracg(i,k)-ngracs(i,k))*precip_frac(i,k)
        3128             :
        3129             :         !-----------------------------------------------------
        3130             :         ! convert rain/snow q and N for output to history, note,
        3131             :         ! output is for gridbox average
        3132             :
        3133  5890903200 :         qrout(i,k) = qr(i,k)
        3134  5890903200 :         nrout(i,k) = nr(i,k) * rho(i,k)
        3135  5890903200 :         qsout(i,k) = qs(i,k)
        3136  5890903200 :         nsout(i,k) = ns(i,k) * rho(i,k)
        3137  5890903200 :         qgout(i,k) = qg(i,k)
        3138  6266175552 :         ngout(i,k) = ng(i,k) * rho(i,k)
        3139             :      end do
        3140             :   end do
        3141             :   !$acc end parallel
        3142             :
        3143             :   ! calculate n0r and lamr from rain mass and number
        3144             :   ! divide by precip fraction to get in-precip (local) values of
        3145             :   ! rain mass and number, divide by rhow to get rain number in kg^-1
        3146     4467528 :   call size_dist_param_basic(mg_rain_props, qric, nric, lamr, mgncol, nlev, n0=n0r)
        3147             :
        3148             :   ! Calculate rercld
        3149             :   ! calculate mean size of combined rain and cloud water
        3150     4467528 :   call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol*nlev)
        3151             :
        3152             :   ! Assign variables back to start-of-timestep values
        3153             :   ! Some state variables are changed before the main microphysics loop
        3154             :   ! to make "instantaneous" adjustments. Afterward, we must move those changes
        3155             :   ! back into the tendencies.
        3156             :   ! These processes:
        3157             :   !  - Droplet activation (npccn, impacts nc)
        3158             :   !  - Instantaneous snow melting  (minstsm/ninstsm, impacts qr/qs/nr/ns)
        3159             :   !  - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns)
        3160             :   !================================================================================
        3161             :   ! Re-apply droplet activation tendency
        3162             :
        3163             :   !$acc parallel vector_length(VLENS) default(present)
        3164             :   !$acc loop gang vector collapse(2)
        3165   379739880 :   do k=1,nlev
        3166  6270643080 :      do i=1,mgncol
        3167  5890903200 :         nc(i,k) = ncn(i,k)
        3168  5890903200 :         nctend(i,k) = nctend(i,k) + npccn(i,k)
        3169             :         ! Re-apply rain freezing and snow melting.
        3170  5890903200 :         dum_2D(i,k) = qs(i,k)
        3171  5890903200 :         qs(i,k)     = qsn(i,k)
        3172  5890903200 :         qstend(i,k) = qstend(i,k) + (dum_2D(i,k)-qs(i,k))*rdeltat
        3173             :
        3174  5890903200 :         dum_2D(i,k) = ns(i,k)
        3175  5890903200 :         ns(i,k)     = nsn(i,k)
        3176  5890903200 :         nstend(i,k) = nstend(i,k) + (dum_2D(i,k)-ns(i,k))*rdeltat
        3177             :
        3178  5890903200 :         dum_2D(i,k) = qr(i,k)
        3179  5890903200 :         qr(i,k)     = qrn(i,k)
        3180  5890903200 :         qrtend(i,k) = qrtend(i,k) + (dum_2D(i,k)-qr(i,k))*rdeltat
        3181             :
        3182  5890903200 :         dum_2D(i,k) = nr(i,k)
        3183  5890903200 :         nr(i,k)     = nrn(i,k)
        3184  5890903200 :         nrtend(i,k) = nrtend(i,k) + (dum_2D(i,k)-nr(i,k))*rdeltat
        3185             :
        3186             :         ! Re-apply graupel freezing/melting
        3187  5890903200 :         dum_2D(i,k) = qg(i,k)
        3188  5890903200 :         qg(i,k)     = qgr(i,k)
        3189  5890903200 :         qgtend(i,k) = qgtend(i,k) + (dum_2D(i,k)-qg(i,k))*rdeltat
        3190             :
        3191  5890903200 :         dum_2D(i,k) = ng(i,k)
        3192  5890903200 :         ng(i,k)     = ngr(i,k)
        3193  5890903200 :         ngtend(i,k) = ngtend(i,k) + (dum_2D(i,k)-ng(i,k))*rdeltat
        3194             :         !.............................................................................
        3195             :         !================================================================================
        3196             :         ! modify to include snow. in prain & evap (diagnostic here: for wet dep)
        3197  5890903200 :         nevapr(i,k) = nevapr(i,k) + proc_rates%evapsnow(i,k)
        3198  6266175552 :         prain(i,k) = prain(i,k) + proc_rates%prodsnow(i,k)
        3199             :      end do
        3200             :   end do
        3201             :   !$acc end parallel
        3202             :
        3203             :   !$acc parallel vector_length(VLENS) default(present)
        3204             :   !$acc loop gang vector collapse(2)
        3205   379739880 :   do k=1,nlev
        3206  6270643080 :      do i=1,mgncol
        3207             :         ! calculate sedimentation for cloud water and ice
        3208             :         ! and Graupel (mg3)
        3209             :         !================================================================================
        3210             :         ! update in-cloud cloud mixing ratio and number concentration
        3211             :         ! with microphysical tendencies to calculate sedimentation, assign to dummy vars
        3212             :         ! note: these are in-cloud values***, hence we divide by cloud fraction
        3213  5890903200 :         dumc(i,k)  = (qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k)
        3214  5890903200 :         dumi(i,k)  = (qi(i,k)+qitend(i,k)*deltat)/icldm(i,k)
        3215  5890903200 :         dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k),0._r8)
        3216  5890903200 :         dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)/icldm(i,k),0._r8)
        3217             :
        3218  5890903200 :         dumr(i,k)  = (qr(i,k)+qrtend(i,k)*deltat)/precip_frac(i,k)
        3219  5890903200 :         dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)/precip_frac(i,k),0._r8)
        3220  5890903200 :         dums(i,k)  = (qs(i,k)+qstend(i,k)*deltat)/precip_frac(i,k)
        3221  5890903200 :         dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)/precip_frac(i,k),0._r8)
        3222             :
        3223  5890903200 :         dumg(i,k)  = (qg(i,k)+qgtend(i,k)*deltat)/precip_frac(i,k)
        3224  5890903200 :         dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat)/precip_frac(i,k),0._r8)
        3225             :
        3226             :         ! switch for specification of droplet and crystal number
        3227  5890903200 :         if (ngcons) then
        3228           0 :            dumng(i,k)=ngnst/rho(i,k)
        3229             :         end if
        3230             :
        3231             :         ! switch for specification of droplet and crystal number
        3232  5890903200 :         if (nccons) then
        3233           0 :            dumnc(i,k)=ncnst/rho(i,k)
        3234             :         end if
        3235             :
        3236             :         ! switch for specification of cloud ice number
        3237  5890903200 :         if (nicons) then
        3238           0 :            dumni(i,k)=ninst/rho(i,k)
        3239             :         end if
        3240             :
        3241             :         ! switch for specification of constant number
        3242  5890903200 :         if (nscons) then
        3243           0 :             dumns(i,k)=nsnst/rho(i,k)
        3244             :         end if
        3245             :
        3246             :         ! switch for specification of constant number
        3247  6266175552 :         if (nrcons) then
        3248           0 :             dumnr(i,k)=nrnst/rho(i,k)
        3249             :         end if
        3250             :      end do
        3251             :   end do
        3252             :   !$acc end parallel
        3253             :
        3254             :   ! obtain new slope parameter to avoid possible singularity
        3255     4467528 :   call size_dist_param_basic(mg_ice_props, dumi, dumni, lami, mgncol, nlev)
        3256     4467528 :   call size_dist_param_liq(mg_liq_props, dumc, dumnc, rho, pgam, lamc, mgncol, nlev)
        3257             :
        3258             :   ! fallspeed for rain
        3259     4467528 :   call size_dist_param_basic(mg_rain_props, dumr, dumnr, lamr, mgncol, nlev)
        3260             :   ! fallspeed for snow
        3261     4467528 :   call size_dist_param_basic(mg_snow_props, dums, dumns, lams, mgncol, nlev)
        3262             :   ! fallspeed for graupel
        3263     4467528 :   if (do_hail) then
        3264           0 :      call size_dist_param_basic(mg_hail_props, dumg, dumng, lamg, mgncol, nlev)
        3265             :   end if
        3266     4467528 :   if (do_graupel) then
        3267     4467528 :      call size_dist_param_basic(mg_graupel_props, dumg, dumng, lamg, mgncol, nlev)
        3268             :   end if
        3269             :
        3270     4467528 :   if ( do_implicit_fall ) then
        3271             : !    calculate interface height for implicit sedimentation
        3272             : !    uses Hypsometric equation
        3273             :
        3274             :      !$acc parallel vector_length(VLENS) default(present)
        3275             :      !$acc loop gang vector
        3276    74597328 :      do i=1,mgncol
        3277    70129800 :         zint(i,nlev+1)=0._r8
        3278             :         !$acc loop seq
        3279  5965500528 :         do k = nlev,1,-1
        3280  5890903200 :            H = r*t(i,k)/g*log(pint(i,k+1)/pint(i,k))
        3281  5961033000 :            zint(i,k)=zint(i,k+1)+H
        3282             :         enddo
        3283             :      enddo
        3284             :      !$acc end parallel
        3285             :   end if
        3286             :
        3287             :   !$acc parallel vector_length(VLENS) default(present) async(LQUEUE)
        3288             :   !$acc loop gang vector collapse(2)
        3289   379739880 :   do k=1,nlev
        3290  6270643080 :      do i=1,mgncol
        3291             :         ! calculate number and mass weighted fall velocity for droplets and cloud ice
        3292             :         !-------------------------------------------------------------------
        3293  5890903200 :         if (dumc(i,k).ge.qsmall) then
        3294   515312722 :            dum1 = 4._r8+bc+pgam(i,k)
        3295   515312722 :            dum2 = pgam(i,k)+4._r8
        3296   515312722 :            proc_rates%vtrmc(i,k)=acn(i,k)*gamma(dum1)/(lamc(i,k)**bc*gamma(dum2))
        3297             :            ! Following ifs, no condensate sedimentation
        3298   515312722 :            if (ifs_sed) then
        3299           0 :               fc(i,k)  = 0._r8
        3300           0 :               fnc(i,k) = 0._r8
        3301             :            else
        3302   515312722 :               dum3     = 1._r8+bc+pgam(i,k)
        3303   515312722 :               dum4     = pgam(i,k)+1._r8
        3304   515312722 :               fc(i,k)  = g*rho(i,k)*proc_rates%vtrmc(i,k)
        3305             :               fnc(i,k) = g*rho(i,k)* &
        3306             :                    acn(i,k)*gamma(dum3)/ &
        3307   515312722 :                    (lamc(i,k)**bc*gamma(dum4))
        3308             :            end if
        3309             :         else
        3310  5375590478 :            fc(i,k) = 0._r8
        3311  5375590478 :            fnc(i,k)= 0._r8
        3312             :         end if
        3313             :
        3314             :         ! redefine dummy variables - sedimentation is calculated over grid-scale
        3315             :         ! quantities to ensure conservation
        3316  5890903200 :         dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)
        3317  5890903200 :         dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat),0._r8)
        3318  6266175552 :         if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8
        3319             :      end do
        3320             :   end do
        3321             :   !$acc end parallel
        3322             :
        3323             :   !$acc parallel vector_length(VLENS) default(present) async(IQUEUE)
        3324             :   !$acc loop gang vector collapse(2)
        3325   379739880 :   do k=1,nlev
        3326  6270643080 :      do i=1,mgncol
        3327             :         ! calculate number and mass weighted fall velocity for cloud ice
        3328  5890903200 :         if (dumi(i,k).ge.qsmall) then
        3329           0 :            proc_rates%vtrmi(i,k)=min(ain(i,k)*gamma_bi_plus4/(6._r8*lami(i,k)**bi), &
        3330  1933577142 :                 1.2_r8*rhof(i,k))
        3331  1933577142 :            proc_rates%vtrmi(i,k)=proc_rates%vtrmi(i,k)*micro_mg_vtrmi_factor
        3332             :
        3333  1933577142 :            fi(i,k) = g*rho(i,k)*proc_rates%vtrmi(i,k)
        3334             :            fni(i,k) = g*rho(i,k)* &
        3335  1933577142 :                 min(ain(i,k)*gamma_bi_plus1/lami(i,k)**bi,1.2_r8*rhof(i,k))
        3336             :
        3337             :            ! adjust the ice fall velocity for smaller (r < 20 um) ice
        3338             :            ! particles (blend over 8-20 um)
        3339  1933577142 :            irad = 1.5_r8 / lami(i,k) * 1e6_r8
        3340  1933577142 :            ifrac = min(1._r8, max(0._r8, (irad - 18._r8) / 2._r8))
        3341             :
        3342  1933577142 :            if (ifrac .lt. 1._r8) then
        3343           0 :               proc_rates%vtrmi(i,k) = ifrac * proc_rates%vtrmi(i,k) + &
        3344             :                  (1._r8 - ifrac) * &
        3345             :                  min(ajn(i,k)*gamma_bj_plus4/(6._r8*lami(i,k)**bj), &
        3346   509061122 :                  1.2_r8*rhof(i,k))
        3347   509061122 :               proc_rates%vtrmi(i,k)=proc_rates%vtrmi(i,k)*micro_mg_vtrmi_factor
        3348             :
        3349   509061122 :               fi(i,k)  = g*rho(i,k)*proc_rates%vtrmi(i,k)
        3350             :               fni(i,k) = ifrac * fni(i,k) + &
        3351             :                  (1._r8 - ifrac) * &
        3352             :                  g*rho(i,k)* &
        3353   509061122 :                  min(ajn(i,k)*gamma_bj_plus1/lami(i,k)**bj,1.2_r8*rhof(i,k))
        3354             :            end if
        3355             :
        3356             :            ! Fix ice fall speed following IFS microphysics
        3357  1933577142 :            if (ifs_sed) then
        3358           0 :               fi(i,k)=g*rho(i,k)*0.1_r8
        3359           0 :               fni(i,k)=g*rho(i,k)*0.1_r8
        3360             :            end if
        3361             :         else
        3362  3957326058 :            fi(i,k) = 0._r8
        3363  3957326058 :            fni(i,k)= 0._r8
        3364             :         end if
        3365             :
        3366             :         ! redefine dummy variables - sedimentation is calculated over grid-scale
        3367             :         ! quantities to ensure conservation
        3368  5890903200 :         dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)
        3369  5890903200 :         dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat),0._r8)
        3370  6266175552 :         if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8
        3371             :      end do
        3372             :   end do
        3373             :   !$acc end parallel
        3374             :
        3375             :   !$acc parallel vector_length(VLENS) default(present) async(RQUEUE)
        3376             :   !$acc loop gang vector
        3377    74597328 :   do i=1,mgncol
        3378             :      !$acc loop seq
        3379  5965500528 :      do k=1,nlev
        3380  5890903200 :         if (lamr(i,k).ge.qsmall) then
        3381  1328674440 :            qtmp = lamr(i,k)**br
        3382             :            ! 'final' values of number and mass weighted mean fallspeed for rain (m/s)
        3383  1328674440 :            unr(i,k) = min(arn(i,k)*gamma_br_plus1/qtmp,9.1_r8*rhof(i,k))
        3384  1328674440 :            fnr(i,k) = g*rho(i,k)*unr(i,k)
        3385  1328674440 :            proc_rates%umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*qtmp),9.1_r8*rhof(i,k))
        3386  1328674440 :            fr(i,k) = g*rho(i,k)*proc_rates%umr(i,k)
        3387             :         else
        3388  4562228760 :            fr(i,k)=0._r8
        3389  4562228760 :            fnr(i,k)=0._r8
        3390             :         end if
        3391             :
        3392             :         ! Fallspeed correction to ensure non-zero if rain in the column
        3393             :         ! from updated Morrison (WRFv3.3) and P3 schemes
        3394             :         ! If fallspeed exists at a higher level, apply it below to eliminate
        3395  5890903200 :         if (precip_fall_corr) then
        3396           0 :            if (k.gt.2) then
        3397           0 :               if (fr(i,k).lt.1.e-10_r8) then
        3398           0 :                  fr(i,k)=fr(i,k-1)
        3399           0 :                  fnr(i,k)=fnr(i,k-1)
        3400             :               end if
        3401             :            end if
        3402             :         end if
        3403             :
        3404             :         ! redefine dummy variables - sedimentation is calculated over grid-scale
        3405             :         ! quantities to ensure conservation
        3406  5890903200 :         dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat)
        3407  5890903200 :         dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat),0._r8)
        3408  5961033000 :         if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8
        3409             :      end do
        3410             :   end do
        3411             :   !$acc end parallel
        3412             :
        3413             :   !$acc parallel vector_length(VLENS) default(present) async(SQUEUE)
        3414             :   !$acc loop gang vector
        3415    74597328 :   do i=1,mgncol
        3416             :      !$acc loop seq
        3417  5965500528 :      do k=1,nlev
        3418  5890903200 :         if (lams(i,k).ge.qsmall) then
        3419  1524747491 :            qtmp = lams(i,k)**bs
        3420             :            ! 'final' values of number and mass weighted mean fallspeed for snow (m/s)
        3421  1524747491 :            proc_rates%ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*qtmp),1.2_r8*rhof(i,k))
        3422  1524747491 :            proc_rates%ums(i,k) = proc_rates%ums(i,k)*micro_mg_vtrms_factor
        3423             :
        3424  1524747491 :            fs(i,k)  = g*rho(i,k)*proc_rates%ums(i,k)
        3425  1524747491 :            uns(i,k) = min(asn(i,k)*gamma_bs_plus1/qtmp,1.2_r8*rhof(i,k))
        3426  1524747491 :            fns(i,k) = g*rho(i,k)*uns(i,k)
        3427             :            ! Fix fallspeed for snow
        3428  1524747491 :            if (ifs_sed) then
        3429           0 :               proc_rates%ums(i,k) = 1._r8
        3430           0 :               uns(i,k) = 1._r8
        3431             :             end if
        3432             :         else
        3433  4366155709 :            fs(i,k)=0._r8
        3434  4366155709 :            fns(i,k)=0._r8
        3435             :         end if
        3436             :
        3437  5890903200 :         if (precip_fall_corr) then
        3438           0 :            if (k.gt.2) then
        3439           0 :               if (fs(i,k).lt.1.e-10_r8) then
        3440           0 :                  fs(i,k)=fs(i,k-1)
        3441           0 :                  fns(i,k)=fns(i,k-1)
        3442             :               end if
        3443             :            end if
        3444             :         end if
        3445             :
        3446             :         ! redefine dummy variables - sedimentation is calculated over grid-scale
        3447             :         ! quantities to ensure conservation
        3448  5890903200 :         dums(i,k) = (qs(i,k)+qstend(i,k)*deltat)
        3449  5890903200 :         dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat),0._r8)
        3450  5961033000 :         if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8
        3451             :      end do
        3452             :   end do
        3453             :   !$acc end parallel
        3454             :
        3455             :   !$acc parallel vector_length(VLENS) default(present) async(GQUEUE)
        3456             :   !$acc loop gang vector
        3457    74597328 :   do i=1,mgncol
        3458             :      !$acc loop seq
        3459  5965500528 :      do k=1,nlev
        3460  5890903200 :         if (lamg(i,k).ge.qsmall) then
        3461   729470418 :            qtmp = lamg(i,k)**bgtmp
        3462             :            ! 'final' values of number and mass weighted mean fallspeed for graupel (m/s)
        3463   729470418 :            proc_rates%umg(i,k) = min(agn(i,k)*gamma_bg_plus4/(6._r8*qtmp),20._r8*rhof(i,k))
        3464   729470418 :            fg(i,k) = g*rho(i,k)*proc_rates%umg(i,k)
        3465   729470418 :            ung(i,k) = min(agn(i,k)*gamma_bg_plus1/qtmp,20._r8*rhof(i,k))
        3466   729470418 :            fng(i,k) = g*rho(i,k)*ung(i,k)
        3467             :         else
        3468  5161432782 :            fg(i,k)=0._r8
        3469  5161432782 :            fng(i,k)=0._r8
        3470             :         end if
        3471             :
        3472  5890903200 :         if (precip_fall_corr) then
        3473           0 :            if (k.gt.2) then
        3474           0 :               if (fg(i,k).lt.1.e-10_r8) then
        3475           0 :                  fg(i,k)=fg(i,k-1)
        3476           0 :                  fng(i,k)=fng(i,k-1)
        3477             :               end if
        3478             :            end if
        3479             :         end if
        3480             :
        3481             :         ! redefine dummy variables - sedimentation is calculated over grid-scale
        3482             :         ! quantities to ensure conservation
        3483  5890903200 :         dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat)
        3484  5890903200 :         dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat),0._r8)
        3485  5961033000 :         if (dumg(i,k).lt.qsmall) dumng(i,k)=0._r8
        3486             :      end do
        3487             :   end do
        3488             :   !$acc end parallel
        3489             :
        3490             : ! ----------------------------------------------
        3491             : ! Sedimentation
        3492             : ! ----------------------------------------------
        3493             :
        3494     4467528 : if ( do_implicit_fall ) then
        3495             :
        3496             : ! Implicit Sedimentation calculation: from Guo et al, 2021, GFDL version.
        3497             :
        3498             :   !$acc parallel vector_length(VLENS) default(present) async(LQUEUE)
        3499             :   !$acc loop gang vector collapse(2)
        3500   379739880 :   do k=1,nlev
        3501  6270643080 :      do i=1,mgncol
        3502  5890903200 :         fc(i,k)  = vfac_drop * fc(i,k)/g/rho(i,k)
        3503  6266175552 :         fnc(i,k) = vfac_drop * fnc(i,k)/g/rho(i,k)
        3504             :      end do
        3505             :   end do
        3506             :   !$acc end parallel
        3507             :
        3508             :   !$acc parallel vector_length(VLENS) default(present) async(IQUEUE)
        3509             :   !$acc loop gang vector collapse(2)
        3510   379739880 :   do k=1,nlev
        3511  6270643080 :      do i=1,mgncol
        3512  5890903200 :         fi(i,k)  = vfac_ice  * fi(i,k)/g/rho(i,k)
        3513  6266175552 :         fni(i,k) = vfac_ice  * fni(i,k)/g/rho(i,k)
        3514             :      end do
        3515             :   end do
        3516             :   !$acc end parallel
        3517             :
        3518             :   !$acc parallel vector_length(VLENS) default(present) async(RQUEUE)
        3519             :   !$acc loop gang vector collapse(2)
        3520   379739880 :   do k=1,nlev
        3521  6270643080 :      do i=1,mgncol
        3522  5890903200 :         fr(i,k)  = vfactor * fr(i,k)/g/rho(i,k)
        3523  6266175552 :         fnr(i,k) = vfactor * fnr(i,k)/g/rho(i,k)
        3524             :      end do
        3525             :   end do
        3526             :   !$acc end parallel
        3527             :
        3528             :   !$acc parallel vector_length(VLENS) default(present) async(SQUEUE)
        3529             :   !$acc loop gang vector collapse(2)
        3530   379739880 :   do k=1,nlev
        3531  6270643080 :      do i=1,mgncol
        3532  5890903200 :         fs(i,k)  = vfactor * fs(i,k)/g/rho(i,k)
        3533  6266175552 :         fns(i,k) = vfactor * fns(i,k)/g/rho(i,k)
        3534             :      end do
        3535             :   end do
        3536             :   !$acc end parallel
        3537             :
        3538             :   !$acc parallel vector_length(VLENS) default(present) async(GQUEUE)
        3539             :   !$acc loop gang vector collapse(2)
        3540   379739880 :   do k=1,nlev
        3541  6270643080 :      do i=1,mgncol
        3542  5890903200 :         fg(i,k)  = vfactor * fg(i,k)/g/rho(i,k)
        3543  6266175552 :         fng(i,k) = vfactor * fng(i,k)/g/rho(i,k)
        3544             :      end do
        3545             :   end do
        3546             :   !$acc end parallel
        3547             :
        3548             :   ! cloud water mass sedimentation
        3549             :
        3550             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumc,fc,.FALSE.,qctend, &
        3551     4467528 :                               LQUEUE,xflx=lflx,qxsedten=proc_rates%qcsedten,prect=prect_l)
        3552             :
        3553             :   ! cloud water number sedimentation
        3554             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumnc,fnc,.FALSE.,nctend, &
        3555     4467528 :                               LQUEUE,qxsedten=proc_rates%ncsedten)
        3556             :
        3557             :   ! cloud ice mass sedimentation
        3558             :
        3559             :    call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumi,fi,.FALSE.,qitend, &
        3560     4467528 :                                IQUEUE,xflx=iflx,qxsedten=proc_rates%qisedten,prect=prect_i,preci=preci_i)
        3561             :
        3562             :   ! cloud ice number sedimentation
        3563             :
        3564             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumni,fni,.FALSE.,nitend, &
        3565     4467528 :                               IQUEUE,qxsedten=proc_rates%nisedten)
        3566             :
        3567             :   ! rain water mass sedimentation
        3568             :
        3569             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumr,fr,.TRUE.,qrtend, &
        3570     4467528 :                               RQUEUE,xflx=rflx,qxsedten=proc_rates%qrsedten,prect=prect_r)
        3571             :
        3572             :   ! rain water number sedimentation
        3573             :
        3574             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumnr,fnr,.TRUE.,nrtend, &
        3575     4467528 :                               RQUEUE,qxsedten=proc_rates%nrsedten)
        3576             :
        3577             :   ! snow water mass sedimentation
        3578             :
        3579             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dums,fs,.TRUE.,qstend, &
        3580     4467528 :                               SQUEUE,xflx=sflx,qxsedten=proc_rates%qssedten,prect=prect_s,preci=preci_s)
        3581             :
        3582             :   ! snow water number sedimentation
        3583             :
        3584             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumns,fns,.TRUE.,nstend, &
        3585     4467528 :                               SQUEUE,qxsedten=proc_rates%nssedten)
        3586             :
        3587             :   ! graupel mass sedimentation
        3588             :
        3589             :    call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumg,fg,.TRUE.,qgtend, &
        3590     4467528 :                                GQUEUE,xflx=gflx,qxsedten=proc_rates%qgsedten,prect=prect_g,preci=preci_g)
        3591             :
        3592             :   ! graupel number sedimentation
        3593             :
        3594             :   call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumng,fng,.TRUE.,ngtend, &
        3595     4467528 :                               GQUEUE,qxsedten=proc_rates%ngsedten)
        3596             :
        3597             : else
        3598             :
        3599             : ! Explicit Sedimentation calculation
        3600             :
        3601             :   !$acc parallel vector_length(VLENS) default(present) async(IQUEUE)
        3602             :   !$acc loop gang vector
        3603           0 :   do i = 1, mgncol
        3604           0 :      nstep_i(i) = 1 + int( max( maxval( fi(i,:)*pdel_inv(i,:) ), maxval( fni(i,:)*pdel_inv(i,:) ) ) * deltat )
        3605           0 :      rnstep_i(i) = 1._r8/real(nstep_i(i))
        3606             :   end do
        3607             :   !$acc end parallel
        3608             :
        3609             :   ! ice mass sediment
        3610             :   call Sedimentation(mgncol,nlev,do_cldice,deltat,nstep_i,rnstep_i,fi,dumi,pdel_inv, &
        3611             :                      qitend,IQUEUE,qxsedten=proc_rates%qisedten,prect=prect_i,xflx=iflx,xxlx=xxls, &
        3612           0 :                      qxsevap=proc_rates%qisevap,tlat=tlat_i,qvlat=qvlat_i,xcldm=icldm,preci=preci_i)
        3613             :
        3614             :   ! ice number sediment
        3615             :   call Sedimentation(mgncol,nlev,do_cldice,deltat,nstep_i,rnstep_i,fni,dumni,pdel_inv, &
        3616           0 :                      nitend,IQUEUE,xcldm=icldm,qxsedten=proc_rates%nisedten)
        3617             :
        3618             :   !$acc parallel vector_length(VLENS) default(present) async(LQUEUE)
        3619             :   !$acc loop gang vector
        3620           0 :   do i = 1, mgncol
        3621           0 :      nstep_l(i) = 1 + int( max( maxval( fc(i,:)*pdel_inv(i,:) ), maxval( fnc(i,:)*pdel_inv(i,:) ) ) * deltat )
        3622           0 :      rnstep_l(i) = 1._r8/real(nstep_l(i))
        3623             :   end do
        3624             :   !$acc end parallel
        3625             :
        3626             :   ! liq mass sediment
        3627             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_l,rnstep_l,fc,dumc,pdel_inv, &
        3628             :                      qctend,LQUEUE,qxsedten=proc_rates%qcsedten,prect=prect_l,xflx=lflx,xxlx=xxlv, &
        3629           0 :                      qxsevap=proc_rates%qcsevap,tlat=tlat_l,qvlat=qvlat_l,xcldm=lcldm)
        3630             :
        3631             :   ! liq number sediment
        3632             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_l,rnstep_l,fnc,dumnc,pdel_inv, &
        3633           0 :                      nctend,LQUEUE,xcldm=lcldm,qxsedten=proc_rates%ncsedten)
        3634             :
        3635             :   !$acc parallel vector_length(VLENS) default(present) async(RQUEUE)
        3636             :   !$acc loop gang vector
        3637           0 :   do i = 1, mgncol
        3638           0 :      nstep_r(i) = 1 + int( max( maxval( fr(i,:)*pdel_inv(i,:) ), maxval( fnr(i,:)*pdel_inv(i,:) ) ) * deltat )
        3639           0 :      rnstep_r(i) = 1._r8/real(nstep_r(i))
        3640             :   end do
        3641             :   !$acc end parallel
        3642             :
        3643             :   ! rain mass sediment
        3644             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_r,rnstep_r,fr,dumr,pdel_inv, &
        3645           0 :                      qrtend,RQUEUE,qxsedten=proc_rates%qrsedten,prect=prect_r,xflx=rflx)
        3646             :
        3647             :   ! rain number sediment
        3648             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_r,rnstep_r,fnr,dumnr,pdel_inv, &
        3649           0 :                      nrtend,RQUEUE,qxsedten=proc_rates%nrsedten)
        3650             :
        3651             :   !$acc parallel vector_length(VLENS) default(present) async(SQUEUE)
        3652             :   !$acc loop gang vector
        3653           0 :   do i = 1, mgncol
        3654           0 :      nstep_s(i) = 1 + int( max( maxval( fs(i,:)*pdel_inv(i,:) ), maxval( fns(i,:)*pdel_inv(i,:) ) ) * deltat )
        3655           0 :      rnstep_s(i) = 1._r8/real(nstep_s(i))
        3656             :   end do
        3657             :   !$acc end parallel
        3658             :
        3659             :   ! snow mass sediment
        3660             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_s,rnstep_s,fs,dums,pdel_inv, &
        3661           0 :                      qstend,SQUEUE,qxsedten=proc_rates%qssedten,prect=prect_s,xflx=sflx,preci=preci_s)
        3662             :
        3663             :   ! snow number sediment
        3664             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_s,rnstep_s,fns,dumns,pdel_inv, &
        3665           0 :                      nstend,SQUEUE,qxsedten=proc_rates%nssedten)
        3666             :
        3667             :   !$acc parallel vector_length(VLENS) default(present) async(GQUEUE)
        3668             :   !$acc loop gang vector
        3669           0 :   do i = 1, mgncol
        3670           0 :      nstep_g(i) = 1 + int( max( maxval( fg(i,:)*pdel_inv(i,:) ), maxval( fng(i,:)*pdel_inv(i,:) ) ) * deltat )
        3671           0 :      rnstep_g(i) = 1._r8/real(nstep_g(i))
        3672             :   end do
        3673             :   !$acc end parallel
        3674             :
        3675             :   ! graupel mass sediment
        3676             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_g,rnstep_g,fg,dumg,pdel_inv, &
        3677           0 :                      qgtend,GQUEUE,qxsedten=proc_rates%qgsedten,prect=prect_g,xflx=gflx,preci=preci_g)
        3678             :
        3679             :   ! graupel number sediment
        3680             :   call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_g,rnstep_g,fng,dumng,pdel_inv, &
        3681           0 :                      ngtend,GQUEUE,qxsedten=proc_rates%ngsedten)
        3682             :
        3683             : end if
        3684             : ! ----------------------------------------------
        3685             : ! End Sedimentation
        3686             : ! ----------------------------------------------
        3687             :
        3688             :   ! sum up the changes due to sedimentation process for different hydrometeors
        3689             :
        3690             :   !$acc parallel vector_length(VLENS) default(present) wait(IQUEUE,LQUEUE)
        3691             :   !$acc loop gang vector collapse(2)
        3692   379739880 :   do k=1,nlev
        3693  6270643080 :      do i=1,mgncol
        3694  5890903200 :         tlat(i,k)  = tlat(i,k) + tlat_i(i,k) + tlat_l(i,k)
        3695  6266175552 :         qvlat(i,k) = qvlat(i,k) + qvlat_i(i,k) + qvlat_l(i,k)
        3696             :      end do
        3697             :   end do
        3698             :   !$acc end parallel
        3699             :
        3700             :   !$acc parallel vector_length(VLENS) wait(RQUEUE,SQUEUE,GQUEUE)
        3701             :   !$acc loop gang vector
        3702    74597328 :   do i=1,mgncol
        3703    70129800 :      prect(i)  = prect(i) + prect_i(i) + prect_l(i) + prect_r(i) + prect_s(i) + prect_g(i)
        3704    74597328 :      preci(i)  = preci(i) + preci_i(i) + preci_s(i) + preci_g(i)
        3705             :   end do
        3706             :   !$acc end parallel
        3707             :
        3708             :   !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        3709             :
        3710             :   ! get new update for variables that includes sedimentation tendency
        3711             :   ! note : here dum variables are grid-average, NOT in-cloud
        3712             :
        3713             :   !$acc parallel vector_length(VLENS) default(present)
        3714             :   !$acc loop gang vector collapse(2)
        3715   379739880 :   do k=1,nlev
        3716  6270643080 :      do i=1,mgncol
        3717  5890903200 :         dumc(i,k)  = max(qc(i,k)+qctend(i,k)*deltat,0._r8)
        3718  5890903200 :         dumi(i,k)  = max(qi(i,k)+qitend(i,k)*deltat,0._r8)
        3719  5890903200 :         dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)
        3720  5890903200 :         dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)
        3721             :
        3722  5890903200 :         dumr(i,k)  = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)
        3723  5890903200 :         dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)
        3724  5890903200 :         dums(i,k)  = max(qs(i,k)+qstend(i,k)*deltat,0._r8)
        3725  5890903200 :         dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)
        3726  5890903200 :         dumg(i,k)  = max(qg(i,k)+qgtend(i,k)*deltat,0._r8)
        3727  5890903200 :         dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat,0._r8)
        3728             :
        3729             :         ! switch for specification of droplet and crystal number
        3730  5890903200 :         if (nccons) then
        3731           0 :            dumnc(i,k)=ncnst/rho(i,k)*lcldm(i,k)
        3732             :         end if
        3733             :
        3734             :         ! switch for specification of cloud ice number
        3735  5890903200 :         if (nicons) then
        3736           0 :            dumni(i,k)=ninst/rho(i,k)*icldm(i,k)
        3737             :         end if
        3738             :
        3739             :         ! switch for specification of graupel number
        3740  5890903200 :         if (ngcons) then
        3741           0 :            dumng(i,k)=ngnst/rho(i,k)*precip_frac(i,k)
        3742             :         end if
        3743             :
        3744             :         ! switch for specification of constant snow number
        3745  5890903200 :         if (nscons) then
        3746           0 :             dumns(i,k)=nsnst/rho(i,k)
        3747             :         end if
        3748             :
        3749             :         ! switch for specification of constant rain number
        3750  5890903200 :         if (nrcons) then
        3751           0 :             dumnr(i,k)=nrnst/rho(i,k)
        3752             :         end if
        3753             :
        3754  5890903200 :         if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8
        3755  5890903200 :         if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8
        3756  5890903200 :         if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8
        3757  5890903200 :         if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8
        3758  5890903200 :         if (dumg(i,k).lt.qsmall) dumng(i,k)=0._r8
        3759             :
        3760             :   ! calculate instantaneous processes (melting, homogeneous freezing)
        3761             :   !====================================================================
        3762             :   ! melting of snow at +2 C
        3763             :
        3764  5890903200 :         if (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) then
        3765  1042349170 :            if (dums(i,k) > 0._r8) then
        3766             :               ! make sure melting snow doesn't reduce temperature below threshold
        3767    40917756 :               dum = -xlf/cpp*dums(i,k)
        3768    40917756 :               if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt. snowmelt) then
        3769      675149 :                  dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf
        3770      675149 :                  dum = dum/dums(i,k)
        3771      675149 :                  dum = max(0._r8,dum)
        3772      675149 :                  dum = min(1._r8,dum)
        3773             :               else
        3774             :                  dum = 1._r8
        3775             :               end if
        3776             :
        3777    40917756 :               qstend(i,k)=qstend(i,k)-dum*dums(i,k)*rdeltat
        3778    40917756 :               nstend(i,k)=nstend(i,k)-dum*dumns(i,k)*rdeltat
        3779    40917756 :               qrtend(i,k)=qrtend(i,k)+dum*dums(i,k)*rdeltat
        3780    40917756 :               nrtend(i,k)=nrtend(i,k)+dum*dumns(i,k)*rdeltat
        3781             :
        3782    40917756 :               dum1=-xlf*dum*dums(i,k)*rdeltat
        3783    40917756 :               tlat(i,k)=tlat(i,k)+dum1
        3784    40917756 :               proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
        3785             :
        3786             : !STOPPED FIX FOR SNOW NUMBER
        3787             : !ensure that snow... number does not go negative with constant number set
        3788             : !necessary because dumng is updated above.
        3789    40917756 :               if (nscons .and. ((ns(i,k)+nstend(i,k)*deltat) .lt. 0._r8)) then
        3790           0 :                  nstend(i,k)=-ns(i,k)*rdeltat
        3791             :               end if
        3792             :            end if
        3793             :         end if
        3794             :
        3795             :   ! melting of graupel at +2 C
        3796             :
        3797  6266175552 :         if (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) then
        3798  1041674032 :            if (dumg(i,k) > 0._r8) then
        3799             :               ! make sure melting graupel doesn't reduce temperature below threshold
        3800    36841612 :               dum = -xlf/cpp*dumg(i,k)
        3801    36841612 :               if (t(i,k)+tlat(i,k)/cpp*deltat+dum .lt. snowmelt) then
        3802      323198 :                  dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf
        3803      323198 :                  dum = dum/dumg(i,k)
        3804      323198 :                  dum = max(0._r8,dum)
        3805      323198 :                  dum = min(1._r8,dum)
        3806             :               else
        3807             :                  dum = 1._r8
        3808             :               end if
        3809             :
        3810    36841612 :               qgtend(i,k)=qgtend(i,k)-dum*dumg(i,k)*rdeltat
        3811    36841612 :               ngtend(i,k)=ngtend(i,k)-dum*dumng(i,k)*rdeltat
        3812    36841612 :               qrtend(i,k)=qrtend(i,k)+dum*dumg(i,k)*rdeltat
        3813    36841612 :               nrtend(i,k)=nrtend(i,k)+dum*dumng(i,k)*rdeltat
        3814             :
        3815    36841612 :               dum1=-xlf*dum*dumg(i,k)*rdeltat
        3816    36841612 :               tlat(i,k)=tlat(i,k)+dum1
        3817    36841612 :               proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
        3818             :
        3819             : !ensure that graupel number does not go negative with constant number set
        3820             : !necessary because dumng is updated above.
        3821    36841612 :               if (ngcons .and. ((ng(i,k)+ngtend(i,k)*deltat) .lt. 0._r8)) then
        3822           0 :                  ngtend(i,k)=-ng(i,k)*rdeltat
        3823             :               end if
        3824             :            end if
        3825             :         end if
        3826             :      end do
        3827             :   end do
        3828             :   !$acc end parallel
        3829             :
        3830             :   ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice
        3831             :   ! depending on mean rain size
        3832             :   ! add to graupel if using that option....
        3833     4467528 :   call size_dist_param_basic(mg_rain_props, dumr, dumnr, lamr, mgncol, nlev)
        3834             :
        3835             :   !$acc parallel vector_length(VLENS) default(present)
        3836             :   !$acc loop gang vector collapse(2)
        3837   379739880 :   do k=1,nlev
        3838  6270643080 :      do i=1,mgncol
        3839             :         ! freezing of rain at -5 C
        3840  6266175552 :         if (t(i,k)+tlat(i,k)/cpp*deltat < rainfrze) then
        3841  3233767098 :            if (dumr(i,k) > 0._r8) then
        3842             :               ! make sure freezing rain doesn't increase temperature above threshold
        3843     8484716 :               dum = xlf/cpp*dumr(i,k)
        3844     8484716 :               if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.rainfrze) then
        3845           5 :                  dum = -(t(i,k)+tlat(i,k)/cpp*deltat-rainfrze)*cpp/xlf
        3846           5 :                  dum = dum/dumr(i,k)
        3847           5 :                  dum = max(0._r8,dum)
        3848           5 :                  dum = min(1._r8,dum)
        3849             :               else
        3850             :                  dum = 1._r8
        3851             :               end if
        3852             :
        3853     8484716 :               qrtend(i,k)=qrtend(i,k)-dum*dumr(i,k)*rdeltat
        3854     8484716 :               nrtend(i,k)=nrtend(i,k)-dum*dumnr(i,k)*rdeltat
        3855             :
        3856     8484716 :               if (lamr(i,k) < 1._r8/Dcs) then
        3857      284368 :                  if (do_hail.or.do_graupel) then
        3858      284368 :                     qgtend(i,k)=qgtend(i,k)+dum*dumr(i,k)*rdeltat
        3859      284368 :                     ngtend(i,k)=ngtend(i,k)+dum*dumnr(i,k)*rdeltat
        3860             :                  else
        3861           0 :                     qstend(i,k)=qstend(i,k)+dum*dumr(i,k)*rdeltat
        3862           0 :                     nstend(i,k)=nstend(i,k)+dum*dumnr(i,k)*rdeltat
        3863             :                  end if
        3864             :               else
        3865     8200348 :                  qitend(i,k)=qitend(i,k)+dum*dumr(i,k)*rdeltat
        3866     8200348 :                  nitend(i,k)=nitend(i,k)+dum*dumnr(i,k)*rdeltat
        3867             :               end if
        3868             :
        3869             :               ! heating tendency
        3870     8484716 :               dum1 = xlf*dum*dumr(i,k)*rdeltat
        3871     8484716 :               proc_rates%frzrdttot(i,k)=proc_rates%frzrdttot(i,k) + dum1
        3872     8484716 :               tlat(i,k)=tlat(i,k)+dum1
        3873             :            end if
        3874             :         end if
        3875             :       end do
        3876             :    end do
        3877             :    !$acc end parallel
        3878             :
        3879     4467528 :    if (do_cldice) then
        3880             :       !$acc parallel vector_length(VLENS) default(present)
        3881             :       !$acc loop gang vector collapse(2)
        3882   379739880 :       do k=1,nlev
        3883  6270643080 :         do i=1,mgncol
        3884  5890903200 :            if (t(i,k)+tlat(i,k)/cpp*deltat > tmelt) then
        3885  1123406578 :               if (dumi(i,k) > 0._r8) then
        3886             :                  ! limit so that melting does not push temperature below freezing
        3887             :                  !-----------------------------------------------------------------
        3888  1123406503 :                  dum = -dumi(i,k)*xlf/cpp
        3889  1123406503 :                  if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.tmelt) then
        3890       10954 :                     dum = (t(i,k)+tlat(i,k)/cpp*deltat-tmelt)*cpp/xlf
        3891       10954 :                     dum = dum/dumi(i,k)
        3892       10954 :                     dum = max(0._r8,dum)
        3893       10954 :                     dum = min(1._r8,dum)
        3894             :                  else
        3895             :                     dum = 1._r8
        3896             :                  end if
        3897             :
        3898  1123406503 :                  qctend(i,k)=qctend(i,k)+dum*dumi(i,k)*rdeltat
        3899             :
        3900             :                  ! for output
        3901  1123406503 :                  proc_rates%melttot(i,k)=dum*dumi(i,k)*rdeltat
        3902             :
        3903             :                  ! assume melting ice produces droplet
        3904             :                  ! mean volume radius of 8 micron
        3905             :
        3906           0 :                  proc_rates%nmelttot(i,k)=3._r8*dum*dumi(i,k)*rdeltat/ &
        3907  1123406503 :                       (4._r8*pi*5.12e-16_r8*rhow)
        3908  1123406503 :                  nctend(i,k)=nctend(i,k)+proc_rates%nmelttot(i,k)
        3909             :
        3910  1123406503 :                  qitend(i,k)=((1._r8-dum)*dumi(i,k)-qi(i,k))*rdeltat
        3911  1123406503 :                  nitend(i,k)=((1._r8-dum)*dumni(i,k)-ni(i,k))*rdeltat
        3912  1123406503 :                  tlat(i,k)=tlat(i,k)-xlf*dum*dumi(i,k)*rdeltat
        3913             :               end if
        3914             :            end if
        3915             :
        3916             :            ! homogeneously freeze droplets at -40 C
        3917             :            !-----------------------------------------------------------------
        3918             :
        3919  5890903200 :            if (t(i,k)+tlat(i,k)/cpp*deltat < 233.15_r8) then
        3920  3233767098 :               if (dumc(i,k) > 0._r8) then
        3921             :                  ! limit so that freezing does not push temperature above threshold
        3922    15671477 :                  dum = dumc(i,k)*xlf/cpp
        3923    15671477 :                  if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.233.15_r8) then
        3924           6 :                     dum = -(t(i,k)+tlat(i,k)/cpp*deltat-233.15_r8)*cpp/xlf
        3925           6 :                     dum = dum/dumc(i,k)
        3926           6 :                     dum = max(0._r8,dum)
        3927           6 :                     dum = min(1._r8,dum)
        3928             :                  else
        3929             :                     dum = 1._r8
        3930             :                  end if
        3931             :
        3932    15671477 :                  qitend(i,k)=qitend(i,k)+dum*dumc(i,k)*rdeltat
        3933             :                  ! for output
        3934    15671477 :                  proc_rates%homotot(i,k)=dum*dumc(i,k)*rdeltat
        3935             :
        3936             :                  ! assume 25 micron mean volume radius of homogeneously frozen droplets
        3937             :                  ! consistent with size of detrained ice in stratiform.F90
        3938    15671477 :                  proc_rates%nhomotot(i,k)=dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*micro_mg_homog_size**3._r8*500._r8)*rdeltat
        3939    15671477 :                  nitend(i,k)=nitend(i,k)+proc_rates%nhomotot(i,k)
        3940             :
        3941    15671477 :                  qctend(i,k)=((1._r8-dum)*dumc(i,k)-qc(i,k))*rdeltat
        3942    15671477 :                  nctend(i,k)=((1._r8-dum)*dumnc(i,k)-nc(i,k))*rdeltat
        3943    15671477 :                  tlat(i,k)=tlat(i,k)+xlf*dum*dumc(i,k)*rdeltat
        3944             :               end if
        3945             :            end if
        3946             :
        3947             :            ! ice number limiter
        3948  5890903200 :            if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.micro_mg_max_nicons*icldm(i,k)/rho(i,k)) then
        3949     7687780 :               nitend(i,k)=max(0._r8,(micro_mg_max_nicons*icldm(i,k)/rho(i,k)-ni(i,k))/deltat)
        3950             :            end if
        3951             :
        3952             :      ! remove any excess over-saturation, which is possible due to non-linearity when adding
        3953             :      ! together all microphysical processes
        3954             :      !-----------------------------------------------------------------
        3955             :      ! follow code similar to old CAM scheme
        3956             :
        3957  5890903200 :            dum_2D(i,k)=q(i,k)+qvlat(i,k)*deltat
        3958  6266175552 :            ttmpA(i,k)=t(i,k)+tlat(i,k)/cpp*deltat
        3959             :         end do
        3960             :      end do
        3961             :      !$acc end parallel
        3962             :
        3963             :      ! use rhw to allow ice supersaturation
        3964     4467528 :      call qsat_water(ttmpA, p, esnA, qvnA, mgncol*nlev)
        3965             :
        3966             :      !$acc parallel vector_length(VLENS) default(present)
        3967             :      !$acc loop gang vector collapse(2)
        3968   379739880 :      do k=1,nlev
        3969  6270643080 :         do i=1,mgncol
        3970  6266175552 :            if (dum_2D(i,k) > qvnA(i,k) .and. qvnA(i,k) > 0 .and. remove_supersat) then
        3971             :               ! expression below is approximate since there may be ice deposition
        3972           0 :               dum = (dum_2D(i,k)-qvnA(i,k))/(1._r8+xxlv_squared*qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))*rdeltat
        3973             :               ! add to output cme
        3974           0 :               cmeout(i,k) = cmeout(i,k)+dum
        3975             :               ! now add to tendencies, partition between liquid and ice based on temperature
        3976           0 :               if (ttmpA(i,k) > 268.15_r8) then
        3977           0 :                  dum1=0.0_r8
        3978             :                  ! now add to tendencies, partition between liquid and ice based on te
        3979             :                  !-------------------------------------------------------
        3980           0 :               else if (ttmpA(i,k) < 238.15_r8) then
        3981           0 :                  dum1=1.0_r8
        3982             :               else
        3983           0 :                  dum1=(268.15_r8-ttmpA(i,k))/30._r8
        3984             :               end if
        3985             :               dum = (dum_2D(i,k)-qvnA(i,k))/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 &
        3986           0 :                     *qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))*rdeltat
        3987           0 :               qctend(i,k)=qctend(i,k)+dum*(1._r8-dum1)
        3988             :               ! for output
        3989           0 :               proc_rates%qcrestot(i,k)=dum*(1._r8-dum1)
        3990           0 :               qitend(i,k)=qitend(i,k)+dum*dum1
        3991           0 :               proc_rates%qirestot(i,k)=dum*dum1
        3992           0 :               qvlat(i,k)=qvlat(i,k)-dum
        3993             :               ! for output
        3994           0 :               proc_rates%qvres(i,k)=-dum
        3995           0 :               tlat(i,k)=tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls
        3996             :            end if
        3997             :         end do
        3998             :      end do
        3999             :      !$acc end parallel
        4000             :   end if
        4001             :
        4002             :   ! calculate effective radius for pass to radiation code
        4003             :   !=========================================================
        4004             :   ! if no cloud water, default value is 10 micron for droplets,
        4005             :   ! 25 micron for cloud ice
        4006             :
        4007             :   ! update cloud variables after instantaneous processes to get effective radius
        4008             :   ! variables are in-cloud to calculate size dist parameters
        4009             :
        4010             :   !$acc parallel vector_length(VLENS) default(present)
        4011             :   !$acc loop gang vector collapse(2)
        4012   379739880 :   do k=1,nlev
        4013  6270643080 :      do i=1,mgncol
        4014  5890903200 :         dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)/lcldm(i,k)
        4015  5890903200 :         dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)/icldm(i,k)
        4016  5890903200 :         dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)/lcldm(i,k)
        4017  5890903200 :         dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)/icldm(i,k)
        4018             :
        4019  5890903200 :         dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)/precip_frac(i,k)
        4020  5890903200 :         dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)/precip_frac(i,k)
        4021  5890903200 :         dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8)/precip_frac(i,k)
        4022  5890903200 :         dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)/precip_frac(i,k)
        4023  5890903200 :         dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat,0._r8)
        4024  5890903200 :         dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat,0._r8)
        4025             :
        4026             :         ! switch for specification of droplet and crystal number
        4027  5890903200 :         if (nccons) then
        4028           0 :            dumnc(i,k)=ncnst/rho(i,k)
        4029             :         end if
        4030             :
        4031             :         ! switch for specification of cloud ice number
        4032  5890903200 :         if (nicons) then
        4033           0 :            dumni(i,k)=ninst/rho(i,k)
        4034             :         end if
        4035             :
        4036             :         ! switch for specification of graupel number
        4037  5890903200 :         if (ngcons) then
        4038           0 :            dumng(i,k)=ngnst/rho(i,k)*precip_frac(i,k)
        4039             :         end if
        4040             :
        4041             :         ! switch for specification of constant snow number
        4042  5890903200 :         if (nscons) then
        4043           0 :             dumns(i,k)=nsnst/rho(i,k)
        4044             :         end if
        4045             :
        4046             :         ! switch for specification of constant rain number
        4047  5890903200 :         if (nrcons) then
        4048           0 :             dumnr(i,k)=nrnst/rho(i,k)
        4049             :         end if
        4050             :
        4051             :         ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1
        4052  5890903200 :         dumc(i,k)=min(dumc(i,k),5.e-3_r8)
        4053  5890903200 :         dumi(i,k)=min(dumi(i,k),5.e-3_r8)
        4054             :         ! limit in-precip mixing ratios
        4055  5890903200 :         dumr(i,k)=min(dumr(i,k),10.e-3_r8)
        4056  5890903200 :         dums(i,k)=min(dums(i,k),10.e-3_r8)
        4057  6266175552 :         dumg(i,k)=min(dumg(i,k),10.e-3_r8)
        4058             :      end do
        4059             :   end do
        4060             :   !$acc end parallel
        4061             :
        4062             :   ! cloud ice effective radius
        4063             :   !-----------------------------------------------------------------
        4064     4467528 :   if (do_cldice) then
        4065             :      !$acc parallel vector_length(VLENS) default(present)
        4066             :      !$acc loop gang vector collapse(2)
        4067   379739880 :      do k=1,nlev
        4068  6270643080 :         do i=1,mgncol
        4069  6266175552 :            dum_2D(i,k) = dumni(i,k)
        4070             :         end do
        4071             :      end do
        4072             :      !$acc end parallel
        4073             :
        4074     4467528 :      call size_dist_param_basic(mg_ice_props, dumi, dumni, lami, mgncol, nlev, n0=dumni0A2D)
        4075             :
        4076             :      !$acc parallel vector_length(VLENS) default(present)
        4077             :      !$acc loop gang vector collapse(2)
        4078   379739880 :      do k=1,nlev
        4079  6270643080 :         do i=1,mgncol
        4080  5890903200 :            if (dumi(i,k).ge.qsmall) then
        4081  1789185940 :               if (dumni(i,k) /=dum_2D(i,k)) then
        4082             :                  ! adjust number conc if needed to keep mean size in reasonable range
        4083   191633618 :                  nitend(i,k)=(dumni(i,k)*icldm(i,k)-ni(i,k))*rdeltat
        4084             :               end if
        4085  1789185940 :               effi(i,k)   = 1.5_r8/lami(i,k)*1.e6_r8
        4086  1789185940 :               effi(i,k)   = effi(i,k)*micro_mg_effi_factor
        4087             :
        4088  1789185940 :               sadice(i,k) = 2._r8*pi*(lami(i,k)**(-3))*dumni0A2D(i,k)*rho(i,k)*1.e-2_r8  ! m2/m3 -> cm2/cm3
        4089             :            else
        4090  4101717260 :               effi(i,k)   = 25._r8
        4091  4101717260 :               effi(i,k)   = effi(i,k)*micro_mg_effi_factor
        4092             :
        4093  4101717260 :               sadice(i,k) = 0._r8
        4094             :            end if
        4095             :            ! ice effective diameter for david mitchell's optics
        4096  6266175552 :            deffi(i,k)=effi(i,k)*rhoi/rhows*2._r8
        4097             :         end do
        4098             :      end do
        4099             :      !$acc end parallel
        4100             :   else
        4101             :      !$acc parallel vector_length(VLENS) default(present)
        4102             :      !acc loop gang vector collapse(2)
        4103           0 :      do k=1,nlev
        4104           0 :         do i=1,mgncol
        4105             :            ! NOTE: If CARMA is doing the ice microphysics, then the ice effective
        4106             :            ! radius has already been determined from the size distribution.
        4107           0 :            effi(i,k)   = re_ice(i,k) * 1.e6_r8      ! m -> um
        4108           0 :            effi(i,k)   = effi(i,k)*micro_mg_effi_factor
        4109             :
        4110           0 :            deffi(i,k)  = effi(i,k) * 2._r8
        4111           0 :            sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8
        4112             :         end do
        4113             :      end do
        4114             :      !$acc end parallel
        4115             :   end if
        4116             :
        4117             :   ! cloud droplet effective radius
        4118             :   !-----------------------------------------------------------------
        4119             :
        4120             :   !$acc parallel vector_length(VLENS) default(present)
        4121             :   !$acc loop gang vector collapse(2)
        4122   379739880 :   do k=1,nlev
        4123  6270643080 :      do i=1,mgncol
        4124  6266175552 :         dum_2D(i,k) = dumnc(i,k)
        4125             :      end do
        4126             :   end do
        4127             :   !$acc end parallel
        4128             :
        4129     4467528 :   call size_dist_param_liq(mg_liq_props, dumc, dumnc, rho, pgam, lamc, mgncol, nlev)
        4130             :
        4131             :   !$acc parallel vector_length(VLENS) default(present)
        4132             :   !$acc loop gang vector collapse(2)
        4133   379739880 :   do k=1,nlev
        4134  6270643080 :      do i=1,mgncol
        4135  6266175552 :         if (dumc(i,k).ge.qsmall) then
        4136             :            ! switch for specification of droplet and crystal number
        4137   699718963 :            if (nccons) then
        4138             :               ! make sure nc is consistence with the constant N by adjusting tendency, need
        4139             :               ! to multiply by cloud fraction
        4140             :               ! note that nctend may be further adjusted below if mean droplet size is
        4141             :               ! out of bounds
        4142           0 :               nctend(i,k)=(ncnst/rho(i,k)*lcldm(i,k)-nc(i,k))*rdeltat
        4143             :            end if
        4144   699718963 :            if (dum_2D(i,k) /= dumnc(i,k)) then
        4145             :               ! adjust number conc if needed to keep mean size in reasonable range
        4146   104796758 :               nctend(i,k)=(dumnc(i,k)*lcldm(i,k)-nc(i,k))*rdeltat
        4147             :            end if
        4148             :
        4149   699718963 :            effc(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8
        4150             :            !assign output fields for shape here
        4151   699718963 :            lamcrad(i,k)=lamc(i,k)
        4152   699718963 :            pgamrad(i,k)=pgam(i,k)
        4153             :
        4154             :            ! recalculate effective radius for constant number, in order to separate
        4155             :            ! first and second indirect effects
        4156             :            !======================================
        4157             :            ! assume constant number of 10^8 kg-1
        4158   699718963 :            dumnc(i,k)=1.e8_r8
        4159             :         end if
        4160             :      end do
        4161             :   end do
        4162             :   !$acc end parallel
        4163             :
        4164             :   ! Pass in "false" adjust flag to prevent number from being changed within
        4165             :   ! size distribution subroutine.
        4166     4467528 :   call size_dist_param_liq(mg_liq_props, dumc, dumnc, rho, pgam, lamc, mgncol, nlev)
        4167             :
        4168             :   !$acc parallel vector_length(VLENS) default(present)
        4169             :   !$acc loop gang vector collapse(2)
        4170   379739880 :   do k =1,nlev
        4171  6270643080 :      do i=1,mgncol
        4172  5890903200 :         if (dumc(i,k).ge.qsmall) then
        4173   699718963 :            effc_fn(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8
        4174             :         else
        4175  5191184237 :            effc(i,k) = 10._r8
        4176  5191184237 :            lamcrad(i,k)=0._r8
        4177  5191184237 :            pgamrad(i,k)=0._r8
        4178  5191184237 :            effc_fn(i,k) = 10._r8
        4179             :         end if
        4180             :
        4181             :         ! recalculate 'final' rain size distribution parameters
        4182             :         ! to ensure that rain size is in bounds, adjust rain number if needed
        4183  6266175552 :         dum_2D(i,k) = dumnr(i,k)
        4184             :      end do
        4185             :   end do
        4186             :   !$acc end parallel
        4187             :
        4188     4467528 :   call size_dist_param_basic(mg_rain_props, dumr, dumnr, lamr, mgncol, nlev, n0=n0r)
        4189             :
        4190             :   !$acc parallel vector_length(VLENS) default(present)
        4191             :   !$acc loop gang vector collapse(2)
        4192   379739880 :   do k=1,nlev
        4193  6270643080 :      do i=1,mgncol
        4194  5890903200 :         if (dumr(i,k).ge.qsmall) then
        4195  1323665688 :            if (dum_2D(i,k) /= dumnr(i,k)) then
        4196             :               ! adjust number conc if needed to keep mean size in reasonable range
        4197   428653196 :               nrtend(i,k)=(dumnr(i,k)*precip_frac(i,k)-nr(i,k))*rdeltat
        4198             :            end if
        4199             :
        4200             :         end if
        4201             :
        4202             :         ! recalculate 'final' snow size distribution parameters
        4203             :         ! to ensure that snow size is in bounds, adjust snow number if needed
        4204  6266175552 :         dum_2D(i,k) = dumns(i,k)
        4205             :      end do
        4206             :   end do
        4207             :   !$acc end parallel
        4208             :
        4209     4467528 :   call size_dist_param_basic(mg_snow_props, dums, dumns, lams, mgncol, nlev, n0=dumns0A2D)
        4210             :
        4211             :   !$acc parallel vector_length(VLENS) default(present)
        4212             :   !$acc loop gang vector collapse(2)
        4213   379739880 :   do k=1,nlev
        4214  6270643080 :      do i=1,mgncol
        4215  5890903200 :         if (dums(i,k).ge.qsmall) then
        4216             :
        4217  1536610668 :            if (dum_2D(i,k) /= dumns(i,k)) then
        4218             :               ! adjust number conc if needed to keep mean size in reasonable range
        4219   108590278 :               nstend(i,k)=(dumns(i,k)*precip_frac(i,k)-ns(i,k))*rdeltat
        4220             :            end if
        4221             :
        4222  1536610668 :            sadsnow(i,k) = 2._r8*pi*(lams(i,k)**(-3))*dumns0A2D(i,k)*rho(i,k)*1.e-2_r8  ! m2/m3 -> cm2/cm3
        4223             :
        4224             :         end if
        4225             :
        4226             :         ! recalculate 'final' graupel size distribution parameters
        4227             :         ! to ensure that  size is in bounds, addjust number if needed
        4228  6266175552 :         dum_2D(i,k) = dumng(i,k)
        4229             :      end do
        4230             :   end do
        4231             :   !$acc end parallel
        4232             :
        4233     4467528 :   if (do_hail) then
        4234           0 :      call size_dist_param_basic(mg_hail_props, dumg, dumng, lamg, mgncol, nlev)
        4235             :   end if
        4236     4467528 :   if (do_graupel) then
        4237     4467528 :      call size_dist_param_basic(mg_graupel_props, dumg, dumng, lamg, mgncol, nlev)
        4238             :   end if
        4239             :
        4240             :   !$acc parallel vector_length(VLENS) default(present)
        4241             :   !$acc loop gang vector collapse(2)
        4242   379739880 :   do k=1,nlev
        4243  6270643080 :      do i=1,mgncol
        4244  5890903200 :         if (dumg(i,k).ge.qsmall) then
        4245   429982127 :            if (dum_2D(i,k) /= dumng(i,k)) then
        4246             :               ! adjust number conc if needed to keep mean size in reasonable range
        4247    92301145 :               ngtend(i,k)=(dumng(i,k)*precip_frac(i,k)-ng(i,k))*rdeltat
        4248             :            end if
        4249             :         end if
        4250             :
        4251             :         ! if updated q (after microphysics) is zero, then ensure updated n is also zero
        4252             :         !=================================================================================
        4253  5890903200 :         if (qc(i,k)+qctend(i,k)*deltat.lt.qsmall) nctend(i,k)=-nc(i,k)*rdeltat
        4254  5890903200 :         if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat.lt.qsmall) nitend(i,k)=-ni(i,k)*rdeltat
        4255  5890903200 :         if (qr(i,k)+qrtend(i,k)*deltat.lt.qsmall) nrtend(i,k)=-nr(i,k)*rdeltat
        4256  5890903200 :         if (qs(i,k)+qstend(i,k)*deltat.lt.qsmall) nstend(i,k)=-ns(i,k)*rdeltat
        4257  5890903200 :         if (qg(i,k)+qgtend(i,k)*deltat.lt.qsmall) ngtend(i,k)=-ng(i,k)*rdeltat
        4258             :
        4259             :   ! DO STUFF FOR OUTPUT:
        4260             :   !==================================================
        4261             :   ! qc and qi are only used for output calculations past here,
        4262             :   ! so add qctend and qitend back in one more time
        4263             :
        4264  5890903200 :         qc(i,k) = qc(i,k) + qctend(i,k)*deltat
        4265  5890903200 :         qi(i,k) = qi(i,k) + qitend(i,k)*deltat
        4266             :
        4267             :   ! averaging for snow and rain number and diameter
        4268             :   !--------------------------------------------------
        4269             :   ! drout2/dsout2:
        4270             :   ! diameter of rain and snow
        4271             :   ! dsout:
        4272             :   ! scaled diameter of snow (passed to radiation in CAM)
        4273             :   ! reff_rain/reff_snow:
        4274             :   ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual
        4275             :
        4276             :         ! avoid divide by zero in avg_diameter_vec
        4277  6266175552 :         if (nrout(i,k) .eq. 0._r8) nrout(i,k)=1.e-34_r8
        4278             :      end do
        4279             :   end do
        4280             :   !$acc end parallel
        4281             :
        4282             :   ! The avg_diameter_vec call does the actual calculation; other diameter
        4283             :   ! outputs are just drout2 times constants.
        4284     4467528 :   call avg_diameter_vec(qrout,nrout,rho,rhow,drout2,mgncol*nlev)
        4285             :
        4286             :   !$acc parallel vector_length(VLENS) default(present)
        4287             :   !$acc loop gang vector collapse(2)
        4288   379739880 :   do k=1,nlev
        4289  6270643080 :      do i=1,mgncol
        4290  5890903200 :         if (qrout(i,k) .gt. 1.e-7_r8 .and. nrout(i,k) .gt. 0._r8) then
        4291   675875180 :            qrout2(i,k) = qrout(i,k) * precip_frac(i,k)
        4292   675875180 :            nrout2(i,k) = nrout(i,k) * precip_frac(i,k)
        4293   675875180 :            freqr(i,k) = precip_frac(i,k)
        4294   675875180 :            reff_rain(i,k)=1.5_r8*drout2(i,k)*1.e6_r8
        4295             :         else
        4296  5215028020 :            qrout2(i,k) = 0._r8
        4297  5215028020 :            nrout2(i,k) = 0._r8
        4298  5215028020 :            drout2(i,k) = 0._r8
        4299  5215028020 :            freqr(i,k) = 0._r8
        4300  5215028020 :            reff_rain(i,k) = 0._r8
        4301             :         end if
        4302             :
        4303             :         ! avoid divide by zero in avg_diameter_vec
        4304  6266175552 :         if (nsout(i,k) .eq. 0._r8) nsout(i,k) = 1.e-34_r8
        4305             :      end do
        4306             :   end do
        4307             :   !$acc end parallel
        4308             :
        4309             :   ! The avg_diameter_vec call does the actual calculation; other diameter
        4310             :   ! outputs are just dsout2 times constants.
        4311     4467528 :   call avg_diameter_vec(qsout, nsout, rho, rhosn,dsout2,mgncol*nlev)
        4312             :
        4313             :   !$acc parallel vector_length(VLENS) default(present)
        4314             :   !$acc loop gang vector collapse(2)
        4315   379739880 :   do k=1,nlev
        4316  6270643080 :      do i=1,mgncol
        4317  5890903200 :         if (qsout(i,k) .gt. 1.e-7_r8 .and. nsout(i,k) .gt. 0._r8) then
        4318   609250130 :            qsout2(i,k) = qsout(i,k) * precip_frac(i,k)
        4319   609250130 :            nsout2(i,k) = nsout(i,k) * precip_frac(i,k)
        4320   609250130 :            freqs(i,k) = precip_frac(i,k)
        4321   609250130 :            dsout(i,k)=3._r8*rhosn/rhows*dsout2(i,k)
        4322   609250130 :            reff_snow(i,k)=1.5_r8*dsout2(i,k)*1.e6_r8
        4323             :         else
        4324  5281653070 :            dsout(i,k)  = 0._r8
        4325  5281653070 :            qsout2(i,k) = 0._r8
        4326  5281653070 :            nsout2(i,k) = 0._r8
        4327  5281653070 :            dsout2(i,k) = 0._r8
        4328  5281653070 :            freqs(i,k)  = 0._r8
        4329  5281653070 :            reff_snow(i,k)=0._r8
        4330             :         end if
        4331             :
        4332             :         ! avoid divide by zero in avg_diameter_vec
        4333  6266175552 :         if (ngout(i,k) .eq. 0._r8) ngout(i,k) = 1.e-34_r8
        4334             :      end do
        4335             :   end do
        4336             :   !$acc end parallel
        4337             :
        4338             :   ! The avg_diameter_vec call does the actual calculation; other diameter
        4339             :   ! outputs are just dgout2 times constants.
        4340     4467528 :   if (do_hail .or. do_graupel) then
        4341     4467528 :      call avg_diameter_vec(qgout, ngout, rho, rhogtmp, dgout2, mgncol*nlev)
        4342             :   else
        4343             :      ! need this if statement for MG2, where rhogtmp = 0
        4344             :
        4345             :      !$acc parallel vector_length(VLENS) default(present)
        4346             :      !$acc loop gang vector collapse(2)
        4347           0 :      do k=1,nlev
        4348           0 :         do i=1,mgncol
        4349           0 :            dgout2(i,k) = 0._r8
        4350             :         end do
        4351             :      end do
        4352             :      !$acc end parallel
        4353             :   end if
        4354             :
        4355             :   !$acc parallel vector_length(VLENS) default(present)
        4356             :   !$acc loop gang vector collapse(2)
        4357   379739880 :   do k=1,nlev
        4358  6270643080 :      do i=1,mgncol
        4359  6266175552 :         if (qgout(i,k) .gt. 1.e-7_r8 .and. ngout(i,k) .gt. 0._r8) then
        4360    42838400 :            qgout2(i,k) = qgout(i,k) * precip_frac(i,k)
        4361    42838400 :            ngout2(i,k) = ngout(i,k) * precip_frac(i,k)
        4362    42838400 :            freqg(i,k) = precip_frac(i,k)
        4363    42838400 :            dgout(i,k)=3._r8*rhogtmp/rhows*dgout2(i,k)
        4364    42838400 :            reff_grau(i,k)=1.5_r8*dgout2(i,k)*1.e6_r8
        4365             :         else
        4366  5848064800 :            dgout(i,k)  = 0._r8
        4367  5848064800 :            qgout2(i,k) = 0._r8
        4368  5848064800 :            ngout2(i,k) = 0._r8
        4369  5848064800 :            dgout2(i,k) = 0._r8
        4370  5848064800 :            freqg(i,k)  = 0._r8
        4371  5848064800 :            reff_grau(i,k)=0._r8
        4372             :         end if
        4373             :      end do
        4374             :   end do
        4375             :   !$acc end parallel
        4376             :
        4377             :   ! analytic radar reflectivity
        4378             :   !--------------------------------------------------
        4379             :   ! formulas from Matthew Shupe, NOAA/CERES
        4380             :   ! *****note: radar reflectivity is local (in-precip average)
        4381             :   ! units of mm^6/m^3
        4382             :
        4383             :   ! Min rain rate of 0.1 mm/hr
        4384             :   rthrsh=0.0001_r8/3600._r8
        4385             :
        4386             :   !$acc parallel vector_length(VLENS) default(present)
        4387             :   !$acc loop gang vector collapse(2)
        4388   379739880 :   do k=1,nlev
        4389  6270643080 :      do i=1,mgncol
        4390  5890903200 :         if (qc(i,k).ge.qsmall .and. (nc(i,k)+nctend(i,k)*deltat).gt.10._r8) then
        4391             :            dum=(qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 &
        4392   436572438 :                 /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k)
        4393             :         else
        4394             :            dum=0._r8
        4395             :         end if
        4396  5890903200 :         if (qi(i,k).ge.qsmall) then
        4397  1075293880 :            dum1=(qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)*icldm(i,k)/precip_frac(i,k)
        4398             :         else
        4399  4815609320 :            dum1=0._r8
        4400             :         end if
        4401  5890903200 :         if (qsout(i,k).ge.qsmall) then
        4402  1416430442 :            dum1=dum1+(qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)
        4403             :         end if
        4404  5890903200 :         refl(i,k)=dum+dum1
        4405             :
        4406             :         ! add rain to reflectivity (rain rate in mm/hr)
        4407             :         ! reflectivity (dum) is in DBz
        4408             :         ! New version Aircraft cloud values
        4409             :         !Z=a*R^b (R in mm/hr) from Comstock et al 2004
        4410             :
        4411  5890903200 :         if (rflx(i,k+1).ge.rthrsh) then
        4412   737808468 :            dum=32._r8*(rflx(i,k+1)*3600._r8)**1.4_r8
        4413             :         else
        4414             :            ! don't include rain rate in R calculation for values less than 0.001 mm/hr
        4415             :            dum=0._r8
        4416             :         end if
        4417             :
        4418             :         ! add to refl
        4419  5890903200 :         refl(i,k)=refl(i,k)+dum
        4420             :
        4421             :         !output reflectivity in Z.
        4422  5890903200 :         areflz(i,k)=refl(i,k) * precip_frac(i,k)
        4423             :
        4424             :         ! convert back to DBz
        4425  5890903200 :         if (refl(i,k).gt.minrefl) then
        4426  1802126771 :            refl(i,k)=10._r8*dlog10(refl(i,k))
        4427             :         else
        4428  4088776429 :            refl(i,k)=-9999._r8
        4429             :         end if
        4430             :
        4431             :         !set averaging flag
        4432  5890903200 :         if (refl(i,k).gt.mindbz) then
        4433  1802126771 :            arefl(i,k)=refl(i,k) * precip_frac(i,k)
        4434  1802126771 :            frefl(i,k)=precip_frac(i,k)
        4435             :         else
        4436  4088776429 :            arefl(i,k)=0._r8
        4437  4088776429 :            areflz(i,k)=0._r8
        4438  4088776429 :            frefl(i,k)=0._r8
        4439             :         end if
        4440             :
        4441             :         ! bound cloudsat reflectivity
        4442  5890903200 :         csrfl(i,k)=min(csmax,refl(i,k))
        4443             :
        4444             :         !set averaging flag
        4445  6266175552 :         if (csrfl(i,k).gt.csmin) then
        4446  1297813884 :            acsrfl(i,k)=refl(i,k) * precip_frac(i,k)
        4447  1297813884 :            fcsrfl(i,k)=precip_frac(i,k)
        4448             :         else
        4449  4593089316 :            acsrfl(i,k)=0._r8
        4450  4593089316 :            fcsrfl(i,k)=0._r8
        4451             :         end if
        4452             :      end do
        4453             :   end do
        4454             :   !$acc end parallel
        4455             :
        4456             :   ! 10cm analytic radar reflectivity (rain radar)
        4457             :   !--------------------------------------------------
        4458             :   ! Formula from Hugh Morrison
        4459             :   ! Ice dielectric correction from Smith 1984, Equation  10 and Snow correction from Smith 1984 Equation 14
        4460             :   ! Smith, Paul L. “Equivalent Radar Reflectivity Factors for Snow and Ice Particles.
        4461             :   !                ” Journal of Climate and Applied Meteorology 23, no. 8 (1984): 1258–60.
        4462             :   !                DOI:  10.1175/1520-0450(1984)023<1258:ERRFFS>2.0.CO;2
        4463             :
        4464             :   ! *****note: radar reflectivity is local (in-precip average)
        4465             :   ! units of mm^6/m^3
        4466             :
        4467             :   !$acc parallel vector_length(VLENS) default(present)
        4468             :   !$acc loop gang vector collapse(2)
        4469   379739880 :   do k=1,nlev
        4470  6270643080 :      do i=1,mgncol
        4471             :
        4472  5890903200 :         dum1  = minrefl10
        4473  5890903200 :         dum2  = minrefl10
        4474  5890903200 :         dum3  = minrefl10
        4475  5890903200 :         dum4  = minrefl10
        4476  5890903200 :         dum   = minrefl10
        4477             :
        4478             : !     Rain
        4479  5890903200 :         if (lamr(i,k) > 0._r8) then
        4480  1323665688 :            dum1 = rho(i,k)*n0r(i,k)*720._r8/lamr(i,k)**3/lamr(i,k)**3/lamr(i,k)
        4481  1323665688 :            dum1 = max(dum1,minrefl10)
        4482             :         end if
        4483             :
        4484             : !     Ice
        4485             :         !  Add diaelectric factor from Smith 1984 equation 10
        4486  5890903200 :         if (lami(i,k) > 0._r8) then
        4487  1789185940 :            dum2= rho(i,k)*(0.176_r8/0.93_r8) * 720._r8*dumni0A2D(i,k)*(rhoi/900._r8)**2/lami(i,k)**7
        4488  1789185940 :            dum2 = max(dum2,minrefl10)
        4489             :         endif
        4490             :
        4491             : !     Snow
        4492  5890903200 :         if (lams(i,k) > 0._r8) then
        4493  1536610668 :            dum3= rho(i,k)*(0.176_r8/0.93_r8) * 720._r8*dumns0A2D(i,k)*(rhosn/900._r8)**2/lams(i,k)**7._r8
        4494  1536610668 :            dum3 = max(dum3,minrefl10)
        4495             :         endif
        4496             :
        4497             : !     Graupel
        4498  5890903200 :         if (do_hail .or. do_graupel .and. lamg(i,k) > 0._r8) then
        4499   429982127 :           dum4= rho(i,k)*(0.176_r8/0.93_r8) * 720._r8*n0g(i,k)*(rhogtmp/900._r8)**2/lamg(i,k)**7._r8
        4500   429982127 :           dum4 =max(dum4,minrefl10)
        4501             :         end if
        4502             :
        4503  5890903200 :         reflz10cm(i,k) = (dum1+dum2+dum3+dum4) * precip_frac(i,k)
        4504             :
        4505             :   ! Convert to dBz....
        4506             :
        4507  5890903200 :         dum = reflz10cm(i,k)*1.e18_r8
        4508  5890903200 :         refl10cm(i,k) = 10._r8*dlog10(dum)
        4509             :
        4510             :   !redefine fice here....
        4511             :
        4512  5890903200 :         dum_2D(i,k) = qsout(i,k) + qrout(i,k) + qc(i,k) + qi(i,k)
        4513  5890903200 :         dumi(i,k)   = qsout(i,k) + qi(i,k)
        4514  6266175552 :         if (dumi(i,k) .gt. qsmall .and. dum_2D(i,k) .gt. qsmall) then
        4515  1498924183 :            nfice(i,k) = min(dumi(i,k)/dum_2D(i,k),1._r8)
        4516             :         else
        4517  4391979017 :            nfice(i,k) = 0._r8
        4518             :         end if
        4519             :
        4520             :      end do
        4521             :   end do
        4522             :   !$acc end parallel
        4523             :
        4524             :   !$acc end data
        4525             :
        4526     4467528 : end subroutine micro_pumas_tend
        4527             :
        4528             : !========================================================================
        4529             : !OUTPUT CALCULATIONS
        4530             : !========================================================================
        4531             :
        4532     4467528 : subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, vlen)
        4533             :   integer,                   intent(in) :: vlen
        4534             :   real(r8), dimension(vlen), intent(in) :: lamr          ! rain size parameter (slope)
        4535             :   real(r8), dimension(vlen), intent(in) :: n0r           ! rain size parameter (intercept)
        4536             :   real(r8), dimension(vlen), intent(in) :: lamc          ! size distribution parameter (slope)
        4537             :   real(r8), dimension(vlen), intent(in) :: pgam          ! droplet size parameter
        4538             :   real(r8), dimension(vlen), intent(in) :: qric          ! in-cloud rain mass mixing ratio
        4539             :   real(r8), dimension(vlen), intent(in) :: qcic          ! in-cloud cloud liquid
        4540             :   real(r8), dimension(vlen), intent(in) :: ncic          ! in-cloud droplet number concentration
        4541             :
        4542             :   real(r8), dimension(vlen), intent(inout) :: rercld     ! effective radius calculation for rain + cloud
        4543             :
        4544             :   ! combined size of precip & cloud drops
        4545     8935056 :   real(r8) :: Atmp,tmp(vlen), pgamp1(vlen)
        4546             :
        4547             :   integer :: i
        4548             :
        4549             :   !$acc data create (tmp,pgamp1)
        4550             :
        4551             :   !$acc parallel vector_length(VLENS) default(present)
        4552             :   !$acc loop gang vector
        4553  5895370728 :   do i=1,vlen
        4554  5895370728 :      pgamp1(i) = pgam(i)+1._r8
        4555             :   end do
        4556             :   !$acc end parallel
        4557             :
        4558     4467528 :   call rising_factorial(pgamp1, 2, tmp, vlen)
        4559             :
        4560             :   !$acc parallel vector_length(VLENS) default(present)
        4561             :   !$acc loop gang vector
        4562  5895370728 :   do i=1,vlen
        4563             :      ! Rain drops
        4564  5890903200 :      if (lamr(i) > 0._r8) then
        4565  1434950401 :         Atmp = n0r(i) * pi / (2._r8 * lamr(i)**3._r8)
        4566             :      else
        4567             :         Atmp = 0._r8
        4568             :      end if
        4569             :      ! Add cloud drops
        4570  5890903200 :      if (lamc(i) > 0._r8) then
        4571             :         Atmp = Atmp + &
        4572   512413729 :              ncic(i) * pi * tmp(i) / (4._r8 * lamc(i)**2._r8)
        4573             :      end if
        4574  5895370728 :      if (Atmp > 0._r8) then
        4575  1447332558 :         rercld(i) = rercld(i) + 3._r8 *(qric(i) + qcic(i)) / (4._r8 * rhow * Atmp)
        4576             :      end if
        4577             :   end do
        4578             :   !$acc end parallel
        4579             :
        4580             :   !$acc end data
        4581     4467528 : end subroutine calc_rercld
        4582             :
        4583             : !========================================================================
        4584             : !2020-09-15: Follow John Dennis's version to generate a new interface
        4585             : !            to update tendency in the sedimentation loop;
        4586             : !2021-10-19: Separate the mass and ice sediment for each class;
        4587             : !========================================================================
        4588           0 : subroutine Sedimentation(mgncol,nlev,do_cldice,deltat,nstep,rnstep,fx,dumx,pdel_inv, &
        4589           0 :                          xxtend,queue,qxsedten,prect,xflx,xxlx,qxsevap,tlat,qvlat,xcldm,preci)
        4590             :
        4591             :    integer, intent(in)               :: mgncol,nlev
        4592             :    logical, intent(in)               :: do_cldice
        4593             :    real(r8),intent(in)               :: deltat
        4594             :    integer, intent(in)               :: nstep(mgncol)
        4595             :    real(r8), intent(in)              :: rnstep(mgncol)
        4596             :    real(r8), intent(in)              :: fx(mgncol,nlev)
        4597             :    real(r8), intent(inout)           :: dumx(mgncol,nlev)
        4598             :    real(r8), intent(in)              :: pdel_inv(mgncol,nlev)
        4599             :    real(r8), intent(inout)           :: xxtend(mgncol,nlev)
        4600             :    integer, intent(in)               :: queue
        4601             :    real(r8), intent(inout), optional :: qxsedten(mgncol,nlev)
        4602             :    real(r8), intent(inout), optional :: prect(mgncol)
        4603             :    real(r8), intent(inout), optional :: xflx(mgncol,nlev+1)
        4604             :    real(r8), intent(in)   , optional :: xxlx
        4605             :    real(r8), intent(inout), optional :: qxsevap(mgncol,nlev)
        4606             :    real(r8), intent(in)   , optional :: xcldm(mgncol,nlev)
        4607             :    real(r8), intent(inout), optional :: tlat(mgncol,nlev)
        4608             :    real(r8), intent(inout), optional :: qvlat(mgncol,nlev)
        4609             :    real(r8), intent(inout), optional :: preci(mgncol)
        4610             :
        4611             :    ! local variables
        4612             :    integer  :: i,k,n,nstepmax
        4613             :    real(r8) :: faltndx,rnstepmax,faltndqxe
        4614           0 :    real(r8) :: dum1(mgncol,nlev),faloutx(mgncol,0:nlev)
        4615             :    logical  :: present_tlat, present_qvlat, present_xcldm, present_qxsevap, &
        4616             :                present_prect, present_preci, present_qxsedten, present_xflx
        4617             :
        4618           0 :    present_tlat     = present(tlat)
        4619           0 :    present_qvlat    = present(qvlat)
        4620           0 :    present_xcldm    = present(xcldm)
        4621           0 :    present_qxsevap  = present(qxsevap)
        4622           0 :    present_preci    = present(preci)
        4623           0 :    present_prect    = present(prect)
        4624           0 :    present_qxsedten = present(qxsedten)
        4625           0 :    present_xflx     = present(xflx)
        4626             :
        4627             :    ! loop over sedimentation sub-time step to ensure stability
        4628             :    !==============================================================
        4629             :
        4630             :    !$acc enter data create (faloutx,dum1) async(queue)
        4631             :
        4632             :    !$acc parallel vector_length(VLENS) default(present) async(queue)
        4633             :    !$acc loop gang vector
        4634           0 :    do i = 1,mgncol
        4635           0 :       nstepmax = nstep(i)
        4636           0 :       rnstepmax = rnstep(i)
        4637             :
        4638           0 :       dum1(i,1) = 0._r8
        4639           0 :       if (present_xcldm) then
        4640           0 :          do k = 2,nlev
        4641           0 :             dum1(i,k) = xcldm(i,k)/xcldm(i,k-1)
        4642           0 :             dum1(i,k) = min(dum1(i,k),1._r8)
        4643             :          end do
        4644             :       else
        4645           0 :          do k=2,nlev
        4646           0 :             dum1(i,k) = 1._r8
        4647             :          end do
        4648             :       end if
        4649             :
        4650             :       !$acc loop seq
        4651           0 :       do n = 1,nstepmax
        4652           0 :          faloutx(i,0)  = 0._r8
        4653           0 :          if (do_cldice) then
        4654           0 :             do k=1,nlev
        4655           0 :                faloutx(i,k)  = fx(i,k)  * dumx(i,k)
        4656             :             end do
        4657             :          else
        4658           0 :             do k=1,nlev
        4659           0 :                faloutx(i,k)  = 0._r8
        4660             :             end do
        4661             :          end if
        4662             :
        4663           0 :          do k = 1,nlev
        4664             :             ! for cloud liquid and ice, if cloud fraction increases with height
        4665             :             ! then add flux from above to both vapor and cloud water of current level
        4666             :             ! this means that flux entering clear portion of cell from above evaporates
        4667             :             ! instantly
        4668             :             ! note: this is not an issue with precip, since we assume max overlap
        4669           0 :             faltndx = (faloutx(i,k) - dum1(i,k) * faloutx(i,k-1)) * pdel_inv(i,k)
        4670             :             ! add fallout terms to eulerian tendencies
        4671           0 :             xxtend(i,k) = xxtend(i,k) - faltndx * rnstepmax
        4672             :             ! sedimentation tendency for output
        4673           0 :             if (present_qxsedten) qxsedten(i,k) = qxsedten(i,k)-faltndx*rnstepmax
        4674             :             ! add terms to to evap/sub of cloud water
        4675           0 :             dumx(i,k) = dumx(i,k) - faltndx*deltat*rnstepmax
        4676             :
        4677           0 :             if (k>1) then
        4678           0 :                if (present_qxsevap .or. present_qvlat .or. present_tlat) then
        4679           0 :                   faltndqxe = (faloutx(i,k)-faloutx(i,k-1))*pdel_inv(i,k)
        4680             :                   ! for output
        4681           0 :                   if (present_qxsevap) qxsevap(i,k) = qxsevap(i,k) - (faltndqxe-faltndx)*rnstepmax
        4682           0 :                   if (present_qvlat) qvlat(i,k) = qvlat(i,k) - (faltndqxe-faltndx)*rnstepmax
        4683           0 :                   if (present_tlat) tlat(i,k) = tlat(i,k) + (faltndqxe-faltndx)*xxlx*rnstepmax
        4684             :                end if
        4685             :             end if
        4686             :
        4687           0 :             if (present_xflx) xflx(i,k+1) = xflx(i,k+1) + faloutx(i,k) / g * rnstepmax
        4688             :          end do
        4689             :
        4690             :          ! units below are m/s
        4691             :          ! sedimentation flux at surface is added to precip flux at surface
        4692             :          ! to get total precip (cloud + precip water) rate
        4693           0 :          if (present_prect) prect(i) = prect(i) + faloutx(i,nlev) / g * rnstepmax / 1000._r8
        4694           0 :          if (present_preci) preci(i) = preci(i) + faloutx(i,nlev) / g * rnstepmax / 1000._r8
        4695             :       end do  ! n loop of 1, nstep
        4696             :    end do  ! i loop of 1, mgncol
        4697             :    !$acc end parallel
        4698             :
        4699             :    !$acc exit data delete(faloutx,dum1) async(queue)
        4700           0 : end subroutine Sedimentation
        4701             :
        4702             : !========================================================================
        4703             : !2021-10-19: Add a new interface for the implicit sedimentation calculation;
        4704             : !            Separate number/mass sediment for each class;
        4705             : !========================================================================
        4706    89350560 : subroutine Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumx,fx,check_qsmall, &
        4707   102753144 :                                   xxtend,queue,xflx,qxsedten,prect,preci)
        4708             :
        4709             :    integer,  intent(in)              :: mgncol,nlev
        4710             :    real(r8), intent(in)              :: deltat
        4711             :    real(r8), intent(in)              :: zint(mgncol,nlev+1)
        4712             :    real(r8), intent(in)              :: pdel(mgncol,nlev)
        4713             :    real(r8), intent(in)              :: dumx(mgncol,nlev)
        4714             :    real(r8), intent(in)              :: fx(mgncol,nlev)
        4715             :    logical,  intent(in)              :: check_qsmall
        4716             :    real(r8), intent(inout)           :: xxtend(mgncol,nlev)
        4717             :    integer,  intent(in)              :: queue
        4718             :    real(r8), intent(inout), optional :: xflx(mgncol,nlev+1)
        4719             :    real(r8), intent(inout), optional :: qxsedten(mgncol,nlev)
        4720             :    real(r8), intent(inout), optional :: prect(mgncol)
        4721             :    real(r8), intent(inout), optional :: preci(mgncol)
        4722             :
        4723             :    ! Local variables
        4724             :    integer  :: i,k
        4725    89350560 :    real(r8) :: dum_2D(mgncol,nlev),flx(mgncol,nlev),precip(mgncol)
        4726             :    logical  :: present_preci, present_xflx, present_qxsedten, present_prect
        4727             :
        4728    44675280 :    present_preci = present(preci)
        4729    44675280 :    present_xflx = present(xflx)
        4730    44675280 :    present_qxsedten = present(qxsedten)
        4731    44675280 :    present_prect = present(prect)
        4732             :
        4733             :    !$acc enter data create (flx,dum_2D,precip) async(queue)
        4734             :
        4735             :    !$acc parallel vector_length(VLENS) default(present) async(queue)
        4736             :    !$acc loop gang vector collapse(2)
        4737  3797398800 :    do k=1,nlev
        4738 62706430800 :       do i=1,mgncol
        4739 62661755520 :          dum_2D(i,k) = dumx(i,k)
        4740             :       enddo
        4741             :    enddo
        4742             :    !$acc end parallel
        4743             :
        4744    44675280 :    call implicit_fall ( deltat, mgncol, 1, nlev, zint, fx, pdel, dum_2D, precip, flx, queue)
        4745             :
        4746             :    !$acc parallel vector_length(VLENS) default(present) async(queue)
        4747             :    !$acc loop gang vector collapse(2)
        4748  3797398800 :    do k=1,nlev
        4749 62706430800 :       do i=1,mgncol
        4750 58909032000 :          if ( check_qsmall ) then
        4751             :             !h1g, 2019-11-26, ensure numerical stability
        4752 35345419200 :             if ( flx(i,k) .ge. qsmall .and. present_xflx ) xflx(i,k+1) = xflx(i,k+1) + flx(i,k) / g / deltat
        4753             :          else
        4754 23563612800 :             if ( present_xflx ) xflx(i,k+1) = xflx(i,k+1) + flx(i,k) / g / deltat
        4755             :          end if
        4756 58909032000 :          if ( present_qxsedten) qxsedten(i,k) = qxsedten(i,k) + (dum_2D(i,k) - dumx(i,k)) / deltat
        4757 62661755520 :          xxtend(i,k) = xxtend(i,k) + (dum_2D(i,k) - dumx(i,k)) / deltat
        4758             :       enddo
        4759             :    enddo
        4760             :    !$acc end parallel
        4761             :
        4762             :    !$acc parallel vector_length(VLENS) default(present) async(queue)
        4763             :    !$acc loop gang vector
        4764   745973280 :    do i=1,mgncol
        4765   745973280 :       if ( precip(i) .ge. 0.0 ) then !h1g, 2019-11-26, ensure numerical stability
        4766   516998999 :          if ( present_prect ) prect(i) = prect(i) + precip(i) / g / deltat / 1000._r8
        4767   516998999 :          if ( present_preci ) preci(i) = preci(i) + precip(i) / g / deltat / 1000._r8
        4768             :       endif
        4769             :    enddo
        4770             :    !$acc end parallel
        4771             :
        4772             :    !$acc exit data delete(flx,dum_2D,precip) async(queue)
        4773             :
        4774   125090784 : end subroutine Sedimentation_implicit
        4775             :
        4776             : !========================================================================
        4777             : !UTILITIES
        4778             : !========================================================================
        4779             :
        4780             :
        4781           0 : pure subroutine micro_pumas_get_cols(ncol, nlev, top_lev, mgncol, mgcols, &
        4782           0 :      qcn, qin, qrn, qsn, qgr)
        4783             :
        4784             :   ! Determines which columns microphysics should operate over by
        4785             :   ! checking for non-zero cloud water/ice.
        4786             :
        4787             :   integer, intent(in) :: ncol      ! Number of columns with meaningful data
        4788             :   integer, intent(in) :: nlev      ! Number of levels to use
        4789             :   integer, intent(in) :: top_lev   ! Top level for microphysics
        4790             :   integer, intent(out) :: mgncol   ! Number of columns MG will use
        4791             :   integer, allocatable, intent(out) :: mgcols(:) ! column indices
        4792             :
        4793             :   real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg)
        4794             :   real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg)
        4795             :   real(r8), intent(in) :: qrn(:,:) ! rain mixing ratio (kg/kg)
        4796             :   real(r8), intent(in) :: qsn(:,:) ! snow mixing ratio (kg/kg)
        4797             :   real(r8), optional, intent(in) :: qgr(:,:) ! graupel mixing ratio (kg/kg)
        4798             :
        4799             :   integer :: lev_offset  ! top_lev - 1 (defined here for consistency)
        4800           0 :   logical :: ltrue(ncol) ! store tests for each column
        4801             :
        4802             :   integer :: i, ii ! column indices
        4803             :
        4804           0 :   if (allocated(mgcols)) deallocate(mgcols)
        4805             :
        4806           0 :   lev_offset = top_lev - 1
        4807             :
        4808             :   ! Using "any" along dimension 2 collapses across levels, but
        4809             :   ! not columns, so we know if water is present at any level
        4810             :   ! in each column.
        4811             :
        4812           0 :   ltrue = any(qcn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
        4813           0 :   ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
        4814           0 :   ltrue = ltrue .or. any(qrn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
        4815           0 :   ltrue = ltrue .or. any(qsn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
        4816             :
        4817           0 :   if(present(qgr)) ltrue = ltrue .or. any(qgr(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
        4818             :
        4819             :   ! Scan for true values to get a usable list of indices.
        4820             :
        4821           0 :   mgncol = count(ltrue)
        4822           0 :   allocate(mgcols(mgncol))
        4823           0 :   i = 0
        4824           0 :   do ii = 1,ncol
        4825           0 :      if (ltrue(ii)) then
        4826           0 :         i = i + 1
        4827           0 :         mgcols(i) = ii
        4828             :      end if
        4829             :   end do
        4830             :
        4831           0 : end subroutine micro_pumas_get_cols
        4832             :
        4833             : ! =======================================================================
        4834             : ! time - implicit monotonic scheme
        4835             : ! developed by sj lin, 2016
        4836             : ! =======================================================================
        4837             :
        4838    44675280 : subroutine implicit_fall (dt, mgncol, ktop, kbot, ze, vt, dp, q, precip, m1, queue)
        4839             :
        4840             :     implicit none
        4841             :
        4842             :     integer, intent (in) :: mgncol                                   ! Number of columns in MG
        4843             :     integer, intent (in) :: ktop,kbot                                ! Level range (top to bottom)
        4844             :     real(r8), intent (in) :: dt                                      ! Time step
        4845             :     real(r8), intent (in), dimension (mgncol,ktop:kbot+1) :: ze      ! Interface height (m)
        4846             :     real(r8), intent (in), dimension (mgncol,ktop:kbot) :: vt, dp    ! fall speed and pressure difference across level
        4847             :     real(r8), intent (inout), dimension (mgncol,ktop:kbot) :: q      ! mass
        4848             :     real(r8), intent (out), dimension (mgncol,ktop:kbot) :: m1       ! Surface Flux
        4849             :     real(r8), intent (out), dimension (mgncol) :: precip             ! Surface Precipitation
        4850             :     integer, intent (in) :: queue                                    ! Stream ID for GPU asynchronous run
        4851             :
        4852             :     ! Local variables
        4853    89350560 :     real(r8), dimension (mgncol,ktop:kbot) :: dz, qm, dd
        4854             :     integer :: i,k
        4855             :
        4856             :     !$acc enter data create (dz,qm,dd) async(queue)
        4857             :
        4858             :     !$acc parallel vector_length(VLENS) default(present) async(queue)
        4859             :     !$acc loop gang vector collapse(2)
        4860   745973280 :     do i = 1, mgncol
        4861 59655005280 :        do k = ktop, kbot
        4862 58909032000 :           dz (i,k) = ze (i,k) - ze (i,k + 1)
        4863 58909032000 :           dd (i,k) = dt * vt (i,k)
        4864 59610330000 :           q (i,k) = q (i,k) * dp (i,k)
        4865             :        end do
        4866             :     end do
        4867             :     !$acc end parallel
        4868             :
        4869             :     ! -----------------------------------------------------------------------
        4870             :     ! sedimentation: non - vectorizable loop
        4871             :     ! -----------------------------------------------------------------------
        4872             :
        4873             :     !$acc parallel vector_length(VLENS) default(present) async(queue)
        4874             :     !$acc loop gang vector
        4875   745973280 :     do i = 1, mgncol
        4876   701298000 :        qm (i,ktop) = q (i,ktop) / (dz (i,ktop) + dd (i,ktop))
        4877             :
        4878             :        !$acc loop seq
        4879 58953707280 :        do k = ktop + 1, kbot
        4880 58909032000 :           qm (i,k) = (q (i,k) + dd (i,k - 1) * qm (i,k - 1)) / (dz (i,k) + dd (i,k))
        4881             :        end do
        4882             :     end do
        4883             :     !$acc end parallel
        4884             :
        4885             :     ! -----------------------------------------------------------------------
        4886             :     ! qm is density at this stage
        4887             :     ! -----------------------------------------------------------------------
        4888             :
        4889             :     !$acc parallel vector_length(VLENS) default(present) async(queue)
        4890             :     !$acc loop gang vector collapse(2)
        4891   745973280 :     do i = 1, mgncol
        4892 59655005280 :        do k = ktop, kbot
        4893 59610330000 :           qm (i,k) = qm (i,k) * dz (i,k)
        4894             :        end do
        4895             :     end do
        4896             :     !$acc end parallel
        4897             :
        4898             :     ! -----------------------------------------------------------------------
        4899             :     ! output mass fluxes: non - vectorizable loop
        4900             :     ! -----------------------------------------------------------------------
        4901             :
        4902             :     !$acc parallel vector_length(VLENS) default(present) async(queue)
        4903             :     !$acc loop gang vector
        4904   745973280 :     do i = 1, mgncol
        4905   701298000 :        m1 (i,ktop) = q (i,ktop) - qm (i,ktop)
        4906             :
        4907             :        !$acc loop seq
        4908 58953707280 :        do k = ktop + 1, kbot
        4909 58909032000 :           m1 (i,k) = m1 (i,k - 1) + q (i,k) - qm (i,k)
        4910             :        end do
        4911             :     end do
        4912             :     !$acc end parallel
        4913             :
        4914             :     !$acc parallel vector_length(VLENS) default(present) async(queue)
        4915             :     !$acc loop gang vector
        4916   745973280 :     do i = 1, mgncol
        4917   745973280 :        precip(i) = m1 (i,kbot)
        4918             :     end do
        4919             :     !$acc end parallel
        4920             :
        4921             :     ! -----------------------------------------------------------------------
        4922             :     ! update:
        4923             :     ! -----------------------------------------------------------------------
        4924             :
        4925             :     !$acc parallel vector_length(VLENS) default(present) async(queue)
        4926             :     !$acc loop gang vector collapse(2)
        4927   745973280 :     do i = 1, mgncol
        4928 59655005280 :        do k = ktop, kbot
        4929 59610330000 :           q (i,k) = qm (i,k) / dp (i,k)
        4930             :        end do
        4931             :     end do
        4932             :     !$acc end parallel
        4933             :
        4934             :     !$acc exit data delete (dz,qm,dd) async(queue)
        4935             :
        4936    44675280 : end subroutine implicit_fall
        4937             :
        4938             :
        4939             : end module micro_pumas_v1

Generated by: LCOV version 1.14