PROGRAM MODIFY_GRIB
!
!     CHANGES THE HEADERS OF ALL GRIB FIELDS CONTAINED IN A FILE
!
!     Written by D.Dent  (20/11/2001)

!     Interface:  modify_grib -i input_file -o output_file -n namelist_file [-d]

!     Parameters:
!                 -i   input_file, containing GRIB fields
!                 -o   output_file, contains the same GRIB fields
!                                   with modified headers
!                 -n   namelist_file, containing Fortran namelist format data
!                      namelist USHEAD
!                      allows details ofchanges to header fields to be specified
!                 -d   optional flag to force decoding/recoding

!     This program is derived from:
!        change_grib    (Pedro Viterbo)
!        changeGrib     (John Chambers)
!        fix_local_grib (Jan Haseler)
!     and combines all of the requirements in one application.
!
!     Features:
!      (1) Do not decode/encode unless necessary
!          This is achieved by calling the C-coded routine 'chgrib'
!      (2) The input fields are decode/recoded:
!            if the namelist input requires a change in packing density
!            if a command line flag is provided (-d)
!          This option also imposes an ECMWF local GRIB definition
!          The output is GRIB coded using option 'M' to ensure that
!          fields which contain missing data are kept to a constant length
!          

PARAMETER(JPPKLEN=0,JPUNPKLEN=2000000, &
    JPMAXLEV=200,JD1=1024,JD2=4096,JD4=1024,JLV=10+JPMAXLEV)

!  IMPLICIT NONE

INTEGER :: IOPTVAL
LOGICAL :: LLDECODE
CHARACTER*16  :: CLOPTP='i:o:n:d'
CHARACTER*64  :: CL_USAGE
CHARACTER*128 :: CLARG
CHARACTER*128 :: CL_NAMELIST_FILE,CL_INPUT_FILE,CL_OUTPUT_FILE
CHARACTER*1   :: CLOPT

INTEGER ISEC0(2),ISEC1(JD1),ISEC2(JD2),ISEC3(2),ISEC4(JD4)
INTEGER IUSEC0(2),IUSEC1(JD1),IUSEC2(JD2),IUSEC3(2), IUSEC4(JD4)
INTEGER,ALLOCATABLE :: IGRIB(:)
INTEGER :: IPPKLEN=JPPKLEN
INTEGER :: IUNPKLEN=JPUNPKLEN
INTEGER GETOPT
INTEGER CHGRIB

REAL*8,ALLOCATABLE :: ZUNP(:)
REAL*8  ZSEC2(JLV),ZSEC3(2)

CHARACTER*4 CNMEXP
NAMELIST /USHEAD/IUSEC0,IUSEC1,IUSEC2,IUSEC3,IUSEC4,CNMEXP

!
!    read input parameters
!
CL_NAMELIST_FILE=""
CL_INPUT_FILE=""
CL_OUTPUT_FILE=""
CL_USAGE='Usage: modify_grib -i input_file -o output_file -n namelist_file [-d]'
IBYTES=4
LLDECODE=.FALSE.
IOPTVAL=GETOPT(CLOPTP,CLARG)

DO WHILE (IOPTVAL > 0)
  CLOPT=CHAR(IOPTVAL)
  IF(CLOPT == 'n') THEN
    CL_NAMELIST_FILE=CLARG
  ELSEIF(CLOPT == 'i') THEN
    CL_INPUT_FILE=CLARG
  ELSEIF(CLOPT == 'o') THEN
    CL_OUTPUT_FILE=CLARG
  ELSEIF(CLOPT == 'd') THEN
    LLDECODE=.TRUE.
  ELSE
    WRITE(0,'(A,A)') 'Invalid parameter ',CLOPT
    CALL ABORT
  ENDIF
  IOPTVAL=GETOPT(CLOPTP,CLARG)
ENDDO

IF(CL_NAMELIST_FILE == "") THEN
  WRITE(0, *) 'namelist file missing'
  WRITE(0, *) CL_USAGE
  CALL ABORT
ENDIF
IF(CL_INPUT_FILE == "") THEN
  WRITE(0, *) 'input file missing'
  WRITE(0, *) CL_USAGE
  CALL ABORT
ENDIF
IF(CL_OUTPUT_FILE == "") THEN
  WRITE(0, *) 'output file missing'
  WRITE(0, *) CL_USAGE
  CALL ABORT
ENDIF
IF(CL_INPUT_FILE == CL_OUTPUT_FILE) THEN
  WRITE(0, *) 'modify_grib: output file cannot be the same as the input file'
  WRITE(0, *) CL_USAGE
  CALL ABORT
ENDIF

!  Initialize namelist, and read namelist file
!
DO JP =1,2
  IUSEC3(JP)=-999
ENDDO
!
DO JP=1,JD1
  IUSEC1(JP)=-999
ENDDO
!
DO JP=1,JD2
  IUSEC2(JP)=-999
ENDDO
!
DO JP=1,JD4
  IUSEC4(JP)=-999
