scale_prc.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
#include "scalelib.h"
module scale_prc
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use mpi
  use scale_precision
  use scale_io
  use scale_fpm, only: &
     fpm_alive,  &
     fpm_polling
  use scale_sigvars
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: prc_mpistart
  public :: prc_universal_setup
  public :: prc_global_setup
  public :: prc_local_setup
  public :: prc_singlecom_setup
  public :: prc_abort
  public :: prc_mpifinish
  public :: prc_mpisplit

  public :: prc_mpibarrier
  public :: prc_mpitime
  public :: prc_mpitimestat

  public :: prc_set_file_closer

  public :: prc_errhandler_setup

  abstract interface
     subroutine closer( skip_abort )
       logical, intent(in), optional :: skip_abort
     end subroutine closer
  end interface

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !                          [ communicator system ]
  !    MPI_COMM_WORLD
  !          |
  ! PRC_UNIVERSAL_COMM_WORLD --split--> BULK_COMM_WORLD
  !                                     |
  !                            PRC_GLOBAL_COMM_WORLD --split--> PRC_LOCAL_COMM_WORLD
  !-----------------------------------------------------------------------------
  integer, public, parameter :: prc_masterrank      = 0
  integer, public, parameter :: prc_domain_nlim = 10000
  integer, public, parameter :: prc_comm_null = mpi_comm_null

  ! universal world
  integer, public :: prc_universal_comm_world = -1
  integer, public :: prc_universal_myrank     = -1
  integer, public :: prc_universal_nprocs     = -1
  logical, public :: prc_universal_ismaster   = .false. 

  integer, public :: prc_universal_jobid      = 0

  ! global world
  integer, public :: prc_global_comm_world    = -1
  integer, public :: prc_global_myrank        = -1
  integer, public :: prc_global_nprocs        = -1
  logical, public :: prc_global_ismaster      = .false. 

  integer, public :: prc_global_domainid      = 0
  integer, public :: prc_global_root(prc_domain_nlim+1)

  ! local world
  integer, public :: prc_local_comm_world     = -1
  integer, public :: prc_nprocs               = 1
  integer, public :: prc_myrank               = 0
  logical, public :: prc_ismaster             = .false. 

  ! error handling
  logical, public :: prc_mpi_alive = .false.            
  integer, public :: prc_universal_handler
  integer, public :: prc_abort_comm_world
  integer, public :: prc_abort_handler

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  private :: prc_mpicoloring
  private :: prc_sort_ascd

  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  integer, private, parameter :: prc_abort_code = -1
!  integer, private, parameter :: PRC_ABORT_code_p = 2 !< mpi abort code in error handler from parent
!  integer, private, parameter :: PRC_ABORT_code_d = 3 !< mpi abort code in error handler from daughter

  procedure(closer), pointer :: prc_file_closer => null()

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine prc_mpistart( &
       comm )
    implicit none

    integer, intent(out) :: comm ! communicator

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

    call mpi_init(ierr)

    prc_mpi_alive = .true.
!    PRC_UNIVERSAL_handler = MPI_ERRHANDLER_NULL
!    call MPI_COMM_CREATE_ERRHANDLER( PRC_MPI_errorhandler, PRC_UNIVERSAL_handler, ierr )

    comm = mpi_comm_world
    prc_abort_comm_world = comm

    return
  end subroutine prc_mpistart

  !-----------------------------------------------------------------------------
  subroutine prc_universal_setup( &
       comm,    &
       nprocs,  &
       ismaster )
    implicit none

    integer, intent(in)  :: comm     ! communicator
    integer, intent(out) :: nprocs   ! number of procs in this communicator
    logical, intent(out) :: ismaster ! master process in this communicator?

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

    prc_universal_comm_world = comm

    call mpi_comm_size(prc_universal_comm_world,prc_universal_nprocs,ierr)
    call mpi_comm_rank(prc_universal_comm_world,prc_universal_myrank,ierr)

    if ( prc_universal_myrank == prc_masterrank ) then
       prc_universal_ismaster = .true.
    else
       prc_universal_ismaster = .false.
    endif

    nprocs   = prc_universal_nprocs
    ismaster = prc_universal_ismaster



