ROMS
Loading...
Searching...
No Matches
Public Member Functions | List of all members
distribute_mod::mp_reduce Interface Reference

Public Member Functions

subroutine mp_reduce_i8 (ng, model, asize, a, handle_op, inpcomm)
 
subroutine mp_reduce_0dp (ng, model, asize, a, handle_op, inpcomm)
 
subroutine mp_reduce_1dp (ng, model, asize, a, handle_op, inpcomm)
 
subroutine mp_reduce_0d (ng, model, asize, a, handle_op, inpcomm)
 
subroutine mp_reduce_1d (ng, model, asize, a, handle_op, inpcomm)
 

Detailed Description

Definition at line 113 of file distribute.F.

Member Function/Subroutine Documentation

◆ mp_reduce_0d()

subroutine distribute_mod::mp_reduce::mp_reduce_0d ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) asize,
real(r8), intent(inout) a,
character (len=*), intent(in) handle_op,
integer, intent(in), optional inpcomm )

Definition at line 6786 of file distribute.F.

6787!
6788!***********************************************************************
6789! !
6790! This routine collects and reduces requested variables from all !
6791! nodes in the group. Then, it broadcasts reduced variables to !
6792! all nodes in the group. !
6793! !
6794! On Input: !
6795! !
6796! ng Nested grid number. !
6797! model Calling model identifier. !
6798! Asize Number of scalar variables to reduce. !
6799! A Vector of scalar variables to reduce. !
6800! handle_op Reduction operation handle (string). The following !
6801! reduction operations are supported: !
6802! 'MIN', 'MAX', 'SUM' !
6803! InpComm Communicator handle (integer, OPTIONAL). !
6804! !
6805! On Output: !
6806! !
6807! A Vector of reduced scalar variables. !
6808! !
6809!***********************************************************************
6810!
6811! Imported variable declarations.
6812!
6813 integer, intent(in) :: ng, model, Asize
6814
6815 integer, intent(in), optional :: InpComm
6816!
6817 character (len=*), intent(in) :: handle_op
6818!
6819 real(r8), intent(inout) :: A
6820!
6821! Local variable declarations.
6822!
6823 integer :: Lstr, MyCOMM, MyError, Npts, Serror
6824 integer :: handle, i, rank, request
6825
6826 integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
6827
6828 integer, dimension(MPI_STATUS_SIZE) :: Rstatus
6829 integer, dimension(MPI_STATUS_SIZE) :: Sstatus
6830!
6831 real(r8) :: Areduce
6832 real(r8) :: Asend
6833 real(r8), dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
6834!
6835 character (len=MPI_MAX_ERROR_STRING) :: string
6836
6837 character (len=*), parameter :: MyFile = &
6838 & __FILE__//", mp_reduce_0d"
6839
6840# ifdef PROFILE
6841!
6842!-----------------------------------------------------------------------
6843! Turn on time clocks.
6844!-----------------------------------------------------------------------
6845!
6846 CALL wclock_on (ng, model, 65, __line__, myfile)
6847# endif
6848# ifdef MPI
6849!
6850!-----------------------------------------------------------------------
6851! Set distributed-memory communicator handle (context ID).
6852!-----------------------------------------------------------------------
6853!
6854 IF (PRESENT(inpcomm)) THEN
6855 mycomm=inpcomm
6856 ELSE
6857 mycomm=ocn_comm_world
6858 END IF
6859# endif
6860!
6861!-----------------------------------------------------------------------
6862! Collect and reduce requested scalar variables.
6863!-----------------------------------------------------------------------
6864!
6865! Pack data to reduce.
6866!
6867 asend=a
6868 npts=1
6869!
6870! Collect and reduce.
6871!
6872# if defined REDUCE_ALLREDUCE
6873 IF (handle_op(1:3).eq.'MIN') THEN
6874 handle=mpi_min
6875 ELSE IF (handle_op(1:3).eq.'MAX') THEN
6876 handle=mpi_max
6877 ELSE IF (handle_op(1:3).eq.'SUM') THEN
6878 handle=mpi_sum
6879 END IF
6880 CALL mpi_allreduce (asend, areduce, npts, mp_float, handle, &
6881 & mycomm, myerror)
6882 IF (myerror.ne.mpi_success) THEN
6883 CALL mpi_error_string (myerror, string, lstr, serror)
6884 lstr=len_trim(string)
6885 WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror, &
6886 & string(1:lstr)
6887 exit_flag=2
6888 RETURN
6889 END IF
6890# elif defined REDUCE_ALLGATHER
6891 CALL mpi_allgather (asend, npts, mp_float, &
6892 & arecv, npts, mp_float, &
6893 & mycomm, myerror)
6894 IF (myerror.ne.mpi_success) THEN
6895 CALL mpi_error_string (myerror, string, lstr, serror)
6896 lstr=len_trim(string)
6897 WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror, &
6898 & string(1:lstr)
6899 exit_flag=2
6900 RETURN
6901 END IF
6902 areduce=arecv(0)
6903 DO rank=1,ntilei(ng)*ntilej(ng)-1
6904 IF (handle_op(1:3).eq.'MIN') THEN
6905 areduce=min(areduce,arecv(rank))
6906 ELSE IF (handle_op(1:3).eq.'MAX') THEN
6907 areduce=max(areduce,arecv(rank))
6908 ELSE IF (handle_op(1:3).eq.'SUM') THEN
6909 areduce=areduce+arecv(rank)
6910 END IF
6911 END DO
6912# elif defined REDUCE_SENDRECV
6913 IF (myrank.eq.mymaster) THEN
6914 DO rank=1,ntilei(ng)*ntilej(ng)-1
6915 CALL mpi_irecv (arecv(rank), npts, mp_float, rank, &
6916 & rank+500, mycomm, rrequest(rank), &
6917 & myerror)
6918 END DO
6919 areduce=asend
6920 DO rank=1,ntilei(ng)*ntilej(ng)-1
6921 CALL mpi_wait (rrequest(rank), rstatus, myerror)
6922 IF (myerror.ne.mpi_success) THEN
6923 CALL mpi_error_string (myerror, string, lstr, serror)
6924 lstr=len_trim(string)
6925 WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
6926 exit_flag=2
6927 RETURN
6928 END IF
6929 IF (handle_op(1:3).eq.'MIN') THEN
6930 areduce=min(areduce,arecv(rank))
6931 ELSE IF (handle_op(1:3).eq.'MAX') THEN
6932 areduce=max(areduce,arecv(rank))
6933 ELSE IF (handle_op(1:3).eq.'SUM') THEN
6934 areduce=areduce+arecv(rank)
6935 END IF
6936 END DO
6937 ELSE
6938 CALL mpi_isend (asend, npts, mp_float, mymaster, myrank+500, &
6939 & mycomm, request, myerror)
6940 CALL mpi_wait (request, sstatus, myerror)
6941 IF (myerror.ne.mpi_success) THEN
6942 CALL mpi_error_string (myerror, string, lstr, serror)
6943 lstr=len_trim(string)
6944 WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
6945 exit_flag=2
6946 RETURN
6947 END IF
6948 END IF
6949!
6950! Broadcast reduced variables from process to all processes in the
6951! group.
6952!
6953 CALL mpi_bcast (areduce, npts, mp_float, mymaster, &
6954 & mycomm, myerror)
6955 IF (myerror.ne.mpi_success) THEN
6956 CALL mpi_error_string (myerror, string, lstr, serror)
6957 lstr=len_trim(string)
6958 WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
6959 exit_flag=2
6960 RETURN
6961 END IF
6962# endif
6963 10 FORMAT (/,' MP_REDUCE_0D - error during ',a,' call, Task = ', &
6964 & i3.3,' Error = ',i3,/,16x,a)
6965!
6966! Unpack.
6967!
6968 a=areduce
6969# ifdef PROFILE
6970!
6971!-----------------------------------------------------------------------
6972! Turn off time clocks.
6973!-----------------------------------------------------------------------
6974!
6975 CALL wclock_off (ng, model, 65, __line__, myfile)
6976# endif
6977!
6978 RETURN
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3

