rrtmgp_lw_cloud_optics.F90

 
 
module rrtmgp_lw_cloud_optics
  use mo_rte_kind,              only: wl, wp
  use mo_cloud_optics_rrtmgp,   only: ty_cloud_optics => ty_cloud_optics_rrtmgp
  use rrtmgp_lw_gas_optics,     only: lw_gas_props
  use radiation_tools,          only: check_error_msg
  use netcdf
  use mpi_f08
 
  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(wp), 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(wp), dimension(:,:,:), allocatable :: &
       lut_exticelw,          & !< LUT shortwave ice extinction coefficient
       lut_ssaicelw,          & !< LUT shortwave ice single scattering albedo
       lut_asyicelw
  
  ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics
  real(wp), parameter :: &
       absrain  = 0.33e-3, & 
       abssnow0 = 1.5,     & 
       abssnow1 = 2.34e-3    
  real(wp) :: &
       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,         &
       nrghice, mpicomm, mpirank, mpiroot, is_initialized, errmsg, errflg)
 
    ! Inputs
    character(len=128),intent(in) :: &
         rrtmgp_root_dir,    & !< RTE-RRTMGP root directory
         rrtmgp_lw_file_clouds
 
    integer, intent(inout) :: &
         nrghice
    type(mpi_comm), intent(in) :: &
         mpicomm
    integer, intent(in) :: & 
         mpirank,            & !< Current MPI rank
         mpiroot
 
    ! Outputs
    logical,          intent(inout) :: &
         is_initialized
    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
 
    if (is_initialized) return
 
    ! 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)
    !
    ! #######################################################################################
    if (mpirank .eq. mpiroot) then
       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)
 
    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)
 
    ! 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
    call mpi_bcast(nrghice_fromfilelw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
 
    ! #######################################################################################
    !
    ! Allocate space for arrays...
    ! (ALL processors)
    !
    ! #######################################################################################
    if (.not. allocated(lut_extliqlw))   allocate(lut_extliqlw(nsize_liqlw, nbandlw))
    if (.not. allocated(lut_ssaliqlw))   allocate(lut_ssaliqlw(nsize_liqlw, nbandlw))
    if (.not. allocated(lut_asyliqlw))   allocate(lut_asyliqlw(nsize_liqlw, nbandlw))
    if (.not. allocated(lut_exticelw))   allocate(lut_exticelw(nsize_icelw, nbandlw, nrghice_fromfilelw))
    if (.not. allocated(lut_ssaicelw))   allocate(lut_ssaicelw(nsize_icelw, nbandlw, nrghice_fromfilelw))
    if (.not. allocated(lut_asyicelw))   allocate(lut_asyicelw(nsize_icelw, nbandlw, nrghice_fromfilelw))
    if (.not. allocated(band_limscldlw)) allocate(band_limscldlw(2,nbandlw))
       
    ! #######################################################################################
    !
    ! Read in data ...
    ! (ONLY master processor(0), if MPI enabled) 
    !
    ! #######################################################################################
    if (mpirank .eq. mpiroot) then
       ! Read in fields from file
       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,'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,'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)
          
       ! Close file
       status = nf90_close(ncid)       
    endif ! Master process
 
    ! Other processors waiting...
    call mpi_barrier(mpicomm, mpierr)
 
    ! #######################################################################################
    !
    ! Broadcast data... 
    ! (ALL processors)
    !
    ! #######################################################################################
 
    ! Real scalars
#ifdef RTE_USE_SP
    call mpi_bcast(radliq_lwrlw, 1, mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(radliq_uprlw, 1, mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(radice_lwrlw, 1, mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(radice_uprlw, 1, mpi_real,             mpiroot, mpicomm, mpierr)
#else
    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)
#endif
 
    ! Real arrays
#ifdef RTE_USE_SP
    call mpi_bcast(band_limscldlw, size(band_limscldlw), mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(lut_extliqlw,   size(lut_extliqlw),   mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(lut_ssaliqlw,   size(lut_ssaliqlw),   mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(lut_asyliqlw,   size(lut_asyliqlw),   mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(lut_exticelw,   size(lut_exticelw),   mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(lut_ssaicelw,   size(lut_ssaicelw),   mpi_real,             mpiroot, mpicomm, mpierr)
    call mpi_bcast(lut_asyicelw,   size(lut_asyicelw),   mpi_real,             mpiroot, mpicomm, mpierr)
#else
    call mpi_bcast(band_limscldlw, size(band_limscldlw), mpi_double_precision, mpiroot, mpicomm, mpierr)
    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
 
    ! #######################################################################################
    !   
    ! Initialize RRTMGP DDT's...
    !
    ! #######################################################################################
    call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_limscldlw,         &
            radliq_lwrlw, radliq_uprlw, radice_lwrlw, radice_uprlw,                         &
            lut_extliqlw, lut_ssaliqlw, lut_asyliqlw,                                       &
            lut_exticelw, lut_ssaicelw, lut_asyicelw))
 
    call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice))
 
    is_initialized = .true.
 
  end subroutine rrtmgp_lw_cloud_optics_init
end module rrtmgp_lw_cloud_optics