!    PRC_ABORT_COMM_WORLD = PRC_UNIVERSAL_COMM_WORLD
!
!    call MPI_Comm_set_errhandler(PRC_ABORT_COMM_WORLD,PRC_UNIVERSAL_handler,ierr)
!    call MPI_Comm_get_errhandler(PRC_ABORT_COMM_WORLD,PRC_ABORT_handler    ,ierr)

    return
  end subroutine prc_universal_setup

  !-----------------------------------------------------------------------------
  subroutine prc_global_setup( &
       abortall, &
       comm      )
    implicit none

    logical, intent(in)  :: abortall ! abort all jobs?
    integer, intent(in)  :: comm     ! communicator

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

    prc_global_comm_world = comm

    call mpi_comm_size(prc_global_comm_world,prc_global_nprocs,ierr)
    call mpi_comm_rank(prc_global_comm_world,prc_global_myrank,ierr)

    if ( prc_global_myrank == prc_masterrank ) then
       prc_global_ismaster = .true.
    else
       prc_global_ismaster = .false.
    endif

!    if ( .NOT. abortall ) then
!       PRC_ABORT_COMM_WORLD = PRC_GLOBAL_COMM_WORLD
!
!       call MPI_COMM_SET_ERRHANDLER(PRC_ABORT_COMM_WORLD,PRC_UNIVERSAL_handler,ierr)
!       call MPI_COMM_GET_ERRHANDLER(PRC_ABORT_COMM_WORLD,PRC_ABORT_handler    ,ierr)
!    endif

    return
  end subroutine prc_global_setup

  !-----------------------------------------------------------------------------
  subroutine prc_local_setup( &
       comm,    &
       myrank,  &
       ismaster )
    implicit none

    integer, intent(in)  :: comm     ! communicator
    integer, intent(out) :: myrank   ! myrank         in this communicator
    logical, intent(out) :: ismaster ! master process in this communicator?

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

    prc_local_comm_world = comm

    call mpi_comm_rank(prc_local_comm_world,prc_myrank,ierr)
    call mpi_comm_size(prc_local_comm_world,prc_nprocs,ierr)

    if ( prc_myrank == prc_masterrank ) then
       prc_ismaster = .true.
    else
       prc_ismaster = .false.
    endif

    myrank   = prc_myrank
    ismaster = prc_ismaster

    return
  end subroutine prc_local_setup

  !-----------------------------------------------------------------------------
  subroutine prc_singlecom_setup( &
       comm,    &
       nprocs,  &
       myrank,  &
       ismaster )
    implicit none

    integer, intent(in)  :: comm     ! communicator
    integer, intent(out) :: nprocs   ! number of procs
    integer, intent(out) :: myrank   ! myrank
    logical, intent(out) :: ismaster ! master process?

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

    call mpi_comm_size(comm,nprocs,ierr)
    call mpi_comm_rank(comm,myrank,ierr)

    if ( myrank == prc_masterrank ) then
       ismaster = .true.
    else
       ismaster = .false.
    endif

    prc_universal_comm_world = comm
    prc_universal_nprocs     = nprocs
    prc_universal_myrank     = myrank
    prc_universal_ismaster   = ismaster

    prc_global_comm_world    = comm
    prc_global_nprocs        = nprocs
    prc_global_myrank        = myrank
    prc_global_ismaster      = ismaster

    prc_local_comm_world     = comm
    prc_nprocs               = nprocs
    prc_myrank               = myrank
    prc_ismaster             = ismaster



    prc_abort_comm_world = comm