References mod_scalars::exit_flag, mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::rerror, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

◆ mp_reduce_0dp()

subroutine distribute_mod::mp_reduce::mp_reduce_0dp ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) asize,
real(dp), intent(inout) a,
character (len=*), intent(in) handle_op,
integer, intent(in), optional inpcomm )

Definition at line 6379 of file distribute.F.

6380!
6381!***********************************************************************
6382! !
6383! This routine collects and reduces requested double precision !
6384! variables from all nodes in the group. Then, it broadcasts !
6385! reduced variables to all nodes in the group. !
6386! !
6387! On Input: !
6388! !
6389! ng Nested grid number. !
6390! model Calling model identifier. !
6391! Asize Number of scalar variables to reduce. !
6392! A Vector of scalar variables to reduce. !
6393! handle_op Reduction operation handle (string). The following !
6394! reduction operations are supported: !
6395! 'MIN', 'MAX', 'SUM' !
6396! InpComm Communicator handle (integer, OPTIONAL). !
6397! !
6398! On Output: !
6399! !
6400! A Vector of reduced scalar variables. !
6401! !
6402!***********************************************************************
6403!
6404! Imported variable declarations.
6405!
6406 integer, intent(in) :: ng, model, Asize
6407
6408 integer, intent(in), optional :: InpComm
6409!
6410 character (len=*), intent(in) :: handle_op
6411!
6412 real(dp), intent(inout) :: A
6413!
6414! Local variable declarations.
6415!
6416 integer :: Lstr, MyCOMM, MyError, Npts, Serror
6417 integer :: handle, i, rank, request
6418
6419 integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
6420
6421 integer, dimension(MPI_STATUS_SIZE) :: Rstatus
6422 integer, dimension(MPI_STATUS_SIZE) :: Sstatus
6423!
6424 real(dp) :: Areduce
6425 real(dp) :: Asend
6426 real(dp), dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
6427!
6428 character (len=MPI_MAX_ERROR_STRING) :: string
6429
6430 character (len=*), parameter :: MyFile = &
6431 & __FILE__//", mp_reduce_0dp"
6432
6433# ifdef PROFILE
6434!
6435!-----------------------------------------------------------------------
6436! Turn on time clocks.
6437!-----------------------------------------------------------------------
6438!
6439 CALL wclock_on (ng, model, 65, __line__, myfile)
6440# endif
6441# ifdef MPI
6442!
6443!-----------------------------------------------------------------------
6444! Set distributed-memory communicator handle (context ID).
6445!-----------------------------------------------------------------------
6446!
6447 IF (PRESENT(inpcomm)) THEN
6448 mycomm=inpcomm
6449 ELSE
6450 mycomm=ocn_comm_world
6451 END IF
6452# endif
6453!
6454!-----------------------------------------------------------------------
6455! Collect and reduce requested scalar variables.
6456!-----------------------------------------------------------------------
6457!
6458! Pack data to reduce.
6459!
6460 asend=a
6461 npts=1
6462!
6463! Collect and reduce.
6464!
6465# if defined REDUCE_ALLREDUCE
6466 IF (handle_op(1:3).eq.'MIN') THEN
6467 handle=mpi_min
6468 ELSE IF (handle_op(1:3).eq.'MAX') THEN
6469 handle=mpi_max
6470 ELSE IF (handle_op(1:3).eq.'SUM') THEN
6471 handle=mpi_sum
6472 END IF
6473 CALL mpi_allreduce (asend, areduce, npts, mp_double, handle, &
6474 & mycomm, myerror)
6475 IF (myerror.ne.mpi_success) THEN
6476 CALL mpi_error_string (myerror, string, lstr, serror)
6477 lstr=len_trim(string)
6478 WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror, &
6479 & string(1:lstr)
6480 exit_flag=2
6481 RETURN
6482 END IF
6483# elif defined REDUCE_ALLGATHER
6484 CALL mpi_allgather (asend, npts, mp_double, &
6485 & arecv, npts, mp_double, &
6486 & mycomm, myerror)
6487 IF (myerror.ne.mpi_success) THEN
6488 CALL mpi_error_string (myerror, string, lstr, serror)
6489 lstr=len_trim(string)
6490 WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror, &
6491 & string(1:lstr)
6492 exit_flag=2
6493 RETURN
6494 END IF
6495 areduce=arecv(0)
6496 DO rank=1,ntilei(ng)*ntilej(ng)-1
6497 IF (handle_op(1:3).eq.'MIN') THEN
6498 areduce=min(areduce,arecv(rank))
6499 ELSE IF (handle_op(1:3).eq.'MAX') THEN
6500 areduce=max(areduce,arecv(rank))
6501 ELSE IF (handle_op(1:3).eq.'SUM') THEN
6502 areduce=areduce+arecv(rank)
6503 END IF
6504 END DO
6505# elif defined REDUCE_SENDRECV
6506 IF (myrank.eq.mymaster) THEN
6507 DO rank=1,ntilei(ng)*ntilej(ng)-1
6508 CALL mpi_irecv (arecv(rank), npts, mp_double, rank, &
6509 & rank+500, mycomm, rrequest(rank), &
6510 & myerror)
6511 END DO
6512 areduce=asend
6513 DO rank=1,ntilei(ng)*ntilej(ng)-1
6514 CALL mpi_wait (rrequest(rank), rstatus, myerror)
6515 IF (myerror.ne.mpi_success) THEN
6516 CALL mpi_error_string (myerror, string, lstr, serror)
6517 lstr=len_trim(string)
6518 WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
6519 exit_flag=2
6520 RETURN
6521 END IF
6522 IF (handle_op(1:3).eq.'MIN') THEN
6523 areduce=min(areduce,arecv(rank))
6524 ELSE IF (handle_op(1:3).eq.'MAX') THEN
6525 areduce=max(areduce,arecv(rank))
6526 ELSE IF (handle_op(1:3).eq.'SUM') THEN
6527 areduce=areduce+arecv(rank)
6528 END IF
6529 END DO
6530 ELSE
6531 CALL mpi_isend (asend, npts, mp_double, mymaster, myrank+500, &
6532 & mycomm, request, myerror)
6533 CALL mpi_wait (request, sstatus, myerror)
6534 IF (myerror.ne.mpi_success) THEN
6535 CALL mpi_error_string (myerror, string, lstr, serror)
6536 lstr=len_trim(string)
6537 WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
6538 exit_flag=2
6539 RETURN
6540 END IF
6541 END IF
6542!
6543! Broadcast reduced variables from process to all processes in the
6544! group.
6545!
6546 CALL mpi_bcast (areduce, npts, mp_double, mymaster, &
6547 & mycomm, myerror)
6548 IF (myerror.ne.mpi_success) THEN
6549 CALL mpi_error_string (myerror, string, lstr, serror)
6550 lstr=len_trim(string)
6551 WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
6552 exit_flag=2
6553 RETURN
6554 END IF
6555# endif
6556 10 FORMAT (/,' MP_REDUCE_0DP - error during ',a,' call, Task = ', &
6557 & i3.3,' Error = ',i3,/,16x,a)
6558!
6559! Unpack.
6560!
6561 a=areduce
6562# ifdef PROFILE
6563!
6564!-----------------------------------------------------------------------
6565! Turn off time clocks.
6566!-----------------------------------------------------------------------
6567!
6568 CALL wclock_off (ng, model, 65, __line__, myfile)
6569# endif
6570!
6571 RETURN

