LCOV - code coverage report
Current view: | top level - physics/cam - oldcloud_optics.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 9 | 111 | 8.1 %
Date: | 2024-12-17 22:39:59 |  | Functions: | 1 | 4 | 25.0 %

              Line data    Source code
           1             : module oldcloud_optics
           2             :
           3             : !------------------------------------------------------------------------------------------------
           4             : !------------------------------------------------------------------------------------------------
           5             :
           6             : use shr_kind_mod,     only: r8 => shr_kind_r8
           7             : use ppgrid,           only: pcols, pver, pverp
           8             : use physics_types,    only: physics_state
           9             : use physics_buffer,   only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field
          10             : use constituents,     only: cnst_get_ind
          11             : use physconst,        only: gravit
          12             : use radconstants,     only: nlwbands
          13             : use ebert_curry_ice_optics, only: scalefactor
          14             :
          15             : use cam_abortutils,   only: endrun
          16             :
          17             : implicit none
          18             : private
          19             : save
          20             :
          21             : public :: &
          22             :    oldcloud_init,            &
          23             :    oldcloud_lw,              &
          24             :    old_liq_get_rad_props_lw, &
          25             :    old_ice_get_rad_props_lw
          26             :
          27             : integer :: nmu, nlambda
          28             : real(r8), allocatable :: g_mu(:)           ! mu samples on grid
          29             : real(r8), allocatable :: g_lambda(:,:)     ! lambda scale samples on grid
          30             : real(r8), allocatable :: ext_sw_liq(:,:,:)
          31             : real(r8), allocatable :: ssa_sw_liq(:,:,:)
          32             : real(r8), allocatable :: asm_sw_liq(:,:,:)
          33             : real(r8), allocatable :: abs_lw_liq(:,:,:)
          34             :
          35             : integer :: n_g_d
          36             : real(r8), allocatable :: g_d_eff(:)        ! radiative effective diameter samples on grid
          37             : real(r8), allocatable :: ext_sw_ice(:,:)
          38             : real(r8), allocatable :: ssa_sw_ice(:,:)
          39             : real(r8), allocatable :: asm_sw_ice(:,:)
          40             : real(r8), allocatable :: abs_lw_ice(:,:)
          41             :
          42             : ! Minimum cloud amount (as a fraction of the grid-box area) to
          43             : ! distinguish from clear sky
          44             : real(r8), parameter :: cldmin = 1.0e-80_r8
          45             :
          46             : ! Decimal precision of cloud amount (0 -> preserve full resolution;
          47             : ! 10^-n -> preserve n digits of cloud amount)
          48             : real(r8), parameter :: cldeps = 0.0_r8
          49             :
          50             : ! indexes into pbuf
          51             : integer :: iciwp_idx   = 0
          52             : integer :: iclwp_idx   = 0
          53             : integer :: cld_idx     = 0
          54             : integer :: rel_idx     = 0
          55             : integer :: rei_idx     = 0
          56             :
          57             : ! indexes into constituents for old optics
          58             : integer :: &
          59             :    ixcldice, & ! cloud ice water index
          60             :    ixcldliq    ! cloud liquid water index
          61             :
          62             :
          63             : !==============================================================================
          64             : contains
          65             : !==============================================================================
          66             :
          67        1536 : subroutine oldcloud_init()
          68             :
          69             :
          70             :    integer :: err
          71             :
          72        1536 :    iciwp_idx  = pbuf_get_index('ICIWP',errcode=err)
          73        1536 :    iclwp_idx  = pbuf_get_index('ICLWP',errcode=err)
          74        1536 :    cld_idx    = pbuf_get_index('CLD')
          75        1536 :    rel_idx    = pbuf_get_index('REL')
          76        1536 :    rei_idx    = pbuf_get_index('REI')
          77             :
          78             :    ! old optics
          79        1536 :    call cnst_get_ind('CLDICE', ixcldice)
          80        1536 :    call cnst_get_ind('CLDLIQ', ixcldliq)
          81             :
          82        1536 : end subroutine oldcloud_init
          83             :
          84             : !==============================================================================
          85             :
          86           0 : subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp)
          87             :
          88             :    type(physics_state), intent(in) :: state
          89             :    type(physics_buffer_desc),pointer :: pbuf(:)
          90             :    real(r8),            intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer
          91             :    logical,intent(in)              :: oldwp ! use old definition of waterpath
          92             :
          93             :
          94             :    real(r8) :: gicewp(pcols,pver)
          95             :    real(r8) :: gliqwp(pcols,pver)
          96             :    real(r8) :: cicewp(pcols,pver)
          97             :    real(r8) :: cliqwp(pcols,pver)
          98             :    real(r8) :: ficemr(pcols,pver)
          99             :    real(r8) :: cwp(pcols,pver)
         100             :    real(r8) :: cldtau(pcols,pver)
         101             :
         102           0 :    real(r8), pointer, dimension(:,:) :: cldn
         103           0 :    real(r8), pointer, dimension(:,:) :: rei
         104             :    integer :: ncol, itim_old, lwband, i, k, lchnk
         105           0 :    real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
         106             :
         107             :    real(r8) :: kabs, kabsi
         108             :    real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
         109             :
         110             :
         111           0 :    ncol = state%ncol
         112           0 :    lchnk = state%lchnk
         113             :
         114           0 :    itim_old  =  pbuf_old_tim_idx()
         115           0 :    call pbuf_get_field(pbuf, rei_idx,   rei)
         116           0 :    call pbuf_get_field(pbuf, cld_idx,   cldn,   start=(/1,1,itim_old/), kount=(/pcols,pver,1/))
         117             :
         118           0 :    if (oldwp) then
         119           0 :      do k=1,pver
         120           0 :          do i = 1,ncol
         121           0 :             gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8  ! Grid box ice water path.
         122           0 :             gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8  ! Grid box liquid water path.
         123           0 :             cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud ice water path.
         124           0 :             cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud liquid water path.
         125             :             ficemr(i,k) = state%q(i,k,ixcldice) /                 &
         126           0 :                  max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq)))
         127             :          end do
         128             :      end do
         129           0 :      cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
         130             :    else
         131           0 :       if (iclwp_idx<=0 .or. iciwp_idx<=0) then
         132           0 :          call endrun('oldcloud_lw: oldwp must be set to true since ICIWP and/or ICLWP were not found in pbuf')
         133             :       endif
         134           0 :       call pbuf_get_field(pbuf, iclwp_idx, iclwpth)
         135           0 :       call pbuf_get_field(pbuf, iciwp_idx, iciwpth)
         136           0 :       do k=1,pver
         137           0 :          do i = 1,ncol
         138           0 :             cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k)
         139           0 :             ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k)))
         140             :          end do
         141             :       end do
         142             :    endif
         143             :
         144           0 :    do k=1,pver
         145           0 :        do i=1,ncol
         146             :
         147             :           !note that optical properties for ice valid only
         148             :           !in range of 13 > rei > 130 micron (Ebert and Curry 92)
         149           0 :           kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
         150           0 :           kabs = kabsl*(1._r8-ficemr(i,k)) + kabsi*ficemr(i,k)
         151           0 :           cldtau(i,k) = kabs*cwp(i,k)
         152             :        end do
         153             :    end do
         154             : !
         155           0 :    do lwband = 1,nlwbands
         156           0 :       cld_abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
         157             :    enddo
         158             :
         159           0 : end subroutine oldcloud_lw
         160             :
         161             : !==============================================================================
         162             :
         163           0 : subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp)
         164             :
         165             :    type(physics_state), intent(in)  :: state
         166             :    type(physics_buffer_desc),pointer  :: pbuf(:)
         167             :    real(r8), intent(out) :: abs_od(nlwbands,pcols,pver)
         168             :    logical, intent(in) :: oldliqwp
         169             :
         170             :    real(r8) :: gicewp(pcols,pver)
         171             :    real(r8) :: gliqwp(pcols,pver)
         172             :    real(r8) :: cicewp(pcols,pver)
         173             :    real(r8) :: cliqwp(pcols,pver)
         174             :    real(r8) :: ficemr(pcols,pver)
         175             :    real(r8) :: cwp(pcols,pver)
         176             :    real(r8) :: cldtau(pcols,pver)
         177             :
         178           0 :    real(r8), pointer, dimension(:,:) :: cldn
         179           0 :    real(r8), pointer, dimension(:,:) :: rei
         180             :    integer :: ncol, itim_old, lwband, i, k, lchnk
         181             :
         182             :    real(r8) :: kabs, kabsi
         183             :    real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
         184             :
         185           0 :    real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
         186             :
         187           0 :    ncol=state%ncol
         188           0 :    lchnk = state%lchnk
         189             :
         190           0 :    itim_old  =  pbuf_old_tim_idx()
         191           0 :    call pbuf_get_field(pbuf, rei_idx,   rei)
         192           0 :    call pbuf_get_field(pbuf, cld_idx,   cldn,   start=(/1,1,itim_old/), kount=(/pcols,pver,1/))
         193             :
         194           0 :    if (oldliqwp) then
         195           0 :      do k=1,pver
         196           0 :          do i = 1,ncol
         197           0 :             gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8  ! Grid box ice water path.
         198           0 :             gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8  ! Grid box liquid water path.
         199           0 :             cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud ice water path.
         200           0 :             cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud liquid water path.
         201             :             ficemr(i,k) = state%q(i,k,ixcldice) /                 &
         202           0 :                  max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq)))
         203             :          end do
         204             :      end do
         205           0 :      cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
         206             :    else
         207           0 :       if (iclwp_idx<=0 .or. iciwp_idx<=0) then
         208           0 :          call endrun('old_liq_get_rad_props_lw: oldliqwp must be set to true since ICIWP and/or ICLWP were not found in pbuf')
         209             :       endif
         210           0 :       call pbuf_get_field(pbuf, iclwp_idx, iclwpth)
         211           0 :       call pbuf_get_field(pbuf, iciwp_idx, iciwpth)
         212           0 :       do k=1,pver
         213           0 :          do i = 1,ncol
         214           0 :             cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k)
         215           0 :             ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k)))
         216             :          end do
         217             :       end do
         218             :    endif
         219             :
         220             :
         221           0 :    do k=1,pver
         222           0 :        do i=1,ncol
         223             :
         224             :           ! Note from Andrew Conley:
         225             :           !  Optics for RK no longer supported, This is constructed to get
         226             :           !  close to bit for bit.  Otherwise we could simply use liquid water path
         227             :           !note that optical properties for ice valid only
         228             :           !in range of 13 > rei > 130 micron (Ebert and Curry 92)
         229           0 :           kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
         230           0 :           kabs = kabsl*(1._r8-ficemr(i,k)) ! + kabsi*ficemr(i,k)
         231           0 :           cldtau(i,k) = kabs*cwp(i,k)
         232             :        end do
         233             :    end do
         234             :
         235           0 :    do lwband = 1,nlwbands
         236           0 :       abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
         237             :    enddo
         238             :
         239             :
         240           0 : end subroutine old_liq_get_rad_props_lw
         241             :
         242             : !==============================================================================
         243             :
         244           0 : subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp)
         245             :
         246             :    type(physics_state), intent(in)  :: state
         247             :    type(physics_buffer_desc),pointer  :: pbuf(:)
         248             :     real(r8), intent(out) :: abs_od(nlwbands,pcols,pver)
         249             :    logical, intent(in) :: oldicewp
         250             :
         251             :    real(r8) :: gicewp(pcols,pver)
         252             :    real(r8) :: gliqwp(pcols,pver)
         253             :    real(r8) :: cicewp(pcols,pver)
         254             :    real(r8) :: cliqwp(pcols,pver)
         255             :    real(r8) :: ficemr(pcols,pver)
         256             :    real(r8) :: cwp(pcols,pver)
         257             :    real(r8) :: cldtau(pcols,pver)
         258             :
         259           0 :    real(r8), pointer, dimension(:,:) :: cldn
         260           0 :    real(r8), pointer, dimension(:,:) :: rei
         261             :    integer :: ncol, itim_old, lwband, i, k, lchnk
         262             :
         263             :    real(r8) :: kabs, kabsi
         264             :    real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
         265             :
         266           0 :    real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
         267             :
         268             :
         269           0 :    ncol = state%ncol
         270           0 :    lchnk = state%lchnk
         271             :
         272           0 :    itim_old  =  pbuf_old_tim_idx()
         273           0 :    call pbuf_get_field(pbuf, rei_idx,   rei)
         274           0 :    call pbuf_get_field(pbuf, cld_idx,   cldn,   start=(/1,1,itim_old/), kount=(/pcols,pver,1/))
         275             :
         276           0 :    if(oldicewp) then
         277           0 :      do k=1,pver
         278           0 :          do i = 1,ncol
         279           0 :             gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8  ! Grid box ice water path.
         280           0 :             gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8  ! Grid box liquid water path.
         281           0 :             cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud ice water path.
         282           0 :             cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud liquid water path.
         283             :             ficemr(i,k) = state%q(i,k,ixcldice) /                 &
         284           0 :                  max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq)))
         285             :          end do
         286             :      end do
         287           0 :      cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
         288             :    else
         289           0 :       if (iclwp_idx<=0 .or. iciwp_idx<=0) then
         290           0 :          call endrun('old_ice_get_rad_props_lw: oldicewp must be set to true since ICIWP and/or ICLWP were not found in pbuf')
         291             :       endif
         292           0 :       call pbuf_get_field(pbuf, iclwp_idx, iclwpth)
         293           0 :       call pbuf_get_field(pbuf, iciwp_idx, iciwpth)
         294           0 :       do k=1,pver
         295           0 :          do i = 1,ncol
         296           0 :             cwp(i,k) = 1000.0_r8 *iciwpth(i,k) + 1000.0_r8 *iclwpth(i,k)
         297           0 :             ficemr(i,k) = 1000.0_r8*iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k)))
         298             :          end do
         299             :       end do
         300             :    endif
         301             :
         302           0 :    do k=1,pver
         303           0 :        do i=1,ncol
         304             :
         305             :           ! Note from Andrew Conley:
         306             :           !  Optics for RK no longer supported, This is constructed to get
         307             :           !  close to bit for bit.  Otherwise we could simply use ice water path
         308             :           !note that optical properties for ice valid only
         309             :           !in range of 13 > rei > 130 micron (Ebert and Curry 92)
         310           0 :           kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
         311           0 :           kabs =  kabsi*ficemr(i,k) ! kabsl*(1._r8-ficemr(i,k)) + kabsi*ficemr(i,k)
         312           0 :           cldtau(i,k) = kabs*cwp(i,k)
         313             :        end do
         314             :    end do
         315             :
         316           0 :    do lwband = 1,nlwbands
         317           0 :       abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
         318             :    enddo
         319             :
         320           0 : end subroutine old_ice_get_rad_props_lw
         321             :
         322             : !==============================================================================
         323             :
         324             : end module oldcloud_optics

Generated by: LCOV version 1.14