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 BUFR
C
C**** *BUFR*
C
C
C     PURPOSE.
C     --------
C         An example of using Bufr packing/unpacking software.
C         It will create synop data in bufr edition 4 
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          M. DRAGOSAVAC    *ECMWF*       05/04/2005.
C
C
C     MODIFICATIONS.
C     --------------
C
C          NONE.
C
C
      IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y)
C
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= 200,
#else
     2          JBPW =  32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT= 200,
#endif
     3          JWORK=4096000,JKEY=46)

C
      PARAMETER (KDLEN=200,KELEM=4000)
      parameter (KVALS=4000,KVALS1=4000)
C 
      DIMENSION KBUFR(JBUFL)
      DIMENSION KSUP(JSUP)  ,KSEC0(JSEC0),KSEC1(JSEC1)
      DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4)
      DIMENSION KEY  (JKEY)
      DIMENSION ISUP(JSUP)  ,ISEC0(JSEC0),ISEC1(JSEC1)
      DIMENSION ISEC2(JSEC2),ISEC3(JSEC3),ISEC4(JSEC4)
C
#ifndef R_4
      REAL*8  VALUES(KVALS),VALUE(KVALS1)
      REAL*8  RQV(KELEM)
      REAL*8  RVIND
#else
      REAL    VALUES(KVALS),VALUE(KVALS1)
      REAL    RQV(KELEM)
      REAL    RVIND
#endif

      DIMENSION KTDLST(KELEM),KTDEXP(KELEM),KRQ(KELEM)
      DIMENSION ITDLST(KELEM),ITDEXP(KELEM)
      DIMENSION KDATA(KDLEN),IDATA(KDLEN)
C
      CHARACTER*8  CF
      CHARACTER*64 CNAMES(KELEM),CNAME(KELEM)
      CHARACTER*24 CUNITS(KELEM),CUNIT(KELEM)
      CHARACTER*80 CVALS(KVALS)
      CHARACTER*80 CVAL (KVALS1)
      CHARACTER*80 YENC
C
C                                                                       
C     ------------------------------------------------------------------
C*          1. INITIALIZE CONSTANTS AND VARIABLES.
C              -----------------------------------
 100  CONTINUE
C
C
      RVIND=1.7D38
C
 
      CALL PBOPEN(IUNIT1,'synop.bufr','W',IRET)
      IF(IRET.EQ.-1) STOP 'OPEN FAILED ON synop.dat'
      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
C

C
C     INITIALIZE DELAYED REPLICATION FACTORS OR REFERENCE VALUES ETD.
C
      DO 101 I=1,KDLEN
      KDATA(I)=1
      VALUES(I)=RVIND
 101  CONTINUE
C
c
      KDLENG=3
