SUBROUTINE GATHERSPA(PGSPA3,PGSPA2,PLSPA3,PLSPA2)

!**** *GATHERSPA*  - Gather partitioned spectral arrays to global form

!     Purpose.
!     --------
!           Gather global versions of SPA3, SPA2 on each PE

!**   Interface.
!     ----------
!        *CALL* *GATHERSPA(PGSPA3,PGSPA2,PLSPA3,PLSPA2)

!        Explicit arguments :
!        --------------------
!        PGSPA3(NFLEVG,NSPEC2G,*) : Global version of SPA3 (output)
!        PGSPA2(NSPEC2G,*)        : Global version of SPA2 (output)
!        PLSPA3(NFLEVG,NSPEC2,*)  : Local version of SPA3 (optional)
!                                      (If not specified, then SPA3 from YOMSP is used)
!        PLSPA2(NSPEC2,*)         : Local version of SPA2 (optional)
!                                      (If not specified, then SPA2 from YOMSP is used)

!        Implicit arguments :
!        --------------------
!        None

!     Method.
!     -------
!        See documentation

!     Externals.
!     ----------
!        MPL_SEND, MPL_RECV  -  communication interface

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        Lars Isaksen *ECMWF*

!     Modifications.
!     --------------
!        Original  : 96-02-02
!     Erik Andersson 98-07-06 : TOVS control variable
!        D.Dent     : 00-09-01  MPE to MPL conversion
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Fisher      17-Mar-2004 Wavelet Jb
!        O.Spaniel     22-02-2006 correction
!        M.Fisher      01-10-2008 non-buffered sends, and remove TOVS cv

!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMDIM   , ONLY : NFLEVL   ,NFLEVLMX ,NSMAX    ,&
 & NSPEC2   ,NSPEC2MX ,NUMP  
USE YOMCT0   , ONLY : NPROC
USE YOMSP    , ONLY : SPA3     ,SPA2
USE YOMLAP   , ONLY : NASM0    ,NASM0G   ,MYMS
USE YOMMP    , ONLY : NPRCIDS  ,MYPROC   ,NUMPP    ,&
 & NPTRMS   ,NALLMS   ,NUMLL    ,NPTRLL   ,MYLEVS   ,&
 & NPSURF   ,NPSP  
USE YOMTAG   , ONLY : MTAGCAIN
USE YOMLUN   , ONLY : NULERR
USE MPL_MODULE, ONLY : MPL_SEND, MPL_RECV, MPL_WAIT, JP_NON_BLOCKING_STANDARD

IMPLICIT NONE

REAL(KIND=JPRB)   ,INTENT(OUT)          :: PGSPA3(:,:,:) 
REAL(KIND=JPRB)   ,INTENT(OUT)          :: PGSPA2(:,:) 
REAL(KIND=JPRB)   ,INTENT(IN), OPTIONAL, TARGET :: PLSPA3(:,:,:)
REAL(KIND=JPRB)   ,INTENT(IN), OPTIONAL, TARGET :: PLSPA2(:,:)

REAL(KIND=JPRB),ALLOCATABLE :: ZSPAS(:)
REAL(KIND=JPRB),ALLOCATABLE :: ZSPAR(:)
REAL(KIND=JPRB), POINTER :: ZSPA3(:,:,:), ZSPA2(:,:)

INTEGER(KIND=JPIM) :: ISPINDX(NSPEC2MX),ISENDREQ(NPROC)

INTEGER(KIND=JPIM) :: ILEN,IBUFLEN,I,IM,ISP,ITAG,IRECV,ILREC &
 & ,IRECVID,IRECVSETA,IRECVSETB,IRECVLEV,IRECVNUMP,ISPEC2RCV &
 & ,ILEV,ISPG,ISEND,IA,IB,JFIE,JMLOC,JIR,JLEV,JROC,JN,JMN,IS3D,IS2D

REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "pe2set.intfb.h"
!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('GATHERSPA',0,ZHOOK_HANDLE)

IS3D=SIZE(PGSPA3,3)
IS2D=SIZE(PGSPA2,2)

ILEN=(NFLEVL*IS3D+IS2D*NPSP)*NSPEC2
IBUFLEN=(NFLEVLMX*IS3D+IS2D)*NSPEC2MX
ALLOCATE(ZSPAS(ILEN))
ALLOCATE(ZSPAR(IBUFLEN))

IF (PRESENT(PLSPA3)) THEN
  ZSPA3 => PLSPA3
ELSE
  ZSPA3 => SPA3
ENDIF

IF (PRESENT(PLSPA2)) THEN
  ZSPA2 => PLSPA2
ELSE
  ZSPA2 => SPA2
ENDIF

IF (SIZE(ZSPA3,3)/=IS3D .OR. (NPSP==1 .AND. SIZE(ZSPA2,2)/=IS2D)) THEN
  WRITE (NULERR,*) 'DIMENSIONS OF INPUT AND OUTPUT ARRAYS DO NOT MATCH:'
  WRITE (NULERR,*) 'SIZE(PGSPA3,3)=',IS3D,' SIZE(ZSPA3,3)=',SIZE(ZSPA3,3)
  WRITE (NULERR,*) 'SIZE(PGSPA2,2)=',IS2D,' SIZE(ZSPA2,2)=',SIZE(ZSPA2,2)
  CALL ABOR1 ('DIMENSIONS OF INPUT AND OUTPUT ARRAYS DO NOT MATCH')
