SUBROUTINE WRITE_GRID_GRIB(CDFILE,YDGRID, &
                         & YDHEADER,KTYPE_INTERP,CDMODE,KSECLOC,PGPSP)

!     Purpose.
!     --------
!     Gather grid point fields on one processor
!     and write it out in GRIB file.

!     Author.
!     -------
!       Y. Tremolet

!     Modifications.
!     --------------
!       Original : 31-01-01
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!        Y.Tremolet    07-Jun-2004 Use type gridpoint_field
!        Y.Tremolet    04-Nov-2004 Added optional mode for appending to file
!        Y.Tremolet    10-Nov-2004 Option to force ECMWF local GRIB definition
!        G. Radnoti    25-Jan-2005 dimensioning from grib header info  
!        Y.Tremolet    17-Feb-2005 Conserving interpolation (copied from WRITE_GRID_GRIB routine)
!        Y.Tremolet    30-Mar-2005 PREGRBENC -> PRESET_GRIB_HEAD
!        E.Holm        04-Jan-2008 Conserving interpolation interface
!                                  changed to use surface pressure
! ----------------------------------------------------------------------

USE PARKIND1,ONLY : JPIM, JPRB
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE YOMLUN, ONLY : NULERR, NULOUT
USE YOMMP , ONLY : MYPROC
USE YOMDIM, ONLY : NDGLG, NPROMA, NGPBLKS
USE YOMGEM, ONLY : NLOENG, NGPTOTG
USE YOMLEG, ONLY : RLATIG
USE YOMMSC, ONLY : NINTLEN
USE YOMGRB, ONLY : NGRBV
USE GRIDPOINT_FIELDS_MIX
USE GRIB_HEADER_MIX

IMPLICIT NONE

CHARACTER(LEN=*), INTENT(IN)      :: CDFILE 
TYPE(GRIDPOINT_FIELD), INTENT(IN) :: YDGRID
TYPE(GRIB_HEADER) , OPTIONAL, INTENT(IN) :: YDHEADER
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KTYPE_INTERP 
CHARACTER(LEN=1)  , OPTIONAL, INTENT(IN) :: CDMODE
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KSECLOC(:)
REAL(KIND=JPRB)   , OPTIONAL, INTENT(IN) :: PGPSP(NPROMA,NGPBLKS)

INTEGER(KIND=JPIM) :: ii,jb,jj,jf,jl,ioproc,iunit,ierr,iword
INTEGER(KIND=JPIM) :: ilats,igpout,ilen,idglg,itype_interp
LOGICAL :: LLINTERP, LLPARITY
REAL(KIND=JPRB), ALLOCATABLE :: zlocal(:), zlowres(:), zgrid(:,:), zlats(:)
REAL(KIND=JPRB), ALLOCATABLE :: zpspin(:), zpspout(:)
INTEGER(KIND=JPIM), ALLOCATABLE :: igrib(:), isec2gg(:), ilons(:)
TYPE(GRIB_HEADER) :: YLHEADER
CHARACTER(LEN=1) :: CLMODE
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "gathergpf.intfb.h"
#include "grid_bicubic.intfb.h"
#include "grid_bilinear.intfb.h"
#include "grid_biconserv.intfb.h"
#include "pre_grid_biconserv.intfb.h"
#include "grid_from_grib.intfb.h"

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

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

itype_interp=2
IF (PRESENT(KTYPE_INTERP)) itype_interp=KTYPE_INTERP

IF (PRESENT(YDHEADER)) THEN
  idglg=YDHEADER%nsec2gg(3)
  ALLOCATE(ilons(idglg))
  ALLOCATE(zlats(idglg))
  CALL GRID_FROM_GRIB(YDHEADER,ilats,ilons,zlats,igpout,idglg)
  LLINTERP=(YDGRID%NGPTOTG/=igpout)
  IF (LLINTERP) THEN
    SELECT CASE (itype_interp)
    CASE(1)
      write(nulout,*)'WRITE_GRID_GRIB: doing linear interpolation'
    CASE(2)
      write(nulout,*)'WRITE_GRID_GRIB: doing cubic interpolation'
    CASE(3)
      write(nulout,*)'WRITE_GRID_GRIB: doing conserving interpolation'
    CASE DEFAULT
      CALL ABOR1('WRITE_GRID_GRIB: unkown interpolation type')
    END SELECT
  ENDIF
