      PROGRAM DCHANGE
      IMPLICIT NONE
C
      INTEGER JPACK, JPBYTES
      PARAMETER (JPACK = 280000)
      PARAMETER (JPBYTES = 4)
      REAL MAXFLT
      PARAMETER (MAXFLT = 2147483647.0)
C
      INTEGER ISEC0(2),ISEC1(1024),ISEC2(1024),ISEC3(2),ISEC4(512)
      INTEGER IUSEC0(2),IUSEC1(1024),IUSEC2(1024),IUSEC3(2), IUSEC4(512)
C
      REAL ZSEC2(512),ZSEC3(2),ZSEC4(JPACK*4),USEC4(JPACK*4)
      INTEGER INBUFF(JPACK)
      INTEGER IRET, FILE1, FILE2, JCOUNT
      INTEGER ILENB, LENOUT, IPUNP, IWORD, LOOP
C
      CHARACTER*4 CNMEXP
      CHARACTER*128 INFILE, OUTFILE, NAMFILE
      INTEGER IJDC, IARGC
cs      EXTERNAL IARGC, GETENV
C
      NAMELIST /USHEAD/IUSEC0,IUSEC1,IUSEC2,IUSEC3,IUSEC4,CNMEXP
C
C     -----------------------------------------------------------------|
C
      IJDC = IARGC()
      IF( IJDC.LT.3 ) THEN
        WRITE(*,*) 'Usage: Dchange_grib namelist input output'
        STOP 'Faulty program options'
      ENDIF
C
      CALL GETARG(1,NAMFILE)
      CALL GETARG(2,INFILE)
      CALL GETARG(3,OUTFILE)
C
C     Open the input file
C
      CALL PBOPEN(FILE1, INFILE, "R", IRET)
      IF( IRET.NE.0 ) THEN
        WRITE(*, *) 'Return code from PBOPEN = ',IRET
        CALL PBCLOSE(FILE1, IRET)
        STOP 'Fault in PBOPEN opening input file'
      ENDIF
C
C     Open the output file
C
      CALL PBOPEN(FILE2, OUTFILE, "w", IRET)
      IF( IRET.NE.0 ) THEN
        WRITE (*, *) 'Return code from PBOPEN = ',IRET
        STOP 'Fault in PBOPEN opening output file'
      ENDIF
C
C     -----------------------------------------------------------------|
C
C     Initialize namelist, read input
C
      DO LOOP =1,2
        IUSEC3(LOOP)=-999
      ENDDO
C
      DO LOOP=1,1024
        IUSEC1(LOOP)=-999
      ENDDO
C
      DO LOOP=1,1024
        IUSEC2(LOOP)=-999
      ENDDO
C
      DO LOOP=1,512
        IUSEC4(LOOP)=-999
      ENDDO
C
      CNMEXP='9999'
C
      OPEN(12,FILE=NAMFILE,FORM='FORMATTED',STATUS='OLD',ERR=900)
C
      READ(12,USHEAD)
C      
      DO LOOP=1,1024
        IF(IUSEC1(LOOP).NE.-999) THEN
          WRITE(*,*)
     X      "Element ",LOOP," of header 1 changed to ",IUSEC1(LOOP)
        ENDIF
      ENDDO   
C
      IF (CNMEXP(1:4).NE.'9999') WRITE(*,*)
     1   "EXPVER (element 41 of header 1) changed to ",CNMEXP(1:4)


      DO LOOP=1,1024
        IF(IUSEC2(LOOP).NE.-999) THEN
          WRITE(*,*)
     X      "Element ",LOOP," of header 2 changed to ",IUSEC2(LOOP)
        ENDIF
      ENDDO
C
      DO LOOP=1,2
        IF(IUSEC3(LOOP).NE.-999) THEN
          WRITE(*,*)
     X      "Element ",LOOP," of header 3 changed to ",IUSEC3(LOOP)
        ENDIF
      ENDDO
