SUBROUTINE WRGP2FA(PBUF,CDPREF,KLEV,CDSUFF,KFIELDS,KUNIT)

!**** *WRGP2FA*  - Write gridpointd fields to *FA* file

!     Purpose.
!     --------
!        To write local gridpoint fields to *FA* file. The file is expected
!        to be opened and close out of this subroutine, which, in counterpart,
!        handles the communications.

!**   Interface.
!     ----------
!        *CALL* *WRGP2FA*

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

!            PBUF    : gridpoint fields
!            CDPREF  : prefix of gridpoint field names to write
!            KLEV    : level  of gridpoint field names to write
!            CDSUFF  : suffix of gridpoint field names to write
!            KFIELDS : number of gridpoint fields in array
!            KUNIT   : file logical unit number 

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

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

!     Externals.
!     ----------
!           FA routines
!           Processor communication routines
!           DISGRID

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS
!        Note de travail ARPEGE Nr 12 et 17

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

!     Modifications.
!     --------------
!        ORIGINAL : 01-0130 from RDPXFA
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        F.Bouyssel    05-11-09 Modifications for cloud fields
!     ------------------------------------------------------------------

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

USE YOMFA    , ONLY : YFAL     ,YFAI     ,YFAR     ,YFAS
USE YOMLUN   , ONLY : NULOUT
USE YOMGEM   , ONLY : NGPTOT   ,NGPTOTG
USE YOMMP    , ONLY : MYPROC   ,NSTROUT
IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KFIELDS 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBUF(NGPTOT,KFIELDS) 
CHARACTER(LEN=*)  ,INTENT(IN)    :: CDPREF(KFIELDS) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV(KFIELDS) 
CHARACTER(LEN=*)  ,INTENT(IN)    :: CDSUFF(KFIELDS) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KUNIT 
INTEGER(KIND=JPIM) :: IOPROC(KFIELDS)

CHARACTER(LEN=16) :: CLNOMA(1,1), CLPRINT(KFIELDS)

REAL(KIND=JPRB) :: ZGVALCO(NGPTOTG+2,1)
REAL(KIND=JPRB) :: ZAVE(KFIELDS,1), ZMIN(KFIELDS,1), ZMAX(KFIELDS,1)

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

LOGICAL :: LLNBPDG
INTEGER(KIND=JPIM) :: IDIMGVAL, IFLDL, ILNOMA(1,1), ILONGD(1,1), INMGPX
INTEGER(KIND=JPIM) :: INUM, IREP, J, JFLD, IMASK(1,1), IPTR(1)
INTEGER(KIND=JPIM) :: INGRIB,IINBPDG,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "diwrgrid.intfb.h"
#include "fpgpnorm.intfb.h"
#include "gathflnm.intfb.h"

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

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

IF (LHOOK) CALL DR_HOOK('WRGP2FA',0,ZHOOK_HANDLE)
IDIMGVAL=NGPTOTG+2
IMASK(1,1)=1
IPTR(1)=1
LLNBPDG=.FALSE.

IOPROC = -999
DO J=1,KFIELDS
  IOPROC(J)=MOD(J-1,NSTROUT)+1
ENDDO
INMGPX=0
DO J=1,KFIELDS
  IF(IOPROC(J)  ==  MYPROC) THEN
    INMGPX = INMGPX + 1
  ENDIF
ENDDO

!     3.    SEND FIELDS
!           -----------

INUM=0
DO JFLD=1,KFIELDS
  INUM=INUM+1
  IF (IOPROC(INUM) /= MYPROC) THEN
    CALL DIWRGRID(IOPROC(INUM),INUM,0,NGPTOT,PBUF(1,JFLD))
  ENDIF
ENDDO

!     4.    RECIEVE FIELDS, PACK THEM AND SEND TO PROCESSOR #1 OR WRITE
!           -----------------------------------------------------------

IF(INMGPX >= 1) THEN
  ALLOCATE(ZGPG(NGPTOTG,INMGPX))
ENDIF

