SUBROUTINE SUFPRFPBUF

!**** *SUFPRFPBUF*  - INITIALIZE BUFFER RFPBUF, WHICH CONTAINS THE THE OUTPUT
!                   CLIMATOLOGY AND GEOMETRY

!     PURPOSE.
!     --------
!       READ OUTPUT CLIMATOLOGY, COPY GEOMETRY THEN FILL BUFFER
!       DM-environment is the one of arrival geometry.

!**   INTERFACE.
!     ----------
!       *CALL* *SUFPRFPBUF*

!        EXPLICIT ARGUMENTS
!        --------------------
!          None

!        IMPLICIT ARGUMENTS
!        --------------------
!        See lower #include.

!     METHOD.
!     -------
!        SEE DOCUMENTATION

!     EXTERNALS.
!     ----------

!     REFERENCE.
!     ----------
!        ECMWF Research Department documentation of the IFS
!        Documentation about FULL-POS.

!     AUTHOR.
!     -------
!        RYAD EL KHATIB *METEO-FRANCE*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 94-04-08
!        Modified by K. YESSAD and Ryad EL KHATIB (MARCH 1997): 
!          - optimisations.
!          - parallelisation of FULL-POS.
!          - RFPCORR is replaced by RFPMXZ. 
!        K.YESSAD : (AUGUST 1997):
!          - cleaning for cy18: corrections of false comments.
!        Modified by V. SARAVANE and Ryad EL KHATIB (OCT 1997):
!          - make tests on ZDIFMAX DM-local and not DM-global, removal of
!            useless communications between processors.
!        R. El Khatib : 98-03-18 Interpolated orography not pre-computed
!        R. El Khatib : 98-03-18 No pre-interpolations
!        G. Radnoti   : 98-09-26 Reading ezone
!        R. El Khatib : 98-10-07 Simplified scanning ; no interpolated fields
!        R. El Khatib : 01-08-07 Pruning options
!        R. El Khatib : 02-21-20 Fullpos B-level distribution + remove IO scheme
!        R. El Khatib : 03-01-29 Remove SM aspects.
!        R. El Khatib : 03-04-17 Fullpos improvments
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!        K. Yessad    : 31-01-2007 Cleanings + use DISGRIDFP.
!     ------------------------------------------------------------------

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

USE YOMLUN   , ONLY : NULOUT
USE YOMFPC   , ONLY : NFPCLI
USE YOMFPG   , ONLY : RFPGM    ,RFPNORX  ,RFPNORY  ,NFPRGPG  ,NFPRGPL  ,&
 & NFPRGPLX ,LFPEZO  
USE YOMFPSC2 , ONLY : NFPBLOCS ,NFPROMA  ,NFPSTART ,NFPEND   ,NFPSORT
USE YOMRFPDS , ONLY : MFPVSO   ,NFPVSO   ,NRFPOS   ,MFPGMO   ,MFPGNXO  ,&
 & MFPGNYO  
USE YOMRFPB  , ONLY : NLENRFPB ,RFPBUF   ,NSTARFPB ,NELENRFP ,REFPBUF  , &
 & NESTARFP  
USE YOMCT0   , ONLY : NPROC    ,LARPEGEF ,LALLOPR
USE YOMMP    , ONLY : MYPROC   ,NSTRIN
USE YOMFPEZO , ONLY : NFPEL    ,NFPROMEL ,NSTREFP  ,NFPEG    ,EFPGM    , &
 & EFPNORX  ,EFPNORY  ,NFPEX    ,NFPEBLKS  
USE YOMTAG   , ONLY : MTAGDISTGP
USE YOMFPGIND, ONLY : NFPRGPIND,NFPRGPNUM

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

IMPLICIT NONE

