rrtmgp_lw_cloud_optics.F90

 
 
module rrtmgp_lw_cloud_optics
  use machine,                  only: kind_phys
  use mo_rte_kind,              only: wl
  use mo_cloud_optics,          only: ty_cloud_optics
  use rrtmgp_lw_gas_optics,     only: lw_gas_props
  use radiation_tools,          only: check_error_msg
  use netcdf
#ifdef MPI
  use mpi_f08
#endif
 
  implicit none
 
  type(ty_cloud_optics) :: lw_cloud_props   
  integer :: &
       nrghice_fromfilelw, nbandlw, nsize_liqlw, nsize_icelw, nsizereglw, &
       ncoeff_extlw, ncoeff_ssa_glw, nboundlw, npairslw
  real(kind_phys) :: &
       radliq_faclw,          & !< Factor for calculating LUT interpolation indices for liquid
       radice_faclw
  real(kind_phys), dimension(:,:), allocatable :: &
       lut_extliqlw,          & !< LUT shortwave liquid extinction coefficient  
       lut_ssaliqlw,          & !< LUT shortwave liquid single scattering albedo   
       lut_asyliqlw,          & !< LUT shortwave liquid asymmetry parameter  
       band_limscldlw
  real(kind_phys), dimension(:,:,:), allocatable :: &
       lut_exticelw,          & !< LUT shortwave ice extinction coefficient
       lut_ssaicelw,          & !< LUT shortwave ice single scattering albedo
       lut_asyicelw
  real(kind_phys), dimension(:), allocatable :: &
       pade_sizereg_extliqlw, & !< Particle size regime boundaries for shortwave liquid extinction 
 
       pade_sizereg_ssaliqlw, & 
       pade_sizereg_asyliqlw, & 
       pade_sizereg_exticelw, & 
       pade_sizereg_ssaicelw, & 
       pade_sizereg_asyicelw    
  real(kind_phys), dimension(:,:,:), allocatable :: &
       pade_extliqlw,         & !< PADE coefficients for shortwave liquid extinction
       pade_ssaliqlw,         & !< PADE coefficients for shortwave liquid single scattering albedo
       pade_asyliqlw
  real(kind_phys), dimension(:,:,:,:), allocatable :: &
       pade_exticelw,         & !< PADE coefficients for shortwave ice extinction
       pade_ssaicelw,         & !< PADE coefficients for shortwave ice single scattering albedo
       pade_asyicelw
  
  ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics
  real(kind_phys), parameter :: &
       absrain  = 0.33e-3, & 
       abssnow0 = 1.5,     & 
       abssnow1 = 2.34e-3    
  real(kind_phys) :: &
       radliq_lwrlw,         & !< Liquid particle size lower bound for LUT interpolation   
       radliq_uprlw,         & !< Liquid particle size upper bound for LUT interpolation
       radice_lwrlw,         & !< Ice particle size upper bound for LUT interpolation  
       radice_uprlw
 
contains
 
  ! ######################################################################################
  ! SUBROUTINE rrtmgp_lw_cloud_optics_init()
  ! ######################################################################################
  subroutine rrtmgp_lw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_clouds,         &
       doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot,      &
       errmsg, errflg)
 
    ! Inputs
    character(len=128),intent(in) :: &
         rrtmgp_root_dir,    & !< RTE-RRTMGP root directory
         rrtmgp_lw_file_clouds
 
    logical, intent(in) :: &
         doGP_cldoptics_PADE,& !< Use RRTMGP cloud-optics: PADE approximation?
         doGP_cldoptics_LUT
    integer, intent(inout) :: &
         nrghice
    type(mpi_comm), intent(in) :: &
         mpicomm
    integer, intent(in) :: & 
         mpirank,            & !< Current MPI rank
         mpiroot
 
    ! Outputs
    character(len=*), intent(out) :: &
         errmsg
    integer,          intent(out) :: &
         errflg
 
    ! Local variables
    integer :: dimID,varID,status,ncid,mpierr
    character(len=264) :: lw_cloud_props_file
 
    ! Initialize
    errmsg = ''
    errflg = 0
 
    ! Filenames are set in the physics_nml
    lw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_lw_file_clouds)
 
    ! #######################################################################################
    !
    ! Read dimensions for longwave cloud-optics fields...
    ! (ONLY master processor(0), if MPI enabled)
    !
    ! #######################################################################################
#ifdef MPI
    if (mpirank .eq. mpiroot) then
