86 SUBROUTINE fdebufr ( ofile, tbldir, lentd, tblfil, prmstg,
87 + basic, forcemt, cfms )
91 parameter( mxbf = 2500000 )
92 parameter( mxbfd4 = mxbf/4 )
93 parameter( mxds3 = 500 )
94 parameter( mxprms = 20 )
96 character*(*) ofile, tbldir, tblfil, prmstg
100 character*120 cmorgc, cmgses, cmmtyp, cmmsbt, cmmsbti
101 character*20 ptag( mxprms ), pvtag(2), cprmnm
103 character*6 cds3( mxds3 )
104 character*1 basic, forcemt, opened, usemt, cfms,
107 integer ibfmg( mxbfd4 )
109 equivalence( bfmg(1), ibfmg(1) )
116 OPEN ( unit = 51, file = ofile )
122 OPEN ( unit = lunit, file =
'/dev/null' )
130 ctbldir = tbldir(1:lentd)
144 CALL
crbmg( bfmg, mxbf, nbyt, ierr )
146 IF ( ierr .ne. 0 )
THEN
148 IF ( ierr .eq. -1 )
THEN
149 WRITE ( unit = 51, fmt =
'( /, 2A, I7, A, I9, A )')
150 +
'Reached end of BUFR file; it contained a total ',
151 +
'of', nmsg,
' messages and', nsubt,
' subsets'
153 WRITE ( unit = 51, fmt =
'( /, 2A, I4 )' )
154 +
'Error while reading BUFR file; the return code ',
155 +
'from CRBMG = ', ierr
158 IF ( ( basic .eq.
'N' ) .and. ( opened .eq.
'Y' ) )
THEN
159 WRITE (51, fmt =
'( /, A, / )' )
160 +
'Here is the DX table that was generated:'
170 IF ( opened .eq.
'N' )
THEN
174 CALL
isetprm(
'MAXSS', 300000 )
180 IF ( prmstg(1:8) .ne.
'NULLPSTG' )
THEN
181 CALL
parstr( prmstg, ptag, mxprms, nptag,
',',
183 IF ( nptag .gt. 0 )
THEN
185 CALL
parstr( ptag(ii), pvtag, 2, npvtag,
'=',
187 IF ( npvtag .eq. 2 )
THEN
188 CALL
strsuc( pvtag(1), cprmnm, lcprmnm )
189 CALL
strnum( pvtag(2), ipval )
190 IF ( ( lcprmnm .gt. 0 ) .and.
191 + ( ipval .ne. -1 ) )
192 + CALL
isetprm( cprmnm(1:lcprmnm), ipval )
200 IF ( (
idxmsg( ibfmg ) .eq. 1 ) .and.
201 + ( forcemt .eq.
'N' ) )
THEN
207 CALL
openbf( lunit,
'INUL', lunit )
208 ELSE IF ( ( tblfil(1:8) .ne.
'NULLFILE' ) .and.
209 + ( forcemt .eq.
'N' ) )
THEN
214 INQUIRE ( file = tblfil, exist = exists )
215 IF ( .not. exists )
THEN
216 print *,
'ERROR: COULD NOT FIND FILE ', tblfil
219 OPEN ( unit = 91, file = tblfil, iostat = ier )
220 IF ( ier .ne. 0 )
THEN
221 print *,
'ERROR: COULD NOT OPEN FILE ', tblfil
224 CALL
openbf( lunit,
'IN', 91 )
230 CALL
openbf( lunit,
'SEC3', lunit )
235 CALL
mtinfo( tbldir, 90, 91 )
236 IF ( cfms .eq.
'Y' ) CALL
codflg(
'Y' )
239 IF ( basic .eq.
'N' )
THEN
243 CALL
readerme( ibfmg, lunit, cmgtag, imgdt, ierme )
249 IF ( (
idxmsg( ibfmg ) .ne. 1 ) .or.
250 + ( usemt .eq.
'Y' ) )
THEN
254 WRITE ( unit = 51, fmt =
'( /, A, I7 )' )
255 +
'Found BUFR message #', nmsg
259 WRITE ( 51, fmt=
'( /, A, I9 )' )
260 +
' Message length: ',
262 WRITE ( 51, fmt=
'( A, I4 )' )
263 +
' Section 0 length: ',
265 WRITE ( 51, fmt=
'( A, I4 )' )
271 WRITE ( 51, fmt=
'( /, A, I4 )' )
272 +
' Section 1 length: ',
274 WRITE ( 51, fmt=
'( A, I4 )' )
278 iogce =
iupbs01( ibfmg,
'OGCE' )
279 igses =
iupbs01( ibfmg,
'GSES' )
280 IF ( ( basic .eq.
'Y' ) .or.
281 + ( cfms .eq.
'N' ) )
THEN
282 WRITE ( 51, fmt=
'( A, I5 )' )
283 +
' Originating center: ', iogce
284 WRITE ( 51, fmt=
'( A, I4 )' )
285 +
' Originating subcenter: ', igses
287 CALL
getcfmng( lunit,
'ORIGC', iogce,
' ', -1,
288 + cmorgc, lcmorgc, ierorgc )
289 IF ( ierorgc .eq. 0 )
THEN
290 WRITE ( 51, fmt=
'( A, I5, 3A )' )
291 +
' Originating center: ', iogce,
292 +
' (= ', cmorgc(1:lcmorgc),
')'
294 WRITE ( 51, fmt=
'( A, I5 )' )
295 +
' Originating center: ', iogce
297 CALL
getcfmng( lunit,
'GSES', igses,
299 + cmgses, lcmgses, iergses )
300 IF ( iergses .eq. 0 )
THEN
301 WRITE ( 51, fmt=
'( A, I4, 3A )' )
302 +
' Originating subcenter: ', igses,
303 +
' (= ', cmgses(1:lcmgses),
')'
305 WRITE ( 51, fmt=
'( A, I4 )' )
306 +
' Originating subcenter: ', igses
310 WRITE ( 51, fmt=
'( A, I4 )' )
311 +
' Update sequence numbr: ',
314 IF (
iupbs01( ibfmg,
'ISC2' ) .eq. 1 )
THEN
315 WRITE ( 51, fmt =
'( A )')
316 +
' Section 2 present?: Yes'
318 WRITE ( 51, fmt =
'( A )')
319 +
' Section 2 present?: No'
322 mtyp =
iupbs01( ibfmg,
'MTYP' )
323 msbt =
iupbs01( ibfmg,
'MSBT' )
324 msbti =
iupbs01( ibfmg,
'MSBTI' )
325 IF ( ( basic .eq.
'Y' ) .or.
326 + ( cfms .eq.
'N' ) )
THEN
327 WRITE ( 51, fmt=
'( A, I4 )' )
328 +
' Data category: ', mtyp
329 WRITE ( 51, fmt=
'( A, I4 )' )
330 +
' Local subcategory: ', msbt
331 WRITE ( 51, fmt=
'( A, I4 )' )
332 +
' Internatl subcategory: ', msbti
334 CALL
getcfmng( lunit,
'TABLAT', mtyp,
' ', -1,
335 + cmmtyp, lcmmtyp, iermtyp )
336 IF ( iermtyp .eq. 0 )
THEN
337 WRITE ( 51, fmt=
'( A, I4, 3A )' )
338 +
' Data category: ', mtyp,
339 +
' (= ', cmmtyp(1:lcmmtyp),
')'
341 WRITE ( 51, fmt=
'( A, I4 )' )
342 +
' Data category: ', mtyp
344 CALL
getcfmng( lunit,
'TABLASL', msbt,
346 + cmmsbt, lcmmsbt, iermsbt )
347 IF ( ( iermsbt .eq. 0 ) .and.
348 + ( iogce .eq. 7 ) )
THEN
349 WRITE ( 51, fmt=
'( A, I4, 3A )' )
350 +
' Local subcategory: ', msbt,
351 +
' (= ', cmmsbt(1:lcmmsbt),
')'
353 WRITE ( 51, fmt=
'( A, I4 )' )
354 +
' Local subcategory: ', msbt
356 CALL
getcfmng( lunit,
'TABLASS', msbti,
358 + cmmsbti, lcmmsbti, iermsbti )
359 IF ( iermsbti .eq. 0 )
THEN
360 WRITE ( 51, fmt=
'( A, I4, 3A )' )
361 +
' Internatl subcategory: ', msbti,
362 +
' (= ', cmmsbti(1:lcmmsbti),
')'
364 WRITE ( 51, fmt=
'( A, I4 )' )
365 +
' Internatl subcategory: ', msbti
369 WRITE ( 51, fmt=
'( A, I4 )' )
370 +
' Master table version: ',
372 WRITE ( 51, fmt=
'( A, I4 )' )
373 +
' Local table version: ',
375 WRITE ( 51, fmt=
'( A, I4 )' )
378 WRITE ( 51, fmt=
'( A, I4 )' )
381 WRITE ( 51, fmt=
'( A, I4 )' )
384 WRITE ( 51, fmt=
'( A, I4 )' )
387 WRITE ( 51, fmt=
'( A, I4 )' )
390 WRITE ( 51, fmt=
'( A, I4 )' )
393 IF ( ( iogce .eq. 7 ) .and. ( igses .eq. 3 ) )
THEN
394 CALL
rtrcptb( ibfmg, iryr, irmo, irdy, irhr,
396 IF ( irtret .eq. 0 )
THEN
397 WRITE ( 51, fmt=
'( A, I4 )' )
398 +
' NCEP tank rcpt year: ', iryr
399 WRITE ( 51, fmt=
'( A, I4 )' )
400 +
' NCEP tank rcpt month: ', irmo
401 WRITE ( 51, fmt=
'( A, I4 )' )
402 +
' NCEP tank rcpt day: ', irdy
403 WRITE ( 51, fmt=
'( A, I4 )' )
404 +
' NCEP tank rcpt hour: ', irhr
405 WRITE ( 51, fmt=
'( A, I4 )' )
406 +
' NCEP tank rcpt minute: ', irmi
412 nsub =
iupbs3( ibfmg,
'NSUB' )
413 WRITE ( 51, fmt=
'( /, A, I4 )' )
414 +
' Number of data subsets: ', nsub
417 IF (
iupbs3( ibfmg,
'IOBS' ) .eq. 1 )
THEN
418 WRITE ( 51, fmt =
'( A )')
419 +
' Data are observed?: Yes'
421 WRITE ( 51, fmt =
'( A )')
422 +
' Data are observed?: No'
425 IF (
iupbs3( ibfmg,
'ICMP' ) .eq. 1 )
THEN
426 WRITE ( 51, fmt =
'( A )')
427 +
' Data are compressed?: Yes'
429 WRITE ( 51, fmt =
'( A )')
430 +
' Data are compressed?: No'
433 CALL
upds3( ibfmg, mxds3, cds3, nds3 )
434 WRITE ( 51, fmt=
'( A, I5 )' )
435 +
' Number of descriptors: ', nds3
437 WRITE ( 51, fmt =
'( 5X, I4, A, A6)' )
438 + jj,
": ", cds3( jj )
441 IF ( ( basic .eq.
'N' ) .and.
442 + ( ierme .ge. 0 ) )
THEN
447 + fmt =
'( /, A, I7, 3A, I10, A, I6, A )' )
448 +
'BUFR message #', nmsg,
' of type ', cmgtag,
449 +
' and date ', imgdt,
' contains ', nsub,
451 DO WHILE (
ireadsb( lunit ) .eq. 0 )
456 WRITE ( unit = 51, fmt =
'( /, A, I7 )' )
457 +
'End of BUFR message #', nmsg
458 WRITE ( unit = 51, fmt =
'( /, 120("-"))' )
491 character*240 bftabfil
498 WRITE ( bftab,
'("bufrtab.",i3.3)' ) mtyp
499 bftabfil = ctbldir(1:ltbd) //
'/' // bftab
501 INQUIRE ( file = bftabfil, exist = exists )
505 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 character 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 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...
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 a given BUFR message contains DX BUFR tables information that was ge...
subroutine openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
void crbmg(char *, f77int *, f77int *, f77int *)
This subroutine reads the next BUFR message from the system file that was opened via the most recent ...
INTEGER function isetprm(CPRMNM, IPVAL)
This function sets a specified parameter to a specified value for use in dynamically allocating one o...
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...