ENDDO
!
CNMEXP='9999'
!
OPEN(12,FILE=CL_NAMELIST_FILE,FORM='FORMATTED',STATUS='OLD',ERR=900)
!
READ(12,USHEAD)
!
DO JP=1,JD1
  IF(IUSEC1(JP).NE.-999) THEN
    WRITE(*,*) &
   "Element ",JP," of header 1 changed to ",IUSEC1(JP)
  ENDIF
ENDDO
!
IF (CNMEXP(1:4).NE.'9999') THEN
  WRITE(*,*) &
    "EXPVER (element 41 of header 1) changed to ",CNMEXP(1:4)
ENDIF
!
DO JP=1,JD2
  IF(IUSEC2(JP).NE.-999) THEN
    WRITE(*,*) &
      "Element ",JP," of header 2 changed to ",IUSEC2(JP)
  ENDIF
ENDDO
DO JP=1,2
  IF(IUSEC3(JP).NE.-999) THEN
    WRITE(*,*) &
    "Element ",JP," of header 3 changed to ",IUSEC3(JP)
  ENDIF
ENDDO
!
DO JP=1,JD4
  IF(IUSEC4(JP).NE.-999) THEN
    WRITE(*,*) &
      "Element ",JP," of header 4 changed to ",IUSEC4(JP)
   ENDIF
ENDDO
!
IF(IUSEC4(2) /= -999) LLDECODE=.TRUE.

IF(LLDECODE) THEN

  WRITE(*, *) 'Grib fields will be re-coded '
!
!      Open input GRIB file
!
  CALL PBOPEN(FILE1, CL_INPUT_FILE, "R", IRET)
  IF( IRET.NE.0 ) THEN
    WRITE(*, *) 'Return code from PBOPEN = ',IRET,' for file ',CL_INPUT_FILE
    CALL ABORT
  ENDIF
!
!      Open output GRIB file
!
  CALL PBOPEN(FILE2, CL_OUTPUT_FILE, "w", IRET)
  IF( IRET.NE.0 ) THEN
    WRITE (*, *) 'Return code from PBOPEN = ',IRET,' for file ',CL_OUTPUT_FILE
    CALL ABORT
  ENDIF

!    allocate space

  IF(IPPKLEN > 0) ALLOCATE(IGRIB(IPPKLEN))
  IF(IUNPKLEN > 0) ALLOCATE(ZUNP(IUNPKLEN))

!    decode and recode each field

  IFLD=0
  READ_LOOP:DO

!     Read packed field
!
    CALL PBSIZE(FILE1, IRET )
    IF( IRET <= 0 ) THEN
      IF(IRET < 0)  write(*,*)'PBSIZE RETURNED ',IRET
      EXIT READ_LOOP
    ELSE
      IF(IRET > IPPKLEN) THEN
!     write(*,*) ' re-allocate IGRIB from ',IPPKLEN,' to ',IRET
        IF(ALLOCATED(IGRIB)) DEALLOCATE(IGRIB)
        IPPKLEN=IRET
        ALLOCATE(IGRIB(IPPKLEN))
      ENDIF
    ENDIF
    CALL PBGRIB(FILE1, IGRIB, IBYTES*IPPKLEN , ILENOUT, IRET )
!
    IF(IRET == -3 ) THEN
!     IGRIB array is too small

      write(*,*)' IGRIB array too small ',IPPKLEN
      CALL ABORT
  
    ELSE IF(IRET < -1 ) THEN
      write(*,*) ' problems reading the grib file  iret= ',iret
      CALL ABORT
    ENDIF
!
    IFLD = IFLD + 1

!     find size of field to be decoded and allocate space for it

!     Unpack GRIB headers
!
    IRET = 0
    CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4, &
                 ZUNP,IUNPKLEN,IGRIB,IPPKLEN,IWORD,'J',IRET)
    IF( IRET.GT.0 ) THEN
        WRITE(0,*) 'GRIBEX problem decoding headers for ',IFLD
        WRITE(0,*) 'GRIBEX return code = ',IRET
        CALL ABORT
    ENDIF
!
    IFIELD_SIZE=ABS(ISEC4(1))
    IF(SIZE(ZUNP) < IFIELD_SIZE) THEN
      IUNPKLEN=IFIELD_SIZE
!     write(*,*)' ZUNP too small ',SIZE(ZUNP),IFIELD_SIZE
    ENDIF
    IF(ALLOCATED(ZUNP) .AND. SIZE(ZUNP) < IFIELD_SIZE) THEN
      DEALLOCATE(ZUNP)
!     write(*,*)' ZUNP de-allocated ',IUNPKLEN
    ENDIF
    IF(.NOT.ALLOCATED(ZUNP)) THEN
      ALLOCATE(ZUNP(IUNPKLEN))
!     write(*,*)' ZUNP allocated ',IUNPKLEN
    ENDIF
!
!     The missing data value must be specified in case the field
!     contains a bit mask

    ISEC3(2) = -999999999
    ZSEC3(2) = -999999999.0