REAL(KIND=JPRB) :: ZFIELD(NFPRGPLX,NRFPOS)
REAL(KIND=JPRB) :: ZFIELDE(NFPEX,NRFPOS)
REAL(KIND=JPRB) :: ZFIELDG(NFPRGPG,NRFPOS)
REAL(KIND=JPRB) :: ZFIELDEG(NFPEG,NRFPOS)
REAL(KIND=JPRB) :: ZFP(NFPROMA,NRFPOS)
REAL(KIND=JPRB) :: ZFPE(NFPROMEL,NRFPOS)
INTEGER(KIND=JPIM) :: IAFPIO(NFPVSO)
LOGICAL :: LLMASK(NFPVSO)
INTEGER(KIND=JPIM) :: IC_DISGRIDFP

INTEGER(KIND=JPIM) :: IEND, JBLOC, ILAST, IOFF, IPARAM, &
 & IST, ISTRIN, JEPCT, JFIELD, JFLD, JFP  
INTEGER(KIND=JPIM) :: INFG, INFL, INFD(NPROC), IFLDOFF(NPROC)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "disgridfp.intfb.h"
#include "ircvezon.intfb.h"
!obsolete #include "ircvgpffp.intfb.h"
#include "isndezon.intfb.h"
!obsolete #include "isndgpffp.intfb.h"
#include "rdclimo.intfb.h"
#include "rdecclimo.intfb.h"
#include "sc2wrgfp.intfb.h"
#include "sufpsc2b.intfb.h"

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

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

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

!*       1. READ OR COMPUTE OUTPUT CLIMATOLOGY
!           ----------------------------------

! ky: IC_DISGRIDFP=2: call to DISGRIDFP, one call for all NFPVSO fields.
!     IC_DISGRIDFP=1: call to DISGRIDFP, one call per field.
IC_DISGRIDFP=1

IF (NFPCLI <= 1) THEN
  ! so few fields
  ISTRIN=1
ELSE
  ! it is worth distributing       
  ISTRIN=NSTRIN
  IF (LFPEZO) THEN
    ! bug in communications 
    ISTRIN=1
  ENDIF
ENDIF

