MODULE grib_header_mix

!     Purpose.
!     --------
!       Data structure for GRIB headers.

!     Author.
!     -------
!        Y. Tremolet *ECMWF*

!     Modifications.
!     --------------
!        Original : 2001-11-08
!        Y.Tremolet    17-Fev-2005 Allow for higher resolution fields
!     ------------------------------------------------------------------

USE PARKIND1, ONLY: JPIM     ,JPRB
USE PARDIM  , ONLY: JPMXLE, JPMXGL
USE YOMCT0  , ONLY: LFPOS
USE YOMHOOK , ONLY: LHOOK,   DR_HOOK
USE YOMGRB  , ONLY: RSEC2, RSEC3,SSEC2,SSEC3
USE YOMMSC  , ONLY: NINTLEN
USE YOMLUN  , ONLY: NULERR

IMPLICIT NONE

SAVE 
PRIVATE
PUBLIC grib_header, allocate_grib_header, deallocate_grib_header, &
     & init_grib_header, preset_grib_head

TYPE grib_header
  INTEGER(KIND=JPIM) :: nsec0(2)
  INTEGER(KIND=JPIM) :: nsec1(2048)
  INTEGER(KIND=JPIM) :: nsec2sp(22)
  INTEGER(KIND=JPIM) :: nsec3(2)
  INTEGER(KIND=JPIM) :: nsec4gg(59)
  INTEGER(KIND=JPIM) :: nsec4sp(59)
  REAL(KIND=JPRB) :: rsec3(2)
  INTEGER(KIND=JPIM),POINTER :: nsec2gg(:)
  REAL(KIND=JPRB),POINTER :: rsec2(:)
END TYPE grib_header

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

CONTAINS

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

SUBROUTINE allocate_grib_header(YDHEAD)

IMPLICIT NONE

TYPE (grib_header), INTENT(INOUT) :: YDHEAD
INTEGER(KIND=JPIM) :: isize
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:ALLOCATE_GRIB_HEADER',0,ZHOOK_HANDLE)
ALLOCATE(YDHEAD%nsec2gg( 22+JPMXGL ))

isize=10+2*(JPMXLE+1)
IF (ALLOCATED(RSEC2)) isize=MAX(isize,SIZE(RSEC2))
ALLOCATE(YDHEAD%rsec2(isize))

IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:ALLOCATE_GRIB_HEADER',1,ZHOOK_HANDLE)
END SUBROUTINE allocate_grib_header

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

SUBROUTINE deallocate_grib_header(YDHEAD)

IMPLICIT NONE

TYPE (grib_header), INTENT(INOUT) :: YDHEAD
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:DEALLOCATE_GRIB_HEADER',0,ZHOOK_HANDLE)
DEALLOCATE(YDHEAD%nsec2gg)
DEALLOCATE(YDHEAD%rsec2)

IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:DEALLOCATE_GRIB_HEADER',1,ZHOOK_HANDLE)
END SUBROUTINE deallocate_grib_header

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

SUBROUTINE init_grib_header(CD_CFILE,ldgrid,YDHEAD)

IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: CD_CFILE
LOGICAL, INTENT(IN) :: ldgrid
TYPE(GRIB_HEADER), INTENT(OUT) :: YDHEAD

INTEGER(KIND=JPIM) :: jlen, ierr, ilen, iunit, ibyte, jsec2
INTEGER(KIND=JPIM),ALLOCATABLE :: igrib(:), isec2(:)
REAL(KIND=JPRB) :: zdata(1)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:INIT_GRIB_HEADER',0,ZHOOK_HANDLE)

