mod_atmos_phy_sf_driver.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
#include "inc_openmp.h"
module mod_atmos_phy_sf_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  use scale_tracer

  use scale_const, only: &
     i_sw  => const_i_sw, &
     i_lw  => const_i_lw
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: atmos_phy_sf_driver_setup
  public :: atmos_phy_sf_driver_resume
  public :: atmos_phy_sf_driver

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_sf_driver_setup
    use scale_process, only: &
       prc_mpistop
    use scale_atmos_phy_sf, only: &
       atmos_phy_sf_setup
    use mod_atmos_admin, only: &
       atmos_phy_sf_type, &
       atmos_sw_phy_sf
    use mod_atmos_phy_sf_vars, only: &
       sfc_z0m   => atmos_phy_sf_sfc_z0m,   &
       sfc_z0h   => atmos_phy_sf_sfc_z0h,   &
       sfc_z0e   => atmos_phy_sf_sfc_z0e,   &
       sflx_mw   => atmos_phy_sf_sflx_mw,   &
       sflx_mu   => atmos_phy_sf_sflx_mu,   &
       sflx_mv   => atmos_phy_sf_sflx_mv,   &
       sflx_sh   => atmos_phy_sf_sflx_sh,   &
       sflx_lh   => atmos_phy_sf_sflx_lh,   &
       sflx_qtrc => atmos_phy_sf_sflx_qtrc
    use mod_cpl_admin, only: &
       cpl_sw
    implicit none

    integer :: ierr
    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*)
    if( io_l ) write(io_fid_log,*) '++++++ Module[DRIVER] / Categ[ATMOS PHY_SF] / Origin[SCALE-RM]'

    if ( atmos_sw_phy_sf ) then

       ! setup library component
       call atmos_phy_sf_setup( atmos_phy_sf_type )

       if ( .NOT. cpl_sw ) then
          if( io_l ) write(io_fid_log,*) '*** Coupler is disabled.'
       endif

    else

       if( io_l ) write(io_fid_log,*) '*** this component is never called.'
       if( io_l ) write(io_fid_log,*) '*** surface fluxes are set to zero.'
       sflx_mw(:,:)   = 0.0_rp
       sflx_mu(:,:)   = 0.0_rp
       sflx_mv(:,:)   = 0.0_rp
       sflx_sh(:,:)   = 0.0_rp
       sflx_lh(:,:)   = 0.0_rp
       sflx_qtrc(:,:,:) = 0.0_rp

       if( io_l ) write(io_fid_log,*) '*** SFC_TEMP, SFC_albedo is set in ATMOS_PHY_SF_vars.'

    endif

    return
  end subroutine atmos_phy_sf_driver_setup

  !-----------------------------------------------------------------------------
  subroutine atmos_phy_sf_driver_resume
    use mod_atmos_admin, only: &
       atmos_sw_phy_sf
    implicit none

    if ( atmos_sw_phy_sf ) then

       ! run once (only for the diagnostic value)
       call prof_rapstart('ATM_SurfaceFlux', 1)
       call atmos_phy_sf_driver( update_flag = .true. )
       call prof_rapend  ('ATM_SurfaceFlux', 1)

    end if

    return
  end subroutine atmos_phy_sf_driver_resume

  !-----------------------------------------------------------------------------
  subroutine atmos_phy_sf_driver( update_flag )
    use scale_const, only: &
       pre00 => const_pre00, &
       rdry  => const_rdry, &
       rvap  => const_rvap, &
       cpdry => const_cpdry
    use scale_comm, only: &
       comm_vars8, &
       comm_wait
    use scale_grid, only: &
       rcdz => grid_rcdz, &
       rfdz => grid_rfdz
    use scale_grid_real, only: &
       real_cz, &
       real_z1
    use scale_gridtrans, only: &
       gsqrt => gtrans_gsqrt, &
       i_xyz,                 &
       i_uyz,                 &
       i_xvz,                 &
       i_xyw
    use scale_topography, only: &
       topo_zsfc
    use scale_time, only: &
       dt_sf => time_dtsec_atmos_phy_sf
    use scale_rm_statistics, only: &
       statistics_checktotal, &
       stat_total
    use scale_history, only: &
       hist_in
    use scale_atmos_bottom, only: &
       bottom_estimate => atmos_bottom_estimate
    use scale_atmos_hydrostatic, only: &
       barometric_law_mslp => atmos_hydrostatic_barometric_law_mslp
    use scale_atmos_thermodyn, only: &
       thermodyn_qd => atmos_thermodyn_qd, &
       thermodyn_cp => atmos_thermodyn_cp
    use scale_atmos_phy_sf, only: &
       atmos_phy_sf
    use mod_atmos_vars, only: &
       dens,              &
       rhot,              &
       qtrc,              &
       temp,              &
       pres,              &
       w,                 &
       u,                 &
       v,                 &
       dens_t => dens_tp, &
       momz_t => momz_tp, &
       momx_t => momx_tp, &
       momy_t => momy_tp, &
       rhot_t => rhot_tp, &
       rhoq_t => rhoq_tp
    use mod_atmos_phy_rd_vars, only: &
       sflx_lw_dn => atmos_phy_rd_sflx_lw_dn, &
       sflx_sw_dn => atmos_phy_rd_sflx_sw_dn
    use mod_atmos_phy_sf_vars, only: &
       dens_t_sf  => atmos_phy_sf_dens_t,     &
       momz_t_sf  => atmos_phy_sf_momz_t,     &
       momx_t_sf  => atmos_phy_sf_momx_t,     &
       momy_t_sf  => atmos_phy_sf_momy_t,     &
       rhot_t_sf  => atmos_phy_sf_rhot_t,     &
       rhoq_t_sf  => atmos_phy_sf_rhoq_t,     &
       sfc_dens   => atmos_phy_sf_sfc_dens,   &
       sfc_pres   => atmos_phy_sf_sfc_pres,   &
       sfc_temp   => atmos_phy_sf_sfc_temp,   &
       sfc_albedo => atmos_phy_sf_sfc_albedo, &
       sfc_z0m    => atmos_phy_sf_sfc_z0m,    &
       sfc_z0h    => atmos_phy_sf_sfc_z0h,    &
       sfc_z0e    => atmos_phy_sf_sfc_z0e,    &
       sflx_mw    => atmos_phy_sf_sflx_mw,    &
       sflx_mu    => atmos_phy_sf_sflx_mu,    &
       sflx_mv    => atmos_phy_sf_sflx_mv,    &
       sflx_sh    => atmos_phy_sf_sflx_sh,    &
       sflx_lh    => atmos_phy_sf_sflx_lh,    &
       sflx_gh    => atmos_phy_sf_sflx_gh,    &
       sflx_qtrc  => atmos_phy_sf_sflx_qtrc,  &
       u10        => atmos_phy_sf_u10,        &
       v10        => atmos_phy_sf_v10,        &
       t2         => atmos_phy_sf_t2,         &
       q2         => atmos_phy_sf_q2
    use mod_cpl_admin, only: &
       cpl_sw
    implicit none

    logical, intent(in) :: update_flag

    real(RP) :: Uabs10(ia,ja) ! 10m absolute wind [m/s]
    real(RP) :: MSLP  (ia,ja) ! mean sea-level pressure [Pa]
    real(RP) :: total ! dummy

    real(RP) :: q(qa)
    real(RP) :: qdry
    real(RP) :: Rtot
    real(RP) :: CPtot

    real(RP) :: work

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

    if ( update_flag ) then

       ! update surface density, surface pressure
       call bottom_estimate( dens(:,:,:), & ! [IN]
                             pres(:,:,:), & ! [IN]
                             real_cz(:,:,:), & ! [IN]
                             topo_zsfc(:,:),   & ! [IN]
                             real_z1(:,:),   & ! [IN]
                             sfc_dens(:,:),   & ! [OUT]
                             sfc_pres(:,:)    ) ! [OUT]

       if ( .NOT. cpl_sw ) then
          call atmos_phy_sf( temp(ks,:,:),   & ! [IN]
                             pres(ks,:,:),   & ! [IN]
                             w(ks,:,:),   & ! [IN]
                             u(ks,:,:),   & ! [IN]
                             v(ks,:,:),   & ! [IN]
                             dens(ks,:,:),   & ! [IN]
                             qtrc(ks,:,:,:), & ! [IN]
                             real_z1(:,:),      & ! [IN]
                             dt_sf,                & ! [IN]
                             sfc_dens(:,:),      & ! [IN]
                             sfc_pres(:,:),      & ! [IN]
                             sflx_lw_dn(:,:),      & ! [IN]
                             sflx_sw_dn(:,:),      & ! [IN]
                             sfc_temp(:,:),      & ! [IN]
                             sfc_albedo(:,:,:),    & ! [IN]
                             sfc_z0m(:,:),      & ! [INOUT]
                             sfc_z0h(:,:),      & ! [INOUT]
                             sfc_z0e(:,:),      & ! [INOUT]
                             sflx_mw(:,:),      & ! [OUT]
                             sflx_mu(:,:),      & ! [OUT]
                             sflx_mv(:,:),      & ! [OUT]
                             sflx_sh(:,:),      & ! [OUT]
                             sflx_lh(:,:),      & ! [OUT]
                             sflx_qtrc(:,:,:),    & ! [OUT]
                             u10(:,:),      & ! [OUT]
                             v10(:,:),      & ! [OUT]
                             t2(:,:),      & ! [OUT]
                             q2(:,:)       ) ! [OUT]
       endif

