mpl_alltoallv_mod.F90

Go to the documentation of this file.

MODULE mpl_alltoallv_mod

!**** MPL_ALLTOALLV - Everyone sends different data to everyone

!     Purpose.
!     --------
!     Interface to MPI_ALLTOALLV
 
!     The data may be REAL*8,or INTEGER

!**   Interface.
!     ----------
!        CALL MPL_ALLTOALLV

!        Input required arguments :
!        -------------------------
!           PSENDBUF -  buffer containing message
!                       (can be type  REAL*8 or INTEGER)
!           PRECVBUF -  buffer containing message
!                       (can be type REAL*8 or INTEGER)
!           KRECVCOUNTS-number of elements received from each process
!           KSENDCOUNTS-number of elements to be sent to 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
!           KRECVDISPL -displacements in PRECVBUF at which to place 
!                       the incoming data
!           KSENDDISPL -displacements in PSENDBUF from which to send
!                       the data
!           KMP_TYPE -  buffering type (see MPL_BUFFER_METHOD)
!                       overrides value provided to MPL_BUFFER_METHOD
!           CDSTRING -  Character string for ABORT messages
!                       used when KERROR is not provided

!        Output optional arguments :
!        -------------------------
!           KREQUEST -  Communication request
!                       required when buffering type is non-blocking
!           KERROR   -  return error code.     If not supplied, 
!                       MPL_ALLTOALLV aborts when an error is detected.

!     Author.
!     -------
!       Y. Tremolet

!     Modifications.
!     --------------
!       Original: 02-03-21
!       Modified : 25-09-02 M.Hamrud - generalize
!      F. Vana  05-Mar-2015  Support for single precision
! ------------------------------------------------------------------

USE parkind1  ,ONLY : jprd, jpim, jpib, jprm

USE mpl_mpif
USE mpl_data_module
USE mpl_message_mod
USE mpl_stats_mod
USE yommplstats

IMPLICIT NONE
PRIVATE

LOGICAL :: llabort=.true.
INTEGER(KIND=JPIM) :: icomm,ierror,ipl_numproc,irecvcount,isendcount,ir,imp_type
LOGICAL :: llscalar

INTERFACE mpl_alltoallv
MODULE PROCEDURE mpl_alltoallv_real8,mpl_alltoallv_integer,mpl_alltoallv_real4
END INTERFACE

PUBLIC mpl_alltoallv

CONTAINS
! ------------------------------------------------------------------

SUBROUTINE mpl_alltoallv_preamb(KSENDCOUNTS,KISENDDISPL,&
 & KRECVCOUNTS,KIRECVDISPL,KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,CDSTRING)


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


INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:),KSENDCOUNTS(:)
INTEGER(KIND=JPIM),INTENT(OUT) :: KISENDDISPL(:),KIRECVDISPL(:)
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KSENDDISPL(:),KRECVDISPL(:),KCOMM,KMP_TYPE
CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING
INTEGER(KIND=JPIM) :: ITID,J
itid = oml_my_thread()
IF(mpl_numproc < 1) CALL mpl_message( &
  & cdmessage='MPL_ALLTOALLV: MPL NOT INITIALISED ',ldabort=llabort)
 
IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

IF(PRESENT(kmp_type)) THEN
  imp_type=kmp_type
ELSE
  imp_type=mpl_method
ENDIF

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

IF(SIZE(krecvcounts)  < ipl_numproc) THEN
  WRITE(mpl_errunit,*)'MPL_ALLTOALLV: ERROR KRECVCOUNTS dimension=',&
   & SIZE(krecvcounts)
  CALL mpl_message(cdmessage=&
   & 'MPL_ALLTOALLV: ERROR KRECVCOUNTS dimension is wrong',ldabort=llabort)
ENDIF

IF(SIZE(ksendcounts)  < ipl_numproc) THEN
  WRITE(mpl_errunit,*)'MPL_ALLTOALLV: ERROR KSENDCOUNTS dimension=',&
   & SIZE(ksendcounts)
  CALL mpl_message(cdmessage=&
   & 'MPL_ALLTOALLV: ERROR KSENDCOUNTS dimension is wrong',ldabort=llabort)
ENDIF

IF(PRESENT(krecvdispl)) THEN
  DO j=1,min(SIZE(krecvdispl),SIZE(kirecvdispl))
    kirecvdispl(j) = krecvdispl(j)
  ENDDO
ELSE
  kirecvdispl(:) = 0
  IF(llscalar) THEN
    DO ir=2, ipl_numproc
      kirecvdispl(ir) = kirecvdispl(ir-1) + 1
    ENDDO
  ELSE
    DO ir=2, ipl_numproc
      kirecvdispl(ir) = kirecvdispl(ir-1) + krecvcounts(ir-1)
    ENDDO
  ENDIF
ENDIF

