scale_atmos_phy_rd_offline.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
#include "scalelib.h"
module scale_atmos_phy_rd_offline
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
  use scale_prof
  use scale_cpl_sfc_index
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: atmos_phy_rd_offline_setup
  public :: atmos_phy_rd_offline_flux

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
  integer,  private, parameter :: num_vars_3d    = 4
  integer,  private, parameter :: num_vars_2d    = 4
  integer,  private, parameter :: num_vars_2d_op = 4 ! optional

  real(RP), private :: atmos_phy_rd_offline_diffuse_rate = 0.5_rp
  real(RP), private :: atmos_phy_rd_offline_nir_rate     = 0.5_rp

  logical, private :: vars_2d_exist(num_vars_2d_op)

contains
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_rd_offline_setup
    use scale_prc, only: &
       prc_abort
    use scale_file_external_input, only: &
       file_external_input_file_limit, &
       file_external_input_regist
    use scale_const, only: &
       undef => const_undef
    implicit none

    character(len=H_SHORT) :: vars_3d   (num_vars_3d)
    character(len=H_SHORT) :: vars_2d   (num_vars_2d)
    character(len=H_SHORT) :: vars_2d_op(num_vars_2d_op)

    data vars_3d    / 'RFLX_LW_up', 'RFLX_LW_dn', 'RFLX_SW_up', 'RFLX_SW_dn' /
    data vars_2d    / 'SFLX_LW_up', 'SFLX_LW_dn', 'SFLX_SW_up', 'SFLX_SW_dn' /
    data vars_2d_op / 'SFLX_NIR_dn_dir', 'SFLX_NIR_dn_dif', 'SFLX_VIS_dn_dir', 'SFLX_VIS_dn_dif' /

    character(len=H_LONG)  :: ATMOS_PHY_RD_offline_basename(file_external_input_file_limit) = ''
    character(len=H_SHORT) :: ATMOS_PHY_RD_offline_axistype                                 = 'XYZ'
    logical                :: ATMOS_PHY_RD_offline_enable_periodic_year                     = .false.
    logical                :: ATMOS_PHY_RD_offline_enable_periodic_month                    = .false.
    logical                :: ATMOS_PHY_RD_offline_enable_periodic_day                      = .false.
    integer                :: ATMOS_PHY_RD_offline_step_fixed                               = 0
    real(RP)               :: ATMOS_PHY_RD_offline_offset                                   = 0.0_rp
    real(RP)               :: ATMOS_PHY_RD_offline_defval                                 ! = UNDEF
    logical                :: ATMOS_PHY_RD_offline_check_coordinates                        = .true.
    integer                :: ATMOS_PHY_RD_offline_step_limit                               = 0

    namelist / param_atmos_phy_rd_offline / &
       atmos_phy_rd_offline_basename,              &
       atmos_phy_rd_offline_axistype,              &
       atmos_phy_rd_offline_enable_periodic_year,  &
       atmos_phy_rd_offline_enable_periodic_month, &
       atmos_phy_rd_offline_enable_periodic_day,   &
       atmos_phy_rd_offline_step_fixed,            &
       atmos_phy_rd_offline_offset,                &
       atmos_phy_rd_offline_defval,                &
       atmos_phy_rd_offline_check_coordinates,     &
       atmos_phy_rd_offline_step_limit,            &
       atmos_phy_rd_offline_diffuse_rate,          &
       atmos_phy_rd_offline_nir_rate

    integer :: n, ierr
    !---------------------------------------------------------------------------

    log_newline
    log_info("ATMOS_PHY_RD_offline_setup",*) 'Setup'
    log_info("ATMOS_PHY_RD_offline_setup",*) 'Offline radiation process'

    atmos_phy_rd_offline_defval = undef

    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_atmos_phy_rd_offline,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("ATMOS_PHY_RD_offline_setup",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("ATMOS_PHY_RD_offline_setup",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_RD_OFFLINE. Check!'
       call prc_abort
    endif
    log_nml(param_atmos_phy_rd_offline)

    if ( atmos_phy_rd_offline_basename(1) == '' ) then
       log_error("ATMOS_PHY_RD_offline_setup",*) 'ATMOS_PHY_RD_offline_basename is necessary'
       call prc_abort
    end if

    do n = 1, num_vars_3d
       call file_external_input_regist( atmos_phy_rd_offline_basename(:),           & ! [IN]
                                        vars_3d(n),                                 & ! [IN]
                                        atmos_phy_rd_offline_axistype,              & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_year,  & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_month, & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_day,   & ! [IN]
                                        atmos_phy_rd_offline_step_fixed,            & ! [IN]
                                        atmos_phy_rd_offline_offset,                & ! [IN]
                                        atmos_phy_rd_offline_defval,                & ! [IN]
                                        atmos_phy_rd_offline_check_coordinates,     & ! [IN]
                                        atmos_phy_rd_offline_step_limit             ) ! [IN]
    end do

    do n = 1, num_vars_2d
       call file_external_input_regist( atmos_phy_rd_offline_basename(:),           & ! [IN]
                                        vars_2d(n),                                 & ! [IN]
                                        'XY',                                       & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_year,  & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_month, & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_day,   & ! [IN]
                                        atmos_phy_rd_offline_step_fixed,            & ! [IN]
                                        atmos_phy_rd_offline_offset,                & ! [IN]
                                        atmos_phy_rd_offline_defval,                & ! [IN]
                                        atmos_phy_rd_offline_check_coordinates,     & ! [IN]
                                        atmos_phy_rd_offline_step_limit             ) ! [IN]
    end do

    do n = 1, num_vars_2d_op
       call file_external_input_regist( atmos_phy_rd_offline_basename(:),           & ! [IN]
                                        vars_2d_op(n),                              & ! [IN]
                                        'XY',                                       & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_year,  & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_month, & ! [IN]
                                        atmos_phy_rd_offline_enable_periodic_day,   & ! [IN]
                                        atmos_phy_rd_offline_step_fixed,            & ! [IN]
                                        atmos_phy_rd_offline_offset,                & ! [IN]
                                        atmos_phy_rd_offline_defval,                & ! [IN]
                                        atmos_phy_rd_offline_check_coordinates,     & ! [IN]
                                        atmos_phy_rd_offline_step_limit,            & ! [IN]
                                        exist = vars_2d_exist(n)                    ) ! [OUT]
       if ( vars_2d_exist(n) ) then
          log_info("ATMOS_PHY_RD_offline_setup",*) '', trim(vars_2d_op(n)), ' found.'
       else
          log_info("ATMOS_PHY_RD_offline_setup",*) '', trim(vars_2d_op(n)), ' not found.'
       end if
    end do

    return
  end subroutine atmos_phy_rd_offline_setup

  !-----------------------------------------------------------------------------
  subroutine atmos_phy_rd_offline_flux( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       time_now,   &
       flux_rad,   &
       SFLX_rad_dn )
    use scale_prc, only: &
       prc_abort
    use scale_file_external_input, only: &
       file_external_input_update
    use scale_atmos_phy_rd_common, only: &
       i_sw, &
       i_lw, &
       i_dn, &
       i_up
    implicit none

    integer,  intent(in)  :: KA, KS, KE
    integer,  intent(in)  :: IA, IS, IE
    integer,  intent(in)  :: JA, JS, JE
    real(DP), intent(in)  :: time_now
    real(RP), intent(out) :: flux_rad   (ka,ia,ja,2,2)
    real(RP), intent(out) :: SFLX_rad_dn(ia,ja,n_rad_dir,n_rad_rgn)

    real(RP) :: buffer(ia,ja)
    logical  :: error, error_sum, error_sflx

    integer  :: i, j
    !---------------------------------------------------------------------------

    log_progress(*) 'atmosphere / physics / radiation / offline'

    ! [note] external data input is now support only SCALE-RM

    error_sum = .false.

    ! 3D
    call file_external_input_update( 'RFLX_LW_up', time_now, flux_rad(:,:,:,i_lw,i_up), error )
    error_sum = ( error .OR. error_sum )

    call file_external_input_update( 'RFLX_LW_dn', time_now, flux_rad(:,:,:,i_lw,i_dn), error )
    error_sum = ( error .OR. error_sum )

    call file_external_input_update( 'RFLX_SW_up', time_now, flux_rad(:,:,:,i_sw,i_up), error )
    error_sum = ( error .OR. error_sum )

    call file_external_input_update( 'RFLX_SW_dn', time_now, flux_rad(:,:,:,i_sw,i_dn), error )
    error_sum = ( error .OR. error_sum )


    ! 2D
    call file_external_input_update( 'SFLX_LW_up', time_now, buffer(:,:), error )
    if ( error ) then
       error_sum = .true.
    else
       !$omp parallel do default(none) OMP_SCHEDULE_ &
       !$omp private(i,j) &
       !$omp shared(KS,IS,IE,JS,JE) &
       !$omp shared(flux_rad,buffer)
       do j = js, je
       do i = is, ie
          flux_rad(ks-1,i,j,i_lw,i_up) = buffer(i,j)
       end do
       end do
    end if

    call file_external_input_update( 'SFLX_LW_dn', time_now, buffer(:,:), error )
    if ( error ) then
       error_sum = .true.
    else
       !$omp parallel do default(none) OMP_SCHEDULE_ &
       !$omp private(i,j) &
       !$omp shared(KS,IS,IE,JS,JE) &
       !$omp shared(flux_rad,buffer)
       do j = js, je
       do i = is, ie
          flux_rad(ks-1,i,j,i_lw,i_dn) = buffer(i,j)
       end do
       end do
    end if

    call file_external_input_update( 'SFLX_SW_up', time_now, buffer(:,:), error )
    if ( error ) then
       error_sum = .true.
    else
       !$omp parallel do default(none) OMP_SCHEDULE_ &
       !$omp private(i,j) &
       !$omp shared(KS,IS,IE,JS,JE) &
       !$omp shared(flux_rad,buffer)
       do j = js, je
       do i = is, ie
          flux_rad(ks-1,i,j,i_sw,i_up) = buffer(i,j)
       end do
       end do
    end if

    call file_external_input_update( 'SFLX_SW_dn', time_now, buffer(:,:), error )
    if ( error ) then
       error_sum = .true.
    else
       !$omp parallel do default(none) OMP_SCHEDULE_ &
       !$omp private(i,j) &
       !$omp shared(KS,IS,IE,JS,JE) &
       !$omp shared(flux_rad,buffer)
       do j = js, je
       do i = is, ie
          flux_rad(ks-1,i,j,i_sw,i_dn) = buffer(i,j)
       end do
       end do
    end if

    !$omp parallel do default(none) OMP_SCHEDULE_ &
    !$omp private(i,j) &
    !$omp shared(KS,IS,IE,JS,JE,ATMOS_PHY_RD_offline_diffuse_rate) &
    !$omp shared(SFLX_rad_dn,flux_rad)
    do j = js, je
    do i = is, ie
       sflx_rad_dn(i,j,i_r_direct ,i_r_ir) = 0.0_rp
       sflx_rad_dn(i,j,i_r_diffuse,i_r_ir) = flux_rad(ks-1,i,j,i_lw,i_dn)
    end do
    end do

    ! 2D optional

    error_sflx = .false.

    if ( vars_2d_exist(1) ) then
       call file_external_input_update( 'SFLX_NIR_dn_dir', time_now, sflx_rad_dn(:,:,i_r_direct,i_r_vis), error )
       error_sum = ( error .OR. error_sum )
    else
       error_sflx = .true.
    endif

    if ( vars_2d_exist(2) ) then
       call file_external_input_update( 'SFLX_NIR_dn_dif', time_now, sflx_rad_dn(:,:,i_r_direct,i_r_vis), error )
       error_sum = ( error .OR. error_sum )
    else
       error_sflx = .true.
    endif

    if ( vars_2d_exist(3) ) then
       call file_external_input_update( 'SFLX_VIS_dn_dir', time_now, sflx_rad_dn(:,:,i_r_direct,i_r_vis), error )
       error_sum = ( error .OR. error_sum )
    else
       error_sflx = .true.
    endif

    if ( vars_2d_exist(4) ) then
       call file_external_input_update( 'SFLX_VIS_dn_dif', time_now, sflx_rad_dn(:,:,i_r_direct,i_r_vis), error )
       error_sum = ( error .OR. error_sum )
    else
       error_sflx = .true.
    endif

    if ( error_sflx ) then ! reconstruct from lowermost SW flux
       !$omp parallel do default(none) OMP_SCHEDULE_ &
       !$omp private(i,j) &
       !$omp shared(KS,IS,IE,JS,JE,ATMOS_PHY_RD_offline_diffuse_rate,ATMOS_PHY_RD_offline_NIR_rate) &
       !$omp shared(SFLX_rad_dn,flux_rad)
       do j = js, je
       do i = is, ie
          sflx_rad_dn(i,j,i_r_direct ,i_r_nir) = ( 1.0_rp-atmos_phy_rd_offline_diffuse_rate ) &
                                               * (        atmos_phy_rd_offline_nir_rate     ) * flux_rad(ks-1,i,j,i_sw,i_dn)
          sflx_rad_dn(i,j,i_r_diffuse,i_r_nir) = (        atmos_phy_rd_offline_diffuse_rate ) &
                                               * (        atmos_phy_rd_offline_nir_rate     ) * flux_rad(ks-1,i,j,i_sw,i_dn)
          sflx_rad_dn(i,j,i_r_direct ,i_r_vis) = ( 1.0_rp-atmos_phy_rd_offline_diffuse_rate ) &
                                               * ( 1.0_rp-atmos_phy_rd_offline_nir_rate     ) * flux_rad(ks-1,i,j,i_sw,i_dn)
          sflx_rad_dn(i,j,i_r_diffuse,i_r_vis) = (        atmos_phy_rd_offline_diffuse_rate ) &
                                               * ( 1.0_rp-atmos_phy_rd_offline_nir_rate     ) * flux_rad(ks-1,i,j,i_sw,i_dn)
       enddo
       enddo
    endif

    if ( error_sum ) then
       log_error("ATMOS_PHY_RD_offline_flux",*) 'Requested data is not found!'
       call prc_abort
    endif

    return
  end subroutine atmos_phy_rd_offline_flux

end module scale_atmos_phy_rd_offline