SUBROUTINE WRPGR(CDFNAM,KYEAR,KMONTH,KDAY,KHOUR,KMIN,KSTEP)

!**** *WRPGR *  - DDH output : code and write out pseudogrib

!     Purpose.
!     --------
!     Prepare for pseudo-grib coding of DDH data by creating pseudo-grib
!     header and integer section from index and integer data. Code by
!     calling CODEPS. Write out coded data.

!**   Interface.
!     ----------
!        *CALL* *WRPGR(..)*

!        Explicit arguments :     CDFNAM - file name
!        --------------------     KYEAR  - year of run
!                                 KMONTH - month of run
!                                 KDAY   - day
!                                 KHOUR  - hour
!                                 KMIN   - minute
!                                 KSTEP  - time step

!        Implicit arguments :      None.
!        --------------------

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

!     Externals.   CODEPS  - code pseudo-grib
!     ----------   PB..    - PB routines

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

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

!     Modifications.
!     --------------
!        Original : 93-03-01
!        Modified : 02-06-10 by D.Dent - improved DDH restart handling
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE YOMLUN   , ONLY : NULERR
USE YOMPGO   , ONLY : NPTCH    ,NPTIN    ,NPTRE    ,NPTIND   ,&
 & NLENIND  ,NLENINT  
USE YOMPGOM  , ONLY : CHAPG    ,REAPG    ,NINDPG   ,NINTPG
USE YOMMSC   , ONLY : NINTLEN

IMPLICIT NONE

CHARACTER(LEN=14) ,INTENT(IN)    :: CDFNAM 
INTEGER(KIND=JPIM),INTENT(IN)    :: KYEAR 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMONTH 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDAY 
INTEGER(KIND=JPIM),INTENT(IN)    :: KHOUR 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMIN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTEP 
CHARACTER :: CLNAME*4
INTEGER(KIND=JPIM) :: INTPG(NLENIND+NLENINT)
INTEGER(KIND=JPIM) :: IPSCOD((NPTCH+NPTIN+NPTRE/2+NPTIND+1000)*2)
INTEGER(KIND=JPIM) :: IB1PAR(18)
CHARACTER (LEN = 9) ,DIMENSION(3)  :: CLFNAM=(/'         ','         ','         '/)
INTEGER(KIND=JPIM) :: IUDDH(3)
SAVE IUDDH

INTEGER(KIND=JPIM) :: IBIT, IBYTE, IERR, IFILE, ILENIN, ILENLG,&
 & ILENPS, IROUND, IRSERV, IWORD, J  

LOGICAL :: LLGPG
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

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

!*       1.  PREPARE FOR WRITING OUT PSEUDO-GRIB.
!            ------------------------------------

!*       1.1  GRIB HEADER

IF (LHOOK) CALL DR_HOOK('WRPGR',0,ZHOOK_HANDLE)
IB1PAR(1 )=98
IB1PAR(2 )=1
IB1PAR(3 )=1
IB1PAR(4 )=0
IB1PAR(5 )=0
IB1PAR(6 )=0
IB1PAR(7 )=0
IB1PAR(8 )=0
IB1PAR(9 )=KYEAR
IB1PAR(10)=KMONTH
IB1PAR(11)=KDAY
IB1PAR(12)=KHOUR
IB1PAR(13)=KMIN
IB1PAR(18)=0
IF (KSTEP <= 255) THEN
  IB1PAR(14) = 1
  IB1PAR(15) = KSTEP
  IB1PAR(17) = 1
ELSEIF (KSTEP <= 65535) THEN
  IB1PAR(14) = 1
  IB1PAR(15) = KSTEP
  IB1PAR(17) = 10
ENDIF

!*       1.2  ADJUST POINTERS TO POINT TO END OF DATA

NPTCH=NPTCH-1
NPTIN=NPTIN-1
NPTRE=NPTRE-1

!*       1.3  CREATE INTEGER SECTION FROM INDEX AND INTEGER DATA

DO J=1,NPTIND
  INTPG(J)=NINDPG(J)
  IF(INTPG(J) < 0) THEN
    INTPG(J)=INTPG(J)-NPTIND
  ENDIF
ENDDO
DO J=1,NPTIN
  INTPG(J+NPTIND)=NINTPG(J)
ENDDO
ILENIN=NPTIND+NPTIN

!*       1.4  CREATE PSEUDO-GRIB

CLNAME='DIAG'
IBYTE=4
ILENLG=0
ILENPS=SIZE(IPSCOD)
IRSERV=0
IBIT=NINTLEN*8
IROUND=1
CALL CODEPS(CLNAME,CHAPG,NPTCH,REAPG,NPTRE,INTPG,ILENIN,&
 & IBYTE,LLGPG,ILENLG,IB1PAR,IPSCOD,ILENPS,&
 & IRSERV,IBIT,IWORD,IROUND,IERR)  
IF(IERR /= 0) THEN
  WRITE(NULERR,*)'WRPGR: ERROR IN CODEPS - IERR= ',IERR
  CALL ABOR1('WRPGR: ERROR IN CODEPS')
ENDIF

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

!*       2.  WRITE OUT PSEUDO-GRIB.
!            ----------------------

!*       2.2  OPEN, WRITE AND CLOSE FILE

DO J=1,3
  IFILE=J
  IF(CDFNAM(1:9) == CLFNAM(J)) THEN
    EXIT
  ELSEIF(CLFNAM(J) == '         ') THEN
    CLFNAM(J)=CDFNAM(1:9)
!     N.B.  use append mode to allow for and existing file when restarting
    CALL PBOPEN(IUDDH(IFILE),CLFNAM(IFILE),'a',IERR)
    IF(IERR /= 0) THEN
      WRITE(NULERR,*)'WRPGR: ERROR IN PBOPEN - IERR= ',IERR
      CALL ABOR1('WRPGR: ERROR IN PBOPEN')
    ENDIF
    EXIT
  ENDIF
ENDDO

CALL PBWRITE(IUDDH(IFILE),IPSCOD,IWORD*NINTLEN,IERR)
IF(IERR < 0) THEN
  WRITE(NULERR,*)'WRPGR: ERROR IN PBWRITE - IERR= ',IERR
  CALL ABOR1('WRPGR: ERROR IN PBWRITE')
ENDIF
!      CALL PBCLOSE(IUDDH,IERR)
!      IF(IERR.NE.0) THEN
!        WRITE(NULERR,*)'WRPGR: ERROR IN PBCLOSE - IERR= ',IERR
!        CALL ABOR1('WRPGR: ERROR IN PBCLOSE')
!      ENDIF

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

!*       3.  RELEASE SPACE.
!            --------------

DEALLOCATE(NINDPG)
DEALLOCATE(NINTPG)
DEALLOCATE(REAPG )

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

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