CALL PBOPEN(iunit,CD_CFILE,'r',ierr)
IF(ierr /= 0) THEN
  WRITE(nulerr,*) 'INIT_GRIB_HEADER: PROBLEM IN PBOPEN FOR FILE ''',&
   & CD_CFILE,''', ierr=',ierr  
  CALL ABOR1('INIT_GRIB_HEADER: PROBLEM IN PBOPEN')
ENDIF

CALL PBSIZE(iunit,ibyte)
IF(ibyte <= 0) THEN
  WRITE(nulerr,*) 'INIT_GRIB_HEADER: PROBLEM IN PBSIZE'
  WRITE(nulerr,*) 'FILENAME=''',CD_CFILE,''', ierr=',ibyte
  CALL ABOR1('INIT_GRIB_HEADER: PROBLEM IN PBSIZE')
ENDIF

jlen=ibyte/nintlen+1
ALLOCATE(igrib(jlen))

CALL PBGRIB(iunit,igrib,ibyte,ilen,ierr)
IF(ierr /= 0) THEN
  WRITE(nulerr,*) 'INIT_GRIB_HEADER: PROBLEM IN PBGRIB'
  WRITE(nulerr,*) 'FILENAME=''',CD_CFILE,''', ierr=',ierr
  CALL ABOR1('INIT_GRIB_HEADER: PROBLEM IN PBGRIB')
ENDIF

CALL PBCLOSE(iunit,ierr)
IF(ierr /= 0) THEN
  WRITE(nulerr,'(A,I2)')'INIT_GRIB_HEADER: PROBLEM IN PBCLOSE, ierr=',ierr
  CALL ABOR1('INIT_GRIB_HEADER: PROBLEM IN PBCLOSE')
ENDIF

ilen = ilen/nintlen
! Header for grid point or spectral fields
! ----------------------------------------
IF (LDGRID) THEN
  jsec2=jlen ! Big enough to hold all igrib...
  ALLOCATE(isec2(jsec2))

  CALL GRIBEX(YDHEAD%nsec0,YDHEAD%nsec1,isec2, &
   & YDHEAD%rsec2,YDHEAD%nsec3,YDHEAD%rsec3, &
   & YDHEAD%nsec4gg,zdata,1,igrib,jlen,ilen,'J',ierr)

  IF (jsec2<22+isec2(3)) CALL ABOR1('INIT_GRIB_HEADER: isec2 too small')
  jsec2=22+isec2(3)
  IF (SIZE(YDHEAD%nsec2gg)<jsec2) THEN
    DEALLOCATE(YDHEAD%nsec2gg)
    ALLOCATE(YDHEAD%nsec2gg(jsec2))
  ENDIF
  YDHEAD%nsec2gg(1:jsec2)=isec2(1:jsec2)
  DEALLOCATE(isec2)
ELSE
  CALL GRIBEX(YDHEAD%nsec0,YDHEAD%nsec1,YDHEAD%nsec2sp, &
   & YDHEAD%rsec2,YDHEAD%nsec3,YDHEAD%rsec3, &
   & YDHEAD%nsec4sp,zdata,1,igrib,jlen,ilen,'J',ierr)
ENDIF
IF (ierr /= 0) THEN
  write(nulerr,*) 'INIT_GRIB_HEADER: GRIBEX returned error code ',ierr
  CALL ABOR1 ('INIT_GRIB_HEADER: error in GRIBEX')
ENDIF

DEALLOCATE(igrib)

IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:INIT_GRIB_HEADER',1,ZHOOK_HANDLE)
END SUBROUTINE init_grib_header

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

SUBROUTINE preset_grib_head(YDHEAD,KGRIB,KLEV,CDREPR,CDLTYPE, &
                          & PDATA,KSMAX,KPTS,KSECLOC,LDGEOPRESET)

IMPLICIT NONE
TYPE(GRIB_HEADER) , INTENT(INOUT) :: YDHEAD
INTEGER(KIND=JPIM), INTENT(IN)    :: KGRIB
INTEGER(KIND=JPIM), INTENT(IN)    :: KLEV 
CHARACTER(LEN=*)  , INTENT(IN)    :: CDREPR
CHARACTER(LEN=*)  , INTENT(IN)    :: CDLTYPE
REAL(KIND=JPRB)   , OPTIONAL, INTENT(IN) :: PDATA(:)
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KSMAX
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KPTS
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KSECLOC(:)
LOGICAL           , OPTIONAL, INTENT(IN) :: LDGEOPRESET

INTEGER(KIND=JPIM) :: ibgn, iend, jj
REAL(KIND=JPRB) :: ZHOOK_HANDLE
LOGICAL :: LLGEOPRESET
IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:PRESET_GRIB_HEAD',0,ZHOOK_HANDLE)

LLGEOPRESET = .FALSE.
IF(PRESENT(LDGEOPRESET)) LLGEOPRESET=LDGEOPRESET
IF (cdrepr=='SH') THEN
  IF (PRESENT(PDATA)) THEN
    IF (PRESENT(ksmax)) THEN
      CALL PREGRBENC(kgrib,klev,cdrepr,cdltype, &
         & YDHEAD%nsec0,YDHEAD%nsec1,YDHEAD%nsec2sp, &
         & YDHEAD%nsec3,YDHEAD%nsec4sp, &
         & PDATA=PDATA,KSMAX=ksmax,LDGEOPRESET=LLGEOPRESET)
    ELSE
      CALL PREGRBENC(kgrib,klev,cdrepr,cdltype, &
         & YDHEAD%nsec0,YDHEAD%nsec1,YDHEAD%nsec2sp, &
         & YDHEAD%nsec3,YDHEAD%nsec4sp, &
         & PDATA=PDATA,LDGEOPRESET=LLGEOPRESET)
    ENDIF
  ELSE
    IF (PRESENT(ksmax)) THEN
      CALL PREGRBENC(kgrib,klev,cdrepr,cdltype, &
         & YDHEAD%nsec0,YDHEAD%nsec1,YDHEAD%nsec2sp, &
         & YDHEAD%nsec3,YDHEAD%nsec4sp, &
         & KSMAX=ksmax,LDGEOPRESET=LLGEOPRESET)
    ELSE
      CALL PREGRBENC(kgrib,klev,cdrepr,cdltype, &
         & YDHEAD%nsec0,YDHEAD%nsec1,YDHEAD%nsec2sp, &
         & YDHEAD%nsec3,YDHEAD%nsec4sp,LDGEOPRESET=LLGEOPRESET)
    ENDIF
  ENDIF
ELSEIF(cdrepr=='GG') THEN
  IF (PRESENT(kpts)) THEN
    CALL PREGRBENC(kgrib,klev,cdrepr,cdltype, &
       & YDHEAD%nsec0,YDHEAD%nsec1,YDHEAD%nsec2gg, &
       & YDHEAD%nsec3,YDHEAD%nsec4gg, &
       & KPTS=kpts,LDGEOPRESET=LLGEOPRESET)
  ELSE
    CALL PREGRBENC(kgrib,klev,cdrepr,cdltype, &
       & YDHEAD%nsec0,YDHEAD%nsec1,YDHEAD%nsec2gg, &
       & YDHEAD%nsec3,YDHEAD%nsec4gg,LDGEOPRESET=LLGEOPRESET)
  ENDIF
ELSE
  CALL ABOR1('GRIB_HEADER_MIX:PRESET_GRIB_HEAD: Unknown representation')
ENDIF

IF (PRESENT(KSECLOC)) THEN
  ibgn=37
  iend=SIZE(KSECLOC)

  IF (iend<ibgn) &
    & CALL ABOR1('GRIB_HEADER_MIX:PRESET_GRIB_HEAD: KSECLOC too short')
  IF (iend>SIZE(YDHEAD%nsec1)) &
    & CALL ABOR1('GRIB_HEADER_MIX:PRESET_GRIB_HEAD: KSECLOC too long')

  DO jj=ibgn,iend
    IF (KSECLOC(jj)/=-999) YDHEAD%nsec1(jj)=KSECLOC(jj)
  ENDDO
  IF (YDHEAD%nsec1(39)==33.OR.YDHEAD%nsec1(39)==35) THEN
    YDHEAD%nsec1(1)=200
  ENDIF
ENDIF

! I know the following is horrible/MH
IF(LFPOS) THEN
  IF (ALLOCATED(SSEC2)) THEN
    YDHEAD%rsec2(1:SIZE(SSEC2))=SSEC2(:)
    YDHEAD%rsec3(:)=SSEC3(:)
  ELSE
    CALL ABOR1('GRIB_HEADER_MIX:PRESET_GRIB_HEAD: SSEC2 not allocated')
  ENDIF
ELSE
  IF (ALLOCATED(RSEC2)) THEN
    YDHEAD%rsec2(1:SIZE(RSEC2))=RSEC2(:)
    YDHEAD%rsec3(:)=RSEC3(:)
  ELSE
    CALL ABOR1('GRIB_HEADER_MIX:PRESET_GRIB_HEAD: RSEC2 not allocated')
  ENDIF
ENDIF

IF (LHOOK) CALL DR_HOOK('GRIB_HEADER_MIX:PRESET_GRIB_HEAD',1,ZHOOK_HANDLE)
END SUBROUTINE preset_grib_head

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

END MODULE grib_header_mix
