78 CHARACTER*20 lchr,pmiss
80 CHARACTER*10 nemo,nemo2,tagrfe
86 CHARACTER*1 cdmf,tab,you
87 equivalence(rval,cval)
89 LOGICAL track,found,rdrv
100 CHARACTER*10 seqnam(mxseq)
101 INTEGER lsqnam(mxseq)
104 CHARACTER*10 lsnemo(mxls)
107 DATA pmiss /
' MISSING'/
115 lcfmeang = len(cfmeang)
126 CALL
status(lunit,lun,il,im)
130 IF(inode(lun).NE.inv(1,lun)) goto 903
132 WRITE(luout,fmt=
'(/,2A,/)')
'MESSAGE TYPE ',tag(inode(lun))
141 IF(cdmf.EQ.
'Y' .AND. nsub(lun).EQ.1) itmp =
ireadmt(lun)
144 IF(luprt.EQ.0 .AND. mod(nv,20).EQ.0)
THEN
149 print*,
'(<enter> for MORE, q <enter> to QUIT)'
159 print*,
'==> You have chosen to stop the dumping of this subset'
170 IF(ityp.GE.1.AND.ityp.LE.3)
THEN
171 CALL
nemtab(lun,nemo,idn,tab,n)
172 numb = tabb(n,lun)(1:6)
173 desc = tabb(n,lun)(16:70)
174 unit = tabb(n,lun)(71:94)
178 IF((ityp.EQ.0).OR.(ityp.EQ.1))
THEN
182 IF((type.EQ.
'REP').OR.(type.EQ.
'DRP').OR.
183 . (type.EQ.
'DRB').OR.(type.EQ.
'DRS'))
THEN
188 IF(nseq.GT.mxseq) goto 904
189 IF(type.EQ.
'REP')
THEN
190 numrep(nseq) = irf(node)
192 numrep(nseq) = nint(rval)
194 CALL
strsuc(nemo,nemo2,lnm2)
195 fmt =
'(11X,A,I6,1X,A)'
196 WRITE(luout,fmt) nemo2(1:lnm2), numrep(nseq),
'REPLICATIONS'
200 IF(numrep(nseq).GT.1)
THEN
213 ELSEIF( ((type.EQ.
'SEQ').OR.(type.EQ.
'RPC').OR.(type.EQ.
'RPS'))
214 . .AND. (nseq.GT.0) )
THEN
220 CALL
strsuc(nemo,nemo2,lnm2)
221 DO WHILE ((ii.GE.1).AND.(.NOT.track))
222 IF(nemo2(1:lnm2).EQ.seqnam(ii)(2:lsqnam(ii)-1))
THEN
227 fmt =
'(4X,A,2X,A,2X,A,I6,2X,A)'
228 WRITE(luout,fmt)
'++++++', nemo2(1:lnm2),
229 .
'REPLICATION #', idxrep(ii),
'++++++'
230 IF(idxrep(ii).LT.numrep(ii))
THEN
234 idxrep(ii) = idxrep(ii)+1
247 ELSEIF(ityp.EQ.2)
THEN
256 DO WHILE ((jj.LE.nnrv).AND.(.NOT.rdrv))
257 IF (node.EQ.inodnrv(jj))
THEN
259 desc =
'New reference value for ' // nemo
269 nrfe = nrfelm(nv,lun)
271 tagrfe = tag(inv(nrfe,lun))
273 DO WHILE((jj.GE.1).AND.(desc(jj:jj).EQ.
' '))
276 IF(jj.LE.33) desc(jj+1:jj+15) =
' for ' // tagrfe
281 IF(
ibfms(rval).NE.0)
THEN
285 fmt =
'(A6,2X,A10,2X,A20,2X,A24,6X,A48)'
286 WRITE(luout,fmt) numb,nemo,pmiss,unit,desc
288 fmt =
'(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)'
293 WRITE(fmt(19:20),
'(I2)') max(1,isc(node))
294 IF(unit(1:4).EQ.
'FLAG')
THEN
299 CALL
upftbv(lunit,nemo,rval,mxfv,ifv,nifv)
305 WRITE(fmtf,
'(A2,I1,A4)')
'(I', isz,
',A1)'
306 IF((ipt+isz).LE.24)
THEN
307 WRITE(unit(ipt:ipt+isz),fmtf) ifv(ii),
','
310 unit(12:23) =
'MANY BITS ON'
314 unit(ipt-1:ipt-1) =
')'
318 WRITE(luout,fmt) numb,nemo,rval,unit,desc
320 IF( (unit(1:4).EQ.
'FLAG' .OR. unit(1:4).EQ.
'CODE') .AND.
321 . (cdmf.EQ.
'Y') )
THEN
326 IF(unit(1:4).EQ.
'CODE')
THEN
328 ifv(nifv) = nint(rval)
333 CALL
srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
334 . cfmeang,lcfmeang,lcfmg,iersf)
336 WRITE(luout,fmt) ifv(ii),
' = ',cfmeang(1:lcfmg)
337 ELSEIF(iersf.LT.0)
THEN
338 WRITE(luout,fmt) ifv(ii),
' = ',
339 .
'***THIS IS AN ILLEGAL/UNDEFINED VALUE***'
350 DO WHILE((jj.LT.iersf).AND.(ierft.LT.0))
352 CALL
numtbd(lun,icfdp(jj),nemod,tab,ierbd)
353 IF((ierbd.GT.0).AND.(tab.EQ.
'B'))
THEN
354 CALL
fstag(lun,nemod,-1,nv,nout,ierft)
358 ifvd = nint(val(nout,lun))
359 IF(jj.GT.1) icfdp(1) = icfdp(jj)
360 CALL
srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
361 . cfmeang,lcfmeang,lcfmg,iersf)
363 WRITE(luout,fmt) ifv(ii),
' = ',
371 ELSEIF(ityp.EQ.3)
THEN
377 IF(
ibfms(rval).NE.0)
THEN
379 ELSE IF(nchr.LE.8)
THEN
388 DO WHILE((ii.LE.nls).AND.(.NOT.found))
389 IF(nemo.EQ.lsnemo(ii))
THEN
398 IF(nls.GT.mxls) goto 905
403 CALL
strsuc(nemo,nemo3,lnm3)
404 lsct(ii) = lsct(ii) + 1
405 WRITE(fmtf,
'(A,I1,A)')
'(2A,I',
isize(lsct(ii)),
')'
406 WRITE(nemo3,fmtf) nemo(1:lnm3),
'#', lsct(ii)
409 CALL
readlc(lunit,lchr2,nemo3)
410 IF (
icbfms(lchr2,nchr).NE.0)
THEN
417 IF ( nchr.LE.20 .OR. lchr.EQ.pmiss )
THEN
419 fmt =
'(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)'
420 WRITE(luout,fmt) numb,nemo,lchr,nchr,unit,desc
422 fmt =
'(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)'
423 WRITE(luout,fmt) numb,nemo,lchr2(1:nchr),nchr,unit,desc
430 3
FORMAT(/
' >>> END OF SUBSET <<< '/)
436 900 CALL
bort(
'BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT '//
437 .
'MUST BE OPEN FOR INPUT')
438 901 CALL
bort(
'BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR '//
439 .
'OUTPUT, IT MUST BE OPEN FOR INPUT')
440 902 CALL
bort(
'BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT '//
441 .
'BUFR FILE, NONE ARE')
442 903 CALL
bort(
'BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '//
443 .
'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
444 .
'INTERNAL SUBSET ARRAY')
445 904 CALL
bort(
'BUFRLIB: UFDUMP - MXSEQ OVERFLOW')
446 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 ...
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 character 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 a descriptor within Table B and Table D of the internal DX BUFR tables...
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...
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 returns information about a descriptor from the internal DX BUFR tables, based on the mnemonic associated with that descriptor.
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...
INTEGER function ireadmt(LUN)
This function checks the most recent BUFR message that was read via a call to one of the message-read...
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.