scale_atmos_phy_rd_offline.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
#include "inc_openmp.h"
module scale_atmos_phy_rd_offline
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  use scale_tracer
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: atmos_phy_rd_offline_setup
  public :: atmos_phy_rd_offline

  !-----------------------------------------------------------------------------
  !
  !++ 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 = 1 ! optional

  real,    private :: ATMOS_PHY_RD_offline_diffuse_rate = 0.5_rp

  logical, private :: vars_2d_exist(num_vars_2d_op)

contains
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_rd_offline_setup( RD_TYPE )
    use scale_process, only: &
       prc_mpistop
    use scale_external_input, only: &
       extin_regist
    use scale_const, only: &
       undef => const_undef
    implicit none

    character(len=*), intent(in) :: rd_type

    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_SW_dn_dir' /

    character(len=H_LONG)  :: atmos_phy_rd_offline_basename              = ''
    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
    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

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

    if( io_l ) write(io_fid_log,*)
    if( io_l ) write(io_fid_log,*) '++++++ Module[RADIATION] / Categ[ATMOS PHYSICS] / Origin[SCALElib]'
    if( io_l ) write(io_fid_log,*) '*** Offline radiation process'

    if ( rd_type /= 'OFFLINE' ) then
       write(*,*) 'xxx RD_TYPE is not OFFLINE. Check!'
       call prc_mpistop
    endif


    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
       if( io_l ) write(io_fid_log,*) '*** Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       write(*,*) 'xxx Not appropriate names in namelist PARAM_ATMOS_PHY_RD_OFFLINE. Check!'
       call prc_mpistop
    endif
    if( io_nml ) write(io_fid_nml,nml=param_atmos_phy_rd_offline)

    if ( atmos_phy_rd_offline_basename == '' ) then
       write(*,*) 'xxx ATMOS_PHY_RD_offline_basename is necessary'
       call prc_mpistop
    end if

    do n = 1, num_vars_3d
       call extin_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 extin_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 extin_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
          if( io_l ) write(io_fid_log,*) '*** ', trim(vars_2d_op(n)), ' found.'
       else
          if( io_l ) write(io_fid_log,*) '*** ', trim(vars_2d_op(n)), ' not found.'
       end if
    end do

    return
  end subroutine atmos_phy_rd_offline_setup

  !-----------------------------------------------------------------------------
  subroutine atmos_phy_rd_offline( &
       DENS, RHOT, QTRC,      &
       CZ, FZ,                &
       fact_ocean,            &
       fact_land,             &
       fact_urban,            &
       temp_sfc, albedo_land, &
       solins, cosSZA,        &
       flux_rad,              &
       flux_rad_top,          &
       SFLX_rad_dn            )
!       Jval                   )
    use scale_grid_index
    use scale_tracer
    use scale_process, only: &
       prc_mpistop
    use scale_external_input, only: &
       extin_update
    use scale_time, only: &
       time_nowdaysec
    use scale_atmos_phy_rd_common, only: &
       i_sw,     &
       i_lw,     &
       i_dn,     &
       i_up,     &
       i_direct, &
       i_diffuse
    implicit none
    real(RP), intent(in)  :: dens        (ka,ia,ja)
    real(RP), intent(in)  :: rhot        (ka,ia,ja)
    real(RP), intent(in)  :: qtrc        (ka,ia,ja,qa)
    real(RP), intent(in)  :: cz          (  ka,ia,ja)    ! UNUSED
    real(RP), intent(in)  :: fz          (0:ka,ia,ja)
    real(RP), intent(in)  :: fact_ocean  (ia,ja)
    real(RP), intent(in)  :: fact_land   (ia,ja)
    real(RP), intent(in)  :: fact_urban  (ia,ja)
    real(RP), intent(in)  :: temp_sfc    (ia,ja)
    real(RP), intent(in)  :: albedo_land (ia,ja,2)
    real(RP), intent(in)  :: solins      (ia,ja)
    real(RP), intent(in)  :: cossza      (ia,ja)
    real(RP), intent(out) :: flux_rad    (ka,ia,ja,2,2,2)
    real(RP), intent(out) :: flux_rad_top(ia,ja,2,2,2)
    real(RP), intent(out) :: sflx_rad_dn (ia,ja,2,2)
!    real(RP), intent(out) :: Jval        (KA,IA,JA,CH_QA_photo)

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

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

    if( io_l ) write(io_fid_log,*) '*** Atmos physics  step: Radiation(offline)'

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

    error_sum = .false.

    ! 3D
    call extin_update( flux_rad(:,:,:,i_lw,i_up,2), 'RFLX_LW_up', time_nowdaysec, error )
    error_sum = ( error .OR. error_sum )

    call extin_update( flux_rad(:,:,:,i_lw,i_dn,2), 'RFLX_LW_dn', time_nowdaysec, error )
    error_sum = ( error .OR. error_sum )

    call extin_update( flux_rad(:,:,:,i_sw,i_up,2), 'RFLX_SW_up', time_nowdaysec, error )
    error_sum = ( error .OR. error_sum )

    call extin_update( flux_rad(:,:,:,i_sw,i_dn,2), 'RFLX_SW_dn', time_nowdaysec, error )
    error_sum = ( error .OR. error_sum )


    ! 2D
    call extin_update( buffer(:,:), 'SFLX_LW_up', time_nowdaysec, 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,2) = buffer(i,j)
       end do
       end do
    end if

    call extin_update( buffer(:,:), 'SFLX_LW_dn', time_nowdaysec, 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,2) = buffer(i,j)
       end do
       end do
    end if

    call extin_update( buffer(:,:), 'SFLX_SW_up', time_nowdaysec, 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,2) = buffer(i,j)
       end do
       end do
    end if

    call extin_update( buffer(:,:), 'SFLX_SW_dn', time_nowdaysec, 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,2) = 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_lw,i_diffuse) = flux_rad(ks-1,i,j,i_lw,i_dn,2)
       sflx_rad_dn(i,j,i_lw,i_direct ) = 0.0_rp
    end do
    end do

    ! 2D optional
    if ( vars_2d_exist(1) ) then
       call extin_update( sflx_rad_dn(:,:,i_sw,i_direct), 'SFLX_SW_dn_dir', time_nowdaysec, 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(SFLX_rad_dn,flux_rad)
          do j = js, je
          do i = is, ie
             sflx_rad_dn(i,j,i_sw,i_diffuse) = flux_rad(ks-1,i,j,i_sw,i_dn,2) - sflx_rad_dn(i,j,i_sw,i_direct)
          end do
          end do
       end if
    else
       !$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_sw,i_diffuse) = (          atmos_phy_rd_offline_diffuse_rate ) * flux_rad(ks-1,i,j,i_sw,i_dn,2)
          sflx_rad_dn(i,j,i_sw,i_direct ) = ( 1.0_rp - atmos_phy_rd_offline_diffuse_rate ) * flux_rad(ks-1,i,j,i_sw,i_dn,2)
       end do
       end do
    end if

    if ( error_sum ) then
       write(*,*) 'xxx Requested data is not found!'
       call prc_mpistop
    endif

    ! clearsky and TOA value are not defined
    flux_rad(:,:,:,:,:,1) = 0.0_rp
    flux_rad_top(:,:,:,:,:)   = 0.0_rp

    return
  end subroutine atmos_phy_rd_offline

end module scale_atmos_phy_rd_offline