!=======================================================================
! RCS Header:
!   Revision     [$Revision: 1.3.1.1 $]     Named [$Name: release#2_9_b5 $]
!   Last checkin [$Date: 2001/12/06 10:14:14 $]
!   Author       [$Author: frpb $]
!=======================================================================

! *****************************COPYRIGHT*******************************
! (c) CROWN COPYRIGHT 2001, Met Office, All Rights Reserved.           
! Please refer to Copyright file in top level GCOM directory
!                 for further details
! *****************************COPYRIGHT*******************************

#include "gcg_prolog.h"   

      SUBROUTINE GCG_RSUMR (LEN, GID, ISTAT, RSUM)
!     ******************************************************************
!     * Purpose:
!     *
!     *  Calculate in a reproducible way the real sum across all 
!     *  processors of a group and distribute the result to all members 
!     *  of the group.
!     *
!     * Input:
!     *  LEN     - number of elements in message
!     *  GID     - processor group ID
!     *  RSUM    - array with elements to be added up across the nodes
!     *
!     * Output:
!     *  RSUM    - array containing the sums across the nodes
!     *  ISTAT   - status of rsum. 0 is OK (MPI_SRC only),
!     *            refer to the header files for nonzero status codes
!     *
!     * NOTES:       
!     *
!     ******************************************************************


      IMPLICIT NONE
      INTEGER LEN, GID, ISTAT
      REAL RSUM(LEN)

      INTEGER OFFSET,TOT_LEN,PART_LEN

      OFFSET=0
      TOT_LEN=LEN
            
 1000 CONTINUE
 
      PART_LEN=MIN(TOT_LEN,MAX_COLL)
      
      CALL GCG_RSUMR_batch(PART_LEN,GID,ISTAT,RSUM(1+OFFSET))
      
      OFFSET=OFFSET+PART_LEN
      TOT_LEN=TOT_LEN-PART_LEN
      IF (TOT_LEN .GT. 0) GOTO 1000
      
      RETURN
      END
      

      SUBROUTINE GCG_RSUMR_batch (LEN, GID, ISTAT, RSUM)
!     ******************************************************************
!     * Purpose:
!     *
!     *  Calculate in a reproducible way the real sum across all 
!     *  processors of a group and distribute the result to all members 
!     *  of the group.
!     *
!     * Input:
!     *  LEN     - number of elements in message
!     *  GID     - processor group ID
!     *  RSUM    - array with elements to be added up across the nodes
!     *
!     * Output:
!     *  RSUM    - array containing the sums across the nodes
!     *  ISTAT   - status of rsum. 0 is OK (MPI_SRC only),
!     *            refer to the header files for nonzero status codes
!     *
!     * NOTES:       
!     *
!     ******************************************************************


      IMPLICIT NONE
      INTEGER LEN, GID, ISTAT
      REAL RSUM(LEN)

#if defined(SHM_SRC)
      INCLUDE 'mpp/shmem.fh'
#include "gc__shm_common.h"
#include "gc__nam_common.h"
#else
      REAL REDUCE_DATA_WRK(MAX_COLL)
#endif

#if defined(SHM_SRC)
#include "gcg__grstore_common.h"

      INTEGER L, NPROC, IGID, ILOC, ME, GRANK
#endif
#if defined(MPI_SRC)
      INCLUDE 'mpif.h'
      INTEGER L, NPROC, IGID, GRANK, GSIZE
      INTEGER STATUS(MPI_STATUS_SIZE)
#endif
      INCLUDE 'gc_com.h'
      INTEGER I


      ISTAT = GC__OK
      IF (LEN .GT. MAX_COLL) CALL GCG__ERRLIM(1, 'RSUMR', 'COLL', 
     $                                        MAX_COLL, LEN)

#if defined(SHM_SRC)
      IF (GID .EQ. GCG__ALLGROUP) THEN
         NPROC = GC_NPROC()
         CALL GC_RSUMR(LEN, NPROC, ISTAT, RSUM)
         RETURN
      ENDIF

!---  Verify GID and membership
      IF (GID .GT. 0) THEN
         DO IGID = 1, MAX_GROUP
            IF (GR_ID(IGID) .EQ. GID) THEN
               ILOC = GR_LOC(IGID)
               ME = GC_ME()
               DO I = ILOC, ILOC+GR_SZ(IGID)-1
                  IF (ME .EQ. GR_MEM(I)) THEN
                     GRANK = I - ILOC
                     GOTO 100
                  ENDIF
               ENDDO
            ENDIF
         ENDDO
      ENDIF
      ISTAT = -1
      RETURN
 100  CONTINUE
      

!---  Perform the global SUM for this GID, we use the simple collect
!     to one (GR_MEM(ILOC)) and broadcast scheme.

      DO I = 1, LEN
         NAM_RWORK(I) = RSUM(I)
      ENDDO
      CALL GCG__SHMSYNC(GRANK, ILOC, IGID)
      IF (GRANK .EQ. 0) THEN
         DO I = 1, GR_SZ(IGID)-1
            CALL SHMEM_GET(REDUCE_DATA_WRK, NAM_RWORK(1), 
     &                     LEN, GR_MEM(ILOC+I))
            DO L = 1, LEN
               NAM_RWORK(L) = NAM_RWORK(L) 
     &                              + REDUCE_DATA_WRK(L)
            ENDDO
         ENDDO
      ENDIF
      CALL GCG__SHMSYNC(GRANK, ILOC, IGID)
      
      CALL SHMEM_GET(RSUM, NAM_RWORK(1), LEN, GR_MEM(ILOC))

      CALL GCG__SHMSYNC(GRANK, ILOC, IGID)
#endif

#if defined(MPI_SRC)
      IF (GID .EQ. GCG__ALLGROUP) THEN
         NPROC = GC_NPROC()
         CALL GC_RSUMR(LEN, NPROC, ISTAT, RSUM)
         RETURN
      ELSE
         IGID = GID
         CALL MPI_COMM_RANK(IGID, GRANK, ISTAT)
         CALL MPI_COMM_SIZE(IGID, GSIZE, ISTAT)
         IF (GRANK .NE. 0) THEN
#if defined(BUFFERED_MPI)
            CALL MPI_BSEND(RSUM, GC__RSIZE*LEN, MPI_BYTE, 0,
     $           GCGID__VEC0, IGID, ISTAT)
#else
            CALL MPI_SEND(RSUM, GC__RSIZE*LEN, MPI_BYTE, 0,
     $           GCGID__VEC0, IGID, ISTAT)
#endif
         ELSE
            DO I = 1, GSIZE-1
               CALL MPI_RECV(REDUCE_DATA_WRK, GC__RSIZE*LEN, MPI_BYTE, 
     $              I, GCGID__VEC0, IGID, STATUS, ISTAT)
               DO L = 1,LEN
                  RSUM(L) = RSUM(L) + REDUCE_DATA_WRK(L)
               ENDDO
            ENDDO
         ENDIF
         CALL MPI_BCAST(RSUM, GC__RSIZE*LEN, MPI_BYTE, 0, IGID, ISTAT)
      ENDIF
#endif

      RETURN
      END