SUBROUTINE TRVTOH(KCPEC2,KCPEC2V,KPTRCV,KVMOD,KVMODPP,KUMVMO,&
 & PSPVOR,PSPDIV,PSPT,&
 & PSPVORG,PSPDIVG,PSPTG,KBUFLEN,KSIGN)  

!**** *trvtoh * - Transposition of spectral coefficients
!                 from vertical columns for a subset of the
!                 spectral coefficients.
!                 This routine is needed during NMI computations 
!                 when vertical modes are distributed among PE's.

!     Purpose.
!     --------
!              Transpose data from SPXX arrays to SPxxG arrays.
!              The normal mode calculations require vertical
!              columns of SPT, SPVOR, and SPDIV.

!**   Interface.
!     ----------
!        *call* *TRVTOH(...)

!        Explicit arguments :
!        -------------------- 
!           KCPEC2,KCPEC2V   - dimensions
!           KPTRCV           - spectral colunm offset
!           KVMOD            - total number of vertical modes
!           KVMODPP          - number of vertical modes on this PE
!           KUMVMO           - number of vertical modes on each B-sets 
!           PSPVOR, PSPVORG  - Vorticity
!           PSPDIV, PSPDIVG  - Divergence
!           PSPT, PSPTG      - Temperature
!           KBUFLEN          - Communication buffer length

!           KSIGN  - = +1 FOR TRANSFORMS FROM NORMAL MODE
!                         SPACE TO PHYSICAL SPACE,
!                    = -1 FOR TRANSFORMS FROM PHYSICAL SPACE
!                         TO NORMAL MODE SPACE.

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

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

!     Externals.
!     ----------

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

!     Author.
!     -------
!        MPP Group *ECMWF*

!     Modifications.
!     --------------
!        Original: 95-10-01 
!        L. Isaksen : 96-05-05 More flexible vertical mode handling
!        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 YOMCT0   , ONLY : NPROC    ,NPRTRV
USE YOMMP    , ONLY : NPRCIDS  ,MYSETV   ,NVMODIST, MYSETW
USE YOMTAG   , ONLY : MTAGVH
USE YOMNMIA  , ONLY : NITNMI
USE YOMCT3   , ONLY : NSTEP
USE YOMLUN   , ONLY : NULOUT
USE MPL_MODULE

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KCPEC2
INTEGER(KIND=JPIM),INTENT(IN)    :: KCPEC2V 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPTRCV(NPRTRV+1) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KVMOD
INTEGER(KIND=JPIM),INTENT(IN)    :: KVMODPP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KUMVMO(NPRTRV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPVOR(KCPEC2,KVMODPP) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPDIV(KCPEC2,KVMODPP) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPT(KCPEC2,KVMODPP) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPVORG(KCPEC2V,KVMOD) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPDIVG(KCPEC2V,KVMOD) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPTG(KCPEC2V,KVMOD) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KBUFLEN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSIGN 
! Fields are INput or OUTput depending on KSIGN
REAL(KIND=JPRB) :: ZCOMBUF(KBUFLEN)

INTEGER(KIND=JPIM) ::  IL, ILRECV, INSFREC, IOFF, IPOS, IRECV,&
 & IRECVSET, ISEND, ISENDSET, ITAG, &
 & JL, JLOC, JNVMO, JROC, JSP  

!     INTEGER FUNCTIONS
INTEGER(KIND=JPIM) :: MYSENDSET,MYRECVSET
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

!*       1.    GATHER VERTICAL COLUMNS OF NORMAL MODE COEFFICIENTS
!              ---------------------------------------------------

IF (LHOOK) CALL DR_HOOK('TRVTOH',0,ZHOOK_HANDLE)
IF( KSIGN == +1 )THEN

!  Transpose data treated on local processor

  ITAG=MTAGVH+NITNMI+NSTEP
  IOFF=KPTRCV(MYSETV)-1
  DO JSP=1,KCPEC2V
    DO JLOC=1,KVMODPP
      IL=NVMODIST(JLOC,MYSETV)
      PSPVORG(JSP,IL)=PSPVOR(JSP+IOFF,JLOC)
      PSPDIVG(JSP,IL)=PSPDIV(JSP+IOFF,JLOC)
      PSPTG(JSP,IL)=PSPT(JSP+IOFF,JLOC)
    ENDDO
  ENDDO

!   Communicate with other processors

  DO JROC=1,NPRTRV-1

!   copy data to be sent into communication buffer

    ISENDSET=MYSENDSET(NPRTRV,MYSETV,JROC)
    CALL SET2PE(ISEND,0,0,MYSETW,ISENDSET)
    IPOS=0
    DO JSP=KPTRCV(ISENDSET),KPTRCV(ISENDSET+1)-1
      DO JLOC=1,KVMODPP
        IPOS=IPOS+1
        ZCOMBUF(IPOS)=PSPVOR(JSP,JLOC)
        IPOS=IPOS+1
        ZCOMBUF(IPOS)=PSPDIV(JSP,JLOC)
        IPOS=IPOS+1
        ZCOMBUF(IPOS)=PSPT(JSP,JLOC)
      ENDDO
    ENDDO

    IF( IPOS > 0 )THEN
      IF( IPOS > KBUFLEN ) CALL ABOR1(&
       & 'TRVTOH: MESSAGE LONGER THAN KBUFLEN')  
      CALL MPL_SEND(ZCOMBUF(1:IPOS),KDEST=NPRCIDS(ISEND), &
       & KTAG=ITAG,CDSTRING='TRVTOH:')  
    ENDIF

    IRECVSET=MYRECVSET(NPRTRV,MYSETV,JROC)
    CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET)

    IF( KUMVMO(IRECVSET) > 0.AND.KCPEC2V > 0 )THEN

