mpl_allreduce_mod.F90

Go to the documentation of this file.

MODULE mpl_allreduce_mod

!**** MPL_ALLREDUCE Perform collective communication

!     Purpose.
!     --------
!     To calculate global MIN,MAX,SUM or IEOR and return result to all processes.
!     The data may be REAL*4, REAL*8,or INTEGER, one dimensional array or scalar

!**   Interface.
!     ----------
!        CALL MPL_ALLREDUCE

!        Input required arguments :
!        -------------------------
!           PSENDBUF -  buffer containing message to be collectively communicated
!                       (can be type REAL*4, REAL*8 or INTEGER) (also output)
!           CDOPER   -  Global operation to be performed : 'MAX', 'MIN', 'SUM' or 'IEOR'

!        Input optional arguments :
!        -------------------------
!           LDREPROD -  Reproducibility flag for SUMmation-operator.
!                       Meaningful only for REAL-numbers.
!                       Three modes (applicable for REAL-number only):
!                       1) Not provided at all (the default) ==> MPL_ABORT
!                       2) Provided and .TRUE. ==> Use home-written binary tree
!                          No MPI_ALLREDUCE used.
!                       3) Provided, but .FALSE. ==> let MPI_ALLREDUCE do the summation.
!           KCOMM    -  Communicator number if different from MPI_COMM_WORLD 
!                       or from that established as the default 
!                       by an MPL communicator routine
!                       the incoming data
!           CDSTRING -  Character string for ABORT messages
!                       used when KERROR is not provided

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

!        Output optional arguments :
!        -------------------------
!           KERROR   -  return error code.     If not supplied, 
!                       MPL_ALLREDUCE aborts when an error is detected.
!     Author.
!     -------
!        D.Dent, M.Hamrud, S.Saarinen     ECMWF

!     Modifications.
!     --------------
!        Original: 2001-02-02
!      F. Vana  05-Mar-2015  Support for single precision

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

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

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_wait_mod
USE mpl_broadcast_mod

IMPLICIT NONE

PRIVATE

LOGICAL :: llabort=.true.

INTERFACE mpl_allreduce
MODULE PROCEDURE mpl_allreduce_real8, mpl_allreduce_real4, mpl_allreduce_int, &
  mpl_allreduce_int8, &
  mpl_allreduce_real8_scalar, mpl_allreduce_real4_scalar, &
  mpl_allreduce_int_scalar, mpl_allreduce_int8_scalar
END INTERFACE

PUBLIC mpl_allreduce

CONTAINS

SUBROUTINE mpl_allreduce_int_scalar(KSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)

INTEGER(KIND=JPIM),INTENT(INOUT)     :: KSENDBUF
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
INTEGER(KIND=JPIM) ISENDBUF(1)

isendbuf(1) = ksendbuf
CALL mpl_allreduce(isendbuf,cdoper,ldreprod,kcomm,kerror,cdstring)
ksendbuf = isendbuf(1)

END SUBROUTINE mpl_allreduce_int_scalar

SUBROUTINE mpl_allreduce_int8_scalar(KSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)
INTEGER(KIND=JPIB),INTENT(INOUT)     :: KSENDBUF
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
INTEGER(KIND=JPIB) ISENDBUF(1)

isendbuf(1) = ksendbuf
CALL mpl_allreduce(isendbuf,cdoper,ldreprod,kcomm,kerror,cdstring)
ksendbuf = isendbuf(1)

END SUBROUTINE mpl_allreduce_int8_scalar



SUBROUTINE mpl_allreduce_real8_scalar(PSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)
REAL(KIND=JPRD),INTENT(INOUT)     :: PSENDBUF
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
REAL(KIND=JPRD) ZSENDBUF(1)

zsendbuf(1) = psendbuf
CALL mpl_allreduce(zsendbuf,cdoper,ldreprod,kcomm,kerror,cdstring)
psendbuf = zsendbuf(1)

END SUBROUTINE mpl_allreduce_real8_scalar


SUBROUTINE mpl_allreduce_real4_scalar(PSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)
REAL(KIND=JPRM),INTENT(INOUT)     :: PSENDBUF
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
REAL(KIND=JPRM) ZSENDBUF(1)

zsendbuf(1) = psendbuf
CALL mpl_allreduce(zsendbuf,cdoper,ldreprod,kcomm,kerror,cdstring)
psendbuf = zsendbuf(1)

END SUBROUTINE mpl_allreduce_real4_scalar


SUBROUTINE mpl_allreduce_int(KSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)

#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_allreduce => mpi_allreduce8
#endif