!OCL XFILL
       do j = js, je
       do i = is, ie
          uabs10(i,j) = sqrt( u10(i,j)**2 + v10(i,j)**2 )
       end do
       end do

       call barometric_law_mslp( mslp(:,:), sfc_pres(:,:), t2(:,:), topo_zsfc(:,:) )

       call hist_in( sfc_dens(:,:),      'SFC_DENS',   'surface atmospheric density',       'kg/m3'   )
       call hist_in( sfc_pres(:,:),      'SFC_PRES',   'surface atmospheric pressure',      'Pa'      )
       call hist_in( sfc_temp(:,:),      'SFC_TEMP',   'surface skin temperature (merged)', 'K'       )
       call hist_in( sfc_albedo(:,:,i_lw), 'SFC_ALB_LW', 'surface albedo (longwave,merged)',  '0-1'     , nohalo=.true. )
       call hist_in( sfc_albedo(:,:,i_sw), 'SFC_ALB_SW', 'surface albedo (shortwave,merged)', '0-1'     , nohalo=.true. )
       call hist_in( sfc_z0m(:,:),      'SFC_Z0M',    'roughness length (momentum)',       'm'       , nohalo=.true. )
       call hist_in( sfc_z0h(:,:),      'SFC_Z0H',    'roughness length (heat)',           'm'       , nohalo=.true. )
       call hist_in( sfc_z0e(:,:),      'SFC_Z0E',    'roughness length (vapor)',          'm'       , nohalo=.true. )
       call hist_in( sflx_mw(:,:),      'MWFLX',      'w-momentum flux (merged)',          'kg/m2/s' )
       call hist_in( sflx_mu(:,:),      'MUFLX',      'u-momentum flux (merged)',          'kg/m2/s' )
       call hist_in( sflx_mv(:,:),      'MVFLX',      'v-momentum flux (merged)',          'kg/m2/s' )
       call hist_in( sflx_sh(:,:),      'SHFLX',      'sensible heat flux (merged)',       'W/m2'    , nohalo=.true. )
       call hist_in( sflx_lh(:,:),      'LHFLX',      'latent heat flux (merged)',         'W/m2'    , nohalo=.true. )
       call hist_in( sflx_gh(:,:),      'GHFLX',      'ground heat flux (merged)',         'W/m2'    , nohalo=.true. )
       call hist_in( uabs10(:,:),      'Uabs10',     '10m absolute wind',                 'm/s'     , nohalo=.true. )
       call hist_in( u10(:,:),      'U10',        '10m x-wind',                        'm/s'     , nohalo=.true. )
       call hist_in( v10(:,:),      'V10',        '10m y-wind',                        'm/s'     , nohalo=.true. )
       call hist_in( t2(:,:),      'T2 ',        '2m air temperature',                'K'       , nohalo=.true. )
       call hist_in( q2(:,:),      'Q2 ',        '2m specific humidity',              'kg/kg'   , nohalo=.true. )
       call hist_in( mslp(:,:),      'MSLP',       'mean sea-level pressure',           'Pa'      )

       call comm_vars8( sflx_mu(:,:), 1 )
       call comm_vars8( sflx_mv(:,:), 2 )
       call comm_wait ( sflx_mu(:,:), 1 )
       call comm_wait ( sflx_mv(:,:), 2 )