C
C
C     SET DATA DECSRIPTORS
C

 
      ktdlst(    1)=  307080
 
      ktdlen=1

      values(  1)=11.        !001001  WMO BLOCK NUMBER
      values(  2)=423.       !001002  WMO STATION NUMBER
      values(  3)=1020.      !001015  STATION OR SITE NAME
      values(  4)=1.         !002001  TYPE OF STATION
      values(  5)=2007.      !004001  YEAR
      values(  6)=11.        !004002  MONTH
      values(  7)=21.        !004003  DAY
      values(  8)=12.        !004004  HOUR
      values(  9)=0.         !004005  MINUTE
      values( 10)=49.66944   !005001  LATITUDE (HIGH ACCURACY)
      values( 11)=12.67778   !006001  LONGITUDE (HIGH ACCURACY)
      values( 12)=742.2      !007030  HEIGHT OF STATION GROUND ABOVE MEAN SEA LEVEL (SEE NOTE 3)
      values( 13)=747.       !007031  HEIGHT OF BAROMETER ABOVE MEAN SEA LEVEL (SEE NOTE 4)
      values( 14)=92520.     !010004  PRESSURE
      values( 15)=rvind      !010051  PRESSURE REDUCED TO MEAN SEA LEVEL
      values( 16)=-60.       !010061  3-HOUR PRESSURE CHANGE
      values( 17)=5.         !010063  CHARACTERISTIC OF PRESSURE TENDENCY
      values( 18)=rvind      !010062  24-HOUR PRESSURE CHANGE
      values( 19)=92500.     !007004  PRESSURE
      values( 20)=749.       !010009  GEOPOTENTIAL HEIGHT
      values( 21)=1.95       !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 22)=270.85     !012101  TEMPERATURE/DRY-BULB TEMPERATURE
      values( 23)=270.45     !012103  DEW-POINT TEMPERATURE
      values( 24)=97.        !013003  RELATIVE HUMIDITY
      values( 25)=4.8        !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 26)=200.       !020001  HORIZONTAL VISIBILITY
      values( 27)=1.12       !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 28)=rvind      !013023  TOTAL PRECIPITATION PAST 24 HOURS
      values( 29)=rvind      !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 30)=100.       !020010  CLOUD COVER (TOTAL)
      values( 31)=5.         !008002  VERTICAL SIGNIFICANCE (SURFACE OBSERVATIONS)
      values( 32)=9.         !020011  CLOUD AMOUNT
      values( 33)=0.         !020013  HEIGHT OF BASE OF CLOUD
      values( 34)=62.        !020012  CLOUD TYPE
      values( 35)=61.        !020012  CLOUD TYPE
      values( 36)=60.        !020012  CLOUD TYPE
      values( 37)=1.         !031001  DELAYED DESCRIPTOR REPLICATION FACTOR
      values( 38)=5.         !008002  VERTICAL SIGNIFICANCE (SURFACE OBSERVATIONS)
      values( 39)=9.         !020011  CLOUD AMOUNT
      values( 40)=59.        !020012  CLOUD TYPE
      values( 41)=0.         !020013  HEIGHT OF BASE OF CLOUD
      values( 42)=1.         !031001  DELAYED DESCRIPTOR REPLICATION FACTOR
      values( 43)=11.        !008002  VERTICAL SIGNIFICANCE (SURFACE OBSERVATIONS)
      values( 44)=rvind      !020011  CLOUD AMOUNT
      values( 45)=rvind      !020012  CLOUD TYPE
      values( 46)=rvind      !020014  HEIGHT OF TOP OF CLOUD
      values( 47)=rvind      !020017  CLOUD TOP DESCRIPTION
      values( 48)=7.         !008002  VERTICAL SIGNIFICANCE (SURFACE OBSERVATIONS)
      values( 49)=rvind      !020054  TRUE DIRECTION FROM WHICH CLOUDS ARE MOVING
      values( 50)=8.         !008002  VERTICAL SIGNIFICANCE (SURFACE OBSERVATIONS)
      values( 51)=rvind      !020054  TRUE DIRECTION FROM WHICH CLOUDS ARE MOVING
      values( 52)=9.         !008002  VERTICAL SIGNIFICANCE (SURFACE OBSERVATIONS)
      values( 53)=rvind      !020054  TRUE DIRECTION FROM WHICH CLOUDS ARE MOVING
      values( 54)=rvind      !008002  VERTICAL SIGNIFICANCE (SURFACE OBSERVATIONS)
      values( 55)=rvind      !005021  BEARING OR AZIMUTH
      values( 56)=rvind      !007021  ELEVATION (SEE NOTE 2)
      values( 57)=rvind      !020012  CLOUD TYPE
      values( 58)=rvind      !005021  BEARING OR AZIMUTH
      values( 59)=rvind      !007021  ELEVATION (SEE NOTE 2)
      values( 60)=rvind      !020062  STATE OF THE GROUND (WITH OR WITHOUT SNOW)
      values( 61)=rvind      !013013  TOTAL SNOW DEPTH
      values( 62)=rvind      !012113  GROUND MINIMUM TEMPERATURE, PAST 12 HOURS
      values( 63)=49.        !020003  PRESENT WEATHER (SEE NOTE 1)
      values( 64)=-6.        !004024  TIME PERIOD OR DISPLACEMENT
      values( 65)=4.         !020004  PAST WEATHER (1) (SEE NOTE 2)
      values( 66)=4.         !020005  PAST WEATHER (2) (SEE NOTE 2)
      values( 67)=-1.        !004024  TIME PERIOD OR DISPLACEMENT
      values( 68)=rvind      !014031  TOTAL SUNSHINE
      values( 69)=-24.       !004024  TIME PERIOD OR DISPLACEMENT
      values( 70)=rvind      !014031  TOTAL SUNSHINE
      values( 71)=1.12       !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 72)=-6.        !004024  TIME PERIOD OR DISPLACEMENT
      values( 73)=0.         !013011  TOTAL PRECIPITATION/TOTAL WATER EQUIVALENT
      values( 74)=-1.        !004024  TIME PERIOD OR DISPLACEMENT
      values( 75)=0.         !013011  TOTAL PRECIPITATION/TOTAL WATER EQUIVALENT
      values( 76)=1.95       !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 77)=-12.       !004024  TIME PERIOD OR DISPLACEMENT
      values( 78)=0.         !004024  TIME PERIOD OR DISPLACEMENT
      values( 79)=rvind      !012111  MAXIMUM TEMPERATURE, AT HEIGHT AND OVER PERIOD SPECIFIED
      values( 80)=-12.       !004024  TIME PERIOD OR DISPLACEMENT
      values( 81)=0.         !004024  TIME PERIOD OR DISPLACEMENT
      values( 82)=rvind      !012112  MINIMUM TEMPERATURE, AT HEIGHT AND OVER PERIOD SPECIFIED
      values( 83)=10.25      !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 84)=8.         !002002  TYPE OF INSTRUMENTATION FOR WIND MEASUREMENT
      values( 85)=2.         !008021  TIME SIGNIFICANCE
      values( 86)=-10.       !004025  TIME PERIOD OR DISPLACEMENT
      values( 87)=110.       !011001  WIND DIRECTION
      values( 88)=5.         !011002  WIND SPEED
      values( 89)=rvind      !008021  TIME SIGNIFICANCE
      values( 90)=-10.       !004025  TIME PERIOD OR DISPLACEMENT
      values( 91)=rvind      !011043  MAXIMUM WIND GUST DIRECTION
      values( 92)=rvind      !011041  MAXIMUM WIND GUST SPEED
      values( 93)=-360.      !004025  TIME PERIOD OR DISPLACEMENT
      values( 94)=rvind      !011043  MAXIMUM WIND GUST DIRECTION
      values( 95)=12.        !011041  MAXIMUM WIND GUST SPEED
      values( 96)=rvind      !007032  HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR DECK OF MARINE PLATFORM)
      values( 97)=-24.       !004024  TIME PERIOD OR DISPLACEMENT
      values( 98)=rvind      !002004  TYPE OF INSTRUMENTATION FOR EVAPORATION MEASUREMENT OR TYPE OF C
      values( 99)=rvind      !013033  EVAPORATION/EVAPOTRANSPIRATION
      values(100)=-1.        !004024  TIME PERIOD OR DISPLACEMENT
      values(101)=rvind      !014002  LONG-WAVE RADIATION, INTEGRATED OVER PERIOD SPECIFIED
      values(102)=rvind      !014004  SHORT-WAVE RADIATION, INTEGRATED OVER PERIOD SPECIFIED
      values(103)=rvind      !014016  NET RADIATION, INTEGRATED OVER PERIOD SPECIFIED
      values(104)=rvind      !014028  GLOBAL SOLAR RADIATION (HIGH ACCURACY), INTEGRATED OVER PERIOD S
      values(105)=rvind      !014029  DIFFUSE SOLAR RADIATION (HIGH ACCURACY), INTEGRATED OVER PERIOD
      values(106)=rvind      !014030  DIRECT SOLAR RADIATION (HIGH ACCURACY), INTEGRATED OVER PERIOD S
      values(107)=-24.       !004024  TIME PERIOD OR DISPLACEMENT
      values(108)=rvind      !014002  LONG-WAVE RADIATION, INTEGRATED OVER PERIOD SPECIFIED
      values(109)=rvind      !014004  SHORT-WAVE RADIATION, INTEGRATED OVER PERIOD SPECIFIED
      values(110)=rvind      !014016  NET RADIATION, INTEGRATED OVER PERIOD SPECIFIED
      values(111)=rvind      !014028  GLOBAL SOLAR RADIATION (HIGH ACCURACY), INTEGRATED OVER PERIOD S
      values(112)=rvind      !014029  DIFFUSE SOLAR RADIATION (HIGH ACCURACY), INTEGRATED OVER PERIOD
      values(113)=rvind      !014030  DIRECT SOLAR RADIATION (HIGH ACCURACY), INTEGRATED OVER PERIOD S
      values(114)=rvind      !004024  TIME PERIOD OR DISPLACEMENT
      values(115)=rvind      !004024  TIME PERIOD OR DISPLACEMENT
      values(116)=rvind      !012049  TEMPERATURE CHANGE OVER SPECIFIED PERIOD

 
