da_bufr_little_endian.f90
References to this file elsewhere.
1 program da_bufr_little_endian
2
3 #ifdef crayx1
4 #define iargc ipxfargc
5 external getarg
6 #endif
7
8 C$$$ MAIN PROGRAM DOCUMENTATION BLOCK
9 C
10 C MAIN PROGRAM: grabbufr
11 C PRGMMR: Gilbert ORG: NP11 DATE: 99-07-13
12 C
13 C ABSTRACT: This program extracts all the BUFR messages from any
14 C file and writes them back out to another file. It is being used
15 C to convert the blocking structure of a BUFR file to standard unix
16 C Fortran format. Also, the program converts any BUFR edition 0 and 1
17 C messages to a BUFR edition 2 message before they are written out.
18 C
19 C PROGRAM HISTORY LOG:
20 C 1999-07-13 Gilbert
21 C 1999-12-22 Gilbert - Made cbuf array allocatable so that there
22 C would be no hard wired size limit.
23 C
24 C USAGE: grabbufr inputBUFRfile ouputBUFRfile
25 C
26 C INPUT FILES:
27 C unit 11 - Input BUFR file.
28 C
29 C OUTPUT FILES:
30 C unit 51 - Output BUFR file.
31 C
32 C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES)
33 C UNIQUE: - lenbufr
34 C LIBRARY:
35 C System - getarg stat
36 C W3LIB - errexit gbyte sbyte
37 C
38 C EXIT STATES:
39 C COND = 0 - SUCCESSFUL RUN
40 C = 2 - Incorrect argument list
41 C = 4 - Coud not allocate memory to hold Input BUFR file
42 C = 99 - Could not obtain size of input BUFR file
43 C
44 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
45 C
46 C ATTRIBUTES:
47 C LANGUAGE: Fortran 90
48 C MACHINE: IBM SP
49 C
50 C$$$
51 character,allocatable :: cbuf(:)
52 CHARACTER(len=80) :: infile,outfile
53 character(len=4) :: bufr='BUFR',ctemp,csec0
54 INTEGER(4) narg,iargc,JSTAT(100)
55 integer findbufr
56 character*1 byte(8)
57
58 data i1/11/,i2/51/,newed/2/
59
60 call wrdlen
61 C
62 C GET Filename ARGUMENTS
63 C
64 NARG=iargc()
65 IF(NARG.NE.2) THEN
66 PRINT *,'grabbufr: Incorrect usage'
67 PRINT *,'Usage: grabbufr inputBUFRfile ouputBUFRfile'
68 CALL EXIT(2)
69 ENDIF
70 call getarg(1,infile)
71 infile = TRIM(infile)//CHAR(0)
72 call getarg(2,outfile)
73 outfile = TRIM(outfile)//CHAR(0)
74 C
75 C Use STAT function to get size of input BUFR file
76 C
77 #ifdef crayx1
78 stop "no STAT function available on crayx1"
79 #else
80 IF (STAT(infile,JSTAT).NE.0) THEN
81 PRINT *,'ERROR IN FUNCTION STAT GETTING FILE STATS'
82 CALL EXIT(99)
83 ELSE
84 c KBYTES = JSTAT(8)
85 KBYTES = JSTAT(12)
86 PRINT *,'NUMBER OF BYTES IN INPUT BUFR FILE = ',KBYTES
87 ENDIF
88 #endif
89 C
90 C Allocate array cbuf to store input file in memory.
91 C
92 allocate(cbuf(kbytes),stat=istat)
93 IF (istat.ne.0) THEN
94 PRINT *,' ERROR Allocating ',kbytes,' bytes to read in file ',
95 & infile
96 CALL EXIT(4)
97 ENDIF
98 C
99 C Read input BUFR file into cbuf
100 C
101 open(i1,recl=kbytes,file=infile,access='direct')
102 read(i1,rec=1) (cbuf(j),j=1,kbytes)
103 C
104 C Open output BUFR file
105 C
106 open(i2,file=outfile,access='sequential',form='unformatted')
107
108 ibeg=1
109 icnt=0
110 C
111 C Process each BUFR message in the input file.
112 C
113 do
114 C Search for next BUFR message
115 ipos=findbufr(cbuf,ibeg,kbytes)
116 if (ipos.eq.0) exit
117 C ibeg=ibeg+ipos-1
118 ibeg=ipos
119 icnt=icnt+1
120 C Extract BUFR edition number
121 call gbyte(cbuf(ibeg),ied,56,8)
122 C Calculate length of BUFR message
123 if (ied.le.1) then
124 ilen=lenbufr(cbuf(ibeg))
125 else
126 call gbyte(cbuf(ibeg),ilen,32,24)
127 endif
128 C Check ending 7777 to see if we have a complete BUFR message
129 iend=ibeg+ilen-1
130 C ctemp=cbuf(iend-3)//cbuf(iend-2)//cbuf(iend-1)//cbuf(iend)
131 CALL CHRTRNA(CTEMP,CBUF(IEND-3),4)
132 if ( ctemp.eq.'7777') then
133 C If BUFR message is edition 0 or 1, convert to edition 2 format
134 if (ied.le.1) then
135 call sbyte(ctemp,ilen+4,0,24)
136 call sbyte(ctemp,newed,24,8)
137 write(i2) bufr,ctemp,(cbuf(j),j=ibeg+4,iend)
138 else
139 write(i2) (cbuf(j),j=ibeg,iend),(byte(j),j=1,8-mod(ilen,8))
140 endif
141 C print *,' BUFR message ',icnt,' was copied. ',ilen,
142 C & ' bytes: from ',ibeg,' to ',iend
143 ibeg=iend
144 else
145 print *,' Invalid BUFR message ',icnt,' at ',ibeg
146 ibeg=ibeg+1
147 C ibeg=ibeg+ilen
148 icnt=icnt-1
149 endif
150 enddo
151
152 print *,'grabbufr: ',icnt,' BUFR messages copied. '
153
154 stop
155 end
156
157 integer function lenbufr(cbufr)
158 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
159 C . . . .
160 C SUBPROGRAM: lenbufr
161 C PRGMMR: Gilbert ORG: NP11 DATE: 99-07-13
162 C
163 C ABSTRACT: Calculates the length of a given BUFR message in bytes.
164 C
165 C PROGRAM HISTORY LOG:
166 C 1999-07-13 Gilbert
167 C
168 C USAGE: integer function lenbufr(cbufr)
169 C INPUT ARGUMENT LIST:
170 C cbufr - Input BUFR message
171 C
172 C RETURN VALUE:
173 C lenbufr - length of BUFR message in bytes
174 C
175 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
176 C
177 C ATTRIBUTES:
178 C LANGUAGE: Fortran 90
179 C MACHINE: IBM SP
180 C
181 C$$$
182 character*(*) cbufr
183 integer ipos,itemp,isec
184
185 lenbufr=4 ! Section 0
186 ipos=32
187 call gbyte(cbufr,itemp,ipos,24) ! Section 1
188 lenbufr=lenbufr+itemp !
189
190 call gbyte(cbufr,isec,88,1)
191 if (isec.eq.1) then
192 ipos=lenbufr*8
193 call gbyte(cbufr,itemp,ipos,24) ! Section 2,
194 lenbufr=lenbufr+itemp ! if included.
195 endif
196 ipos=lenbufr*8
197 call gbyte(cbufr,itemp,ipos,24) ! Section 3
198 lenbufr=lenbufr+itemp !
199 ipos=lenbufr*8
200 call gbyte(cbufr,itemp,ipos,24) ! Section 4
201 lenbufr=lenbufr+itemp !
202 lenbufr=lenbufr+4 ! Section 5
203
204 return
205 end
206
207 integer function findbufr(cbufr,ibeg,iend)
208 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
209 C . . . .
210 C SUBPROGRAM: findbufr
211 C PRGMMR: Gilbert ORG: NP11 DATE: 99-12-22
212 C
213 C ABSTRACT: Finds the first occurence of string 'BUFR' in character
214 C array cbufr starting at element ibeg and searching to
215 C element iend and returns the element of the array
216 C where the string begins. If the string 'BUFR' is not found,
217 C findbufr returns 0.
218 C
219 C PROGRAM HISTORY LOG:
220 C 1999-12-22 Gilbert
221 C
222 C USAGE: integer function lenbufr(cbufr,ibeg,iend)
223 C INPUT ARGUMENT LIST:
224 C cbufr - Input character buffer
225 C ibeg - Array element number to begin search.
226 C iend - Array element number to end search.
227 C
228 C RETURN VALUE:
229 C findbufr - Array element number where string 'BUFR' begins
230 C
231 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
232 C
233 C ATTRIBUTES:
234 C LANGUAGE: Fortran 90
235 C MACHINE: IBM SP
236 C
237 C$$$
238 character cbufr(iend)
239 character(len=4) :: bufr='BUFR',ctemp
240
241 findbufr=0
242 do i=ibeg,iend-3
243 C ctemp=cbufr(i)//cbufr(i+1)//cbufr(i+2)//cbufr(i+3)
244 CALL CHRTRNA(CTEMP,CBUFR(I),4)
245 if ( ctemp .eq. bufr ) then
246 findbufr=i
247 return
248 endif
249 enddo
250
251 return
252 end
253 C-----------------------------------------------------------------------
254 C THIS PROGRAM WRITTEN BY.....
255 C DR. ROBERT C. GAMMILL, CONSULTANT
256 C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH
257 C MAY 1972
258 C
259 C CHANGES FOR SiliconGraphics IRIS-4D/25
260 C SiliconGraphics 3.3 FORTRAN 77
261 C March 1991, RUSSELL E. JONES
262 C NATIONAL WEATHER SERVICE
263 C
264 C THIS IS THE FORTRAN VERSION OF GBYTE
265 C
266 C-----------------------------------------------------------------------
267 C
268 C SUBROUTINE GBYTE (IPACKD,IUNPKD,NOFF,NBITS)
269 C
270 C PURPOSE TO UNPACK A BYTE INTO A TARGET WORD. THE
271 C UNPACKED BYTE IS RIGHT-JUSTIFIED IN THE
272 C TARGET WORD, AND THE REMAINDER OF THE
273 C WORD IS ZERO-FILLED.
274 C
275 C USAGE CALL GBYTE(IPACKD,IUNPKD,NOFF,NBITS)
276 C
277 C ARGUMENTS
278 C
279 C ON INPUT IPACKD
280 C THE WORD OR ARRAY CONTAINING THE BYTE TO BE
281 C UNPACKED.
282 C
283 C IUNPKD
284 C THE WORD WHICH WILL CONTAIN THE UNPACKED
285 C BYTE.
286 C
287 C NOFF
288 C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT,
289 C IN 'IPACKD' IN ORDER TO LOCATE THE BYTE
290 C TO BE UNPACKED.
291 C
292 C NBITS
293 C NUMBER OF BITS IN THE BYTE TO BE UNPACKED.
294 C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32
295 C BITS ON 32 BIT MACHINE.
296 C
297 C ON OUTPUT IUNPKD
298 C CONTAINS THE REQUESTED UNPACKED BYTE.
299 C-----------------------------------------------------------------------
300 SUBROUTINE GBYTE(IPACKD,IUNPKD,NOFF,NBITS)
301
302 INTEGER IPACKD(*)
303 INTEGER IUNPKD
304 DATA IFIRST/1/
305 SAVE IFIRST
306
307 C-----------------------------------------------------------------------
308 C-----------------------------------------------------------------------
309
310 IF(IFIRST.EQ.1) THEN
311 CALL WRDLEN
312 IFIRST = 0
313 ENDIF
314
315 IBIT = NOFF
316 CALL UPB(IUNPKD,NBITS,IPACKD,IBIT)
317
318 RETURN
319 END
320 C-----------------------------------------------------------------------
321 C THIS PROGRAM WRITTEN BY.....
322 C DR. ROBERT C. GAMMILL, CONSULTANT
323 C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH
324 C JULY 1972
325 C
326 C THIS IS THE FORTRAN 32 bit VERSION OF SBYTE.
327 C Changes for SiliconGraphics IRIS-4D/25
328 C SiliconGraphics 3.3 FORTRAN 77
329 C MARCH 1991 RUSSELL E. JONES
330 C NATIONAL WEATHER SERVICE
331 C
332 C-----------------------------------------------------------------------
333 C
334 C SUBROUTINE SBYTE (IPACKD,IUNPKD,NOFF,NBITS)
335 C
336 C PURPOSE GIVEN A BYTE, RIGHT-JUSTIFIED IN A WORD, TO
337 C PACK THE BYTE INTO A TARGET WORD OR ARRAY.
338 C BITS SURROUNDING THE BYTE IN THE TARGET
339 C AREA ARE UNCHANGED.
340 C
341 C USAGE CALL SBYTE (IPACKD,IUNPKD,NOFF,NBITS)
342 C
343 C ARGUMENTS
344 C ON INPUT IPACKD
345 C THE WORD OR ARRAY WHICH WILL CONTAIN THE
346 C PACKED BYTE. BYTE MAY CROSS WORD BOUNDARIES.
347 C
348 C IUNPKD
349 C THE WORD CONTAINING THE RIGHT-JUSTIFIED BYTE
350 C TO BE PACKED.
351 C
352 C NOFF
353 C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT,
354 C IN 'IPACKD' IN ORDER TO LOCATE WHERE THE
355 C BYTE IS TO BE PACKED.
356 C
357 C NBITS
358 C NUMBER OF BITS IN THE BYTE TO BE PACKED.
359 C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32
360 C BITS ON 32 BIT MACHINE.
361 C
362 C ON OUTPUT IPACKD
363 C WORD OR CONSECUTIVE WORDS CONTAINING THE
364 C REQUESTED BYTE.
365 C-----------------------------------------------------------------------
366 SUBROUTINE SBYTE(IPACKD,IUNPKD,NOFF,NBITS)
367
368 INTEGER IUNPKD
369 INTEGER IPACKD(*)
370 DATA IFIRST/1/
371 SAVE IFIRST
372
373 C-----------------------------------------------------------------------
374 C-----------------------------------------------------------------------
375
376 IF(IFIRST.EQ.1) THEN
377 CALL WRDLEN
378 IFIRST = 0
379 ENDIF
380
381 IBIT = NOFF
382 CALL PKB(IUNPKD,NBITS,IPACKD,IBIT)
383
384 END
385
386 SUBROUTINE wrf_abort
387 STOP
388 END SUBROUTINE wrf_abort
389
390 #ifdef crayx1
391
392 subroutine getarg(i, harg)
393 implicit none
394 character(len=*) :: harg
395 integer :: ierr, ilen, i
396
397 call pxfgetarg(i, harg, ilen, ierr)
398 end subroutine getarg
399 #endif
400
401
402
403