INTEGER(KIND=JPIM),INTENT(INOUT)     :: KSENDBUF(:)
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
INTEGER(KIND=JPIM) :: IRECVBUF(size(ksendbuf))
INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER
INTEGER(KIND=JPIM) :: ITID
itid = oml_my_thread()
ierror = 0
IF(mpl_numproc < 1) CALL mpl_message( &
  & cdmessage='MPL_ALLREDUCE: MPL NOT INITIALISED ',ldabort=llabort) 

IF(cdoper(1:3) == 'MAX' .OR. cdoper(1:3) == 'max' ) THEN
  ioper = mpi_max
ELSEIF(cdoper(1:3) == 'MIN' .OR. cdoper(1:3) == 'min' ) THEN
  ioper = mpi_min
ELSEIF(cdoper(1:3) == 'SUM' .OR. cdoper(1:3) == 'sum' ) THEN
  ioper = mpi_sum
ELSEIF(cdoper(1:4) == 'IEOR' .OR. cdoper(1:4) == 'ieor' ) THEN
  ioper = mpi_bxor
ELSEIF(cdoper(1:4) == 'XOR' .OR. cdoper(1:4) == 'xor' ) THEN
  ioper = mpi_bxor
ELSE
  CALL mpl_message(ierror,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',&
   & cdstring,ldabort=llabort)
ENDIF

IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

isendcount = SIZE(ksendbuf)

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

IF ( mpl_numproc > 1 ) &
CALL mpi_allreduce(ksendbuf,irecvbuf,isendcount,int(mpi_integer), &
                &  ioper,icomm,ierror)

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

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

IF ( mpl_numproc > 1 ) &
ksendbuf(:) = irecvbuf(:)

END SUBROUTINE mpl_allreduce_int

SUBROUTINE mpl_allreduce_int8(KSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)
INTEGER(KIND=JPIB),INTENT(INOUT)     :: KSENDBUF(:)
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
INTEGER(KIND=JPIB) :: IRECVBUF(size(ksendbuf))
INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER
INTEGER(KIND=JPIM) :: ITID
ierror = 0
itid = oml_my_thread()
IF(mpl_numproc < 1) CALL mpl_message( &
  & cdmessage='MPL_ALLREDUCE: MPL NOT INITIALISED ',ldabort=llabort) 

IF(cdoper(1:3) == 'MAX' .OR. cdoper(1:3) == 'max' ) THEN
  ioper = mpi_max
ELSEIF(cdoper(1:3) == 'MIN' .OR. cdoper(1:3) == 'min' ) THEN
  ioper = mpi_min
ELSEIF(cdoper(1:3) == 'SUM' .OR. cdoper(1:3) == 'sum' ) THEN
  ioper = mpi_sum
ELSEIF(cdoper(1:4) == 'IEOR' .OR. cdoper(1:4) == 'ieor' ) THEN
  ioper = mpi_bxor
ELSEIF(cdoper(1:4) == 'XOR' .OR. cdoper(1:4) == 'xor' ) THEN
  ioper = mpi_bxor
ELSE
  CALL mpl_message(ierror,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',&
   & cdstring,ldabort=llabort)
ENDIF

IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

