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 CREX2BUFR
C
C**** *CREX2BUFR*
C
C
C     PURPOSE.
C     --------
C         Decode CREX coded data into BUFR format
C
C
C**   INTERFACE.
C     ----------
C
C          NONE.
C
C     METHOD.
C     -------
C
C          NONE.
C
C
C     EXTERNALS.
C     ----------
C
C
C     REFERENCE.
C     ----------
C
C          NONE.
C
C     AUTHOR.
C     -------
C
C          MILAN DRAGOSAVAC    *ECMWF*       07/01/2004.
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=40000,
#ifdef JBPW_64
     2          JBPW =  64,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200,
#else
     2          JBPW =  32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200,
#endif
     3          JWORK=4096000,JKEY=46,JBYTE=80000)
C
      PARAMETER (KELEM=40000)
      PARAMETER (KVALS=360000)
C 
      DIMENSION KBUFF(JBUFL),KBUFR(JBUFL)
      DIMENSION KSUP(JSUP)  ,KSEC0(JSEC0),KSEC1(JSEC1)
      DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4)
      DIMENSION KEY  (JKEY),KREQ(2)
C
      REAL*8 VALUES(KVALS), VALUE(KVALS)
      REAL*8 RVIND
      REAL*8 EPS
C
      DIMENSION KTDLST(KELEM),KTDEXP(KELEM),KTDLST1(KELEM)
      DIMENSION KDATA(2000)
C
      CHARACTER*256 CF,COUT,CARG(4)
      CHARACTER*64 CNAMES(KELEM)
      CHARACTER*24 CUNITS(KELEM)
      CHARACTER*80 CVALS(KVALS)
      CHARACTER*80 CVAL(KVALS),CV
      CHARACTER*80 YENC
      CHARACTER*160000 YBUFF
c
      EQUIVALENCE(YBUFF,KBUFF(1))
C                                                                       
C     ------------------------------------------------------------------
C*          1. INITIALIZE CONSTANTS AND VARIABLES.
C              -----------------------------------
 100  CONTINUE
C
      NBYTPW=JBPW/8
      RVIND=1.7D38
      NVIND=2147483647
      IOBS=0
      EPS=10.D-8
      N=0
      OCOMP=.FALSE.
      OO=.FALSE.
      CF=' '
      COUT=' '
      KKK=0
C
C     GET INPUT AND OUTPUT FILE NAME.
C
      NARG=IARGC()
c
      IF(NARG.NE.4) THEN
         print*,'Usage -- crex2bufr -i infile -o outfile' 
         STOP
      END IF
c
      DO 101 J=1,NARG
      CALL GETARG(J,CARG(J))
 101  CONTINUE
c
      IF(CARG(1).NE.'-i'.AND.CARG(1).NE.'-I'.OR.
     1   CARG(2).EQ.' ') THEN
         print*,'Usage -- crex2bufr -i inpfile -o outfile'
         STOP
      END IF
      IF(CARG(3).NE.'-o'.AND.CARG(3).NE.'-O'.OR.
     1   CARG(4).EQ.' ') THEN
         print*,'Usage -- crex2bufr -i inpfile -o outfile'
         STOP
      END IF
c
      CF=CARG(2)
      II=INDEX(CF,' ')
      II=II-1
      COUT=CARG(4)
      I=INDEX(COUT,' ')
      I=I-1
C
C*          1.2 OPEN FILE CONTAINING CREX DATA.
C               -------------------------------
 120  CONTINUE
C
      IRET=0 
      CALL PBOPEN(IUNIT,CF(1:II),'r',IRET)
      IF(IRET.EQ.-1) STOP 'open failed on input file'
      IF(IRET.EQ.-2) STOP 'Invalid file name'
      IF(IRET.EQ.-3) STOP 'Invalid open mode specified'
c
C
C*          1.2.1 OPEN OUTPUT FILE.
C               ------------------
 121  CONTINUE
