1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
|
C Copyright 1981-2007 ECMWF
C
C Licensed under the GNU Lesser General Public License which
C incorporates the terms and conditions of version 3 of the GNU
C General Public License.
C See LICENSE and gpl-3.0.txt for details.
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.7E38
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
|
