LCOV - code coverage report
Current view: top level - atmos_phys/schemes/zhang_mcfarlane - zm_conv_convtran.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 111 120 92.5 %
Date: 2025-03-13 19:18:33 Functions: 1 2 50.0 %

          Line data    Source code
       1             : module zm_conv_convtran
       2             : 
       3             :   use ccpp_kinds, only:  kind_phys
       4             : 
       5             :   implicit none
       6             : 
       7             :   save
       8             :   private                         ! Make default type private to the module
       9             : !
      10             : ! PUBLIC: interfaces
      11             : !
      12             :   public zm_conv_convtran_init
      13             :   public zm_conv_convtran_run     ! convective transport
      14             : 
      15             : 
      16             : contains
      17             : 
      18             : !===============================================================================
      19             : !> \section arg_table_zm_conv_convtran_init Argument Table
      20             : !! \htmlinclude zm_conv_convtran_init.html
      21             : !!
      22           0 : subroutine zm_conv_convtran_init(qprops, ncnst, doconvtran, errmsg, errflg)
      23             : 
      24             : use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t
      25             : 
      26             :    implicit none
      27             : 
      28             :    type(ccpp_constituent_prop_ptr_t), intent(in)  :: qprops(:)
      29             :    integer,             intent(in) :: ncnst          ! number of tracers to transport
      30             : 
      31             :    logical,            intent(out) :: doconvtran(:)  ! flag for doing convective transport      (ncnst)
      32             :    character(len=512), intent(out) :: errmsg
      33             :    integer,            intent(out) :: errflg
      34             : 
      35             : 
      36             :    integer :: q_index
      37             : 
      38           0 :    errmsg = ''
      39           0 :    errflg = 0
      40             : 
      41             :    ! Only convectively transport constituents that are water species 
      42           0 :    do q_index=1,ncnst
      43           0 :        call qprops(q_index)%is_water_species(doconvtran(q_index), errflg, errmsg)
      44           0 :        if (errflg /= 0) return
      45             :    end do
      46             : 
      47             : end subroutine zm_conv_convtran_init
      48             : !===============================================================================
      49             : !> \section arg_table_zm_conv_convtran_run Argument Table
      50             : !! \htmlinclude zm_conv_convtran_run.html
      51             : !!
      52      188856 : subroutine zm_conv_convtran_run(ncol, pver, &
      53      188856 :                     doconvtran,q       ,ncnst   ,mu      ,md      , &
      54      188856 :                     du      ,eu      ,ed      ,dp      ,dsubcld , &
      55      377712 :                     jt      ,mx      ,ideep   ,il1g    ,il2g    , &
      56      377712 :                     nstep   ,fracis  ,dqdt    ,dpdry   ,const_metadata, &
      57      188856 :                     scheme_name, errmsg, errflg)
      58             : 
      59             : !-----------------------------------------------------------------------
      60             : !
      61             : ! Purpose:
      62             : ! Convective transport of trace species
      63             : !
      64             : ! Mixing ratios may be with respect to either dry or moist air
      65             : !
      66             : ! Method:
      67             : ! <Describe the algorithm(s) used in the routine.>
      68             : ! <Also include any applicable external references.>
      69             : !
      70             : ! Author: P. Rasch
      71             : !
      72             : !-----------------------------------------------------------------------
      73             :    use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t
      74             : 
      75             : 
      76             :    implicit none
      77             : !-----------------------------------------------------------------------
      78             : !
      79             : ! Input arguments
      80             : !
      81             :    integer, intent(in) :: ncol
      82             :    integer, intent(in) :: pver
      83             :    integer, intent(in) :: ncnst          ! number of tracers to transport
      84             :    logical, intent(in) :: doconvtran(:)  ! flag for doing convective transport      (ncnst)
      85             :    real(kind_phys), intent(in) :: q(:,:,:)      ! Tracer array including moisture          (ncol,pver,ncnst)
      86             :    real(kind_phys), intent(in) :: mu(:,:)       ! Mass flux up                             (ncol,pver)
      87             :    real(kind_phys), intent(in) :: md(:,:)       ! Mass flux down                           (ncol,pver)
      88             :    real(kind_phys), intent(in) :: du(:,:)       ! Mass detraining from updraft             (ncol,pver)
      89             :    real(kind_phys), intent(in) :: eu(:,:)       ! Mass entraining from updraft             (ncol,pver)
      90             :    real(kind_phys), intent(in) :: ed(:,:)       ! Mass entraining from downdraft           (ncol,pver)
      91             :    real(kind_phys), intent(in) :: dp(:,:)       ! Delta pressure between interfaces        (ncol,pver)
      92             :    real(kind_phys), intent(in) :: dsubcld(:)    ! Delta pressure from cloud base to sfc    (ncol)
      93             :    real(kind_phys), intent(in) :: fracis(:,:,:) ! fraction of tracer that is insoluble     (ncol,pver,ncnst)
      94             : 
      95             :    integer, intent(in) :: jt(:)          ! Index of cloud top for each column       (ncol)
      96             :    integer, intent(in) :: mx(:)          ! Index of cloud top for each column       (ncol)
      97             :    integer, intent(in) :: ideep(:)       ! Gathering array                          (ncol)
      98             :    integer, intent(in) :: il1g           ! Gathered min lon indices over which to operate
      99             :    integer, intent(in) :: il2g           ! Gathered max lon indices over which to operate
     100             :    integer, intent(in) :: nstep          ! Time step index
     101             : 
     102             :    real(kind_phys), intent(in) :: dpdry(:,:)    ! Delta pressure between interfaces        (ncol,pver)
     103             : 
     104             : 
     105             :    type(ccpp_constituent_prop_ptr_t), intent(in) :: const_metadata(:)
     106             :    character(len=40),  intent(out) :: scheme_name
     107             :    character(len=512), intent(out) :: errmsg
     108             :    integer,            intent(out) :: errflg
     109             : 
     110             : ! input/output
     111             : 
     112             :    real(kind_phys), intent(out) :: dqdt(:,:,:)  ! Tracer tendency array  (ncol,pver,ncnst)
     113             : 
     114             : !--------------------------Local Variables------------------------------
     115             : 
     116             :    integer i                 ! Work index
     117             :    integer k                 ! Work index
     118             :    integer kbm               ! Highest altitude index of cloud base
     119             :    integer kk                ! Work index
     120             :    integer kkp1              ! Work index
     121             :    integer km1               ! Work index
     122             :    integer kp1               ! Work index
     123             :    integer ktm               ! Highest altitude index of cloud top
     124             :    integer m                 ! Work index
     125             : 
     126             :    logical :: is_dry
     127             : 
     128             :    real(kind_phys) cabv                 ! Mix ratio of constituent above
     129             :    real(kind_phys) cbel                 ! Mix ratio of constituent below
     130             :    real(kind_phys) cdifr                ! Normalized diff between cabv and cbel
     131      377712 :    real(kind_phys) chat(ncol,pver)     ! Mix ratio in env at interfaces
     132      377712 :    real(kind_phys) cond(ncol,pver)     ! Mix ratio in downdraft at interfaces
     133      377712 :    real(kind_phys) const(ncol,pver)    ! Gathered tracer array
     134      377712 :    real(kind_phys) fisg(ncol,pver)     ! gathered insoluble fraction of tracer
     135      377712 :    real(kind_phys) conu(ncol,pver)     ! Mix ratio in updraft at interfaces
     136      377712 :    real(kind_phys) dcondt(ncol,pver)   ! Gathered tend array
     137             :    real(kind_phys) small                ! A small number
     138             :    real(kind_phys) mbsth                ! Threshold for mass fluxes
     139             :    real(kind_phys) mupdudp              ! A work variable
     140             :    real(kind_phys) minc                 ! A work variable
     141             :    real(kind_phys) maxc                 ! A work variable
     142             :    real(kind_phys) fluxin               ! A work variable
     143             :    real(kind_phys) fluxout              ! A work variable
     144             :    real(kind_phys) netflux              ! A work variable
     145             : 
     146      377712 :    real(kind_phys) dutmp(ncol,pver)       ! Mass detraining from updraft
     147      377712 :    real(kind_phys) eutmp(ncol,pver)       ! Mass entraining from updraft
     148      377712 :    real(kind_phys) edtmp(ncol,pver)       ! Mass entraining from downdraft
     149      188856 :    real(kind_phys) dptmp(ncol,pver)    ! Delta pressure between interfaces
     150             :    real(kind_phys) total(ncol)
     151             :    real(kind_phys) negadt,qtmp
     152             : 
     153             :    character(len=256) :: standard_name
     154             : 
     155             : !-----------------------------------------------------------------------
     156             : !
     157      188856 :    scheme_name = "zm_conv_convtran_run"
     158      188856 :    errmsg = ''
     159      188856 :    errflg = 0
     160             : 
     161      188856 :    small = 1.e-36_kind_phys
     162             : ! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s)
     163      188856 :    mbsth = 1.e-15_kind_phys
     164             : 
     165             : ! Find the highest level top and bottom levels of convection
     166      188856 :    ktm = pver
     167      188856 :    kbm = pver
     168      687581 :    do i = il1g, il2g
     169      498725 :       ktm = min(ktm,jt(i))
     170      687581 :       kbm = min(kbm,mx(i))
     171             :    end do
     172             : 
     173             : ! Loop ever each constituent
     174 12032059680 :    dqdt(:,:,:) = 0._kind_phys
     175     7931952 :    do m = 1, ncnst
     176             : 
     177     7743096 :       call const_metadata(m)%standard_name(standard_name)
     178     7743096 :       if (standard_name == 'water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water') then
     179             :         cycle
     180             :       end if
     181             : 
     182     7743096 :       if (doconvtran(m)) then
     183             : 
     184     1978344 :          call const_metadata(m)%is_dry(is_dry, errflg, errmsg)
     185     1978344 :          if (is_dry) then
     186    92836656 :             do k = 1,pver
     187   335572050 :                do i =il1g,il2g
     188   242735394 :                   dptmp(i,k) = dpdry(i,k)
     189   242735394 :                   dutmp(i,k) = du(i,k)*dp(i,k)/dpdry(i,k)
     190   242735394 :                   eutmp(i,k) = eu(i,k)*dp(i,k)/dpdry(i,k)
     191   334584426 :                   edtmp(i,k) = ed(i,k)*dp(i,k)/dpdry(i,k)
     192             :                end do
     193             :             end do
     194             :          else
     195    93127680 :             do k = 1,pver
     196   336273390 :                do i =il1g,il2g
     197   243145710 :                   dptmp(i,k) = dp(i,k)
     198   243145710 :                   dutmp(i,k) = du(i,k)
     199   243145710 :                   eutmp(i,k) = eu(i,k)
     200   335282670 :                   edtmp(i,k) = ed(i,k)
     201             :                end do
     202             :             end do
     203             :          endif
     204             : 
     205             : ! Gather up the constituent and set tend to zero
     206   185964336 :          do k = 1,pver
     207   671845440 :             do i =il1g,il2g
     208   485881104 :                const(i,k) = q(ideep(i),k,m)
     209   669867096 :                fisg(i,k) = fracis(ideep(i),k,m)
     210             :             end do
     211             :          end do
     212             : 
     213             : ! From now on work only with gathered data
     214             : 
     215             : ! Interpolate environment tracer values to interfaces
     216   185964336 :          do k = 1,pver
     217   183985992 :             km1 = max(1,k-1)
     218   671845440 :             do i = il1g, il2g
     219   485881104 :                minc = min(const(i,km1),const(i,k))
     220   485881104 :                maxc = max(const(i,km1),const(i,k))
     221   485881104 :                if (minc < 0) then
     222             :                   cdifr = 0._kind_phys
     223             :                else
     224   485881104 :                   cdifr = abs(const(i,k)-const(i,km1))/max(maxc,small)
     225             :                endif
     226             : 
     227             : ! If the two layers differ significantly use a geometric averaging
     228             : ! procedure
     229   485881104 :                if (cdifr > 1.E-6_kind_phys) then
     230   351166333 :                   cabv = max(const(i,km1),maxc*1.e-12_kind_phys)
     231   351166333 :                   cbel = max(const(i,k),maxc*1.e-12_kind_phys)
     232   351166333 :                   chat(i,k) = log(cabv/cbel)/(cabv-cbel)*cabv*cbel
     233             : 
     234             :                else             ! Small diff, so just arithmetic mean
     235   134714771 :                   chat(i,k) = 0.5_kind_phys* (const(i,k)+const(i,km1))
     236             :                end if
     237             : 
     238             : ! Provisional up and down draft values
     239   485881104 :                conu(i,k) = chat(i,k)
     240   485881104 :                cond(i,k) = chat(i,k)
     241             : 
     242             : !              provisional tends
     243   669867096 :                dcondt(i,k) = 0._kind_phys
     244             : 
     245             :             end do
     246             :          end do
     247             : 
     248             : ! Do levels adjacent to top and bottom
     249     7202872 :          k = 2
     250     7202872 :          km1 = 1
     251     7202872 :          kk = pver
     252     7202872 :          do i = il1g,il2g
     253     5224528 :             mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk)
     254     5224528 :             if (mupdudp > mbsth) then
     255           0 :                conu(i,kk) = (+eutmp(i,kk)*fisg(i,kk)*const(i,kk)*dptmp(i,kk))/mupdudp
     256             :             endif
     257     7202872 :             if (md(i,k) < -mbsth) then
     258           0 :                cond(i,k) =  (-edtmp(i,km1)*fisg(i,km1)*const(i,km1)*dptmp(i,km1))/md(i,k)
     259             :             endif
     260             :          end do
     261             : 
     262             : ! Updraft from bottom to top
     263   183985992 :          do kk = pver-1,1,-1
     264   182007648 :             kkp1 = min(pver,kk+1)
     265   664642568 :             do i = il1g,il2g
     266   480656576 :                mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk)
     267   662664224 :                if (mupdudp > mbsth) then
     268    88167657 :                   conu(i,kk) = (  mu(i,kkp1)*conu(i,kkp1)+eutmp(i,kk)*fisg(i,kk)* &
     269   176335314 :                                   const(i,kk)*dptmp(i,kk) )/mupdudp
     270             :                endif
     271             :             end do
     272             :          end do
     273             : 
     274             : ! Downdraft from top to bottom
     275   182007648 :          do k = 3,pver
     276   180029304 :             km1 = max(1,k-1)
     277   657439696 :             do i = il1g,il2g
     278   655461352 :                if (md(i,k) < -mbsth) then
     279   138171416 :                   cond(i,k) =  (  md(i,km1)*cond(i,km1)-edtmp(i,km1)*fisg(i,km1)*const(i,km1) &
     280   138171416 :                                   *dptmp(i,km1) )/md(i,k)
     281             :                endif
     282             :             end do
     283             :          end do
     284             : 
     285             : 
     286    18206797 :          do k = ktm,pver
     287    16228453 :             km1 = max(1,k-1)
     288    16228453 :             kp1 = min(pver,k+1)
     289   142956838 :             do i = il1g,il2g
     290             : 
     291             : ! limit fluxes outside convection to mass in appropriate layer
     292             : ! these limiters are probably only safe for positive definite quantitities
     293             : ! it assumes that mu and md already satify a courant number limit of 1
     294   499000164 :                fluxin =  mu(i,kp1)*conu(i,kp1)+ mu(i,k)*min(chat(i,k),const(i,km1)) &
     295   623750205 :                          -(md(i,k)  *cond(i,k) + md(i,kp1)*min(chat(i,kp1),const(i,kp1)))
     296             :                fluxout = mu(i,k)*conu(i,k) + mu(i,kp1)*min(chat(i,kp1),const(i,k)) &
     297   124750041 :                          -(md(i,kp1)*cond(i,kp1) + md(i,k)*min(chat(i,k),const(i,k)))
     298             : 
     299   124750041 :                netflux = fluxin - fluxout
     300   124750041 :                if (abs(netflux) < max(fluxin,fluxout)*1.e-12_kind_phys) then
     301    10117570 :                   netflux = 0._kind_phys
     302             :                endif
     303   140978494 :                dcondt(i,k) = netflux/dptmp(i,k)
     304             :             end do
     305             :          end do
     306             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     307             : !
     308     6670042 :          do k = kbm,pver
     309     4691698 :             km1 = max(1,k-1)
     310    33140965 :             do i = il1g,il2g
     311    31162621 :                if (k == mx(i)) then
     312             : 
     313     5224528 :                   fluxin =  mu(i,k)*min(chat(i,k),const(i,km1)) - md(i,k)*cond(i,k)
     314     5224528 :                   fluxout = mu(i,k)*conu(i,k) - md(i,k)*min(chat(i,k),const(i,k))
     315             : 
     316     5224528 :                   netflux = fluxin - fluxout
     317     5224528 :                   if (abs(netflux) < max(fluxin,fluxout)*1.e-12_kind_phys) then
     318           0 :                      netflux = 0._kind_phys
     319             :                   endif
     320     5224528 :                   dcondt(i,k) = netflux/dptmp(i,k)
     321    21246395 :                else if (k > mx(i)) then
     322    17656370 :                   dcondt(i,k) = 0._kind_phys
     323             :                end if
     324             :             end do
     325             :          end do
     326             : 
     327             : ! Scatter tendency back to full array
     328   185964336 :          do k = 1,pver
     329   183985992 :             kp1 = min(pver,k+1)
     330   671845440 :             do i = il1g,il2g
     331   669867096 :                dqdt(ideep(i),k,m) = dcondt(i,k)
     332             :             end do
     333             :          end do
     334             : 
     335             :       end if      ! for doconvtran
     336             : 
     337             :    end do
     338             : 
     339      188856 :    return
     340             : end subroutine zm_conv_convtran_run
     341             : 
     342             : 
     343             : end module zm_conv_convtran

Generated by: LCOV version 1.14