scale_prc_cartesC.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
#include "scalelib.h"
module scale_prc_cartesc
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use mpi
  use scale_precision
  use scale_io
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: prc_cartesc_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

  logical, public              :: prc_periodic_x   = .true.  
  logical, public              :: prc_periodic_y   = .true.  

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine prc_cartesc_setup
    use scale_prc, only: &
       prc_abort,                &
       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_CART_REORDER = .false. 

    namelist / param_prc_cartesc / &
       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
    !---------------------------------------------------------------------------

    log_newline
    log_info("PRC_CARTESC_setup",*) 'Setup'

    if ( io_l ) then
       log_newline
       log_progress(*) 'start MPI'
       log_newline
       log_info("PRC_CARTESC_setup",*) 'Process information '
       log_info_cont('(1x,A,I12)')     'UNIVERSAL_COMM_WORLD        : ', prc_universal_comm_world
       log_info_cont('(1x,A,I12)')     'total process [UNIVERSAL]   : ', prc_universal_nprocs
       log_info_cont('(1x,A,I12)')     'my process ID [UNIVERSAL]   : ', prc_universal_myrank
       log_info_cont('(1x,A,L12)')     'master rank?  [UNIVERSAL]   : ', prc_universal_ismaster
       log_info_cont('(1x,A,I12)')     'GLOBAL_COMM_WORLD           : ', prc_global_comm_world
       log_info_cont('(1x,A,I12)')     'total process [GLOBAL]      : ', prc_global_nprocs
       log_info_cont('(1x,A,I12)')     'my process ID [GLOBAL]      : ', prc_global_myrank
       log_info_cont('(1x,A,L12)')     'master rank?  [GLOBAL]      : ', prc_global_ismaster
       log_info_cont('(1x,A,I12)')     'LOCAL_COMM_WORLD            : ', prc_local_comm_world
       log_info_cont('(1x,A,I12)')     'total process [LOCAL]       : ', prc_nprocs
       log_info_cont('(1x,A,I12)')     'my process ID [LOCAL]       : ', prc_myrank
       log_info_cont('(1x,A,L12)')     'master rank?  [LOCAL]       : ', prc_ismaster
       log_info_cont('(1x,A,I12)')     'ABORT_COMM_WORLD            : ', prc_abort_comm_world
       log_info_cont('(1x,A,I12)')     'master rank ID [each world] : ', prc_masterrank
    endif

    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_prc_cartesc,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("PRC_CARTESC_setup",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("PRC_CARTESC_setup",*) 'Not appropriate names in namelist PARAM_PRC_CARTESC. Check!'
       call prc_abort
    endif
    if( io_nml ) write(io_fid_nml,nml=param_prc_cartesc)

    log_newline
    log_info("PRC_CARTESC_setup",*) 'Process allocation '
    log_info_cont(*)                'No. of Node   :', prc_num_x," x ",prc_num_y

    if ( prc_num_x*prc_num_y /= prc_nprocs ) then
       log_error("PRC_CARTESC_setup",*) 'total number of node does not match that requested. Check!'
       call prc_abort
    endif

    if ( mod(prc_nprocs,prc_num_x) /= 0 ) then
       log_error("PRC_CARTESC_setup",*) 'number of requested node cannot devide to 2D. Check!'
       call prc_abort
    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

    log_info("PRC_CARTESC_setup",*) 'Node topology :'
    log_info_cont('(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),')'
    log_info_cont('(1x,A)') '             |                       |                       |'
    log_info_cont('(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),')'
    log_info_cont('(1x,A)') '             |                       |                       |'
    log_info_cont('(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_cartesc_setup

end module scale_prc_cartesc