C Copyright 1981-2012 ECMWF.
C
C This software is licensed under the terms of the Apache Licence 
C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
C
C In applying this licence, ECMWF does not waive the privileges and immunities 
C granted to it by virtue of its status as an intergovernmental organisation 
C nor does it submit to any jurisdiction.
C

       PROGRAM DECODE_BUFR_IMAGE
C
C**** *DECODE_BUFR_IMAGE*
C
C
C     PURPOSE.
C     --------
C         Expnds Opera run-length encoded composite images
C         and creates image header and image file.
C
C
C**   INTERFACE.
C     ----------
C
C          NONE.
C
C     METHOD.
C     -------
C
C          NONE.
C
C
C     EXTERNALS.
C     ----------
C
C     REFERENCE.
C     ----------
C
C          NONE.
C
C     AUTHOR.
C     -------
C
C          M. DRAGOSAVAC    *ECMWF*       15/07/2008.
C
C
C     MODIFICATIONS.
C     --------------
C
C          NONE.
C
C
      IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
C
      PARAMETER(JSUP =   9,JSEC0=   3,JSEC1= 40,JSEC2=4096,JSEC3=   4,
     1          JSEC4=2,JELEM=320000,JSUBS=400,JCVAL=150 ,JBUFL=512000,
#ifdef JBPW_64
     2          JBPW =  64,JTAB =3000,JCTAB=3000,JCTST=9000,JCTEXT=9000,
#else
     2          JBPW =  32,JTAB =3000,JCTAB=3000,JCTST=9000,JCTEXT=9000,
#endif
     3          JWORK=4096000,JKEY=46, JTMAX=10,JTCLAS=64,JTEL=255)

C
      PARAMETER (JIMG=2500000)
      PARAMETER (KELEM=320000)
      PARAMETER (KVALS=4096000)
   
C 
      DIMENSION KBUFF(JBUFL)
      DIMENSION KBUFR(JBUFL)
      DIMENSION KSUP(JSUP)  ,KSEC0(JSEC0),KSEC1(JSEC1)
      DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4)
C
      REAL*8 VALUES(KVALS),VALUES_IMG(500)
      INTEGER IMAGE(JIMG)
      DIMENSION KTDLST(KELEM),KTDEXP(KELEM)
      DIMENSION KTDEXP_IMG(KELEM)
C
      CHARACTER*256 CF,COUT,CARG(4),COUT1,COUT2,COUT3
      CHARACTER*64 CNAMES(KELEM),CNAMES_IMG(KELEM)
      CHARACTER*24 CUNITS(KELEM),CUNITS_IMG(KELEM)
      CHARACTER*80 CVALS(KELEM),CVALS_IMG(KELEM)
      REAL*8 RVIND
C
C     ------------------------------------------------------------------
C*          1. INITIALIZE CONSTANTS AND VARIABLES.
C              -----------------------------------
 100  CONTINUE
C
C     MISSING VALUE INDICATOR
C 
      NBYTPW=JBPW/8
      RVIND=1.7D38
      NVIND=2147483647
      IOBS=0
      N=0
C
C
C
C     GET INPUT AND OUTPUT FILE NAME.
C
      NARG=IARGC()
C
C
      DO 104 J=1,NARG
      CALL GETARG(J,CARG(J))
 104  CONTINUE

      IF(NARG.EQ.0) THEN
         PRINT*,'USAGE -- decode_bufr_image infile'
         STOP
      END IF
C
      DO 101 II=1,NARG

      CF=CARG(II)
      ILN=INDEX(CF,' ')-1
C
C*          1.2 OPEN FILE CONTAINING BUFR DATA.
C               -------------------------------
 120  CONTINUE
C
      IRET=0 
      CALL PBOPEN(IUNIT,CF(1:ILN),'R',IRET)
      IF(IRET.EQ.-1) STOP 'OPEN FAILED'
      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
C
      COUT1=CF(1:ILN-5)//'.img'
      ILN1=INDEX(COUT1,' ')-1
      CALL PBOPEN(IUNIT1,COUT1(1:ILN1),'W',IRET)
      IF(IRET.EQ.-1) STOP 'OPEN FAILED ON *.img file'
      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
C
      COUT2=CF(1:ILN-5)//'.img_header'
      ILN2=INDEX(COUT2,' ')-1
      IUNIT2=40
      OPEN(UNIT=IUNIT2,FILE=COUT2(1:ILN2),STATUS='UNKNOWN',IOSTAT=ios)
      IF(IOS.NE.0) THEN
        PRINT*,'Open error on ',COUT2(1:ILN2)
        STOP 
      END IF
         
