!=======================================================================
! RCS Header:
!   Revision     [$Revision: 1.3.1.2 $]     Named [$Name: release#2_9_b5 $]
!   Last checkin [$Date: 2003/03/14 08:27: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 "gcg_prolog.h"    

      SUBROUTINE GCG_IMAX (LEN, GID, ISTAT, IMAX)
!     ******************************************************************
!     * Purpose:
!     *
!     *  Calculate the integer maximum 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
!     *  IMAX    - array with elements to be added up across the nodes
!     *
!     * Output:
!     *  IMAX    - 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, IMAX(LEN)
      
      INTEGER OFFSET,TOT_LEN,PART_LEN

      OFFSET=0
      TOT_LEN=LEN
            
 1000 CONTINUE
 
      PART_LEN=MIN(TOT_LEN,MAX_COLL)
      
      CALL GCG_IMAX_batch(PART_LEN,GID,ISTAT,IMAX(1+OFFSET))
      
      OFFSET=OFFSET+PART_LEN
      TOT_LEN=TOT_LEN-PART_LEN
      IF (TOT_LEN .GT. 0) GOTO 1000
      
      RETURN
      END
      
      SUBROUTINE GCG_IMAX_batch (LEN, GID, ISTAT, IMAX)
!     ******************************************************************
!     * Purpose:
!     *
!     *  Calculate the integer maximum 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
!     *  IMAX    - array with elements to be added up across the nodes
!     *
!     * Output:
!     *  IMAX    - 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, IMAX(LEN)

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

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

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


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

#if defined(SHM_SRC)
      IF (GID .EQ. GCG__ALLGROUP) THEN
         NPROC = GC_NPROC()
         CALL GC_IMAX(LEN, NPROC, ISTAT, IMAX)
         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 MAX for this GID, we use the simple collect
!     to one (GR_MEM(ILOC)) and broadcast scheme.
      DO I = 1, LEN
         NAM_IWORK(I) = IMAX(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_IWRK, NAM_IWORK(1), 
     &                     LEN, GR_MEM(ILOC+I))
            DO L = 1, LEN
               NAM_IWORK(L) = MAX(NAM_IWORK(L),
     &                                  REDUCE_DATA_IWRK(L))
            ENDDO
         ENDDO
      ENDIF
      CALL GCG__SHMSYNC(GRANK, ILOC, IGID)

      CALL SHMEM_GET(IMAX, NAM_IWORK(1), LEN, GR_MEM(ILOC))

      CALL GCG__SHMSYNC(GRANK, ILOC, IGID)
#endif

#if defined(MPI_SRC)
      IF (GID .EQ. GCG__ALLGROUP) THEN
         IGID = MPI_COMM_WORLD
      ELSE
         IGID = GID
      ENDIF
      DO I = 1,LEN
         REDUCE_DATA_IWRK(I) = IMAX(I)
      ENDDO
#if defined(I_64B)
      CALL MPI_ALLREDUCE(REDUCE_DATA_IWRK, IMAX, LEN, MPI_INTEGER8,
#else
      CALL MPI_ALLREDUCE(REDUCE_DATA_IWRK, IMAX, LEN, MPI_INTEGER,
#endif
     $     MPI_MAX, IGID, ISTAT)
#endif

      RETURN
      END