!     Unpack GRIB message.
!
    IRET = 0
    CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4, &
                 ZUNP,IUNPKLEN,IGRIB,IPPKLEN,IWORD,'D',IRET)
    IF( IRET.GT.0 ) THEN
        WRITE(0,*) 'GRIBEX problem decoding product ',IFLD
        WRITE(0,*) 'GRIBEX return code = ',IRET
        CALL ABORT
    ENDIF
!
!     -----------------------------------------------------------------|
!
!     Repack the field and write to results file
!
!
!     Changes the header, according to user requests
!
    DO JP=1,JD1
      IF(IUSEC1(JP).NE.-999) THEN
        ISEC1(JP)=IUSEC1(JP)
      ENDIF
    ENDDO
!
    IF (CNMEXP(1:4).NE.'9999') THEN
        READ(CNMEXP,'(A4)') ISEC1(41)
    ENDIF
!
    DO JP=1,JD2
      IF(IUSEC2(JP).NE.-999) THEN
        ISEC2(JP)=IUSEC2(JP)
      ENDIF
    ENDDO
    DO JP=1,2
      IF(IUSEC3(JP).NE.-999) THEN
        ISEC3(JP)=IUSEC3(JP)
      ENDIF
    ENDDO
!
    DO JP=1,JD4
      IF(IUSEC4(JP).NE.-999) THEN
        ISEC4(JP)=IUSEC4(JP)
       ENDIF
    ENDDO

!     Add local GRIB definition, if it is missing for invariant fields
!
    IF (ISEC1(24) == 0) then
      WRITE(*,*) ' Add local GRIB definition for parameter',ISEC1(6)
      ISEC1(24)=1
     
      DO J=25,36
        IF(IUSEC1(J).NE.-999) THEN
          ISEC1(J)=IUSEC1(J)
        ELSE
          ISEC1(J)=0
        ENDIF
      ENDDO

      DO J=37,43
        IF (IUSEC1(j) == -999) then
          localdef:  SELECT CASE(J)
            CASE(37)            !  local definition type 1
              ISEC1(37)=1
            CASE(38)            !  class (default rd)
              ISEC1(38)=2
            CASE(39)            !  type (default an)
              ISEC1(39)=2
            CASE(40)            !  stream (default daily archive)
              ISEC1(40)=1025
            CASE(41)            !  expver
              IF (CNMEXP(1:4).NE.'9999') THEN
                READ(CNMEXP,'(A4)') ISEC1(41)
              ENDIF
            CASE(42)            !  mars labelling (default simple)
              ISEC1(42)=0
            CASE(43)            !  ensemble (default no)
              ISEC1(43)=0
          END SELECT localdef
        ELSE
          ISEC1(J)=IUSEC1(J)
        ENDIF
      ENDDO

      DO J=44,JD1
        IF(IUSEC1(J).NE.-999) THEN
          ISEC1(J)=IUSEC1(J)
        ELSE
          ISEC1(J)=0
        ENDIF
      ENDDO

    ENDIF
!
    IRET = 1
    IPUNP = ISEC4(1)
    CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4, &
      ZUNP,IPUNP,IGRIB,IPPKLEN,IWORD,'M',IRET)
    IF( IRET.GT.0 ) THEN
      WRITE(*,*) 'GRIBEX problem encoding product ',IFLD
      WRITE(*,*) 'GRIBEX return code = ',IRET
      CALL ABORT
    ENDIF
!
    ILENOUT = IWORD * IBYTES
    CALL PBWRITE(FILE2, IGRIB, ILENOUT, IRET)
    IF( IRET.LT.ILENOUT ) THEN
      WRITE(*,*) 'Problem writing product ',IFLD
      WRITE(*,*) 'Return code from PBWRITE = ',IRET
      CALL ABORT
    ENDIF

  ENDDO READ_LOOP

  CALL PBCLOSE(FILE2, IRET)
  IF( IRET.LT.0 ) THEN
    WRITE(*, *) 'Return code from PBCLOSE = ',IRET
    CALL ABORT
  ENDIF
!
  WRITE(*, *) 'Number of GRIB products changed = ',IFLD
  CALL PBCLOSE(FILE1, IRET)
  IF( IRET.LT.0 ) THEN
    WRITE (*, *) 'Return code from PBGRIB = ',IRET
    CALL PBCLOSE(FILE1, IRET)
    WRITE(*,*) 'Fault in PBGRIB reading product number ', IFLD
    CALL ABORT
  ENDIF

  STOP

ELSE

!   no decoding/encoding

  WRITE(*, *) 'Grib fields will NOT be re-coded '
  IRET = CHGRIB(CL_NAMELIST_FILE,CL_INPUT_FILE,CL_OUTPUT_FILE)
  WRITE(0,'(A,I4)') ' CHGRIB return code ',IRET
  IF(IRET /= 0) THEN
    WRITE(0,'(A,I4)') ' CHGRIB return code ',IRET
    CALL ABORT
  ENDIF
ENDIF

STOP

900 CONTINUE
WRITE(*, *) 'Namelist OPEN failed for file ',CL_NAMELIST_FILE
CALL ABORT
!
END
