mpl_allgatherv_mod.F90

Go to the documentation of this file.

#ifdef RS6K
@process nocheck
#endif
MODULE mpl_allgatherv_mod

!**** MPL_ALLGATHERV Send data to all processes

!     Purpose.
!     --------
!     Send a message to all processes from a buffer.
!     The data may be REAL*4, REAL*8,or INTEGER, one dimensional array
!                     REAL*4,or REAL*8, two dimensional array
!                  or INTEGER scalar

!**   Interface.
!     ----------
!        CALL MPL_ALLGATHERV

!        Input required arguments :
!        -------------------------
!           PSENDBUF -  buffer containing message
!                       (can be type REAL*4, REAL*8 or INTEGER)
!           PRECVBUF -  buffer containing message
!                       (can be type REAL*4, REAL*8 or INTEGER)
!           KRECVCOUNTS-number of elements received from each process

!        Input optional arguments :
!        -------------------------
!           KCOMM    -  Communicator number if different from MPI_COMM_WORLD 
!                       or from that established as the default 
!                       by an MPL communicator routine
!           KMP_TYPE -  buffering type (see MPL_BUFFER_METHOD)
!                       overrides value provided to MPL_BUFFER_METHOD
!           KRECVDISPL -displacements in PRECVBUF at which to place 
!                       the incoming data
!           CDSTRING -  Character string for ABORT messages
!                       used when KERROR is not provided

!        Output required arguments :
!        -------------------------
!           none

!        Output optional arguments :
!        -------------------------
!           KREQUEST -  Communication request
!                       required when buffering type is non-blocking
!           KERROR   -  return error code.     If not supplied, 
!                       MPL_ALLGATHERV aborts when an error is detected.
!     Author.
!     -------
!        D.Dent, M.Hamrud     ECMWF

!     Modifications.
!     --------------
!        Original:   2000-11-23
!        Threadsafe: 2004-12-15  J.Hague
!        M.Hamrud     : 2014-10-22 : Add nonblocking option
!      F. Vana  05-Mar-2015  Support for single precision

!     ------------------------------------------------------------------

USE parkind1  ,ONLY : jprd, jpim ,jprm

USE mpl_mpif
USE mpl_data_module
USE mpl_stats_mod
USE yommplstats
USE mpl_message_mod
USE mpl_send_mod
USE mpl_recv_mod
USE mpl_barrier_mod

IMPLICIT NONE

PRIVATE

LOGICAL   :: llabort=.true.
LOGICAL   :: llbarrier

INTERFACE mpl_allgatherv
MODULE PROCEDURE mpl_allgatherv_real8,mpl_allgatherv_real4,&
                 mpl_allgatherv_int,  mpl_allgatherv_int_scalar
END INTERFACE

PUBLIC mpl_allgatherv

CONTAINS


SUBROUTINE mpl_allgatherv_real4(PSENDBUF,PRECVBUF,KRECVCOUNTS,KRECVDISPL, &
                            & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_comm_size => mpi_comm_size8, mpi_allgatherv => mpi_allgatherv8
#endif



REAL(KIND=JPRM)            :: PSENDBUF(:)
REAL(KIND=JPRM)            :: PRECVBUF(:)
INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:)
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST
CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING

INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT
INTEGER(KIND=JPIM) :: IMP_TYPE
INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC
INTEGER(KIND=JPIM) :: ITID
INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:)

itid = oml_my_thread()
isendcount = SIZE(psendbuf)
isendcount = max(0,isendcount)  ! Bug? on IBM
irecvcount = SIZE(precvbuf)

!--------- Preamble repeated for threadsafe--------------
IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

IF(icomm == mpl_comm_oml(itid)) THEN
  ipl_numproc = mpl_numproc
ELSE
  CALL mpi_comm_size(icomm,ipl_numproc,ierror)
ENDIF

ALLOCATE(irecvdispl(ipl_numproc))
IF(PRESENT(krecvdispl)) THEN
  irecvdispl(:) = krecvdispl(:)
ELSE
  irecvdispl(:) = 0
  DO ir=2, ipl_numproc
    irecvdispl(ir) = irecvdispl(ir-1) + krecvcounts(ir-1)
  ENDDO
ENDIF
IF(PRESENT(kmp_type)) THEN
  imp_type=kmp_type
ELSE
  imp_type=mpl_method
ENDIF
IF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  IF(.NOT.PRESENT(krequest)) CALL mpl_message(cdmessage='MPL_ALLGATHERV:  KREQUEST MISSING',ldabort=llabort)
ENDIF
!--------- End of Preamble --------------


IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
  CALL mpi_allgatherv(psendbuf(1),isendcount,int(mpi_real4),precvbuf(1),&
   & krecvcounts,irecvdispl,int(mpi_real4),icomm,ierror)
ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  CALL mpi_iallgatherv(psendbuf(1),isendcount,int(mpi_real4),precvbuf(1),&
   & krecvcounts,irecvdispl,int(mpi_real4),icomm,krequest,ierror)
