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 BUFR2CREX
C
C**** *BUFRCREX*
C
C
C     PURPOSE.
C     --------
C         Bufr to CREX conversion.
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=512000,
#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=20000)
      PARAMETER (KVALS=360000)
C 
      DIMENSION KBUFF(JBUFL)
      DIMENSION 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)
      REAL*8 RQV(KELEM)
C
      DIMENSION KTDLST(KELEM),KTDEXP(KELEM),KRQ(KELEM)
      DIMENSION KDATA(2000)
C
      CHARACTER*256    COUT,CARG(4),CFIN
      CHARACTER*64     CNAMES(KELEM)
      CHARACTER*24     CUNITS(KELEM)
      CHARACTER*80     CVALS(KVALS)
      CHARACTER*80     YENC
      CHARACTER*160000 YOUT
      CHARACTER*3      CRCRLF
C
C     Common block containing bufr tables
C
      COMMON /BCOMTAB/ NTABBTR(JTAB),NTABBS (JTAB),NTABBRV(JTAB),
     1                 NTABBDW(JTAB),NTABDTR(JTAB),NTABDST(JTAB),
     2                 NTABDL (JTAB),NTABDSQ(JTAB*20),NTABP(64,255)
C
C             NTABBTR    - table B,  table reference              array
C             NTABBS     - table B,  scale                        array
C             NTABBRF    - table B,  reference value              array
C             NTABBDW    - table B,  data width                   array
C             NTABDTR    - table D,  table reference              array
C             NTABDST    - table D,  starting pointers            array
C             NTABDL     - table D,  lengths                      array
C             NTABDSQ    - table D,  list of sequence descriptors array
C
      COMMON /BCOMWT/ NDWINC,NSCAM,NAFDW,NWT ,ODREPF,
     1                N221,MREL,NFCM,NFUCM,MBMP,OMARKER,M0,
     2                MBMPL,NSTACK(JELEM),NWTEN(JELEM),
     3                NWTR (JELEM),NWTS (JELEM),NWTRV (JELEM),
     4                NWTDW(JELEM)
C
C             NDWINC   -  data width increment
C             NSCAM    -  scale multiplier
C             NAFDW    -  augmented field data width
C             NWT      -  pointer to working table
C             NSTACK   -  list of data descriptors
C             ODREPF   -  replication (logical)
C             N221     -  data not present for n221 elements
C             MREL     -  pointer to the last data element
C             NFCM     -  first compressed message
C             MBMP     -  pointer to the begining of bit map
C             NWTR     -  working table reference
C             NWTS     -  working scale
C             NWTRV    -  working reference value
C             NWTDW    -  working data width
C
      COMMON /BCOMWTC/ CWTEN(JELEM),CWTU (JELEM)
C
C             CWTEN    -  working table element naame
C             CWTU     -  working table units
C
c
      PARAMETER(JP=3000)
C
      CHARACTER*120 YENTRY
      CHARACTER*15  YFNAME
      CHARACTER*15  FMT
      CHARACTER*6   CREXKTDLST(KELEM),CREXKTDLST0
C
      INTEGER IVALUE(KELEM)
C
C     Logical switch to use check digit indicator
C
      CHARACTER*4 YUSE_E
C
      INTEGER IVAL,IIVAL
c
      REAL*8 EPS
      REAL*8 RVIND
      REAL*8 VAL
C
      EQUIVALENCE (YOUT,KBUFR(1))
C
C                                                                       
C     ------------------------------------------------------------------
C*          1. INITIALIZE CONSTANTS AND VARIABLES.
C              -----------------------------------
 100  CONTINUE
C
C 
      NBYTPW=JBPW/8
      RVIND=1.7E38
      NVIND=2147483647
      IOBS=0
      EPS=1.0E-8
      NPACK=0
      N=0
      OO=.FALSE.
C
      CRCRLF=CHAR(13)//CHAR(13)//CHAR(10)
C
C     Get input and output file name.
C
      NARG=IARGC()
c
      IF(NARG.LT.4) THEN
         print*,'Usage -- bufr2crex -i infile -o outfile' 
         STOP
      END IF
c
      COUT=' '
      CFIN=' '
c
      DO 101 J=1,NARG
      CALL GETARG(J,CARG(J))
 101  CONTINUE
c
      DO 102 J=1,NARG,2
        IF(CARG(J).EQ.'-i') THEN
           CFIN=CARG(J+1)
        ELSEIF(CARG(J).EQ.'-o') THEN
           COUT=CARG(J+1)
        ELSE
            print*,'Usage -- bufr2crex -i infile -o outfile'
            STOP
        END IF
 102  CONTINUE
C
      II=INDEX(CFIN,' ')
      II=II-1
      JJ=INDEX(COUT,' ')
      JJ=JJ-1