C     SET CCITTIA5 STATION OR SITE NAME

      cvals(1)='PRIMDA'
C
C
C     SECTION 0 CONTENT
C
      KSEC0(1)=0      ! TOTAL LENGTH OF SECTION 0
      KSEC0(2)=0      ! TOTAL LENGTH OF BUFR MESSAGE
      KSEC0(3)=4      ! BUFR EDITION NUMBER
C
C     SECTION 1 CONTENT
C
      KSEC1(1)=22    ! TOTTAL LENGTH OF SECTION 1 (  set to 18 for edition <= 3)
      KSEC1(2)=4     ! BUFR EDITION NUMBER
      KSEC1(3)=89    ! ORIGINATING CENTRE
      KSEC1(4)=1     ! UPDATE SEQUENCE NUMBER
      KSEC1(5)=0     ! FLAG (PRESENCE OF SECTION 2)
      KSEC1(6)=0     ! DATA CATEGORY
      KSEC1(7)=0     ! LOCAL DATA SUB-CATEGORY
      KSEC1(8)=0     ! VERSION NUMBER OF LOCAL TABLE USED
      KSEC1(9)=nint(values(5)) 
      if(KSEC1(2).le.3) then
        if(ksec1(9).gt.2000) then
           ksec1(9)=ksec1(9)-2000
        else
           ksec1(9)=ksec1(9)-1900
        end if
      end if
      KSEC1(10)=nint(values(6))
      KSEC1(11)=nint(values(7))   ! DAY
      KSEC1(12)=nint(values(8))   ! HOUR
      KSEC1(13)=nint(values(9))   ! MINUTE
      KSEC1(14)=0    ! BUFR MASTER TABLE( ZERO) FOR METEOROLOGICAL DATA)
      KSEC1(15)=13   ! VERSION NUMBER OF MASTER TABLE USED
      KSEC1(16)=255  ! ORIGINATING SUB-CENTRE
      KSEC1(17)=2    ! INTERNATIONAL SUB-CATEGORY
      KSEC1(18)=0    ! SECOND
      
