SUBROUTINE GATHERCOST2(PFSPALT,PFSPSUR,PSPALTG,PSPSURG)

!**** *GATHERCOST2*  - Gather partitioned spectral cost function contributions

!     Purpose.
!     --------
!           Build up global spectral cost function arrays.
!           The global versions will be available on all PE's.
!           This is done in a reproducible manner.

!**   Interface.
!     ----------
!        *CALL* *GATHERCOST2(PFSPALT,PFSPSUR,PSPALTG,PSPSURG)

!        Explicit arguments :
!        --------------------
!        PFSPALT(NFLEVL,:,NUMP)       : Local part of ALT cost function
!        PFSPSUR(NFD2D,NUMP)          : Local part of SUR cost function
!        PSPALTG(NFLEVG,:,0:NVARMAX)  : Global version of cost function
!        PSPSURG(NFD2D,0:NVARMAX)     : Global version of cost function

!        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-04-04
!        L. Isaksen : 96-07-07
!        C. Fischer : 99-06-21 nvarmax for global cost function (aladin)
!        G. Mozdzynski : 00-08-09 support use by dfi
!        D.Dent     : 00-09-01  MPE to MPL conversion
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB

USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMDIM   , ONLY : NFLEVL   ,NF3D     ,NS3D     ,NFD2D    ,NUMP
USE YOMCT0   , ONLY : NPROC
USE YOMLAP   , ONLY : MYMS
USE YOMMP    , ONLY :   NUMPP    ,NPTRMS   ,&
 & NALLMS   ,NUMLL    ,NPTRLL   ,MYLEVS   ,MYSETV   ,NBSETSP  
USE MPL_MODULE

IMPLICIT NONE

REAL(KIND=JPRB)   ,INTENT(IN)    :: PFSPALT(:,:,:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFSPSUR(:,:) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPALTG(:,:,:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSPSURG(:,:) 
! === END OF INTERFACE BLOCK ===
REAL(KIND=JPRB),ALLOCATABLE :: ZCOMSEND(:)
REAL(KIND=JPRB),ALLOCATABLE :: ZCOMRECV(:)

INTEGER(KIND=JPIM) :: IA, IB, II, ILEV, IM, IRECVLEN, IRECVLEV, IRECVNUMP, IRECVSETA, &
 & IRECVSETB, ISENDLEN, &
 & JFLD, JLEV, JMLOC, JROC ,I3D,IOFF  
INTEGER(KIND=JPIM) :: IRECVCOUNTS(NPROC)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

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

I3D=SIZE(PSPALTG,2)
IF( I3D /= NF3D .AND. I3D /= NS3D )THEN
  CALL ABOR1('GATHERCOST2: NUMBER OF 3D VARIABLES WRONG')
ENDIF

!     1.    Store this PE's cost function contributions in global array

IF(NPROC == 1) THEN

  DO JMLOC=1,NUMP
    IM=MYMS(JMLOC)
    DO JFLD=1,I3D
      DO JLEV=1,NFLEVL
        ILEV=MYLEVS(JLEV)
        PSPALTG(ILEV,JFLD,IM+1)=PFSPALT(JLEV,JFLD,JMLOC)
      ENDDO
    ENDDO
    IF( MYSETV  ==  NBSETSP )THEN
      DO JFLD=1,NFD2D
        PSPSURG(JFLD,IM+1)=PFSPSUR(JFLD,JMLOC)
      ENDDO
    ENDIF
  ENDDO

!     2.    Send local spectral arrays to all other PEs
!           -------------------------------------------
ELSE
  IRECVLEN=0
  DO JROC=1,NPROC
    CALL PE2SET(JROC,IA,IB,IRECVSETA,IRECVSETB)
    IRECVNUMP=NUMPP(IRECVSETA)
    IRECVLEV=NUMLL(IRECVSETB)
    IRECVCOUNTS(JROC)=IRECVLEV*I3D*IRECVNUMP+NFD2D*IRECVNUMP
    IRECVLEN=IRECVLEN+IRECVCOUNTS(JROC)
  ENDDO
  ISENDLEN=NFLEVL*I3D*NUMP+NFD2D*NUMP
  ALLOCATE(ZCOMSEND(ISENDLEN))
  ALLOCATE(ZCOMRECV(IRECVLEN))

  II=0
  DO JMLOC=1,NUMP
    DO JFLD=1,I3D
      DO JLEV=1,NFLEVL
        II=II+1
        ZCOMSEND(II)=PFSPALT(JLEV,JFLD,JMLOC)
      ENDDO
    ENDDO
    IF( MYSETV  ==  NBSETSP )THEN
      DO JFLD=1,NFD2D
        II=II+1
        ZCOMSEND(II)=PFSPSUR(JFLD,JMLOC)
      ENDDO
    ENDIF
  ENDDO

  CALL GSTATS_BARRIER(778)
  CALL GSTATS(611,0)
  CALL MPL_ALLGATHERV(ZCOMSEND,ZCOMRECV,IRECVCOUNTS, &
   & CDSTRING='GATHERCOST2:')  
  CALL GSTATS(611,1)
  CALL GSTATS_BARRIER2(778)

  IOFF=0
  DO JROC=1,NPROC

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

!  Extract received message and place it in the global arrays

    II=IOFF
    DO JMLOC=1,IRECVNUMP
      IM=NALLMS(NPTRMS(IRECVSETA)-1+JMLOC)
      DO JFLD=1,I3D
        DO JLEV=1,IRECVLEV
          ILEV=NPTRLL(IRECVSETB)-1+JLEV
          II=II+1
          PSPALTG(ILEV,JFLD,IM+1)=ZCOMRECV(II)
        ENDDO
      ENDDO
      IF( IRECVSETB == NBSETSP )THEN
        DO JFLD=1,NFD2D
          II=II+1
          PSPSURG(JFLD,IM+1)=ZCOMRECV(II)
        ENDDO
      ENDIF
    ENDDO
    IOFF=IOFF+IRECVCOUNTS(JROC)
  ENDDO

  DEALLOCATE(ZCOMSEND)
  DEALLOCATE(ZCOMRECV)

ENDIF

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