!=======================================================================
! RCS Header:
!   Revision     [$Revision: 1.8.1.1 $]     Named [$Name: release#2_9_b5 $]
!   Last checkin [$Date: 2001/12/06 10:13:47 $]
!   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 "gc_prolog.h"    

      SUBROUTINE GC_RSUM (LEN, NPROC, ISTAT, SSUM)
!     ******************************************************************
!     * Purpose:
!     *  Calculate the real sum across all processors and distribute
!     *  the result to all the processors.
!     *
!     * Input:
!     *  LEN     - number of elements in message
!     *  NPROC   - number of processors
!     *  SSUM    - array with elements to be added up across the nodes
!     *
!     * Output:
!     *  SSUM    - 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, NPROC, ISTAT
      REAL SSUM(LEN)
      
      INTEGER OFFSET,TOT_LEN,PART_LEN

      OFFSET=0
      TOT_LEN=LEN
            
 1000 CONTINUE
 
      PART_LEN=MIN(TOT_LEN,MAX_COLL)
      
      CALL GC_RSUM_batch(PART_LEN,NPROC,ISTAT,SSUM(1+OFFSET))
      
      OFFSET=OFFSET+PART_LEN
      TOT_LEN=TOT_LEN-PART_LEN
      IF (TOT_LEN .GT. 0) GOTO 1000
      
      RETURN
      END
      
      SUBROUTINE GC_RSUM_batch (LEN, NPROC, ISTAT, SSUM)
!     ******************************************************************
!     * Purpose:
!     *  Calculate the real sum across all processors and distribute
!     *  the result to all the processors.
!     *
!     * Input:
!     *  LEN     - number of elements in message
!     *  NPROC   - number of processors
!     *  SSUM    - array with elements to be added up across the nodes
!     *
!     * Output:
!     *  SSUM    - 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, NPROC, ISTAT
      REAL SSUM(LEN)
#if defined(SHM_SRC)
      INCLUDE 'mpp/shmem.fh'
#include "gc__shm_common.h"
#include "gc__opts_common.h"
#include "gc__nam_common.h"
      INTEGER I
#else
      REAL REDUCE_DATA_WRK(MAX_COLL)
#endif
#if defined(MPI_SRC)
      INCLUDE 'mpif.h'
      INTEGER I
#endif

#if !defined(SERIAL_SRC)
      IF (LEN .GT. MAX_COLL) CALL GC__ERRLIM(0, 'RSUM', 'COLL', 
     $                                       MAX_COLL, LEN)
#endif
      
#if defined(SHM_SRC)
      DO I = 1, LEN
         NAM_RWORK(I) = SSUM(I)
      ENDDO
      CALL BARRIER()
#if defined(FLP_64B)
      CALL SHMEM_REAL8_SUM_TO_ALL(NAM_RWORK,NAM_RWORK,LEN,0,0,NPROC,
     &     REDUCE_DATA_WRK,REDUCE_SYNC_WRK)
#else
      CALL SHMEM_REAL4_SUM_TO_ALL(NAM_RWORK,NAM_RWORK,LEN,0,0,NPROC,
     &     REDUCE_DATA_WRK,REDUCE_SYNC_WRK)
#endif
      DO I = 1, LEN
         SSUM(I) = NAM_RWORK(I)
      ENDDO
      
      
      CALL BARRIER()  
#endif

#if defined(MPI_SRC)
      DO I = 1,LEN
         REDUCE_DATA_WRK(I) = SSUM(I)
      ENDDO
#if defined(FLP_64B)
#if defined(_UNICOS)
      CALL MPI_ALLREDUCE(REDUCE_DATA_WRK, SSUM, LEN, 
     $     MPI_REAL, MPI_SUM, MPI_COMM_WORLD, ISTAT)
#else
      CALL MPI_ALLREDUCE(REDUCE_DATA_WRK, SSUM, LEN, 
     $     MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ISTAT)
#endif
#else
      CALL MPI_ALLREDUCE(REDUCE_DATA_WRK, SSUM, LEN, MPI_REAL, MPI_SUM,
     $     MPI_COMM_WORLD, ISTAT)
#endif
#endif

#if defined(SHM_SRC) || defined(SERIAL_SRC)
      ISTAT = GC__OK
#endif

      RETURN
      END