IF (NFPVSO > 0) THEN

  IAFPIO(:) = -999
  LLMASK(:) = .FALSE.
  DO JFIELD=1,NFPVSO
    IAFPIO(JFIELD) = MOD(JFIELD-1,ISTRIN)+1
    LLMASK(JFIELD) = MYPROC /= IAFPIO(JFIELD)
  ENDDO

  IF (MYPROC <= ISTRIN) THEN
    ! "input" processors read the global fields
    IF (.NOT.LARPEGEF) THEN
      CALL RDECCLIMO(ZFIELDG,NFPRGPG,NFPVSO,MFPVSO,NFPCLI,LLMASK)
    ELSE
      CALL RDCLIMO(LFPEZO,ZFIELDEG,NFPEG,ZFIELDG,NFPRGPG,NFPVSO,&
       & MFPVSO,NFPCLI,LLMASK)  
    ENDIF
  ENDIF

  IF (NPROC == 1) THEN
    ! Data transfers
    DO JFLD=1,NFPVSO
      ZFIELD(1:NFPRGPL,JFLD)=ZFIELDG(1:NFPRGPL,JFLD)
      IF (LFPEZO) THEN
        ZFIELDE(1:NFPEL,JFLD)=ZFIELDEG(1:NFPEL,JFLD)
      ENDIF
    ENDDO
  ELSE

    IF (IC_DISGRIDFP == 2) THEN

      ! One call of DISGRIDFP for all fields.
      !  Probably more efficient than IC_DISGRIDFP=1.
      !  Coding not yet complete.
      INFG=NFPVSO
      INFL=0
      DO JFIELD=1,NFPVSO
        IF (.NOT.LLMASK(JFIELD)) INFL=INFL+1
      ENDDO
      INFD(1:NPROC)=1 !! ky: not OK, I don't know what to put in!
      IFLDOFF(1:NPROC)=0 !! ky: not OK, I don't know what to put in!
      CALL DISGRIDFP(MTAGDISTGP,INFG,NFPRGPG,NFPRGPL,NFPRGPLX,INFL, &
       & NFPRGPIND,NFPRGPNUM,INFD,IFLDOFF,ZFIELDG(1:NFPRGPG,1:NFPVSO), &
       & ZFIELD(1:NFPRGPL,1:NFPVSO))

    ELSEIF (IC_DISGRIDFP == 1) THEN

      ! One call of DISGRIDFP per field.
      INFG=1
      IFLDOFF(1:NPROC)=0
      DO JFIELD=1,NFPVSO
        ! INFL is 1 when the current proc has read the field number JFIELD via
        !  RDCLIMO/RDECCLIMO, 0 otherwise (if 0, DISGRIDFP only receives data)
        IF (.NOT.LLMASK(JFIELD)) THEN
          INFL=1
        ELSE
          INFL=0
        ENDIF
        ! INFD is 1 for the proc which reads the field number JFIELD via
        !  RDCLIMO/RDECCLIMO, 0 otherwise.
        INFD(1:NPROC)=0
        INFD(IAFPIO(JFIELD))=1
        CALL DISGRIDFP(MTAGDISTGP,INFG,NFPRGPG,NFPRGPL,NFPRGPLX,INFL, &
         & NFPRGPIND,NFPRGPNUM,INFD,IFLDOFF,ZFIELDG(1,JFIELD),ZFIELD(1,JFIELD))
      ENDDO

    !obsolete ELSE

     !obsolete  ! Distributions from (fields) to (gridpoints) ; to be optimised
     !obsolete  !  (obsolescent calls to ISNDGPFFP and IRCVGPFFP).
     !obsolete  ! Loop to send : 
     !obsolete  DO JFIELD=1,NFPVSO
     !obsolete    IPARAM=JFIELD+250
     !obsolete    IF (IAFPIO(JFIELD) == MYPROC) THEN
     !obsolete      ! Send my fields to all processors
     !obsolete      CALL ISNDGPFFP(ZFIELDG(1,JFIELD),ZFIELD(1,JFIELD),IPARAM,0)
     !obsolete    ENDIF
     !obsolete  ENDDO
     !obsolete  ! Loop to receive : 
     !obsolete  DO JFIELD=1,NFPVSO
     !obsolete    IPARAM=JFIELD+250
     !obsolete    ! Recieve fields from "input" processors :  
     !obsolete    CALL IRCVGPFFP(ZFIELD(1,JFIELD),ZFIELDG(1,JFIELD),&
     !obsolete     & IPARAM,0,IAFPIO(JFIELD))  
     !obsolete  ENDDO

    ENDIF

    IF (LFPEZO) THEN
      DO JFIELD=1,NFPVSO
        IPARAM=JFIELD+250
        IF (IAFPIO(JFIELD) == MYPROC) THEN
          ! Send my fields to processors #1 to #NSTREFP
          CALL ISNDEZON(ZFIELDEG(1,JFIELD),ZFIELDE(1,JFIELD),IPARAM,0)
        ENDIF
      ENDDO
      ! Loop to receive :
      DO JFIELD=1,NFPVSO
        IPARAM=JFIELD+250
        ! Procs 1 to NSTREFP receive fields from "input" procs:
        CALL IRCVEZON(ZFIELDE(1,JFIELD),ZFIELDEG(1,JFIELD),&
         & IPARAM,0,IAFPIO(JFIELD))  
      ENDDO
    ENDIF
  ENDIF
ENDIF

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

!*       2. COPY OUTPUT GEOMETRY
!           --------------------

DO JFP=1,NFPRGPL
  IF (MFPGMO  > 0) ZFIELD(JFP,MFPGMO )=RFPGM  (JFP)
  IF (MFPGNXO > 0) ZFIELD(JFP,MFPGNXO)=RFPNORX(JFP)
  IF (MFPGNYO > 0) ZFIELD(JFP,MFPGNYO)=RFPNORY(JFP)