C

      CALL PBOPEN(IUNIT1,COUT(1:I),'w',IRET)
      IF(IRET.EQ.-1) STOP 'open failed on output file'
      IF(IRET.EQ.-2) STOP 'Invalid output file name'
      IF(IRET.EQ.-3) STOP 'Invalid open mode specified'
C
C     ----------------------------------------------------------------- 
C*          2. SET REQUEST FOR EXPANSION.
C              --------------------------
 200  CONTINUE
C
      NR=1
      OPRT=.TRUE.
      OENC=.FALSE.
C
      OENC=.TRUE.

 210  CONTINUE
C
C
C     -----------------------------------------------------------------
C*          3.  READ CREX MESSAGE.
C               ------------------
 300  CONTINUE
C
      IERR=0
      IRET=0
c
      CALL PBCREX(IUNIT,KBUFF,JBUFL,KBUFL,IRET)
      IF(IRET.LT.0) THEN
         if(iret.eq.-1) stop 'End of file '
         if(iret.eq.-2) stop 'Error in handling the file'
         if(iret.eq.-3) stop 'Error during read CREX file.'
      END IF
c
      N=N+1
      print*,'----------------------------------',n
      IF(N.LT.NR) GO TO 300
      KEL=KELEM
C
C     -----------------------------------------------------------------
C*          4. EXPAND CREX MESSAGE.
C              --------------------
 400  CONTINUE
C
      IERR=0
      CALL CREXEX(KBUFL,YBUFF,KSUP,KSEC0 ,KSEC1,KSEC3 ,
     1            KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR)
C
      IF(IERR.NE.0) then
         print*,'CREX error ', ierr
         IF(IERR.EQ.20.or.IERR.EQ.14) THEN
            KEL=KVALS/KSUP(6)
            GO TO 400
         ELSE
            CALL EXIT(2)
         END IF
      END IF
C
      
      IOBS=IOBS+KSEC3(3)
C
      ISUBSET=1
      CALL CREXSEL2(ISUBSET,KEL,KTDLEN,KTDLST,KTDEXL,KTDEXP,
     1              CNAMES,CUNITS,KERR)
      IF(KERR.NE.0) then
         print*,'CREXSEL: error.'
         CALL EXIT(2)
      END IF
C
C*          4.1 PRINT CONTENT OF EXPANDED DATA.
C               -------------------------------
 410  CONTINUE
C
      IF(.NOT.OPRT) GO TO 500
C
C*          4.2 PRINT SECTION ZERO OF CREX MESSAGE.
C               -----------------------------------
 420  CONTINUE
C

      CALL CREXPRS0(KSEC0)
C
C*          4.3 PRINT SECTION ONE OF CREX MESSAGE.
C               -----------------------------------
 430  CONTINUE
C
      CALL CREXPRS1(KSEC1,KSEC3,KTDLEN,KTDLST,KTDEXL,
     1              KTDEXP,KEL,CNAMES)
C
C
C
C*         4.6 PRINT SECTION 4 (DATA).
C              -----------------------
 460  CONTINUE
C
C          IN THE CASE OF MANY SUBSETS DEFINE RANGE OF SUBSETS
C
      IF(.NOT.OO) THEN
      WRITE(*,'(a,$)') ' STARTING SUBSET TO BE PRINTED : '
      READ(*,'(BN,I6)')   IST
      WRITE(*,'(a,$)') ' ENDING SUBSET TO BE PRINTED : '
      READ(*,'(BN,I6)')   IEND
      OO=.false.
      END IF
C
C              PRINT DATA
C
      ICODE=0
      CALL CREXPRT(ICODE,IST,KSEC3(3),KEL,CNAMES,CUNITS,CVALS,
     1           KVALS,VALUES,KSUP,KSEC1,IERR)
C
C
C     -----------------------------------------------------------------
C*          5. COLLECT DATA FOR REPACKING.
C              ---------------------------
 500  CONTINUE
C      
      IF(.NOT.OENC) GO TO 300
C
C               FIRST GET DATA DESCRIPTORS
C
      KK=0
      IST=1
      IEND=KSEC3(3)