DO ir=1, ipl_numproc
  IF(kirecvdispl(ir) < 0 .OR. krecvcounts(ir) < 0) THEN
    WRITE(mpl_errunit,'(A,4I10)')'MPL_ALLTOALLV: RECV.. < 0 ',&
     & ir,kirecvdispl(ir),krecvcounts(ir)
    CALL mpl_message(ierror,'MPL_ALLTOALLV',cdstring,ldabort=llabort)
  ENDIF
  IF(kirecvdispl(ir)+krecvcounts(ir) > irecvcount) THEN
    WRITE(mpl_errunit,'(A,4I10)')'MPL_ALLTOALLV:RECV BUFFER TOO SMALL  ', &
     & ir,kirecvdispl(ir),krecvcounts(ir),irecvcount
    CALL mpl_message(ierror,'MPL_ALLTOALLV',cdstring,ldabort=llabort)
  ENDIF
ENDDO

IF(PRESENT(ksenddispl)) THEN
  DO j=1,min(SIZE(ksenddispl),SIZE(kisenddispl))
    kisenddispl(j) = ksenddispl(j)
  ENDDO
ELSE
  kisenddispl(:) = 0
  IF(llscalar) THEN
    DO ir=2, ipl_numproc
      kisenddispl(ir) = kisenddispl(ir-1) + 1
    ENDDO
  ELSE
    DO ir=2, ipl_numproc
      kisenddispl(ir) = kisenddispl(ir-1) + ksendcounts(ir-1)
    ENDDO
  ENDIF
ENDIF
DO ir=1, ipl_numproc
  IF(kisenddispl(ir) < 0 .OR. ksendcounts(ir) < 0) THEN
    WRITE(mpl_errunit,'(A,4I10)')'MPL_ALLTOALLV:SEND.. <0 ',&
     & ir,kisenddispl(ir),ksendcounts(ir)
    CALL mpl_message(ierror,'MPL_ALLTOALLV',cdstring,ldabort=llabort)
  ENDIF
  IF(kisenddispl(ir)+ksendcounts(ir) > isendcount) THEN
    WRITE(mpl_errunit,'(A,4I10)')'MPL_ALLTOALLV:SEND BUFFER TOO SMALL  ', &
     & ir,kisenddispl(ir),ksendcounts(ir),isendcount
    CALL mpl_message(ierror,'MPL_ALLTOALLV',cdstring,ldabort=llabort)
  ENDIF
ENDDO

END SUBROUTINE mpl_alltoallv_preamb