#endif
       write (*,*) 'Reading RRTMGP longwave cloud-optics metadata ... '
 
       ! Open file
       status = nf90_open(trim(lw_cloud_props_file), nf90_nowrite, ncid)
       
       ! Read dimensions
       status = nf90_inq_dimid(ncid, 'nband', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=nbandlw)
       status = nf90_inq_dimid(ncid, 'nrghice', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=nrghice_fromfilelw)
       status = nf90_inq_dimid(ncid, 'nsize_liq', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=nsize_liqlw)
       status = nf90_inq_dimid(ncid, 'nsize_ice', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=nsize_icelw)
       status = nf90_inq_dimid(ncid, 'nsizereg', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=nsizereglw)
       status = nf90_inq_dimid(ncid, 'ncoeff_ext', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=ncoeff_extlw)
       status = nf90_inq_dimid(ncid, 'ncoeff_ssa_g', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=ncoeff_ssa_glw)
       status = nf90_inq_dimid(ncid, 'nbound', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=nboundlw)
       status = nf90_inq_dimid(ncid, 'pair', dimid)
       status = nf90_inquire_dimension(ncid, dimid, len=npairslw)
 
#ifdef MPI
    endif ! On master processor
 
    ! Other processors waiting...
    call mpi_barrier(mpicomm, mpierr)
 
    ! #######################################################################################
    !
    ! Broadcast dimensions...
    ! (ALL processors)
    !
    ! #######################################################################################
    call mpi_bcast(nbandlw,            1, mpi_integer, mpiroot, mpicomm, mpierr)
    call mpi_bcast(nsize_liqlw,        1, mpi_integer, mpiroot, mpicomm, mpierr)
    call mpi_bcast(nsize_icelw,        1, mpi_integer, mpiroot, mpicomm, mpierr)
    call mpi_bcast(nsizereglw,         1, mpi_integer, mpiroot, mpicomm, mpierr)
    call mpi_bcast(ncoeff_extlw,       1, mpi_integer, mpiroot, mpicomm, mpierr)
    call mpi_bcast(ncoeff_ssa_glw,     1, mpi_integer, mpiroot, mpicomm, mpierr)
    call mpi_bcast(nboundlw,           1, mpi_integer, mpiroot, mpicomm, mpierr)
    call mpi_bcast(npairslw,           1, mpi_integer, mpiroot, mpicomm, mpierr)
#endif
 
    ! Has the number of ice-roughnesses to use been provided from the namelist?
    ! If so, override nrghice from cloud-optics file
    if (nrghice .ne. 0) nrghice_fromfilelw = nrghice
