1      PROGRAM SNOW_KEY_REPACK
2C
3C**** *SNOW_KEY_REPACK*
4C
5C
6C     PURPOSE.
7C     --------
8C         Change the date in the section 2
9C
10C
11C**   INTERFACE.
12C     ----------
13C
14C          NONE.
15C
16C     METHOD.
17C     -------
18C
19C          NONE.
20C
21C
22C     EXTERNALS.
23C     ----------
24C
25C         CALL BUSEL
26C         CALL BUFREX
27C         CALL BUFREN
28C         CALL BUPRS0
29C         CALL BUPRS1
30C         CALL BUPRS2
31C         CALL BUPRS3
32C         CALL BUPRT
33C         CALL BUUKEY
34C
35C     REFERENCE.
36C     ----------
37C
38C          NONE.
39C
40C     AUTHOR.
41C     -------
42C
43C          M. DRAGOSAVAC    *ECMWF*       15/02/2004.
44C
45C
46C     MODIFICATIONS.
47C     --------------
48C
49C          NONE.
50C
51C
52      IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
53C
54      PARAMETER(JSUP =   9,JSEC0=   3,JSEC1= 40,JSEC2=4096 ,JSEC3= 4,
55     1      JSEC4=   2,JELEM=160000,JSUBS=400,JCVAL=150 ,JBUFL=512000,
56#ifdef JBPW_64
57     2          JBPW =  64,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200,
58#else
59     2          JBPW =  32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200,
60#endif
61     3          JWORK=4096000,JKEY=46,JBYTE=512000)
62C
63      PARAMETER (KELEM=9)
64      PARAMETER (KVALS=360000)
65C
66      DIMENSION KBUFF(JBUFL)
67      DIMENSION KBUFR(JBUFL)
68      DIMENSION KSUP(JSUP)  ,KSEC0(JSEC0),KSEC1(JSEC1)
69      DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4)
70      DIMENSION KEY  (JKEY),KREQ(2)
71C
72      REAL*8 VALUES(KVALS),RQV(KELEM)
73      REAL*8 RVIND,EPS
74      DIMENSION KTDLST(JELEM),KTDEXP(JELEM),KRQ(KELEM)
75      DIMENSION KDATA(200)
76C
77      CHARACTER*256 CF(100),COUT,CFIN
78      CHARACTER*64 CNAMES(KELEM)
79      CHARACTER*24 CUNITS(KELEM)
80      CHARACTER*80 CVALS(KVALS)
81      CHARACTER*80 YENC
82      CHARACTER*256 CARG(10)
83      CHARACTER*10 CDATE
84C
85cs      EXTERNAL GETARG
86C
87C     ------------------------------------------------------------------
88C*          1. INITIALIZE CONSTANTS AND VARIABLES.
89C              -----------------------------------
90 100  CONTINUE
91C
92C     MISSING VALUE INDICATOR
93C
94      ITLEN=6400
95      ITL=0
96      JZ=0
97      NW=0
98      NBYTES=JBPW/8
99      RVIND=1.7D38
100      NVIND=2147483647
101      IOBS=0
102      KRQL=0
103      NR=0
104      KREQ(1)=0
105      KREQ(2)=0
106      DO 102 I=1,KELEM
107      RQV(I)=RVIND
108      KRQ(I)=NVIND
109 102  CONTINUE
110C
111C     INPUT FILE NAMES
112C
113      NARG=IARGC()
114      IF(NARG.LT.6) THEN
115      PRINT*,'USAGE --snow_key_repack
116     1 -i infile -d yyyymmddhh -o outfile'
117         STOP
118      END IF
119      NFILE=NARG
120C
121      DO 104 J=1,NARG
122      CALL GETARG(J,CARG(J))
123 104  CONTINUE
124
125      II=0
126      IO=0
127      DO 105 J=1,NARG
128      IF(CARG(J).EQ.'-i') THEN
129         IN=J
130      ELSEIF(CARG(J).EQ.'-o') THEN
131         IO=J
132      ELSEIF(CARG(J).EQ.'-d') THEN
133         ID=J
134      END IF
135 105  CONTINUE
136      IF(IO.EQ.0.OR.IN.EQ.0.or.ID.EQ.0) THEN
137       PRINT*,'USAGE --snow_key_repack
138     1 -i infile -d yyyymmddhh -o outfile'
139         STOP
140      END IF
141C
142      COUT=CARG(IO+1)
143      CDATE=CARG(ID+1)
144      CFIN=CARG(IN+1)
145C
146      JJ=INDEX(COUT,' ')
147C
148      CALL PBOPEN(IUNIT1,COUT(1:JJ),'W',IRET)
149      IF(IRET.EQ.-1) STOP 'OPEN FAILED ON BUFR.DAT'
150      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
151      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
152C
153      ILN=INDEX(CFIN,' ')
154C
155C*          1.2 OPEN FILE CONTAINING BUFR DATA.
156C               -------------------------------
157 120  CONTINUE
158C
159      IRET=0
160      CALL PBOPEN(IUNIT,CFIN(1:ILN),'R',IRET)
161      IF(IRET.EQ.-1) STOP 'OPEN FAILED'
162      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
163      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
164C
165C     -----------------------------------------------------------------
166C*          2. SET REQUEST FOR EXPANSION.
167C              --------------------------
168 200  CONTINUE
169C
170      OPRT=.FALSE.
171      OENC=.TRUE.
172      NCOM=1
173      OCOMP=.FALSE.
174      NR=0
175      OSEC3=.FALSE.
176C
177C*          2.1 SET REQUEST FOR PARTIAL EXPANSION.
178C               ----------------------------------
179 210  CONTINUE
180C
181C     SET VARIABLE TO PACK BIG VALUES AS MISSING VALUE INDICATOR
182C
183      KPMISS=1
184      KPRUS=0
185      NOKEY=0
186      CALL BUPRQ(KPMISS,KPRUS,NOKEY)
187C
188C     -----------------------------------------------------------------
189C*          3.  READ BUFR MESSAGE.
190C               ------------------
191 300  CONTINUE
192C
193      IERR=0
194      KBUFL=0
195C
196      IRET=0
197      CALL PBBUFR(IUNIT,KBUFF,JBYTE,KBUFL,IRET)
198      IF(IRET.EQ.-1) THEN
199          GO TO 900
200      END IF
201      IF(IRET.EQ.-2) STOP 'FILE HANDLING PROBLEM'
202      IF(IRET.EQ.-3) STOP 'ARRAY TOO SMALL FOR PRODUCT'
203C
204      N=N+1
205      IKBUFL=KBUFL
206      KBUFL=KBUFL/NBYTES+1
207      IF(N.LT.NR) GO TO 300
208C
209C     -----------------------------------------------------------------
210C*          4. EXPAND BUFR MESSAGE.
211C              --------------------
212 400  CONTINUE
213C
214      CALL BUS012(KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KERR)
215      IF(KERR.NE.0) THEN
216         PRINT*,'ERROR IN BUS012: ',KERR
217         PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.'
218         KERR=0
219         GO TO 300
220      END IF
221C
222      IF(KSUP(6).GT.1) THEN
223         KEL=JWORK/KSUP(6)
224         if(kel.gt.kelem) kel=kelem
225      ELSE
226         KEL=KELEM
227      END IF
228C
229      CALL BUFREX(KBUFL,KBUFF,KSUP,KSEC0 ,KSEC1,KSEC2 ,KSEC3 ,KSEC4,
230     1            KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR)
231C
232      IF(IERR.NE.0) THEN
233         IF(IERR.EQ.45) GO TO 300
234         CALL EXIT(2)
235      END IF
236      IOBS=IOBS+KSEC3(3)
237C
238      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
239      IF(KERR.NE.0) CALL EXIT(2)
240C
241C*          4.1 PRINT CONTENT OF EXPANDED DATA.
242C               -------------------------------
243 410  CONTINUE
244C
245      IF(.NOT.OPRT) GO TO 500
246      IF(.NOT.OSEC3) GO TO 450
247C
248C*          4.2 PRINT SECTION ZERO OF BUFR MESSAGE.
249C               -----------------------------------
250 420  CONTINUE
251C
252
253      CALL BUPRS0(KSEC0)
254C
255C*          4.3 PRINT SECTION ONE OF BUFR MESSAGE.
256C               -----------------------------------
257 430  CONTINUE
258C
259      CALL BUPRS1(KSEC1)
260C
261C
262C*          4.4 PRINT SECTION TWO OF BUFR MESSAGE.
263C               -----------------------------------
264 440  CONTINUE
265C
266C              AT ECMWF SECTION 2 CONTAINS RDB KEY.
267C              SO UNPACK KEY
268C
269      CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
270C
271C              PRINT KEY
272C
273      CALL BUPRS2(KSUP ,KEY)
274C
275C*          4.5 PRINT SECTION 3 OF BUFR MESSAGE.
276C               -----------------------------------
277 450  CONTINUE
278C
279C               FIRST GET DATA DESCRIPTORS
280C
281      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
282      IF(KERR.NE.0) CALL EXIT(2)
283C
284C               PRINT  CONTENT
285C
286      IF(OSEC3) THEN
287         CALL BUPRS3(KSEC3,KTDLEN,KTDLST,KTDEXL,KTDEXP,KEL,CNAMES)
288      END IF
289C
290C*         4.6 PRINT SECTION 4 (DATA).
291C              -----------------------
292 460  CONTINUE
293C
294C          IN THE CASE OF MANY SUBSETS DEFINE RANGE OF SUBSETS
295C
296      IF(.NOT.OO) THEN
297      WRITE(*,'(A,$)') ' STARTING SUBSET TO BE PRINTED : '
298      READ(*,'(BN,I4)')   IST
299      WRITE(*,'(A,$)') ' ENDING SUBSET TO BE PRINTED : '
300      READ(*,'(BN,I4)')   IEND
301      OO=.FALSE.
302      END IF
303C
304C              PRINT DATA
305C
306      ICODE=0
307      CALL BUPRT(ICODE,IST,IEND,KEL,CNAMES,CUNITS,CVALS,
308     1           KVALS,VALUES,KSUP,KSEC1,IERR)
309C
310C              RESOLVE BIT MAPS
311C
312      IF(IEND.GT.KSEC3(3)) IEND=KSEC3(3)
313C
314C     DO 461 IK=IST,IEND
315C
316C     CALL BUBOX(IK,KSUP,KEL,KTDEXP,CNAMES,CUNITS,KVALS,VALUES,
317C    1           KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU,IERR)
318C
319C     CALL BUPRTBOX(KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU)
320C
321C461  CONTINUE
322C
323C     -----------------------------------------------------------------
324C*          5. COLLECT DATA FOR REPACKING.
325C              ---------------------------
326 500  CONTINUE
327C
328      IF(.NOT.OENC) GO TO 300
329C
330C               FIRST GET DATA DESCRIPTORS
331C
332      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
333      IF(KERR.NE.0) CALL EXIT(2)
334C
335C     -----------------------------------------------------------------
336C*          6. PACK BUFR MESSAGE BACK INTO BUFR.
337C              ---------------------------------
338 600  CONTINUE
339C
340
341      KKK=0
342      KBUFL=JBUFL
343C
344C     GET REPLICATION FACTORS
345C
346      KK=0
347      DO 601 K=1,KSUP(5)
348      IF(KTDEXP(K).EQ.31001.OR.KTDEXP(K).EQ.31002.OR.
349     1   KTDEXP(K).EQ.31000) THEN
350         KK=KK+1
351         KDATA(KK)=NINT(VALUES(K))
352      END IF
353 601  CONTINUE
354C
355      KDLEN=2
356      IF(KK.NE.0) KDLEN=KK
357C
358C     --------------------------------
359C     |Modification to sections error|
360C     --------------------------------
361C
362C     -----------------------------------------------------------------------
363C
364C*          6.2 ENCODE DATA INTO BUFR MESSAGE.
365C               ------------------------------
366 620  CONTINUE
367C
368      IF(KSEC1(5).NE.0) THEN
369         CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
370         IF(KERR.NE.0) THEN
371            PRINT*,'BUUKEY: ERROR ',KERR
372            CALL EXIT(2)
373         END IF
374C
375C
376         ksec2(1)=52
377c
378         read(cdate,'(i4,i2,i2,i2)') iyyy,imm,idd,ihh
379c
380         key(1)=52
381         key(4)=iyyy
382         key(5)=imm
383         key(6)=idd
384         key(7)=ihh
385         key(8)=0
386         key(9)=0
387         key(15)=0
388         key(16)=48
389         do iz=17,24
390         key(iz)=32
391         end do
392      else
393         read(cdate,'(i4,i2,i2,i2)') iyyy,imm,idd,ihh
394         ksec2(1)=52
395         ksec1(5)=128
396         key( 1)=52
397         key( 2)=1
398         key( 3)=165
399         key( 4)=iyyy
400         key( 5)=imm
401         key( 6)=idd
402         key( 7)=ihh
403         key( 8)=0
404         key( 9)=0
405c
406         call fmmh(6,7,kel,values,ksec3,rminlat,rminlon,
407     1             rmaxlat,rmaxlon)
408c
409         key(10)=nint(rminlon*100000.+18000000.)
410         key(11)=nint(rminlat*100000.+9000000.)
411         key(12)=nint(rmaxlon*100000.+18000000.)
412         key(13)=nint(rmaxlat*100000.+9000000.)
413         key(14)=ksec3(3)
414         key(15)=0
415c
416         key(16)=48
417         do iy=17,24
418           key(iy)=32
419         end do
420c
421         key(26)=0
422         key(27)=0
423         key(28)=0
424         key(29)=0
425         key(30)=0
426         key(31)=0
427         key(32)=0
428         key(33)=0
429         do iy=34,45
430         key(iy)=0
431         end do
432         key(46)=70
433      END IF
434C
435C     PACK NEW RDB KEY
436C
437C
438      CALL BUPKEY(KEY,KSEC1,KSEC2,KERR)
439      IF(KERR.NE.0) CALL EXIT(2)
440C
441      KSEC3(4)=128
442      IF(KSEC3(3).GT.1) KSEC3(4)=192
443      CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4,
444     1             KTDLEN,KTDLST,KDLEN,KDATA,KEL,        !KSUP(5),
445     2             KVALS,VALUES,CVALS,KBUFL,KBUFR,KERR)
446C
447      IF(KERR.GT.0) THEN
448         PRINT*,'ERROR DURING ENCODING.'
449         CALL EXIT(2)
450      END IF
451C
452C           6.3 WRITE PACKED BUFR MESSAGE INTO FILE.
453C               ------------------------------------
454 630  CONTINUE
455C
456      IKBUFL=KBUFL*4
457      CALL PBWRITE(IUNIT1,KBUFR,IKBUFL,IERR)
458      IF(IERR.LT.0) THEN
459         PRINT*,'ERROR WRITING INTO TARGET FILE.'
460         CALL EXIT(2)
461      END IF
462C
463      NW=NW+1
464C
465      GO TO 300
466C     -----------------------------------------------------------------
467C
468 810  CONTINUE
469C
470      WRITE(*,'(1H ,A)') 'OPEN ERROR ON INPUT FILE'
471      GO TO 900
472C
473 800  CONTINUE
474C
475      IF(IRET.EQ.-1) THEN
476         PRINT*,'NUMBER OF RECORDS PROCESSED ',N
477         PRINT*,'NUMBER OF RECORDS CONVERTED ',NW
478c
479      ELSE
480         PRINT*,' BUFR : ERROR= ',IERR
481      END IF
482C
483 900  CONTINUE
484C
485      PRINT*,'NUMBER OF RECORDS PROCESSED ',N
486      PRINT*,'NUMBER OF RECORDS CONVERTED ',NW
487C
488      CALL PBCLOSE(IUNIT,IRET)
489C
490      CALL PBCLOSE(IUNIT1,IRET)
491C
492      END
493