References mod_scalars::exit_flag, mod_parallel::mp_double, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::rerror, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

◆ mp_reduce_1d()

subroutine distribute_mod::mp_reduce::mp_reduce_1d ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) asize,
real(r8), dimension(asize), intent(inout) a,
character (len=*), dimension(asize), intent(in) handle_op,
integer, intent(in), optional inpcomm )

Definition at line 6981 of file distribute.F.

6982!
6983!***********************************************************************
6984! !
6985! This routine collects and reduces requested variables from all !
6986! nodes in the group. Then, it broadcasts reduced variables to !
6987! all nodes in the group. !
6988! !
6989! On Input: !
6990! !
6991! ng Nested grid number. !
6992! model Calling model identifier. !
6993! Asize Number of scalar variables to reduce. !
6994! A Vector of scalar variables to reduce. !
6995! handle_op Reduction operation handle (string). The following !
6996! reduction operations are supported: !
6997! 'MIN', 'MAX', 'SUM' !
6998! InpComm Communicator handle (integer, OPTIONAL). !
6999! !
7000! On Output: !
7001! !
7002! A Vector of reduced scalar variables. !
7003! !
7004!***********************************************************************
7005!
7006! Imported variable declarations.
7007!
7008 integer, intent(in) :: ng, model, Asize
7009
7010 integer, intent(in), optional :: InpComm
7011!
7012 character (len=*), intent(in) :: handle_op(Asize)
7013!
7014 real(r8), intent(inout) :: A(Asize)
7015!
7016! Local variable declarations.
7017!
7018 integer :: Lstr, MyCOMM, MyError, Serror
7019 integer :: handle, i, rank, request
7020
7021 integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
7022
7023 integer, dimension(MPI_STATUS_SIZE) :: Rstatus
7024 integer, dimension(MPI_STATUS_SIZE) :: Sstatus
7025!
7026 real(r8), dimension(Asize,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
7027 real(r8), dimension(Asize) :: Areduce
7028 real(r8), dimension(Asize) :: Asend
7029!
7030 character (len=MPI_MAX_ERROR_STRING) :: string
7031
7032 character (len=*), parameter :: MyFile = &
7033 & __FILE__//", mp_reduce_1d"
7034
7035# ifdef PROFILE
7036!
7037!-----------------------------------------------------------------------
7038! Turn on time clocks.
7039!-----------------------------------------------------------------------
7040!
7041 CALL wclock_on (ng, model, 65, __line__, myfile)
7042# endif
7043# ifdef MPI
7044!
7045!-----------------------------------------------------------------------
7046! Set distributed-memory communicator handle (context ID).
7047!-----------------------------------------------------------------------
7048!
7049 IF (PRESENT(inpcomm)) THEN
7050 mycomm=inpcomm
7051 ELSE
7052 mycomm=ocn_comm_world
7053 END IF
7054# endif
7055!
7056!-----------------------------------------------------------------------
7057! Collect and reduce requested scalar variables.
7058!-----------------------------------------------------------------------
7059!
7060! Maximum automatic buffer memory size in bytes.
7061!
7062 bmemmax(ng)=max(bmemmax(ng), real((SIZE(arecv)+ &
7063 & 2*asize)*kind(a),r8))
7064!
7065! Pack data to reduce.
7066!
7067 DO i=1,asize
7068 asend(i)=a(i)
7069 END DO
7070!
7071! Collect and reduce.
7072!
7073# if defined REDUCE_ALLREDUCE
7074 DO i=1,asize
7075 IF (handle_op(i)(1:3).eq.'MIN') THEN
7076 handle=mpi_min
7077 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
7078 handle=mpi_max
7079 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
7080 handle=mpi_sum
7081 END IF
7082 CALL mpi_allreduce (asend(i), areduce(i), 1, mp_float, handle, &
7083 & mycomm, myerror)
7084 IF (myerror.ne.mpi_success) THEN
7085 CALL mpi_error_string (myerror, string, lstr, serror)
7086 lstr=len_trim(string)
7087 WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror, &
7088 & string(1:lstr)
7089 exit_flag=2
7090 RETURN
7091 END IF
7092 END DO
7093# elif defined REDUCE_ALLGATHER
7094 CALL mpi_allgather (asend, asize, mp_float, &
7095 & arecv, asize, mp_float, &
7096 & mycomm, myerror)
7097 IF (myerror.ne.mpi_success) THEN
7098 CALL mpi_error_string (myerror, string, lstr, serror)
7099 lstr=len_trim(string)
7100 WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror, &
7101 & string(1:lstr)
7102 exit_flag=2
7103 RETURN
7104 END IF
7105 DO i=1,asize
7106 areduce(i)=arecv(i,0)
7107 DO rank=1,ntilei(ng)*ntilej(ng)-1
7108 IF (handle_op(i)(1:3).eq.'MIN') THEN
7109 areduce(i)=min(areduce(i),arecv(i,rank))
7110 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
7111 areduce(i)=max(areduce(i),arecv(i,rank))
7112 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
7113 areduce(i)=areduce(i)+arecv(i,rank)
7114 END IF
7115 END DO
7116 END DO
7117# elif defined REDUCE_SENDRECV
7118 IF (myrank.eq.mymaster) THEN
7119 DO rank=1,ntilei(ng)*ntilej(ng)-1
7120 CALL mpi_irecv (arecv(1,rank), asize, mp_float, rank, &
7121 & rank+500, mycomm, rrequest(rank), myerror)
7122 END DO
7123 DO i=1,asize
7124 areduce(i)=asend(i)
7125 END DO
7126 DO rank=1,ntilei(ng)*ntilej(ng)-1
7127 CALL mpi_wait (rrequest(rank), rstatus, myerror)
7128 IF (myerror.ne.mpi_success) THEN
7129 CALL mpi_error_string (myerror, string, lstr, serror)
7130 lstr=len_trim(string)
7131 WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
7132 exit_flag=2
7133 RETURN
7134 END IF
7135 DO i=1,asize
7136 IF (handle_op(i)(1:3).eq.'MIN') THEN
7137 areduce(i)=min(areduce(i),arecv(i,rank))
7138 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
7139 areduce(i)=max(areduce(i),arecv(i,rank))
7140 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
7141 areduce(i)=areduce(i)+arecv(i,rank)
7142 END IF
7143 END DO
7144 END DO
7145 ELSE
7146 CALL mpi_isend (asend, asize, mp_float, mymaster, myrank+500, &
7147 & mycomm, request, myerror)
7148 CALL mpi_wait (request, sstatus, myerror)
7149 IF (myerror.ne.mpi_success) THEN
7150 CALL mpi_error_string (myerror, string, lstr, serror)
7151 lstr=len_trim(string)
7152 WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
7153 exit_flag=2
7154 RETURN
7155 END IF
7156 END IF
7157!
7158! Broadcast reduced variables from process to all processes in the
7159! group.
7160!
7161 CALL mpi_bcast (areduce, asize, mp_float, mymaster, &
7162 & mycomm, myerror)
7163 IF (myerror.ne.mpi_success) THEN
7164 CALL mpi_error_string (myerror, string, lstr, serror)
7165 lstr=len_trim(string)
7166 WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
7167 exit_flag=2
7168 RETURN
7169 END IF
7170# endif
7171 10 FORMAT (/,' MP_REDUCE_1D - error during ',a,' call, Task = ', &
7172 & i3.3,' Error = ',i3,/,16x,a)
7173!
7174! Unpack.
7175!
7176 DO i=1,asize
7177 a(i)=areduce(i)
7178 END DO
7179# ifdef PROFILE
7180!
7181!-----------------------------------------------------------------------
7182! Turn off time clocks.
7183!-----------------------------------------------------------------------
7184!
7185 CALL wclock_off (ng, model, 65, __line__, myfile)
7186# endif
7187!
7188 RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::rerror, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

◆ mp_reduce_1dp()

subroutine distribute_mod::mp_reduce::mp_reduce_1dp ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) asize,
real(dp), dimension(asize), intent(inout) a,
character (len=*), dimension(asize), intent(in) handle_op,
integer, intent(in), optional inpcomm )

