mod_mktopo.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
#include "scalelib.h"
module mod_mktopo
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
  use scale_prof
  use scale_atmos_grid_cartesc_index
  use scale_tracer
 
  use scale_prc, only: &
     prc_abort
  use scale_atmos_grid_cartesc, only: &
     cx => atmos_grid_cartesc_cx, &
     cy => atmos_grid_cartesc_cy
  use scale_topography, only: &
     topography_zsfc
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: mktopo_setup
  public :: mktopo
 
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  integer, public            :: mktopo_type = -1
  integer, public, parameter :: i_ignore    =  0
  integer, public, parameter :: i_flat      =  1
  integer, public, parameter :: i_bellshape =  2
  integer, public, parameter :: i_schaer    =  3
 
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  private :: mktopo_flat
  private :: mktopo_bellshape
  private :: mktopo_schaer
 
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
 
  !-----------------------------------------------------------------------------
  subroutine mktopo_setup
    implicit none
 
    character(len=H_SHORT) :: mktopo_name = 'NONE'
 
    namelist / param_mktopo / &
       mktopo_name
 
    integer :: ierr
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("MKTOPO_setup",*) 'Setup'
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_mktopo,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("MKTOPO_setup",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("MKTOPO_setup",*) 'Not appropriate names in namelist PARAM_MKTOPO. Check!'
       call prc_abort
    endif
    log_nml(param_mktopo)
 
    select case(mktopo_name)
    case('NONE')
       mktopo_type = i_ignore
    case('FLAT')
       mktopo_type = i_flat
    case('BELLSHAPE')
       mktopo_type = i_bellshape
    case('SCHAER')
       mktopo_type = i_schaer
    case default
       log_error("MKTOPO_setup",*) 'Unsupported TYPE:', trim(mktopo_name)
       call prc_abort
    endselect
 
    return
  end subroutine mktopo_setup
 
  !-----------------------------------------------------------------------------
  subroutine mktopo
    implicit none
    !---------------------------------------------------------------------------
 
    if ( mktopo_type == i_ignore ) then
       log_newline
       log_info("MKTOPO",*) 'SKIP  MAKING TOPOGRAPHY DATA'
    else
       log_newline
       log_info("MKTOP",*) 'START MAKING TOPOGRAPHY DATA'
 
       select case(mktopo_type)
       case(i_flat)
          call mktopo_flat
 
       case(i_bellshape)
          call mktopo_bellshape
 
       case(i_schaer)
          call mktopo_schaer
 
       case default
          log_error("MKTOPO",*) 'Unsupported TYPE:', mktopo_type
          call prc_abort
       endselect
 
       log_info("MKTOPO",*) 'END   MAKING TOPOGRAPHY DATA'
 
    endif
 
    return
  end subroutine mktopo
 
  !-----------------------------------------------------------------------------
  subroutine mktopo_flat
    implicit none
 
    ! flat mountain parameter
    real(rp) :: flat_height   =  100.0_rp ! height of mountain [m]
 
    namelist / param_mktopo_flat / &
       flat_height
 
    integer :: ierr
    integer :: i, j
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("MKTOPO_flat",*) 'Setup'
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_mktopo_flat,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("MKTOPO_flat",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("MKTOPO_flat",*) 'Not appropriate names in namelist PARAM_MKTOPO_FLAT. Check!'
       call prc_abort
    endif
    log_nml(param_mktopo_flat)
 
    !$acc kernels
    do j = 1, ja
    do i = 1, ia
       topography_zsfc(i,j) = flat_height
    enddo
    enddo
    !$acc end kernels
 
    return
  end subroutine mktopo_flat
 
  !-----------------------------------------------------------------------------
  subroutine mktopo_bellshape
    implicit none
 
    ! bell-shaped mountain parameter
    logical  :: bell_eachnode = .false.   ! Arrange mountain at each node? [kg/kg]
    real(rp) :: bell_cx       =   2.e3_rp ! center location [m]: x
    real(rp) :: bell_cy       =   2.e3_rp ! center location [m]: y
    real(rp) :: bell_rx       =   2.e3_rp ! bubble radius   [m]: x
    real(rp) :: bell_ry       =   2.e3_rp ! bubble radius   [m]: y
    real(rp) :: bell_height   =  100.0_rp ! height of mountain [m]
 
    namelist / param_mktopo_bellshape / &
       bell_eachnode, &
       bell_cx,       &
       bell_cy,       &
       bell_rx,       &
       bell_ry,       &
       bell_height
 
    real(rp) :: cx_offset
    real(rp) :: cy_offset
    real(rp) :: dist
 
    integer :: ierr
    integer :: i, j
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("MKTOPO_bellshape",*) 'Setup'
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_mktopo_bellshape,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("MKTOPO_bellshape",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("MKTOPO_bellshape",*) 'Not appropriate names in namelist PARAM_MKTOPO_BELLSHAPE. Check!'
       call prc_abort
    endif
    log_nml(param_mktopo_bellshape)
 
    if ( bell_eachnode ) then
       cx_offset = cx(is)
       cy_offset = cy(js)
    else
       cx_offset = 0.0_rp
       cy_offset = 0.0_rp
    endif
 
    ! make bell-shaped mountain
    !$acc kernels
    do j = 1, ja
    do i = 1, ia
 
       dist = ( (cx(i)-cx_offset-bell_cx)/bell_rx )**2 &
            + ( (cy(j)-cy_offset-bell_cy)/bell_ry )**2
 
       topography_zsfc(i,j) = bell_height / ( 1.0_rp + dist )
 
    enddo
    enddo
    !$acc end kernels
 
    return
  end subroutine mktopo_bellshape
 
  !-----------------------------------------------------------------------------
  subroutine mktopo_schaer
    use scale_const, only: &
       pi => const_pi
    implicit none
 
    ! Schaer-type mountain parameter
    real(rp) :: schaer_cx       =  25.e3_rp ! center location [m]: x
    real(rp) :: schaer_rx       =   5.e3_rp ! bubble radius   [m]: x
    real(rp) :: schaer_lambda   =   4.e3_rp ! wavelength of wavelike perturbation [m]: x
    real(rp) :: schaer_height   =  250.0_rp ! height of mountain [m]
    logical  :: schaer_swapxy   =  .false.
 
    namelist / param_mktopo_schaer / &
       schaer_cx,     &
       schaer_rx,     &
       schaer_lambda, &
       schaer_height, &
       schaer_swapxy
 
    real(rp) :: dist
 
    integer :: ierr
    integer :: i, j
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("MKTOPO_schaer",*) 'Setup'
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_mktopo_schaer,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("MKTOPO_schaer",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("MKTOPO_schaer",*) 'Not appropriate names in namelist PARAM_MKTOPO_SCHAER. Check!'
       call prc_abort
    endif
    log_nml(param_mktopo_schaer)
 
    ! make bell-shaped mountain
    if ( .NOT. schaer_swapxy ) then
       !$acc kernels
       do j = 1, ja
       do i = 1, ia
 
          dist = exp( -( (cx(i)-schaer_cx)/schaer_rx )**2 )
 
          topography_zsfc(i,j) = schaer_height * dist * ( cos( pi*(cx(i)-schaer_cx)/schaer_lambda ) )**2
 
       enddo
       enddo
       !$acc end kernels
    else
       !$acc kernels
       do j = 1, ja
       do i = 1, ia
 
          dist = exp( -( (cy(j)-schaer_cx)/schaer_rx )**2 )
 
          topography_zsfc(i,j) = schaer_height * dist * ( cos( pi*(cy(j)-schaer_cx)/schaer_lambda ) )**2
 
       enddo
       enddo
       !$acc end kernels
    endif
 
    return
  end subroutine mktopo_schaer
 
end module mod_mktopo