C
      DO ISUBSET=IST, IEND


      CALL CREXSEL2(ISUBSET,KEL,KTDLEN,KTDLST,KTDEXL,KTDEXP,CNAMES,
     1            CUNITS,IERR)
      IF(KERR.NE.0) THEN
         print*,'CREXSEL: error ',kerr
         CALL EXIT(2)
      END IF
C
      JM1KELEM=(ISUBSET-1)*KEL
C
      DO 501 I=1,KTDEXL
         INV=I+JM1KELEM
         IN =I+JM1KELEM
C
         IF(CUNITS(I).EQ.'CHARACTER') THEN
            IPOS =VALUES(INV)/1000.
            ICH=NINT(VALUES(INV)-IPOS*1000)
            KKK=KKK+1
            VALUE(IN)=KKK*1000+ICH
            IF(CVALS(IPOS)(1:1).EQ.'/') THEN
               CV=' '
               DO II=1,ICH
               CV(II:II)=CHAR(255)
               END DO
               CVAL(KKK)=CV
            ELSE
              CVAL(KKK)=CVALS(IPOS)
            END IF
         ELSEIF(CUNITS(I)(1:2).EQ.'C '.AND.
     1     KTDEXP(I)/1000.eq.12 ) THEN
           VALUE(IN)=VALUES(INV)+273.15
         ELSEIF(CUNITS(I)(1:2).EQ.'NB'.AND.
     1     KTDEXP(I).EQ.015003) THEN
           VALUE(IN)=VALUES(INV)*0.0001
         ELSE
            VALUE(IN)=VALUES(INV)
         END IF
C
         IF(KTDEXP(I).EQ.31001.OR.KTDEXP(I).EQ.31002.OR.
     1      KTDEXP(I).EQ.31000) THEN
            KK=KK+1
            KDATA(KK)=NINT(VALUES(INV))
         END IF
 501  CONTINUE
C
      END DO
C
      KDLEN=2
      IF(KK.NE.0) KDLEN=KK

C     -----------------------------------------------------------------
C*          6. PACK BUFR MESSAGE.
C              -----------------
 600  CONTINUE
C
      KKK=0
C
      IF(KSEC0(3).LE.1) THEN
         KSEC0(3)=3              ! Edition 3  of bufr message
C
         KSEC1(1)=18
         KSEC1(2)=3              ! Bufr edition number
         KSEC1(3)=KSEC1(3)
         KSEC1(4)=1
         KSEC1(5)=0            ! presence od section 2
         KSEC1(7)=0
         KSEC1(8)=0            ! Bufr local tables version number
         KSEC1(9)=0
         KSEC1(10)=0
         KSEC1(11)=0
         KSEC1(12)=0
         KSEC1(13)=0
         KSEC1(14)=0
         KSEC1(15)=0           ! Bufr master table version number
c
         I_004001=0
         I_004002=0
         I_004003=0
         I_004004=0
         I_004005=0
c
         DO I=1,KTDEXL
         IF(KTDEXP(I).EQ.004001) THEN
            IF(I_004001.EQ.0) I_004001=I
         ELSEIF(KTDEXP(I).EQ.004002) THEN
            IF(I_004002.EQ.0) I_004002=I
         ELSEIF(KTDEXP(I).EQ.004003) THEN
            IF(I_004003.EQ.0) I_004003=I
         ELSEIF(KTDEXP(I).EQ.004004) THEN
            IF(I_004004.EQ.0) I_004004=I
         ELSEIF(KTDEXP(I).EQ.004005) THEN
            IF(I_004005.EQ.0) I_004005=I
         END IF
         END DO
c
         KSEC1(9)=NINT(VALUE(I_004001))-1900
         IF(NINT(VALUE(I_004001)).GE.2000) THEN
             KSEC1(9)=NINT(VALUE(I_004001))-2000
         END IF
         KSEC1(10)=NINT(VALUE(I_004002))
         KSEC1(11)=NINT(VALUE(I_004003))
         KSEC1(12)=NINT(VALUE(I_004004))
         KSEC1(13)=NINT(VALUE(I_004005))