C
C     SECTION 2 CONTENT
C
      KSEC2(1)=52
C
      DO 110 I=2,JSEC2
      KSEC2(I)=0
 110  CONTINUE
C
C     SECTION 3 CONTENT
C
      KSEC3(1)=0     ! TOTAL LENGTH OF SECTION 3
      KSEC3(2)=0     ! RESERVED
      KSEC3(3)=1
      KSEC3(4)=0     ! 64 FOR COMPRESSION/ 0 MANY SUBSETS
      if(KSEC3(3).GT.1) KSEC3(4)=64
C
      IREP=0
C
C
C*          6. PACK BUFR MESSAGE
C              -----------------
 600  CONTINUE
C
C---------------------------------------------------------------
C              This call is not needed for packing. It just 
C              prints expanded list corresponding to ktdlst sequence
C              and delayed replications in kdata array. This four
C              lines can be deleted or commented out.
      K=1
      CALL BUXDES(K,KSEC1,KTDLEN,KTDLST,KDLENG,KDATA,KELEM,
     1            KTDEXL,KTDEXP,CNAMES,CUNITS,KERR)
C
      IF(KERR.NE.0) CALL EXIT(2)
C---------------------------------------------------------------
C
C
C*          6.2 ENCODE DATA INTO BUFR MESSAGE.
C               ------------------------------
 620  CONTINUE
