mpl_scatterv_mod.F90

Go to the documentation of this file.

MODULE mpl_scatterv_mod

!**** MPL_SCATTERV Scatter data from specific processor

!     Purpose.
!     --------
!     Scatter data from specific processor
!     The data may be REAL*8,or INTEGER, one dimensional array
!
!**   Interface.
!     ----------
!        CALL MPL_SCATTERV

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

!        Input optional arguments :
!        -------------------------
!           KROOT    -  rank of sending processor (default 1) 
!           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
!           KSENDDISPL -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_SCATTERV aborts when an error is detected.
!     Author.
!     -------
!        Y. Tremolet, M.Hamrud     ECMWF

!     Modifications.
!     --------------
!        Original: 02-03-13
!        M.Hamrud     : 2014-10-22 : Add nonblocking option
!      F. Vana  05-Mar-2015  Support for single precision

! --- *NOT* THREAD SAFE YET ---

!     ----------------------------------------------------------------
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_myrank_mod

IMPLICIT NONE
PRIVATE
PUBLIC mpl_scatterv

INTEGER(KIND=JPIM) :: icomm,iroot,ipl_numproc,irecvcount,isendbufsize,ir,ipl_myrank,imp_type
LOGICAL            :: llabort=.true.
INTEGER(KIND=JPIM) :: ierror,idum
REAL(KIND=JPRD)    :: zdum
REAL(KIND=JPRM)    :: zdum_4
INTEGER(KIND=JPIM)    :: zdum_int

INTERFACE mpl_scatterv
MODULE PROCEDURE mpl_scatterv_real8,mpl_scatterv_real4,mpl_scatterv_integer
END INTERFACE

CONTAINS

SUBROUTINE mpl_scatterv_preamb1(KCOMM,KROOT,KMP_TYPE,KREQUEST)


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



INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KMP_TYPE
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KREQUEST
INTEGER(KIND=JPIM) :: ITID
itid = oml_my_thread()

ierror = 0