#ifdef MPI
    call mpi_bcast(nrghice_fromfilelw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
#endif
 
    ! #######################################################################################
    !
    ! Allocate space for arrays...
    ! (ALL processors)
    !
    ! #######################################################################################
    if (dogp_cldoptics_lut) then
       allocate(lut_extliqlw(nsize_liqlw, nbandlw))
       allocate(lut_ssaliqlw(nsize_liqlw, nbandlw))
       allocate(lut_asyliqlw(nsize_liqlw, nbandlw))
       allocate(lut_exticelw(nsize_icelw, nbandlw, nrghice_fromfilelw))
       allocate(lut_ssaicelw(nsize_icelw, nbandlw, nrghice_fromfilelw))
       allocate(lut_asyicelw(nsize_icelw, nbandlw, nrghice_fromfilelw))
    endif
    if (dogp_cldoptics_pade) then
       allocate(pade_extliqlw(nbandlw, nsizereglw,  ncoeff_extlw ))
       allocate(pade_ssaliqlw(nbandlw, nsizereglw,  ncoeff_ssa_glw))
       allocate(pade_asyliqlw(nbandlw, nsizereglw,  ncoeff_ssa_glw))
       allocate(pade_exticelw(nbandlw, nsizereglw,  ncoeff_extlw,   nrghice_fromfilelw))
       allocate(pade_ssaicelw(nbandlw, nsizereglw,  ncoeff_ssa_glw, nrghice_fromfilelw))
       allocate(pade_asyicelw(nbandlw, nsizereglw,  ncoeff_ssa_glw, nrghice_fromfilelw))
       allocate(pade_sizereg_extliqlw(nboundlw))
       allocate(pade_sizereg_ssaliqlw(nboundlw))
       allocate(pade_sizereg_asyliqlw(nboundlw))
       allocate(pade_sizereg_exticelw(nboundlw))
       allocate(pade_sizereg_ssaicelw(nboundlw))
       allocate(pade_sizereg_asyicelw(nboundlw))
    endif
    allocate(band_limscldlw(2,nbandlw))
       
    ! #######################################################################################
    !
    ! Read in data ...
    ! (ONLY master processor(0), if MPI enabled) 
    !
    ! #######################################################################################
#ifdef MPI
    if (mpirank .eq. mpiroot) then
#endif
       ! Read in fields from file
       if (dogp_cldoptics_lut) then
          write (*,*) 'Reading RRTMGP longwave cloud data (LUT) ... '
          status = nf90_inq_varid(ncid,'radliq_lwr',varid)
          status = nf90_get_var(ncid,varid,radliq_lwrlw)
          status = nf90_inq_varid(ncid,'radliq_upr',varid)
          status = nf90_get_var(ncid,varid,radliq_uprlw)
          status = nf90_inq_varid(ncid,'radliq_fac',varid)
          status = nf90_get_var(ncid,varid,radliq_faclw)
          status = nf90_inq_varid(ncid,'radice_lwr',varid)
          status = nf90_get_var(ncid,varid,radice_lwrlw)
          status = nf90_inq_varid(ncid,'radice_upr',varid)
          status = nf90_get_var(ncid,varid,radice_uprlw)
          status = nf90_inq_varid(ncid,'radice_fac',varid)
          status = nf90_get_var(ncid,varid,radice_faclw)
          status = nf90_inq_varid(ncid,'lut_extliq',varid)
          status = nf90_get_var(ncid,varid,lut_extliqlw)
          status = nf90_inq_varid(ncid,'lut_ssaliq',varid)
          status = nf90_get_var(ncid,varid,lut_ssaliqlw)
          status = nf90_inq_varid(ncid,'lut_asyliq',varid)
          status = nf90_get_var(ncid,varid,lut_asyliqlw)
          status = nf90_inq_varid(ncid,'lut_extice',varid)
          status = nf90_get_var(ncid,varid,lut_exticelw)
          status = nf90_inq_varid(ncid,'lut_ssaice',varid)
          status = nf90_get_var(ncid,varid,lut_ssaicelw)
          status = nf90_inq_varid(ncid,'lut_asyice',varid)
          status = nf90_get_var(ncid,varid,lut_asyicelw)
          status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varid)
          status = nf90_get_var(ncid,varid,band_limscldlw)
       endif
       if (dogp_cldoptics_pade) then
          write (*,*) 'Reading RRTMGP longwave cloud data (PADE) ... '
          status = nf90_inq_varid(ncid,'radliq_lwr',varid)
          status = nf90_get_var(ncid,varid,radliq_lwrlw)
          status = nf90_inq_varid(ncid,'radliq_upr',varid)
          status = nf90_get_var(ncid,varid,radliq_uprlw)
          status = nf90_inq_varid(ncid,'radliq_fac',varid)
          status = nf90_get_var(ncid,varid,radliq_faclw)
          status = nf90_inq_varid(ncid,'radice_lwr',varid)
          status = nf90_get_var(ncid,varid,radice_lwrlw)
          status = nf90_inq_varid(ncid,'radice_upr',varid)
          status = nf90_get_var(ncid,varid,radice_uprlw)
          status = nf90_inq_varid(ncid,'radice_fac',varid)
          status = nf90_get_var(ncid,varid,radice_faclw)
          status = nf90_inq_varid(ncid,'pade_extliq',varid)
          status = nf90_get_var(ncid,varid,pade_extliqlw)
          status = nf90_inq_varid(ncid,'pade_ssaliq',varid)
          status = nf90_get_var(ncid,varid,pade_ssaliqlw)
          status = nf90_inq_varid(ncid,'pade_asyliq',varid)
          status = nf90_get_var(ncid,varid,pade_asyliqlw)
          status = nf90_inq_varid(ncid,'pade_extice',varid)
          status = nf90_get_var(ncid,varid,pade_exticelw)
          status = nf90_inq_varid(ncid,'pade_ssaice',varid)
          status = nf90_get_var(ncid,varid,pade_ssaicelw)
          status = nf90_inq_varid(ncid,'pade_asyice',varid)
          status = nf90_get_var(ncid,varid,pade_asyicelw)
          status = nf90_inq_varid(ncid,'pade_sizreg_extliq',varid)
          status = nf90_get_var(ncid,varid,pade_sizereg_extliqlw)
          status = nf90_inq_varid(ncid,'pade_sizreg_ssaliq',varid)
          status = nf90_get_var(ncid,varid,pade_sizereg_ssaliqlw)
          status = nf90_inq_varid(ncid,'pade_sizreg_asyliq',varid)
          status = nf90_get_var(ncid,varid,pade_sizereg_asyliqlw)
          status = nf90_inq_varid(ncid,'pade_sizreg_extice',varid)
          status = nf90_get_var(ncid,varid,pade_sizereg_exticelw)
          status = nf90_inq_varid(ncid,'pade_sizreg_ssaice',varid)
          status = nf90_get_var(ncid,varid,pade_sizereg_ssaicelw)
          status = nf90_inq_varid(ncid,'pade_sizreg_asyice',varid)
          status = nf90_get_var(ncid,varid,pade_sizereg_asyicelw)
          status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varid)
          status = nf90_get_var(ncid,varid,band_limscldlw)
       endif
          
       ! Close file
       status = nf90_close(ncid)       
