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: &
     topo_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
    use scale_topography, only: &
       topo_write
    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'

       ! output topography file
       call topo_write
    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)

    do j = 1, ja
    do i = 1, ia
       topo_zsfc(i,j) = flat_height
    enddo
    enddo

    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
    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

       topo_zsfc(i,j) = bell_height / ( 1.0_rp + dist )

    enddo
    enddo

    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
       do j = 1, ja
       do i = 1, ia

          dist = exp( -( (cx(i)-schaer_cx)/schaer_rx )**2 )

          topo_zsfc(i,j) = schaer_height * dist * ( cos( pi*(cx(i)-schaer_cx)/schaer_lambda ) )**2

       enddo
       enddo
    else
       do j = 1, ja
       do i = 1, ia

          dist = exp( -( (cy(j)-schaer_cx)/schaer_rx )**2 )

          topo_zsfc(i,j) = schaer_height * dist * ( cos( pi*(cy(j)-schaer_cx)/schaer_lambda ) )**2

       enddo
       enddo
    endif

    return
  end subroutine mktopo_schaer

end module mod_mktopo