| blob | c636e479ba28e153f522158d17f35d13366b716b |
1 PROGRAM BUFR
2 C
3 C**** *BUFR*
4 C
5 C
6 C PURPOSE.
7 C --------
8 C EXAMPLE OF USING BUFR UNPACKING/PACKING SOFTWARE.
9 C
10 C
11 C** INTERFACE.
12 C ----------
13 C
14 C NONE.
15 C
16 C METHOD.
17 C -------
18 C
19 C NONE.
20 C
21 C
22 C EXTERNALS.
23 C ----------
24 C
25 C CALL BUSEL
26 C CALL BUFREX
27 C CALL BUFREN
28 C CALL BUPRS0
29 C CALL BUPRS1
30 C CALL BUPRS2
31 C CALL BUPRS3
32 C CALL BUPRT
33 C CALL BUUKEY
34 C
35 C REFERENCE.
36 C ----------
37 C
38 C NONE.
39 C
40 C AUTHOR.
41 C -------
42 C
43 C M. DRAGOSAVAC *ECMWF* 15/09/87.
44 C
45 C
46 C MODIFICATIONS.
47 C --------------
48 C
49 C NONE.
50 C
51 C
52 IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
53 C
54 PARAMETER(JSUP = 9,JSEC0= 3,JSEC1= 40,JSEC2= 64 ,JSEC3= 4,
55 1 JSEC4= 2,JELEM=80000,JSUBS=400,JCVAL=150 ,JBUFL=512000,
56 #ifdef JBPW_64
57 2 JBPW = 64,JTAB =1000,JCTAB=120,JCTST=1800,JCTEXT=1200,
58 #else
59 2 JBPW = 32,JTAB =1000,JCTAB=120,JCTST=1800,JCTEXT=1200,
60 #endif
61 3 JWORK=4096000,JKEY=46,JBYTE=2048000)
62 C
63 PARAMETER (KELEM=40000)
64 PARAMETER (KVALS=4096000)
65 C
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)
71 DIMENSION NREQUEST(2)
72 C
73 REAL*8 VALUES(KVALS),VALUE(KVALS)
74 REAL*8 VALS(KVALS)
75 REAL*8 RQV(KELEM)
76 REAL*8 RVIND,EPS
77 C
78 DIMENSION KTDLST(JELEM),KTDEXP(JELEM),KRQ(KELEM)
79 DIMENSION KDATA(200),KBOXR(JELEM*4)
81 C
82 CHARACTER*256 CFIN,COUT,CARG(4)
83 CHARACTER*64 CNAMES(KELEM),CBOXN(JELEM*4)
84 CHARACTER*24 CUNITS(KELEM),CBOXU(JELEM*4)
85 CHARACTER*80 CVALS(kelem)
86 CHARACTER*80 CVAL(kelem)
87 CHARACTER*80 YENC
88 C
89 C ------------------------------------------------------------------
90 C* 1. INITIALIZE CONSTANTS AND VARIABLES.
91 C -----------------------------------
92 100 CONTINUE
93 C
94 C MISSING VALUE INDICATOR
95 C
96 RVIND=1.7E38
97 NVIND=2147483647
98 C
99 NBYTPW=JBPW/8
100 IOBS=0
101 EPS=1.E-8
102 NPACK=0
103 N=0
104 OO=.FALSE.
105 KKK=0
106 C
107 C GET INPUT AND OUTPUT FILE NAME.
108 C
109 NARG=COMMAND_ARGUMENT_COUNT()
110 C
111 C
112 DO 104 J=1,NARG
113 CALL GET_COMMAND_ARGUMENT(number=J, value=CARG(J))
114 104 CONTINUE
116 II=0
117 IO=0
118 DO 105 J=1,NARG
119 IF(CARG(J).EQ.'-i') THEN
120 IN=J
121 ELSEIF(CARG(J).EQ.'-o') THEN
122 IO=J
123 END IF
124 105 CONTINUE
125 IF(IN.EQ.0) THEN
126 PRINT*,'USAGE -- decode_bufr -i infile'
127 STOP
128 END IF
129 IF(IO.EQ.0.and.IN.EQ.0) THEN
130 PRINT*,'USAGE -- decode_bufr -i infile -o outfile'
131 STOP
132 END IF
134 C
135 IF(IO.NE.0) COUT=CARG(IO+1)
136 C
137 IF(IO.LT.IN) THEN
138 IST=IN+1
139 IEND=NARG
140 ELSE
141 IST=IN+1
142 IEND=IO-1
143 END IF
144 C
145 C
146 IF(IO.NE.0) THEN
147 JJ=INDEX(COUT,' ')
148 JJ=JJ-1
149 CALL PBOPEN(IUNIT1,COUT(1:JJ),'W',IRET)
150 IF(IRET.EQ.-1) STOP 'OPEN FAILED ON BUFR.DAT'
151 IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
152 IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
153 END IF
154 C
155 DO 101 II=IST,IEND
157 CFIN=CARG(II)
158 ILN=INDEX(CFIN,' ')
159 ILN=ILN-1
160 C
161 C SET REQUEST FOR PARTIAL EXPANSION
162 C
163 KRQL=0
164 NR=0
165 KREQ(1)=0
166 KREQ(2)=0
167 DO 103 I=1,KELEM
168 RQV(I)=RVIND
169 KRQ(I)=NVIND
170 103 CONTINUE
171 C
172 C* 1.2 OPEN FILE CONTAINING BUFR DATA.
173 C -------------------------------
174 120 CONTINUE
175 C
176 IRET=0
177 CALL PBOPEN(IUNIT,CFIN(1:ILN),'R',IRET)
178 IF(IRET.EQ.-1) STOP 'OPEN FAILED'
179 IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
180 IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
183 C
184 C
185 C -----------------------------------------------------------------
186 C* 2. SET REQUEST FOR EXPANSION.
187 C --------------------------
188 200 CONTINUE
189 C
190 OPRT=.FALSE.
191 OENC=.FALSE.
192 WRITE(*,'(A,$)') ' DO YOU WANT TO PRINT( Y/N ) : '
193 READ (*,'(A)') YENC
194 IF(YENC(1:1).EQ.'Y'.OR.YENC(1:1).EQ.'y') THEN
195 OPRT=.TRUE.
196 END IF
197 ICODE=0
198 WRITE(*,'(A,$)') ' CODE TABLES TO BE PRINTED ( Y/N ) : '
199 READ (*,'(A)') YCODC
200 IF(YCODC(1:1).EQ.'Y'.OR.YCODC(1:1).EQ.'y') THEN
201 ICODE=1
202 END IF
203 WRITE(*,'(A,$)') ' DO YOU WANT ENCODING( Y/N ) : '
204 READ (*,'(A)') YENC
205 IF(YENC(1:1).EQ.'Y'.OR.YENC(1:1).EQ.'y') THEN
206 OENC=.TRUE.
207 WRITE(*,'(A,$)') ' NUMBER OF SUBSETS TO PACK : '
208 READ(*,'(BN,I4)') NCOM
209 OCOMP=.FALSE.
210 WRITE(*,'(A,$)') ' DO YOU WANT COMPRESSION( Y/N ) : '
211 READ (*,'(A)') YCOMP
212 IF(YCOMP(1:1).EQ.'Y'.OR.YCOMP(1:1).EQ.'y') OCOMP=.TRUE.
213 END IF
214 WRITE(*,'(A,$)') ' RECORD NUMBER TO START FROM : '
215 READ(*,'(BN,I6)') NR
216 C
217 201 CONTINUE
218 C
219 WRITE(*,'(A,$)') ' REQUESTED ELEMENT : '
220 READ(*,'(BN,I6)') IEL
221 WRITE(*,'(A,$)') ' REQUESTED VALUE : '
222 READ(*,'(BN,F12.2)') VAL
223 IF(IEL.EQ.0) THEN
224 KRQL=J
225 ELSE
226 J=J+1
227 KRQ(J)=IEL
228 RQV(J)=VAL
229 IF(VAL.EQ.0.) RQV(J)=RVIND
230 GO TO 201
231 END IF
232 C
233 WRITE(*,'(A,$)') ' REQUESTED FLAG 1 : '
234 READ(*,'(BN,I6)') KREQ(1)
235 C
236 WRITE(*,'(A,$)') ' REQUESTED FLAG 2 : '
237 READ(*,'(BN,I6)') KREQ(2)
238 C
239 WRITE(*,'(A,$)') ' DO YOU WANT TO PRINT SECTION 0-3( Y/N ) : '
240 READ (*,'(A,$)') YENC
241 OSEC3=.FALSE.
242 IF(YENC(1:1).EQ.'Y'.OR.YENC(1:1).EQ.'y') OSEC3=.TRUE.
243 C
244 C* 2.1 SET REQUEST FOR PARTIAL EXPANSION.
245 C ----------------------------------
246 210 CONTINUE
247 C
248 c KERR=0
249 CALL BUSRQ(KREQ,KRQL,KRQ,RQV,KERR)
250 C
251 C SET VARIABLE TO PACK BIG VALUES AS MISSING VALUE INDICATOR
252 C
253 KPMISS=1
254 KPRUS=0
255 KOKEY=0
256 CALL BUPRQ(KPMISS,KPRUS,KOKEY)
257 C
258 C -----------------------------------------------------------------
259 C* 3. READ BUFR MESSAGE.
260 C ------------------
261 300 CONTINUE
262 C
263 IERR=0
264 KBUFL=0
265 C
266 IRET=0
267 CALL PBBUFR(IUNIT,KBUFF,JBYTE,KBUFL,IRET)
268 IF(IRET.EQ.-1) THEN
269 IF(IO.NE.0) THEN
270 IF(NPACK.NE.0) GO TO 600
271 END IF
272 PRINT*,'NUMBER OF SUBSETS ',IOBS
273 PRINT*,'NUMBER OF MESSAGES ',N
274 CALL PBCLOSE(IUNIT,IRET)
275 GO TO 101
276 END IF
277 IF(IRET.EQ.-2) STOP 'FILE HANDLING PROBLEM'
278 IF(IRET.EQ.-3) STOP 'ARRAY TOO SMALL FOR PRODUCT'
279 C
280 N=N+1
281 PRINT*,'----------------------------------',N,' ',KBUFL
282 KBUFL=KBUFL/NBYTPW+1
283 IF(N.LT.NR) GO TO 300
284 C
285 C -----------------------------------------------------------------
286 C* 4. EXPAND BUFR MESSAGE.
287 C --------------------
288 400 CONTINUE
289 C
290 CALL BUS012(KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KERR)
291 IF(KERR.NE.0) THEN
292 PRINT*,'ERROR IN BUS012: ',KERR
293 PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.'
294 KERR=0
295 GO TO 300
296 END IF
297 C
298 KEL=KVALS/KSUP(6)
299 IF(KEL.GT.JELEM) KEL=JELEM
300 C
301 CALL BUFREX(KBUFL,KBUFF,KSUP,KSEC0 ,KSEC1,KSEC2 ,KSEC3 ,KSEC4,
302 1 KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR)
303 C
304 IF(IERR.NE.0) THEN
305 IF(IERR.EQ.39) GO TO 300
306 CALL EXIT(2)
307 END IF
308 C
309 C
310 IOBS=IOBS+KSEC3(3)
311 C
312 NPACK=NPACK+1
313 C
314 CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
315 IF(KERR.NE.0) CALL EXIT(2)
317 C
318 c DO 401 IK=1,KSEC3(3)
319 c
320 c CALL BUBOX(IK,KSUP,KEL,KTDEXP,CNAMES,CUNITS,KVALS,VALUES,
321 c 1 KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU,IERR)
322 C
323 c 401 CONTINUE
324 C
325 c IF(IERR.NE.0) THEN
326 c PRINT*,'bubox error----------------------------------',N
327 c END IF
328 C
329 C* 4.1 PRINT CONTENT OF EXPANDED DATA.
330 C -------------------------------
331 410 CONTINUE
332 C
333 IF(.NOT.OPRT) GO TO 500
334 IF(.NOT.OSEC3) GO TO 450
335 C
336 C* 4.2 PRINT SECTION ZERO OF BUFR MESSAGE.
337 C -----------------------------------
338 420 CONTINUE
339 C
341 CALL BUPRS0(KSEC0)
342 C
343 C* 4.3 PRINT SECTION ONE OF BUFR MESSAGE.
344 C -----------------------------------
345 430 CONTINUE
346 C
347 CALL BUPRS1(KSEC1)
348 C
349 C
350 C* 4.4 PRINT SECTION TWO OF BUFR MESSAGE.
351 C -----------------------------------
352 440 CONTINUE
353 C
354 C AT ECMWF SECTION 2 CONTAINS RDB KEY.
355 C SO UNPACK KEY
356 C
357 CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
358 C
359 C PRINT KEY
360 C
361 CALL BUPRS2(KSUP ,KEY)
362 C
363 C* 4.5 PRINT SECTION 3 OF BUFR MESSAGE.
364 C -----------------------------------
365 450 CONTINUE
366 C
367 C FIRST GET DATA DESCRIPTORS
368 C
369 CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
370 C IF(KERR.NE.0) CALL EXIT(2)
371 C
372 C PRINT CONTENT
373 C
374 IF(OSEC3) THEN
375 CALL BUPRS3(KSEC3,KTDLEN,KTDLST,KTDEXL,KTDEXP,KEL,CNAMES)
376 END IF
377 C
378 C* 4.6 PRINT SECTION 4 (DATA).
379 C -----------------------
380 460 CONTINUE
381 C
382 C IN THE CASE OF MANY SUBSETS DEFINE RANGE OF SUBSETS
383 C
384 IF(.NOT.OO) THEN
385 WRITE(*,'(A,$)') ' STARTING SUBSET TO BE PRINTED : '
386 READ(*,'(BN,I6)') IST
387 WRITE(*,'(A,$)') ' ENDING SUBSET TO BE PRINTED : '
388 READ(*,'(BN,I6)') IEND
389 OO=.FALSE.
390 END IF
391 C
392 C PRINT DATA
393 C
394 ICODE=0
396 C IF(KSEC1(6).EQ.11) THEN
397 C
398 CALL BUPRT(ICODE,IST,IEND,KEL,CNAMES,CUNITS,CVALS,
399 1 KVALS,VALUES,KSUP,KSEC1,IERR)
400 C ELSE
401 C
402 C RESOLVE BIT MAPS
403 C
404 C IF(IEND.GT.KSEC3(3)) IEND=KSEC3(3)
405 c
406 C DO 461 IK=IST,IEND
407 c
408 C CALL BUBOX(IK,KSUP,KEL,KTDEXP,CNAMES,CUNITS,KVALS,VALUES,
409 C 1 KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU,IERR)
410 C IF(IERR.NE.0) CALL EXIT(2)
411 c
412 C CALL BUPRTBOX(KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU)
413 c
414 C461 CONTINUE
415 C END IF
416 C
417 C -----------------------------------------------------------------
418 C* 5. COLLECT DATA FOR REPACKING.
419 C ---------------------------
420 500 CONTINUE
421 C
422 C
423 IF(.NOT.OENC) GO TO 300
424 C
425 C FIRST GET DATA DESCRIPTORS
426 C
427 CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
428 IF(KERR.NE.0) CALL EXIT(2)
429 C
430 DO 501 I=1,KSUP(5)
431 IN=I+(NPACK-1)*KSUP(5)
432 C
433 IF(CUNITS(I).EQ.'CCITTIA5') THEN
434 IPOS =VALUES(I)/1000.
435 ICH=NINT(VALUES(I)-IPOS*1000)
436 KKK=KKK+1
437 VALUE(IN)=KKK*1000+ICH
438 CVAL(KKK)=CVALS(IPOS)
439 ELSE
440 VALUE(IN)=VALUES(I)
441 END IF
442 501 CONTINUE
443 C
444 IF(NPACK.EQ.NCOM) GO TO 600
445 C
446 GO TO 300
447 C -----------------------------------------------------------------
448 C* 6. PACK BUFR MESSAGE BACK INTO BUFR.
449 C ---------------------------------
450 600 CONTINUE
451 C
453 KKK=0
454 KSEC1(5)=0
455 KSEC3(3)=NPACK
456 KSEC1(8)=1
457 KSEC1(15)=6
458 KSEC0(3)=4 ! EDITION 4 OF BUFR MESSAGE
459 KSEC3(4)=128 ! NO COMPRESSION
460 IF(OCOMP) KSEC3(4)=192 ! COMPRESSION
461 KBUFL=JBUFL
462 C
463 C GET REPLICATION FACTORS
464 C
465 KK=0
466 DO 601 K=1,KSUP(5)
467 IF(KTDEXP(K).EQ.31001.OR.KTDEXP(K).EQ.31002) THEN
468 KK=KK+1
469 KDATA(KK)=NINT(VALUE(K))
470 END IF
471 601 CONTINUE
472 C
473 KDLEN=2
474 IF(KK.NE.0) KDLEN=KK
475 IF(KSEC1(5).NE.0) THEN
476 CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
477 IF(KERR.NE.0) THEN
478 PRINT*,'BUUKEY: ERROR ',KERR
479 CALL EXIT(2)
480 END IF
481 C
482 C
483 C GET INFORMATION FOR RDB KEY
484 C
485 CALL BUCRKEY(KSUP(5),KTDEXP,KSUP,KSEC1,KSEC3,KEY,
486 1 VALUE,CVAL,KERR)
487 IF(KERR.NE.0) THEN
488 PRINT*,'ERROR IN BUCREKEY.'
489 call exit(2)
490 END IF
491 C
492 C
493 C PACK NEW RDB KEY
494 C
495 C
496 CALL BUPKEY(KEY,KSEC1,KSEC2,KERR)
497 IF(KERR.NE.0) CALL EXIT(2)
499 END IF
500 C
501 IF(KSUP(6).EQ.0) THEN
502 PRINT*,'ZERO SUBSETS'
503 CALL EXIT(2)
504 END IF
505 C
506 C
507 C* 6.2 ENCODE DATA INTO BUFR MESSAGE.
508 C ------------------------------
509 620 CONTINUE
510 C
511 CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4,
512 1 KTDLEN,KTDLST,KDLEN,KDATA,KSUP(5), ! KEL
513 2 KVALS,VALUE,CVAL,KBUFL,KBUFR,KERR)
514 C
515 IF(KERR.NE.0) THEN
516 PRINT*,'ERROR IS ',KERR
517 PRINT*,'ERROR DURING ENCODING.'
518 CALL EXIT(2)
519 END IF
520 C
521 C 6.3 WRITE PACKED BUFR MESSAGE INTO FILE.
522 C ------------------------------------
523 630 CONTINUE
524 C
525 ILEN=KBUFL*NBYTPW
526 C
527 IERR=0
528 C
529 CALL PBWRITE(IUNIT1,KBUFR,ILEN,IERR)
530 IF(IERR.LT.0) THEN
531 PRINT*,'ERROR WRITING INTO TARGET FILE.'
532 CALL EXIT(2)
533 END IF
534 PRINT*,'RECORD WRITTEN INTO FILE- ILEN=',ilen
535 C
536 NPACK=0
537 C
538 GO TO 300
539 C -----------------------------------------------------------------
540 C
541 101 CONTINUE
542 C
543 IF(IO.NE.0) THEN
544 CALL PBCLOSE(IUNIT1,IRET)
545 END IF
546 C
547 END