86 CHARACTER*20 lchr,pmiss
88 CHARACTER*10 nemo,nemo2,tagrfe
94 CHARACTER*1 cdmf,tab,you
95 equivalence(rval,cval)
97 LOGICAL track,found,rdrv
100 INTEGER icfdp(mxcfdp)
106 INTEGER idxrep(mxseq)
107 INTEGER numrep(mxseq)
108 CHARACTER*10 seqnam(mxseq)
109 INTEGER lsqnam(mxseq)
112 CHARACTER*10 lsnemo(mxls)
115 DATA pmiss /
' MISSING'/
123 lcfmeang = len(cfmeang)
134 CALL
status(lunit,lun,il,im)
138 IF(inode(lun).NE.inv(1,lun)) goto 903
140 WRITE(luout,fmt=
'(/,2A,/)')
'MESSAGE TYPE ',tag(inode(lun))
149 IF(cdmf.EQ.
'Y' .AND. nsub(lun).EQ.1) itmp =
ireadmt(lun)
152 IF(luprt.EQ.0 .AND. mod(nv,20).EQ.0)
THEN
157 print*,
'(<enter> for MORE, q <enter> to QUIT)'
167 print*,
'==> You have chosen to stop the dumping of this subset'
178 IF(ityp.GE.1.AND.ityp.LE.3)
THEN
179 CALL
nemtab(lun,nemo,idn,tab,n)
180 numb = tabb(n,lun)(1:6)
181 desc = tabb(n,lun)(16:70)
182 unit = tabb(n,lun)(71:94)
186 IF((ityp.EQ.0).OR.(ityp.EQ.1))
THEN
190 IF((type.EQ.
'REP').OR.(type.EQ.
'DRP').OR.
191 . (type.EQ.
'DRB').OR.(type.EQ.
'DRS'))
THEN
196 IF(nseq.GT.mxseq) goto 904
197 IF(type.EQ.
'REP')
THEN
198 numrep(nseq) = irf(node)
200 numrep(nseq) = nint(rval)
202 CALL
strsuc(nemo,nemo2,lnm2)
203 fmt =
'(11X,A,I6,1X,A)'
204 WRITE(luout,fmt) nemo2(1:lnm2), numrep(nseq),
'REPLICATIONS'
208 IF(numrep(nseq).GT.1)
THEN
221 ELSEIF( ((type.EQ.
'SEQ').OR.(type.EQ.
'RPC').OR.(type.EQ.
'RPS'))
222 . .AND. (nseq.GT.0) )
THEN
228 CALL
strsuc(nemo,nemo2,lnm2)
229 DO WHILE ((ii.GE.1).AND.(.NOT.track))
230 IF(nemo2(1:lnm2).EQ.seqnam(ii)(2:lsqnam(ii)-1))
THEN
235 fmt =
'(4X,A,2X,A,2X,A,I6,2X,A)'
236 WRITE(luout,fmt)
'++++++', nemo2(1:lnm2),
237 .
'REPLICATION #', idxrep(ii),
'++++++'
238 IF(idxrep(ii).LT.numrep(ii))
THEN
242 idxrep(ii) = idxrep(ii)+1
255 ELSEIF(ityp.EQ.2)
THEN
264 DO WHILE ((jj.LE.nnrv).AND.(.NOT.rdrv))
265 IF (node.EQ.inodnrv(jj))
THEN
267 desc =
'New reference value for ' // nemo
277 nrfe = nrfelm(nv,lun)
279 tagrfe = tag(inv(nrfe,lun))
281 DO WHILE((jj.GE.1).AND.(desc(jj:jj).EQ.
' '))
284 IF(jj.LE.33) desc(jj+1:jj+15) =
' for ' // tagrfe
289 IF(
ibfms(rval).NE.0)
THEN
293 fmt =
'(A6,2X,A10,2X,A20,2X,A24,6X,A48)'
294 WRITE(luout,fmt) numb,nemo,pmiss,unit,desc
296 fmt =
'(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)'
301 WRITE(fmt(19:20),
'(I2)') max(1,isc(node))
302 IF(unit(1:4).EQ.
'FLAG')
THEN
307 CALL
upftbv(lunit,nemo,rval,mxfv,ifv,nifv)
313 WRITE(fmtf,
'(A2,I1,A4)')
'(I', isz,
',A1)'
314 IF((ipt+isz).LE.24)
THEN
315 WRITE(unit(ipt:ipt+isz),fmtf) ifv(ii),
','
318 unit(12:23) =
'MANY BITS ON'
322 unit(ipt-1:ipt-1) =
')'
326 WRITE(luout,fmt) numb,nemo,rval,unit,desc
328 IF( (unit(1:4).EQ.
'FLAG' .OR. unit(1:4).EQ.
'CODE') .AND.
329 . (cdmf.EQ.
'Y') )
THEN
334 IF(unit(1:4).EQ.
'CODE')
THEN
336 ifv(nifv) = nint(rval)
341 CALL
srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
342 . cfmeang,lcfmeang,lcfmg,iersf)
344 WRITE(luout,fmt) ifv(ii),
' = ',cfmeang(1:lcfmg)
345 ELSEIF(iersf.LT.0)
THEN
346 WRITE(luout,fmt) ifv(ii),
' = ',
347 .
'***THIS IS AN ILLEGAL/UNDEFINED VALUE***'
358 DO WHILE((jj.LT.iersf).AND.(ierft.LT.0))
360 CALL
numtbd(lun,icfdp(jj),nemod,tab,ierbd)
361 IF((ierbd.GT.0).AND.(tab.EQ.
'B'))
THEN
362 CALL
fstag(lun,nemod,-1,nv,nout,ierft)
366 ifvd = nint(val(nout,lun))
367 IF(jj.GT.1) icfdp(1) = icfdp(jj)
368 CALL
srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
369 . cfmeang,lcfmeang,lcfmg,iersf)
371 WRITE(luout,fmt) ifv(ii),
' = ',
379 ELSEIF(ityp.EQ.3)
THEN
385 IF(
ibfms(rval).NE.0)
THEN
387 ELSE IF(nchr.LE.8)
THEN
396 DO WHILE((ii.LE.nls).AND.(.NOT.found))
397 IF(nemo.EQ.lsnemo(ii))
THEN
406 IF(nls.GT.mxls) goto 905
411 CALL
strsuc(nemo,nemo3,lnm3)
412 lsct(ii) = lsct(ii) + 1
413 WRITE(fmtf,
'(A,I1,A)')
'(2A,I',
isize(lsct(ii)),
')'
414 WRITE(nemo3,fmtf) nemo(1:lnm3),
'#', lsct(ii)
417 CALL
readlc(lunit,lchr2,nemo3)
418 IF (
icbfms(lchr2,nchr).NE.0)
THEN
425 IF ( nchr.LE.20 .OR. lchr.EQ.pmiss )
THEN
427 fmt =
'(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)'
428 WRITE(luout,fmt) numb,nemo,lchr,nchr,unit,desc
430 fmt =
'(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)'
431 WRITE(luout,fmt) numb,nemo,lchr2(1:nchr),nchr,unit,desc
438 3
FORMAT(/
' >>> END OF SUBSET <<< '/)
444 900 CALL
bort(
'BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT '//
445 .
'MUST BE OPEN FOR INPUT')
446 901 CALL
bort(
'BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR '//
447 .
'OUTPUT, IT MUST BE OPEN FOR INPUT')
448 902 CALL
bort(
'BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT '//
449 .
'BUFR FILE, NONE ARE')
450 903 CALL
bort(
'BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '//
451 .
'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
452 .
'INTERNAL SUBSET ARRAY')
453 904 CALL
bort(
'BUFRLIB: UFDUMP - MXSEQ OVERFLOW')
454 905 CALL
bort(
'BUFRLIB: UFDUMP - MXLS OVERFLOW')
INTEGER function icbfms(STR, LSTR)
This function provides a handy way to check whether a character string returned from a previous call ...
function rjust(STR)
THIS FUNCTION RIGHT JUSTIFIES A CHARACTER STRING.
This module contains array and variable declarations for use with any 2-03-YYY (change reference valu...
subroutine strsuc(STR1, STR2, LENS)
THIS SUBROUTINE REMOVES LEADING AND TRAILING BLANKS FROM A STRING.
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
INTEGER function ibfms(R8VAL)
This function provides a handy way to check whether a real*8 data value returned from a previous call...
subroutine numtbd(LUN, IDN, NEMO, TAB, IRET)
THIS SUBROUTINE SEARCHES FOR AN INTEGER IDN, CONTAINING THE BIT-WISE REPRESENTATION OF A DESCRIPTOR (...
This module contains array and variable declarations used to store the internal jump/link table...
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
subroutine upftbv(LUNIT, NEMO, VAL, MXIB, IBIT, NIB)
Given a Table B mnemonic with flag table units and a corresponding numerical data value...
INTEGER function ireadmt(LUN)
THIS FUNCTION CHECKS THE MOST RECENT BUFR MESSAGE THAT WAS READ AS INPUT VIA SUBROUTINE READMG...
subroutine ufdump(LUNIT, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
subroutine nemtab(LUN, NEMO, IDN, TAB, IRET)
THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTI...
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
INTEGER function isize(NUM)
THIS FUNCTION COMPUTES AND RETURNS THE NUMBER OF CHARACTERS NEEDED TO ENCODE THE INPUT INTEGER NUM AS...
void srchtbf(f77int *, f77int *, f77int *, f77int *, f77int *, char *, f77int *, f77int *, f77int *)
This subroutine searches for a specified FXY number and associated value (code figure or bit number) ...
subroutine fstag(LUN, UTAG, NUTAG, NIN, NOUT, IRET)
THIS SUBROUTINE FINDS THE (NUTAG)th OCCURRENCE OF MNEMONIC UTAG WITHIN THE CURRENT OVERALL SUBSET DEF...
subroutine readlc(LUNIT, CHR, STR)
This subroutine reads a long character string (greater than 8 bytes) from a data subset.