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_bulk
  public :: prc_mpisplit_nest
 
  public :: prc_mpibarrier
  public :: prc_mpitime
  public :: prc_mpitimestat
  public :: prc_timereorder
 
  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)
 
  ! local world
  integer, public :: prc_local_comm_world     = -1
  integer, public :: prc_nprocs               = 1
  integer, public :: prc_myrank               = 0
  logical, public :: prc_ismaster             = .false. 
  !$acc declare create(PRC_myrank)
 
  ! inter-domain world
  integer, public :: prc_intercomm_parent     = mpi_comm_null 
  integer, public :: prc_intercomm_child      = mpi_comm_null 
 
  ! 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,  &
       myrank,  &
       ismaster )
    implicit none
 
    integer, intent(in)  :: comm     ! communicator
    integer, intent(out) :: nprocs   ! number of procs in this communicator
    integer, intent(out) :: myrank   ! myrank          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
    myrank   = prc_universal_myrank
    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)
    !$acc update device(PRC_myrank)
 
    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
    !$acc update device(PRC_myrank)
 
 
 
    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
    !---------------------------------------------------------------------------
 
    call mpi_barrier(prc_global_comm_world, ierr)
    if ( prc_intercomm_child /= mpi_comm_null ) &
         call mpi_comm_free(prc_intercomm_child, ierr)
    if ( prc_intercomm_parent /= mpi_comm_null ) &
         call mpi_comm_free(prc_intercomm_parent, ierr)
 
    ! 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
       ! 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)
    endif
 
    return
  end subroutine prc_mpifinish
 
  !-----------------------------------------------------------------------------
  subroutine prc_mpisplit_bulk( &
      ORG_COMM_WORLD, &
      NUM_BULKJOB,    &
      PRC_BULKJOB,    &
      debug,          &
      SUB_COMM_WORLD, &
      ID_BULKJOB      )
    implicit none
 
    integer, intent(in)  :: org_comm_world ! communicator (original group)
    integer, intent(in)  :: num_bulkjob    ! number of bulk jobs
    integer, intent(in)  :: prc_bulkjob(:) ! number of ranks in subgroup communicator
    logical, intent(in)  :: debug          ! log-output for mpi splitting?
    integer, intent(out) :: sub_comm_world ! communicator (new subgroup)
    integer, intent(out) :: id_bulkjob     ! bulk job id
 
    integer :: org_myrank ! my rank         in the original communicator
    integer :: org_nrank  ! number of ranks in the original communicator
    integer :: sum_nrank
 
    integer, allocatable  :: prc2color (:)                 ! color id      for each process
    integer, allocatable  :: prc2key   (:)                 ! local rank id for each process
    integer               :: col_domain(0:prc_domain_nlim) ! domain id    of this color
    integer               :: col_master(0:prc_domain_nlim) ! master rank  of this color
    integer               :: col_parent(0:prc_domain_nlim) ! parent color of this color
    integer               :: col_child (0:prc_domain_nlim) ! child  color of this color
 
    logical :: color_reorder = .false. ! dummy
 
    integer :: i, color
    integer :: itag, ierr
    !---------------------------------------------------------------------------
 
 
    if ( num_bulkjob == 1 ) then ! single domain run
 
       sub_comm_world      = org_comm_world
       id_bulkjob          = 0
       prc_universal_jobid = 0
 
    elseif( num_bulkjob > 1 ) then ! multi domain run
 
       call mpi_comm_rank(org_comm_world,org_myrank,ierr)
       call mpi_comm_size(org_comm_world,org_nrank ,ierr)
 
       sum_nrank = sum(prc_bulkjob(1:num_bulkjob))
 
       if ( sum_nrank /= org_nrank ) then
          if ( prc_universal_ismaster ) then
             log_error("PRC_MPIsplit",*) "MPI PROCESS NUMBER is INCONSISTENT"
             log_error_cont(*)           " REQUESTED NPROCS = ", sum_nrank, "  LAUNCHED NPROCS = ", org_nrank
          endif
          call prc_abort
       endif
 
       allocate( prc2color(0:org_nrank-1) )
       allocate( prc2key(0:org_nrank-1) )
 
       call prc_mpicoloring( org_comm_world, & ! [IN]
                             org_nrank,      & ! [IN]
                             num_bulkjob,    & ! [IN]
                             prc_bulkjob(:), & ! [IN]
                             color_reorder,  & ! [IN]
                             .true.,         & ! [IN]
                             debug,          & ! [IN]
                             prc2color(:),  & ! [OUT]
                             prc2key(:),  & ! [OUT]
                             col_domain(:),  & ! [OUT]
                             col_master(:),  & ! [OUT]
                             col_parent(:),  & ! [OUT]
                             col_child(:)   ) ! [OUT]
 
       ! split comm_world
       call mpi_comm_split( org_comm_world,        & ! [IN]
                            prc2color(org_myrank), & ! [IN]
                            prc2key(org_myrank), & ! [IN]
                            sub_comm_world,        & ! [OUT]
                            ierr                   ) ! [OUT]
 
       do i = 1, num_bulkjob
          color = i-1
          prc_global_root(i) = col_master(color)
       enddo
 
       id_bulkjob          = prc2color(org_myrank) ! color = bulk id
       prc_universal_jobid = prc2color(org_myrank) ! color = bulk id
 
       deallocate( prc2color )
       deallocate( prc2key   )
 
    else
       if ( prc_universal_ismaster ) then
          log_error("PRC_MPIsplit",*) "REQUESTED DOMAIN NUMBER IS NOT ACCEPTABLE"
       endif
       call prc_abort
    endif
 
    return
  end subroutine prc_mpisplit_bulk
 
  !-----------------------------------------------------------------------------
  subroutine prc_mpisplit_nest( &
      ORG_COMM_WORLD,   &
      NUM_DOMAIN,       &
      PRC_DOMAIN,       &
      debug,            &
      color_reorder,    &
      SUB_COMM_WORLD,   &
      ID_DOMAIN         )
    implicit none
 
    integer,               intent(in)  :: org_comm_world   ! communicator (original group)
    integer,               intent(in)  :: num_domain       ! number of bulk jobs
    integer,               intent(in)  :: prc_domain(:)    ! number of ranks in subgroup communicator
    logical,               intent(in)  :: debug            ! log-output for mpi splitting?
    logical,               intent(in)  :: color_reorder    ! reorder
    integer,               intent(out) :: sub_comm_world   ! communicator (new subgroup)
    integer,               intent(out) :: id_domain        ! domain id
 
    integer :: org_myrank ! my rank         in the original communicator
    integer :: org_nrank  ! number of ranks in the original communicator
    integer :: sum_nrank
 
    integer, allocatable  :: prc2color (:)                 ! color id      for each process
    integer, allocatable  :: prc2key   (:)                 ! local rank id for each process
    integer               :: col_domain(0:prc_domain_nlim) ! domain id    of this color
    integer               :: col_master(0:prc_domain_nlim) ! master rank  of this color
    integer               :: col_parent(0:prc_domain_nlim) ! parent color of this color
    integer               :: col_child (0:prc_domain_nlim) ! child  color of this color
 
    integer :: i, color
    integer :: itag, ierr
    !---------------------------------------------------------------------------
 
    if ( num_domain == 1 ) then ! single domain run
 
       sub_comm_world      = org_comm_world
       id_domain           = 1
       prc_global_domainid = 1
 
    elseif( num_domain > 1 ) then ! multi domain run
 
       call mpi_comm_rank(org_comm_world,org_myrank,ierr)
       call mpi_comm_size(org_comm_world,org_nrank ,ierr)
 
       sum_nrank = sum(prc_domain(1:num_domain))
 
       if ( sum_nrank /= org_nrank ) then
          if ( prc_universal_ismaster ) then
             log_error("PRC_MPIsplit",*) "MPI PROCESS NUMBER is INCONSISTENT"
             log_error_cont(*)           " REQUESTED NPROCS = ", sum_nrank, "  LAUNCHED NPROCS = ", org_nrank
          endif
          call prc_abort
       endif
 
       allocate( prc2color(0:org_nrank-1) )
       allocate( prc2key(0:org_nrank-1) )
 
       call prc_mpicoloring( org_comm_world, & ! [IN]
                             org_nrank,      & ! [IN]
                             num_domain,     & ! [IN]
                             prc_domain(:),  & ! [IN]
                             color_reorder,  & ! [IN]
                             .false.,        & ! [IN]
                             debug,          & ! [IN]
                             prc2color(:),  & ! [OUT]
                             prc2key(:),  & ! [OUT]
                             col_domain(:),  & ! [OUT]
                             col_master(:),  & ! [OUT]
                             col_parent(:),  & ! [OUT]
                             col_child(:)   ) ! [OUT]
 
       ! split comm_world
       call mpi_comm_split( org_comm_world,        & ! [IN]
                            prc2color(org_myrank), & ! [IN]
                            prc2key(org_myrank), & ! [IN]
                            sub_comm_world,        & ! [OUT]
                            ierr                   ) ! [OUT]
 
       id_domain           = col_domain(prc2color(org_myrank)) ! color /= domain id
       prc_global_domainid = col_domain(prc2color(org_myrank)) ! color /= domain id
 
       if ( prc_universal_ismaster ) then
          write(*,*)
          write(*,*) "INFO [PRC_MPIsplit] Inter-domain relationship information"
          do i = 1, num_domain
             color = i-1
             if ( col_parent(color) >= 0 ) then
                write(*,'(5x,A,I2.2)')          "Relationship No.", i
                write(*,'(5x,A,I2.2,A,A,I2.2)') "Parent color: ", col_parent(color), " <=> ", &
                                                "Child  color: ", color
             endif
          enddo
       endif
 
       ! create inter-communicator
       do i = 1, num_domain
          color = i-1
          if ( col_parent(color) >= 0 ) then
             itag  = i*100
 
             if    ( prc2color(org_myrank) == col_parent(color) ) then ! as a parent
 
                call mpi_intercomm_create( sub_comm_world, prc_masterrank,    &
                                           org_comm_world, col_master(color), &
                                           itag, prc_intercomm_child, ierr    )
 
             elseif( prc2color(org_myrank) == color ) then ! as a child
 
                call mpi_intercomm_create( sub_comm_world, prc_masterrank,                &
                                           org_comm_world, col_master(col_parent(color)), &
                                           itag, prc_intercomm_parent, ierr               )
 
             endif
 
             call mpi_barrier(org_comm_world,ierr)
          endif
       enddo
 
       deallocate( prc2color )
       deallocate( prc2key   )
 
    else
       if ( prc_universal_ismaster ) then
          write(*,*)"ERROR [RPC_MPIsplit] REQUESTED DOMAIN NUMBER IS NOT ACCEPTABLE"
       endif
       call prc_abort
    endif
 
    return
  end subroutine prc_mpisplit_nest
 
  !-----------------------------------------------------------------------------
  subroutine prc_mpicoloring( &
      ORG_COMM_WORLD, &
      ORG_nrank,      &
      NUM_SUBGROUP,   &
      PRC_SUBGROUP,   &
      color_reorder,  &
      bulkjob,        &
      debug,          &
      prc2color,      &
      prc2key,        &
      COL_domain,     &
      COL_master,     &
      COL_parent,     &
      COL_child       )
    implicit none
 
    integer, intent(in)  :: org_comm_world
    integer, intent(in)  :: org_nrank
    integer, intent(in)  :: num_subgroup
    integer, intent(in)  :: prc_subgroup(:)
    logical, intent(in)  :: color_reorder
    logical, intent(in)  :: bulkjob
    logical, intent(in)  :: debug
    integer, intent(out) :: prc2color (0:org_nrank-1)     ! color id      for each process
    integer, intent(out) :: prc2key   (0:org_nrank-1)     ! local rank id for each process
    integer, intent(out) :: col_domain(0:prc_domain_nlim) ! domain id    of the color
    integer, intent(out) :: col_master(0:prc_domain_nlim) ! master rank  of the color
    integer, intent(out) :: col_parent(0:prc_domain_nlim) ! parent color of the color
    integer, intent(out) :: col_child (0:prc_domain_nlim) ! child  color of the color
 
    integer :: prc_reorder(  num_subgroup)   ! reordered  number of process
    integer :: dom2col    (  num_subgroup)   ! get color  number by domain number
    integer :: col2dom    (0:num_subgroup-1) ! get domain number by color  number
    logical :: touch      (0:num_subgroup-1)
 
    integer :: id_parent  ! parent domain number
    integer :: id_child   ! child  domain number
    integer :: nprc, key
    integer :: i, domain, color, p
    integer :: ierr
    !---------------------------------------------------------------------------
 
    if ( color_reorder .AND. .NOT. bulkjob ) then ! with reordering of colors
 
       prc_reorder(1:num_subgroup) = prc_subgroup(1:num_subgroup)
       call prc_sort_ascd( prc_reorder(1:num_subgroup), 1, num_subgroup )
 
       touch(:) = .false.
       do domain = 1, num_subgroup
       do i      = num_subgroup, 1, -1
          color = i-1 ! counted from 0
          if ( prc_subgroup(domain) == prc_reorder(i) .AND. ( .NOT. touch(color) ) ) then
             dom2col(domain) = color  ! domain_num -> color_num
             col2dom(color)  = domain ! color_num  -> domain_num
             touch(color)  = .true.
             exit
          endif
       enddo ! order(=color+1) loop
       enddo ! domain loop
 
    else ! without reordering of colors
 
       do domain = 1, num_subgroup
          color = domain-1 ! counted from 0
          dom2col(domain) = color  ! domain_num -> color_num
          col2dom(color)  = domain ! color_num  -> domain_num
       enddo ! domain loop
 
    endif
 
    ! make relationship
    col_parent(:) = -1
    col_child(:) = -1
    if ( .NOT. bulkjob ) then
       do i = 1, num_subgroup
          id_parent = i - 1
          id_child  = i + 1
 
          if ( id_parent >= 1 .AND. id_parent <= num_subgroup ) then
             col_parent(dom2col(i)) = dom2col(id_parent)
          endif
          if ( id_child  >= 1 .AND. id_child  <= num_subgroup ) then
             col_child(dom2col(i)) = dom2col(id_child)
          endif
 
          if ( debug .AND. prc_universal_ismaster ) then
             write(*,'(4(A,I2))') &
             "DOMAIN: ", i, ", MY COL: ", dom2col(i), ", PARENT COL:", col_parent(i), ", CHILD COL:", col_child(i)
          endif
       enddo ! domain loop
    endif
 
    if ( prc_universal_ismaster ) then
       write(*,*)
       write(*,*)           'INFO [PRC_MPIcoloring] Domain information'
       write(*,'(5x,A,L2)')      'Reordering? : ', color_reorder
       do i = 1, num_subgroup
          color  = i-1
          domain = col2dom(color)
          write(*,*)
          write(*,'(5x,2(A,I2.2))') "Order No. ", i, " -> Domain No. ", domain
          write(*,'(5x,A,I5)')      "Number of process      = ", prc_subgroup(domain)
          write(*,'(5x,A,I5)')      "Color of this   domain = ", color
          if ( col_parent(color) >= 0 ) then
             write(*,'(5x,A,I5)')   "Color of parent domain = ", col_parent(color)
          else
             write(*,'(5x,A)'   )   "Color of parent domain = no parent"
          endif
          if ( col_child(color) >= 0 ) then
             write(*,'(5x,A,I5)')   "Color of child  domain = ", col_child(color)
          else
             write(*,'(5x,A)'   )   "Color of child  domain = no child"
          endif
       enddo ! order(=color+1) loop
    endif
 
    ! make a process table
    color  = 0
    key    = 0
    domain = col2dom(color)
    nprc   = prc_subgroup(domain)
    col_master(:) = -999
 
    do p = 0, org_nrank-1
       prc2color(p) = color
       prc2key(p) = key
 
       if ( key == 0 ) then ! master rank
          col_domain(color) = domain
          col_master(color) = p
       endif
 
       if ( debug .AND. prc_universal_ismaster ) then
          write(*,'(5x,4(A,I5))') &
          "PE:", p, " COLOR:", prc2color(p), " KEY:", prc2key(p), " COL_master:", col_master(color)
       endif
 
       key = key + 1
       if ( key >= nprc ) then
          color = color + 1
          key   = 0
          if ( color < num_subgroup ) then ! ignore last
             domain = col2dom(color)
             nprc   = prc_subgroup(domain)
          endif
       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_timereorder( &
       rapnlimit, &
       rapnmax, &
       rapttot, &
       rapname )
    implicit none
    integer,                intent(in)    :: rapnlimit
    integer,                intent(inout) :: rapnmax
    real(dp),               intent(inout) :: rapttot(rapnlimit)
    character(len=H_SHORT), intent(in)    :: rapname(rapnlimit)
 
    integer                :: rapnmax0
    character(len=H_SHORT) :: rapname0
    real(dp)               :: rapttot0(rapnlimit)
 
    integer :: ierr
    integer :: i, j
 
    if ( prc_ismaster ) rapnmax0 = rapnmax
    call mpi_bcast( rapnmax0, 1, mpi_integer, prc_masterrank, prc_local_comm_world, ierr )
 
    do i = 1, rapnmax0
       if ( prc_ismaster ) rapname0 = rapname(i)
       call mpi_bcast( rapname0, h_short, mpi_character, prc_masterrank, prc_local_comm_world, ierr )
       if ( .not. prc_ismaster ) then
          do j = 1, rapnmax
             if ( rapname(j) == rapname0 ) then
                rapttot0(i) = rapttot(j)
                exit
             end if
          end do
          if ( j > rapnmax ) then
             rapttot0(i) = 0.0_dp
          end if
       end if
    end do
    if ( .not. prc_ismaster ) then
       rapnmax = rapnmax0
       do i = 1, rapnmax
          rapttot(i) = rapttot0(i)
       end do
    end if
  end subroutine prc_timereorder
 
  !-----------------------------------------------------------------------------
  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