!    call MPI_Comm_set_errhandler(PRC_ABORT_COMM_WORLD,PRC_UNIVERSAL_handler,ierr)
!    call MPI_Comm_get_errhandler(PRC_ABORT_COMM_WORLD,PRC_ABORT_handler    ,ierr)

    return
  end subroutine prc_singlecom_setup

  !-----------------------------------------------------------------------------
  subroutine prc_errhandler_setup( &
       use_fpm, &
       master   )
    implicit none

    logical, intent(in) :: use_fpm ! fpm switch
    logical, intent(in) :: master  ! master flag

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

    call mpi_comm_create_errhandler(prc_mpi_errorhandler,prc_universal_handler,ierr)

    call mpi_comm_set_errhandler(prc_abort_comm_world,prc_universal_handler,ierr)
    call mpi_comm_get_errhandler(prc_abort_comm_world,prc_abort_handler    ,ierr)

    if ( prc_universal_handler /= prc_abort_handler ) then
       if( prc_universal_ismaster ) write(*,*) ""
       if( prc_universal_ismaster ) write(*,*) "ERROR: MPI HANDLER is INCONSISTENT"
       if( prc_universal_ismaster ) write(*,*) "     PRC_UNIVERSAL_handler = ", prc_universal_handler
       if( prc_universal_ismaster ) write(*,*) "     PRC_ABORT_handler     = ", prc_abort_handler
       call prc_abort
    endif

    if ( use_fpm ) then
       call sigvars_get_all( master )
       call signal( sigint,  prc_abort )
       call signal( sigquit, prc_abort )
       call signal( sigabrt, prc_abort )
       call signal( sigfpe,  prc_abort )
       call signal( sigsegv, prc_abort )
       call signal( sigterm, prc_abort )
    endif

    return
  end subroutine prc_errhandler_setup

  !-----------------------------------------------------------------------------
  subroutine prc_abort
    implicit none

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

    if ( prc_mpi_alive ) then
       ! tentative approach; input "PRC_UNIVERSAL_COMM_WORLD".
       call mpi_comm_call_errhandler(prc_universal_comm_world,prc_abort_code,ierr)
    endif

    stop
  end subroutine prc_abort

  !-----------------------------------------------------------------------------
  subroutine prc_mpifinish
    implicit none

    integer :: ierr
    logical :: sign_status
    logical :: sign_exit
    !---------------------------------------------------------------------------

    ! FPM polling
    if ( fpm_alive ) then
       sign_status = .false.
       sign_exit   = .false.
       do while ( .NOT. sign_exit )
          call fpm_polling( sign_status, sign_exit )
       enddo
    endif

    if (prc_universal_handler .NE. mpi_errhandler_null) then
        call mpi_errhandler_free(prc_universal_handler, ierr)
    endif
    if (prc_abort_handler .NE. mpi_errhandler_null) then
        call mpi_errhandler_free(prc_abort_handler, ierr)
    endif

    ! Stop MPI
    if ( prc_mpi_alive ) then
       log_newline
       log_progress(*) 'finalize MPI...'

       ! free splitted communicator
       if ( prc_local_comm_world  /= prc_global_comm_world ) then
          call mpi_comm_free(prc_local_comm_world,ierr)
       endif

       call mpi_barrier(prc_universal_comm_world,ierr)

       call mpi_finalize(ierr)
       log_progress(*) 'MPI is peacefully finalized'
    endif

    ! Close logfile, configfile
    if ( io_l ) then
       if( io_fid_log /= io_fid_stdout ) close(io_fid_log)
    endif
    close(io_fid_conf)

    return
  end subroutine prc_mpifinish

  !-----------------------------------------------------------------------------
  subroutine prc_mpisplit( &
      ORG_COMM,         & ! [in ]
      NUM_DOMAIN,       & ! [in ]
      PRC_DOMAINS,      & ! [in ]
      CONF_FILES,       & ! [in ]
      LOG_SPLIT,        & ! [in ]
      bulk_split,       & ! [in ]
      color_reorder,    & ! [in ]
      INTRA_COMM,       & ! [out]
      inter_parent,     & ! [out]
      inter_child,      & ! [out]
      fname_local       ) ! [out]
    implicit none

    integer,               intent(in)  :: ORG_COMM
    integer,               intent(in)  :: NUM_DOMAIN
    integer,               intent(in)  :: PRC_DOMAINS(:)
    character(len=*),      intent(in)  :: CONF_FILES(:)
    logical,               intent(in)  :: LOG_SPLIT
    logical,               intent(in)  :: bulk_split
    logical,               intent(in)  :: color_reorder
    integer,               intent(out) :: intra_comm
    integer,               intent(out) :: inter_parent
    integer,               intent(out) :: inter_child
    character(len=H_LONG), intent(out) :: fname_local

    integer :: PARENT_COL(prc_domain_nlim)        ! parent color number
    integer :: CHILD_COL(prc_domain_nlim)         ! child  color number
    integer :: PRC_ROOT(0:prc_domain_nlim)        ! root process in the color
    integer, allocatable :: COLOR_LIST(:)   ! member list in each color
    integer, allocatable :: KEY_LIST(:)     ! local process number in each color

    integer :: total_nmax
    integer :: ORG_myrank  ! my rank number in the original communicator
    integer :: ORG_nmax    ! total rank number in the original communicator

    logical :: do_create_p(prc_domain_nlim)
    logical :: do_create_c(prc_domain_nlim)
    logical :: reordering

    character(len=H_LONG) :: COL_FILE(0:prc_domain_nlim)
    character(len=4)      :: col_num

    integer :: i, ii
    integer :: itag, ierr
    !---------------------------------------------------------------------------

    intra_comm   = org_comm
    inter_parent = mpi_comm_null
    inter_child  = mpi_comm_null
    fname_local  = conf_files(1)

    if ( num_domain > 1 ) then ! multi domain run
       call mpi_comm_rank(org_comm,org_myrank,ierr)
       call mpi_comm_size(org_comm,org_nmax,  ierr)
       allocate( color_list(0:org_nmax-1) )
       allocate( key_list(0:org_nmax-1) )

       total_nmax = 0
       do i = 1, num_domain
          total_nmax = total_nmax + prc_domains(i)
       enddo
       if ( total_nmax /= org_nmax ) then
          if( prc_universal_ismaster ) then
             log_error("PRC_MPIsplit",*) "MPI PROCESS NUMBER is INCONSISTENT"
             log_error_cont(*) " REQUESTED NPROCS = ", total_nmax, "  LAUNCHED NPROCS = ", org_nmax
          end if
          call prc_abort
       endif

       reordering = color_reorder
       if ( bulk_split ) then
          reordering = .false.
       endif
       call prc_mpicoloring( org_comm,    & ! [IN]
                             num_domain,  & ! [IN]
                             prc_domains, & ! [IN]
                             conf_files,  & ! [IN]
                             reordering,  & ! [IN]
                             log_split,   & ! [IN]
                             color_list,  & ! [OUT]
                             prc_root,    & ! [OUT]
                             key_list,    & ! [OUT]
                             parent_col,  & ! [OUT]
                             child_col,   & ! [OUT]
                             col_file     ) ! [OUT]

       if ( bulk_split ) then
          ii = 1
          do i=0, prc_domain_nlim
             prc_global_root(ii) = prc_root(i)
             ii = ii + 1
          enddo
       endif

       ! split comm_world
       call mpi_comm_split(org_comm,               &
                           color_list(org_myrank), &
                           key_list(org_myrank),   &
                           intra_comm, ierr)
       if ( bulk_split ) then
          write(col_num,'(I4.4)') color_list(org_myrank)
          fname_local = col_num
          prc_universal_jobid  = color_list(org_myrank)
       else
          fname_local = col_file(color_list(org_myrank))
       endif

       ! set parent-child relationship
       do_create_p(:) = .false.
       do_create_c(:) = .false.
       if ( .NOT. bulk_split ) then
          if ( prc_universal_ismaster ) write(*,*)
          if ( prc_universal_ismaster ) write(*,*) "INFO [PRC_MPIsplit] Inter-domain relationship information"
          do i = 1, num_domain-1
             if ( prc_universal_ismaster ) write(*,'(5x,A,I2.2)')  "Relationship No. ", i
             if ( prc_universal_ismaster ) write(*,'(5x,2(A,I2))') "Parent color = ", parent_col(i), &
                                                                   " <=> child color = ", child_col(i)
             if ( color_list(org_myrank) == parent_col(i) ) then
                do_create_p(i) = .true.
             elseif ( color_list(org_myrank) == child_col(i) ) then
                do_create_c(i) = .true.
             endif
          enddo
       endif

       ! create inter-commnunicator
       inter_parent = mpi_comm_null
       inter_child  = mpi_comm_null
       if ( .NOT. bulk_split ) then
          do i = 1, num_domain-1
             itag = i*100
             if    ( do_create_p(i) ) then ! as a parent
                call mpi_intercomm_create( intra_comm, prc_masterrank,          &
                                           org_comm,   prc_root(child_col(i)),  &
                                           itag, inter_child,  ierr             )
             elseif( do_create_c(i) ) then ! as a child
                call mpi_intercomm_create( intra_comm, prc_masterrank,          &
                                           org_comm,   prc_root(parent_col(i)), &
                                           itag, inter_parent, ierr             )
             endif
             call mpi_barrier(org_comm, ierr)
          enddo
       endif

       deallocate( color_list, key_list )

    elseif ( num_domain == 1 ) then ! single domain run
       ! if ( PRC_UNIVERSAL_IsMaster ) write (*,*) "INFO [PRC_MPIsplit] a single communicator"
    else
       if ( prc_universal_ismaster ) then
          write(*,*)"ERROR [RPC_MPIsplit] REQUESTED DOMAIN NUMBER IS NOT ACCEPTABLE"
       end if
       call prc_abort
    endif

    return
  end subroutine prc_mpisplit

  !-----------------------------------------------------------------------------
  subroutine prc_mpicoloring( &
      ORG_COMM,        & ! [in ]
      NUM_DOMAIN,      & ! [in ]
      PRC_DOMAINS,     & ! [in ]
      CONF_FILES,      & ! [in ]
      color_reorder,   & ! [in ]
      LOG_SPLIT,       & ! [in ]
      COLOR_LIST,      & ! [out]
      PRC_ROOT,        & ! [out]
      KEY_LIST,        & ! [out]
      PARENT_COL,      & ! [out]
      CHILD_COL,       & ! [out]
      COL_FILE         ) ! [out]
    implicit none

    integer,               intent(in)  :: ORG_COMM
    integer,               intent(in)  :: NUM_DOMAIN
    integer,               intent(in)  :: PRC_DOMAINS(:)
    character(len=*),      intent(in)  :: CONF_FILES(:)
    logical,               intent(in)  :: color_reorder
    logical,               intent(in)  :: LOG_SPLIT
    integer,               intent(out) :: COLOR_LIST(:)             ! member list in each color
    integer,               intent(out) :: PRC_ROOT(0:prc_domain_nlim)     ! root process in each color
    integer,               intent(out) :: KEY_LIST(:)               ! local process number in each color
    integer,               intent(out) :: PARENT_COL(:)             ! parent color number
    integer,               intent(out) :: CHILD_COL(:)              ! child  color number
    character(len=H_LONG), intent(out) :: COL_FILE(0:prc_domain_nlim) ! conf file in each color

    integer               :: touch         (  prc_domain_nlim)
    integer               :: PRC_ORDER     (  prc_domain_nlim) ! reordered number of process
    integer               :: ORDER2DOM     (  prc_domain_nlim) ! get domain number by order number
    integer               :: DOM2ORDER     (  prc_domain_nlim) ! get order number by domain number
    integer               :: DOM2COL       (  prc_domain_nlim) ! get color number by domain number
    integer               :: COL2DOM       (0:prc_domain_nlim) ! get domain number by color number

    integer               :: RO_PRC_DOMAINS(  prc_domain_nlim) ! reordered values
    integer               :: RO_DOM2COL    (  prc_domain_nlim) ! reordered values
    integer               :: RO_PARENT_COL (  prc_domain_nlim) ! reordered values
    integer               :: RO_CHILD_COL  (  prc_domain_nlim) ! reordered values
    character(len=H_LONG) :: RO_CONF_FILES (  prc_domain_nlim) ! reordered values

    integer :: ORG_nmax   ! parent domain number
    integer :: id_parent  ! parent domain number
    integer :: id_child   ! child domain number
    integer :: dnum, nprc, order, key
    integer :: i, j
    integer :: ierr
    !---------------------------------------------------------------------------

    order2dom(:) = -1
    dom2order(:) = -1
    ro_prc_domains(:) = -1
    ro_dom2col(:) = -1
    ro_conf_files(:) = ""
    ro_parent_col(:) = -1
    ro_child_col(:) = -1

    call mpi_comm_size(org_comm,org_nmax, ierr)

    if ( color_reorder ) then
       !--- make color order
       !    domain num is counted from 1
       !    color num  is counted from 0
       touch(:) = -1
       prc_order(:) = prc_domains(:)

       call prc_sort_ascd( prc_order(1:num_domain), 1, num_domain )

       do i = 1, num_domain
       do j = num_domain, 1, -1
          if ( prc_domains(i) == prc_order(j) .AND. touch(j) < 0 ) then
             dom2col(i  ) = j-1 ! domain_num --> color_num
             col2dom(j-1) = i   ! color_num  --> domain_num
             touch(j  ) = 1
             exit
          endif
       enddo
       enddo

       parent_col(:) = -1
       child_col(:) = -1
       do i = 1, num_domain
          id_parent = i - 1
          id_child  = i + 1

          if ( 1 <= id_parent .AND. id_parent <= num_domain ) then
             parent_col(i) = dom2col(id_parent)
          endif
          if ( 1 <= id_child  .AND. id_child  <= num_domain ) then
             child_col(i) = dom2col(id_child)
          endif

          if ( prc_universal_ismaster .AND. log_split ) then
             write(*,'(1x,A,I2,1x,A,I2,2(2x,A,I2))') &
             "DOMAIN: ", i, "MY_COL: ", dom2col(i), "PARENT: COL= ", parent_col(i), "CHILD: COL= ", child_col(i)
          endif
       enddo

       !--- reorder following color order
       do i = 1, num_domain
          dnum = col2dom(i-1)

          order2dom(i)    = dnum
          dom2order(dnum) = i
          ro_prc_domains(i)    = prc_domains(dnum)
          ro_dom2col(dnum) = dom2col(dnum)
          ro_conf_files(i)    = conf_files(dnum)
          ro_parent_col(i)    = parent_col(dnum)
          ro_child_col(i)    = child_col(dnum)
       enddo

       !--- set relationship by ordering of relationship number
       parent_col(:) = -1
       child_col(:) = -1
       do i = 1, num_domain-1
          parent_col(i) = ro_parent_col(dom2order(i+1)) ! from child to parent
          child_col(i) = ro_child_col(dom2order(i)  ) ! from parent to child
       enddo

       if( prc_universal_ismaster ) write(*,*)
       if( prc_universal_ismaster ) write(*,*) 'INFO [PRC_MPIcoloring] Domain information (with reordering)'
       do i = 1, num_domain
          if( prc_universal_ismaster ) write(*,*)
          if( prc_universal_ismaster ) write(*,'(5x,2(A,I2.2))') "Order No. ",i," -> Domain No. ", order2dom(i)
          if( prc_universal_ismaster ) write(*,'(5x,A,I5)')      "Number of process      = ", ro_prc_domains(i)
          if( prc_universal_ismaster ) write(*,'(5x,A,I5)')      "Color of this   domain = ", ro_dom2col(order2dom(i))
          if ( ro_parent_col(i) >= 0 ) then
             if( prc_universal_ismaster ) write(*,'(5x,A,I5)')   "Color of parent domain = ", ro_parent_col(i)
          else
             if( prc_universal_ismaster ) write(*,'(5x,A)'   )   "Color of parent domain = no parent"
          endif
          if ( ro_child_col(i) >= 0 ) then
             if( prc_universal_ismaster ) write(*,'(5x,A,I5)')   "Color of child  domain = ", ro_child_col(i)
          else
             if( prc_universal_ismaster ) write(*,'(5x,A)'   )   "Color of child  domain = no child"
          endif
          if( prc_universal_ismaster ) write(*,'(5x,A,A)')       "Name of config file    = ", trim(ro_conf_files(i))
       enddo

       do i = 1, num_domain
          col_file(i-1) = ro_conf_files(i) ! final copy
       enddo

    else !--- without reordering of colors

       do i = 1, num_domain
          order2dom(i) = i
          ro_prc_domains(i) = prc_domains(i)
          ro_dom2col(i) = i-1
          ro_conf_files(i) = conf_files(i)
       enddo

       do i = 1, num_domain
          id_parent = i - 1
          id_child  = i + 1

          if ( 1 <= id_parent .AND. id_parent <= num_domain ) then
             ro_parent_col(i) = ro_dom2col(id_parent)
          endif
          if ( 1 <= id_child  .AND. id_child  <= num_domain ) then
             ro_child_col(i) = ro_dom2col(id_child)
          endif
       enddo

       ! make relationship
       do i = 1, num_domain-1
          parent_col(i) = ro_parent_col(i+1) ! from child to parent
          child_col(i) = ro_child_col(i  ) ! from parent to child
       enddo

    endif

    ! make a process table
    order = 1
    key   = 0
    nprc  = ro_prc_domains(order)
    prc_root(:) = -999

    do i = 0, org_nmax-1
       color_list(i+1) = ro_dom2col(order2dom(order))
       key_list(i+1) = key

       if ( key == 0 ) then
          prc_root(color_list(i+1)) = i
          col_file(color_list(i+1)) = ro_conf_files(order)
       endif

       if ( log_split .AND. prc_universal_ismaster ) then
          write(*,'(5x,4(A,I5))') &
          "PE:", i, " COLOR:", color_list(i+1), " KEY:", key_list(i+1), " PRC_ROOT:", prc_root(color_list(i+1))
       endif

       key = key + 1
       if ( key >= nprc ) then
          order = order + 1
          key   = 0
          nprc  = ro_prc_domains(order)
       endif
    enddo

    return
  end subroutine prc_mpicoloring

  !-----------------------------------------------------------------------------
  recursive subroutine prc_sort_ascd(a, top, bottom)
    implicit none
    integer, intent(inout) :: a(:)
    integer, intent(in)    :: top, bottom
    integer :: i, j, cnt, trg
    !---------------------------------------------------------------------------
    cnt = a( (top+bottom) / 2 )
    i = top; j = bottom
    do
       do while ( a(i) > cnt ) !ascending evaluation
          i = i + 1
       enddo
       do while ( cnt > a(j) ) !ascending evaluation
          j = j - 1
       enddo
       if ( i >= j ) exit
       trg = a(i);  a(i) = a(j);  a(j) = trg
       i = i + 1
       j = j - 1
    enddo
    if ( top < i-1    ) call prc_sort_ascd( a, top, i-1    )
    if ( j+1 < bottom ) call prc_sort_ascd( a, j+1, bottom )
    return
  end subroutine prc_sort_ascd

  !-----------------------------------------------------------------------------
  subroutine prc_mpibarrier
    implicit none

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

    if ( prc_mpi_alive ) then
       call mpi_barrier(prc_local_comm_world,ierr)
    endif

  end subroutine prc_mpibarrier

  !-----------------------------------------------------------------------------
  function prc_mpitime() result(time)
    implicit none

    real(DP) :: time
    !---------------------------------------------------------------------------

    if ( prc_mpi_alive ) then
       time = real(MPI_WTIME(), kind=dp)
    else
       call cpu_time(time)
    endif

  end function prc_mpitime

  !-----------------------------------------------------------------------------
  subroutine prc_mpitimestat( &
      avgvar, &
      maxvar, &
      minvar, &
      maxidx, &
      minidx, &
      var     )
    implicit none

    real(DP), intent(out) :: avgvar(:)
    real(DP), intent(out) :: maxvar(:)
    real(DP), intent(out) :: minvar(:)
    integer,  intent(out) :: maxidx(:)
    integer,  intent(out) :: minidx(:)
    real(DP), intent(in)  :: var(:)

    real(DP), allocatable :: statval(:,:)
    integer               :: vsize

    real(DP) :: totalvar
    integer  :: ierr
    integer  :: v, p
    !---------------------------------------------------------------------------

    vsize = size(var(:))

    allocate( statval(vsize,0:prc_nprocs-1) )
    statval(:,:) = 0.0_dp

    do v = 1, vsize
       statval(v,prc_myrank) = var(v)
    enddo

    ! MPI broadcast
    do p = 0, prc_nprocs-1
       call mpi_bcast( statval(1,p),         &
                       vsize,                &
                       mpi_double_precision, &
                       p,                    &
                       prc_local_comm_world, &
                       ierr                  )
    enddo

    do v = 1, vsize
       totalvar = 0.0_dp
       do p = 0, prc_nprocs-1
          totalvar = totalvar + statval(v,p)
       enddo
       avgvar(v) = totalvar / prc_nprocs

       maxvar(v)   = maxval(statval(v,:))
       minvar(v)   = minval(statval(v,:))
       maxidx(v:v) = maxloc(statval(v,:))
       minidx(v:v) = minloc(statval(v,:))
    enddo

    deallocate( statval )

    return
  end subroutine prc_mpitimestat

  !-----------------------------------------------------------------------------
  subroutine prc_mpi_errorhandler( &
      comm,     &
      errcode   )
    implicit none

    ! attributes are needed to be the same with COMM_ERRHANDLER function
    integer :: comm
    integer :: errcode

    character(len=MPI_MAX_ERROR_STRING) :: msg
    integer :: len
    integer :: ierr
    logical :: sign_status
    logical :: sign_exit
    !---------------------------------------------------------------------------

