LCOV - code coverage report
Current view: top level - atmos_phys/to_be_ccppized - cloud_optical_properties.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 66 74 89.2 %
Date: 2025-04-28 18:57:11 Functions: 6 7 85.7 %

          Line data    Source code
       1             : ! Cloud optical properties (to-be-ccppized utility module)
       2             : ! Computes liquid and ice particle size and emissivity
       3             : ! Author: Byron Boville, Sept 2002 assembled from existing subroutines
       4             : module cloud_optical_properties
       5             : 
       6             :   use shr_kind_mod, only: r8 => shr_kind_r8
       7             :   use ppgrid, only: pcols, pver, pverp
       8             : 
       9             :   implicit none
      10             :   private
      11             :   save
      12             : 
      13             :   public :: cldefr, cldovrlap, cldclw, reitab, reltab
      14             :   public :: cldems_rk, cldems
      15             : 
      16             : contains
      17             : 
      18             :   ! Compute cloud water and ice particle size [um]
      19             :   ! using empirical formulas to construct effective radii
      20             :   ! Original author: J.T. Kiehl, B.A. Boville, P. Rasch
      21       70392 :   subroutine cldefr( &
      22             :     ncol, pver, &
      23             :     tmelt, &
      24       70392 :     landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh)
      25             :     ! Input arguments
      26             :     integer,  intent(in) :: ncol                 ! number of atmospheric columns
      27             :     integer,  intent(in) :: pver
      28             :     real(r8), intent(in) :: tmelt
      29             : 
      30             :     real(r8), intent(in) :: landfrac(:)          ! Land fraction
      31             :     real(r8), intent(in) :: icefrac(:)           ! Ice fraction
      32             :     real(r8), intent(in) :: t(:, :)              ! Temperature
      33             :     real(r8), intent(in) :: ps(:)                ! Surface pressure
      34             :     real(r8), intent(in) :: pmid(:, :)           ! Midpoint pressures
      35             :     real(r8), intent(in) :: landm(:)
      36             :     real(r8), intent(in) :: snowh(:)             ! Snow depth over land, water equivalent [m]
      37             : 
      38             :     ! Output arguments
      39             :     real(r8), intent(out) :: rel(:, :)           ! Liquid effective drop size [um]
      40             :     real(r8), intent(out) :: rei(:, :)           ! Ice effective drop size [um]
      41             : 
      42             :     ! following Kiehl
      43       70392 :     call reltab(ncol, pver, tmelt, t(:ncol,:), landfrac(:ncol), landm(:ncol), icefrac(:ncol), snowh(:), rel(:ncol,:))
      44             : 
      45             :     ! following Kristjansson and Mitchell
      46       70392 :     call reitab(ncol, pver, t(:ncol,:), rei(:ncol,:))
      47       70392 :   end subroutine cldefr
      48             : 
      49             :   ! Compute cloud emissivity using cloud liquid water path [g m-2]
      50             :   ! Original author: J.T. Kiehl
      51             :   !
      52             :   ! Variant 1 used for RK microphysics
      53       33520 :   subroutine cldems_rk(ncol, pver, clwp, fice, rei, emis, cldtau)
      54             :     integer, intent(in) :: ncol                    ! number of atmospheric columns
      55             :     integer, intent(in) :: pver                    ! number of vertical levels
      56             :     real(r8), intent(in) :: clwp(pcols, pver)       ! cloud liquid water path (g/m**2)
      57             :     real(r8), intent(in) :: rei(pcols, pver)        ! ice effective drop size (microns)
      58             :     real(r8), intent(in) :: fice(pcols, pver)       ! fractional ice content within cloud
      59             : 
      60             :     real(r8), intent(out) :: emis(pcols, pver)      ! cloud emissivity (fraction)
      61             :     real(r8), intent(out) :: cldtau(pcols, pver)    ! cloud optical depth
      62             : 
      63             :     integer :: i, k                                 ! longitude, level indices
      64             :     real(r8) :: kabs                               ! longwave absorption coeff (m**2/g)
      65             :     real(r8) :: kabsi                              ! ice absorption coefficient
      66             :     real(r8) :: kabsl                              ! longwave liquid absorption coeff (m**2/g)
      67             :     parameter(kabsl=0.090361_r8)
      68             : 
      69      905040 :     do k = 1, pver
      70    13541040 :       do i = 1, ncol
      71             :         ! note that optical properties for ice valid only
      72             :         ! in range of 13 > rei > 130 micron (Ebert and Curry 92)
      73    12636000 :         kabsi = 0.005_r8 + 1._r8/rei(i, k)
      74    12636000 :         kabs = kabsl*(1._r8 - fice(i, k)) + kabsi*fice(i, k)
      75    12636000 :         emis(i, k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i, k))
      76    13507520 :         cldtau(i, k) = kabs*clwp(i, k)
      77             :       end do
      78             :     end do
      79       33520 :   end subroutine cldems_rk
      80             : 
      81             :   ! Variant 2 used for other microphysical schemes
      82           0 :   subroutine cldems(ncol, pver, clwp, fice, rei, emis, cldtau)
      83             :     integer, intent(in) :: ncol                    ! number of atmospheric columns
      84             :     integer, intent(in) :: pver                    ! number of vertical levels
      85             :     real(r8), intent(in) :: clwp(pcols, pver)       ! cloud liquid water path (g/m**2)
      86             :     real(r8), intent(in) :: rei(pcols, pver)        ! ice effective drop size (microns)
      87             :     real(r8), intent(in) :: fice(pcols, pver)       ! fractional ice content within cloud
      88             : 
      89             :     real(r8), intent(out) :: emis(pcols, pver)      ! cloud emissivity (fraction)
      90             :     real(r8), intent(out) :: cldtau(pcols, pver)    ! cloud optical depth
      91             : 
      92             :     integer :: i, k                                 ! longitude, level indices
      93             :     real(r8) :: kabs                               ! longwave absorption coeff (m**2/g)
      94             :     real(r8) :: kabsi                              ! ice absorption coefficient
      95             :     real(r8) :: kabsl                              ! longwave liquid absorption coeff (m**2/g)
      96             :     parameter(kabsl=0.090361_r8)
      97             : 
      98           0 :     do k = 1, pver
      99           0 :       do i = 1, ncol
     100             :         ! note that optical properties for ice valid only
     101             :         ! in range of 13 > rei > 130 micron (Ebert and Curry 92)
     102           0 :         kabsi = 0.005_r8 + 1._r8/min(max(13._r8, rei(i, k)), 130._r8)
     103           0 :         kabs = kabsl*(1._r8 - fice(i, k)) + kabsi*fice(i, k)
     104           0 :         emis(i, k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i, k))
     105           0 :         cldtau(i, k) = kabs*clwp(i, k)
     106             :       end do
     107             :     end do
     108           0 :   end subroutine cldems
     109             : 
     110             :   ! Partitions each column into regions with clouds in neighboring layers.
     111             :   ! This information is used to implement maximum overlap in these regions
     112             :   ! with random overlap between them.
     113             :   ! On output,
     114             :   !    nmxrgn contains the number of regions in each column
     115             :   !    pmxrgn contains the interface pressures for the lower boundaries of
     116             :   !           each region!
     117       33520 :   subroutine cldovrlap(ncol, pver, pverp, pint, cld, nmxrgn, pmxrgn)
     118             : 
     119             :     ! Input arguments
     120             :     integer, intent(in) :: ncol
     121             :     integer, intent(in) :: pver
     122             :     integer, intent(in) :: pverp
     123             : 
     124             :     real(r8), intent(in) :: pint(:, :)     ! Interface pressure
     125             :     real(r8), intent(in) :: cld(:, :)      ! Fractional cloud cover
     126             : 
     127             :     ! Output arguments
     128             :     integer,  intent(out) :: nmxrgn(:)     ! Number of maximally overlapped regions
     129             :     real(r8), intent(out) :: pmxrgn(:, :)  ! Maximum values of pressure for each
     130             :                                            !    maximally overlapped region.
     131             :                                            !    0->pmxrgn(i,1) is range of pressure for
     132             :                                            !    1st region,pmxrgn(i,1)->pmxrgn(i,2) for
     133             :                                            !    2nd region, etc
     134             :                                            ! (ncol, pverp)
     135             : 
     136             :     integer  :: i, k
     137             :     integer  :: n                    ! Max-overlap region counter
     138       67040 :     real(r8) :: pnm(ncol, pverp)     ! Interface pressure
     139             :     logical  :: cld_found            ! Flag for detection of cloud
     140       67040 :     logical  :: cld_layer(pver)      ! Flag for cloud in layer
     141             : 
     142      519520 :     do i = 1, ncol
     143      486000 :       cld_found = .false.
     144    13122000 :       cld_layer(:) = cld(i, :) > 0.0_r8
     145    13608000 :       pmxrgn(i, :) = 0.0_r8
     146    13608000 :       pnm(i, :) = pint(i, :)*10._r8
     147      486000 :       n = 1
     148    12410158 :       do k = 1, pver
     149    12410158 :         if (cld_layer(k) .and. .not. cld_found) then
     150      768424 :           cld_found = .true.
     151    11468688 :         else if (.not. cld_layer(k) .and. cld_found) then
     152      616745 :           cld_found = .false.
     153     4626767 :           if (count(cld_layer(k:pver)) == 0) then
     154      312954 :             exit
     155             :           end if
     156      303791 :           pmxrgn(i, n) = pnm(i, k)
     157      303791 :           n = n + 1
     158             :         end if
     159             :       end do
     160      486000 :       pmxrgn(i, n) = pnm(i, pverp)
     161      519520 :       nmxrgn(i) = n
     162             :     end do
     163       33520 :   end subroutine cldovrlap
     164             : 
     165             :   ! Evaluate cloud liquid water path clwp [g m-2]
     166             :   ! Original author: Author: J.T. Kiehl
     167       33520 :   subroutine cldclw(ncol, zi, clwp, tpw, hl)
     168             : 
     169             :     ! Input arguments
     170             :     integer, intent(in) :: ncol                    ! number of atmospheric columns
     171             : 
     172             :     real(r8), intent(in) :: zi(pcols, pverp)       ! height at layer interfaces(m)
     173             :     real(r8), intent(in) :: tpw(pcols)             ! total precipitable water (mm)
     174             : 
     175             :     ! Output arguments
     176             :     real(r8), intent(out) :: clwp(pcols, pver)     ! cloud liquid water path (g/m**2)
     177             :     real(r8), intent(out) :: hl(pcols)             ! liquid water scale height
     178             : 
     179             :     integer  :: i, k                  ! longitude, level indices
     180             :     real(r8) :: clwc0                 ! reference liquid water concentration (g/m**3)
     181             :     real(r8) :: emziohl(pcols, pverp) ! exp(-zi/hl)
     182             :     real(r8) :: rhl(pcols)            ! 1/hl
     183             : 
     184             :     ! Set reference liquid water concentration
     185       33520 :     clwc0 = 0.21_r8
     186             : 
     187             :     ! Diagnose liquid water scale height from precipitable water
     188      519520 :     do i = 1, ncol
     189      486000 :       hl(i) = 700.0_r8*log(max(tpw(i) + 1.0_r8, 1.0_r8))
     190      519520 :       rhl(i) = 1.0_r8/hl(i)
     191             :     end do
     192             : 
     193             :     ! Evaluate cloud liquid water path (vertical integral of exponential fn)
     194      938560 :     do k = 1, pverp
     195    14060560 :       do i = 1, ncol
     196    14027040 :         emziohl(i, k) = exp(-zi(i, k)*rhl(i))
     197             :       end do
     198             :     end do
     199      905040 :     do k = 1, pver
     200    13541040 :       do i = 1, ncol
     201    13507520 :         clwp(i, k) = clwc0*hl(i)*(emziohl(i, k + 1) - emziohl(i, k))
     202             :       end do
     203             :     end do
     204       33520 :   end subroutine cldclw
     205             : 
     206             : 
     207             :   ! Compute cloud water size
     208             :   ! analytic formula following the formulation originally developed by J. T. Kiehl
     209             :   ! Author: Phil Rasch
     210      140784 :   subroutine reltab(ncol, pver, tmelt, t, landfrac, landm, icefrac, snowh, rel)
     211             : 
     212             :     ! Input arguments
     213             :     integer,  intent(in) :: ncol
     214             :     integer,  intent(in) :: pver
     215             :     real(r8), intent(in) :: tmelt
     216             :     real(r8), intent(in) :: landfrac(:)      ! Land fraction
     217             :     real(r8), intent(in) :: landm(:)         ! Land fraction ramping to zero over ocean
     218             :     real(r8), intent(in) :: icefrac(:)       ! Ice fraction
     219             :     real(r8), intent(in) :: t(:, :)          ! Temperature [K]
     220             :     real(r8), intent(in) :: snowh(:)         ! Snow depth over land, water equivalent [m]
     221             : 
     222             :     ! Output arguments
     223             :     real(r8), intent(out) :: rel(:, :)       ! Liquid effective drop size (microns)
     224             : 
     225             :     integer i, k
     226             :     real(r8) :: rliqland      ! liquid drop size if over land
     227             :     real(r8) :: rliqocean     ! liquid drop size if over ocean
     228             :     real(r8) :: rliqice       ! liquid drop size if over sea ice
     229             : 
     230      140784 :     rliqocean = 14.0_r8
     231      140784 :     rliqice = 14.0_r8
     232      140784 :     rliqland = 8.0_r8
     233             : 
     234     3801168 :     do k = 1, pver
     235    56872368 :       do i = 1, ncol
     236             :         ! jrm Reworked effective radius algorithm
     237             :         ! Start with temperature-dependent value appropriate for continental air
     238             :         ! Note: findmcnew has a pressure dependence here
     239    53071200 :         rel(i, k) = rliqland + (rliqocean - rliqland)*min(1.0_r8, max(0.0_r8, (tmelt - t(i, k))*0.05_r8))
     240             :         ! Modify for snow depth over land
     241    53071200 :         rel(i, k) = rel(i, k) + (rliqocean - rel(i, k))*min(1.0_r8, max(0.0_r8, snowh(i)*10._r8))
     242             :         ! Ramp between polluted value over land to clean value over ocean.
     243    53071200 :         rel(i, k) = rel(i, k) + (rliqocean - rel(i, k))*min(1.0_r8, max(0.0_r8, 1.0_r8 - landm(i)))
     244             :         ! Ramp between the resultant value and a sea ice value in the presence of ice.
     245    56731584 :         rel(i, k) = rel(i, k) + (rliqice - rel(i, k))*min(1.0_r8, max(0.0_r8, icefrac(i)))
     246             :         ! end jrm
     247             :       end do
     248             :     end do
     249      140784 :   end subroutine reltab
     250             : 
     251      140784 :   subroutine reitab(ncol, pver, t, re)
     252             : 
     253             :     integer, intent(in) :: ncol
     254             :     integer, intent(in) :: pver
     255             :     real(r8), intent(in) :: t(:, :)
     256             :     real(r8), intent(out) :: re(:, :)
     257             :     integer, parameter :: len_retab = 138
     258             :     real(r8), parameter :: min_retab = 136._r8
     259             :     real(r8) :: retab(len_retab)
     260             :     real(r8) :: corr
     261             :     integer :: i
     262             :     integer :: k
     263             :     integer :: index
     264             :     !
     265             :     !       Tabulated values of re(T) in the temperature interval
     266             :     !       180 K -- 274 K; hexagonal columns assumed:
     267             :     !
     268             :     !       Modified for pmc formation: 136K -- 274K
     269             :     !
     270             :     data retab / &
     271             :       0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, &
     272             :       0.055_r8, 0.06_r8, 0.07_r8, 0.08_r8, 0.09_r8, 0.1_r8, &
     273             :       0.2_r8, 0.3_r8, 0.40_r8, 0.50_r8, 0.60_r8, 0.70_r8, &
     274             :       0.8_r8, 0.9_r8, 1.0_r8, 1.1_r8, 1.2_r8, 1.3_r8, &
     275             :       1.4_r8, 1.5_r8, 1.6_r8, 1.8_r8, 2.0_r8, 2.2_r8, &
     276             :       2.4_r8, 2.6_r8, 2.8_r8, 3.0_r8, 3.2_r8, 3.5_r8, &
     277             :       3.8_r8, 4.1_r8, 4.4_r8, 4.7_r8, 5.0_r8, 5.3_r8, &
     278             :       5.6_r8, &
     279             :       5.92779_r8, 6.26422_r8, 6.61973_r8, 6.99539_r8, 7.39234_r8, &
     280             :       7.81177_r8, 8.25496_r8, 8.72323_r8, 9.21800_r8, 9.74075_r8, 10.2930_r8, &
     281             :       10.8765_r8, 11.4929_r8, 12.1440_r8, 12.8317_r8, 13.5581_r8, 14.2319_r8, &
     282             :       15.0351_r8, 15.8799_r8, 16.7674_r8, 17.6986_r8, 18.6744_r8, 19.6955_r8, &
     283             :       20.7623_r8, 21.8757_r8, 23.0364_r8, 24.2452_r8, 25.5034_r8, 26.8125_r8, &
     284             :       27.7895_r8, 28.6450_r8, 29.4167_r8, 30.1088_r8, 30.7306_r8, 31.2943_r8, &
     285             :       31.8151_r8, 32.3077_r8, 32.7870_r8, 33.2657_r8, 33.7540_r8, 34.2601_r8, &
     286             :       34.7892_r8, 35.3442_r8, 35.9255_r8, 36.5316_r8, 37.1602_r8, 37.8078_r8, &
     287             :       38.4720_r8, 39.1508_r8, 39.8442_r8, 40.5552_r8, 41.2912_r8, 42.0635_r8, &
     288             :       42.8876_r8, 43.7863_r8, 44.7853_r8, 45.9170_r8, 47.2165_r8, 48.7221_r8, &
     289             :       50.4710_r8, 52.4980_r8, 54.8315_r8, 57.4898_r8, 60.4785_r8, 63.7898_r8, &
     290             :       65.5604_r8, 71.2885_r8, 75.4113_r8, 79.7368_r8, 84.2351_r8, 88.8833_r8, &
     291             :       93.6658_r8, 98.5739_r8, 103.603_r8, 108.752_r8, 114.025_r8, 119.424_r8, &
     292             :       124.954_r8, 130.630_r8, 136.457_r8, 142.446_r8, 148.608_r8, 154.956_r8, &
     293             :       161.503_r8, 168.262_r8, 175.248_r8, 182.473_r8, 189.952_r8, 197.699_r8, &
     294             :       205.728_r8, 214.055_r8, 222.694_r8, 231.661_r8, 240.971_r8, 250.639_r8/
     295             :     save retab
     296             : 
     297     3801168 :     do k = 1, pver
     298    56872368 :       do i = 1, ncol
     299    53071200 :         index = int(t(i, k) - min_retab)
     300    53071200 :         index = min(max(index, 1), len_retab - 1)
     301    53071200 :         corr = t(i, k) - int(t(i, k))
     302   159213600 :         re(i, k) = retab(index)*(1._r8 - corr) &
     303   215945184 :                    + retab(index + 1)*corr
     304             :         !           re(i,k) = amax1(amin1(re(i,k),30.),10.)
     305             :       end do
     306             :     end do
     307      140784 :   end subroutine reitab
     308             : 
     309             : end module cloud_optical_properties

Generated by: LCOV version 1.14