scale_rm_process.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
module scale_rm_process
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use mpi
  use gtool_file, only: &
     filecloseall
  use scale_precision
  use scale_stdio
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: prc_setup

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  integer, public, parameter   :: prc_w  = 1
  integer, public, parameter   :: prc_n  = 2
  integer, public, parameter   :: prc_e  = 3
  integer, public, parameter   :: prc_s  = 4
  integer, public, parameter   :: prc_nw = 5
  integer, public, parameter   :: prc_ne = 6
  integer, public, parameter   :: prc_sw = 7
  integer, public, parameter   :: prc_se = 8

  integer, public              :: prc_num_x  = 1
  integer, public              :: prc_num_y  = 1

  integer, public, allocatable :: prc_2drank(:,:)
  integer, public              :: prc_next(8) = -1

  logical, public              :: prc_has_w
  logical, public              :: prc_has_n
  logical, public              :: prc_has_e
  logical, public              :: prc_has_s

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine prc_setup
    use scale_process, only: &
       prc_mpistop,              &
       prc_masterrank,           &
       prc_mpi_alive,            &
       prc_abort_comm_world,     &
       prc_universal_comm_world, &
       prc_universal_nprocs,     &
       prc_universal_myrank,     &
       prc_universal_ismaster,   &
       prc_global_comm_world,    &
       prc_global_nprocs,        &
       prc_global_myrank,        &
       prc_global_ismaster,      &
       prc_local_comm_world,     &
       prc_nprocs,               &
       prc_myrank,               &
       prc_ismaster
    implicit none

    logical :: PRC_PERIODIC_X   = .true.  
    logical :: PRC_PERIODIC_Y   = .true.  
    logical :: PRC_CART_REORDER = .false. 

    namelist / param_prc / &
       prc_num_x,      &
       prc_num_y,      &
       prc_periodic_x, &
       prc_periodic_y, &
       prc_cart_reorder

    logical :: period(2)
    integer :: divide(2)
    integer :: coords_W(2)
    integer :: coords_N(2)
    integer :: coords_E(2)
    integer :: coords_S(2)
    integer :: next_coords(2)
    integer :: iptbl
    integer :: next(8)

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

    if( io_l ) write(io_fid_log,*)
    if( io_l ) write(io_fid_log,*) '++++++ Module[PROCESS] / Categ[ATMOS-RM COMM] / Origin[SCALElib]'

    if ( io_l ) then
       write(io_fid_log,*)            ''
       write(io_fid_log,*)            '++++++ Start MPI'
       write(io_fid_log,'(1x,A,I12)') '*** UNIVERSAL_COMM_WORLD        : ', prc_universal_comm_world
       write(io_fid_log,'(1x,A,I12)') '*** total process [UNIVERSAL]   : ', prc_universal_nprocs
       write(io_fid_log,'(1x,A,I12)') '*** my process ID [UNIVERSAL]   : ', prc_universal_myrank
       write(io_fid_log,'(1x,A,L12)') '*** master rank?  [UNIVERSAL]   : ', prc_universal_ismaster
       write(io_fid_log,'(1x,A,I12)') '*** GLOBAL_COMM_WORLD           : ', prc_global_comm_world
       write(io_fid_log,'(1x,A,I12)') '*** total process [GLOBAL]      : ', prc_global_nprocs
       write(io_fid_log,'(1x,A,I12)') '*** my process ID [GLOBAL]      : ', prc_global_myrank
       write(io_fid_log,'(1x,A,L12)') '*** master rank?  [GLOBAL]      : ', prc_global_ismaster
       write(io_fid_log,'(1x,A,I12)') '*** LOCAL_COMM_WORLD            : ', prc_local_comm_world
       write(io_fid_log,'(1x,A,I12)') '*** total process [LOCAL]       : ', prc_nprocs
       write(io_fid_log,'(1x,A,I12)') '*** my process ID [LOCAL]       : ', prc_myrank
       write(io_fid_log,'(1x,A,L12)') '*** master rank?  [LOCAL]       : ', prc_ismaster
       write(io_fid_log,'(1x,A,I12)') '*** ABORT_COMM_WORLD            : ', prc_abort_comm_world
       write(io_fid_log,'(1x,A,I12)') '*** master rank ID [each world] : ', prc_masterrank
    endif

    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_prc,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_PRC. Check!'
       call prc_mpistop
    endif
    if( io_lnml ) write(io_fid_log,nml=param_prc)

    if( io_l ) write(io_fid_log,*)
    if( io_l ) write(io_fid_log,*) '*** Process Allocation ***'
    if( io_l ) write(io_fid_log,*) '*** No. of Node   :', prc_num_x," x ",prc_num_y

    if ( prc_num_x*prc_num_y /= prc_nprocs ) then
       write(*,*) 'xxx total number of node does not match that requested. Check!'
       call prc_mpistop
    endif

    if ( mod(prc_nprocs,prc_num_x) /= 0 ) then
       write(*,*) 'xxx number of requested node cannot devide to 2D. Check!'
       call prc_mpistop
    endif

    ! set communication topology
    allocate( prc_2drank(-1:prc_nprocs-1,2) )
    prc_2drank(:,:) = -1

    do p = 0, prc_nprocs-1
       prc_2drank(p,1) = mod(p,prc_num_x)
       prc_2drank(p,2) = (p-prc_2drank(p,1)) / prc_num_x
    enddo

    divide(1) = prc_num_y
    divide(2) = prc_num_x
    period(1) = prc_periodic_y
    period(2) = prc_periodic_x
    if ( prc_mpi_alive ) then
       call mpi_cart_create(prc_local_comm_world,2,divide,period,prc_cart_reorder,iptbl,ierr)
       call mpi_cart_shift(iptbl,0,1,prc_next(prc_s),prc_next(prc_n),ierr) ! next rank search Down/Up
       call mpi_cart_shift(iptbl,1,1,prc_next(prc_w),prc_next(prc_e),ierr) ! next rank search Left/Right

       ! get neighbor_coordinates
       prc_has_w = prc_next(prc_w) /= mpi_proc_null
       if( prc_has_w ) call mpi_cart_coords(iptbl,prc_next(prc_w),2,coords_w,ierr)
       prc_has_n = prc_next(prc_n) /= mpi_proc_null
       if( prc_has_n ) call mpi_cart_coords(iptbl,prc_next(prc_n),2,coords_n,ierr)
       prc_has_e = prc_next(prc_e) /= mpi_proc_null
       if( prc_has_e ) call mpi_cart_coords(iptbl,prc_next(prc_e),2,coords_e,ierr)
       prc_has_s = prc_next(prc_s) /= mpi_proc_null
       if( prc_has_s ) call mpi_cart_coords(iptbl,prc_next(prc_s),2,coords_s,ierr)
       ! next rank search NorthWest
       if (      .NOT. prc_has_n &
            .OR. .NOT. prc_has_w ) then
          prc_next(prc_nw) = mpi_proc_null
       else
          next_coords(1) = coords_n(1)
          next_coords(2) = coords_w(2)
          call mpi_cart_rank(iptbl, next_coords, prc_next(prc_nw), ierr)
       endif
       ! next rank search NorthEast
       if (      .NOT. prc_has_n &
            .OR. .NOT. prc_has_e ) then
          prc_next(prc_ne) = mpi_proc_null
       else
          next_coords(1) = coords_n(1)
          next_coords(2) = coords_e(2)
          call mpi_cart_rank(iptbl, next_coords, prc_next(prc_ne), ierr)
       endif
       ! next rank search SouthWest
       if (      .NOT. prc_has_s &
            .OR. .NOT. prc_has_w ) then
          prc_next(prc_sw) = mpi_proc_null
       else
          next_coords(1) = coords_s(1)
          next_coords(2) = coords_w(2)
          call mpi_cart_rank(iptbl, next_coords, prc_next(prc_sw), ierr)
       endif
       ! next rank search SouthEast
       if (      .NOT. prc_has_s &
            .OR. .NOT. prc_has_e ) then
          prc_next(prc_se) = mpi_proc_null
       else
          next_coords(1) = coords_s(1)
          next_coords(2) = coords_e(2)
          call mpi_cart_rank(iptbl, next_coords, prc_next(prc_se), ierr)
       endif
       call mpi_comm_free(iptbl,ierr)
    endif

    next(:) = max(prc_next(:),-1) ! avoid if MPI_PROC_NULL < -1

    if( io_l ) write(io_fid_log,*) '*** Node topology :'
    if( io_l ) write(io_fid_log,'(1x,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A)') &
    '***  NW(',next(prc_nw),',',prc_2drank(next(prc_nw),1),',',prc_2drank(next(prc_nw),2),')', &
      ' -  N(',next(prc_n) ,',',prc_2drank(next(prc_n) ,1),',',prc_2drank(next(prc_n) ,2),')', &
      ' - NE(',next(prc_ne),',',prc_2drank(next(prc_ne),1),',',prc_2drank(next(prc_ne),2),')'
    if( io_l ) write(io_fid_log,'(1x,A)') '***                                  |'
    if( io_l ) write(io_fid_log,'(1x,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A)') &
    '***   W(',next(prc_w),',',prc_2drank(next(prc_w),1),',',prc_2drank(next(prc_w),2),')', &
      ' -  P(',prc_myrank ,',',prc_2drank(prc_myrank, 1),',',prc_2drank(prc_myrank, 2),')', &
      ' -  E(',next(prc_e),',',prc_2drank(next(prc_e),1),',',prc_2drank(next(prc_e),2),')'
    if( io_l ) write(io_fid_log,'(1x,A)') '***                                  |'
    if( io_l ) write(io_fid_log,'(1x,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A)') &
    '***  SW(',next(prc_sw),',',prc_2drank(next(prc_sw),1),',',prc_2drank(next(prc_sw),2),')', &
      ' -  S(',next(prc_s) ,',',prc_2drank(next(prc_s) ,1),',',prc_2drank(next(prc_s) ,2),')', &
      ' - SE(',next(prc_se),',',prc_2drank(next(prc_se),1),',',prc_2drank(next(prc_se),2),')'

    return
  end subroutine prc_setup

end module scale_rm_process