SUBROUTINE GATHERT(PSPXTG)

!***** *gathert*  ****  gather diffused temperature values

!     Purpose.
!     --------
!               For the Horizontal Diffusion computations, the 
!               diffused temperature values are needed for all levels
!               for all the wave numbers within a A-set. This routine
!               builds up the diffused temperature fields with all
!               levels on each PE. The communication is simplified
!               because all PE's within an A-set has NUMP waves.

!**   Interface.
!     ----------
!        *call* *GATHERT(PSPXTG)

!        Explicit arguments : PSPXTG - Global diff. temperature field
!        --------------------    ( all levels but local spectral waves)

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

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

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

!     Reference.
!     ----------

!     Author.
!     -------
!        L. Isaksen  *ECMWF*

!     Modifications.
!     --------------
!        Original   : 96-02-02 
!        Modified: 00-09-01 by D.Dent : 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 : NFLEVG   ,NSMAX    ,NUMP
USE YOMCT0   , ONLY : NPRTRV
USE YOMMP    , ONLY : NPRCIDS  ,MYSETV   ,NPTRLL   ,MYSETW
USE YOMTAG   , ONLY : MTAGBRPR
USE YOMLUN   , ONLY : NULOUT
USE MPL_MODULE

IMPLICIT NONE

REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPXTG(NFLEVG,0:NSMAX,2,NUMP) 
INTEGER(KIND=JPIM) :: IBUFLEN, IEXPECT, IFRSTLEV, ILASTLEV,&
 & ILEVELS, ILRECV, IRECV, IRECVSET, &
 & ISEND, ISENDSIZE, JROCB,ISENDSET  

INTERFACE
#include "user_clock.h"
END INTERFACE

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

REAL(KIND=JPRB) :: ZCOMBUF(NFLEVG*(NSMAX-1)*2*NUMP)
!     INTEGER FUNCTIONS
INTEGER(KIND=JPIM) :: MYSENDSET,MYRECVSET
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('GATHERT',0,ZHOOK_HANDLE)
IBUFLEN=SIZE(ZCOMBUF)

DO JROCB=1,NPRTRV-1

!*      Send local part of diffused temperature array. Because PE's
!       belong to the same A-set they all have NUMP wave numbers

  ISENDSET = MYSENDSET(NPRTRV,MYSETV,JROCB)
  CALL SET2PE(ISEND,0,0,MYSETW,ISENDSET)
  
  IFRSTLEV=NPTRLL(MYSETV)
  ILASTLEV=NPTRLL(MYSETV+1)-1
  ISENDSIZE=(ILASTLEV-IFRSTLEV+1)*(NSMAX+1)*2*NUMP
  CALL MPL_SEND(PSPXTG(IFRSTLEV:ILASTLEV,1,1,1),KDEST=NPRCIDS(ISEND), &
   & KTAG=MTAGBRPR+2,CDSTRING='GATHERT:')  
  ILRECV = 0
  IRECVSET = MYRECVSET(NPRTRV,MYSETV,JROCB)
  CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET)

  CALL MPL_RECV(ZCOMBUF(1:IBUFLEN),KSOURCE=NPRCIDS(IRECV),KTAG=MTAGBRPR+2, &
   & KOUNT=ILRECV,CDSTRING='GATHERT:')  

  IFRSTLEV=NPTRLL(IRECVSET)
  ILASTLEV=NPTRLL(IRECVSET+1)-1

  ILEVELS=ILASTLEV-IFRSTLEV+1
  IEXPECT=ILEVELS*(NSMAX+1)*2*NUMP

  IF (ILRECV /= IEXPECT) THEN
    WRITE(NULOUT,*) MYSETV,'receiving',ILRECV,'expected',IEXPECT
    CALL ABOR1('GATHERT: RECEIVED MESSAGE NOT CORRECT LENGTH')
  ENDIF

  PSPXTG(IFRSTLEV:ILASTLEV,:,:,:)=RESHAPE(ZCOMBUF,(/ILEVELS,NSMAX+1,2,NUMP/))

ENDDO

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