49 subroutine closer( skip_abort )
50 logical,
intent(in),
optional :: skip_abort
103 private :: prc_mpicoloring
104 private :: prc_sort_ascd
110 integer,
private,
parameter :: prc_abort_code = -1
114 procedure(closer),
pointer :: prc_file_closer => null()
124 integer,
intent(out) :: comm
135 comm = mpi_comm_world
150 integer,
intent(in) :: comm
151 integer,
intent(out) :: nprocs
152 integer,
intent(out) :: myrank
153 logical,
intent(out) :: ismaster
190 logical,
intent(in) :: abortall
191 integer,
intent(in) :: comm
225 integer,
intent(in) :: comm
226 integer,
intent(out) :: myrank
227 logical,
intent(out) :: ismaster
258 integer,
intent(in) :: comm
259 integer,
intent(out) :: nprocs
260 integer,
intent(out) :: myrank
261 logical,
intent(out) :: ismaster
266 call mpi_comm_size(comm,nprocs,ierr)
267 call mpi_comm_rank(comm,myrank,ierr)
307 logical,
intent(in) :: use_fpm
308 logical,
intent(in) :: master
361 logical :: sign_status
367 sign_status = .false.
369 do while ( .NOT. sign_exit )
384 log_progress(*)
'finalize MPI...'
393 call mpi_finalize(ierr)
394 log_progress(*)
'MPI is peacefully finalized'
417 integer,
intent(in) :: org_comm_world
418 integer,
intent(in) :: num_bulkjob
419 integer,
intent(in) :: prc_bulkjob(:)
420 logical,
intent(in) :: debug
421 integer,
intent(out) :: sub_comm_world
422 integer,
intent(out) :: id_bulkjob
424 integer :: org_myrank
428 integer,
allocatable :: prc2color (:)
429 integer,
allocatable :: prc2key (:)
435 logical :: color_reorder = .false.
438 integer :: itag, ierr
442 if ( num_bulkjob == 1 )
then
444 sub_comm_world = org_comm_world
448 elseif( num_bulkjob > 1 )
then
450 call mpi_comm_rank(org_comm_world,org_myrank,ierr)
451 call mpi_comm_size(org_comm_world,org_nrank ,ierr)
453 sum_nrank = sum(prc_bulkjob(1:num_bulkjob))
455 if ( sum_nrank /= org_nrank )
then
457 log_error(
"PRC_MPIsplit",*)
"MPI PROCESS NUMBER is INCONSISTENT"
458 log_error_cont(*)
" REQUESTED NPROCS = ", sum_nrank,
" LAUNCHED NPROCS = ", org_nrank
463 allocate( prc2color(0:org_nrank-1) )
464 allocate( prc2key(0:org_nrank-1) )
466 call prc_mpicoloring( org_comm_world, &
481 call mpi_comm_split( org_comm_world, &
482 prc2color(org_myrank), &
483 prc2key(org_myrank), &
487 do i = 1, num_bulkjob
492 id_bulkjob = prc2color(org_myrank)
495 deallocate( prc2color )
496 deallocate( prc2key )
500 log_error(
"PRC_MPIsplit",*)
"REQUESTED DOMAIN NUMBER IS NOT ACCEPTABLE"
522 integer,
intent(in) :: org_comm_world
523 integer,
intent(in) :: num_domain
524 integer,
intent(in) :: prc_domain(:)
525 logical,
intent(in) :: debug
526 logical,
intent(in) :: color_reorder
527 integer,
intent(out) :: sub_comm_world
528 integer,
intent(out) :: id_domain
529 integer,
intent(out) :: intercomm_parent
530 integer,
intent(out) :: intercomm_child
532 integer :: org_myrank
536 integer,
allocatable :: prc2color (:)
537 integer,
allocatable :: prc2key (:)
544 integer :: itag, ierr
547 intercomm_parent = mpi_comm_null
548 intercomm_child = mpi_comm_null
550 if ( num_domain == 1 )
then
552 sub_comm_world = org_comm_world
556 elseif( num_domain > 1 )
then
558 call mpi_comm_rank(org_comm_world,org_myrank,ierr)
559 call mpi_comm_size(org_comm_world,org_nrank ,ierr)
561 sum_nrank = sum(prc_domain(1:num_domain))
563 if ( sum_nrank /= org_nrank )
then
565 log_error(
"PRC_MPIsplit",*)
"MPI PROCESS NUMBER is INCONSISTENT"
566 log_error_cont(*)
" REQUESTED NPROCS = ", sum_nrank,
" LAUNCHED NPROCS = ", org_nrank
571 allocate( prc2color(0:org_nrank-1) )
572 allocate( prc2key(0:org_nrank-1) )
574 call prc_mpicoloring( org_comm_world, &
589 call mpi_comm_split( org_comm_world, &
590 prc2color(org_myrank), &
591 prc2key(org_myrank), &
595 id_domain = col_domain(prc2color(org_myrank))
600 write(*,*)
"INFO [PRC_MPIsplit] Inter-domain relationship information"
603 if ( col_parent(color) >= 0 )
then
604 write(*,
'(5x,A,I2.2)')
"Relationship No.", i
605 write(*,
'(5x,A,I2.2,A,A,I2.2)')
"Parent color: ", col_parent(color),
" <=> ", &
606 "Child color: ", color
614 if ( col_parent(color) >= 0 )
then
617 if ( prc2color(org_myrank) == col_parent(color) )
then
620 org_comm_world, col_master(color), &
621 itag, intercomm_child, ierr )
623 elseif( prc2color(org_myrank) == color )
then
626 org_comm_world, col_master(col_parent(color)), &
627 itag, intercomm_parent, ierr )
631 call mpi_barrier(org_comm_world,ierr)
635 deallocate( prc2color )
636 deallocate( prc2key )
640 write(*,*)
"ERROR [RPC_MPIsplit] REQUESTED DOMAIN NUMBER IS NOT ACCEPTABLE"
650 subroutine prc_mpicoloring( &
666 integer,
intent(in) :: org_comm_world
667 integer,
intent(in) :: org_nrank
668 integer,
intent(in) :: num_subgroup
669 integer,
intent(in) :: prc_subgroup(:)
670 logical,
intent(in) :: color_reorder
671 logical,
intent(in) :: bulkjob
672 logical,
intent(in) :: debug
673 integer,
intent(out) :: prc2color (0:org_nrank-1)
674 integer,
intent(out) :: prc2key (0:org_nrank-1)
680 integer :: prc_reorder( num_subgroup)
681 integer :: dom2col ( num_subgroup)
682 integer :: col2dom (0:num_subgroup-1)
683 logical :: touch (0:num_subgroup-1)
688 integer :: i, domain, color, p
692 if ( color_reorder .AND. .NOT. bulkjob )
then
694 prc_reorder(1:num_subgroup) = prc_subgroup(1:num_subgroup)
695 call prc_sort_ascd( prc_reorder(1:num_subgroup), 1, num_subgroup )
698 do domain = 1, num_subgroup
699 do i = num_subgroup, 1, -1
701 if ( prc_subgroup(domain) == prc_reorder(i) .AND. ( .NOT. touch(color) ) )
then
702 dom2col(domain) = color
703 col2dom(color) = domain
704 touch(color) = .true.
712 do domain = 1, num_subgroup
714 dom2col(domain) = color
715 col2dom(color) = domain
723 if ( .NOT. bulkjob )
then
724 do i = 1, num_subgroup
728 if ( id_parent >= 1 .AND. id_parent <= num_subgroup )
then
729 col_parent(dom2col(i)) = dom2col(id_parent)
731 if ( id_child >= 1 .AND. id_child <= num_subgroup )
then
732 col_child(dom2col(i)) = dom2col(id_child)
736 write(*,
'(4(A,I2))') &
737 "DOMAIN: ", i,
", MY COL: ", dom2col(i),
", PARENT COL:", col_parent(i),
", CHILD COL:", col_child(i)
744 write(*,*)
'INFO [PRC_MPIcoloring] Domain information'
745 write(*,
'(5x,A,L2)')
'Reordering? : ', color_reorder
746 do i = 1, num_subgroup
748 domain = col2dom(color)
750 write(*,
'(5x,2(A,I2.2))')
"Order No. ", i,
" -> Domain No. ", domain
751 write(*,
'(5x,A,I5)')
"Number of process = ", prc_subgroup(domain)
752 write(*,
'(5x,A,I5)')
"Color of this domain = ", color
753 if ( col_parent(color) >= 0 )
then
754 write(*,
'(5x,A,I5)')
"Color of parent domain = ", col_parent(color)
756 write(*,
'(5x,A)' )
"Color of parent domain = no parent"
758 if ( col_child(color) >= 0 )
then
759 write(*,
'(5x,A,I5)')
"Color of child domain = ", col_child(color)
761 write(*,
'(5x,A)' )
"Color of child domain = no child"
769 domain = col2dom(color)
770 nprc = prc_subgroup(domain)
773 do p = 0, org_nrank-1
778 col_domain(color) = domain
779 col_master(color) = p
783 write(*,
'(5x,4(A,I5))') &
784 "PE:", p,
" COLOR:", prc2color(p),
" KEY:", prc2key(p),
" COL_master:", col_master(color)
788 if ( key >= nprc )
then
791 if ( color < num_subgroup )
then
792 domain = col2dom(color)
793 nprc = prc_subgroup(domain)
799 end subroutine prc_mpicoloring
803 recursive subroutine prc_sort_ascd(a, top, bottom)
805 integer,
intent(inout) :: a(:)
806 integer,
intent(in) :: top, bottom
807 integer :: i, j, cnt, trg
809 cnt = a( (top+bottom) / 2 )
812 do while ( a(i) > cnt )
815 do while ( cnt > a(j) )
819 trg = a(i); a(i) = a(j); a(j) = trg
823 if ( top < i-1 )
call prc_sort_ascd( a, top, i-1 )
824 if ( j+1 < bottom )
call prc_sort_ascd( a, j+1, bottom )
826 end subroutine prc_sort_ascd
852 time = real(mpi_wtime(), kind=
dp)
870 real(
dp),
intent(out) :: avgvar(:)
871 real(
dp),
intent(out) :: maxvar(:)
872 real(
dp),
intent(out) :: minvar(:)
873 integer,
intent(out) :: maxidx(:)
874 integer,
intent(out) :: minidx(:)
875 real(
dp),
intent(in) :: var(:)
877 real(
dp),
allocatable :: statval(:,:)
888 statval(:,:) = 0.0_dp
896 call mpi_bcast( statval(1,p), &
898 mpi_double_precision, &
907 totalvar = totalvar + statval(v,p)
911 maxvar(v) = maxval(statval(v,:))
912 minvar(v) = minval(statval(v,:))
913 maxidx(v:v) = maxloc(statval(v,:))
914 minidx(v:v) = minloc(statval(v,:))
917 deallocate( statval )
924 subroutine prc_mpi_errorhandler( &
933 character(len=MPI_MAX_ERROR_STRING) :: msg
936 logical :: sign_status
944 sign_status = .false.
946 do while ( .NOT. sign_exit )
955 log_progress(*)
'abort MPI'
968 if ( errcode == prc_abort_code )
then
970 elseif( errcode <= mpi_err_lastcode )
then
971 call mpi_error_string(errcode, msg, len, ierr)
973 write(*,*)
'+++++ ', errcode, trim(msg)
975 if(
io_l )
write(
io_fid_log,*)
'+++++ Unexpected error code', errcode
976 write(*,*)
'+++++ Unexpected error code', errcode
981 write(*,*)
'+++++ Unexpected communicator'
987 if (
associated( prc_file_closer ) )
call prc_file_closer( .true. )
1002 end subroutine prc_mpi_errorhandler
1005 procedure(closer) :: routine
1007 prc_file_closer => routine