scale_prc_icoA.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
#include "scalelib.h"
module scale_prc_icoa
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use mpi
  use scale_precision
  use scale_io
  use scale_prc, only: &
     prc_masterrank
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: prc_icoa_setup
  public :: prc_icoa_rgn_generate

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !

  !====== Information for processes ======

  integer,  public, parameter   :: prc_rank_pl = prc_masterrank 
  logical,  public              :: prc_have_pl

  !====== Information for processes-region relationship ======

  integer,  public, parameter   :: i_l   = 1
  integer,  public, parameter   :: i_prc = 2

  integer,  public, parameter   :: i_rgnid = 1
  integer,  public, parameter   :: i_dir   = 2

  ! Identifiers of directions of region edges
  integer,  public, parameter   :: i_sw = 1
  integer,  public, parameter   :: i_nw = 2
  integer,  public, parameter   :: i_ne = 3
  integer,  public, parameter   :: i_se = 4

  ! Identifiers of directions of region vertices
  integer,  public, parameter   :: i_w = 1
  integer,  public, parameter   :: i_n = 2
  integer,  public, parameter   :: i_e = 3
  integer,  public, parameter   :: i_s = 4

  ! Identifier of poles (north pole or south pole)
  integer,  public, parameter   :: i_npl = 1
  integer,  public, parameter   :: i_spl = 2

  ! main parameter
  integer,  public              :: prc_rgn_level   = -1
  integer,  public              :: prc_rgn_dmd     = 10
  integer,  public              :: prc_rgn_vlink   = 5

  ! region
  integer,  public              :: prc_rgn_total
  integer,  public              :: prc_rgn_local
  integer,  public, parameter   :: prc_rgn_total_pl  = 2

  integer,  public, parameter   :: prc_rgn_local_lim = 2560

  integer,  public, allocatable :: prc_rgn_edge_tab   (:,:,:)

  integer,  public, allocatable :: prc_rgn_vert_num   (:,:)
  integer,  public, allocatable :: prc_rgn_vert_tab   (:,:,:,:)
  integer,  public, allocatable :: prc_rgn_vert_tab_pl(:,:,:)

  integer,  public, allocatable :: prc_rgn_lp2r(:,:)
  integer,  public, allocatable :: prc_rgn_r2lp(:,:)
  integer,  public, allocatable :: prc_rgn_l2r (:)

  integer,  public              :: prc_rgn_r2p_pl(prc_rgn_total_pl)
  integer,  public              :: prc_rgn_rgn4pl(prc_rgn_total_pl)

  !====== Information for regions ======

  logical,  public, allocatable :: prc_rgn_have_sgp(:)

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  private :: prc_icoa_rgn_setup
  private :: prc_icoa_rgn_input
  private :: prc_icoa_rgn_output
  private :: prc_icoa_rgn_vertex_walkaround
  private :: output_info

  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  character(len=H_LONG), private            :: prc_icoa_rgn_in_fname  = ''
  character(len=H_LONG), private            :: prc_icoa_rgn_out_fname = ''

  character(len=2),      private, parameter :: prc_rgn_edgename(4) = (/'SW','NW','NE','SE'/)
  character(len=2),      private, parameter :: prc_rgn_vertname(4) = (/'W ','N ','E ','S '/)

  logical, private :: debug = .false. 

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine prc_icoa_setup
    use scale_prc, only: &
       prc_abort,                &
       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

    namelist / param_prc_icoa / &
       prc_rgn_level, &
       debug

    integer :: l, rgnid

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

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

    if ( io_l ) then
       log_newline
       log_progress(*) 'start MPI'
       log_newline
       log_info("PRC_ICOA_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_icoa,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("PRC_ICOA_setup",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("PRC_ICOA_setup",*) 'Not appropriate names in namelist PARAM_PRC_ICOA. Check!'
       call prc_abort
    endif
    if( io_nml ) write(io_fid_nml,nml=param_prc_icoa)

    if ( prc_rgn_level < 0 ) then
       log_error("PRC_ICOA_setup",*) 'PRC_RGN_level is not appropriate :', prc_rgn_level
       call prc_abort
    endif

    prc_rgn_total = 2**prc_rgn_level * 2**prc_rgn_level * prc_rgn_dmd
    prc_rgn_local = prc_rgn_total / prc_nprocs

    if ( mod(prc_rgn_total,prc_nprocs) /= 0 ) then
       log_error("PRC_ICOA_setup",*) 'Number of total region must be divisible by the number of process', prc_rgn_total, prc_nprocs
       call prc_abort
    endif

    if ( prc_rgn_local > prc_rgn_local_lim ) then
       log_error("PRC_ICOA_setup",*) 'limit exceed! local region: ', prc_rgn_local, prc_rgn_local_lim
       call prc_abort
    endif

    call prc_icoa_rgn_setup

    ! pole region management flag
    if ( prc_myrank == prc_rank_pl ) then
       prc_have_pl = .true.
    else
       prc_have_pl = .false.
    endif

    ! singlar point management flag
    allocate( prc_rgn_have_sgp(prc_rgn_local) )
    prc_rgn_have_sgp(:) = .false.

    do l = 1, prc_rgn_local
       rgnid = prc_rgn_lp2r(l,prc_myrank)
       if ( prc_rgn_vert_num(i_w,rgnid) == 3 ) then
          prc_rgn_have_sgp(l) = .true.
       endif
    enddo

    call output_info

    return
  end subroutine prc_icoa_setup

  !-----------------------------------------------------------------------------
  subroutine prc_icoa_rgn_setup
    use scale_prc, only: &
       prc_abort,  &
       prc_nprocs, &
       prc_myrank
    implicit none

    namelist / param_prc_icoa_rgn / &
       prc_icoa_rgn_in_fname,  &
       prc_icoa_rgn_out_fname, &
       debug

    integer  :: l, p, r
    integer  :: ierr
    !---------------------------------------------------------------------------

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

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

    ! Global information (Each process has all the information)
    allocate( prc_rgn_edge_tab(i_rgnid:i_dir,i_sw:i_se,prc_rgn_total) )
    allocate( prc_rgn_lp2r(prc_rgn_local,0:prc_nprocs-1) )

    if ( prc_icoa_rgn_in_fname /= '' ) then
       call prc_icoa_rgn_input( prc_icoa_rgn_in_fname,   & ! [IN]
                                prc_nprocs,              & ! [IN]
                                prc_rgn_total,           & ! [IN]
                                prc_rgn_local,           & ! [IN]
                                prc_rgn_edge_tab(:,:,:), & ! [OUT]
                                prc_rgn_lp2r(:,:)    ) ! [OUT]
    else
       log_info("PRC_ICOA_RGN_setup",*) 'input file is not specified.'

       call prc_icoa_rgn_generate( prc_rgn_level,           & ! [IN]
                                   prc_nprocs,              & ! [IN]
                                   prc_rgn_total,           & ! [IN]
                                   prc_rgn_local,           & ! [IN]
                                   prc_rgn_edge_tab(:,:,:), & ! [OUT]
                                   prc_rgn_lp2r(:,:)    ) ! [OUT]
    endif

    if ( prc_icoa_rgn_out_fname /= '' ) then
       call prc_icoa_rgn_output( prc_icoa_rgn_out_fname,  & ! [IN]
                                 prc_nprocs,              & ! [IN]
                                 prc_rgn_total,           & ! [IN]
                                 prc_rgn_local,           & ! [IN]
                                 prc_rgn_edge_tab(:,:,:), & ! [IN]
                                 prc_rgn_lp2r(:,:)    ) ! [IN]
    endif

    !--- additional table (reversal,local)
    allocate( prc_rgn_r2lp(2,prc_rgn_total) )
    allocate( prc_rgn_l2r(  prc_rgn_local) )

    do p = 0, prc_nprocs-1
    do l = 1, prc_rgn_local
       prc_rgn_r2lp(i_l,  prc_rgn_lp2r(l,p)) = l
       prc_rgn_r2lp(i_prc,prc_rgn_lp2r(l,p)) = p
    enddo
    enddo

    do l = 1, prc_rgn_local
       prc_rgn_l2r(l) = prc_rgn_lp2r(l,prc_myrank)
    enddo

    !--- region connection chains around the diamond vertexes
    allocate( prc_rgn_vert_num(i_w:i_s,prc_rgn_total) )
    allocate( prc_rgn_vert_tab(i_rgnid:i_dir,i_w:i_s,prc_rgn_total   ,prc_rgn_vlink) )
    allocate( prc_rgn_vert_tab_pl(i_rgnid:i_dir,        prc_rgn_total_pl,prc_rgn_vlink) )

    call prc_icoa_rgn_vertex_walkaround( prc_rgn_total,             & ! [IN]
                                    prc_rgn_total_pl,          & ! [IN]
                                    prc_rgn_vlink,             & ! [IN]
                                    prc_rgn_edge_tab(:,:,:),   & ! [IN]
                                    prc_rgn_vert_num(:,:),     & ! [OUT]
                                    prc_rgn_vert_tab(:,:,:,:), & ! [OUT]
                                    prc_rgn_vert_tab_pl(:,:,:) ) ! [OUT]

    !--- tables for pole
    do r = 1, prc_rgn_total
       if ( prc_rgn_vert_num(i_n,r) == prc_rgn_vlink ) then
          prc_rgn_rgn4pl(i_npl) = r
          exit
       endif
    enddo

    do r = 1, prc_rgn_total
       if ( prc_rgn_vert_num(i_s,r) == prc_rgn_vlink ) then
          prc_rgn_rgn4pl(i_spl) = r
          exit
       endif
    enddo

    prc_rgn_r2p_pl(i_npl) = prc_rank_pl
    prc_rgn_r2p_pl(i_spl) = prc_rank_pl

    return
  end subroutine prc_icoa_rgn_setup

  !-----------------------------------------------------------------------------
  subroutine prc_icoa_rgn_input( &
       in_fname, &
       pall,     &
       rall,     &
       lall,     &
       edge_tab, &
       lp2r      )
    use scale_prc, only: &
       prc_abort
    implicit none

    character(len=*), intent(in)  :: in_fname
    integer,          intent(in)  :: pall
    integer,          intent(in)  :: rall
    integer,          intent(in)  :: lall
    integer,          intent(out) :: edge_tab(2,4,rall)
    integer,          intent(out) :: lp2r(lall,0:pall-1)

    integer :: num_of_rgn

    namelist / rgn_info / &
       num_of_rgn

    integer :: rgnid
    integer :: sw(2) = -1
    integer :: nw(2) = -1
    integer :: ne(2) = -1
    integer :: se(2) = -1

    namelist / rgn_link_info / &
       rgnid, &
       sw,    &
       nw,    &
       ne,    &
       se

    integer :: num_of_proc

    namelist / proc_info / &
       num_of_proc

    integer :: peid
    integer :: num_of_mng
    integer :: mng_rgnid(prc_rgn_local_lim)

    namelist / rgn_mng_info / &
       peid,       &
       num_of_mng, &
       mng_rgnid

    integer  :: fid, ierr
    integer  :: r, p, l
    !---------------------------------------------------------------------------

    log_info("PRC_ICOA_RGN_input",*) 'input region management information file: ', trim(in_fname)

    fid = io_get_available_fid()
    open( unit   = fid,            &
          file   = trim(in_fname), &
          form   = 'formatted',    &
          status = 'old',          &
          iostat = ierr            )

       ! ERROR if filename are not defined
       if ( ierr /= 0 ) then
          log_error("PRC_ICOA_RGN_input",*) 'File is not found!', trim(in_fname)
          call prc_abort
       endif

       read(fid,nml=rgn_info)

       if ( num_of_rgn /= rall ) then
          log_error("PRC_ICOA_RGN_input",*) 'Missmatch of region number!'
          log_error_cont(*)                 'rall= ', rall,', num_of_rgn=', num_of_rgn
          call prc_abort
       endif

       do r = 1, rall
          read(fid,nml=rgn_link_info)

          edge_tab(i_rgnid:i_dir,i_sw,rgnid) = sw(i_rgnid:i_dir)
          edge_tab(i_rgnid:i_dir,i_nw,rgnid) = nw(i_rgnid:i_dir)
          edge_tab(i_rgnid:i_dir,i_ne,rgnid) = ne(i_rgnid:i_dir)
          edge_tab(i_rgnid:i_dir,i_se,rgnid) = se(i_rgnid:i_dir)
       enddo

       read(fid,nml=proc_info)
       if ( num_of_proc /= pall ) then
          log_error("PRC_ICOA_RGN_input",*) ' Missmatch of process number!'
          log_error_cont(*)                 ' pall= ', pall, ', num_of_proc=', num_of_proc
          call prc_abort
       endif

       do p = 0, pall-1
          read(fid,nml=rgn_mng_info)

          if ( p /= peid ) then
             log_error("PRC_ICOA_RGN_input",*) 'Wrong peid: ', p, peid
             call prc_abort
          endif

          if ( num_of_mng /= lall ) then
             log_error("PRC_ICOA_RGN_input",*) 'number of local region is not match: ', p, num_of_mng, lall
             call prc_abort
          endif

          lp2r(:,p) = -1 ! initialize
          do l = 1, lall
             lp2r(l,p) = mng_rgnid(l)
          enddo
       enddo

    close(fid)

    return
  end subroutine prc_icoa_rgn_input

  !-----------------------------------------------------------------------------
  subroutine prc_icoa_rgn_output( &
       out_fname, &
       pall,      &
       rall,      &
       lall,      &
       edge_tab,  &
       lp2r       )
    use scale_prc, only: &
       prc_ismaster
    implicit none

    character(len=*), intent(in) :: out_fname
    integer,          intent(in) :: pall
    integer,          intent(in) :: rall
    integer,          intent(in) :: lall
    integer,          intent(in) :: edge_tab(2,4,rall)
    integer,          intent(in) :: lp2r(lall,pall)

    integer :: num_of_rgn

    namelist / rgn_info / &
       num_of_rgn

    integer :: rgnid
    integer :: sw(2) = -1
    integer :: nw(2) = -1
    integer :: ne(2) = -1
    integer :: se(2) = -1

    namelist / rgn_link_info / &
       rgnid, &
       sw,    &
       nw,    &
       ne,    &
       se

    integer :: num_of_proc

    namelist / proc_info / &
       num_of_proc

    integer :: peid
    integer :: num_of_mng
    integer :: mng_rgnid(prc_rgn_local_lim)

    namelist / rgn_mng_info / &
       peid,       &
       num_of_mng, &
       mng_rgnid

    integer  :: fid
    integer  :: r, p, l
    !---------------------------------------------------------------------------

    if ( prc_ismaster ) then
       log_info("PRC_ICOA_RGN_output",*) 'output region management information file: ', trim(out_fname)

       fid = io_get_available_fid()
       open( unit   = fid,             &
             file   = trim(out_fname), &
             form   = 'formatted'      )

          num_of_rgn = rall
          write(fid,nml=rgn_info)

          do r = 1, rall
             rgnid = r
             sw(i_rgnid:i_dir) = edge_tab(i_rgnid:i_dir,i_sw,rgnid)
             nw(i_rgnid:i_dir) = edge_tab(i_rgnid:i_dir,i_nw,rgnid)
             ne(i_rgnid:i_dir) = edge_tab(i_rgnid:i_dir,i_ne,rgnid)
             se(i_rgnid:i_dir) = edge_tab(i_rgnid:i_dir,i_se,rgnid)

             write(fid,nml=rgn_link_info)
          enddo

          num_of_proc = pall
          write(fid,nml=proc_info)

          do p = 0, pall-1
             peid       = p
             num_of_mng = lall

             mng_rgnid(:) = -1
             do l = 1, lall
                mng_rgnid(l) = lp2r(l,p)
             enddo

             write(fid,nml=rgn_mng_info)
          enddo

       close(fid)
    else
       log_info("PRC_ICOA_RGN_output",*) 'output region management information file at the master process'
    endif

    return
  end subroutine prc_icoa_rgn_output

  !-----------------------------------------------------------------------------
  Subroutine prc_icoa_rgn_generate( &
       rlevel,   &
       pall,     &
       rall,     &
       lall,     &
       edge_tab, &
       lp2r      )
    use scale_prc, only: &
       prc_abort
    implicit none

    integer, intent(in)  :: rlevel
    integer, intent(in)  :: pall
    integer, intent(in)  :: rall
    integer, intent(in)  :: lall
    integer, intent(out) :: edge_tab(2,4,rall)
    integer, intent(out) :: lp2r(lall,0:pall-1)

    integer, parameter :: nmax_dmd = 10
    integer            :: dmd_data(4,nmax_dmd)
    integer            :: rall_1d, rall_1dmd

    integer :: d_nb, i_nb, j_nb, rgnid_nb, direction
    integer :: d, i, j, rgnid
    integer :: l, p
    !---------------------------------------------------------------------------

    log_info("PRC_ICOA_RGN_generate",*) 'generate region management information file'
    log_info_cont(*)                    'Topology: icosahedral'

    dmd_data(:, 1) = (/  6, 5, 2,10 /)
    dmd_data(:, 2) = (/ 10, 1, 3, 9 /)
    dmd_data(:, 3) = (/  9, 2, 4, 8 /)
    dmd_data(:, 4) = (/  8, 3, 5, 7 /)
    dmd_data(:, 5) = (/  7, 4, 1, 6 /)
    dmd_data(:, 6) = (/  7, 5, 1,10 /)
    dmd_data(:, 7) = (/  8, 4, 5, 6 /)
    dmd_data(:, 8) = (/  9, 3, 4, 7 /)
    dmd_data(:, 9) = (/ 10, 2, 3, 8 /)
    dmd_data(:,10) = (/  6, 1, 2, 9 /)

    rall_1d   = 2**rlevel
    rall_1dmd = rall_1d*rall_1d

    !--- make region link table
    do d = 1, nmax_dmd
    do i = 1, rall_1d
    do j = 1, rall_1d
       rgnid = (d-1)*rall_1dmd + (j-1)*rall_1d + i

       !--- I_SW
       if ( j == 1 ) then
          if ( d <= 5 ) then
             i_nb = i
             j_nb = rall_1d
             d_nb = dmd_data(i_sw,d)
             direction = i_ne
          else
             i_nb = rall_1d
             j_nb = rall_1d+1-i
             d_nb = dmd_data(i_sw,d)
             direction = i_se
          endif
       else
          i_nb = i
          j_nb = j-1
          d_nb = d
          direction = i_ne
       endif
       rgnid_nb = (d_nb-1)*rall_1dmd + (j_nb-1)*rall_1d + i_nb

       edge_tab(i_rgnid,i_sw,rgnid) = rgnid_nb
       edge_tab(i_dir,  i_sw,rgnid) = direction

       !--- I_NW
       if ( i == 1 ) then
          if ( d <= 5 ) then
             i_nb = rall_1d+1-j
             j_nb = rall_1d
             d_nb = dmd_data(i_nw,d)
             direction = i_ne
          else
             i_nb = rall_1d
             j_nb = j
             d_nb = dmd_data(i_nw,d)
             direction = i_se
          endif
       else
          i_nb = i-1
          j_nb = j
          d_nb = d
          direction = i_se
       endif
       rgnid_nb = (d_nb-1)*rall_1dmd + (j_nb-1)*rall_1d + i_nb

       edge_tab(i_rgnid,i_nw,rgnid) = rgnid_nb
       edge_tab(i_dir,  i_nw,rgnid) = direction

       !--- I_NE
       if ( j == rall_1d ) then
          if ( d <= 5 ) then
             i_nb = 1
             j_nb = rall_1d+1-i
             d_nb = dmd_data(i_ne,d)
             direction = i_nw
          else
             i_nb = i
             j_nb = 1
             d_nb = dmd_data(i_ne,d)
             direction = i_sw
          endif
       else
          i_nb = i
          j_nb = j+1
          d_nb = d
          direction = i_sw
       endif
       rgnid_nb = (d_nb-1)*rall_1dmd + (j_nb-1)*rall_1d + i_nb

       edge_tab(i_rgnid,i_ne,rgnid) = rgnid_nb
       edge_tab(i_dir,  i_ne,rgnid) = direction

       !--- I_SE
       if ( i == rall_1d ) then
          if ( d <= 5 ) then
             i_nb = 1
             j_nb = j
             d_nb = dmd_data(i_se,d)
             direction = i_nw
          else
             i_nb = rall_1d+1-j
             j_nb = 1
             d_nb = dmd_data(i_se,d)
             direction = i_sw
          endif
       else
          i_nb = i+1
          j_nb = j
          d_nb = d
          direction = i_nw
       endif
       rgnid_nb = (d_nb-1)*rall_1dmd + (j_nb-1)*rall_1d + i_nb

       edge_tab(i_rgnid,i_se,rgnid) = rgnid_nb
       edge_tab(i_dir,  i_se,rgnid) = direction
    enddo
    enddo
    enddo

    !--- make region-pe relationship
    lp2r(:,:) = -1

    rgnid = 0
    do p = 0, pall-1
    do l = 1, lall
       rgnid = rgnid + 1

       lp2r(l,p) = rgnid
    enddo
    enddo

    return
  end Subroutine prc_icoa_rgn_generate

  !-----------------------------------------------------------------------------
  subroutine prc_icoa_rgn_vertex_walkaround( &
       rall,       &
       rall_pl,    &
       vlink,      &
       edge_tab,   &
       vert_num,   &
       vert_tab,   &
       vert_tab_pl )
    implicit none

    integer, intent(in)  :: rall
    integer, intent(in)  :: rall_pl
    integer, intent(in)  :: vlink
    integer, intent(in)  :: edge_tab(2,4,rall)

    integer, intent(out) :: vert_num   (4,rall)
    integer, intent(out) :: vert_tab   (2,4,rall   ,vlink)
    integer, intent(out) :: vert_tab_pl(2  ,rall_pl,vlink)

    integer  :: rgnid, dir
    integer  :: rgnid_next, dir_next

    integer  :: r, d, v
    !---------------------------------------------------------------------------

    vert_num(:,:)     = -1
    vert_tab(:,:,:,:) = -1

    do r = 1, rall
    do d = i_w, i_s

       rgnid = r
       select case(d)
       case(i_w)
          dir = i_sw
       case(i_n)
          dir = i_nw
       case(i_e)
          dir = i_ne
       case(i_s)
          dir = i_se
       end select

       v = 0
       do
          rgnid_next = edge_tab(i_rgnid,dir,rgnid)
          dir_next   = edge_tab(i_dir,  dir,rgnid) - 1

          if( dir_next == 0 ) dir_next = 4
          v = v + 1
          vert_tab(i_rgnid,d,r,v) = rgnid
          vert_tab(i_dir,  d,r,v) = dir

          rgnid = rgnid_next
          dir   = dir_next

          if( rgnid == r ) exit
       enddo
       vert_num(d,r) = v

    enddo
    enddo

    vert_tab_pl(:,:,:) = -1

    do r = 1, rall
       if ( vert_num(i_n,r) == vlink ) then
          do v = 1, vlink
             vert_tab_pl(i_rgnid,i_npl,v) = vert_tab(i_rgnid,i_n,r,v)
             vert_tab_pl(i_dir,  i_npl,v) = vert_tab(i_dir,  i_n,r,v)
          enddo
          exit
       endif
    enddo

    do r = 1, rall
       if ( vert_num(i_s,r) == vlink ) then
          do v = 1, vlink
             vert_tab_pl(i_rgnid,i_spl,v) = vert_tab(i_rgnid,i_s,r,v)
             vert_tab_pl(i_dir,  i_spl,v) = vert_tab(i_dir,  i_s,r,v)
          enddo
          exit
       endif
    enddo

    return
  end subroutine prc_icoa_rgn_vertex_walkaround

  !-----------------------------------------------------------------------------
  subroutine output_info
    use scale_prc, only: &
       prc_myrank
    implicit none

    integer          :: rgnid, rgnid_next
    character(len=2) :: dstr, dstr_next

    integer  :: l, d, v
    !---------------------------------------------------------------------------

    log_newline
    log_info("PRC_ICOA_RGN_setup",'(1x,A)') 'Region management information'
    log_info_cont('(1x,A,A)' )              'Grid sysytem                      : Icosahedral'
    log_info_cont('(1x,A,I7)')              'number of diamond                 : ', prc_rgn_dmd
    log_info_cont('(1x,A,I7)')              'maximum number of vertex linkage  : ', prc_rgn_vlink
    log_newline
    log_info_cont('(1x,A,I7)')              'Region division level (RL)        : ', prc_rgn_level
    log_info_cont('(1x,A,I7,3(A,I4),A)')    'Total number of regular region    : ', prc_rgn_total, &
                                            ' (', 2**prc_rgn_level, ' x', 2**prc_rgn_level, ' x', prc_rgn_dmd, ' )'
    log_info_cont('(1x,A,I7)')              '#  of region per process          : ', prc_rgn_local
    log_info_cont('(1x,A)'   )              'ID of region in my process        : '
    log_info_cont(*)                        prc_rgn_lp2r(:,prc_myrank)
    log_info_cont('(1x,A,I7)')              'Region ID, containing north pole  : ', prc_rgn_rgn4pl(i_npl)
    log_info_cont('(1x,A,I7)')              'Region ID, containing south pole  : ', prc_rgn_rgn4pl(i_spl)
    log_info_cont('(1x,A,I7)')              'Process rank, managing north pole : ', prc_rgn_r2p_pl(i_npl)
    log_info_cont('(1x,A,I7)')              'Process rank, managing south pole : ', prc_rgn_r2p_pl(i_spl)

    if ( debug ) then
       log_newline
       log_info("PRC_ICOA_RGN_setup",'(1x,A)') 'Detailed region management information'

       log_info_cont(*)'--- (l,myrank) => (rgn)'
       do l = 1, prc_rgn_local
          rgnid = prc_rgn_l2r(l)
          log_info_cont('(1x,A,I4,A,I6,A,I6,A)') '--- (',l,',',prc_myrank,') => (',rgnid,') '
       enddo

       log_newline
       log_info_cont(*)'--- Link information'
       do l = 1, prc_rgn_local
          rgnid = prc_rgn_l2r(l)

          log_newline
          log_info_cont(*)'--- edge link: (rgn,direction)'
          do d = i_sw, i_se
             rgnid_next = prc_rgn_edge_tab(i_rgnid,d,rgnid)
             dstr       = prc_rgn_edgename(d)
             dstr_next  = prc_rgn_edgename(prc_rgn_edge_tab(i_dir,d,rgnid))
             log_info_cont('(5x,A,I6,A,A,A,I6,A,A,A)') '(',rgnid,',',dstr,') -> (', rgnid_next,',', dstr_next,')'
          enddo

          log_info_cont(*)'--- vertex link: (rgn)'
          do d = i_w, i_s
             dstr = prc_rgn_vertname(d)
             log_info_contna('(5x,A,I6,A,A,A)') '(',rgnid,',',dstr,')'
             do v = 2, prc_rgn_vert_num(d,rgnid)
                dstr = prc_rgn_vertname(prc_rgn_vert_tab(i_dir,d,rgnid,v))
                log_info_contna('(A,I6,A,A,A)') ' -> (',prc_rgn_vert_tab(i_rgnid,d,rgnid,v),',',dstr,')'
             enddo
             log_newline
          enddo
       enddo

       log_newline
       log_info_cont(*)'--- Pole information (in the global scope)'

       log_newline
       log_info_cont(*)'--- Region ID, containing north pole data : ', prc_rgn_rgn4pl(i_npl)
       log_info_cont(*)'--- vertex link: (north pole)'
       do v = 2, prc_rgn_vlink
          rgnid = prc_rgn_vert_tab_pl(i_rgnid,i_npl,v)
          dstr  = prc_rgn_vertname(prc_rgn_vert_tab_pl(i_dir,i_npl,v))
          log_info_contna('(A,I6,A,A,A)') ' -> (',rgnid,',',dstr,')'
       enddo
       rgnid = prc_rgn_vert_tab_pl(i_rgnid,i_npl,1)
       dstr  = prc_rgn_vertname(prc_rgn_vert_tab_pl(i_dir,i_npl,1))
       log_info_contna('(A,I6,A,A,A)') ' -> (',rgnid,',',dstr,')'
       log_newline
       log_info_cont(*)'--- process, managing north pole : ', prc_rgn_r2p_pl(i_npl)

       log_newline
       log_info_cont(*)'--- Region ID, containing south pole data : ', prc_rgn_rgn4pl(i_spl)
       log_info_cont(*)'--- vertex link: (south pole)'
       do v = 2, prc_rgn_vlink
          rgnid = prc_rgn_vert_tab_pl(i_rgnid,i_spl,v)
          dstr  = prc_rgn_vertname(prc_rgn_vert_tab_pl(i_dir,i_spl,v))
          log_info_contna('(A,I6,A,A,A)') ' -> (',rgnid,',',dstr,')'
       enddo
       rgnid = prc_rgn_vert_tab_pl(i_rgnid,i_spl,1)
       dstr  = prc_rgn_vertname(prc_rgn_vert_tab_pl(i_dir,i_spl,1))
       log_info_contna('(A,I6,A,A,A)') ' -> (',rgnid,',',dstr,')'
       log_newline
       log_info_cont(*)'--- process, managing south pole : ', prc_rgn_r2p_pl(i_spl)
    endif

    return
  end subroutine output_info

end module scale_prc_icoa