ELSE
  llinterp=.false.
  igpout=YDGRID%NGPTOTG
ENDIF

ioproc=1

IF (MYPROC==ioproc) THEN
  IF (LLINTERP) THEN
    ALLOCATE(zlowres(igpout))
!   Other parts of header set by PREGRBENC
    ALLOCATE(isec2gg(SIZE(YDHEADER%NSEC2GG)))
    isec2gg=YDHEADER%nsec2gg
    write(nulout,*)'WRITE_GRID_GRIB: watch vertical part of NSEC2'
!   vertical definition should be kept from PRESET_GRIB_HEAD
  ENDIF
  ALLOCATE(igrib(igpout))
  CALL ALLOCATE_GRIB_HEADER(YLHEADER)

  CALL GSTATS(1721,0)
  CLMODE="w"
  IF (PRESENT(CDMODE)) CLMODE=CDMODE
  CALL PBOPEN(iunit,CDFILE,CLMODE,ierr)
  CALL GSTATS(1721,1)
  IF (ierr /= 0) THEN
    write(nulerr,*)'WRITE_GRID_GRIB: PBOPEN error code ',ierr
    CALL ABOR1('WRITE_GRID_GRIB: error opening grib file')
  ENDIF
ENDIF

IF (YDGRID%NG3D>0) THEN
  ALLOCATE(zlocal(YDGRID%NGPTOT*YDGRID%NFLEVG))
  ALLOCATE(zgrid(YDGRID%NGPTOTG,YDGRID%NFLEVG))
  IF (LLINTERP.AND.ITYPE_INTERP==3) THEN
    ALLOCATE(ZPSPIN(YDGRID%NGPTOTG))
    ALLOCATE(ZPSPOUT(igpout))
    IF (PRESENT(PGPSP)) THEN
      CALL PRE_GRID_BICONSERV(igpout,ILATS,ILONS,ZLATS, &
                            & ZPSPIN,ZPSPOUT,PGPSP=PGPSP)
    ELSE
      IF (ASSOCIATED(YDGRID%SPR)) THEN
        CALL PRE_GRID_BICONSERV(igpout,ILATS,ILONS,ZLATS, &
                              & ZPSPIN,ZPSPOUT,PGPSP=YDGRID%SPR)
      ELSE
        CALL ABOR1('WRITE_GRID_GRIB: LNSP required for interpolation')
      ENDIF
    ENDIF
  ENDIF
ENDIF

DO jf=1,YDGRID%NG3D
  CALL GSTATS(1946,0)
  ii=0
  DO jl=1,YDGRID%NFLEVG
    DO jb=1,YDGRID%NGPBLKS
      ilen=MIN(YDGRID%NPROMA, YDGRID%NGPTOT-(jb-1)*YDGRID%NPROMA)
      DO jj=1,ilen
        ii=ii+1
        zlocal(ii)=YDGRID%GP3D(jj,jl,jf,jb)
      ENDDO
    ENDDO
  ENDDO
  CALL GSTATS(1946,1)

  CALL GATHERGPF(zlocal,zgrid,YDGRID%NFLEVG,ioproc)

  IF (MYPROC==ioproc) THEN
    DO jl=1,YDGRID%NFLEVG
      IF (PRESENT(KSECLOC)) THEN
        CALL PRESET_GRIB_HEAD(YLHEADER,YDGRID%NGRIB3(jf),jl,'GG','ML', &
                            & KPTS=igpout,KSECLOC=KSECLOC)
      ELSE
        CALL PRESET_GRIB_HEAD(YLHEADER,YDGRID%NGRIB3(jf),jl,'GG','ML', &
                            & KPTS=igpout)
      ENDIF

      IF (LLINTERP) THEN
        IF (NGPTOTG /= YDGRID%NGPTOTG) THEN
          write(nulerr,*)'WRITE_GRID_GRIB: NGPTOT /= YDGRID%NGPTOT'
          CALL ABOR1('WRITE_GRID_GRIB: Un supported option used')
        ENDIF

        SELECT CASE (itype_interp)
        CASE(1)
          CALL GRID_BILINEAR(NDGLG,NLOENG(1:NDGLG),RLATIG(1:NDGLG),&
           & NGPTOTG,ILATS,ILONS,ZLATS,IGPOUT,ZGRID(:,JL),ZLOWRES)
        CASE(2)
          CALL GRID_BICUBIC (NDGLG,NLOENG(1:NDGLG),RLATIG(1:NDGLG),&
           & NGPTOTG,ILATS,ILONS,ZLATS,IGPOUT,ZGRID(:,JL),ZLOWRES)
        CASE(3)
          LLPARITY=.NOT.(YDGRID%NGRIB3(jf)==NGRBV)
          CALL GRID_BICONSERV(NDGLG,NLOENG(1:NDGLG),RLATIG(1:NDGLG),&
           & NGPTOTG,ILATS,ILONS,ZLATS,IGPOUT,ZGRID(:,JL),ZLOWRES,&
           & LLPARITY,JL,ZPSPIN,ZPSPOUT)
        END SELECT

        CALL GSTATS(1704,0)
        CALL GRIBEX(YLHEADER%nsec0,YLHEADER%nsec1,isec2gg, &
         & YLHEADER%rsec2,YLHEADER%nsec3,YLHEADER%rsec3, &
         & YLHEADER%nsec4gg,zlowres,igpout,igrib,igpout,iword,'C',ierr)  
        CALL GSTATS(1704,1)
      ELSE
        CALL GSTATS(1704,0)
        CALL GRIBEX(YLHEADER%nsec0,YLHEADER%nsec1,YLHEADER%nsec2gg, &
         & YLHEADER%rsec2,YLHEADER%nsec3,YLHEADER%rsec3, &
         & YLHEADER%nsec4gg,zgrid(:,jl),igpout,igrib,igpout,iword,'C',ierr)  
        CALL GSTATS(1704,1)
      ENDIF
      IF (ierr /= 0) THEN
        write(nulerr,*)'WRITE_GRID_GRIB: GRIBEX error code ',ierr
        CALL ABOR1('WRITE_GRID_GRIB: error in GRIBEX')
      ENDIF

      CALL GSTATS(1745,0)
      CALL PBWRITE(iunit,igrib,iword*NINTLEN,ierr)
      CALL GSTATS(1745,1)
      IF (ierr < 0) THEN
        write(nulerr,*)'WRITE_GRID_GRIB: PBWRITE error code ',ierr
        CALL ABOR1('WRITE_GRID_GRIB: PBWRITE failed')
      ENDIF
    ENDDO
  ENDIF
ENDDO

IF (ALLOCATED(zlocal  )) DEALLOCATE(zlocal)
IF (ALLOCATED(zgrid   )) DEALLOCATE(zgrid)