C
      COUT3=CF(1:ILN-5)//'.section_1'
      ILN3=INDEX(COUT3,' ')-1
      IUNIT3=41
      OPEN(UNIT=IUNIT3,FILE=COUT3(1:ILN3),STATUS='UNKNOWN',IOSTAT=ios)
      IF(IOS.NE.0) THEN
        PRINT*,'Open error on ',COUT3(1:ILN3)
        STOP 
      END IF
C
C     ----------------------------------------------------------------- 
C
C*          3.  READ BUFR MESSAGE.
C               ------------------
 300  CONTINUE
C
      IERR=0
      KBUFL=0
C
      CALL PBBUFR(IUNIT,KBUFF,JBUFL,KBUFL,IERR) 
      IF(IERR.EQ.-1) THEN
         PRINT*,'NUMBER OF SUBSETS     ',IOBS
         PRINT*,'NUMBER OF MESSAGES    ',N
         STOP 'EOF'
      END IF
      IF(IERR.EQ.-2) STOP 'FILE HANDLING PROBLEM' 
      IF(IERR.EQ.-3) STOP 'ARRAY TOO SMALL FOR PRODUCT'
C
      N=N+1
      PRINT*,'----------------------------------',N,' ',KBUFL
      KBUFL=KBUFL/NBYTPW+1
C
C     -----------------------------------------------------------------
C*          4. EXPAND BUFR MESSAGE.
C              --------------------
 400  CONTINUE
C
      CALL BUS0123( KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KSEC3,IERR)
      IF(IERR.NE.0) THEN
         PRINT*,'ERROR IN BUS012: ',IERR
         PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.'
         IERR=0
         GO TO 300
      END IF
C
      KEL=KVALS/KSEC3(3)
      IF(KEL.GT.KELEM) KEL=KELEM
C
      CALL BUFREX(KBUFL,KBUFF,KSUP,KSEC0 ,KSEC1,KSEC2 ,KSEC3 ,KSEC4,
     1            KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR)
C
      IF(IERR.NE.0) THEN
         CALL EXIT(2)
      END IF
C
      IOBS=IOBS+KSEC3(3)
C
C
      ISUBSET=1
      CALL BUSEL2(ISUBSET,KEL,KTDLEN,KTDLST,KTDEXL,KTDEXP,CNAMES,
     1            CUNITS,IERR)
C     IF(IERR.NE.0) CALL EXIT(2)
C
C     Get full image as array of pixel values

      CALL BUGET_OPERA_IMAGE(KSEC1,KTDEXL,KTDEXP,CNAMES,CUNITS,
     1      KELEM,KVALS,VALUES,CVALS,KTDEXL_IMG,KTDEXP_IMG,
     2      CNAMES_IMG,CUNITS_IMG,KVALS_IMG,VALUES_IMG,
     3      CVALS_IMG,KSIZE_IMG_BYTES,IMAGE,KPIXEL_SIZE,KERR)

c
c
C
C     Write image meta data into file
C     -------------------------------
      DO I=1,KTDEXL_IMG
      WRITE(IUNIT2,'(I6,1X,A64,1x,F20.8,1x,a24)') I,CNAMES_IMG(I),
     c                                VALUES_IMG(I),CUNITS_IMG(I)
      END DO

C
C     Write bufr section 1 into file
C     ------------------------------
      CALL BBUPRS1(IUNIT3,KSEC1)
      IMX=KSIZE_IMG_BYTES
C   
C     Write image ( pixel values ) into file
C     -----------------------------------------------------------------
      CALL PBWRITE(IUNIT1,IMAGE,IMX,IERR)
C
C
      GO TO 900 
C     -----------------------------------------------------------------
C
 810  CONTINUE
C
      WRITE(*,'(1H ,A)') 'OPEN ERROR ON INPUT FILE'
      GO TO 900
C      
 800  CONTINUE
C
      IF(IRET.EQ.-1) THEN
         PRINT*,'NUMBER OF RECORDS PROCESSED ',N
         PRINT*,'NUMBER OF OBSERVATIONS      ',IOBS
      ELSE
         PRINT*,' BUFR : ERROR= ',IERR
      END IF
C
 900  CONTINUE
C
      CALL PBCLOSE(IUNIT,IRET)
      CALL PBCLOSE(IUNIT1,IRET)
      CLOSE(IUNIT2)
      CLOSE(IUNIT3)
 101  CONTINUE
C
      END