C
      KRQL=0
      NR=0
      KREQ(1)=0
      KREQ(2)=0
C
C
C*          1.2 OPEN FILE CONTAINING BUFR DATA.
C               -------------------------------
 120  CONTINUE
C
      IRET=0 
      CALL PBOPEN(IUNIT,CFIN(1:ii),'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
      CALL PBOPEN(IUNIT1,cout(1:jj),'w',IRET)
      IF(IRET.EQ.-1) STOP 'open failed on bufr.dat'
      IF(IRET.EQ.-2) STOP 'Invalid file name'
      IF(IRET.EQ.-3) STOP 'Invalid open mode specified'
C
C     ----------------------------------------------------------------- 
C*          2. SET REQUEST FOR EXPANSION.
C              --------------------------
 200  CONTINUE
C
      KREQ(1)=1
      KREQ(2)=0
C
      OSEC3=.FALSE.
      OPRT=.FALSE.
      OENC=.TRUE.
      ICODE=0
      OCOMP=.FALSE.
C
C*          2.1 SET REQUEST FOR PARTIAL EXPANSION.
C               ----------------------------------
 210  CONTINUE
C
      KERR=0
      CALL BUSRQ(KREQ,KRQL,KRQ,RQV,KERR)
C
C     -----------------------------------------------------------------
C*          3.  READ BUFR MESSAGE.
C               ------------------
 300  CONTINUE
C
      IERR=0
      KBUFL=0
C
      IRET=0
      CALL PBBUFR(IUNIT,KBUFF,JBYTE,KBUFL,IRET) 
      IF(IRET.EQ.-1) THEN
c         IF(N.NE.0) GO TO 600
         print*,'Number of subsets     ',iobs
         print*,'Number of messages    ',n
         STOP 'EOF'
      END IF
      IF(IRET.EQ.-2) STOP 'File handling problem' 
      IF(IRET.EQ.-3) STOP 'Array too small for product'
C
      N=N+1
      KBUFL=KBUFL/nbytpw+1
      IF(N.LT.NR) GO TO 300
      print*,'----------------------',n
C
C     -----------------------------------------------------------------
C*          4. EXPAND BUFR MESSAGE.
C              --------------------
 400  CONTINUE
C
      CALL BUS012(KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KERR)
      IF(KERR.NE.0) THEN
         PRINT*,'Error in BUS012: ',KERR
         PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.'
         KERR=0
         GO TO 300
      END IF
C
      KEL=KELEM
      IF(KSUP(6).GT.1) THEN
         KEL=KVALS/KSUP(6)
         IF(KEL.GT.KELEM) KEL=KELEM
      END IF
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
         IF(IERR.EQ.45) GO TO 300
         IF(IERR.EQ.2) THEN
            IERR=0
            GO TO 300
         END IF
         CALL EXIT(2)
      END IF
c
      IOBS=IOBS+KSEC3(3)
c
      NPACK=NPACK+1 
C
      ISUBSET=1
      CALL BUSEL2(ISUBSET,KEL,KTDLEN,KTDLST,KTDEXL,KTDEXP,CNAMES,
     1            CUNITS,IERR)
      IF(KERR.NE.0) CALL EXIT(2)
C
C*          4.1 PRINT CONTENT OF EXPANDED DATA.
C               -------------------------------
 410  CONTINUE
C
      IF(.NOT.OPRT) GO TO 500
      IF(.NOT.OSEC3) GO TO 450
C
C*          4.2 PRINT SECTION ZERO OF BUFR MESSAGE.
C               -----------------------------------
 420  CONTINUE
C

      CALL BUPRS0(KSEC0)
C
C*          4.3 PRINT SECTION ONE OF BUFR MESSAGE.
C               -----------------------------------
 430  CONTINUE
C
      CALL BUPRS1(KSEC1)
C
C
C*          4.4 PRINT SECTION TWO OF BUFR MESSAGE.
C               -----------------------------------
 440  CONTINUE
c
C              AT ECMWF SECTION 2 CONTAINS RDB KEY.
C              SO UNPACK KEY
C
      CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
C
C              PRINT KEY
C
      CALL BUPRS2(KSUP ,KEY)
C
C*          4.5 PRINT SECTION 3 OF BUFR MESSAGE.
C               -----------------------------------
 450  CONTINUE
C
C               FIRST GET DATA DESCRIPTORS
C
      ISUBSET=1
      CALL BUSEL2(ISUBSET,KEL,KTDLEN,KTDLST,KTDEXL,KTDEXP,CNAMES,
     1            CUNITS,IERR)
      IF(KERR.NE.0) CALL EXIT(2)
C
C               PRINT  CONTENT
C
      IF(OSEC3) THEN
         CALL BUPRS3(KSEC3,KTDLEN,KTDLST,KTDEXL,KTDEXP,KEL,CNAMES)
      END IF
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 BUPRT(ICODE,IST,IEND,KEL,CNAMES,CUNITS,CVALS,
     1           KVALS,VALUES,KSUP,KSEC1,IERR)
C
C
C     -----------------------------------------------------------------
C*          5. COLLECT DATA FOR REPACKING.
C              ---------------------------
 500  CONTINUE
C      
C               FIRST GET DATA DESCRIPTORS
C
      ISUBSET=1
      CALL BUSEL2(ISUBSET,KEL,KTDLEN,KTDLST,KTDEXL,KTDEXP,CNAMES,
     1            CUNITS,IERR)
      IF(KERR.NE.0) CALL EXIT(2)
C
C     -----------------------------------------------------------------
C*          6. PACK CREX MESSAGE.
C              ------------------
 600  CONTINUE
C
C     Modify BUFR operators
C
      J=0
      DO 602 I=1,KTDLEN
      IF(KTDLST(I).EQ.222000) GO TO 603
      IF(KTDLST(I).EQ.201000) GO TO 602 
      IF(KTDLST(I).EQ.202000) GO TO 602
      IF(KTDLST(I).EQ.204000) GO TO 602
      IF(KTDLST(I).EQ.031000) GO TO 602
      IF(KTDLST(I).EQ.031001) GO TO 602
      IF(KTDLST(I).EQ.031002) GO TO 602
C
      CREXKTDLST0=' '
      WRITE(CREXKTDLST0,'(I6.6)',IOSTAT=IOS) KTDLST(I)
      IF(IOS.NE.0) THEN
         print*,'Internal write error.'
         CALL EXIT(2)
      END IF
      J=J+1
      CREXKTDLST(J)(1:6)=CREXKTDLST0
C
      IF(CREXKTDLST(J)(1:1).EQ.'3') THEN
         CREXKTDLST(J)(1:1)='D'
      ELSEIF(CREXKTDLST(J)(1:1).EQ.'0') THEN
         CREXKTDLST(J)(1:1)='B'
      ELSEIF(CREXKTDLST(J)(1:1).EQ.'1') THEN
         CREXKTDLST(J)(1:1)='R'
c        scan for any 201000,202000 or 201y,202y followed by 206y
         READ(CREXKTDLST(J)(2:3),'(I2.2)',IOSTAT=IOS) IELEMENTS
         IF(IOS.NE.0) THEN
            print*,'Internal read error.'
            CALL EXIT(2)
         END IF
         IEL=IELEMENTS
         DO IN=I,I+IELEMENTS-1
         IF(KTDLST(IN).EQ.201000) IEL=IEL-1
         IF(KTDLST(IN).EQ.202000) IEL=IEL-1
         IF(KTDLST(IN).GE.201001.AND.KTDLST(IN).LE.201999.AND.
     1      KTDLST(IN+1)/1000.EQ.206) IEL=IEL-1
         IF(KTDLST(IN).GE.202001.AND.KTDLST(IN).LE.202999.AND.         
     1      KTDLST(IN+1)/1000.EQ.206) IEL=IEL-1
         END DO
         WRITE(CREXKTDLST(J)(2:3),'(I2.2)',IOSTAT=IOS) IEl
         IF(IOS.NE.0) THEN
            print*,'Internal write error.'
            CALL EXIT(2)
         END IF
      ELSEIF(CREXKTDLST(J)(1:3).EQ.'201') THEN
         IF(KTDLST(I+1)/1000.EQ.206) THEN
            J=J-1
            GO TO 602
         END IF
         READ(CREXKTDLST(J)(4:6),'(I3.3)',IOSTAT=IOS) IY
         IF(IOS.NE.0) THEN
            print*,'Internal read error.'
            CALL EXIT(2)
         END IF
         IBITS=IY-128
         ICLASS=KTDLST(I+1)/1000
         IYYY  =KTDLST(I+1)-ICLASS*1000+1
         ICLASS=ICLASS+1
         III=NTABP(ICLASS,IYYY)
         IDW=NTABBDW(III)+IBITS
         IRES=2.**IDW-1
         JZ=0
         DO WHILE(IRES.GT.0)
         JZ=JZ+1
         IRES=IRES/10
         END DO
         CREXKTDLST(J)(1:3)='C01'
         WRITE(CREXKTDLST(J)(4:6),'(I3.3)',IOSTAT=IOS) JZ
         IF(IOS.NE.0) THEN
            print*,'Internal write error.'
            CALL EXIT(2)
         END IF
      ELSEIF(CREXKTDLST(J)(1:3).EQ.'202') THEN
         GO TO 602
      ELSEIF(CREXKTDLST(J)(1:3).EQ.'205') THEN
          CREXKTDLST(J)(1:3)='C05'
      ELSE
         print*,'Wrong data descriptor ',crexktdlst(j)
         print*,'Data containing above descriptor can',
     1          ' not be converted'
         go to 300
      END IF
 602  CONTINUE
c
 603  CONTINUE
C
      ICREXLEN=J
c
C     Find delayed replications
c
      KDLEN=0
C
      IST=1
      IEND=1
      OMULTI=.FALSE.
      IF(IAND(KSEC3(4),64).NE.0.AND.KSEC3(3).GT.1) THEN
         IEND=KSEC3(3)
         OMULTI=.TRUE.
      END IF
C
      DO ISUBSET=IST, IEND

      JJ=(ISUBSET-1)*KEL
C
      CALL BUSEL2(ISUBSET,KEL,KTDLEN,KTDLST,KTDEXL,KTDEXP,CNAMES,
     1            CUNITS,IERR)
C
      DO I=1,KTDEXL
C
        II=I+JJ
C
        IF(KTDEXP(I).EQ.031001.OR.
     1     KTDEXP(I).EQ.031000.OR.
     2     KTDEXP(I).EQ.031002) THEN
           KDLEN=KDLEN+1
           KDATA(KDLEN)=NINT(VALUES(II))
        END IF
      END DO
C
C*   Make unit conversion from K to Celsius
C
      DO I=1,KTDEXL
        IF(CUNITS(I)(1:2).EQ.'K '.AND.
     1     KTDEXP(I)/1000.EQ.12) THEN
           IF(KTDEXP(I).NE.012064.AND.
     1        KTDEXP(I).NE.012065.AND.
     2        KTDEXP(I).NE.012070.AND.
     2        KTDEXP(I).NE.012071.AND.
     4        KTDEXP(I).NE.012164.AND.
     5        KTDEXP(I).NE.012151.AND.
     6        KTDEXP(I).NE.012051.AND.
     7        KTDEXP(I).NE.022050.AND.
     8        KTDEXP(I).NE.012171) THEN
              IF(OMULTI) THEN
              IJ=I+JJ
              IF(abs(VALUES(IJ)-rvind)/rvind.GT.eps) 
     1           VALUES(IJ)=VALUES(IJ)-273.15 
              ELSE
              DO J=1,KSEC3(3)
              IJ=I+(J-1)*KEL
              IF(abs(VALUES(IJ)-rvind)/rvind.GT.eps)
     1           VALUES(IJ)=VALUES(IJ)-273.15
              END DO
              END IF
           END IF
        END IF
        IF(CUNITS(I)(1:2).EQ.'PA'.AND.
     1     KTDEXP(I).EQ.015003) THEN
           IF(OMULTI) THEN
           IJ=I+JJ
           IF(abs(VALUES(IJ)-rvind)/rvind.GT.eps)
     1        VALUES(IJ)=VALUES(IJ)*10000.
           ELSE
           DO J=1,KSEC3(3)
           IJ=I+(J-1)*KEL
           IF(abs(VALUES(IJ)-rvind)/rvind.GT.eps) 
     1        VALUES(IJ)=VALUES(IJ)*10000.
           END DO
           END IF
        END IF
      END DO
C
      END DO

C
C*          6.2 ENCODE DATA INTO CREX MESSAGE.
C               ------------------------------
 620  CONTINUE
C
      IF(KSEC1(2).EQ.4) THEN         ! Bufr edition number
         KSEC1(2)=2                  ! Crex edition number
         KSEC1(5)=KSEC3(3)           ! Number of subsets
         KSEC1( 7)=KSEC1(17)         ! International sub category
         KSEC1(17)=KSEC1(15)            ! Bufr master table version number
         KSEC1(15)=3                    ! Crex version number used
         KSEC1(18)=KSEC1(8)             ! Bufr version number of local tables
      ELSE
         KSEC1(17)=KSEC1(15)            ! Bufr master table version number
         KSEC1(2)=1                  ! Crex edition number
         KSEC1(15)=3                    ! Crex version number used
         KSEC1(18)=KSEC1(8)             ! Bufr version number of local tables
      END IF
c
      CALL CREXEN(KSEC0,KSEC1,KSEC3,
     1            ICREXLEN,CREXKTDLST,KDLEN,KDATA,KEL,KVALS,
     2            VALUES,CVALS,KBUFL,KBUFR,KERR)
      IF(KERR.GT.0) THEN
         print*,'CREXEN error:',KERR
         go to 300
      END IF
C
C           6.3 WRITE CREX MESSAGE INTO FILE.
C               -----------------------------
 630  CONTINUE
C
      ILEN=KBUFL
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
      END
