LCOV - code coverage report
Current view: top level - atmos_phys/schemes/zhang_mcfarlane - zm_conv_momtran.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 171 172 99.4 %
Date: 2025-03-14 01:18:36 Functions: 1 1 100.0 %

          Line data    Source code
       1             : module zm_conv_momtran
       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             :   public zm_conv_momtran_run      ! convective momentum transport
      10             :   integer, parameter, private :: num_winds=2  ! Number of wind directions (for historical purposes)
      11             : 
      12             : 
      13             : contains
      14             : 
      15             : !===============================================================================
      16             : !> \section arg_table_zm_conv_momtran_run Argument Table
      17             : !! \htmlinclude zm_conv_momtran_run.html
      18             : !!
      19       80640 : subroutine zm_conv_momtran_run(ncol, pver, pverp, &
      20       80640 :                     domomtran,windu, windv, mu, md, &
      21             :                     momcu, momcd, &
      22       80640 :                     du, eu, ed, dp, dsubcld , &
      23       80640 :                     jt, mx, ideep , il1g, il2g, &
      24       80640 :                     nstep, windu_tend, windv_tend, pguallu, pguallv, pgdallu, pgdallv, &
      25      241920 :                     icwuu, icwuv, icwdu, icwdv, dt, seten, scheme_name, errmsg, errflg)
      26             : !-----------------------------------------------------------------------
      27             : !
      28             : ! Purpose:
      29             : ! Convective transport of momentum
      30             : !
      31             : ! Mixing ratios may be with respect to either dry or moist air
      32             : !
      33             : ! Method:
      34             : ! Based on the convtran subroutine by P. Rasch
      35             : ! <Also include any applicable external references.>
      36             : !
      37             : ! Author: J. Richter and P. Rasch
      38             : !
      39             : !-----------------------------------------------------------------------
      40             : 
      41             :    implicit none
      42             : !-----------------------------------------------------------------------
      43             : !
      44             : ! Input arguments
      45             : !
      46             :    integer, intent(in) :: ncol                  ! number of atmospheric columns
      47             :    integer, intent(in) :: pver, pverp
      48             :    logical, intent(in) :: domomtran      ! flag for doing convective transport
      49             :    real(kind_phys), intent(in) :: windu(:,:)  ! U Wind array                                    (ncol,pver)
      50             :    real(kind_phys), intent(in) :: windv(:,:)  ! V Wind array                                    (ncol,pver)
      51             :    real(kind_phys), intent(in) :: mu(:,:)       ! Mass flux up                              (ncol,pver)
      52             :    real(kind_phys), intent(in) :: md(:,:)       ! Mass flux down                            (ncol,pver)
      53             :    real(kind_phys), intent(in) :: momcu
      54             :    real(kind_phys), intent(in) :: momcd
      55             :    real(kind_phys), intent(in) :: du(:,:)       ! Mass detraining from updraft              (ncol,pver)
      56             :    real(kind_phys), intent(in) :: eu(:,:)       ! Mass entraining from updraft              (ncol,pver)
      57             :    real(kind_phys), intent(in) :: ed(:,:)       ! Mass entraining from downdraft            (ncol,pver)
      58             :    real(kind_phys), intent(in) :: dp(:,:)       ! Delta pressure between interfaces         (ncol,pver)
      59             :    real(kind_phys), intent(in) :: dsubcld(:)       ! Delta pressure from cloud base to sfc  (ncol)
      60             :    real(kind_phys), intent(in) :: dt    ! time step in seconds
      61             : 
      62             :    integer, intent(in) :: jt(:)         ! Index of cloud top for each column         (ncol)
      63             :    integer, intent(in) :: mx(:)         ! Index of cloud top for each column         (ncol)
      64             :    integer, intent(in) :: ideep(:)      ! Gathering array                            (ncol)
      65             :    integer, intent(in) :: il1g              ! Gathered min lon indices over which to operate
      66             :    integer, intent(in) :: il2g              ! Gathered max lon indices over which to operate
      67             :    integer, intent(in) :: nstep             ! Time step index
      68             : 
      69             : 
      70             : 
      71             : ! input/output
      72             : 
      73             :    real(kind_phys), intent(out) :: windu_tend(:,:)  ! U wind tendency
      74             :    real(kind_phys), intent(out) :: windv_tend(:,:)  ! V wind tendency
      75             : 
      76             :    character(len=512), intent(out) :: errmsg
      77             :    integer,            intent(out) :: errflg
      78             :    character(len=40),  intent(out) :: scheme_name
      79             : 
      80             : !--------------------------Local Variables------------------------------
      81             : 
      82             :    integer i                 ! Work index
      83             :    integer k                 ! Work index
      84             :    integer kbm               ! Highest altitude index of cloud base
      85             :    integer kk                ! Work index
      86             :    integer kkp1              ! Work index
      87             :    integer kkm1              ! Work index
      88             :    integer km1               ! Work index
      89             :    integer kp1               ! Work index
      90             :    integer ktm               ! Highest altitude index of cloud top
      91             :    integer m                 ! Work index
      92             :    integer ii                 ! Work index
      93             : 
      94             :    real(kind_phys) cabv                 ! Mix ratio of constituent above
      95             :    real(kind_phys) cbel                 ! Mix ratio of constituent below
      96             :    real(kind_phys) cdifr                ! Normalized diff between cabv and cbel
      97      161280 :    real(kind_phys) chat(ncol,pver)     ! Mix ratio in env at interfaces
      98      161280 :    real(kind_phys) cond(ncol,pver)     ! Mix ratio in downdraft at interfaces
      99      161280 :    real(kind_phys) const(ncol,pver)    ! Gathered wind array
     100      161280 :    real(kind_phys) conu(ncol,pver)     ! Mix ratio in updraft at interfaces
     101      161280 :    real(kind_phys) dcondt(ncol,pver)   ! Gathered tend array
     102             :    real(kind_phys) mbsth                ! Threshold for mass fluxes
     103             :    real(kind_phys) mupdudp              ! A work variable
     104             :    real(kind_phys) minc                 ! A work variable
     105             :    real(kind_phys) maxc                 ! A work variable
     106             :    real(kind_phys) fluxin               ! A work variable
     107             :    real(kind_phys) fluxout              ! A work variable
     108             :    real(kind_phys) netflux              ! A work variable
     109             : 
     110             : 
     111             :    real(kind_phys) sum                  ! sum
     112             :    real(kind_phys) sum2                  ! sum2
     113             : 
     114      161280 :    real(kind_phys) mududp(ncol,pver) ! working variable
     115      161280 :    real(kind_phys) mddudp(ncol,pver)     ! working variable
     116             : 
     117      161280 :    real(kind_phys) pgu(ncol,pver)      ! Pressure gradient term for updraft
     118      161280 :    real(kind_phys) pgd(ncol,pver)      ! Pressure gradient term for downdraft
     119             : 
     120             :    real(kind_phys),intent(out) ::  pguallu(:,:)      ! Apparent force from  updraft PG on U winds  ! (ncol,pver)
     121             :    real(kind_phys),intent(out) ::  pguallv(:,:)      ! Apparent force from  updraft PG on V winds  ! (ncol,pver)
     122             :    real(kind_phys),intent(out) ::  pgdallu(:,:)      ! Apparent force from  downdraft PG on U winds! (ncol,pver)
     123             :    real(kind_phys),intent(out) ::  pgdallv(:,:)      ! Apparent force from  downdraft PG on V winds! (ncol,pver)
     124             : 
     125             :    real(kind_phys),intent(out) ::  icwuu(:,:)      ! In-cloud U winds in updraft           ! (ncol,pver)
     126             :    real(kind_phys),intent(out) ::  icwuv(:,:)      ! In-cloud V winds in updraft           ! (ncol,pver)
     127             :    real(kind_phys),intent(out) ::  icwdu(:,:)      ! In-cloud U winds in downdraft         ! (ncol,pver)
     128             :    real(kind_phys),intent(out) ::  icwdv(:,:)      ! In-cloud V winds in downdraft         ! (ncol,pver)
     129             : 
     130             :    real(kind_phys),intent(out) ::  seten(:,:) ! Dry static energy tendency                ! (ncol,pver)
     131      161280 :    real(kind_phys)                 gseten(ncol,pver) ! Gathered dry static energy tendency
     132             : 
     133      161280 :    real(kind_phys) :: winds(ncol,pver,num_winds)       ! combined winds array
     134      161280 :    real(kind_phys) :: wind_tends(ncol,pver,num_winds)  ! combined tendency array
     135      161280 :    real(kind_phys) :: pguall(ncol,pver,num_winds)      ! Combined apparent force from  updraft PG on U winds
     136      161280 :    real(kind_phys) :: pgdall(ncol,pver,num_winds)      ! Combined apparent force from  downdraft PG on U winds
     137      161280 :    real(kind_phys) :: icwu(ncol,pver,num_winds)        ! Combined In-cloud winds in updraft
     138      161280 :    real(kind_phys) :: icwd(ncol,pver,num_winds)        ! Combined In-cloud winds in downdraft
     139             : 
     140      161280 :    real(kind_phys)  mflux(ncol,pverp,num_winds)   ! Gathered momentum flux
     141             : 
     142      161280 :    real(kind_phys)  wind0(ncol,pver,num_winds)       !  gathered  wind before time step
     143       80640 :    real(kind_phys)  windf(ncol,pver,num_winds)       !  gathered  wind after time step
     144             :    real(kind_phys) fkeb, fket, ketend_cons, ketend, utop, ubot, vtop, vbot, gset2
     145             : 
     146             : 
     147             : !-----------------------------------------------------------------------
     148       80640 :    scheme_name = "zm_conv_momtran_run"
     149       80640 :    errmsg = ''
     150       80640 :    errflg = 0
     151             : 
     152             : ! Combine winds in single array
     153    69705216 :    winds(:,:,1) = windu(:,:)
     154    69624576 :    winds(:,:,2) = windv(:,:)
     155             : 
     156             : ! Initialize outgoing fields
     157   139329792 :    pguall(:,:,:)     = 0.0_kind_phys
     158   139329792 :    pgdall(:,:,:)     = 0.0_kind_phys
     159             : ! Initialize in-cloud winds to environmental wind
     160   139329792 :    icwu(:ncol,:,:)       = winds(:ncol,:,:)
     161   139329792 :    icwd(:ncol,:,:)       = winds(:ncol,:,:)
     162             : 
     163             : ! Initialize momentum flux and  final winds
     164   141813504 :    mflux(:,:,:)       = 0.0_kind_phys
     165   139329792 :    wind0(:,:,:)         = 0.0_kind_phys
     166   139329792 :    windf(:,:,:)         = 0.0_kind_phys
     167             : 
     168             : ! Initialize dry static energy
     169             : 
     170    69624576 :    seten(:,:)         = 0.0_kind_phys
     171    69624576 :    gseten(:,:)         = 0.0_kind_phys
     172             : 
     173             : ! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s)
     174       80640 :    mbsth = 1.e-15_kind_phys
     175             : 
     176             : ! Find the highest level top and bottom levels of convection
     177       80640 :    ktm = pver
     178       80640 :    kbm = pver
     179      298095 :    do i = il1g, il2g
     180      217455 :       ktm = min(ktm,jt(i))
     181      298095 :       kbm = min(kbm,mx(i))
     182             :    end do
     183             : 
     184             : ! Loop ever each wind component
     185      241920 :    do m = 1, num_winds                    !start at m = 1 to transport momentum
     186      241920 :       if (domomtran) then
     187             : 
     188             : ! Gather up the winds and set tend to zero
     189     9192960 :          do k = 1,pver
     190    33547920 :             do i =il1g,il2g
     191    24354960 :                const(i,k) = winds(ideep(i),k,m)
     192    33386640 :                 wind0(i,k,m) = const(i,k)
     193             :             end do
     194             :          end do
     195             : 
     196             : 
     197             : ! From now on work only with gathered data
     198             : 
     199             : ! Interpolate winds to interfaces
     200             : 
     201     9192960 :          do k = 1,pver
     202     9031680 :             km1 = max(1,k-1)
     203    33547920 :             do i = il1g, il2g
     204             : 
     205             :                ! use arithmetic mean
     206    24354960 :                chat(i,k) = 0.5_kind_phys* (const(i,k)+const(i,km1))
     207             : 
     208             : ! Provisional up and down draft values
     209    24354960 :                conu(i,k) = chat(i,k)
     210    24354960 :                cond(i,k) = chat(i,k)
     211             : 
     212             : !              provisional tends
     213    33386640 :                dcondt(i,k) = 0._kind_phys
     214             : 
     215             :             end do
     216             :          end do
     217             : 
     218             : 
     219             : !
     220             : ! Pressure Perturbation Term
     221             : !
     222             : 
     223             :       !Top boundary:  assume mu is zero
     224             : 
     225      161280 :          k=1
     226      757470 :          pgu(:il2g,k) = 0.0_kind_phys
     227      596190 :          pgd(:il2g,k) = 0.0_kind_phys
     228             : 
     229     8870400 :          do k=2,pver-1
     230     8709120 :             km1 = max(1,k-1)
     231     8709120 :             kp1 = min(pver,k+1)
     232    32355540 :             do i = il1g,il2g
     233             : 
     234             :                !interior points
     235             : 
     236    70455420 :                mududp(i,k) =  ( mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
     237    93940560 :                            +  mu(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
     238             : 
     239    23485140 :                pgu(i,k) = - momcu * 0.5_kind_phys * mududp(i,k)
     240             : 
     241             : 
     242    23485140 :                mddudp(i,k) =  ( md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
     243    23485140 :                            +  md(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
     244             : 
     245    32194260 :                pgd(i,k) = - momcd * 0.5_kind_phys * mddudp(i,k)
     246             : 
     247             : 
     248             :             end do
     249             :          end do
     250             : 
     251             :        ! bottom boundary
     252      161280 :        k = pver
     253      161280 :        km1 = max(1,k-1)
     254      596190 :        do i=il1g,il2g
     255             : 
     256      434910 :           mududp(i,k) =   mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
     257      434910 :           pgu(i,k) = - momcu *  mududp(i,k)
     258             : 
     259      434910 :           mddudp(i,k) =   md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
     260             : 
     261      596190 :           pgd(i,k) = - momcd * mddudp(i,k)
     262             : 
     263             :        end do
     264             : 
     265             : 
     266             : !
     267             : ! In-cloud velocity calculations
     268             : !
     269             : 
     270             : ! Do levels adjacent to top and bottom
     271      596190 :          k = 2
     272      596190 :          km1 = 1
     273      596190 :          kk = pver
     274      596190 :          kkm1 = max(1,kk-1)
     275      596190 :          do i = il1g,il2g
     276      434910 :             mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
     277      434910 :             if (mupdudp > mbsth) then
     278             : 
     279      403354 :                conu(i,kk) = (+eu(i,kk)*const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
     280             :             endif
     281      596190 :             if (md(i,k) < -mbsth) then
     282           0 :                cond(i,k) =  (-ed(i,km1)*const(i,km1)*dp(i,km1))-pgd(i,km1)*dp(i,km1)/md(i,k)
     283             :             endif
     284             : 
     285             : 
     286             :          end do
     287             : 
     288             : 
     289             : 
     290             : ! Updraft from bottom to top
     291     9031680 :          do kk = pver-1,1,-1
     292     8870400 :             kkm1 = max(1,kk-1)
     293     8870400 :             kkp1 = min(pver,kk+1)
     294    32951730 :             do i = il1g,il2g
     295    23920050 :                mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
     296    32790450 :                if (mupdudp > mbsth) then
     297             : 
     298    14291752 :                   conu(i,kk) = (  mu(i,kkp1)*conu(i,kkp1)+eu(i,kk)* &
     299    14291752 :                                   const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
     300             :                endif
     301             :             end do
     302             : 
     303             :          end do
     304             : 
     305             : 
     306             : ! Downdraft from top to bottom
     307     8870400 :          do k = 3,pver
     308     8709120 :             km1 = max(1,k-1)
     309    32355540 :             do i = il1g,il2g
     310    32194260 :                if (md(i,k) < -mbsth) then
     311             : 
     312    12032456 :                   cond(i,k) =  (  md(i,km1)*cond(i,km1)-ed(i,km1)*const(i,km1) &
     313    12032456 :                                   *dp(i,km1)-pgd(i,km1)*dp(i,km1) )/md(i,k)
     314             : 
     315             :                endif
     316             :             end do
     317             :          end do
     318             : 
     319             : 
     320             :          sum = 0._kind_phys
     321             :          sum2 = 0._kind_phys
     322             : 
     323             : 
     324     3387246 :          do k = ktm,pver
     325     3225966 :             km1 = max(1,k-1)
     326     3225966 :             kp1 = min(pver,k+1)
     327    12857464 :             do i = il1g,il2g
     328     9470218 :                ii = ideep(i)
     329             : 
     330             : ! version 1 hard to check for roundoff errors
     331     9470218 :                dcondt(i,k) =  &
     332     9470218 :                            +(mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) &
     333     9470218 :                            -mu(i,k)*   (conu(i,k)-chat(i,k))      &
     334     9470218 :                            +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) &
     335     9470218 :                            -md(i,k)*   (cond(i,k)-chat(i,k)) &
     336    31636620 :                           )/dp(i,k)
     337             : 
     338             :             end do
     339             :          end do
     340             : 
     341             :   ! dcont for bottom layer
     342             :           !
     343      366936 :           do k = kbm,pver
     344      799226 :              km1 = max(1,k-1)
     345      960506 :              do i = il1g,il2g
     346      799226 :                 if (k == mx(i)) then
     347             : 
     348             :                    ! version 1
     349      434910 :                    dcondt(i,k) = (1._kind_phys/dp(i,k))*   &
     350      434910 :                         (-mu(i,k)*(conu(i,k)-chat(i,k)) &
     351      434910 :                         -md(i,k)*(cond(i,k)-chat(i,k)) &
     352      869820 :                         )
     353             :                 end if
     354             :              end do
     355             :           end do
     356             : 
     357             : ! Initialize to zero everywhere, then scatter tendency back to full array
     358   139249152 :          wind_tends(:,:,m) = 0._kind_phys
     359             : 
     360     9192960 :          do k = 1,pver
     361    33547920 :             do i = il1g,il2g
     362    24354960 :                ii = ideep(i)
     363    24354960 :                wind_tends(ii,k,m) = dcondt(i,k)
     364             :     ! Output apparent force on the mean flow from pressure gradient
     365    24354960 :                pguall(ii,k,m) = -pgu(i,k)
     366    24354960 :                pgdall(ii,k,m) = -pgd(i,k)
     367    24354960 :                icwu(ii,k,m)   =  conu(i,k)
     368    33386640 :                icwd(ii,k,m)   =  cond(i,k)
     369             :             end do
     370             :          end do
     371             : 
     372             :           ! Calculate momentum flux in units of mb*m/s2
     373             : 
     374     3387246 :           do k = ktm,pver
     375    12857464 :              do i = il1g,il2g
     376     9470218 :                 ii = ideep(i)
     377     9470218 :                 mflux(i,k,m) = &
     378     9470218 :                      -mu(i,k)*   (conu(i,k)-chat(i,k))      &
     379    22166402 :                      -md(i,k)*   (cond(i,k)-chat(i,k))
     380             :              end do
     381             :           end do
     382             : 
     383             : 
     384             :           ! Calculate winds at the end of the time step
     385             : 
     386     3387246 :           do k = ktm,pver
     387    12857464 :              do i = il1g,il2g
     388     9470218 :                 ii = ideep(i)
     389     9470218 :                 km1 = max(1,k-1)
     390     9470218 :                 kp1 = k+1
     391    12696184 :                 windf(i,k,m) = const(i,k)    -   (mflux(i,kp1,m) - mflux(i,k,m)) * dt /dp(i,k)
     392             : 
     393             :              end do
     394             :           end do
     395             : 
     396             :        end if      ! for domomtran
     397             :    end do
     398             : 
     399             :  ! Need to add an energy fix to account for the dissipation of kinetic energy
     400             :     ! Formulation follows from Boville and Bretherton (2003)
     401             :     ! formulation by PJR
     402             : 
     403     1693623 :     do k = ktm,pver
     404     1612983 :        km1 = max(1,k-1)
     405     1612983 :        kp1 = min(pver,k+1)
     406     6428732 :        do i = il1g,il2g
     407             : 
     408     4735109 :           ii = ideep(i)
     409             : 
     410             :           ! calculate the KE fluxes at top and bot of layer
     411             :           ! based on a discrete approximation to b&b eq(35) F_KE = u*F_u + v*F_v at interface
     412     4735109 :           utop = (wind0(i,k,1)+wind0(i,km1,1))/2._kind_phys
     413     4735109 :           vtop = (wind0(i,k,2)+wind0(i,km1,2))/2._kind_phys
     414     4735109 :           ubot = (wind0(i,kp1,1)+wind0(i,k,1))/2._kind_phys
     415     4735109 :           vbot = (wind0(i,kp1,2)+wind0(i,k,2))/2._kind_phys
     416     4735109 :           fket = utop*mflux(i,k,1)   + vtop*mflux(i,k,2)    ! top of layer
     417     4735109 :           fkeb = ubot*mflux(i,k+1,1) + vbot*mflux(i,k+1,2)  ! bot of layer
     418             : 
     419             :           ! divergence of these fluxes should give a conservative redistribution of KE
     420     4735109 :           ketend_cons = (fket-fkeb)/dp(i,k)
     421             : 
     422             :           ! tendency in kinetic energy resulting from the momentum transport
     423     4735109 :           ketend = ((windf(i,k,1)**2 + windf(i,k,2)**2) - (wind0(i,k,1)**2 + wind0(i,k,2)**2))/dt
     424             : 
     425             :           ! the difference should be the dissipation
     426     4735109 :           gset2 = ketend_cons - ketend
     427     6348092 :           gseten(i,k) = gset2
     428             : 
     429             :        end do
     430             : 
     431             :     end do
     432             : 
     433             :     ! Scatter dry static energy to full array
     434     4596480 :     do k = 1,pver
     435    16773960 :        do i = il1g,il2g
     436    12177480 :           ii = ideep(i)
     437    16693320 :           seten(ii,k) = gseten(i,k)
     438             : 
     439             :        end do
     440             :     end do
     441             : 
     442             : ! Split out the wind tendencies
     443    69705216 :    windu_tend(:,:) = wind_tends(:,:,1)
     444    69705216 :    windv_tend(:,:) = wind_tends(:,:,2)
     445             : 
     446    69705216 :    pguallu(:,:)     = pguall(:,:,1)
     447    69705216 :    pguallv(:,:)     = pguall(:,:,2)
     448    69705216 :    pgdallu(:,:)     = pgdall(:,:,1)
     449    69705216 :    pgdallv(:,:)     = pgdall(:,:,2)
     450    69705216 :    icwuu(:ncol,:)       = icwu(:,:,1)
     451    69705216 :    icwuv(:ncol,:)       = icwu(:,:,2)
     452    69705216 :    icwdu(:ncol,:)       = icwd(:,:,1)
     453    69705216 :    icwdv(:ncol,:)       = icwd(:,:,2)
     454             : 
     455       80640 :    return
     456             : end subroutine zm_conv_momtran_run
     457             : 
     458             : 
     459             : end module zm_conv_momtran

Generated by: LCOV version 1.14