C
      KBUFL=3000
      KPMISS=1
      KPRUS=1
      NOKEY=0
      CALL BUPRQ(KPMISS,KPRUS,NOKEY)
C
      KERR=0
      CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4,
     1             KTDLEN,KTDLST,KDLENG,KDATA,KELEM,
     2             KVALS,VALUES,CVALS,KBUFL,KBUFR,KERR)
C

      IF(KERR.GT.0) THEN
         CALL EXIT(2)
      ELSEIF(KERR.lt.0) then
         print*,'Encoding return_code=',kerr
      END IF 
c
C     ILEN=KBUFL*JBPW/8
      ILEN=KSEC0(2)
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
C     -----------------------------------------------------------------
C*          7. UNPACK MESSAGE.
C              -------------
 700  CONTINUE
C
      DO 702 I=1,KVALS1
      VALUE(I)=RVIND
 702  CONTINUE
c
 701  CONTINUE
C
      CALL BUFREX(KBUFL,KBUFR,ISUP,ISEC0 ,ISEC1,ISEC2 ,ISEC3 ,ISEC4,
     1            KELEM,CNAME,CUNIT,KVALS1,VALUE,CVAL,IERR)
c
      IF(IERR.NE.0) CALL EXIT(2)
C
      CALL BUPRS0(ISEC0)
      CALL BUPRS1(ISEC1)
      CALL BUUKEY(ISEC1,ISEC2,KEY,ISUP,KERR)
      CALL BUPRS2(ISUP ,KEY)
      ISUBSET=1
      CALL BUSEL2(ISUBSET,KELEM,KTDLEN,KTDLST,KTDEXL,KTDEXP,CNAMES,
     1            CUNITS,IERR)
      CALL BUPRS3(ISEC3,KTDLEN,KTDLST,KTDEXL,KTDEXP,KELEM,CNAME)
C
      WRITE(*,'(a,$)') ' STARTING SUBSET TO BE PRINTED : '
      READ(*,'(I5)')   IST
      WRITE(*,'(a,$)') ' ENDING SUBSET TO BE PRINTED : '
      READ(*,'(I6)')   IEND
C
      ICODE=0
      CALL BUPRT(ICODE,IST,IEND,KELEM,CNAME,CUNIT,CVAL,
     1           KVALS1,VALUE,ISUP,ISEC1,IERR)
C
C      
      IREP=IREP+1
C   
      IF(IREP.GT.3) GO TO 900 
      GO TO 900
C
 810  CONTINUE
C
      WRITE(*,'(1H ,A)') 'OPEN ERROR ON INPUT FILE'
      GO TO 900
C      
 800  CONTINUE
C
      IF(IERR.EQ.-1) THEN
         print*,'Number of records processed ',IREP
      ELSE
         print*,' BUFR : error= ',ierr
      END IF
C
 900  CONTINUE
C
      STOP
      END