!print *, "into errhandler:", PRC_UNIVERSAL_myrank

    ! FPM polling
    if ( fpm_alive ) then
       sign_status = .false.
       sign_exit   = .false.
       do while ( .NOT. sign_exit )
          call fpm_polling( sign_status, sign_exit )
       enddo
    endif

    ! Print Error Messages
    if ( prc_mpi_alive ) then
          ! flush 1kbyte
       if ( io_l ) then
          log_progress(*) 'abort MPI'
          flush(io_fid_log)
       endif

       if ( prc_ismaster ) then
          write(*,*) '+++++ BULK   ID       : ', prc_universal_jobid
          write(*,*) '+++++ DOMAIN ID       : ', prc_global_domainid
          write(*,*) '+++++ MASTER LOCATION : ', prc_universal_myrank,'/',prc_universal_nprocs
          write(*,*) '+++++ GLOBAL LOCATION : ', prc_global_myrank,'/',prc_global_nprocs
          write(*,*) '+++++ LOCAL  LOCATION : ', prc_myrank,'/',prc_nprocs
          write(*,*) ''
       endif

       if    ( errcode == prc_abort_code ) then ! called from PRC_abort
          ! do nothing
       elseif( errcode <= mpi_err_lastcode ) then
          call mpi_error_string(errcode, msg, len, ierr)
          if( io_l ) write(io_fid_log,*) '+++++ ', errcode, trim(msg)
          write(*,*)                     '+++++ ', errcode, trim(msg)
       else
          if( io_l ) write(io_fid_log,*) '+++++ Unexpected error code', errcode
          write(*,*)                     '+++++ Unexpected error code', errcode
       endif

       if ( comm /= prc_abort_comm_world ) then
          if( io_l ) write(io_fid_log,*) '+++++ Unexpected communicator'
          write(*,*)                     '+++++ Unexpected communicator'
       endif
       if( io_l ) write(io_fid_log,*) ''
       write(*,*)                     ''
    endif

    if ( associated( prc_file_closer ) ) call prc_file_closer( .true. )

    ! Close logfile, configfile
    if ( io_l ) then
       if( io_fid_log /= io_fid_stdout ) close(io_fid_log)
    endif
    close(io_fid_conf)

    ! Abort MPI
    if ( prc_mpi_alive ) then
       call sleep(5)
       call mpi_abort(prc_abort_comm_world, prc_abort_code, ierr)
    endif

    stop
  end subroutine prc_mpi_errorhandler

  subroutine prc_set_file_closer( routine )
    procedure(closer) :: routine

    prc_file_closer => routine

    return
  end subroutine prc_set_file_closer

end module scale_prc