isendcount = SIZE(ksendbuf)
#ifndef NAG
IF (isendcount > 0) THEN
  IF( (loc(ksendbuf(ubound(ksendbuf,1)))-loc(ksendbuf(lbound(ksendbuf,1)))) /= 8_jpib*(isendcount - 1) ) THEN
    CALL mpl_message(cdmessage='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF
#endif

IF ( mpl_numproc > 1 ) &
CALL mpi_allreduce(ksendbuf,irecvbuf,isendcount,mpi_integer8, &
                &  ioper,icomm,ierror)

IF(lmplstats) THEN
  CALL mpl_sendstats(isendcount,int(mpi_integer8))
  CALL mpl_recvstats(isendcount,int(mpi_integer8))
ENDIF

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

IF ( mpl_numproc > 1 ) &
ksendbuf(:) = irecvbuf(:)

END SUBROUTINE mpl_allreduce_int8


SUBROUTINE mpl_allreduce_real8(PSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_allreduce => mpi_allreduce8
#endif

REAL(KIND=JPRD),INTENT(INOUT)        :: PSENDBUF(:)
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
REAL(KIND=JPRD)            :: ZRECVBUF(size(psendbuf))
INTEGER(KIND=JPIM) ITAG, ICOUNT
LOGICAL LLREPRODSUM
INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER
INTEGER(KIND=JPIM) :: IP2,II,IHALF,JSTAGE,ISEND,IRECV,IMSENT
INTEGER(KIND=JPIM) :: ISREQ(mpl_numproc)
INTEGER(KIND=JPIM) :: ITID
ierror = 0
itid = oml_my_thread()
llreprodsum = .false.

IF(mpl_numproc < 1) CALL mpl_message( &
  & cdmessage='MPL_ALLREDUCE: MPL NOT INITIALISED ',ldabort=llabort) 

IF(cdoper(1:3) == 'MAX' .OR. cdoper(1:3) == 'max' ) THEN
  ioper = mpi_max
ELSEIF(cdoper(1:3) == 'MIN' .OR. cdoper(1:3) == 'min' ) THEN
  ioper = mpi_min
ELSEIF(cdoper(1:3) == 'SUM' .OR. cdoper(1:3) == 'sum' ) THEN
  ioper = mpi_sum
  IF (PRESENT(ldreprod)) THEN
    llreprodsum = ldreprod
  ELSE
    CALL mpl_message(ierror,&
     & 'MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',&
     & cdstring,ldabort=llabort)
  ENDIF
ELSE
  CALL mpl_message(ierror,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',&
   & cdstring,ldabort=llabort)
ENDIF

IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

isendcount = SIZE(psendbuf)
#ifndef NAG
IF (isendcount > 0) THEN
  IF( (loc(psendbuf(ubound(psendbuf,1)))-loc(psendbuf(lbound(psendbuf,1)))) /= 8_jpib*(isendcount - 1) ) THEN
    CALL mpl_message(cdmessage='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF
#endif

IF (llreprodsum) THEN
!-- Near reproducible summation (independent of number of threads)

  ip2=0
  DO
    ip2=ip2+1
    IF(2**ip2 >= mpl_numproc) EXIT
  ENDDO

  imsent=0
  DO jstage=ip2,1,-1
!    WRITE(0,*) 'STAGE ',JSTAGE
    itag  = 2001+jstage
    ii    = 2**jstage
    ihalf = ii/2
    isend = mpl_rank - ihalf
    IF(isend > 0 .AND. mpl_rank <= ii) THEN
      imsent=imsent+1
      CALL mpl_send(psendbuf,kdest=isend,kcomm=icomm,ktag=itag,kerror=ierror,&
       &kmp_type=jp_non_blocking_standard,krequest=isreq(imsent),cdstring='MPLS_SEND')
!      write(0,*) 'I SEND TO ',MPL_RANK,ISEND
    ENDIF
    irecv=mpl_rank + ihalf
    IF(irecv <=mpl_numproc .AND. mpl_rank <= ihalf) THEN
      CALL mpl_recv(zrecvbuf,ksource=irecv,kcomm=icomm,ktag=itag,&
       &kerror=ierror,kount=icount)
!      write(0,*) 'I RECV FROM ',MPL_RANK,IRECV
      psendbuf(:) = psendbuf(:) + zrecvbuf(:)
    ENDIF
  ENDDO
  IF(imsent > 0) THEN
    CALL mpl_wait(psendbuf,krequest=isreq(1:imsent),cdstring='MPLS_SEND')
  ENDIF
  IF (mpl_rank == 1) THEN
    zrecvbuf(:) = psendbuf(:)
  ENDIF
!  write(0,*) 'enter broadcast '
  CALL mpl_broadcast(zrecvbuf,ktag=itag,kcomm=icomm,kroot=1,kerror=ierror)
!  write(0,*) 'exit broadcast '

!!$  IMSENT=0
!!$  DO JSTAGE=1,IP2
!!$    ITAG = 2001+JSTAGE
!!$    WRITE(0,*) 'STAGE BACK  ',JSTAGE
!!$    II = 2**JSTAGE
!!$    IHALF = II/2
!!$    ISEND=MPL_RANK + IHALF
!!$    IF(ISEND <=MPL_NUMPROC .AND. MPL_RANK <= IHALF) THEN
!!$      IMSENT=IMSENT+1
!!$      CALL MPL_SEND(PSENDBUF,KDEST=ISEND,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,&
!!$       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISREQ(IMSENT),CDSTRING='MPLS_SEND')
!!$      WRITE(0,*) 'I SEND BACK TO ',MPL_RANK,ISEND
!!$    ENDIF
!!$    IRECV=MPL_RANK - IHALF
!!$    IF(IRECV > 0 .AND. MPL_RANK <= II) THEN
!!$      WRITE(0,*) 'I RECV BACK FROM ',MPL_RANK,IRECV
!!$      CALL MPL_RECV(ZRECVBUF,KSOURCE=IRECV,KCOMM=ICOMM,KTAG=ITAG,&
!!$       &KERROR=IERROR,KOUNT=ICOUNT)
!!$    ENDIF
!!$  ENDDO
!!$  IF(IMSENT > 0) THEN
!!$    CALL MPL_WAIT(PSENDBUF,KREQUEST=ISREQ(1:IMSENT),CDSTRING='MPLS_SEND')
!!$  ENDIF
  
ELSE  
  IF ( mpl_numproc > 1 ) &
  CALL mpi_allreduce(psendbuf,zrecvbuf,isendcount,int(mpi_real8), &
                  &  ioper,icomm,ierror)

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

ENDIF

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

IF ( mpl_numproc > 1 ) &
psendbuf(:) = zrecvbuf(:)

END SUBROUTINE mpl_allreduce_real8


SUBROUTINE mpl_allreduce_real4(PSENDBUF,CDOPER,LDREPROD, &
                            & KCOMM,KERROR,CDSTRING)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_allreduce => mpi_allreduce8
#endif

REAL(KIND=JPRM),INTENT(INOUT)        :: PSENDBUF(:)
CHARACTER(LEN=*),INTENT(IN)    :: CDOPER
LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD
INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING
REAL(KIND=JPRM)            :: ZRECVBUF(size(psendbuf))
INTEGER(KIND=JPIM) IPROC, ITAG, ICOUNT
LOGICAL LLREPRODSUM
INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER
INTEGER(KIND=JPIM) :: ITID
ierror = 0
itid = oml_my_thread()
llreprodsum = .false.

IF(mpl_numproc < 1) CALL mpl_message( &
  & cdmessage='MPL_ALLREDUCE: MPL NOT INITIALISED ',ldabort=llabort) 

IF(cdoper(1:3) == 'MAX' .OR. cdoper(1:3) == 'max' ) THEN
  ioper = mpi_max
ELSEIF(cdoper(1:3) == 'MIN' .OR. cdoper(1:3) == 'min' ) THEN
  ioper = mpi_min
ELSEIF(cdoper(1:3) == 'SUM' .OR. cdoper(1:3) == 'sum' ) THEN
  ioper = mpi_sum
  IF (PRESENT(ldreprod)) THEN
    llreprodsum = ldreprod
  ELSE
    CALL mpl_message(ierror,&
     & 'MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',&
     & cdstring,ldabort=llabort)
  ENDIF
ELSE
  CALL mpl_message(ierror,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',&
   & cdstring,ldabort=llabort)
ENDIF

IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF

isendcount = SIZE(psendbuf)
#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_ALLREDUCE: BUFFER NOT CONTIGUOUS ',ldabort=llabort)
  ENDIF
ENDIF
#endif

IF (llreprodsum) THEN
!-- Near reproducible summation
  itag = 2001
  IF (mpl_rank == 1) THEN
    DO iproc=2,mpl_numproc
      CALL mpl_recv(zrecvbuf,ksource=iproc,kcomm=icomm,ktag=itag,&
        &kerror=ierror,kount=icount)
      IF (icount /= isendcount) THEN
        WRITE(mpl_errunit,'(A,I10,A,I6,A,I10)')&
        & 'MPL_ALLREDUCE: RECEIVED UNEXPECTED NUMBER OF ELEMENTS ', &
        & icount,' FROM PROC ',iproc,'. EXPECTED=',isendcount
        CALL mpl_message(ierror,'MPL_ALLREDUCE',cdstring,ldabort=llabort)
      ENDIF
      psendbuf(:) = psendbuf(:) + zrecvbuf(:)
    ENDDO
    zrecvbuf(:) = psendbuf(:)
  ELSE
    CALL mpl_send(psendbuf,kdest=1,kcomm=icomm,ktag=itag,kerror=ierror,&
      &kmp_type=jp_blocking_standard,cdstring='MPLS_SEND')
  ENDIF
  itag = itag + 1
  CALL mpl_broadcast(zrecvbuf,ktag=itag,kcomm=icomm,kroot=1,kerror=ierror)
ELSE  
  IF ( mpl_numproc > 1 ) &
  CALL mpi_allreduce(psendbuf,zrecvbuf,isendcount,int(mpi_real4), &
                  &  ioper,icomm,ierror)

  IF(lmplstats) THEN
    CALL mpl_sendstats(isendcount,int(mpi_real4))
    CALL mpl_recvstats(isendcount,int(mpi_real4))
  ENDIF

ENDIF

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

IF ( mpl_numproc > 1 ) &
psendbuf(:) = zrecvbuf(:)

END SUBROUTINE mpl_allreduce_real4

END MODULE mpl_allreduce_mod