!=======================================================================
! RCS Header:
!   Revision     [$Revision: 1.8.1.2 $]     Named [$Name: release#2_9_b5 $]
!   Last checkin [$Date: 2001/12/10 15:41:17 $]
!   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_RALLTOALLE(
     &   SEND_ARRAY, SEND_MAP, N_ITEMS_TO_SEND, SARR_LEN,
     &   RECV_ARRAY, RECV_MAP, N_ITEMS_TO_RECV, RARR_LEN,
     &   GID, FLAG, ISTAT)
!     ******************************************************************
!     * Purpose:
!     *
!     *  An extended all-to-all permutation of real data between the 
!     *  processors in a group. One processor may send several items 
!     *  of data to another processor. Similarly, a processor may 
!     *  receive several items from another processor. This routine 
!     *  may also be used for 1-to-all, all-to-1 and some-to-some
!     *  permutations.
!     *
!     * Input:
!     *  SEND_ARRAY       - array containing all data to be sent
!     *  SEND_MAP         - a map containing the following information
!     *                     for each of the items to be sent:
!     *                        1 - destination processor
!     *                        2 - base address in SEND_ARRAY
!     *                        3 - number of elements in this item 
!     *                        4 - stride between the elements in 
!     *                            SEND_ARRAY
!     *                        5 - element length
!     *                        6 - base address in the receiving 
!     *                            processor's RECV_ARRAY
!     *                        7 - stride between the elements in the
!     *                            receiving processor's RECV_ARRAY
!     *  N_ITEMS_TO_SEND  - total number of items to be sent from this
!     *                     processor
!     *  SARR_LEN         - length of SEND_ARRAY
!     *  RECV_MAP         - a map containing the following information
!     *                     for each of the items to be received:
!     *                        1 - source processor
!     *                        2 - base address in RECV_ARRAY
!     *                        3 - number of elements in this item 
!     *                        4 - stride between the elements in 
!     *                            RECV_ARRAY
!     *                        5 - element length
!     *                        6 - base address in the sending 
!     *                            processor's SEND_ARRAY
!     *                        7 - stride between the elements in the
!     *                            sending processor's SEND_ARRAY
!     *  N_ITEMS_TO_RECV  - total number of items to be received at this
!     *                     processor
!     *  RARR_LEN         - length of RECV_ARRAY
!     *  GID              - processor group ID
!     *  FLAG             - Not currently used. Expected to be used
!     *                     to characterize the permutation
!     *
!     * Output:
!     *  RECV_ARRAY       - array containing the received data, in
!     *                     the structure defined by RECV_MAP. 
!     *  ISTAT            - Status variable. 0 is OK, refer to the
!     *                     header files for nonzero status codes
!     *
!     ******************************************************************

      IMPLICIT NONE
      INTEGER N_ITEMS_TO_SEND, SARR_LEN, SEND_MAP(7,N_ITEMS_TO_SEND)
      INTEGER N_ITEMS_TO_RECV, RARR_LEN, RECV_MAP(7,N_ITEMS_TO_RECV)
      INTEGER GID, FLAG, ISTAT
      REAL SEND_ARRAY(SARR_LEN), RECV_ARRAY(RARR_LEN)

#if defined(SERIAL_SRC)
      INTEGER I,J,K
#else
      INTEGER MAX_BUF_SIZE
#if !defined(SHM_SRC)
      INTEGER J
#endif
#endif
     
#if defined(SERIAL_SRC)
      DO K=1,N_ITEMS_TO_SEND
        DO J=1,SEND_MAP(3,K)
          DO I=1,SEND_MAP(5,K)
            RECV_ARRAY(I-1+SEND_MAP(6,K)+
     &                 (J-1)*SEND_MAP(7,K))=
     &      SEND_ARRAY(I-1+SEND_MAP(2,K)+
     &                 (J-1)*SEND_MAP(4,K))
          ENDDO
        ENDDO
      ENDDO
#else
      MAX_BUF_SIZE = 0
#if defined(SHM_SRC)
      CALL GCG__RALLTOALLE(
     &   SEND_ARRAY, SEND_MAP, N_ITEMS_TO_SEND, SARR_LEN,
     &   RECV_ARRAY, RECV_MAP, N_ITEMS_TO_RECV, RARR_LEN,
     &   GID, MAX_BUF_SIZE, FLAG, ISTAT)
#else
      DO J = 1, N_ITEMS_TO_SEND
         MAX_BUF_SIZE = MAX(MAX_BUF_SIZE, SEND_MAP(3,J)*SEND_MAP(5,J))
      ENDDO
      DO J = 1, N_ITEMS_TO_RECV
         MAX_BUF_SIZE = MAX(MAX_BUF_SIZE, RECV_MAP(3,J)*RECV_MAP(5,J))
      ENDDO
      CALL GCG_IMAX(1, GID, ISTAT, MAX_BUF_SIZE)
      CALL GCG__RALLTOALLE(
     &   SEND_ARRAY, SEND_MAP, N_ITEMS_TO_SEND, SARR_LEN,
     &   RECV_ARRAY, RECV_MAP, N_ITEMS_TO_RECV, RARR_LEN,
     &   GID, MAX_BUF_SIZE, FLAG, ISTAT)
#endif
#endif

      RETURN
      END


      SUBROUTINE GCG__RALLTOALLE(
     &   SEND_ARRAY, SEND_MAP, N_ITEMS_TO_SEND, SARR_LEN,
     &   RECV_ARRAY, RECV_MAP, N_ITEMS_TO_RECV, RARR_LEN,
     &   GID, MAX_BUF_SIZE, FLAG, ISTAT)

      IMPLICIT NONE
      INTEGER N_ITEMS_TO_SEND, SARR_LEN, SEND_MAP(7,N_ITEMS_TO_SEND)
      INTEGER N_ITEMS_TO_RECV, RARR_LEN, RECV_MAP(7,N_ITEMS_TO_RECV)
      INTEGER GID, MAX_BUF_SIZE, FLAG, ISTAT
      REAL SEND_ARRAY(SARR_LEN), RECV_ARRAY(RARR_LEN)

      INTEGER I, J, K, L, LENGTH, LBASE, LSTRIDE, RBASE, RSTRIDE, TAG

#if !defined(SHM_SRC) 
      REAL CBUF(MAX_BUF_SIZE)
#endif
#if defined(SHM_SRC)
#include "gc__opts_common.h"
      INTEGER GC_ME, ME, NPROC, GC_NPROC
      REAL LARR(RARR_LEN)
      POINTER(PTR,LARR)
#include "gc__nam_flags_common.h"
      INTEGER SENT_FLAG(0:MAX_PROC-1)
#endif
#if defined(MPI_SRC)
      INTEGER ME, GC_ME
#if defined(_CRAYMPP) 
      INTEGER NPROC, GC_NPROC, LOOP
#endif
#include "gc__mpi_common.h"
#endif

      
#if defined(SHM_SRC)
      NPROC = GC_NPROC()
      DO I=0, NPROC-1
        SENT_FLAG(I)=0
      END DO

      IF (SHM_DIR .EQ. GC__SHM_PUT .OR.
     $   (SHM_DIR .EQ. GC__DONTCARE .AND. ISTAT .EQ. GC__SHM_PUT)) THEN
        CALL BARRIER()
        ME = GC_ME()
        PTR = LOC(RECV_ARRAY)
        DO J = 1, N_ITEMS_TO_RECV
          IF(SENT_FLAG(RECV_MAP(1,J)).EQ.0) THEN
            CALL SHMEM_PUT(NAM_FLAG(ME), PTR, 1, RECV_MAP(1,J))
            SENT_FLAG(RECV_MAP(1,J))=1
          ENDIF
        ENDDO
        CALL BARRIER()
        DO J = 1, N_ITEMS_TO_SEND
          PTR = NAM_FLAG(SEND_MAP(1,J))
          LBASE = SEND_MAP(2,J)
          LSTRIDE = SEND_MAP(4,J)
          RBASE = SEND_MAP(6,J)
          RSTRIDE = SEND_MAP(7,J)
          DO I = 1, SEND_MAP(3,J)
            CALL SHMEM_PUT(LARR(RBASE+(I-1)*RSTRIDE),
     &               SEND_ARRAY(LBASE+(I-1)*LSTRIDE),
     &               SEND_MAP(5,J), SEND_MAP(1,J))
          ENDDO
        ENDDO
      ELSE
        CALL BARRIER()
        ME = GC_ME()
        PTR = LOC(SEND_ARRAY)
        DO J = 1, N_ITEMS_TO_SEND
          IF(SENT_FLAG(SEND_MAP(1,J)).EQ.0) THEN
            CALL SHMEM_PUT(NAM_FLAG(ME), PTR, 1, SEND_MAP(1,J))
            SENT_FLAG(SEND_MAP(1,J))=1
          ENDIF
        ENDDO
        CALL BARRIER()
        DO J = 1, N_ITEMS_TO_RECV
          PTR = NAM_FLAG(RECV_MAP(1,J))
          LBASE = RECV_MAP(2,J)
          LSTRIDE = RECV_MAP(4,J)
          RBASE = RECV_MAP(6,J)
          RSTRIDE = RECV_MAP(7,J)
          DO I = 1, RECV_MAP(3,J)
            CALL SHMEM_GET(RECV_ARRAY(LBASE+(I-1)*LSTRIDE),
     &                           LARR(RBASE+(I-1)*RSTRIDE),
     &                     RECV_MAP(5,J), RECV_MAP(1,J))
          ENDDO
        ENDDO
      ENDIF
      DO I=0, NPROC-1
        NAM_FLAG(I)=0
      END DO
      CALL BARRIER()
#endif

      ISTAT = GC__OK

#if defined(MPI_SRC)
      ME = GC_ME()

#if defined(_CRAYMPP)
      NPROC = GC_NPROC()

      DO LOOP = 0, NPROC-1
#endif
      DO J = 1, N_ITEMS_TO_SEND
      
#if defined(_CRAYMPP)
         IF (SEND_MAP(1,J) .EQ. LOOP) THEN
#endif
         LBASE = SEND_MAP(2,J)
         LSTRIDE = SEND_MAP(4,J)
         IF (SEND_MAP(1,J) .EQ. ME) THEN  ! Sending to myself
           DO I=1,SEND_MAP(3,J)
             DO K=1,SEND_MAP(5,J)
               RECV_ARRAY(SEND_MAP(6,J) + (I-1)*SEND_MAP(7,J) +K-1)=
     &         SEND_ARRAY(LBASE + (I-1)*LSTRIDE + K-1)
             ENDDO
           ENDDO
         ELSE ! Sending to another processor
         
         L = 0
         DO I = 1, SEND_MAP(3,J)
            DO K = 1, SEND_MAP(5,J)
               L = L + 1
               CBUF(L) = SEND_ARRAY(LBASE + (I-1)*LSTRIDE + K-1)
            ENDDO
         ENDDO
         LENGTH = SEND_MAP(3,J)*SEND_MAP(5,J)
#if defined(MPI_SRC)
         TAG=MOD(SEND_MAP(6,J),GC__MPI_MAXTAG)
#else
         TAG = SEND_MAP(6,J)
#endif

         CALL GC_RSEND(TAG, LENGTH, SEND_MAP(1,J), ISTAT, CBUF, CBUF)
         IF (ISTAT .NE. 0) RETURN
         
         ENDIF  ! IF (SEND_MAP(1,J) .EQ. ME)
#if defined(_CRAYMPP)
         ENDIF
#endif
      ENDDO

#if defined(_CRAYMPP)
      IF (ME .EQ. LOOP) THEN
#endif
      DO J = 1, N_ITEMS_TO_RECV
         IF (RECV_MAP(1,J) .NE. ME) THEN ! Only receive if the message
                                         ! is not from myself

         LBASE = RECV_MAP(2,J)
         LSTRIDE = RECV_MAP(4,J)
         LENGTH = RECV_MAP(3,J)*RECV_MAP(5,J)
#if defined(MPI_SRC)
         TAG=MOD(RECV_MAP(2,J),GC__MPI_MAXTAG)
#else
         TAG = RECV_MAP(2,J)
#endif
         CALL GC_RRECV(TAG, LENGTH, RECV_MAP(1,J), ISTAT, CBUF, CBUF)
         IF (ISTAT .NE. 0) RETURN
         L = 0
         DO I = 1, RECV_MAP(3,J)
            DO K = 1, RECV_MAP(5,J)
               L = L + 1
               RECV_ARRAY(LBASE + (I-1)*LSTRIDE + K-1) = CBUF(L)
            ENDDO
         ENDDO

         ENDIF ! IF (RECV_MAP(1,J) .NE. ME)

      ENDDO
#if defined(_CRAYMPP)
      ENDIF

      CALL BARRIER()
      ENDDO
#endif
#endif
      
      RETURN
      END