C   
      DO LOOP=1,512
        IF(IUSEC4(LOOP).NE.-999) THEN
          WRITE(*,*)
     X      "Element ",LOOP," of header 4 changed to ",IUSEC4(LOOP)
        ENDIF
      ENDDO
C
C     -----------------------------------------------------------------|
C
      JCOUNT = 0
C
   50 CONTINUE
C
C     Read packed field into INBUFF.
C
      ILENB = JPACK*JPBYTES
      CALL PBGRIB(FILE1, INBUFF, ILENB, LENOUT, IRET )
      IF( IRET.LT.0 ) THEN
        IF( IRET.EQ.-1 ) THEN
C
          CALL PBCLOSE(FILE2, IRET)
          IF( IRET.LT.0 ) THEN
            WRITE(*, *) 'Return code from PBCLOSE = ',IRET
            STOP 'Fault in PBCLOSE closing output file'
          ENDIF
C
          CALL PBCLOSE(FILE1, IRET)
          WRITE(*, *) 'Number of GRIB products changed = ',JCOUNT
          STOP 'End-of-file for input'
        ELSE
          WRITE (*, *) 'Return code from PBGRIB = ',IRET
          CALL PBCLOSE(FILE1, IRET)
          WRITE(*,*) 'Fault in PBGRIB reading product number ', JCOUNT
          STOP 'Fault in PBGRIB reading product'
        ENDIF
      ENDIF
C
      JCOUNT = JCOUNT + 1
C
C     Unpack GRIB message.
C
      ZSEC3(2) = -MAXFLT
      ISEC3(2) = INT(ZSEC3(2))
      IRET = 1
      IPUNP = JPACK * JPBYTES
      ILENB = (LENOUT + (JPBYTES-1))/JPBYTES
      CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4,
     X             ZSEC4,IPUNP,INBUFF,ILENB,IWORD,'D',IRET)
      IF( IRET.GT.0 ) THEN
        WRITE(*,*) 'GRIBEX problem decoding product ',JCOUNT
        WRITE(*,*) 'GRIBEX return code = ',IRET
        STOP 'GRIBEX error'
      ENDIF
C
C     -----------------------------------------------------------------|
C
C     Repack the field and write to results file
C
C
C     Changes the header, according to user requests
C
      DO LOOP=1,1024
        IF(IUSEC1(LOOP).NE.-999) ISEC1(LOOP)=IUSEC1(LOOP)
      ENDDO
C
      IF (CNMEXP(1:4).NE.'9999')  READ(CNMEXP,'(A4)') ISEC1(41)
C
      DO LOOP=1,1024
        IF(IUSEC2(LOOP).NE.-999) ISEC2(LOOP)=IUSEC2(LOOP)
      ENDDO
C
      DO LOOP=1,2
        IF(IUSEC3(LOOP).NE.-999) ISEC3(LOOP)=IUSEC3(LOOP)
      ENDDO
C
      DO LOOP=1,512
        IF(IUSEC4(LOOP).NE.-999) ISEC4(LOOP)=IUSEC4(LOOP)
      ENDDO
C
      IRET = 1
      IPUNP = ISEC4(1)
      ILENB = JPACK
      CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4,
     X             ZSEC4,IPUNP,INBUFF,ILENB,IWORD,'C',IRET)
      IF( IRET.GT.0 ) THEN
        WRITE(*,*) 'GRIBEX problem encoding product ',JCOUNT
        WRITE(*,*) 'GRIBEX return code = ',IRET
        STOP 'GRIBEX error'
      ENDIF
C
      LENOUT = IWORD * JPBYTES
      CALL PBWRITE(FILE2, INBUFF, LENOUT, IRET)
      IF( IRET.LT.LENOUT ) THEN
        WRITE(*,*) 'Problem writing product ',JCOUNT
        WRITE(*,*) 'Return code from PBWRITE = ',IRET
        STOP 'Fault in PBWRITE'
      ENDIF
C
C     -----------------------------------------------------------------|
C
      GOTO 50
C
  900 CONTINUE
C
      WRITE(*, *) 'Namelist OPEN failed'
C
      STOP
      END