#ifdef MPI
    endif ! Master process
 
    ! Other processors waiting...
    call mpi_barrier(mpicomm, mpierr)
 
    ! #######################################################################################
    !
    ! Broadcast data... 
    ! (ALL processors)
    !
    ! #######################################################################################
 
    ! Real scalars
    call mpi_bcast(radliq_faclw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
    call mpi_bcast(radice_faclw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
    call mpi_bcast(radliq_lwrlw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
    call mpi_bcast(radliq_uprlw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
    call mpi_bcast(radice_lwrlw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
    call mpi_bcast(radice_uprlw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
 
    ! Real arrays
    call mpi_bcast(band_limscldlw, size(band_limscldlw),  &
         mpi_double_precision, mpiroot, mpicomm, mpierr)
    if (dogp_cldoptics_lut) then
       call mpi_bcast(lut_extliqlw, size(lut_extliqlw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(lut_ssaliqlw, size(lut_ssaliqlw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(lut_asyliqlw, size(lut_asyliqlw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(lut_exticelw, size(lut_exticelw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(lut_ssaicelw, size(lut_ssaicelw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(lut_asyicelw, size(lut_asyicelw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
    endif
    if (dogp_cldoptics_pade) then
       call mpi_bcast(pade_extliqlw, size(pade_extliqlw),                   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_ssaliqlw, size(pade_ssaliqlw),                   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_asyliqlw, size(pade_asyliqlw),                   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_exticelw, size(pade_exticelw),                   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_ssaicelw, size(pade_ssaicelw),                   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_asyicelw, size(pade_asyicelw),                   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_sizereg_extliqlw, size(pade_sizereg_extliqlw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_sizereg_ssaliqlw, size(pade_sizereg_ssaliqlw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_sizereg_asyliqlw, size(pade_sizereg_asyliqlw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_sizereg_exticelw, size(pade_sizereg_exticelw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_sizereg_ssaicelw, size(pade_sizereg_ssaicelw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
       call mpi_bcast(pade_sizereg_asyicelw, size(pade_sizereg_asyicelw),   &
            mpi_double_precision, mpiroot, mpicomm, mpierr)
    endif
#endif
 
    ! #######################################################################################
    !   
    ! Initialize RRTMGP DDT's...
    !
    ! #######################################################################################
    if (dogp_cldoptics_lut) then
       call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_limscldlw,      &
            radliq_lwrlw, radliq_uprlw, radliq_faclw, radice_lwrlw, radice_uprlw,           &
            radice_faclw, lut_extliqlw, lut_ssaliqlw, lut_asyliqlw, lut_exticelw,           &
            lut_ssaicelw, lut_asyicelw))
    endif
 
    if (dogp_cldoptics_pade) then
       call check_error_msg('lw_cloud_optics_init', lw_cloud_props%load(band_limscldlw,     &
            pade_extliqlw, pade_ssaliqlw, pade_asyliqlw, pade_exticelw, pade_ssaicelw,      &
            pade_asyicelw, pade_sizereg_extliqlw, pade_sizereg_ssaliqlw,                    &
            pade_sizereg_asyliqlw, pade_sizereg_exticelw, pade_sizereg_ssaicelw,            &
            pade_sizereg_asyicelw))
    endif
 
    call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice))
 
  end subroutine rrtmgp_lw_cloud_optics_init
end module rrtmgp_lw_cloud_optics