INUM=0
IFLDL=0
DO JFLD=1,KFIELDS
  INUM=INUM+1
  IF (IOPROC(INUM) == MYPROC) THEN
    IFLDL=IFLDL+1
    ZGPG(1:NGPTOT,IFLDL)=PBUF(1:NGPTOT,JFLD)
    CALL DIWRGRID(IOPROC(INUM),INUM,1,NGPTOTG,ZGPG(1,IFLDL))
    CALL FPGPNORM(ZGPG(1,IFLDL),1,NGPTOTG,IMASK(1,1),ZAVE(JFLD,1),ZMIN(JFLD,1),&
     & ZMAX(JFLD,1),1,NGPTOTG)
    IF (CDSUFF(JFLD) == 'NEBULOSI.TOT') THEN
      CALL FAVEUR(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      IINBPDG=4
      CALL FAGOTE(IREP,KUNIT,INGRIB,IINBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.TRUE.
    ELSEIF (CDSUFF(JFLD) == 'HUMILIQU.TOT') THEN
      CALL FAVEUR(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      IINBPDG=10
      CALL FAGOTE(IREP,KUNIT,INGRIB,IINBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.TRUE.
    ELSEIF (CDSUFF(JFLD) == 'HUMISOLI.TOT') THEN
      CALL FAVEUR(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      IINBPDG=10
      CALL FAGOTE(IREP,KUNIT,INGRIB,IINBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.TRUE.
    ELSEIF (CDSUFF(JFLD) == YFAL%CLNAME .AND. YFAL%NBITS > 0) THEN
      CALL FAVEUR(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      IINBPDG=YFAL%NBITS
      CALL FAGOTE(IREP,KUNIT,INGRIB,IINBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.TRUE.
    ELSEIF (CDSUFF(JFLD) == YFAI%CLNAME .AND. YFAI%NBITS > 0) THEN
      CALL FAVEUR(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      IINBPDG=YFAI%NBITS
      CALL FAGOTE(IREP,KUNIT,INGRIB,IINBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.TRUE.
    ELSEIF (CDSUFF(JFLD) == YFAR%CLNAME .AND. YFAR%NBITS > 0) THEN
      CALL FAVEUR(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      IINBPDG=YFAR%NBITS
      CALL FAGOTE(IREP,KUNIT,INGRIB,IINBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.TRUE.
    ELSEIF (CDSUFF(JFLD) == YFAS%CLNAME .AND. YFAS%NBITS > 0) THEN
      CALL FAVEUR(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      IINBPDG=YFAS%NBITS
      CALL FAGOTE(IREP,KUNIT,INGRIB,IINBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.TRUE.
    ENDIF
    ILNOMA(1,1)=0
    ILONGD(1,1)=0
    CLNOMA(1,1)=' '
    ZGVALCO(:,1)=0.0_JPRB
    CALL FACOND(IREP,KUNIT,CDPREF(JFLD),KLEV(JFLD),&
     & CDSUFF(JFLD),ZGPG(1,IFLDL),.FALSE.,CLNOMA,&
     & ILNOMA,ZGVALCO,ILONGD)  
    IF (LLNBPDG) THEN
      CALL FAGOTE(IREP,KUNIT,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
      LLNBPDG=.FALSE.
    ENDIF
    IF(MYPROC  >  1) THEN
      CALL GATHFLNM(0,INUM,1,1,CLNOMA,ILNOMA,ZGVALCO,ILONGD,IMASK,IDIMGVAL,&
       &ZAVE(JFLD,1),ZMIN(JFLD,1),ZMAX(JFLD,1),.TRUE.,IPTR)
    ELSE
      CALL FAISAN(IREP,KUNIT,CLNOMA(1,1)(1:ILNOMA(1,1)),ZGVALCO,ILONGD)
      CLPRINT(JFLD)=CLNOMA(1,1)(1:ILNOMA(1,1))//' '
    ENDIF
  ENDIF
ENDDO

!*    5.    PROCESSOR #1 WRITES FIELDS
!           --------------------------

INUM=0
IF(MYPROC == 1) THEN
  WRITE(NULOUT,FMT='(''GPNORMS OF FIELDS TO BE WRITTEN OUT ON FILE :'')')
  WRITE(NULOUT,FMT='(29X,3(6X,A7,9X))')'AVERAGE','MINIMUM','MAXIMUM'
  IFLDL=0
  DO JFLD=1,KFIELDS
    INUM=INUM+1
    IF (IOPROC(INUM) /= MYPROC) THEN
      IFLDL=IFLDL+1
      CALL GATHFLNM(1,INUM,1,1,CLNOMA,ILNOMA,ZGVALCO,&
       &ILONGD,IMASK,IDIMGVAL,ZAVE(JFLD,1),ZMIN(JFLD,1),ZMAX(JFLD,1),.TRUE.,IPTR)
      CALL FAISAN(IREP,KUNIT,CLNOMA(1,1)(1:ILNOMA(1,1)),ZGVALCO,ILONGD)
      CLPRINT(JFLD)=CLNOMA(1,1)(1:ILNOMA(1,1))//' '
    ENDIF
    WRITE(NULOUT,FMT='(1X, A16,'' : '',3(E21.15,1X))') CLPRINT(JFLD),&
     & ZAVE(JFLD,1),ZMIN(JFLD,1),ZMAX(JFLD,1)  
  ENDDO
ENDIF

IF(INMGPX >= 1) THEN
  DEALLOCATE(ZGPG)
ENDIF

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

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