ENDDO
IF (LFPEZO) THEN
  DO JFP=1,NFPEL
    IF (MFPGMO  > 0) ZFIELDE(JFP,MFPGMO )=EFPGM  (JFP)
    IF (MFPGNXO > 0) ZFIELDE(JFP,MFPGNXO)=EFPNORX(JFP)
    IF (MFPGNYO > 0) ZFIELDE(JFP,MFPGNYO)=EFPNORY(JFP)
  ENDDO
ENDIF

IF (ALLOCATED(RFPGM)) DEALLOCATE(RFPGM)
IF (ALLOCATED(RFPNORX)) DEALLOCATE(RFPNORX)
IF (ALLOCATED(RFPNORY)) DEALLOCATE(RFPNORY)
IF (ALLOCATED(EFPGM)) DEALLOCATE(EFPGM)
IF (ALLOCATED(EFPNORX)) DEALLOCATE(EFPNORX)
IF (ALLOCATED(EFPNORY)) DEALLOCATE(EFPNORY)

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

!*       3. INITIALIZE BUFFER/WORKFILE
!           --------------------------

!*       3.2 ALLOCATE BUFFER

ALLOCATE(NSTARFPB(NFPBLOCS))
CALL SUFPSC2B(NRFPOS,NSTARFPB,NLENRFPB,NFPROMA,NFPBLOCS)
ALLOCATE(RFPBUF(NLENRFPB))
IF (LALLOPR) THEN
  WRITE(NULOUT,9990) 'NSTARFPB  ',SIZE(NSTARFPB),SHAPE(NSTARFPB)
  WRITE(NULOUT,9990) 'RFPBUF    ',SIZE(RFPBUF  ),SHAPE(RFPBUF  )
ENDIF
IF (LFPEZO) THEN
  ALLOCATE(NESTARFP(NFPEBLKS))
  CALL SUFPSC2B(NRFPOS,NESTARFP,NELENRFP,NFPROMEL,NFPEBLKS)
  ALLOCATE(REFPBUF(NELENRFP))
  IF (LALLOPR) THEN
    WRITE(NULOUT,9990) 'NESTARFP  ',SIZE(NESTARFP),SHAPE(NESTARFP)
    WRITE(NULOUT,9990) 'REFPBUF    ',SIZE(REFPBUF  ),SHAPE(REFPBUF  )
  ENDIF
ENDIF

!*       3.3 FILL BUFFER AND WRITE RECORD

DO JBLOC=1,NFPBLOCS

  IST =NFPSTART(JBLOC)
  IEND=NFPEND(JBLOC)

  DO JFLD=1,NRFPOS
    DO JFP=IST,IEND
      ZFP(JFP,JFLD)=ZFIELD(NFPSORT(JFP,JBLOC),JFLD)
    ENDDO
    DO JFP=IEND+1,NFPROMA
      ZFP(JFP,JFLD)=0.0_JPRB
    ENDDO
  ENDDO

  CALL SC2WRGFP(NFPROMA,NRFPOS,RFPBUF,NSTARFPB(JBLOC),IST,IEND,ZFP)

ENDDO

IF (LFPEZO) THEN
  IF (MYPROC <= NSTREFP) THEN
    ILAST=MOD(NFPEL,NFPROMEL)
    IF (ILAST == 0) THEN
      ILAST=NFPROMEL
    ENDIF
    DO JEPCT=1,NFPEBLKS
      IST=1
      IEND=(1-JEPCT/NFPEBLKS)*NFPROMEL + (JEPCT/NFPEBLKS) * ILAST
      IOFF=(JEPCT-1)*NFPROMEL
      DO JFLD=1,NRFPOS
        DO JFP=IST,IEND
          ZFPE(JFP,JFLD)=ZFIELDE(IOFF+JFP,JFLD)
        ENDDO
        DO JFP=IEND+1,NFPROMEL
          ZFPE(JFP,JFLD)=0.0_JPRB
        ENDDO
      ENDDO
      CALL SC2WRGFP(NFPROMEL,NRFPOS,REFPBUF,NESTARFP(JEPCT),IST,IEND,ZFPE)
    ENDDO
  ENDIF
ENDIF

! ---------------------------------------------------------------------
9990 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

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