SUBROUTINE DIWRGRFP(KMTAGDISTGP,KNFG,KDIMGP,KGPL,KGPLX,KNFL, &
 & KGPIND,KGPD,KNFD,KFLDOFF,PREALL,PREALG)

!**** *DIWRGRFP* - Routine to send and receive all distributed output 
!                  grid point fields for FULL-POS fields

!     Purpose.
!     --------
!       To transpose a gridpoint-distributed set of fields to a 
!       field-distributed set of global gridpoint fields.

!**   Interface.
!     ----------
!        *CALL* *DIWRGRFP*

!        Explicit arguments :
!        --------------------

!        * INPUT:
!        KMTAGDISTGP: tag for processor communication.
!        KNFG   : global number of fields
!        KDIMGP : first dimension of PREALG (over-dimensioning for gridpoints)
!        KGPL   : number of gridpoints on the processor at output distribution
!        KGPLX  : maximum number of gridpoints (taken among all processors)
!        KNFL   : number of local fields on output distribution
!        KGPIND : KGPIND(i,j)=k mean: i-th gridpoint on j-th processor is k-th
!                 global gp
!        KGPD   : number of gridpoints on each processor
!        KNFD   : number of fields on output distribution for each processor
!        KFLDOFF: offset to the first local field for each processor
!        PREALL : gridpoint-distributed fields

!        * OUTPUT:
!        PREALG : field-distributed gridpoints

!        Implicit arguments :
!        --------------------
!           See modules above.

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

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

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

!     Author.
!     -------
!        Valaparaiso Team at Meteo France

!     Modifications.
!     --------------
!        Original : 98-04    
!        Jean Latour : fusion from osndgpffp and orcvgpffp                   
!                      distribution on several processors
!        R. El Khatib 98-08-20 Cleanups
!        G. Radnoti   98-10-17 rewriting: generalization (gp pointer come from
!         dummy) fewer packets no need of counting messages 
!        R. El Khatib 98-08-20 Cleanups ; only contigus distribution
!        D.Dent     : 00-09-01  MPE to MPL conversion
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        K.Yessad   : 31-Jan-2007: cleaning, tag becomes dummy argument.
!     -------------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMMP    , ONLY : MYPROC    ,NPRCIDS
USE YOMCT0   , ONLY : NPROC
USE MPL_MODULE

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KMTAGDISTGP
INTEGER(KIND=JPIM),INTENT(IN)    :: KNFG 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDIMGP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KGPL 
INTEGER(KIND=JPIM),INTENT(IN)    :: KGPLX 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNFL 
INTEGER(KIND=JPIM),INTENT(IN)    :: KGPIND(KGPLX,NPROC) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KGPD(NPROC) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNFD(NPROC) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFLDOFF(NPROC) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PREALL(KGPL,KNFG) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PREALG(KDIMGP,KNFL) 

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

!     LLWAITRECV : .TRUE. if I wait for a message from processor JROC 
!     LLGDONE    : .TRUE. when all messages have been received.
!     ZBUF       : message
!     LLEXIST    : .TRUE. if the requested message is available
!     LLWAIT     : .FALSE. in order not to wait until the requested message is available

REAL(KIND=JPRB), ALLOCATABLE :: ZBUF(:)

LOGICAL :: LLEXIST, LLGDONE, LLWAIT, LLWAITRECV(NPROC)

INTEGER(KIND=JPIM) :: I, IFLD, ILEN, ILENB, IRCV, ITAG, JFLD, JJ, JROC  

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"

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

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

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

!*     1. PREPARATIONS
!         ------------

IF (KNFL /= KNFD(MYPROC)) THEN
  CALL ABOR1('DIWRGRFP : INTERNAL ERROR KNFL/KNFD')
ENDIF
IF (KGPL /= KGPD(MYPROC)) THEN
  CALL ABOR1('DIWRGRFP : INTERNAL ERROR KGPL/KGPD')
ENDIF
IF (KGPLX < MAXVAL(KGPD)) THEN
  CALL ABOR1('DIWRGRFP : INTERNAL ERROR KGPLX/KGPD')
ENDIF

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

!*     2. LOOP TO SEND GRIDPOINT-DISTRIBUTED FIELDS 
!         -----------------------------------------

IF (KGPL > 0) THEN
  ALLOCATE(ZBUF(KGPL*MAXVAL(KNFD)))
  DO JROC=1,NPROC
    IF (KNFD(JROC) > 0) THEN
      IF (JROC == MYPROC) THEN
        ! local contribution to PREALG : 
        DO JFLD=1,KNFD(JROC)
          IFLD=KFLDOFF(JROC)+JFLD
          DO JJ=1,KGPL
            PREALG(KGPIND(JJ,JROC),JFLD)=PREALL(JJ,IFLD)
          ENDDO
        ENDDO
      ELSE
        ! Send the chunk of fields :                          
        ITAG = KMTAGDISTGP
        ILEN=KGPL*KNFD(JROC)
        DO JFLD=1,KNFD(JROC)
          IFLD=KFLDOFF(JROC)+JFLD
          DO JJ=1,KGPL
            I=JJ+KGPL*(JFLD-1)
            ZBUF(I)=PREALL(JJ,IFLD)
          ENDDO
        ENDDO 
        CALL MPL_SEND(ZBUF(1:ILEN),KDEST=NPRCIDS(JROC),KTAG=ITAG, &
         & CDSTRING='DIWRGRFP:')  
      ENDIF
    ENDIF
  ENDDO
  DEALLOCATE(ZBUF)
ENDIF

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

!*     3. LOOP TO RECEIVE FIELD-DISTRIBUTED GRIDPOINTS 
!         --------------------------------------------

IF (KNFL > 0) THEN
  ALLOCATE(ZBUF(KGPLX*KNFL))
  LLWAITRECV(:)=.TRUE.
  LLWAITRECV(MYPROC)=.FALSE.
  LLGDONE= .FALSE.
  LLWAIT = .FALSE.
  ILENB=KGPLX*KNFL
  DO WHILE (.NOT.LLGDONE)
    LLGDONE=.TRUE.
    DO JROC = 1, NPROC
      IF (KGPD(JROC) > 0.AND.LLWAITRECV(JROC)) THEN
        IRCV = JROC
        ITAG = KMTAGDISTGP
        CALL MPL_PROBE(KSOURCE=IRCV,KTAG=ITAG,LDWAIT=LLWAIT,LDFLAG=LLEXIST, &
         & CDSTRING='DIWRGRFP:')  
        IF (LLEXIST) THEN
          CALL MPL_RECV(ZBUF(1:ILENB),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG, &
           & CDSTRING='DIWRGRFP:')  
          LLWAITRECV(JROC)=.FALSE.
          DO JFLD=1,KNFL
            DO JJ=1,KGPD(JROC)
              I=JJ+KGPD(JROC)*(JFLD-1)
              PREALG(KGPIND(JJ,JROC),JFLD)=ZBUF(I)
            ENDDO
          ENDDO
        ELSE
          LLGDONE=.FALSE.
        ENDIF
      ENDIF
    ENDDO
  ENDDO
  DEALLOCATE(ZBUF)
ENDIF

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

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