cam6_4_098: CAM updates to bring in CCPP-ized RRTMGP longwave modules

.gitmodules

@@ -35,8 +35,8 @@
 
 [submodule "atmos_phys"]
 	path = src/atmos_phys
-	url = https://github.com/ESCOMP/atmospheric_physics
-        fxtag = atmos_phys0_13_000
+	url = https://github.com/peverwhee/atmospheric_physics
+        fxtag = 55295a4734ceed60fd696968c0fd31709ab9ab98
         fxrequired = AlwaysRequired
 	fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics
 

bld/configure

@@ -2146,6 +2146,8 @@ sub write_filepath
         }
         print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp-kernels\n";
         print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte-kernels\n";
+        print $fh "$camsrcdir/src/atmos_phys/schemes/rrtmgp\n";
+        print $fh "$camsrcdir/src/atmos_phys/schemes/rrtmgp/objects\n";
     }
 
     if ($clubb_sgs) {
@@ -2177,6 +2179,7 @@ sub write_filepath
     print $fh "$camsrcdir/src/atmos_phys/schemes/conservation_adjust/check_energy\n";
     print $fh "$camsrcdir/src/atmos_phys/schemes/conservation_adjust/dme_adjust\n";
     print $fh "$camsrcdir/src/atmos_phys/schemes/hack_shallow\n";
+    print $fh "$camsrcdir/src/atmos_phys/schemes/rrtmgp/utils\n";
     print $fh "$camsrcdir/src/atmos_phys/schemes/rasch_kristjansson\n";
     print $fh "$camsrcdir/src/atmos_phys/schemes/utilities\n";
     print $fh "$camsrcdir/src/atmos_phys/schemes/rayleigh_friction\n";

src/physics/cam/cloud_rad_props.F90

@@ -37,6 +37,7 @@ module cloud_rad_props
    get_snow_optics_sw,            &
    snow_cloud_get_rad_props_lw,   &
    get_grau_optics_sw,            &
+   get_mu_lambda_weights,         &
    grau_cloud_get_rad_props_lw
 
 
@@ -77,15 +78,26 @@ module cloud_rad_props
 contains
 !==============================================================================
 
-subroutine cloud_rad_props_init()
-
+subroutine cloud_rad_props_init(nmu_out, nlambda_out, n_g_d_out, &
+                  abs_lw_liq_out, abs_lw_ice_out, g_mu_out, g_lambda_out, &
+                  g_d_eff_out, tiny_out)
    use netcdf
    use spmd_utils,     only: masterproc
    use ioFileMod,      only: getfil
    use error_messages, only: handle_ncerr
+   use cam_abortutils, only: handle_allocate_error
 #if ( defined SPMD )
    use mpishorthand
 #endif
+   integer, intent(out) :: nmu_out
+   integer, intent(out) :: nlambda_out
+   integer, intent(out) :: n_g_d_out
+   real(r8), allocatable, intent(out) :: abs_lw_liq_out(:,:,:)
+   real(r8), allocatable, intent(out) :: abs_lw_ice_out(:,:)
+   real(r8), allocatable, intent(out) :: g_mu_out(:)
+   real(r8), allocatable, intent(out) :: g_lambda_out(:,:)
+   real(r8), allocatable, intent(out) :: g_d_eff_out(:)
+   real(r8),              intent(out) :: tiny_out
 
    character(len=256) :: liquidfile
    character(len=256) :: icefile
@@ -103,6 +115,7 @@ subroutine cloud_rad_props_init()
 
    integer :: err
    character(len=*), parameter :: sub = 'cloud_rad_props_init'
+   character(len=512) :: errmsg
 
    liquidfile = liqopticsfile
    icefile = iceopticsfile
@@ -278,6 +291,26 @@ subroutine cloud_rad_props_init()
    call mpibcast(abs_lw_ice, n_g_d*nlwbands, mpir8, 0, mpicom, ierr)
 #endif
 
+   ! Set output variables
+   tiny_out = tiny
+   nmu_out = nmu
+   nlambda_out = nlambda
+   n_g_d_out = n_g_d
+   allocate(abs_lw_liq_out(nmu,nlambda,nlwbands), stat=ierr, errmsg=errmsg)
+   call handle_allocate_error(ierr, sub, 'abs_lw_liq_out')
+   abs_lw_liq_out = abs_lw_liq
+   allocate(abs_lw_ice_out(n_g_d,nlwbands), stat=ierr, errmsg=errmsg)
+   call handle_allocate_error(ierr, sub, 'abs_lw_ice_out')
+   abs_lw_ice_out = abs_lw_ice
+   allocate(g_mu_out(nmu), stat=ierr, errmsg=errmsg)
+   call handle_allocate_error(ierr, sub, 'g_mu_out')
+   g_mu_out = g_mu
+   allocate(g_lambda_out(nmu,nlambda), stat=ierr, errmsg=errmsg)
+   call handle_allocate_error(ierr, sub, 'g_lambda_out')
+   g_lambda_out = g_lambda
+   allocate(g_d_eff_out(n_g_d), stat=ierr, errmsg=errmsg)
+   call handle_allocate_error(ierr, sub, 'g_d_eff_out')
+   g_d_eff_out = g_d_eff
    return
 
 end subroutine cloud_rad_props_init
@@ -728,28 +761,21 @@ end subroutine gam_liquid_sw
 !==============================================================================
 
 subroutine get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts)