ENDIF
IF(lmplstats) THEN
  CALL mpl_sendstats(isendcount,int(mpi_real4))
  CALL mpl_recvstats(sum(krecvcounts),int(mpi_real4))
ENDIF

IF(mpl_output > 1 )THEN
  WRITE(mpl_unit,'(A,5I8)') ' MPL_ALLGATHERV ',isendcount,irecvcount,icomm
ENDIF
IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF(ierror /= 0 ) CALL mpl_message(ierror,'MPL_ALLGATHERV',&
   & cdstring,ldabort=llabort)
ENDIF
DEALLOCATE(irecvdispl)

END SUBROUTINE mpl_allgatherv_real4

SUBROUTINE mpl_allgatherv_real8(PSENDBUF,PRECVBUF,KRECVCOUNTS,KRECVDISPL, &
                            & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_comm_size => mpi_comm_size8, mpi_allgatherv => mpi_allgatherv8
#endif



REAL(KIND=JPRD)            :: PSENDBUF(:)
REAL(KIND=JPRD)            :: PRECVBUF(:)
INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:)
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST
CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING

INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT
INTEGER(KIND=JPIM) :: IMP_TYPE
INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC
INTEGER(KIND=JPIM) :: ITID,J
INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:)
itid = oml_my_thread()
isendcount = SIZE(psendbuf)
isendcount = max(0,isendcount)  ! Bug? on IBM
irecvcount = SIZE(precvbuf)

!--------- Preamble repeated for threadsafe--------------
IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

IF(icomm == mpl_comm_oml(itid)) THEN
  ipl_numproc = mpl_numproc
ELSE
  CALL mpi_comm_size(icomm,ipl_numproc,ierror)
ENDIF

ALLOCATE(irecvdispl(ipl_numproc))
IF(PRESENT(krecvdispl)) THEN
  DO j=1,min(SIZE(irecvdispl),SIZE(krecvdispl))
    irecvdispl(j) = krecvdispl(j)
  ENDDO
ELSE
  irecvdispl(:) = 0
  DO ir=2, ipl_numproc
    irecvdispl(ir) = irecvdispl(ir-1) + krecvcounts(ir-1)
  ENDDO
ENDIF
IF(PRESENT(kmp_type)) THEN
  imp_type=kmp_type
ELSE
  imp_type=mpl_method
ENDIF
IF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  IF(.NOT.PRESENT(krequest)) CALL mpl_message(cdmessage='MPL_ALLGATHERV:  KREQUEST MISSING',ldabort=llabort)
ENDIF
!!--------- End of Preamble --------------

ierror=0

IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
  CALL mpi_allgatherv(psendbuf(1),isendcount,int(mpi_real8),precvbuf(1),&
   & krecvcounts,irecvdispl,int(mpi_real8),icomm,ierror)
ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  CALL mpi_iallgatherv(psendbuf(1),isendcount,int(mpi_real8),precvbuf(1),&
   & krecvcounts,irecvdispl,int(mpi_real8),icomm,krequest,ierror)
ENDIF

IF(lmplstats) THEN
  CALL mpl_sendstats(isendcount,int(mpi_real8))
  CALL mpl_recvstats(sum(krecvcounts),int(mpi_real8))
ENDIF

IF(mpl_output > 1 )THEN
  WRITE(mpl_unit,'(A,5I8)') ' MPL_ALLGATHERV ',isendcount,irecvcount,icomm
ENDIF
IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF(ierror /= 0 ) CALL mpl_message(ierror,'MPL_ALLGATHERV',cdstring,&
   & ldabort=llabort)
ENDIF
DEALLOCATE(irecvdispl)

END SUBROUTINE mpl_allgatherv_real8

SUBROUTINE mpl_allgatherv_int(KSENDBUF,KRECVBUF,KRECVCOUNTS,KRECVDISPL, &
                            & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_comm_size => mpi_comm_size8, mpi_allgatherv => mpi_allgatherv8
#endif



INTEGER(KIND=JPIM)         :: KSENDBUF(:)
INTEGER(KIND=JPIM)         :: KRECVBUF(:)
INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:)
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST
CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING

INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT
INTEGER(KIND=JPIM) :: IMP_TYPE
INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC
INTEGER(KIND=JPIM) :: ITID
INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:)
itid = oml_my_thread()
isendcount = SIZE(ksendbuf)
isendcount = max(0,isendcount)  ! Bug? on IBM
irecvcount = SIZE(krecvbuf)

!--------- Preamble repeated for threadsafe--------------
IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

IF(icomm == mpl_comm_oml(itid)) THEN
  ipl_numproc = mpl_numproc
ELSE
  CALL mpi_comm_size(icomm,ipl_numproc,ierror)
ENDIF

