91 SUBROUTINE fdebufr ( ofile, tbldir, lentd, tblfil, prmstg,
92 + basic, forcemt, cfms )
96 parameter( mxbf = 2500000 )
97 parameter( mxbfd4 = mxbf/4 )
98 parameter( mxds3 = 500 )
99 parameter( mxprms = 20 )
101 character*(*) ofile, tbldir, tblfil, prmstg
105 character*120 cmorgc, cmgses, cmmtyp, cmmsbt, cmmsbti
106 character*20 ptag( mxprms ), pvtag(2), cprmnm
108 character*6 cds3( mxds3 )
109 character*1 basic, forcemt, opened, usemt, cfms,
112 integer ibfmg( mxbfd4 )
114 equivalence( bfmg(1), ibfmg(1) )
121 OPEN ( unit = 51, file = ofile )
127 OPEN ( unit = lunit, file =
'/dev/null' )
135 ctbldir = tbldir(1:lentd)
149 CALL
crbmg( bfmg, mxbf, nbyt, ierr )
151 IF ( ierr .ne. 0 )
THEN
153 IF ( ierr .eq. -1 )
THEN
154 WRITE ( unit = 51, fmt =
'( /, 2A, I7, A, I9, A )')
155 +
'Reached end of BUFR file; it contained a total ',
156 +
'of', nmsg,
' messages and', nsubt,
' subsets'
158 WRITE ( unit = 51, fmt =
'( /, 2A, I4 )' )
159 +
'Error while reading BUFR file; the return code ',
160 +
'from CRBMG = ', ierr
163 IF ( ( basic .eq.
'N' ) .and. ( opened .eq.
'Y' ) )
THEN
164 WRITE (51, fmt =
'( /, A, / )' )
165 +
'Here is the DX table that was generated:'
175 IF ( opened .eq.
'N' )
THEN
179 CALL
isetprm(
'MAXSS', 300000 )
185 IF ( prmstg(1:8) .ne.
'NULLPSTG' )
THEN
186 CALL
parstr( prmstg, ptag, mxprms, nptag,
',',
188 IF ( nptag .gt. 0 )
THEN
190 CALL
parstr( ptag(ii), pvtag, 2, npvtag,
'=',
192 IF ( npvtag .eq. 2 )
THEN
193 CALL
strsuc( pvtag(1), cprmnm, lcprmnm )
194 CALL
strnum( pvtag(2), ipval )
195 IF ( ( lcprmnm .gt. 0 ) .and.
196 + ( ipval .ne. -1 ) )
197 + CALL
isetprm( cprmnm(1:lcprmnm), ipval )
205 IF ( (
idxmsg( ibfmg ) .eq. 1 ) .and.
206 + ( forcemt .eq.
'N' ) )
THEN
212 CALL
openbf( lunit,
'INUL', lunit )
213 ELSE IF ( ( tblfil(1:8) .ne.
'NULLFILE' ) .and.
214 + ( forcemt .eq.
'N' ) )
THEN
219 INQUIRE ( file = tblfil, exist = exists )
220 IF ( .not. exists )
THEN
221 print *,
'ERROR: COULD NOT FIND FILE ', tblfil
224 OPEN ( unit = 91, file = tblfil, iostat = ier )
225 IF ( ier .ne. 0 )
THEN
226 print *,
'ERROR: COULD NOT OPEN FILE ', tblfil
229 CALL
openbf( lunit,
'IN', 91 )
235 CALL
openbf( lunit,
'SEC3', lunit )
240 CALL
mtinfo( tbldir, 90, 91 )
241 IF ( cfms .eq.
'Y' ) CALL
codflg(
'Y' )
244 IF ( basic .eq.
'N' )
THEN
248 CALL
readerme( ibfmg, lunit, cmgtag, imgdt, ierme )
254 IF ( (
idxmsg( ibfmg ) .ne. 1 ) .or.
255 + ( usemt .eq.
'Y' ) )
THEN
259 WRITE ( unit = 51, fmt =
'( /, A, I7 )' )
260 +
'Found BUFR message #', nmsg
264 WRITE ( 51, fmt=
'( /, A, I9 )' )
265 +
' Message length: ',
267 WRITE ( 51, fmt=
'( A, I4 )' )
268 +
' Section 0 length: ',
270 WRITE ( 51, fmt=
'( A, I4 )' )
276 WRITE ( 51, fmt=
'( /, A, I4 )' )
277 +
' Section 1 length: ',
279 WRITE ( 51, fmt=
'( A, I4 )' )
283 iogce =
iupbs01( ibfmg,
'OGCE' )
284 igses =
iupbs01( ibfmg,
'GSES' )
285 IF ( ( basic .eq.
'Y' ) .or.
286 + ( cfms .eq.
'N' ) )
THEN
287 WRITE ( 51, fmt=
'( A, I5 )' )
288 +
' Originating center: ', iogce
289 WRITE ( 51, fmt=
'( A, I4 )' )
290 +
' Originating subcenter: ', igses
292 CALL
getcfmng( lunit,
'ORIGC', iogce,
' ', -1,
293 + cmorgc, lcmorgc, ierorgc )
294 IF ( ierorgc .eq. 0 )
THEN
295 WRITE ( 51, fmt=
'( A, I5, 3A )' )
296 +
' Originating center: ', iogce,
297 +
' (= ', cmorgc(1:lcmorgc),
')'
299 WRITE ( 51, fmt=
'( A, I5 )' )
300 +
' Originating center: ', iogce
302 CALL
getcfmng( lunit,
'GSES', igses,
304 + cmgses, lcmgses, iergses )
305 IF ( iergses .eq. 0 )
THEN
306 WRITE ( 51, fmt=
'( A, I4, 3A )' )
307 +
' Originating subcenter: ', igses,
308 +
' (= ', cmgses(1:lcmgses),
')'
310 WRITE ( 51, fmt=
'( A, I4 )' )
311 +
' Originating subcenter: ', igses
315 WRITE ( 51, fmt=
'( A, I4 )' )
316 +
' Update sequence numbr: ',
319 IF (
iupbs01( ibfmg,
'ISC2' ) .eq. 1 )
THEN
320 WRITE ( 51, fmt =
'( A )')
321 +
' Section 2 present?: Yes'
323 WRITE ( 51, fmt =
'( A )')
324 +
' Section 2 present?: No'
327 mtyp =
iupbs01( ibfmg,
'MTYP' )
328 msbt =
iupbs01( ibfmg,
'MSBT' )
329 msbti =
iupbs01( ibfmg,
'MSBTI' )
330 IF ( ( basic .eq.
'Y' ) .or.
331 + ( cfms .eq.
'N' ) )
THEN
332 WRITE ( 51, fmt=
'( A, I4 )' )
333 +
' Data category: ', mtyp
334 WRITE ( 51, fmt=
'( A, I4 )' )
335 +
' Local subcategory: ', msbt
336 WRITE ( 51, fmt=
'( A, I4 )' )
337 +
' Internatl subcategory: ', msbti
339 CALL
getcfmng( lunit,
'TABLAT', mtyp,
' ', -1,
340 + cmmtyp, lcmmtyp, iermtyp )
341 IF ( iermtyp .eq. 0 )
THEN
342 WRITE ( 51, fmt=
'( A, I4, 3A )' )
343 +
' Data category: ', mtyp,
344 +
' (= ', cmmtyp(1:lcmmtyp),
')'
346 WRITE ( 51, fmt=
'( A, I4 )' )
347 +
' Data category: ', mtyp
349 CALL
getcfmng( lunit,
'TABLASL', msbt,
351 + cmmsbt, lcmmsbt, iermsbt )
352 IF ( ( iermsbt .eq. 0 ) .and.
353 + ( iogce .eq. 7 ) )
THEN
354 WRITE ( 51, fmt=
'( A, I4, 3A )' )
355 +
' Local subcategory: ', msbt,
356 +
' (= ', cmmsbt(1:lcmmsbt),
')'
358 WRITE ( 51, fmt=
'( A, I4 )' )
359 +
' Local subcategory: ', msbt
361 CALL
getcfmng( lunit,
'TABLASS', msbti,
363 + cmmsbti, lcmmsbti, iermsbti )
364 IF ( iermsbti .eq. 0 )
THEN
365 WRITE ( 51, fmt=
'( A, I4, 3A )' )
366 +
' Internatl subcategory: ', msbti,
367 +
' (= ', cmmsbti(1:lcmmsbti),
')'
369 WRITE ( 51, fmt=
'( A, I4 )' )
370 +
' Internatl subcategory: ', msbti
374 WRITE ( 51, fmt=
'( A, I4 )' )
375 +
' Master table version: ',
377 WRITE ( 51, fmt=
'( A, I4 )' )
378 +
' Local table version: ',
380 WRITE ( 51, fmt=
'( A, I4 )' )
383 WRITE ( 51, fmt=
'( A, I4 )' )
386 WRITE ( 51, fmt=
'( A, I4 )' )
389 WRITE ( 51, fmt=
'( A, I4 )' )
392 WRITE ( 51, fmt=
'( A, I4 )' )
395 WRITE ( 51, fmt=
'( A, I4 )' )
398 IF ( ( iogce .eq. 7 ) .and. ( igses .eq. 3 ) )
THEN
399 CALL
rtrcptb( ibfmg, iryr, irmo, irdy, irhr,
401 IF ( irtret .eq. 0 )
THEN
402 WRITE ( 51, fmt=
'( A, I4 )' )
403 +
' NCEP tank rcpt year: ', iryr
404 WRITE ( 51, fmt=
'( A, I4 )' )
405 +
' NCEP tank rcpt month: ', irmo
406 WRITE ( 51, fmt=
'( A, I4 )' )
407 +
' NCEP tank rcpt day: ', irdy
408 WRITE ( 51, fmt=
'( A, I4 )' )
409 +
' NCEP tank rcpt hour: ', irhr
410 WRITE ( 51, fmt=
'( A, I4 )' )
411 +
' NCEP tank rcpt minute: ', irmi
417 nsub =
iupbs3( ibfmg,
'NSUB' )
418 WRITE ( 51, fmt=
'( /, A, I4 )' )
419 +
' Number of data subsets: ', nsub
422 IF (
iupbs3( ibfmg,
'IOBS' ) .eq. 1 )
THEN
423 WRITE ( 51, fmt =
'( A )')
424 +
' Data are observed?: Yes'
426 WRITE ( 51, fmt =
'( A )')
427 +
' Data are observed?: No'
430 IF (
iupbs3( ibfmg,
'ICMP' ) .eq. 1 )
THEN
431 WRITE ( 51, fmt =
'( A )')
432 +
' Data are compressed?: Yes'
434 WRITE ( 51, fmt =
'( A )')
435 +
' Data are compressed?: No'
438 CALL
upds3( ibfmg, mxds3, cds3, nds3 )
439 WRITE ( 51, fmt=
'( A, I5 )' )
440 +
' Number of descriptors: ', nds3
442 WRITE ( 51, fmt =
'( 5X, I4, A, A6)' )
443 + jj,
": ", cds3( jj )
446 IF ( ( basic .eq.
'N' ) .and.
447 + ( ierme .ge. 0 ) )
THEN
452 + fmt =
'( /, A, I7, 3A, I10, A, I6, A )' )
453 +
'BUFR message #', nmsg,
' of type ', cmgtag,
454 +
' and date ', imgdt,
' contains ', nsub,
456 DO WHILE (
ireadsb( lunit ) .eq. 0 )
461 WRITE ( unit = 51, fmt =
'( /, A, I7 )' )
462 +
'End of BUFR message #', nmsg
463 WRITE ( unit = 51, fmt =
'( /, 120("-"))' )
496 character*240 bftabfil
503 WRITE ( bftab,
'("bufrtab.",i3.3)' ) mtyp
504 bftabfil = ctbldir(1:ltbd) //
'/' // bftab
506 INQUIRE ( file = bftabfil, exist = exists )
510 OPEN ( unit = lundx, file = bftabfil )
subroutine codflg(CF)
This subroutine is used to specify whether or not code and flag table information should be included ...
function iupbs3(MBAY, S3MNEM)
This function returns a specified value from within Section 3 of a BUFR message.
subroutine dxdump(LUNIT, LDXOT)
This subroutine prints a copy of the DX BUFR table associated with a specified Fortran logical unit...
function ireadsb(LUNIT)
This function calls BUFRLIB subroutine readsb() and passes back its return code as the function value...
subroutine strsuc(STR1, STR2, LENS)
THIS SUBROUTINE REMOVES LEADING AND TRAILING BLANKS FROM A STRING.
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS...
subroutine datelen(LEN)
This subroutine is used to specify the format of Section 1 date-time values that will be output by fu...
subroutine fdebufr(ofile, tbldir, lentd, tblfil, prmstg, basic, forcemt, cfms)
This subroutine reads, decodes, and generates a verbose output listing of the contents of every BUFR ...
subroutine rtrcptb(MBAY, IYR, IMO, IDY, IHR, IMI, IRET)
This subroutine reads the tank receipt time (if one exists) from Section 1 of a BUFR message...
subroutine mtinfo(CMTDIR, LUNMT1, LUNMT2)
This subroutine allows the specification of the directory location and Fortran logical unit numbers t...
subroutine openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
subroutine strnum(STR, NUM)
THIS SUBROUTINE DECODES AN INTEGER FROM A CHARACTER STRING.
This module is used within the debufr utility to share information between subroutine fdebufr() and s...
subroutine upds3(MBAY, LCDS3, CDS3, NDS3)
This subroutine returns the sequence of data descriptors contained within Section 3 of a BUFR message...
INTEGER function isetprm(CPRMNM, IPVAL)
This function sets a specified parameter to a specified value for use in dynamically allocating one o...
subroutine readerme(MESG, LUNIT, SUBSET, JDATE, IRET)
This subroutine is similar to subroutine readmg(), except that it reads a BUFR message from an array ...
function idxmsg(MESG)
THIS FUNCTION DETERMINES WHETHER THE GIVEN BUFR MESSAGE IS A DX DICTIONARY MESSAGE THAT WAS CREATED B...
void crbmg(char *, f77int *, f77int *, f77int *)
This subroutine reads the next BUFR message from the system file that was opened via the most recent ...
subroutine openbt(LUNDX, MTYP)
This subroutine is called as a last resort from within subroutine cktaba(), in the event the latter s...
subroutine ufdump(LUNIT, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
subroutine getcfmng(LUNIT, NEMOI, IVALI, NEMOD, IVALD, CMEANG, LNMNG, IRET)
This subroutine searches for a specified Table B mnemonic and associated value (code figure or bit nu...
function iupbs01(MBAY, S01MNEM)
This function returns a specified value from within Section 0 or Section 1 of a BUFR message...