!OCL XFILL
       do j = js, je
       do i = is, ie
          momz_t_sf(i,j) = sflx_mw(i,j) * rfdz(ks) / gsqrt(ks,i,j,i_xyw)
       enddo
       enddo

!OCL XFILL
       do j = js, je
       do i = is, ie
          momx_t_sf(i,j) = 0.5_rp * ( sflx_mu(i,j) + sflx_mu(i+1,j) ) * rcdz(ks) / gsqrt(ks,i,j,i_uyz)
       enddo
       enddo

!OCL XFILL
       do j = js, je
       do i = is, ie
          momy_t_sf(i,j) = 0.5_rp * ( sflx_mv(i,j) + sflx_mv(i,j+1) ) * rcdz(ks) / gsqrt(ks,i,j,i_xvz)
       enddo
       enddo

       do j = js, je
       do i = is, ie
          q(:) = qtrc(ks,i,j,:)
          call thermodyn_qd( qdry, q )
          call thermodyn_cp( cptot, q, qdry )
          rtot  = rdry * qdry + rvap * q(i_qv)
          rhot_t_sf(i,j) = ( sflx_sh(i,j) * rcdz(ks) / ( cptot * gsqrt(ks,i,j,i_xyz) ) ) &
                         * rhot(ks,i,j) * rtot / pres(ks,i,j) ! = POTT/TEMP
       enddo
       enddo

       dens_t_sf(:,:) = 0.0_rp
       do iq = i_qv, i_qv
       do j  = js, je
       do i  = is, ie
          work = sflx_qtrc(i,j,iq) * rcdz(ks) / gsqrt(ks,i,j,i_xyz)
          dens_t_sf(i,j)    = dens_t_sf(i,j) + work
          rhoq_t_sf(i,j,iq) = work
       enddo
       enddo
       enddo

       do j  = js, je
       do i  = is, ie
          rhot_t_sf(i,j) = rhot_t_sf(i,j) + dens_t_sf(i,j) * rhot(ks,i,j) / dens(ks,i,j)
       enddo
       enddo

    endif

    do j = js, je
    do i = is, ie
       dens_t(ks,i,j) = dens_t(ks,i,j) + dens_t_sf(i,j)
       momz_t(ks,i,j) = momz_t(ks,i,j) + momz_t_sf(i,j)
       momx_t(ks,i,j) = momx_t(ks,i,j) + momx_t_sf(i,j)
       momy_t(ks,i,j) = momy_t(ks,i,j) + momy_t_sf(i,j)
       rhot_t(ks,i,j) = rhot_t(ks,i,j) + rhot_t_sf(i,j)
    enddo
    enddo

    do iq = i_qv, i_qv
    do j  = js, je
    do i  = is, ie
       rhoq_t(ks,i,j,iq) = rhoq_t(ks,i,j,iq) + rhoq_t_sf(i,j,iq)
    enddo
    enddo
    enddo

    if ( statistics_checktotal ) then
       call stat_total( total, dens_t_sf(:,:), 'DENS_t_SF' )
       call stat_total( total, momz_t_sf(:,:), 'MOMZ_t_SF' )
       call stat_total( total, momx_t_sf(:,:), 'MOMX_t_SF' )
       call stat_total( total, momy_t_sf(:,:), 'MOMY_t_SF' )
       call stat_total( total, rhot_t_sf(:,:), 'RHOT_t_SF' )

       do iq = i_qv, i_qv
          call stat_total( total, rhoq_t_sf(:,:,iq), trim(aq_name(iq))//'_t_SF' )
       enddo
    endif

    return
  end subroutine atmos_phy_sf_driver

end module mod_atmos_phy_sf_driver