ALLOCATE(irecvdispl(ipl_numproc))
IF(PRESENT(krecvdispl)) THEN
  irecvdispl(:) = krecvdispl(:)
ELSE
  irecvdispl(:) = 0
  DO ir=2, ipl_numproc
    irecvdispl(ir) = irecvdispl(ir-1) + krecvcounts(ir-1)
  ENDDO
ENDIF
IF(PRESENT(kmp_type)) THEN
  imp_type=kmp_type
ELSE
  imp_type=mpl_method
ENDIF
IF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  IF(.NOT.PRESENT(krequest)) CALL mpl_message(cdmessage='MPL_ALLGATHERV:  KREQUEST MISSING',ldabort=llabort)
ENDIF
!--------- End of Preamble --------------

ierror=0
IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
  CALL mpi_allgatherv(ksendbuf(1),isendcount,int(mpi_integer),krecvbuf(1),&
   & krecvcounts,irecvdispl,int(mpi_integer),icomm,ierror)
ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  CALL mpi_iallgatherv(ksendbuf(1),isendcount,int(mpi_integer),krecvbuf(1),&
   & krecvcounts,irecvdispl,int(mpi_integer),icomm,krequest,ierror)
ENDIF

IF(lmplstats) THEN
  CALL mpl_sendstats(isendcount,int(mpi_integer))
  CALL mpl_recvstats(sum(krecvcounts),int(mpi_integer))
ENDIF

IF(mpl_output > 1 )THEN
  WRITE(mpl_unit,'(A,5I8)') ' MPL_ALLGATHERV ',isendcount,irecvcount,icomm
ENDIF
IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF(ierror /= 0 ) CALL mpl_message(ierror,'MPL_ALLGATHERV',cdstring,ldabort=llabort)
ENDIF
DEALLOCATE(irecvdispl)

END SUBROUTINE mpl_allgatherv_int

SUBROUTINE mpl_allgatherv_int_scalar(KSENDBUF,KRECVBUF,KRECVCOUNTS,KRECVDISPL, &
                            & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_comm_size => mpi_comm_size8, mpi_allgatherv => mpi_allgatherv8
#endif



INTEGER(KIND=JPIM)         :: KSENDBUF
INTEGER(KIND=JPIM)         :: KRECVBUF(:)
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:) ! Not used; for compatibility only
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST
CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING

INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT
INTEGER(KIND=JPIM) :: IMP_TYPE
INTEGER(KIND=JPIM) :: IRECVCOUNTS(mpl_numproc)
INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC
INTEGER(KIND=JPIM) :: ITID
INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:)
itid = oml_my_thread()
isendcount = 1
irecvcount = SIZE(krecvbuf)

irecvcounts(:) = 1
!--------- Preamble repeated for threadsafe--------------
IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

IF(icomm == mpl_comm_oml(itid)) THEN
  ipl_numproc = mpl_numproc
ELSE
  CALL mpi_comm_size(icomm,ipl_numproc,ierror)
ENDIF

ALLOCATE(irecvdispl(ipl_numproc))
IF(PRESENT(krecvdispl)) THEN
  irecvdispl(:) = krecvdispl(:)
ELSE
  irecvdispl(:) = 0
  DO ir=2, ipl_numproc
    irecvdispl(ir) = irecvdispl(ir-1) + irecvcounts(ir-1)
  ENDDO
ENDIF
IF(PRESENT(kmp_type)) THEN
  imp_type=kmp_type
ELSE
  imp_type=mpl_method
ENDIF
IF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  IF(.NOT.PRESENT(krequest)) CALL mpl_message(cdmessage='MPL_ALLGATHERV:  KREQUEST MISSING',ldabort=llabort)
ENDIF
!--------- End of Preamble --------------

IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
  CALL mpi_allgatherv(ksendbuf,isendcount,int(mpi_integer),krecvbuf(1),irecvcounts,&
   &  irecvdispl,int(mpi_integer),icomm,ierror)
ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  CALL mpi_iallgatherv(ksendbuf,isendcount,int(mpi_integer),krecvbuf(1),irecvcounts,&
   &  irecvdispl,int(mpi_integer),icomm,krequest,ierror)
ENDIF
IF(lmplstats) THEN
  CALL mpl_sendstats(isendcount,int(mpi_integer))
  CALL mpl_recvstats(sum(irecvcounts),int(mpi_integer))
ENDIF

IF(mpl_output > 1 )THEN
  WRITE(mpl_unit,'(A,5I8)') ' MPL_ALLGATHERV ',isendcount,irecvcount,icomm
ENDIF
IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF(ierror /= 0 ) CALL mpl_message(ierror,'MPL_ALLGATHERV',cdstring,ldabort=llabort)
ENDIF
DEALLOCATE(irecvdispl)

END SUBROUTINE mpl_allgatherv_int_scalar

END MODULE mpl_allgatherv_mod