!*   receive message (if not empty)

      CALL MPL_RECV(ZCOMBUF(1:KBUFLEN),KSOURCE=NPRCIDS(IRECV), &
       & KTAG=ITAG,KOUNT=ILRECV,CDSTRING='TRVTOH:')  

!*   copy data from buffer into global vertical arrays

      IPOS=0
      DO JSP=1,KCPEC2V
        DO JNVMO=1,KUMVMO(IRECVSET)
          IL=NVMODIST(JNVMO,IRECVSET)
          IPOS=IPOS+1
          PSPVORG(JSP,IL)=ZCOMBUF(IPOS)
          IPOS=IPOS+1
          PSPDIVG(JSP,IL)=ZCOMBUF(IPOS)
          IPOS=IPOS+1
          PSPTG(JSP,IL)=ZCOMBUF(IPOS)
        ENDDO
      ENDDO

      IF( ILRECV /= IPOS )THEN
        write(NULOUT,*) mysetv,' receiving ',ilrecv,'expected',ipos
        CALL ABOR1('TRVTOH: RECEIVED MESSAGE NOT CORRECT LENGTH')
      ENDIF
    ENDIF

  ENDDO

! Perform barrier synchronisation to guarantee all processors have
! completed communication

  IF( NPROC > 1 )THEN
    CALL MPl_BARRIER(CDSTRING='TRVTOH:')
  ENDIF

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

!*       2.   SCATTER VERTICAL COLUMNS OF NORMAL MODE COEFFICIENTS
!             ----------------------------------------------------

ELSEIF( KSIGN == -1 )THEN

!  Transpose data treated on local processor

  ITAG=MTAGVH+100+NITNMI+NSTEP
  IOFF=KPTRCV(MYSETV)-1
  DO JSP=1,KCPEC2V
    DO JLOC=1,KVMODPP
      IL=NVMODIST(JLOC,MYSETV)
      PSPVOR(JSP+IOFF,JLOC)=PSPVORG(JSP,IL)
      PSPDIV(JSP+IOFF,JLOC)=PSPDIVG(JSP,IL)
      PSPT(JSP+IOFF,JLOC)=PSPTG(JSP,IL)
    ENDDO
  ENDDO

!   Communicate with other processors

  DO JROC=1,NPRTRV-1

!   copy data to be sent into ZCOMBUF

    ISENDSET=MYSENDSET(NPRTRV,MYSETV,JROC)
    CALL SET2PE(ISEND,0,0,MYSETW,ISENDSET)

!   fill buffer

    IPOS=0
    DO JSP=1,KCPEC2V
      DO JNVMO=1,KUMVMO(ISENDSET)
        IL=NVMODIST(JNVMO,ISENDSET)
        IPOS=IPOS+1
        ZCOMBUF(IPOS)=PSPVORG(JSP,IL)
        IPOS=IPOS+1
        ZCOMBUF(IPOS)=PSPDIVG(JSP,IL)
        IPOS=IPOS+1
        ZCOMBUF(IPOS)=PSPTG(JSP,IL)
      ENDDO
    ENDDO

    IF( IPOS > 0 )THEN
      IF( IPOS > KBUFLEN ) CALL ABOR1(&
       & 'TRVTOH: MESSAGE LONGER THAN KBUFLEN')  
      CALL MPL_SEND(ZCOMBUF(1:IPOS),KDEST=NPRCIDS(ISEND), &
       & KTAG=ITAG,CDSTRING='TRVTOH:')  
    ENDIF

    IRECVSET=MYRECVSET(NPRTRV,MYSETV,JROC)
    CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET)
    
    INSFREC=KPTRCV(IRECVSET+1)-KPTRCV(IRECVSET)
    IF( KUMVMO(MYSETV) > 0.AND.INSFREC > 0 )THEN

!*   receive message (if not empty)

      CALL MPL_RECV(ZCOMBUF(1:KBUFLEN),KSOURCE=NPRCIDS(IRECV),&
       & KTAG=ITAG,KOUNT=ILRECV,CDSTRING='TRVTOH:')  

!*   copy data from buffer into global vertical arrays

      IPOS=0
      DO JSP=KPTRCV(IRECVSET),KPTRCV(IRECVSET+1)-1
        DO JL=1,KVMODPP
          IPOS=IPOS+1
          PSPVOR(JSP,JL)=ZCOMBUF(IPOS)
          IPOS=IPOS+1
          PSPDIV(JSP,JL)=ZCOMBUF(IPOS)
          IPOS=IPOS+1
          PSPT(JSP,JL)=ZCOMBUF(IPOS)
        ENDDO
      ENDDO

      IF( ILRECV /= IPOS )THEN
        CALL ABOR1('TRVTOH: RECEIVED MESSAGE NOT CORRECT LENGTH')
      ENDIF
    ENDIF

  ENDDO

! Perform barrier synchronisation to guarantee all processors have
! completed communication

  IF( NPROC > 1 )THEN
    CALL MPL_BARRIER(CDSTRING='TRVTOH:')
  ENDIF

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

ENDIF

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