IF(mpl_numproc < 1) CALL mpl_message( &
  & cdmessage='MPL_SCATTERV: 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(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
  IF(.NOT.PRESENT(krequest)) CALL mpl_message(cdmessage='MPL_SCATTERV:  KREQUEST MISSING',ldabort=llabort)
ENDIF

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

IF(PRESENT(kroot)) THEN
  iroot=kroot
ELSE
  iroot=1
ENDIF

END SUBROUTINE mpl_scatterv_preamb1

SUBROUTINE mpl_scatterv_preamb2(KSENDCOUNTS,KISENDDISPL,KSENDDISPL,CDSTRING)

INTEGER(KIND=JPIM),INTENT(IN) :: KSENDCOUNTS(:)
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KSENDDISPL(:)
INTEGER(KIND=JPIM),INTENT(OUT) :: KISENDDISPL(:) 
CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING


IF(SIZE(ksendcounts)  < ipl_numproc) THEN
  WRITE(mpl_errunit,*)'MPL_SCATTERV: ERROR KSENDCOUNTS DIMENSION=',&
   & SIZE(ksendcounts)
  CALL mpl_message(cdmessage=&
   & 'MPL_SCATTERV: ERROR KSENDCOUNTS DIMENSION IS WRONG',ldabort=llabort)
ENDIF
IF(irecvcount /= ksendcounts(ipl_myrank)) THEN
  WRITE(mpl_errunit,*)'MPL_SCATTERV: ERROR KSENDCOUNTS INCONSISTENCY ',&
   & irecvcount,ksendcounts(ipl_myrank)
  CALL mpl_message(cdmessage=&
   & 'MPL_SCATTERV: ERROR IRECVCOUNT /= KSENDCOUNTS(MPL_RANK) ',ldabort=llabort)
ENDIF

IF(PRESENT(ksenddispl)) THEN
  kisenddispl(:) = ksenddispl(:)
ELSE
  kisenddispl(:) = 0
  DO ir=2, ipl_numproc
    kisenddispl(ir) = kisenddispl(ir-1) + ksendcounts(ir-1)
  ENDDO
ENDIF
DO ir=1, ipl_numproc
  IF(kisenddispl(ir)+ksendcounts(ir) > isendbufsize) THEN
    WRITE(mpl_errunit,'(A,4I10)')'MPL_SCATTERV:SEND BUFFER TOO SMALL  ', &
     & ir,kisenddispl(ir),ksendcounts(ir),isendbufsize
    CALL mpl_message(cdmessage='MPL_SCATTERV',cdstring=cdstring,ldabort=llabort)
  ENDIF
ENDDO

END SUBROUTINE mpl_scatterv_preamb2
! ------------------------------------------------------------------
SUBROUTINE mpl_scatterv_real8(PRECVBUF,KROOT,PSENDBUF,KSENDCOUNTS,KSENDDISPL,&
 & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_scatterv => mpi_scatterv8
#endif


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

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

CALL mpl_scatterv_preamb1(kcomm,kroot,kmp_type,krequest)
irecvcount=SIZE(precvbuf)

IF(ipl_myrank == iroot) THEN
  IF( .NOT. PRESENT(psendbuf)) CALL mpl_message(&
   & cdmessage='MPL_SCATTERV:SENDBUF MISSING',cdstring=cdstring,&
   & ldabort=llabort)
  isendbufsize=SIZE(psendbuf)
  CALL mpl_scatterv_preamb2(ksendcounts,isenddispl,ksenddispl,cdstring)
  IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
    CALL mpi_scatterv(psendbuf,ksendcounts,isenddispl,int(mpi_real8), &
     & precvbuf,irecvcount,int(mpi_real8),iroot-1,icomm,ierror)
  ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
    CALL mpi_iscatterv(psendbuf,ksendcounts,isenddispl,int(mpi_real8), &
     & precvbuf,irecvcount,int(mpi_real8),iroot-1,icomm,krequest,ierror)
  ENDIF
  IF(lmplstats) THEN
    CALL mpl_sendstats(sum(ksendcounts),int(mpi_real8))
    CALL mpl_recvstats(irecvcount,int(mpi_real8))
  ENDIF
ELSE
  IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
    CALL mpi_scatterv(zdum,1,1,int(mpi_real8), &
     & precvbuf,irecvcount,int(mpi_real8),iroot-1,icomm,ierror)
  ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
    CALL mpi_iscatterv(zdum,1,1,int(mpi_real8), &
     & precvbuf,irecvcount,int(mpi_real8),iroot-1,icomm,krequest,ierror)
  ENDIF
  IF(lmplstats) THEN
    CALL mpl_recvstats(irecvcount,int(mpi_real8))
  ENDIF
ENDIF  

IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF (ierror/=0) CALL mpl_message(ierror,'MPL_SCATTERV',&
   & cdstring,ldabort=llabort)
ENDIF

END SUBROUTINE mpl_scatterv_real8
! ------------------------------------------------------------------
SUBROUTINE mpl_scatterv_real4(PRECVBUF,KROOT,PSENDBUF,KSENDCOUNTS,KSENDDISPL,&
 &  KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_scatterv => mpi_scatterv8
#endif


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

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

CALL mpl_scatterv_preamb1(kcomm,kroot,kmp_type,krequest)
irecvcount=SIZE(precvbuf)

IF(ipl_myrank == iroot) THEN
  IF( .NOT. PRESENT(psendbuf)) CALL mpl_message(&
   & cdmessage='MPL_SCATTERV:SENDBUF MISSING',cdstring=cdstring,&
   & ldabort=llabort)
  isendbufsize=SIZE(psendbuf)
  CALL mpl_scatterv_preamb2(ksendcounts,isenddispl,ksenddispl,cdstring)
  IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
    CALL mpi_scatterv(psendbuf,ksendcounts,isenddispl,int(mpi_real4), &
     & precvbuf,irecvcount,int(mpi_real4),iroot-1,icomm,ierror)
  ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
    CALL mpi_iscatterv(psendbuf,ksendcounts,isenddispl,int(mpi_real4), &
     & precvbuf,irecvcount,int(mpi_real4),iroot-1,icomm,krequest,ierror)
  ENDIF
  IF(lmplstats) THEN
    CALL mpl_sendstats(sum(ksendcounts),int(mpi_real4))
    CALL mpl_recvstats(irecvcount,int(mpi_real4))
  ENDIF
ELSE
  IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
    CALL mpi_scatterv(zdum_4,1,1,int(mpi_real4), &
     & precvbuf,irecvcount,int(mpi_real4),iroot-1,icomm,ierror)
  ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
    CALL mpi_iscatterv(zdum_4,1,1,int(mpi_real4), &
     & precvbuf,irecvcount,int(mpi_real4),iroot-1,icomm,krequest,ierror)
  ENDIF
  IF(lmplstats) THEN
    CALL mpl_recvstats(irecvcount,int(mpi_real4))
  ENDIF
ENDIF  

IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF (ierror/=0) CALL mpl_message(ierror,'MPL_SCATTERV',&
   & cdstring,ldabort=llabort)
ENDIF

END SUBROUTINE mpl_scatterv_real4


SUBROUTINE mpl_scatterv_integer(KRECVBUF,KROOT,KSENDBUF,KSENDCOUNTS,&
 & KSENDDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_scatterv => mpi_scatterv8
#endif


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

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

CALL mpl_scatterv_preamb1(kcomm,kroot,kmp_type,krequest)
irecvcount=SIZE(krecvbuf)

IF(ipl_myrank == iroot) THEN
  IF( .NOT. PRESENT(ksendbuf)) CALL mpl_message(&
   & cdmessage='MPL_SCATTERV:SENDBUF MISSING',cdstring=cdstring,&
   & ldabort=llabort)
  isendbufsize=SIZE(ksendbuf)
  CALL mpl_scatterv_preamb2(ksendcounts,isenddispl,ksenddispl,&
   & cdstring)
  IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
    CALL mpi_scatterv(ksendbuf,ksendcounts,isenddispl,int(mpi_integer), &
     & krecvbuf,irecvcount,int(mpi_integer),iroot-1,icomm,ierror)
  ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
    CALL mpi_iscatterv(ksendbuf,ksendcounts,isenddispl,int(mpi_integer), &
     & krecvbuf,irecvcount,int(mpi_integer),iroot-1,icomm,krequest,ierror)
  ENDIF
  IF(lmplstats) THEN
    CALL mpl_sendstats(sum(ksendcounts),int(mpi_integer))
    CALL mpl_recvstats(irecvcount,int(mpi_integer))
  ENDIF
ELSE
  IF(imp_type == jp_blocking_standard .OR. imp_type == jp_blocking_buffered) THEN
    CALL mpi_scatterv(zdum_int,1,1,int(mpi_integer), &
     & krecvbuf,irecvcount,int(mpi_integer),iroot-1,icomm,ierror)
  ELSEIF(imp_type == jp_non_blocking_standard .OR. imp_type == jp_non_blocking_buffered) THEN
    CALL mpi_iscatterv(zdum_int,1,1,int(mpi_integer), &
     & krecvbuf,irecvcount,int(mpi_integer),iroot-1,icomm,krequest,ierror)
  ENDIF
  IF(lmplstats) THEN
    CALL mpl_recvstats(irecvcount,int(mpi_integer))
  ENDIF
ENDIF  

IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF (ierror/=0) CALL mpl_message(ierror,'MPL_SCATTERV',&
   & cdstring,ldabort=llabort)
ENDIF

END SUBROUTINE mpl_scatterv_integer
! ------------------------------------------------------------------

END MODULE mpl_scatterv_mod