ENDIF

!     1.    Store local SPA3 and SPA2 in a communication buffer
!           ---------------------------------------------------

I=0
DO JFIE=1,IS3D
  DO JMLOC=1,NUMP
    IM=MYMS(JMLOC)
    DO JIR=0,1
      DO JN=IM,NSMAX
        ISP=NASM0(IM)+(JN-IM)*2+JIR
        DO JLEV=1,NFLEVL
          I=I+1
          ZSPAS(I)=ZSPA3(JLEV,ISP,JFIE)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
ENDDO

IF (NPSP == 1) THEN
  DO JFIE=1,IS2D
    DO JMLOC=1,NUMP
      IM=MYMS(JMLOC)
      DO JIR=0,1
        DO JN=IM,NSMAX
          I=I+1
          ISP=NASM0(IM)+(JN-IM)*2+JIR
          ZSPAS(I)=ZSPA2(ISP,JFIE)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
ENDIF

IF (I /= ILEN) CALL ABOR1(' GATHERSPA : ERROR IN ILEN')
!     ------------------------------------------------------------------

!     2.    Send local spectral arrays to all PEs
!           --------------------------------------------------------
ITAG=MTAGCAIN
DO JROC=1,NPROC-1
  ISEND=MOD(MYPROC+JROC-1,NPROC)+1
  CALL MPL_SEND(ZSPAS(1:ILEN),KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
   &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC),&
   & CDSTRING='GATHERSPA:')  
ENDDO

!     2.1   Receive local arrays and store in global array

DO JROC=1,NPROC-1
  IRECV=MOD(-JROC-1+MYPROC+NPROC,NPROC)+1
  CALL MPL_RECV(ZSPAR(1:IBUFLEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
   & KOUNT=ILREC,KFROM=IRECVID,CDSTRING='GATHERSPA:')  

  CALL PE2SET(IRECVID,IA,IB,IRECVSETA,IRECVSETB)
  IRECVLEV=NUMLL(IRECVSETB)
  IRECVNUMP=NUMPP(IRECVSETA)

  ISPEC2RCV=0
  DO JMLOC=1,IRECVNUMP
    IM=NALLMS(NPTRMS(IRECVSETA)-1+JMLOC)
    DO JIR=0,1
      DO JN=IM,NSMAX
        ISPEC2RCV=ISPEC2RCV+1
        ISPINDX(ISPEC2RCV)=NASM0G(IM)+(JN-IM)*2+JIR
      ENDDO
    ENDDO
  ENDDO
  IF (ILREC /= (IRECVLEV*IS3D+IS2D*NPSURF(IRECVSETB))*ISPEC2RCV) THEN
    WRITE(NULERR,*) ' Lengths: ',ILREC &
     & ,(IRECVLEV*IS3D+IS2D*NPSURF(IRECVSETB))*ISPEC2RCV, IRECV
    CALL ABOR1(' GATHERSPA : RECEIVED MESSAGE WRONG LENGTH')
  ENDIF

  I=0
  DO JFIE=1,IS3D
    DO JMN=1,ISPEC2RCV
      DO JLEV=1,IRECVLEV
        ILEV=NPTRLL(IRECVSETB)-1+JLEV
        I=I+1
        PGSPA3(ILEV,ISPINDX(JMN),JFIE)=ZSPAR(I)
      ENDDO
    ENDDO
  ENDDO
  IF (NPSURF(IRECVSETB) == 1) THEN
    DO JFIE=1,IS2D
      DO JMN=1,ISPEC2RCV
        I=I+1
        PGSPA2(ISPINDX(JMN),JFIE)=ZSPAR(I)
      ENDDO
    ENDDO
  ENDIF

ENDDO

!    2.2    Wait for all the message passing to complete
DO JROC=1,NPROC-1
  CALL MPL_WAIT(ZSPAS,KREQUEST=ISENDREQ(JROC),CDSTRING='GATHERSPA:: WAIT')
ENDDO

!     ------------------------------------------------------------------

!     3.    Store this PEs spectral arrays in global version
!           ------------------------------------------------

DO JFIE=1,IS3D
  DO JLEV=1,NFLEVL
    ILEV=MYLEVS(JLEV)
    DO JMLOC=1,NUMP
      IM=MYMS(JMLOC)
      DO JIR=0,1
        DO JN=IM,NSMAX
          ISPG=NASM0G(IM)+(JN-IM)*2+JIR
          ISP =NASM0 (IM)+(JN-IM)*2+JIR
          PGSPA3(ILEV,ISPG,JFIE)=ZSPA3(JLEV,ISP,JFIE)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
ENDDO

IF (NPSP == 1) THEN
  DO JFIE=1,IS2D
    DO JMLOC=1,NUMP
      IM=MYMS(JMLOC)
      DO JIR=0,1
        DO JN=IM,NSMAX
          ISPG=NASM0G(IM)+(JN-IM)*2+JIR
          ISP =NASM0 (IM)+(JN-IM)*2+JIR
          PGSPA2(ISPG,JFIE)=ZSPA2(ISP,JFIE)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
ENDIF

IF(ALLOCATED(ZSPAS))DEALLOCATE(ZSPAS)
IF(ALLOCATED(ZSPAR))DEALLOCATE(ZSPAR)

IF (LHOOK) CALL DR_HOOK('GATHERSPA',1,ZHOOK_HANDLE)
END SUBROUTINE GATHERSPA
