Module shr_mpi_mod !------------------------------------------------------------------------------- ! PURPOSE: general layer on MPI functions !------------------------------------------------------------------------------- use shr_kind_mod use shr_log_mod, only: s_loglev => shr_log_Level use shr_log_mod, only: s_logunit => shr_log_Unit implicit none private ! PUBLIC: Public interfaces public :: shr_mpi_chkerr public :: shr_mpi_send public :: shr_mpi_recv public :: shr_mpi_bcast public :: shr_mpi_gathScatVInit public :: shr_mpi_gatherV public :: shr_mpi_scatterV public :: shr_mpi_sum public :: shr_mpi_min public :: shr_mpi_max public :: shr_mpi_commsize public :: shr_mpi_commrank public :: shr_mpi_initialized public :: shr_mpi_abort public :: shr_mpi_barrier public :: shr_mpi_init public :: shr_mpi_finalize interface shr_mpi_send ; module procedure & shr_mpi_sendi0, & shr_mpi_sendi1, & shr_mpi_sendr0, & shr_mpi_sendr1, & shr_mpi_sendr3 end interface shr_mpi_send interface shr_mpi_recv ; module procedure & shr_mpi_recvi0, & shr_mpi_recvi1, & shr_mpi_recvr0, & shr_mpi_recvr1, & shr_mpi_recvr3 end interface shr_mpi_recv interface shr_mpi_bcast ; module procedure & shr_mpi_bcastc0, & shr_mpi_bcastc1, & shr_mpi_bcastl0, & shr_mpi_bcastl1, & shr_mpi_bcasti0, & shr_mpi_bcasti1, & shr_mpi_bcasti80, & shr_mpi_bcasti81, & shr_mpi_bcasti2, & shr_mpi_bcastr0, & shr_mpi_bcastr1, & shr_mpi_bcastr2, & shr_mpi_bcastr3 end interface shr_mpi_bcast interface shr_mpi_gathScatVInit ; module procedure & shr_mpi_gathScatVInitr1 end interface shr_mpi_gathScatVInit interface shr_mpi_gatherv ; module procedure & shr_mpi_gatherVr1 end interface shr_mpi_gatherv interface shr_mpi_scatterv ; module procedure & shr_mpi_scatterVr1 end interface shr_mpi_scatterv interface shr_mpi_sum ; module procedure & shr_mpi_sumi0, & shr_mpi_sumi1, & shr_mpi_sumb0, & shr_mpi_sumb1, & shr_mpi_sumr0, & shr_mpi_sumr1, & shr_mpi_sumr2, & shr_mpi_sumr3 end interface shr_mpi_sum interface shr_mpi_min ; module procedure & shr_mpi_mini0, & shr_mpi_mini1, & shr_mpi_minr0, & shr_mpi_minr1 end interface shr_mpi_min interface shr_mpi_max ; module procedure & shr_mpi_maxi0, & shr_mpi_maxi1, & shr_mpi_maxr0, & shr_mpi_maxr1 end interface shr_mpi_max #include <mpif.h> ! mpi library include file !=============================================================================== CONTAINS !=============================================================================== SUBROUTINE shr_mpi_chkerr(rcode,string) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: rcode ! input MPI error code character(*), intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_chkerr) ' character(MPI_MAX_ERROR_STRING) :: lstring integer(SHR_KIND_IN) :: len integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: layer on MPI error checking !------------------------------------------------------------------------------- if (rcode /= MPI_SUCCESS) then call MPI_ERROR_STRING(rcode,lstring,len,ierr) write(s_logunit,*) trim(subName),":",lstring(1:len) call shr_mpi_abort(string,rcode) endif END SUBROUTINE shr_mpi_chkerr !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sendi0(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec ! send value integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_sendi0) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Send a single integer !------------------------------------------------------------------------------- lsize = 1 call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_sendi0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sendi1(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_sendi1) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Send a vector of integers !------------------------------------------------------------------------------- lsize = size(lvec) call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_sendi1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sendr0(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_sendr0) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Send a real scalar !------------------------------------------------------------------------------- lsize = 1 call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_sendr0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sendr1(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_sendr1) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Send a vector of reals !------------------------------------------------------------------------------- lsize = size(lvec) call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_sendr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sendr3(array,pid,tag,comm,string) IMPLICIT none !----- arguments --- real (SHR_KIND_R8), intent(in) :: array(:,:,:) ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_sendr3) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Send a vector of reals !------------------------------------------------------------------------------- lsize = size(array) call MPI_SEND(array,lsize,MPI_REAL8,pid,tag,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_sendr3 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_recvi0(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(out):: lvec ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_recvi0) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Recv a vector of reals !------------------------------------------------------------------------------- lsize = 1 call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_recvi0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_recvi1(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(out):: lvec(:) ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_recvi1) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Recv a vector of reals !------------------------------------------------------------------------------- lsize = size(lvec) call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_recvi1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_recvr0(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(out):: lvec ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_recvr0) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Recv a vector of reals !------------------------------------------------------------------------------- lsize = 1 call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_recvr0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_recvr1(lvec,pid,tag,comm,string) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(out):: lvec(:) ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_recvr1) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Recv a vector of reals !------------------------------------------------------------------------------- lsize = size(lvec) call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_recvr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_recvr3(array,pid,tag,comm,string) IMPLICIT none !----- arguments --- real (SHR_KIND_R8), intent(out):: array(:,:,:) ! in/out local values integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from integer(SHR_KIND_IN), intent(in) :: tag ! tag integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_recvr3) ' integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Recv a vector of reals !------------------------------------------------------------------------------- lsize = size(array) call MPI_RECV(array,lsize,MPI_REAL8,pid,tag,comm,status,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_recvr3 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcasti0(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(inout):: vec ! vector of 1 integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcasti0) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast an integer !------------------------------------------------------------------------------- lsize = 1 lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcasti0 SUBROUTINE shr_mpi_bcasti80(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- integer(SHR_KIND_I8), intent(inout):: vec ! vector of 1 integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcasti0) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast an integer !------------------------------------------------------------------------------- lsize = 1 lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcasti80 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastl0(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- logical, intent(inout):: vec ! vector of 1 integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcastl0) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a logical !------------------------------------------------------------------------------- lsize = 1 lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastl0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastc0(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- character(len=*), intent(inout) :: vec ! vector of 1 integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcastc0) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a character string !------------------------------------------------------------------------------- lsize = len(vec) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastc0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastc1(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- character(len=*), intent(inout) :: vec(:) ! 1D vector integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcastc1) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a character string !------------------------------------------------------------------------------- lsize = size(vec)*len(vec) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastc1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastr0(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(inout):: vec ! vector of 1 integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcastr0) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a real !------------------------------------------------------------------------------- lsize = 1 lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastr0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcasti1(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(inout):: vec(:) ! vector integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcasti1) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a vector of integers !------------------------------------------------------------------------------- lsize = size(vec) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcasti1 SUBROUTINE shr_mpi_bcasti81(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- integer(SHR_KIND_I8), intent(inout):: vec(:) ! vector integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcasti1) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a vector of integers !------------------------------------------------------------------------------- lsize = size(vec) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcasti81 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastl1(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- logical, intent(inout):: vec(:) ! vector of 1 integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcastl1) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a logical !------------------------------------------------------------------------------- lsize = size(vec) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastl1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastr1(vec,comm,string,pebcast) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(inout):: vec(:) ! vector integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local --- character(*),parameter :: subName = '(shr_mpi_bcastr1) ' integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a vector of reals !------------------------------------------------------------------------------- lsize = size(vec) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastr2(arr,comm,string,pebcast) IMPLICIT none !----- arguments ----- real(SHR_KIND_R8), intent(inout):: arr(:,:) ! array, 2d integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local ----- integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !----- formats ----- character(*),parameter :: subName = '(shr_mpi_bcastr2) ' !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a 2d array of reals !------------------------------------------------------------------------------- lsize = size(arr) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastr2 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcasti2(arr,comm,string,pebcast) IMPLICIT none !----- arguments ----- integer, intent(inout):: arr(:,:) ! array, 2d integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local ----- integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !----- formats ----- character(*),parameter :: subName = '(shr_mpi_bcasti2) ' !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a 2d array of integers !------------------------------------------------------------------------------- lsize = size(arr) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(arr,lsize,MPI_INTEGER,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcasti2 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_bcastr3(arr,comm,string,pebcast) IMPLICIT none !----- arguments ----- real(SHR_KIND_R8), intent(inout):: arr(:,:,:) ! array, 3d integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) !----- local ----- integer(SHR_KIND_IN) :: ierr integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: lpebcast !----- formats ----- character(*),parameter :: subName = '(shr_mpi_bcastr3) ' !------------------------------------------------------------------------------- ! PURPOSE: Broadcast a 3d array of reals !------------------------------------------------------------------------------- lsize = size(arr) lpebcast = 0 if (present(pebcast)) lpebcast = pebcast call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_bcastr3 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_gathScatvInitr1(comm, rootid, locArr, glob1DArr, globSize, & displs, string ) IMPLICIT none !----- arguments ----- integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather/scatter on real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array of distributed data real(SHR_KIND_R8), pointer :: glob1DArr(:) ! Global 1D array of gathered data integer(SHR_KIND_IN), pointer :: globSize(:) ! Size of each distributed piece integer(SHR_KIND_IN), pointer :: displs(:) ! Displacements for receive character(*),optional,intent(in) :: string ! message !----- local ----- integer(SHR_KIND_IN) :: npes ! Number of MPI tasks integer(SHR_KIND_IN) :: locSize ! Size of local distributed data integer(SHR_KIND_IN), pointer :: sendSize(:) ! Size to send for initial gather integer(SHR_KIND_IN) :: i ! Index integer(SHR_KIND_IN) :: rank ! Rank of this MPI task integer(SHR_KIND_IN) :: nSize ! Maximum size to send integer(SHR_KIND_IN) :: ierr ! Error code integer(SHR_KIND_IN) :: nSiz1D ! Size of 1D global array integer(SHR_KIND_IN) :: maxSize ! Maximum size !----- formats ----- character(*),parameter :: subName = '(shr_mpi_gathScatvInitr1) ' !------------------------------------------------------------------------------- ! PURPOSE: Setup arrays for a gatherv/scatterv operation !------------------------------------------------------------------------------- locSize = size(locarr) call shr_mpi_commsize( comm, npes ) call shr_mpi_commrank( comm, rank ) allocate( globSize(npes) ) ! ! --- Gather the send global sizes from each MPI task ----------------------- ! allocate( sendSize(npes) ) sendSize(:) = 1 globSize(:) = 1 call MPI_GATHER( locSize, 1, MPI_INTEGER, globSize, sendSize, & MPI_INTEGER, rootid, comm, ierr ) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif deallocate( sendSize ) ! ! --- Prepare the displacement and allocate arrays ------------------------- ! allocate( displs(npes) ) displs(1) = 0 if ( rootid /= rank )then maxSize = 1 globSize = 1 else maxSize = maxval(globSize) end if nsiz1D = min(maxSize,globSize(1)) do i = 2, npes nSize = min(maxSize,globSize(i-1)) displs(i) = displs(i-1) + nSize nsiz1D = nsiz1D + min(maxSize,globSize(i)) end do allocate( glob1DArr(nsiz1D) ) !----- Do some error checking for the root task arrays computed ---- if ( rootid == rank )then if ( nsiz1D /= sum(globSize) ) & call shr_mpi_abort( subName//" : Error, size of global array not right" ) if ( any(displs < 0) .or. any(displs >= nsiz1D) ) & call shr_mpi_abort( subName//" : Error, displacement array not right" ) if ( (displs(npes)+globSize(npes)) /= nsiz1D ) & call shr_mpi_abort( subName//" : Error, displacement array values too big" ) end if END SUBROUTINE shr_mpi_gathScatvInitr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, & comm, string ) IMPLICIT none !----- arguments ----- real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array real(SHR_KIND_R8), intent(inout):: glob1DArr(:) ! Global 1D array to receive in on integer(SHR_KIND_IN), intent(in) :: locSize ! Number to send this PE integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to receive each PE integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for receive integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather on integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local ----- integer(SHR_KIND_IN) :: ierr ! Error code !----- formats ----- character(*),parameter :: subName = '(shr_mpi_gathervr1) ' !------------------------------------------------------------------------------- ! PURPOSE: Gather a 1D array of reals !------------------------------------------------------------------------------- call MPI_GATHERV( locarr, locSize, MPI_REAL8, glob1Darr, globSize, displs, & MPI_REAL8, rootid, comm, ierr ) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_gathervr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, & comm, string ) IMPLICIT none !----- arguments ----- real(SHR_KIND_R8), intent(out) :: locarr(:) ! Local array real(SHR_KIND_R8), intent(in) :: glob1Darr(:) ! Global 1D array to send from integer(SHR_KIND_IN), intent(in) :: locSize ! Number to receive this PE integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to send to each PE integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for send integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to scatter on integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message !----- local ----- integer(SHR_KIND_IN) :: ierr ! Error code !----- formats ----- character(*),parameter :: subName = '(shr_mpi_scattervr1) ' !------------------------------------------------------------------------------- ! PURPOSE: Scatter a 1D array of reals !------------------------------------------------------------------------------- call MPI_SCATTERV( glob1Darr, globSize, displs, MPI_REAL8, locarr, locSize, & MPI_REAL8, rootid, comm, ierr ) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_scattervr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumi0(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumi0) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = 1 gsize = 1 if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumi0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumi1(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumi1) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumi1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumb0(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_I8), intent(in) :: lvec ! in/out local values integer(SHR_KIND_I8), intent(out):: gvec ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumb0) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = 1 gsize = 1 if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumb0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumb1(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_I8), intent(in) :: lvec(:) ! in/out local values integer(SHR_KIND_I8), intent(out):: gvec(:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumb1) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumb1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumr0(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values real(SHR_KIND_R8), intent(out):: gvec ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumr0) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = 1 gsize = 1 if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumr0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumr1(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumr1) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumr2(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec(:,:)! in/out local values real(SHR_KIND_R8), intent(out):: gvec(:,:)! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumr2) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumr2 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_sumr3(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec(:,:,:) ! in/out local values real(SHR_KIND_R8), intent(out):: gvec(:,:,:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_sumr3) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds sum of a distributed vector of values, assume local sum ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_SUM if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_sumr3 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_mini0(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_mini0) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds min of a distributed vector of values, assume local min ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MIN if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = 1 gsize = 1 if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_mini0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_mini1(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_mini1) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds min of a distributed vector of values, assume local min ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MIN if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_mini1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_minr0(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values real(SHR_KIND_R8), intent(out):: gvec ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_minr0) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds min of a distributed vector of values, assume local min ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MIN if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = 1 gsize = 1 if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_minr0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_minr1(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_minr1) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds min of a distributed vector of values, assume local min ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MIN if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_minr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_maxi0(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_maxi0) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds max of a distributed vector of values, assume local max ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MAX if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = 1 gsize = 1 if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_maxi0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_maxi1(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_maxi1) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds max of a distributed vector of values, assume local max ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MAX if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_maxi1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_maxr0(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values real(SHR_KIND_R8), intent(out):: gvec ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_maxr0) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds max of a distributed vector of values, assume local max ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MAX if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = 1 gsize = 1 if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_maxr0 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_maxr1(lvec,gvec,comm,string,all) IMPLICIT none !----- arguments --- real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator character(*),optional,intent(in) :: string ! message logical, optional,intent(in) :: all ! allreduce if true !----- local --- character(*),parameter :: subName = '(shr_mpi_maxr1) ' logical :: lall character(SHR_KIND_CL) :: lstring integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type integer(SHR_KIND_IN) :: lsize integer(SHR_KIND_IN) :: gsize integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: Finds max of a distributed vector of values, assume local max ! already computed !------------------------------------------------------------------------------- reduce_type = MPI_MAX if (present(all)) then lall = all else lall = .false. endif if (present(string)) then lstring = trim(subName)//":"//trim(string) else lstring = trim(subName) endif lsize = size(lvec) gsize = size(gvec) if (lsize /= gsize) then call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) endif if (lall) then call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") else call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") endif END SUBROUTINE shr_mpi_maxr1 !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_commsize(comm,size,string) IMPLICIT none !----- arguments --- integer,intent(in) :: comm integer,intent(out) :: size character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_commsize) ' integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: MPI commsize !------------------------------------------------------------------------------- call MPI_COMM_SIZE(comm,size,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_commsize !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_commrank(comm,rank,string) IMPLICIT none !----- arguments --- integer,intent(in) :: comm integer,intent(out) :: rank character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_commrank) ' integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: MPI commrank !------------------------------------------------------------------------------- call MPI_COMM_RANK(comm,rank,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_commrank !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_initialized(flag,string) IMPLICIT none !----- arguments --- logical,intent(out) :: flag character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_initialized) ' integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: MPI initialized !------------------------------------------------------------------------------- call MPI_INITIALIZED(flag,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_initialized !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_abort(string,rcode) IMPLICIT none !----- arguments --- character(*),optional,intent(in) :: string ! message integer,optional,intent(in) :: rcode ! optional code !----- local --- character(*),parameter :: subName = '(shr_mpi_abort) ' integer(SHR_KIND_IN) :: ierr integer :: rc ! return code !------------------------------------------------------------------------------- ! PURPOSE: MPI abort !------------------------------------------------------------------------------- if ( present(string) .and. present(rcode) ) then write(s_logunit,*) trim(subName),":",trim(string),rcode endif if ( present(rcode) )then rc = rcode else rc = 1001 end if call MPI_ABORT(MPI_COMM_WORLD,rc,ierr) END SUBROUTINE shr_mpi_abort !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_barrier(comm,string) IMPLICIT none !----- arguments --- integer,intent(in) :: comm character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_barrier) ' integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: MPI barrier !------------------------------------------------------------------------------- call MPI_BARRIER(comm,ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_barrier !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_init(string) IMPLICIT none !----- arguments --- character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_init) ' integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: MPI init !------------------------------------------------------------------------------- call MPI_INIT(ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_init !=============================================================================== !=============================================================================== SUBROUTINE shr_mpi_finalize(string) IMPLICIT none !----- arguments --- character(*),optional,intent(in) :: string ! message !----- local --- character(*),parameter :: subName = '(shr_mpi_finalize) ' integer(SHR_KIND_IN) :: ierr !------------------------------------------------------------------------------- ! PURPOSE: MPI finalize !------------------------------------------------------------------------------- call MPI_BARRIER(MPI_COMM_WORLD,ierr) call MPI_FINALIZE(ierr) if (present(string)) then call shr_mpi_chkerr(ierr,subName//trim(string)) else call shr_mpi_chkerr(ierr,subName) endif END SUBROUTINE shr_mpi_finalize !=============================================================================== !=============================================================================== END MODULE shr_mpi_mod