SUBROUTINE GATHERCOST1(KDIM,PJCCOST,PFJCCOSTG)

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

!     Purpose.
!     --------
!           Build up global spectral cost function arrays.
!           This is done in a reproducible manner.

!**   Interface.
!     ----------
!        *CALL* *GATHERCOST1(KDIM,PJCCOST,PFJCCOSTG)

!        Explicit arguments :
!        --------------------
!        KDIM  ( NF3D+NFD2D or NF3D+NFD2D+NFC2D ) : Dimension
!        PJCCOST(KDIM,NUMP)      : Local contribution to JC
!        PFJCCOSTG(KDIM,0:NVARMAX) : Global version of JC

!        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 Fix and cleaning
!        C. Fischer : 99-06-21 nvarmax for global cost function (aladin)
!        D.Dent     : 00-09-01  MPE to MPL conversion
!        Y.Tremolet : 02-08-07 removed Jb
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB

USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMDIM   , ONLY : NVARMAX  ,NUMP
USE YOMCT0   , ONLY : NPRTRW
USE YOMLAP   , ONLY : MYMS
USE YOMMP    , ONLY : NPRCIDS  ,NUMPP    ,NPTRMS   ,&
 & NALLMS ,MYSETV,MYSETW  
USE YOMTAG   , ONLY : MTAGCOST
USE MPL_MODULE

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KDIM 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PJCCOST(:,:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFJCCOSTG(KDIM,0:NVARMAX) 
! === END OF INTERFACE BLOCK ===
REAL(KIND=JPRB) :: ZCOMSEND(KDIM*NUMP)
REAL(KIND=JPRB) :: ZCOMRECV(KDIM*(NVARMAX+1))

INTEGER(KIND=JPIM) :: IBUFRECV, IBUFSEND, ILREC, IM, IRECV,&
 & IRECVNUMP, IRECVSETA, ISENDSETA,ISEND, ITAG, &
 & JMLOC, JROC,J1,II  
!     INTEGER FUNCTIONS
INTEGER(KIND=JPIM) :: MYSENDSET,MYRECVSET
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "set2pe.intfb.h"

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

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


IBUFSEND=SIZE(ZCOMSEND)
IBUFRECV=SIZE(ZCOMRECV)

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

DO JMLOC=1,NUMP
  IM=MYMS(JMLOC)
  PFJCCOSTG(:,IM)=PJCCOST(:,JMLOC)
ENDDO

!     2.    Send local spectral arrays to all other PEs
!           -------------------------------------------

ITAG=MTAGCOST
II=0
DO JMLOC=1,NUMP
  DO J1=1,KDIM
    II=II+1
    ZCOMSEND(II)=PJCCOST(J1,JMLOC)
  ENDDO
ENDDO
    
CALL GSTATS_BARRIER(777)
DO JROC=1,NPRTRW-1

  CALL GSTATS(668,0)
  ISENDSETA=MYSENDSET(NPRTRW,MYSETW,JROC)
  CALL SET2PE(ISEND,0,0,ISENDSETA,MYSETV)
  CALL MPL_SEND(ZCOMSEND(1:IBUFSEND),KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
   & CDSTRING='GATHERCOST1:')  

  IRECVSETA=MYRECVSET(NPRTRW,MYSETW,JROC)
  CALL SET2PE(IRECV,0,0,IRECVSETA,MYSETV)
  IRECVNUMP=NUMPP(IRECVSETA)
  CALL MPL_RECV(ZCOMRECV(1:IBUFRECV),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
   & KOUNT=ILREC,CDSTRING='GATHERCOST1:')  
  CALL GSTATS(668,1)
  IF (ILREC /= KDIM*IRECVNUMP)&
   & CALL ABOR1('GATHERCOST1: RECEIVED MESSAGE HAS WRONG LENGTH')  

!     3.    Store received contribution in the global arrays
!           ------------------------------------------------

  II=0
  DO JMLOC=1,IRECVNUMP
    IM=NALLMS(NPTRMS(IRECVSETA)-1+JMLOC)
    DO J1=1,KDIM
      II=II+1
      PFJCCOSTG(J1,IM)=ZCOMRECV(II)
    ENDDO
  ENDDO

ENDDO
CALL GSTATS_BARRIER2(777)

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