mod_atmos_phy_lt_driver.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
#include "scalelib.h"
module mod_atmos_phy_lt_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
  use scale_prof
  use scale_atmos_grid_cartesc_index
  use scale_tracer
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: atmos_phy_lt_driver_tracer_setup
  public :: atmos_phy_lt_driver_setup
  public :: atmos_phy_lt_driver_finalize
  public :: atmos_phy_lt_driver_adjustment
 
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
 
  !--- For history output
  integer, private, parameter :: w_nmax = 3
  integer, private, parameter :: I_CRGD_LIQ = 1
  integer, private, parameter :: I_CRGD_ICE = 2
  integer, private, parameter :: I_CRGD_TOT = 3
  integer,  private              :: HIST_id(w_nmax)
  character(len=H_SHORT), private :: w_name(w_nmax)
  character(len=H_MID),   private :: w_longname(w_nmax)
  character(len=H_SHORT), private :: w_unit(w_nmax)
  data w_name / 'CRGD_LIQ', &
                'CRGD_ICE', &
                'CRGD_TOT' /
  data w_longname / 'Charge density of liquid water', &
                    'Charge density of ice water', &
                    'Charge density of QHYD' /
  data w_unit / 'nC/m3', &
                'nC/m3', &
                'nC/m3' /
 
 
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_lt_driver_tracer_setup
    use mod_atmos_admin, only: &
       atmos_phy_mp_type, &
       atmos_phy_lt_type, &
       atmos_sw_phy_lt
    use scale_tracer, only: &
       tracer_regist
    use scale_atmos_phy_mp_suzuki10, only: &
       atmos_phy_mp_suzuki10_nwaters, &
       atmos_phy_mp_suzuki10_nices, &
       atmos_phy_mp_suzuki10_nccn
    use mod_atmos_phy_lt_vars, only: &
       qa_lt, &
       qs_lt, &
       qe_lt
    use scale_atmos_hydrometeor, only: &
       qha, &
       qhs
    use scale_prc, only: &
       prc_abort
    implicit none
 
    character(len=H_SHORT), allocatable :: name(:)
    character(len=H_MID  ), allocatable :: desc(:)
    character(len=H_SHORT), allocatable :: unit(:)
    integer :: iq
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("ATMOS_PHY_LT_driver_tracer_setup",*) 'Setup'
 
    if ( atmos_sw_phy_lt ) then
 
       select case ( atmos_phy_lt_type )
       case ( 'OFF', 'NONE' )
          log_info("ATMOS_PHY_LT_driver_tracer_setup",*) 'this component is never called.'
       case ( 'SATO2019' )
          select case ( atmos_phy_mp_type )
          case ( 'TOMITA08', 'SN14' )
             ! do nothing
          case ( 'SUZUKI10' )
 
             if( atmos_phy_mp_suzuki10_nccn /= 0 ) then
                log_error("ATMOS_PHY_LT_driver_tracer_setup",*) 'nccn in SUZUKI10 should be 0 for lithgning component(', atmos_phy_mp_suzuki10_nccn, '). CHECK!'
                call prc_abort
             endif
             if ( atmos_phy_mp_suzuki10_nices == 0 ) then
                log_error("ATMOS_PHY_LT_driver_tracer_setup",*) 'ICEFLG in SUZUKI10 should be 1 for lithgning component. CHECK!'
                call prc_abort
             endif
          case ( 'KESSLER' )
             log_error("ATMOS_PHY_LT_driver_tracer_setup",*) 'ATMOS_PHY_MP_TYPE should be TOMITA08, or SN14, or SUZUKI10 (', atmos_phy_mp_type, '). CHECK!'
             call prc_abort
          end select
       case default
          log_error("ATMOS_PHY_LT_driver_tracer_setup",*) 'invalid lithgning type(', atmos_phy_lt_type, '). CHECK!'
          call prc_abort
       end select
 
       qa_lt = qha
 
       allocate( name(qa_lt), desc(qa_lt), unit(qa_lt) )
       do iq = 1, qa_lt
          name(iq) = 'QCRG_'//trim(tracer_name(qhs+iq-1)(2:))
          desc(iq) = 'Ratio of charge density of '//trim(tracer_name(qhs+iq-1))
          unit(iq) = 'fC/kg'
       end do
       call tracer_regist( qs_lt,   & ! [OUT]
                           qa_lt,   & ! [IN]
                           name(:), & ! [IN]
                           desc(:), & ! [IN]
                           unit(:)  ) ! [IN]
       deallocate( name, desc, unit )
 
       qe_lt = qs_lt - 1 + qa_lt
 
    else
       qa_lt = 0
       qs_lt = -1
       qe_lt = -2
    endif
 
    return
  end subroutine atmos_phy_lt_driver_tracer_setup
 
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_lt_driver_setup
    use scale_atmos_grid_cartesc_real, only: &
       real_lon => atmos_grid_cartesc_real_lon, &
       real_lat => atmos_grid_cartesc_real_lat
    use scale_atmos_grid_cartesc, only: &
       cdx => atmos_grid_cartesc_cdx, &
       cdy => atmos_grid_cartesc_cdy
    use scale_atmos_phy_lt_sato2019, only: &
       atmos_phy_lt_sato2019_setup
    use mod_atmos_phy_lt_vars, only: &
       flg_lt, &
       atmos_phy_lt_sarea
    use mod_atmos_admin, only: &
       atmos_phy_mp_type, &
       atmos_phy_lt_type
    use scale_prc, only: &
       prc_abort
    use scale_atmos_hydrometeor, only: &
       qha
    use scale_file_history, only: &
       file_history_reg
    implicit none
 
    logical :: lt_force_with_suzuki10 = .false. ! experimental use only
 
    namelist / param_atmos_phy_lt / &
         lt_force_with_suzuki10
 
    integer :: ip
    integer :: ierr
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("ATMOS_PHY_LT_driver_setup",*) 'Setup'
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_atmos_phy_lt,iostat=ierr)
    if ( ierr < 0 ) then !--- missing
       log_info("ATMOS_PHY_LT_driver_setup",*) 'Not found namelist. Default used.'
    elseif ( ierr > 0 ) then !--- fatal error
       log_error("ATMOS_PHY_LT_dirver_setup",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_LT. Check!'
       call prc_abort
    end if
    log_nml(param_atmos_phy_lt)
 
    select case( atmos_phy_lt_type )
    case ( 'SATO2019' )
 
       if ( atmos_phy_mp_type == "SUZUKI10" ) then
          log_warn("ATMOS_PHY_LT_driver_setup",*) 'At this moment, ATMOS_PHY_MP_TYPE of SUZUKI10 with SATO2019 scheme is for experimental use only.'
          if ( .not. lt_force_with_suzuki10 ) then
             log_error("ATMOS_PHY_LT_driver_setup",*) 'At this moment, ATMOS_PHY_MP_TYPE of SUZUKI10 with SATO2019 scheme is for experimental use only.'
             call prc_abort
          end if
       end if
 
 
       call atmos_phy_lt_sato2019_setup( ka, ks, ke, & ! [IN]
                                         ia, is, ie, & ! [IN]
                                         ja, js, je, & ! [IN]
                                         imaxg,      & ! [IN]
                                         jmaxg,      & ! [IN]
                                         kmax,       & ! [IN]
                                         atmos_phy_mp_type, & ! [IN]
                                         cdx, cdy           ) ! [IN]
       flg_lt = .true.
    case default
       flg_lt = .false.
    end select
 
 
    if ( flg_lt ) then
 
       allocate( atmos_phy_lt_sarea(ka,ia,ja,qha) )
 
       do ip = 1, w_nmax
          call file_history_reg( w_name(ip), w_longname(ip), w_unit(ip), & ! [IN]
                                 hist_id(ip)                             ) ! [OUT]
       end do
 
       call history
 
    else
       log_info("ATMOS_PHY_LT_driver_setup",*) 'This component is never called.'
    endif
 
 
    return
  end subroutine atmos_phy_lt_driver_setup
 
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_lt_driver_finalize
    use scale_atmos_phy_lt_sato2019, only: &
       atmos_phy_lt_sato2019_finalize
    use mod_atmos_admin, only: &
       atmos_phy_lt_type, &
       atmos_sw_phy_lt
    use mod_atmos_phy_lt_vars, only: &
       flg_lt, &
       atmos_phy_lt_sarea
    implicit none
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("ATMOS_PHY_LT_driver_finalize",*) 'Finalize'
 
    if ( atmos_sw_phy_lt ) then
       select case ( atmos_phy_lt_type )
       case ( 'OFF', 'NONE' )
       case ( 'SATO2019' )
          call atmos_phy_lt_sato2019_finalize
       end select
    end if
 
    if ( flg_lt ) then
       deallocate( atmos_phy_lt_sarea )
    end if
 
    return
  end subroutine atmos_phy_lt_driver_finalize
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_lt_driver_adjustment
    use scale_time, only: &
       dt_lt => time_dtsec_atmos_phy_lt
    use mod_atmos_vars, only: &
       dens => dens_av, &
       rhot => rhot_av, &
       qtrc => qtrc_av, &
       atmos_vars_get_diagnostic
    use mod_atmos_phy_lt_vars, only: &
       qa_lt, &
       qs_lt, &
       qe_lt, &
       sarea => atmos_phy_lt_sarea, &
       epot  => atmos_phy_lt_epot
    use scale_atmos_phy_lt_sato2019, only: &
       atmos_phy_lt_sato2019_adjustment
    implicit none
 
    real(rp) :: qhyd(ka,ia,ja)
    !---------------------------------------------------------------------------
 
    !$acc data create(QHYD) &
    !$acc      copyin(DENS,RHOT,QHYD,Sarea) &
    !$acc      copy(QTRC,Epot)
 
    call atmos_vars_get_diagnostic( "QHYD", qhyd(:,:,:) )
 
    call atmos_phy_lt_sato2019_adjustment( &
         ka, ks, ke, ia, is, ie, ja, js, je, kijmax, imax, jmax, qa_lt, & ! [IN]
         dens(:,:,:), rhot(:,:,:), qhyd(:,:,:), sarea(:,:,:,:), & ! [IN]
         dt_lt,                                                 & ! [IN]
         qtrc(:,:,:,qs_lt:qe_lt), epot(:,:,:)                   ) ! [INOUT]
 
    call history
 
    !$acc end data
 
    return
  end subroutine atmos_phy_lt_driver_adjustment
 
  ! private
  subroutine history
    use scale_atmos_hydrometeor, only: &
       qla
    use mod_atmos_phy_lt_vars, only: &
       qs_lt, &
       qe_lt
    use mod_atmos_vars, only: &
       dens => dens_av, &
       qtrc => qtrc_av
    use scale_file_history, only: &
       file_history_query, &
       file_history_put
    implicit none
    real(RP) :: work(KA,IA,JA)
    logical  :: HIST_sw(w_nmax)
    integer  :: k, i, j, n, ip
 
    !$acc data copyin(QTRC,DENS) create(work)
 
    do ip = 1, w_nmax
       call file_history_query( hist_id(ip), hist_sw(ip) )
    end do
 
    if ( hist_sw(i_crgd_liq) ) then
       !$omp parallel do
       !$acc kernels
       do j = js, je
       do i = is, ie
       do k = ks, ke
          work(k,i,j) = 0.0_rp
          do n = qs_lt, qs_lt + qla - 1
             work(k,i,j) = work(k,i,j) + qtrc(k,i,j,n)
          enddo
          work(k,i,j) = work(k,i,j) * dens(k,i,j) * 1.e-6_rp ! [fC/kg] -> [nc/m3]
       end do
       end do
       end do
       !$acc end kernels
       call file_history_put( hist_id(i_crgd_liq), work(:,:,:) )
    end if
    if ( hist_sw(i_crgd_ice) ) then
       !$omp parallel do
       !$acc kernels
       do j = js, je
       do i = is, ie
       do k = ks, ke
          work(k,i,j) = 0.0_rp
          do n = qs_lt + qla, qe_lt
             work(k,i,j) = work(k,i,j) + qtrc(k,i,j,n)
          enddo
          work(k,i,j) = work(k,i,j) * dens(k,i,j) * 1.e-6_rp ! [fC/kg] -> [nc/m3]
       end do
       end do
       end do
       !$acc end kernels
       call file_history_put( hist_id(i_crgd_ice), work(:,:,:) )
    end if
    if ( hist_sw(i_crgd_tot) ) then
       !$omp parallel do
       !$acc kernels
       do j = js, je
       do i = is, ie
       do k = ks, ke
          work(k,i,j) = 0.0_rp
          do n = qs_lt, qe_lt
             work(k,i,j) = work(k,i,j) + qtrc(k,i,j,n)
          enddo
          work(k,i,j) = work(k,i,j) * dens(k,i,j) * 1.e-6_rp ! [fC/kg] -> [nc/m3]
       end do
       end do
       end do
       !$acc end kernels
       call file_history_put( hist_id(i_crgd_tot), work(:,:,:) )
    end if
 
    !$acc end data
 
    return
  end subroutine history
 
end module mod_atmos_phy_lt_driver