SUBROUTINE GATHERTC(KLEN,KDIM,PIN,KOWNI,POUT,KOWNO)

!**** SUBROUTINE GATHERTC - TIME CORR. OBS. ERRORS MESSGE PASSING

!     HEIKKI JARVINEN and ERIK ANDERSSON,  ECMWF        13/OCT/1997

!*    PURPOSE
!     -------

!       COMMUNICATE THE RELEVENT PARTS OF THE TC-ARRAYS.

!**   INTERFACE
!     ---------

!     ***CALL COMTC(KLEN,KDIM,PIN,KOWNI,POUT,KOWNO)
!     WHERE KLEN  = LENGTH OF ARRAYS
!           KDIM  = SECOND DIMENSION
!           PIN   = INPUT ARRAY
!           KOWNI = OWNERSHIP ON INPUT
!           POUT  = OUTPUT ARRAY
!           KOWNO = OWNERSHIP ON OUTPUT

!        GATHERTC IS CALLED BY COMTC

!**   EXTERNALS
!     ---------
!        MPL_BARRIER
!        MPL_RECV
!        MPL_SEND
!        ABOR1

!*    METHOD
!     ------
!     EACH PE SENDS THE INFORMATION IT HAS GOT, AS INDICATED BY KOWNI.
!     A GLOBAL VIEW IS BUILT ON PE NUMBER 1.
!     PE 1 SENDS TO EACH PE ONLY THOSE PARTS OF THE ARRAY THAT WILL
!     BE NEEDED ON EACH PE, AS INDICATED BY KOWNO.

!**   MODIFICATIONS
!     -------------

!        D.Dent     : 00-09-01  MPE to MPL conversion
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB

USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMCT0   , ONLY : NPROC
USE YOMLUN   , ONLY : NULERR   
USE YOMMP    , ONLY :   MYPROC
USE YOMANCS  , ONLY : RMDI
USE MPL_MODULE

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDIM 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PIN(KLEN,KDIM) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOWNI(KLEN) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: POUT(KLEN,KDIM) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOWNO(KLEN) 
REAL(KIND=JPRB) :: ZBUFS(KLEN*KDIM),ZBUFR(KLEN*KDIM)
INTEGER(KIND=JPIM) :: ICOUNTS(NPROC),ICC(NPROC)

INTEGER(KIND=JPIM) :: IC,JIPR,J,JC,IOFF
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

!        0.       PREPARATIONS
!                 ------------

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

!        1.       BUILD GLOBAL VIEW ON PE1
!                 ------------------------

!*          1.1   RECEIVE LOCAL CONTRIBUTIONS AT PE1

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

  CALL GSTATS_BARRIER(770)

ICOUNTS(:)=0
IC=0
CALL GSTATS(1864,0)
DO J=1,KDIM
  DO JC=1,KLEN
    ICOUNTS(KOWNI(JC)) = ICOUNTS(KOWNI(JC))+1
    IF(KOWNI(JC) == MYPROC) THEN
      IC=IC+1
      ZBUFS(IC)=PIN(JC,J)
    ENDIF
  ENDDO
ENDDO
CALL GSTATS(1864,1)

CALL GSTATS(605,0)
CALL MPL_GATHERV(ZBUFS(1:IC),KROOT=1,KRECVCOUNTS=ICOUNTS,&
 & PRECVBUF=ZBUFR,CDSTRING='GATHERTC:')  
CALL GSTATS(605,1)

CALL GSTATS(1825,0)
IF(MYPROC == 1) THEN
  ICC(1)=0
  DO JIPR=2,NPROC
    ICC(JIPR)=ICC(JIPR-1)+ICOUNTS(JIPR-1)
  ENDDO
  DO J=1,KDIM
    DO JC=1,KLEN
      IC=ICC(KOWNI(JC))+1
      PIN(JC,J) = ZBUFR(IC)
      ICC(KOWNI(JC))=IC
    ENDDO
  ENDDO
  IOFF=0
  DO JIPR=1,NPROC
    IF(ICC(JIPR)-IOFF /= ICOUNTS(JIPR)) THEN
      WRITE(NULERR,*)' GATHERTC:JIPR, ICC(JIPR),IOFF,ICOUNTS(JIPR) ',&
       & JIPR, ICC(JIPR),IOFF,ICOUNTS(JIPR)  
      CALL ABOR1('GATHERTC: ERROR UNPACK 1')
    ENDIF
    IOFF=IOFF+ICOUNTS(JIPR)
  ENDDO

!*          1.2   CHECK THAT NOTHING IS MISSING FROM GLOBAL VIEW ON PE1

  IF(ANY(PIN(:,:) == RMDI)) THEN
    WRITE(NULERR,*) ' GATHERTC: SOME OF PIN IS MISSING! '&
     & ,COUNT(PIN(:,:) == RMDI),SIZE(PIN)  
    CALL ABOR1('GATHERTC: MISSING IN PIN')
  ENDIF

ENDIF
!*
!     ------------------------------------------------------------------

!        2.       SEND RELEVANT BITS TO OTHER PEs
!                 -------------------------------

!*          2.2    SCATTER THE OUTPUT ARRAYS FROM PE1

ICOUNTS(:)=0
DO J=1,KDIM
  DO JC=1,KLEN
    ICOUNTS(KOWNO(JC)) = ICOUNTS(KOWNO(JC))+1
  ENDDO
ENDDO

IF(MYPROC == 1) THEN
  ICC(1)=0
  DO JIPR=2,NPROC
    ICC(JIPR)=ICC(JIPR-1)+ICOUNTS(JIPR-1)
  ENDDO
  DO J=1,KDIM
    DO JC=1,KLEN
      IC=ICC(KOWNO(JC))+1
      ZBUFS(IC)=PIN(JC,J)
      ICC(KOWNO(JC))=IC
    ENDDO
  ENDDO
  IOFF=0
  DO JIPR=1,NPROC
    IF(ICC(JIPR)-IOFF /= ICOUNTS(JIPR)) THEN
      WRITE(NULERR,*)' GATHERTC:JIPR, ICC(JIPR),IOFF,ICOUNTS(JIPR) ',&
       & JIPR, ICC(JIPR),IOFF,ICOUNTS(JIPR)  
      CALL ABOR1('GATHERTC: ERROR PACK 1')
    ENDIF
    IOFF=IOFF+ICOUNTS(JIPR)
  ENDDO
ENDIF
CALL GSTATS(1825,1)

IF(NPROC > 1) THEN
  CALL GSTATS(606,0)
  CALL MPL_SCATTERV(ZBUFR(1:ICOUNTS(MYPROC)),KROOT=1,&
   & PSENDBUF=ZBUFS,KSENDCOUNTS=ICOUNTS,&
   & CDSTRING='GATHERTC:')  
  CALL GSTATS(606,1)
ELSE
  IC=ICOUNTS(1)
  ZBUFR(1:IC)=ZBUFS(1:IC)
ENDIF

!*          2.4    UNPACK OUTPUT ARRAYS 

IC=0
DO J=1,KDIM
  DO JC=1,KLEN
    IF(KOWNO(JC) == MYPROC) THEN
      IC=IC+1
      POUT(JC,J)=ZBUFR(IC)
    ENDIF
  ENDDO
ENDDO

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