Definition at line 6574 of file distribute.F.

6575!
6576!***********************************************************************
6577! !
6578! This routine collects and reduces requested double precision !
6579! variables from all nodes in the group. Then, it broadcasts !
6580! reduced variables to all nodes in the group. !
6581! !
6582! On Input: !
6583! !
6584! ng Nested grid number. !
6585! model Calling model identifier. !
6586! Asize Number of scalar variables to reduce. !
6587! A Vector of scalar variables to reduce. !
6588! handle_op Reduction operation handle (string). The following !
6589! reduction operations are supported: !
6590! 'MIN', 'MAX', 'SUM' !
6591! InpComm Communicator handle (integer, OPTIONAL). !
6592! !
6593! On Output: !
6594! !
6595! A Vector of reduced scalar variables. !
6596! !
6597!***********************************************************************
6598!
6599! Imported variable declarations.
6600!
6601 integer, intent(in) :: ng, model, Asize
6602
6603 integer, intent(in), optional :: InpComm
6604!
6605 character (len=*), intent(in) :: handle_op(Asize)
6606!
6607 real(dp), intent(inout) :: A(Asize)
6608!
6609! Local variable declarations.
6610!
6611 integer :: Lstr, MyCOMM, MyError, Serror
6612 integer :: handle, i, rank, request
6613
6614 integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
6615
6616 integer, dimension(MPI_STATUS_SIZE) :: Rstatus
6617 integer, dimension(MPI_STATUS_SIZE) :: Sstatus
6618!
6619 real(dp), dimension(Asize,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
6620 real(dp), dimension(Asize) :: Areduce
6621 real(dp), dimension(Asize) :: Asend
6622!
6623 character (len=MPI_MAX_ERROR_STRING) :: string
6624
6625 character (len=*), parameter :: MyFile = &
6626 & __FILE__//", mp_reduce_1dp"
6627
6628# ifdef PROFILE
6629!
6630!-----------------------------------------------------------------------
6631! Turn on time clocks.
6632!-----------------------------------------------------------------------
6633!
6634 CALL wclock_on (ng, model, 65, __line__, myfile)
6635# endif
6636# ifdef MPI
6637!
6638!-----------------------------------------------------------------------
6639! Set distributed-memory communicator handle (context ID).
6640!-----------------------------------------------------------------------
6641!
6642 IF (PRESENT(inpcomm)) THEN
6643 mycomm=inpcomm
6644 ELSE
6645 mycomm=ocn_comm_world
6646 END IF
6647# endif
6648!
6649!-----------------------------------------------------------------------
6650! Collect and reduce requested scalar variables.
6651!-----------------------------------------------------------------------
6652!
6653! Maximum automatic buffer memory size in bytes.
6654!
6655 bmemmax(ng)=max(bmemmax(ng), real((SIZE(arecv)+ &
6656 & 2*asize)*kind(a),r8))
6657!
6658! Pack data to reduce.
6659!
6660 DO i=1,asize
6661 asend(i)=a(i)
6662 END DO
6663!
6664! Collect and reduce.
6665!
6666# if defined REDUCE_ALLREDUCE
6667 DO i=1,asize
6668 IF (handle_op(i)(1:3).eq.'MIN') THEN
6669 handle=mpi_min
6670 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
6671 handle=mpi_max
6672 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
6673 handle=mpi_sum
6674 END IF
6675 CALL mpi_allreduce (asend(i), areduce(i), 1, mp_double, handle, &
6676 & mycomm, myerror)
6677 IF (myerror.ne.mpi_success) THEN
6678 CALL mpi_error_string (myerror, string, lstr, serror)
6679 lstr=len_trim(string)
6680 WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror, &
6681 & string(1:lstr)
6682 exit_flag=2
6683 RETURN
6684 END IF
6685 END DO
6686# elif defined REDUCE_ALLGATHER
6687 CALL mpi_allgather (asend, asize, mp_double, &
6688 & arecv, asize, mp_double, &
6689 & mycomm, myerror)
6690 IF (myerror.ne.mpi_success) THEN
6691 CALL mpi_error_string (myerror, string, lstr, serror)
6692 lstr=len_trim(string)
6693 WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror, &
6694 & string(1:lstr)
6695 exit_flag=2
6696 RETURN
6697 END IF
6698 DO i=1,asize
6699 areduce(i)=arecv(i,0)
6700 DO rank=1,ntilei(ng)*ntilej(ng)-1
6701 IF (handle_op(i)(1:3).eq.'MIN') THEN
6702 areduce(i)=min(areduce(i),arecv(i,rank))
6703 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
6704 areduce(i)=max(areduce(i),arecv(i,rank))
6705 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
6706 areduce(i)=areduce(i)+arecv(i,rank)
6707 END IF
6708 END DO
6709 END DO
6710# elif defined REDUCE_SENDRECV
6711 IF (myrank.eq.mymaster) THEN
6712 DO rank=1,ntilei(ng)*ntilej(ng)-1
6713 CALL mpi_irecv (arecv(1,rank), asize, mp_double, rank, &
6714 & rank+500, mycomm, rrequest(rank), &
6715 & myerror)
6716 END DO
6717 DO i=1,asize
6718 areduce(i)=asend(i)
6719 END DO
6720 DO rank=1,ntilei(ng)*ntilej(ng)-1
6721 CALL mpi_wait (rrequest(rank), rstatus, myerror)
6722 IF (myerror.ne.mpi_success) THEN
6723 CALL mpi_error_string (myerror, string, lstr, serror)
6724 lstr=len_trim(string)
6725 WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
6726 exit_flag=2
6727 RETURN
6728 END IF
6729 DO i=1,asize
6730 IF (handle_op(i)(1:3).eq.'MIN') THEN
6731 areduce(i)=min(areduce(i),arecv(i,rank))
6732 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
6733 areduce(i)=max(areduce(i),arecv(i,rank))
6734 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
6735 areduce(i)=areduce(i)+arecv(i,rank)
6736 END IF
6737 END DO
6738 END DO
6739 ELSE
6740 CALL mpi_isend (asend, asize, mp_double, mymaster, myrank+500, &
6741 & mycomm, request, myerror)
6742 CALL mpi_wait (request, sstatus, myerror)
6743 IF (myerror.ne.mpi_success) THEN
6744 CALL mpi_error_string (myerror, string, lstr, serror)
6745 lstr=len_trim(string)
6746 WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
6747 exit_flag=2
6748 RETURN
6749 END IF
6750 END IF
6751!
6752! Broadcast reduced variables from process to all processes in the
6753! group.
6754!
6755 CALL mpi_bcast (areduce, asize, mp_double, mymaster, &
6756 & mycomm, myerror)
6757 IF (myerror.ne.mpi_success) THEN
6758 CALL mpi_error_string (myerror, string, lstr, serror)
6759 lstr=len_trim(string)
6760 WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
6761 exit_flag=2
6762 RETURN
6763 END IF
6764# endif
6765 10 FORMAT (/,' MP_REDUCE_1DP - error during ',a,' call, Task = ', &
6766 & i3.3,' Error = ',i3,/,16x,a)
6767!
6768! Unpack.
6769!
6770 DO i=1,asize
6771 a(i)=areduce(i)
6772 END DO
6773# ifdef PROFILE
6774!
6775!-----------------------------------------------------------------------
6776! Turn off time clocks.
6777!-----------------------------------------------------------------------
6778!
6779 CALL wclock_off (ng, model, 65, __line__, myfile)
6780# endif
6781!
6782 RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::mp_double, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::rerror, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

◆ mp_reduce_i8()

subroutine distribute_mod::mp_reduce::mp_reduce_i8 ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) asize,
integer(i8b), dimension(asize), intent(inout) a,
character (len=*), dimension(asize), intent(in) handle_op,
integer, intent(in), optional inpcomm )