+  use radiation_utils, only: get_mu_lambda_weights_ccpp
   real(r8), intent(in) :: lamc   ! prognosed value of lambda for cloud
   real(r8), intent(in) :: pgam   ! prognosed value of mu for cloud
   ! Output interpolation weights. Caller is responsible for freeing these.
   type(interp_type), intent(out) :: mu_wgts
   type(interp_type), intent(out) :: lambda_wgts
 
-  integer :: ilambda
-  real(r8) :: g_lambda_interp(nlambda)
-
-  ! Make interpolation weights for mu.
-  ! (Put pgam in a temporary array for this purpose.)
-  call lininterp_init(g_mu, nmu, [pgam], 1, extrap_method_bndry, mu_wgts)
-
-  ! Use mu weights to interpolate to a row in the lambda table.
-  do ilambda = 1, nlambda
-     call lininterp(g_lambda(:,ilambda), nmu, &
-          g_lambda_interp(ilambda:ilambda), 1, mu_wgts)
-  end do
+  character(len=512) :: errmsg
+  integer            :: errflg
 
-  ! Make interpolation weights for lambda.
-  call lininterp_init(g_lambda_interp, nlambda, [lamc], 1, &
-       extrap_method_bndry, lambda_wgts)
+  call get_mu_lambda_weights_ccpp(nmu, nlambda, g_mu, g_lambda, lamc, pgam, mu_wgts, &
+          lambda_wgts, errmsg, errflg)
+  if (errflg /= 0) then
+     call endrun('get_mu_lambda_weights: ERROR message: '//errmsg)
+  end if
 
 end subroutine get_mu_lambda_weights
 

src/physics/cam/radheat.F90

@@ -82,6 +82,8 @@ subroutine radheat_tend(state, pbuf,  ptend, qrl, qrs, fsns, &
 #if ( defined OFFLINE_DYN )
    use metdata, only: met_rlx, met_srf_feedback
 #endif
+   use calculate_net_heating, only: calculate_net_heating_run
+   use cam_abortutils,        only: endrun
 !-----------------------------------------------------------------------
 ! Compute net radiative heating from qrs and qrl, and the associated net
 ! boundary flux.
@@ -91,7 +93,7 @@ subroutine radheat_tend(state, pbuf,  ptend, qrl, qrs, fsns, &
    type(physics_state), intent(in)  :: state             ! Physics state variables
 
    type(physics_buffer_desc), pointer :: pbuf(:)
-   type(physics_ptend), intent(out) :: ptend             ! indivdual parameterization tendencie
+   type(physics_ptend), intent(out) :: ptend             ! individual parameterization tendencies
    real(r8),            intent(in)  :: qrl(pcols,pver)   ! longwave heating
    real(r8),            intent(in)  :: qrs(pcols,pver)   ! shortwave heating
    real(r8),            intent(in)  :: fsns(pcols)       ! Surface solar absorbed flux
@@ -105,26 +107,40 @@ subroutine radheat_tend(state, pbuf,  ptend, qrl, qrs, fsns, &
 ! Local variables
    integer :: i, k
    integer :: ncol
+   character(len=512) :: errmsg
+   integer            :: errflg
 !-----------------------------------------------------------------------
 
+   ! Set error variables
+   errmsg = ''
+   errflg = 0
+
    ncol = state%ncol
 
    call physics_ptend_init(ptend,state%psetcols, 'radheat', ls=.true.)
 
+   ! REMOVECAM no longer need once CAM is retired and pcols doesn't exist
+   ptend%s(:,:) = 0._r8
+   net_flx(:) = 0._r8
+   ! END_REMOVECAM
+
 #if ( defined OFFLINE_DYN )
    ptend%s(:ncol,:) = 0._r8
    do k = 1,pver
      if (met_rlx(k) < 1._r8 .or. met_srf_feedback) then
        ptend%s(:ncol,k) = (qrs(:ncol,k) + qrl(:ncol,k))
      endif
    enddo
+   call calculate_net_heating_run(ncol, ptend%s(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns(:ncol), &
+                fsnt(:ncol), flns(:ncol), flnt(:ncol), .true., net_flx(:ncol), errmsg, errflg)
 #else
-   ptend%s(:ncol,:) = (qrs(:ncol,:) + qrl(:ncol,:))
+   call calculate_net_heating_run(ncol, ptend%s(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns(:ncol), &
+                fsnt(:ncol), flns(:ncol), flnt(:ncol), .false., net_flx(:ncol), errmsg, errflg)
 #endif
 
-   do i = 1, ncol
-      net_flx(i) = fsnt(i) - fsns(i) - flnt(i) + flns(i)
-   end do
+   if (errflg /= 0) then
+      call endrun('ERROR - failure during calculate_net_heating_run. Message: "'//errmsg//'"')
+   end if
 
 end subroutine radheat_tend
 

src/physics/rrtmg/radiation.F90

@@ -382,6 +382,15 @@ subroutine radiation_init(pbuf2d)
    integer :: history_budget_histfile_num ! output history file number for budget fields
    integer :: err
 
+   ! Cloud optics variables
+   integer :: nmu, n_g_d, nlambda
+   real(kind=r8), allocatable :: abs_lw_ice(:,:)
+   real(kind=r8), allocatable :: abs_lw_liq(:,:,:)
+   real(kind=r8), allocatable :: g_lambda(:,:)
+   real(kind=r8), allocatable :: g_mu(:)
+   real(kind=r8), allocatable :: g_d_eff(:)
+   real(kind=r8) :: tiny
+
    integer :: dtime
    !-----------------------------------------------------------------------
 
@@ -390,7 +399,8 @@ subroutine radiation_init(pbuf2d)
    call rad_data_init(pbuf2d) ! initialize output fields for offline driver
    call radsw_init()
    call radlw_init()
-   call cloud_rad_props_init()
+   call cloud_rad_props_init(nmu, nlambda, n_g_d, abs_lw_liq, abs_lw_ice, &
+                             g_mu, g_lambda, g_d_eff, tiny)
 
    cld_idx      = pbuf_get_index('CLD')
    cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err)

src/physics/rrtmgp/mcica_subcol_gen.F90

@@ -36,126 +36,12 @@ module mcica_subcol_gen
 private
 save
 
-public :: mcica_subcol_lw, mcica_subcol_sw
+public :: mcica_subcol_sw
 
 !========================================================================================
 contains
 !========================================================================================
 
-subroutine mcica_subcol_lw( &
-   kdist, nbnd, ngpt, ncol, nver,           &
-   changeseed, pmid, cldfrac, tauc, taucmcl )
-
-   ! Arrays use CAM vertical index convention: index increases from top to bottom.
-   ! This index ordering is assumed in the maximum-random overlap algorithm which starts
-   ! at the top of a column and marches down, with each layer depending on the state
-   ! of the layer above it.
-   !
-   ! For GCM mode, changeseed must be offset between LW and SW by at least the
-   ! number of subcolumns
-
-   ! arguments
-   class(ty_gas_optics_rrtmgp), intent(in) :: kdist  ! spectral information
-   integer,  intent(in)  :: nbnd                     ! number of spectral bands
-   integer,  intent(in)  :: ngpt                     ! number of subcolumns (g-point intervals)
-   integer,  intent(in)  :: ncol                     ! number of columns
-   integer,  intent(in)  :: nver                     ! number of layers
-   integer,  intent(in)  :: changeseed               ! if the subcolumn generator is called multiple times,
-                                                     ! permute the seed between each call.
-   real(r8), intent(in)  :: pmid(pcols,pver)         ! layer pressures (Pa)
-   real(r8), intent(in)  :: cldfrac(ncol,nver)       ! layer cloud fraction
-   real(r8), intent(in)  :: tauc(nbnd,ncol,nver)     ! cloud optical depth
-   real(r8), intent(out) :: taucmcl(ngpt,ncol,nver)  ! subcolumn cloud optical depth [mcica]
-
-   ! Local variables
-
-   integer :: i, isubcol, k, n
-
-   real(r8), parameter :: cldmin = 1.0e-80_r8  ! min cloud fraction
-   real(r8) :: cldf(ncol,nver)      ! cloud fraction clipped to cldmin
-
-   type(ShrKissRandGen) :: kiss_gen  ! KISS RNG object
-   integer  :: kiss_seed(ncol,4)
-   real(r8) :: rand_num_1d(ncol,1)   ! random number (kissvec)
-   real(r8) :: rand_num(ncol,nver)   ! random number (kissvec)
-
-   real(r8) :: cdf(ngpt,ncol,nver)   ! random numbers
-   logical  :: iscloudy(ngpt,ncol,nver)   ! flag that says whether a gridbox is cloudy
-   !------------------------------------------------------------------------------------------
-
-   ! clip cloud fraction
-   cldf(:,:) = cldfrac(:ncol,:)
-   where (cldf(:,:) < cldmin)
-      cldf(:,:) = 0._r8
-   end where
-
-   ! Create a seed that depends on the state of the columns.
-   ! Use pmid from bottom four layers.
-   do i = 1, ncol
-      kiss_seed(i,1) = (pmid(i,pver)   - int(pmid(i,pver)))    * 1000000000
-      kiss_seed(i,2) = (pmid(i,pver-1) - int(pmid(i,pver-1)))  * 1000000000
-      kiss_seed(i,3) = (pmid(i,pver-2) - int(pmid(i,pver-2)))  * 1000000000
-      kiss_seed(i,4) = (pmid(i,pver-3) - int(pmid(i,pver-3)))  * 1000000000
-   end do
-
-   ! create the RNG object
-   kiss_gen = ShrKissRandGen(kiss_seed)
-
-   ! Advance randum number generator by changeseed values
-   do i = 1, changeSeed
-      call kiss_gen%random(rand_num_1d)
-   end do
-
-   ! Generate random numbers in each subcolumn at every level
-   do isubcol = 1,ngpt
-      call kiss_gen%random(rand_num)
-      cdf(isubcol,:,:) = rand_num(:,:)
-   enddo
-
-   ! Maximum-Random overlap
-   ! i) pick a random number for top layer.
-   ! ii) walk down the column:
-   !    - if the layer above is cloudy, use the same random number as in the layer above
-   !    - if the layer above is clear, use a new random number
-
-   do k = 2, nver
-      do i = 1, ncol
-         do isubcol = 1, ngpt
-            if (cdf(isubcol,i,k-1) > 1._r8 - cldf(i,k-1) ) then
-               cdf(isubcol,i,k) = cdf(isubcol,i,k-1)
-            else
-               cdf(isubcol,i,k) = cdf(isubcol,i,k) * (1._r8 - cldf(i,k-1))
-            end if
-         end do
-      end do
-   end do
-
-   do k = 1, nver
-      iscloudy(:,:,k) = (cdf(:,:,k) >= 1._r8 - spread(cldf(:,k), dim=1, nCopies=ngpt) )
-   end do
-
-   ! -- generate subcolumns for homogeneous clouds -----
-   ! where there is a cloud, set the subcolumn cloud properties;
-   ! incoming tauc should be in-cloud quantites and not grid-averaged quantities
-   do k = 1,nver
-      do i = 1,ncol
-         do isubcol = 1,ngpt
-            if (iscloudy(isubcol,i,k) .and. (cldf(i,k) > 0._r8) ) then
-               n = kdist%convert_gpt2band(isubcol)
-               taucmcl(isubcol,i,k) = tauc(n,i,k)
-            else
-               taucmcl(isubcol,i,k) = 0._r8
-            end if
-         end do
-      end do
-   end do
-
-   call kiss_gen%finalize()
-
-end subroutine mcica_subcol_lw
-
-!========================================================================================
-
 subroutine mcica_subcol_sw( &
    kdist, nbnd, ngpt, ncol, nlay, nver, changeseed, &
    pmid, cldfrac, tauc, ssac, asmc,     &