SUBROUTINE mpl_alltoallv_real8(PSENDBUF,KSENDCOUNTS,PRECVBUF,KRECVCOUNTS,&
 &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_alltoallv => mpi_alltoallv8
#endif


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

INTEGER(KIND=JPIM) :: IRECVDISPL(mpl_numproc),ISENDDISPL(mpl_numproc)

isendcount=SIZE(psendbuf)
irecvcount=SIZE(precvbuf)

#ifndef NAG
IF (isendcount > 0) THEN
  IF( (loc(psendbuf(ubound(psendbuf,1))) - loc(psendbuf(lbound(psendbuf,1)))) /= 8_jpib*(isendcount - 1) .AND. &
    & isendcount > 0 ) THEN
    CALL mpl_message(cdmessage='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF

IF (irecvcount > 0) THEN
  IF( (loc(precvbuf(ubound(precvbuf,1))) - loc(precvbuf(lbound(precvbuf,1)))) /= 8_jpib*(irecvcount - 1) .AND. &
    & irecvcount > 0 ) THEN
    CALL mpl_message(cdmessage='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF
#endif

llscalar=.false.

ierror=0
CALL mpl_alltoallv_preamb(ksendcounts,isenddispl,&
 & krecvcounts,irecvdispl,ksenddispl,krecvdispl,kmp_type,kcomm,cdstring)
IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
  CALL mpi_alltoallv(psendbuf(:),ksendcounts,isenddispl,int(mpi_real8), &
   & precvbuf(:),krecvcounts,irecvdispl,int(mpi_real8),icomm,ierror)
ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  IF(.NOT.PRESENT(krequest)) CALL mpl_message(kerror,'MPL_ALLTOALLV',' KREQUEST MISSING',ldabort=llabort)
  CALL mpi_ialltoallv(psendbuf(:),ksendcounts,isenddispl,int(mpi_real8), &
   & precvbuf(:),krecvcounts,irecvdispl,int(mpi_real8),icomm,krequest,ierror)
ELSE
  IF(PRESENT(kerror)) THEN
    ierror=1
  ELSE
    CALL mpl_message(kerror,'MPL_ALLTOALLV',' INVALID METHOD',ldabort=llabort)
  ENDIF
ENDIF

IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF (ierror/=0) CALL mpl_message(ierror,'ERROR IN MPL_ALLTOALLV',&
   &ldabort=llabort)
ENDIF

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

END SUBROUTINE mpl_alltoallv_real8

SUBROUTINE mpl_alltoallv_real4(PSENDBUF,KSENDCOUNTS,PRECVBUF,KRECVCOUNTS,&
 &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_alltoallv => mpi_alltoallv8
#endif


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

INTEGER(KIND=JPIM) :: IRECVDISPL(mpl_numproc),ISENDDISPL(mpl_numproc)

isendcount=SIZE(psendbuf)
irecvcount=SIZE(precvbuf)

#ifndef NAG
IF (isendcount > 0) THEN
  IF( (loc(psendbuf(ubound(psendbuf,1))) - loc(psendbuf(lbound(psendbuf,1)))) /= 4_jpib*(isendcount - 1) ) THEN
    CALL mpl_message(cdmessage='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF

IF (irecvcount > 0) THEN
  IF( (loc(precvbuf(ubound(precvbuf,1))) - loc(precvbuf(lbound(precvbuf,1)))) /= 4_jpib*(irecvcount - 1) ) THEN
    CALL mpl_message(cdmessage='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF
#endif

llscalar=.false.

ierror=0
CALL mpl_alltoallv_preamb(ksendcounts,isenddispl,&
 & krecvcounts,irecvdispl,ksenddispl,krecvdispl,kmp_type,kcomm,cdstring)
IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
  CALL mpi_alltoallv(psendbuf(:),ksendcounts,isenddispl,int(mpi_real4), &
   & precvbuf(:),krecvcounts,irecvdispl,int(mpi_real4),icomm,ierror)
ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  CALL mpi_ialltoallv(psendbuf(:),ksendcounts,isenddispl,int(mpi_real4), &
   & precvbuf(:),krecvcounts,irecvdispl,int(mpi_real4),icomm,krequest,ierror)
ELSE
  IF(PRESENT(kerror)) THEN
    ierror=1
  ELSE
    CALL mpl_message(kerror,'MPL_ALLTOALLV',' INVALID METHOD',ldabort=llabort)
  ENDIF
ENDIF

IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF (ierror/=0) CALL mpl_message(ierror,'ERROR IN MPL_ALLTOALLV',&
   &ldabort=llabort)
ENDIF

IF(lmplstats) THEN
  CALL mpl_sendstats(sum(ksendcounts),int(mpi_real4))
  CALL mpl_recvstats(sum(krecvcounts),int(mpi_real4))
ENDIF

END SUBROUTINE mpl_alltoallv_real4


SUBROUTINE mpl_alltoallv_integer(KSENDBUF,KSENDCOUNTS,KRECVBUF,KRECVCOUNTS,&
 &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_alltoallv => mpi_alltoallv8
#endif


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

INTEGER(KIND=JPIM) :: IRECVDISPL(mpl_numproc),ISENDDISPL(mpl_numproc)

isendcount=SIZE(ksendbuf)
irecvcount=SIZE(krecvbuf)

#ifndef NAG
IF (isendcount > 0) THEN
  IF( (loc(ksendbuf(ubound(ksendbuf,1))) - loc(ksendbuf(lbound(ksendbuf,1)))) /= 4_jpib*(isendcount - 1) ) THEN
    CALL mpl_message(cdmessage='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF

IF (irecvcount > 0) THEN
  IF( (loc(krecvbuf(ubound(krecvbuf,1))) - loc(krecvbuf(lbound(krecvbuf,1)))) /= 4_jpib*(irecvcount - 1) ) THEN
    CALL mpl_message(cdmessage='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF
#endif

llscalar=.false.

ierror=0
CALL mpl_alltoallv_preamb(ksendcounts,isenddispl,&
 & krecvcounts,irecvdispl,ksenddispl,krecvdispl,kmp_type,kcomm,cdstring)
IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
  CALL mpi_alltoallv(ksendbuf(1),ksendcounts,isenddispl,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
  IF(.NOT.PRESENT(krequest)) CALL mpl_message(kerror,'MPL_ALLTOALLV',' KREQUEST MISSING',ldabort=llabort)
  CALL mpi_ialltoallv(ksendbuf(1),ksendcounts,isenddispl,int(mpi_integer), &
   & krecvbuf(1),krecvcounts,irecvdispl,int(mpi_integer),icomm,krequest,ierror)
ELSE
  IF(PRESENT(kerror)) THEN
    ierror=1
  ELSE
    CALL mpl_message(kerror,'MPL_ALLTOALLV',' INVALID METHOD',ldabort=llabort)
  ENDIF
ENDIF

IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF (ierror/=0) CALL mpl_message(ierror,'ERROR IN MPL_ALLTOALLV',&
   &ldabort=llabort)
ENDIF

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

END SUBROUTINE mpl_alltoallv_integer

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

END MODULE mpl_alltoallv_mod