Definition at line 6167 of file distribute.F.

6168!
6169!***********************************************************************
6170! !
6171! This routine collects and reduces requested 1D integer array !
6172! variables from all nodes in the group. !
6173! !
6174! On Input: !
6175! !
6176! ng Nested grid number. !
6177! model Calling model identifier. !
6178! Asize Number of scalar variables to reduce. !
6179! A Vector of scalar variables to reduce. !
6180! handle_op Reduction operation handle (string). The following !
6181! reduction operations are supported: !
6182! 'MIN', 'MAX', 'SUM' !
6183! InpComm Communicator handle (integer, OPTIONAL). !
6184! !
6185! On Output: !
6186! !
6187! A Vector of reduced scalar variables. !
6188! !
6189!***********************************************************************
6190!
6191! Imported variable declarations.
6192!
6193 integer, intent(in) :: ng, model, Asize
6194
6195 integer, intent(in), optional :: InpComm
6196!
6197 character (len=*), intent(in) :: handle_op(Asize)
6198!
6199 integer(i8b), intent(inout) :: A(Asize)
6200!
6201! Local variable declarations.
6202!
6203 integer :: Lstr, MyCOMM, MyError, Serror
6204 integer :: handle, i, rank, request
6205
6206 integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
6207
6208 integer, dimension(MPI_STATUS_SIZE) :: Rstatus
6209 integer, dimension(MPI_STATUS_SIZE) :: Sstatus
6210!
6211 integer(i8b), dimension(Asize,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
6212 integer(i8b), dimension(Asize) :: Areduce
6213 integer(i8b), dimension(Asize) :: Asend
6214!
6215 character (len=MPI_MAX_ERROR_STRING) :: string
6216
6217 character (len=*), parameter :: MyFile = &
6218 & __FILE__//", mp_reduce_1di"
6219
6220# ifdef PROFILE
6221!
6222!-----------------------------------------------------------------------
6223! Turn on time clocks.
6224!-----------------------------------------------------------------------
6225!
6226 CALL wclock_on (ng, model, 65, __line__, myfile)
6227# endif
6228# ifdef MPI
6229!
6230!-----------------------------------------------------------------------
6231! Set distributed-memory communicator handle (context ID).
6232!-----------------------------------------------------------------------
6233!
6234 IF (PRESENT(inpcomm)) THEN
6235 mycomm=inpcomm
6236 ELSE
6237 mycomm=ocn_comm_world
6238 END IF
6239# endif
6240!
6241!-----------------------------------------------------------------------
6242! Collect and reduce requested scalar variables.
6243!-----------------------------------------------------------------------
6244!
6245! Maximum automatic buffer memory size in bytes.
6246!
6247 bmemmax(ng)=max(bmemmax(ng), real((SIZE(arecv)+ &
6248 & 2*asize)*kind(a),r8))
6249!
6250! Pack data to reduce.
6251!
6252 DO i=1,asize
6253 asend(i)=a(i)
6254 END DO
6255!
6256! Collect and reduce.
6257!
6258# if defined REDUCE_ALLREDUCE
6259 DO i=1,asize
6260 IF (handle_op(i)(1:3).eq.'MIN') THEN
6261 handle=mpi_min
6262 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
6263 handle=mpi_max
6264 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
6265 handle=mpi_sum
6266 END IF
6267 CALL mpi_allreduce (asend(i), areduce(i), 1, mpi_integer, &
6268 & handle, mycomm, myerror)
6269 IF (myerror.ne.mpi_success) THEN
6270 CALL mpi_error_string (myerror, string, lstr, serror)
6271 lstr=len_trim(string)
6272 WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror, &
6273 & string(1:lstr)
6274 exit_flag=2
6275 RETURN
6276 END IF
6277 END DO
6278# elif defined REDUCE_ALLGATHER
6279 CALL mpi_allgather (asend, asize, mpi_integer, &
6280 & arecv, asize, mpi_integer, &
6281 & mycomm, myerror)
6282 IF (myerror.ne.mpi_success) THEN
6283 CALL mpi_error_string (myerror, string, lstr, serror)
6284 lstr=len_trim(string)
6285 WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror, &
6286 & string(1:lstr)
6287 exit_flag=2
6288 RETURN
6289 END IF
6290 DO i=1,asize
6291 areduce(i)=arecv(i,0)
6292 DO rank=1,ntilei(ng)*ntilej(ng)-1
6293 IF (handle_op(i)(1:3).eq.'MIN') THEN
6294 areduce(i)=min(areduce(i),arecv(i,rank))
6295 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
6296 areduce(i)=max(areduce(i),arecv(i,rank))
6297 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
6298 areduce(i)=areduce(i)+arecv(i,rank)
6299 END IF
6300 END DO
6301 END DO
6302# elif defined REDUCE_SENDRECV
6303 IF (myrank.eq.mymaster) THEN
6304 DO rank=1,ntilei(ng)*ntilej(ng)-1
6305 CALL mpi_irecv (arecv(1,rank), asize, mpi_integer, rank, &
6306 & rank+500, mycomm, rrequest(rank), &
6307 & myerror)
6308 END DO
6309 DO i=1,asize
6310 areduce(i)=asend(i)
6311 END DO
6312 DO rank=1,ntilei(ng)*ntilej(ng)-1
6313 CALL mpi_wait (rrequest(rank), rstatus, myerror)
6314 IF (myerror.ne.mpi_success) THEN
6315 CALL mpi_error_string (myerror, string, lstr, serror)
6316 lstr=len_trim(string)
6317 WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
6318 exit_flag=2
6319 RETURN
6320 END IF
6321 DO i=1,asize
6322 IF (handle_op(i)(1:3).eq.'MIN') THEN
6323 areduce(i)=min(areduce(i),arecv(i,rank))
6324 ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
6325 areduce(i)=max(areduce(i),arecv(i,rank))
6326 ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
6327 areduce(i)=areduce(i)+arecv(i,rank)
6328 END IF
6329 END DO
6330 END DO
6331 ELSE
6332 CALL mpi_isend (asend, asize, mpi_integer, mymaster, &
6333 & myrank+500, mycomm, request, myerror)
6334 CALL mpi_wait (request, sstatus, myerror)
6335 IF (myerror.ne.mpi_success) THEN
6336 CALL mpi_error_string (myerror, string, lstr, serror)
6337 lstr=len_trim(string)
6338 WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
6339 exit_flag=2
6340 RETURN
6341 END IF
6342 END IF
6343!
6344! Broadcast reduced variables from process to all processes in the
6345! group.
6346!
6347 CALL mpi_bcast (areduce, asize, mpi_integer, mymaster, &
6348 & mycomm, myerror)
6349 IF (myerror.ne.mpi_success) THEN
6350 CALL mpi_error_string (myerror, string, lstr, serror)
6351 lstr=len_trim(string)
6352 WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
6353 exit_flag=2
6354 RETURN
6355 END IF
6356# endif
6357 10 FORMAT (/,' MP_REDUCE_I8 - error during ',a,' call, Task = ', &
6358 & i3.3,' Error = ',i3,/,16x,a)
6359!
6360! Unpack.
6361!
6362 DO i=1,asize
6363 a(i)=areduce(i)
6364 END DO
6365# ifdef PROFILE
6366!
6367!-----------------------------------------------------------------------
6368! Turn off time clocks.
6369!-----------------------------------------------------------------------
6370!
6371 CALL wclock_off (ng, model, 65, __line__, myfile)
6372# endif
6373!
6374 RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::rerror, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:
The documentation for this interface was generated from the following file: