SUBROUTINE WRBUDG

!**** *WRBUDG*  - writes out the 'budget values' of the model

!     Purpose.
!     --------
!     Write out the "budget values" of the model (GRIB code 128)

!**   Interface.
!     ----------
!        *CALL* *WRBUDG(KDB)

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

!        Implicit arguments :      The momentum budget values
!        --------------------

!     Method.
!     -------
!        Routine looks odd especially the lenght of the real section
!        set to 296 but it is all done to make the record look the
!        same as it did in 'old' spectral model at ECMWF.

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

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

!     Author.
!     -------
!        Mats Hamrud *ECMWF*

!     Modifications.
!     --------------
!       Original : 93-08-15
!       M.Hamrud : 95-12-12 Cleaning
!       Modified : 00-09-01 D.Dent: convert from MPE to MPL
!       P.Towers 23-04-03 - Added ISETFIELDCOUNTFDB logic
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMMSC   , ONLY : NINTLEN
USE YOMCT0   , ONLY : CNMEXP   ,CFCLASS  ,CTYPE    ,NCYCLE   ,&
 & NPROC    ,LFDBOP   ,LGRBOP    
USE YOMCT3   , ONLY : NSTEP
USE YOMDYN   , ONLY : TSTEP
USE YOMOP    , ONLY : CFNGG    ,LINC     ,NFDBREF
USE YOMGRB   , ONLY : NSEC0,NSEC1,NSEC2GG,NSEC3,NSEC4
USE YOMANGM  , ONLY : X1APNH   ,X2APNH   ,X3APNH   ,X1BPNH   ,&
 & X2BPNH   ,X3BPNH   ,X1APSH   ,X2APSH   ,X3APSH   ,&
 & X1BPSH   ,X2BPSH   ,X3BPSH   ,XSP  
USE YOMMP    , ONLY :   MYPROC
USE MPL_MODULE
USE FDBSUBS_MOD

IMPLICIT NONE

!     EXTERNAL INTEGER FUNCTIONS
INTEGER(KIND=JPIM) :: JPLENR
INTEGER(KIND=JPIM) :: JPMAXFL

PARAMETER(JPMAXFL=10,JPLENR=296)

CHARACTER :: CLBL0*4,CLDAT*12
CHARACTER :: CLPAR*3,CLEVEL*4
INTEGER(KIND=JPIM) :: IGRIB(1501),IBLO1(18)
REAL(KIND=JPRB) :: ZRDAT(JPLENR),ZBUF(JPLENR*NPROC)
CHARACTER :: CLR1*5,CLR2*4
CHARACTER :: CLFNGG*30
CHARACTER (LEN = 1) ::  CLMODE

INTEGER(KIND=JPIM) :: ISEC0(SIZE(NSEC0)),ISEC1(SIZE(NSEC1))
INTEGER(KIND=JPIM) :: ISEC3(SIZE(NSEC3)),ISEC4(SIZE(NSEC4)),ISEC2GG(SIZE(NSEC2GG))

INTEGER(KIND=JPIM) :: IANG, IBIT, IBYTE, IERR, IGRIBCD, IIDAT,&
 & IINC, ILENBL1, ILENCH, ILENIN, ILENLO, ILENPS, &
 & ILENRE, IROUND, IRSERV, &
 & ISTAT, IUGG, IUSED, IWORD, J, &
 & JROC  
INTEGER(KIND=JPIM) :: IRECVCOUNTS(NPROC)

LOGICAL :: LLDAT

REAL(KIND=JPRB) :: ZX1NH, ZX1SH, ZX2NH, ZX2SH, ZX3NH, ZX3SH
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "pregrbenc.intfb.h"

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

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

!*       1.1   COMPUTE HEMISPREIC AND GLOBAL ANG.MOMENTUM TERMS

IF (LHOOK) CALL DR_HOOK('WRBUDG',0,ZHOOK_HANDLE)
ZX1NH = X1APNH+X1BPNH
ZX2NH = X2APNH+X2BPNH
ZX3NH = X3APNH+X3BPNH
ZX1SH = X1APSH+X1BPSH
ZX2SH = X2APSH+X2BPSH
ZX3SH = X3APSH+X3BPSH

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

!*       2.    PREPARE FOR PSEUDO GRIB CODING.
!              -------------------------------

CALL PREGRBENC(129,1,'GG','SFC',&
 & ISEC0,ISEC1,ISEC2GG,ISEC3,ISEC4,&
 & ZRDAT)  

!*       2.1  BLOCK 0

CLBL0 = 'BUDG'

!*       2.2  BLOCK 1

IBLO1(1) = 98
IBLO1(2) = NCYCLE
IBLO1(3) = 255
IBLO1(4) = 0
IBLO1(5) = 128
IBLO1(6) = 1
IBLO1(7) = 0
IBLO1(8) = 0
IBLO1(9) = ISEC1(10)+100*(ISEC1(21)-1)
IBLO1(10:18) = ISEC1(11:19)

!*       2.3   BLOCK 4, CHARACTER SECTION.

ILENCH = 12
CLDAT  = CFCLASS//'  '//CTYPE//'  '//CNMEXP

!*       2.4   BLOCK 4, LOGICAL SECTION.

ILENLO = 0

!*       2.5   BLOCK 4, INTEGER SECTION.

ILENIN = 0

!*       2.6   BLOCK 4, REAL SECTION.

ILENRE=JPLENR
DO J=1,ILENRE
  ZRDAT(J) = 0.0_JPRB
ENDDO
IANG=ILENRE-17
ZRDAT(IANG+0 ) = ZX1NH
ZRDAT(IANG+1 ) = ZX1SH
ZRDAT(IANG+2 ) = ZX2NH
ZRDAT(IANG+3 ) = ZX2SH
ZRDAT(IANG+4 ) = ZX3NH
ZRDAT(IANG+5 ) = ZX3SH
ZRDAT(IANG+6 ) = X1APNH
ZRDAT(IANG+7 ) = X1APSH
ZRDAT(IANG+8 ) = X1BPNH
ZRDAT(IANG+9 ) = X1BPSH
ZRDAT(IANG+10) = X2APNH
ZRDAT(IANG+11) = X2APSH
ZRDAT(IANG+12) = X2BPNH
ZRDAT(IANG+13) = X2BPSH
ZRDAT(IANG+14) = X3APNH
ZRDAT(IANG+15) = X3APSH
ZRDAT(IANG+16) = X3BPNH
ZRDAT(IANG+17) = X3BPSH
ZRDAT(ILENRE-29) = XSP

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

!*       3.    MESSAGE PASSING
!              ---------------

IF (NPROC > 1) THEN
  IRECVCOUNTS(:)=JPLENR
  CALL GSTATS(612,0)
  CALL MPL_GATHERV(ZRDAT,KROOT=1,&
   & PRECVBUF=ZBUF,KRECVCOUNTS=IRECVCOUNTS, &
   & CDSTRING='WRBUDG:')  
  CALL GSTATS(612,1)
  IF(MYPROC == 1) THEN
    DO JROC=1,NPROC-1
      ZRDAT(:) = ZRDAT(:)+ZBUF((JROC-1)*JPLENR+1:JROC*JPLENR)
    ENDDO
  ENDIF
ENDIF

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

!*       3.    CODE IN PSEUDO-GRIB
!              -------------------

IF (MYPROC == 1) THEN
  IBYTE   = 2
  IBIT    = NINTLEN*8
  IROUND  = 1
  ILENPS  = 1501
  IUSED   = ILENCH+4*ILENRE+IBYTE*ILENIN+ILENLO
  ILENBL1 = 24
  IRSERV  = (ILENPS-1)*NINTLEN-IUSED-4-ILENBL1-4-32
  CALL CODEPS(CLBL0,CLDAT,ILENCH,ZRDAT,ILENRE,IIDAT,ILENIN,&
   & IBYTE,LLDAT,ILENLO,IBLO1,IGRIB,ILENPS,IRSERV,&
   & IBIT,IWORD,IROUND,IERR)  

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

!*       4.    WRITE OUT.
!              ----------

  IF(LGRBOP) THEN
    IF(LFDBOP) THEN
      WRITE(CLPAR,'(I3.3)') IBLO1(5)
      ISTAT = ISETVALFDBSUBS(NFDBREF,'parameter',CLPAR)
      WRITE(CLEVEL,'(I4.4)') IBLO1(7)
      ISTAT = ISETVALFDBSUBS(NFDBREF,'level',CLEVEL)
      ISTAT = ISETFIELDCOUNTFDBSUBS(NFDBREF,1,1)
      IF(ISTAT /= 0) THEN
        WRITE(NULERR,'(A,I4)') ' ISETFIELDCOUNTFDB RETURNS ',ISTAT
        CALL ABOR1('WRBUDG: ISETFIELDCOUNTFDB')
      ENDIF
      ISTAT = IWRITEFDBSUBS(NFDBREF,IGRIB,IWORD)
      IF(ISTAT /= 0) THEN
        WRITE(NULOUT,'(A,I4)') ' IWRITEFDB RETURNS ',ISTAT
        CALL ABOR1('WRBUDG')
      ENDIF
    ELSE
      CLMODE = 'w'
      IGRIBCD=IBLO1(5)
      CLR1 = CFNGG(1:5)
      CLR2 = CFNGG(6:9)
      IF (LINC) THEN
        IINC = NINT(REAL(NSTEP,JPRB)*TSTEP/3600._JPRB)
      ELSE
        IINC = NSTEP
      ENDIF
      IF (NSTEP < 0) THEN
        WRITE(CLFNGG,'(A5,A4,I5.4,A,I3.3)')CLR1,CLR2,NSTEP,'.',IGRIBCD
      ELSE
        WRITE(CLFNGG,'(A5,A4,''+'',I6.6,A,I3.3)')CLR1,CLR2,IINC,'.',IGRIBCD
      ENDIF
      CALL PBOPEN(IUGG,CLFNGG,CLMODE,IERR)
      IF( IERR /= 0 )THEN
        CALL ABOR1(' WRBUDG: ERROR ON PBOPEN CALL')
      ENDIF
      CALL PBWRITE(IUGG,IGRIB,IWORD*NINTLEN,IERR)
      IF( IERR < 0 )THEN
        CALL ABOR1(' WRBUDG: ERROR ON PBWRITE CALL')
      ENDIF
      CALL PBCLOSE(IUGG,IERR)
      IF( IERR /= 0 )THEN
        CALL ABOR1(' WRBUDG: ERROR ON PBCLOSE CALL')
      ENDIF
    ENDIF
  ENDIF

ENDIF

X1APNH = 0.0_JPRB
X2APNH = 0.0_JPRB
X3APNH = 0.0_JPRB
X1BPNH = 0.0_JPRB
X2BPNH = 0.0_JPRB
X3BPNH = 0.0_JPRB
X1APSH = 0.0_JPRB
X2APSH = 0.0_JPRB
X3APSH = 0.0_JPRB
X1BPSH = 0.0_JPRB
X2BPSH = 0.0_JPRB
X3BPSH = 0.0_JPRB
XSP    = 0.0_JPRB

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

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