!=======================================================================
! RCS Header:
!   Revision     [$Revision: 1.2.2.2 $]     Named [$Name: release#2_9_b5 $]
!   Last checkin [$Date: 2003/03/07 11:04:58 $]
!   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_RVECSUMR(LVL, LSL, LSO, NV, FIELD, GID, 
     $                        ISTAT, SUMS)
!     ******************************************************************
!     * Purpose:
!     *
!     *  Calculate in a reproducible way the real sum of a set of
!     *  vectors across all members of a group, and distribute the
!     *  results to all members of the group.
!     *
!     * Input:
!     *  LVL     - Local Vector Length
!     *  LSL     - Local Sum Length (the length of the subsection to be
!     *            summed for each vector)
!     *  LSO     - Local Sum Offset (element where the summation start)
!     *  NV      - Number of Vectors
!     *  FIELD   - local array containing the vectors to be summed
!     *  GID     - processor group ID
!     *
!     * Output:
!     *  SUMS    - 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 LVL, LSL, LSO, NV, GID, ISTAT
      REAL FIELD(LVL,NV), SUMS(NV)

#if defined(SHM_SRC)
      INCLUDE 'mpp/shmem.fh'
#include "gc__shm_common.h"
#include "gc__opts_common.h"
#include "gcg__grstore_common.h"
#endif
#if defined(SHM_SRC)
#include "gcg__wait_common.h"
#include "gc__nam_common.h"
#endif
#if defined(MPI_SRC)
      INCLUDE 'mpif.h'
      INTEGER STATUS(MPI_STATUS_SIZE)
#endif
      INCLUDE 'gc_com.h'
      INTEGER I, J, ME, GRANK, GSIZE, IGID, ILOC
      INTEGER G0, GPREV, GNEXT, GLAST


      ISTAT = GC__OK

!---  Set all sums to zero
      DO J = 1, NV
         SUMS(J) = 0.0
      ENDDO


#if defined(SHM_SRC)
!---  Verify GID and membership, and find my rank within the group
      IF (GID .EQ. GCG__ALLGROUP) THEN
         GRANK = GC_ME()
         GSIZE = GC_NPROC()
         GLAST = GSIZE - 1
         GPREV = GRANK - 1
         GNEXT = GRANK + 1
         G0 = 0
         IGID = 0
      ELSE IF (GID .GT. GCG__ALLGROUP) 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
         ISTAT = -1
         RETURN
 100     CONTINUE
         GSIZE = GR_SZ(IGID)
         G0 = GR_MEM(ILOC)
         GLAST = GR_MEM(ILOC+GSIZE-1)
         IF (GRANK .GT. 0) GPREV = GR_MEM(ILOC+GRANK-1)
         IF (GRANK .LT. GSIZE-1) GNEXT = GR_MEM(ILOC+GRANK+1)
      ENDIF
      IF (GRANK .EQ. GSIZE-1) GNEXT = G0

      IF (NV .GT. MAX_COLL) CALL GCG__ERRLIM(1, 'RVECSUMR', 'COLL', 
     $                                       MAX_COLL, NV)
      DO J = 1, NV
         NAM_RWORK(J) = 0.0
      ENDDO
#endif      

#if defined(MPI_SRC)
      IF (GID .EQ. GCG__ALLGROUP) THEN
         IGID = MPI_COMM_WORLD
      ELSE
         IGID = GID
      ENDIF
      CALL MPI_COMM_RANK(IGID, GRANK, ISTAT)
      CALL MPI_COMM_SIZE(IGID, GSIZE, ISTAT)
      GLAST = GSIZE - 1
      GPREV = GRANK - 1
      GNEXT = GRANK + 1
#endif

#if defined(SERIAL_SRC)
      DO J = 1, NV
         DO I = LSO, LSL+LSO-1
            SUMS(J) = SUMS(J) + FIELD(I,J)
         ENDDO
      ENDDO
#else

!---  Perform the reproducible global sums for this GID. The first 
!     group member (GRANK = 0) starts. He sums his elements, pass on 
!     the partial results to the next member, and so on until the last 
!     member, which broadcast the sums after adding his contributions.
      IF (GRANK .NE. 0) THEN
#if defined(SHM_SRC)
!DIR$ SUPPRESS GCG_SHM_WAIT
         CALL SHMEM_WAIT(GCG_SHM_WAIT(IGID), GCG_SHM_WAIT_VALUE)
         GCG_SHM_WAIT(IGID) = GCG_SHM_WAIT_VALUE
         IF (NAM_SAFE .EQ. GC__NAM_ALL) THEN
           CALL SHMEM_GET(SUMS, SUMS, NV, GPREV)
         ELSE
           CALL SHMEM_GET(NAM_RWORK(1), NAM_RWORK(1), 
     $          NV, GPREV)
         ENDIF
#endif

#if defined(MPI_SRC)
         CALL MPI_RECV(SUMS, GC__RSIZE*NV, MPI_BYTE, GPREV, GCGID__VEC0,
     $        IGID, STATUS, ISTAT)
#endif
      ENDIF

#if defined(SHM_SRC)
      IF (NAM_SAFE .EQ. GC__NAM_UNA) THEN
        DO J = 1, NV
          DO I = LSO, LSL+LSO-1
            NAM_RWORK(J) = NAM_RWORK(J) + FIELD(I,J)
          ENDDO
        ENDDO
      ELSE
        DO J = 1, NV
          DO I = LSO, LSL+LSO-1
            SUMS(J) = SUMS(J) + FIELD(I,J)
          ENDDO
        ENDDO
      ENDIF
#else
      DO J = 1, NV
!cdir novector
         DO I = LSO, LSL+LSO-1
            SUMS(J) = SUMS(J) + FIELD(I,J)
         ENDDO
      ENDDO
#endif

      IF (GRANK .LT. GSIZE-1) THEN
#if defined(SHM_SRC)
         CALL SHMEM_PUT(GCG_SHM_WAIT(IGID), GCG_SHM_CONT_VALUE,
     $        1, GNEXT)
#endif

#if defined(MPI_SRC)
#if defined(BUFFERED_MPI)
         CALL MPI_BSEND(SUMS, GC__RSIZE*NV, MPI_BYTE, GNEXT, GCGID__VEC0,
     $        IGID, ISTAT)
#else
         CALL MPI_SEND(SUMS, GC__RSIZE*NV, MPI_BYTE, GNEXT, GCGID__VEC0,
     $        IGID, ISTAT)
#endif
#endif
      ENDIF

#if defined(SHM_SRC)
      IF (NAM_SAFE .EQ. GC__NAM_UNA) THEN
        CALL GCG__SHMSYNC(GRANK, ILOC, IGID)
        CALL SHMEM_GET(SUMS, NAM_RWORK(1), NV, GLAST)
        CALL GCG__SHMSYNC(GRANK, ILOC, IGID)
      ENDIF
#else
      IF (GSIZE .GT. 1) THEN
#if defined(MPI_SRC)
         CALL MPI_BCAST(SUMS, GC__RSIZE*NV, MPI_BYTE, GLAST, 
     $        IGID, ISTAT)
#endif
      ENDIF
#endif
#endif

      RETURN
      END