c
         KSEC1(14)=0
         KSEC1(15)=13
         KSEC1(16)=0
      ELSEIF(KSEC0(3).EQ.2) THEN
         KSEC0(3)=4              ! Edition 4  of bufr message
c
         KSEC1(1)=22             ! The size of section 1
         KSEC1(2)=4
         KSEC1(3)=KSEC1(3)
         KSEC1(5)=0              ! presence od section 2
         KSEC1(9)=0
         KSEC1(10)=0
         KSEC1(11)=0
         KSEC1(12)=0
         KSEC1(13)=0
c
         I_004001=0
         I_004002=0
         I_004003=0
         I_004004=0
         I_004005=0
c
         DO I=1,KTDEXL
         IF(KTDEXP(I).EQ.004001) THEN
            IF(I_004001.EQ.0) I_004001=I
         ELSEIF(KTDEXP(I).EQ.004002) THEN
            IF(I_004002.EQ.0) I_004002=I
         ELSEIF(KTDEXP(I).EQ.004003) THEN
            IF(I_004003.EQ.0) I_004003=I
         ELSEIF(KTDEXP(I).EQ.004004) THEN
            IF(I_004004.EQ.0) I_004004=I
         ELSEIF(KTDEXP(I).EQ.004005) THEN
            IF(I_004005.EQ.0) I_004005=I
         END IF
         END DO
c
         KSEC1( 9)=NINT(VALUE(I_004001))
         KSEC1(10)=NINT(VALUE(I_004002))
         KSEC1(11)=NINT(VALUE(I_004003))
         KSEC1(12)=NINT(VALUE(I_004004))
         KSEC1(13)=NINT(VALUE(I_004005))
c
         KSEC1(14)=0         ! Bufr master table
         KSEC1(15)=KSEC1(17) ! Bufr master table version number
         KSEC1(16)=KSEC1(16) ! Originating sub-centre
         KSEC1(17)=KSEC1( 7) ! International sub-category
         KSEC1( 7)=0
         KSEC1(18)=0         ! Second
c
         
      END IF
c
      KSEC3(4)=192                    ! No compression
c
      KBUFL=JBUFL
C
C
C*          6.2 ENCODE DATA INTO BUFR MESSAGE.
C               ------------------------------
 620  CONTINUE
C
c              Modify descriptor list for delayed 
c              replication factor
c
      J=0
      DO I=1,KTDLEN
      IIF=KTDLST(I)/100000
      IF(IIF.EQ.1) THEN
         II=KTDLST(I)/1000
         IY=KTDLST(I)-II*1000
         IF(IY.EQ.0) THEN
           J=J+1
           KTDLST1(J)=KTDLST(I)
           J=J+1
           KTDLST1(J)=031002
         ELSE
           j=j+1
           KTDlst1(j)=KTDlst(i)
         END IF
      ELSE
         J=J+1
         KTDLST1(J)=KTDLST(I)
      END IF
      END DO
c
      KTDLEN=J
c 
      KERR=0
c     
      CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4,
     1             KTDLEN,KTDLST1,KDLEN,KDATA,KEL,   
     2             KVALS,VALUE,CVAL,KBUFL,KBUFR,KERR)
C
      IF(KERR.gt.0) THEN
         print*,'error is ',kerr
         PRINT*,'ERROR DURING ENCODING.'
         CALL EXIT(2)
      END IF
C
C           6.3 WRITE PACKED BUFR MESSAGE INTO FILE.
C               ------------------------------------
 630  CONTINUE
C
      ILEN=KBUFL*NBYTPW
C     
      IERR=0
      CALL PBWRITE(IUNIT1,KBUFR,ILEN,IERR)
      if(ierr.lt.0) then
         print*,'Error writing into target file.'
         CALL EXIT(2)
      END IF
C
      GO TO 300
C     -----------------------------------------------------------------
C
      END