IF (YDGRID%NG2D>0) THEN
  ALLOCATE(zlocal(YDGRID%NGPTOT*YDGRID%NG2D))
  ALLOCATE(zgrid(YDGRID%NGPTOTG,YDGRID%NG2D))

  CALL GSTATS(1946,0)
  ii=0
  DO jf=1,YDGRID%NG2D
    DO jb=1,YDGRID%NGPBLKS
      ilen=MIN(YDGRID%NPROMA, YDGRID%NGPTOT-(jb-1)*YDGRID%NPROMA)
      DO jj=1,ilen
        ii=ii+1
        zlocal(ii)=YDGRID%GP2D(jj,jf,jb)
      ENDDO
    ENDDO
  ENDDO
  CALL GSTATS(1946,1)

  CALL GATHERGPF(zlocal,zgrid,YDGRID%NG2D,ioproc)

  IF (MYPROC==ioproc) THEN
    DO jf=1,YDGRID%NG2D
      IF (PRESENT(KSECLOC)) THEN
        CALL PRESET_GRIB_HEAD(YLHEADER,YDGRID%NGRIB2(jf),1,'GG','SFC', &
                            & KPTS=igpout,KSECLOC=KSECLOC)
      ELSE
        CALL PRESET_GRIB_HEAD(YLHEADER,YDGRID%NGRIB2(jf),1,'GG','SFC', &
                            & KPTS=igpout)
      ENDIF

      IF (LLINTERP) THEN
        SELECT CASE (itype_interp)
        CASE(1:2)
          CALL GRID_BILINEAR (NDGLG,NLOENG(1:NDGLG),RLATIG(1:NDGLG),&
           & NGPTOTG,ILATS,ILONS,ZLATS,IGPOUT,ZGRID(:,JF),ZLOWRES)
        CASE(3)
          CALL GRID_BICONSERV(NDGLG,NLOENG(1:NDGLG),RLATIG(1:NDGLG),&
           & NGPTOTG,ILATS,ILONS,ZLATS,IGPOUT,ZGRID(:,JF),ZLOWRES)
        END SELECT

        CALL GSTATS(1704,0)
        CALL GRIBEX(YLHEADER%nsec0,YLHEADER%nsec1,isec2gg, &
         & YLHEADER%rsec2,YLHEADER%nsec3,YLHEADER%rsec3, &
         & YLHEADER%nsec4gg,zlowres,igpout,igrib,igpout,iword,'C',ierr)  
        CALL GSTATS(1704,1)
      ELSE
        CALL GSTATS(1704,0)
        CALL GRIBEX(YLHEADER%nsec0,YLHEADER%nsec1,YLHEADER%nsec2gg, &
         & YLHEADER%rsec2,YLHEADER%nsec3,YLHEADER%rsec3, &
         & YLHEADER%nsec4gg,zgrid(:,jf),igpout,igrib,igpout,iword,'C',ierr)  
        CALL GSTATS(1704,1)
      ENDIF

      IF (ierr /= 0) THEN
        write(nulerr,*)'WRITE_GRID_GRIB: GRIBEX error code ',ierr
        CALL ABOR1('WRITE_GRID_GRIB: error in GRIBEX')
      ENDIF

      CALL GSTATS(1745,0)
      CALL PBWRITE(iunit,igrib,iword*NINTLEN,ierr)
      CALL GSTATS(1745,1)
      IF (ierr < 0) THEN
        write(nulerr,*)'WRITE_GRID_GRIB: PBWRITE error code ',ierr
        CALL ABOR1('WRITE_GRID_GRIB: PBWRITE failed')
      ENDIF
    ENDDO
  ENDIF

  DEALLOCATE(zlocal)
  DEALLOCATE(zgrid)
ENDIF

IF (MYPROC==ioproc) THEN
  CALL PBCLOSE(iunit,ierr)
  IF (ierr /= 0) THEN
    write(nulerr,*)'WRITE_GRID_GRIB: PBCLOSE error code ',ierr
    CALL ABOR1('WRITE_GRID_GRIB: error closing grib file')
  ENDIF
  DEALLOCATE(igrib)
  IF (ALLOCATED(zlowres)) DEALLOCATE(zlowres)
  IF (ALLOCATED(isec2gg)) DEALLOCATE(isec2gg)
  CALL DEALLOCATE_GRIB_HEADER(YLHEADER)
ENDIF
IF (ALLOCATED(ilons)) DEALLOCATE(ilons)
IF (ALLOCATED(zlats)) DEALLOCATE(zlats)
IF (ALLOCATED(ZPSPIN)) DEALLOCATE(ZPSPIN)
IF (ALLOCATED(ZPSPOUT)) DEALLOCATE(ZPSPOUT)

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