NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
ufdump.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Print the contents of a data subset.
3 
4 C> This subroutine prints a verbose listing of the contents of a data
5 C> subset, including all data values and replicated sequences, as well
6 C> as the meanings of data values which are code or flag table entries.
7 C>
8 C> <p>This subroutine is similar to subroutine ufbdmp(), but it prints
9 C> different characteristics of each data subset, and in a slightly
10 C> different format. However, both subroutines can be useful for
11 C> different diagnostic purposes, and both can also be run
12 C> interactively to scroll through the contents of a data subset.
13 C>
14 C> @authors J. Woollen
15 C> @authors J. Ator
16 C> @date 2002-05-14
17 C>
18 C> @param[in] LUNIT - integer: Fortran logical unit number for
19 C> BUFR file
20 C> @param[in] LUPRT - integer: Fortran logical unit number for
21 C> print output
22 C> - 0 = Run interactively, printing to
23 C> standard output
24 C>
25 C> <p>Logical unit LUNIT should have already been opened for
26 C> input operations via a previous call to subroutine openbf(), and a
27 C> BUFR data subset should have already been read into internal arrays
28 C> via a previous call to one of the
29 C> [subset-reading subroutines](@ref hierarchy).
30 C>
31 C> <p>Except when LUPRT = 0, logical unit LUPRT must already be
32 C> associated with a filename on the local system, typically via a
33 C> Fortran "OPEN" statement. When LUPRT = 0, the subroutine will run
34 C> interactively and print to standard output, scrolling 20 lines at
35 C> a time and prompting each time whether to quit and return to the
36 C> application program (by typing 'q' then '<Enter>') or continue
37 C> scrolling (by typing anything else).
38 C>
39 C> @remarks
40 C> - In order for the meanings of code and flag table values to be
41 C> included in the output, a previous call to subroutine codflg()
42 C> must have been made with argument CF = 'Y'. Otherwise, only the
43 C> code and flag table values themselves will be printed.
44 C>
45 C> <b>Program history log:</b>
46 C> - 2002-05-14 J. Woollen -- Original author
47 C> - 2003-11-04 J. Woollen -- Modified to handle print of character
48 C> values greater than 8 bytes
49 C> - 2003-11-04 S. Bender -- Added remarks and routine interdependencies
50 C> - 2003-11-04 D. Keyser -- Increased MAXJL from 15000 to 16000;
51 C> unified/portable for WRF; added history
52 C> documentation; outputs more complete
53 C> diagnostic info when routine terminates
54 C> abnormally, unusual things happen or for
55 C> informational purposes
56 C> - 2004-08-18 J. Ator -- Added fuzziness test and threshold for
57 C> missing value; added interactive and
58 C> scrolling capability similar to ufbdmp()
59 C> - 2006-04-14 J. Ator -- Add call to upftbv() for flag tables to get
60 C> actual bits that were set to generate value
61 C> - 2007-01-19 J. Ator -- Use function ibfms()
62 C> - 2009-03-23 J. Ator -- Add level markers to output for sequences
63 C> where the replication count is > 1; output
64 C> all occurrences of long character strings
65 C> - 2012-02-24 J. Ator -- Fix missing check for long character strings
66 C> - 2012-03-02 J. Ator -- Label redefined reference values
67 C> - 2014-12-10 J. Ator -- Use modules instead of COMMON blocks
68 C> - 2015-09-24 J. Woollen -- Print level identifiers for event stacks
69 C> - 2020-08-18 J. Ator -- Improve logic for sequence tracking
70 C>
71  SUBROUTINE ufdump(LUNIT,LUPRT)
72 
73  USE moda_usrint
74  USE moda_msgcwd
75  USE moda_tababd
76  USE moda_tables
77  USE moda_nrv203
78 
79  COMMON /tablef/ cdmf
80 
81  CHARACTER*120 cfmeang
82  CHARACTER*80 fmt
83  CHARACTER*64 desc
84  CHARACTER*24 unit
85  CHARACTER*120 lchr2
86  CHARACTER*20 lchr,pmiss
87  CHARACTER*15 nemo3
88  CHARACTER*10 nemo,nemo2,tagrfe
89  CHARACTER*8 nemod
90  CHARACTER*6 numb
91  CHARACTER*7 fmtf
92  CHARACTER*8 cval
93  CHARACTER*3 type
94  CHARACTER*1 cdmf,tab,you
95  equivalence(rval,cval)
96  REAL*8 rval
97  LOGICAL track,found,rdrv
98 
99  parameter(mxcfdp=5)
100  INTEGER icfdp(mxcfdp)
101 
102  parameter(mxfv=31)
103  integer ifv(mxfv)
104 
105  parameter(mxseq=10)
106  INTEGER idxrep(mxseq)
107  INTEGER numrep(mxseq)
108  CHARACTER*10 seqnam(mxseq)
109  INTEGER lsqnam(mxseq)
110 
111  parameter(mxls=10)
112  CHARACTER*10 lsnemo(mxls)
113  INTEGER lsct(mxls)
114 
115  DATA pmiss /' MISSING'/
116  DATA you /'Y'/
117 
118 C----------------------------------------------------------------------
119 C----------------------------------------------------------------------
120 
121  nseq = 0
122  nls = 0
123  lcfmeang = len(cfmeang)
124 
125  IF(luprt.EQ.0) THEN
126  luout = 6
127  ELSE
128  luout = luprt
129  ENDIF
130 
131 C CHECK THE FILE STATUS AND I-NODE
132 C --------------------------------
133 
134  CALL status(lunit,lun,il,im)
135  IF(il.EQ.0) goto 900
136  IF(il.GT.0) goto 901
137  IF(im.EQ.0) goto 902
138  IF(inode(lun).NE.inv(1,lun)) goto 903
139 
140  WRITE(luout,fmt='(/,2A,/)') 'MESSAGE TYPE ',tag(inode(lun))
141 
142 C DUMP THE CONTENTS OF MODULE USRINT FOR UNIT LUNIT
143 C -------------------------------------------------
144 
145 C If code/flag table details are being printed, and if this is the
146 C first subset of a new message, then make sure the appropriate
147 C master tables have been read in to memory for this message.
148 
149  IF(cdmf.EQ.'Y' .AND. nsub(lun).EQ.1) itmp = ireadmt(lun)
150 
151  DO nv=1,nval(lun)
152  IF(luprt.EQ.0 .AND. mod(nv,20).EQ.0) THEN
153 
154 C When LUPRT=0, the output will be scrolled, 20 elements at a time
155 C ----------------------------------------------------------------
156 
157  print*,'(<enter> for MORE, q <enter> to QUIT)'
158  READ(5,'(A1)') you
159 
160 C If the terminal enters "q" followed by "<enter>" after the prompt
161 C "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
162 C subroutine will return to the calling program
163 C -------------------------------------------------------------------
164 
165  IF(you.EQ.'q') THEN
166  print*
167  print*,'==> You have chosen to stop the dumping of this subset'
168  print*
169  goto 100
170  ENDIF
171  ENDIF
172 
173  node = inv(nv,lun)
174  nemo = tag(node)
175  ityp = itp(node)
176  TYPE = typ (node)
177 
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)
183  rval = val(nv,lun)
184  ENDIF
185 
186  IF((ityp.EQ.0).OR.(ityp.EQ.1)) THEN
187 
188 C Sequence descriptor or delayed descriptor replication factor
189 
190  IF((type.EQ.'REP').OR.(type.EQ.'DRP').OR.
191  . (type.EQ.'DRB').OR.(type.EQ.'DRS')) THEN
192 
193 C Print the number of replications
194 
195  nseq = nseq+1
196  IF(nseq.GT.mxseq) goto 904
197  IF(type.EQ.'REP') THEN
198  numrep(nseq) = irf(node)
199  ELSE
200  numrep(nseq) = nint(rval)
201  ENDIF
202  CALL strsuc(nemo,nemo2,lnm2)
203  fmt = '(11X,A,I6,1X,A)'
204  WRITE(luout,fmt) nemo2(1:lnm2), numrep(nseq), 'REPLICATIONS'
205 
206 C How many times is this sequence replicated?
207 
208  IF(numrep(nseq).GT.1) THEN
209 
210 C Track the sequence
211 
212  seqnam(nseq) = nemo2
213  lsqnam(nseq) = lnm2
214  idxrep(nseq) = 1
215  ELSE
216 
217 C Don't bother
218 
219  nseq = nseq-1
220  ENDIF
221  ELSEIF( ((type.EQ.'SEQ').OR.(type.EQ.'RPC').OR.(type.EQ.'RPS'))
222  . .AND. (nseq.GT.0) ) THEN
223 
224 C Is this one of the sequences being tracked?
225 
226  ii = nseq
227  track = .false.
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
231  track = .true.
232 
233 C Mark this level in the output
234 
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
239 
240 C There are more levels to come
241 
242  idxrep(ii) = idxrep(ii)+1
243  ELSE
244 
245 C This was the last level for this sequence, so stop
246 C tracking it
247 
248  nseq = nseq-1
249  ENDIF
250  ELSE
251  ii = ii-1
252  ENDIF
253  ENDDO
254  ENDIF
255  ELSEIF(ityp.EQ.2) THEN
256 
257 C Other numeric value
258 
259 C First check if this node contains a redefined reference
260 C value. If so, modify the DESC field to label it as such.
261 
262  jj = 1
263  rdrv = .false.
264  DO WHILE ((jj.LE.nnrv).AND.(.NOT.rdrv))
265  IF (node.EQ.inodnrv(jj)) THEN
266  rdrv = .true.
267  desc = 'New reference value for ' // nemo
268  unit = ' '
269  ELSE
270  jj = jj + 1
271  ENDIF
272  ENDDO
273 
274 C Check if this element refers to another element via a bitmap.
275 C If so, modify the DESC field to identify the referred element.
276 
277  nrfe = nrfelm(nv,lun)
278  IF(nrfe.GT.0) THEN
279  tagrfe = tag(inv(nrfe,lun))
280  jj = 48
281  DO WHILE((jj.GE.1).AND.(desc(jj:jj).EQ.' '))
282  jj = jj - 1
283  ENDDO
284  IF(jj.LE.33) desc(jj+1:jj+15) = ' for ' // tagrfe
285  ENDIF
286 
287 C Now print the value
288 
289  IF(ibfms(rval).NE.0) THEN
290 
291 C The value is "missing".
292 
293  fmt = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)'
294  WRITE(luout,fmt) numb,nemo,pmiss,unit,desc
295  ELSE
296  fmt = '(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)'
297 
298 C Based upon the corresponding scale factor, select an
299 C appropriate format for the printing of this value.
300 
301  WRITE(fmt(19:20),'(I2)') max(1,isc(node))
302  IF(unit(1:4).EQ.'FLAG') THEN
303 
304 C Print a listing of the bits corresponding to
305 C this value.
306 
307  CALL upftbv(lunit,nemo,rval,mxfv,ifv,nifv)
308  IF(nifv.GT.0) THEN
309  unit(11:11) = '('
310  ipt = 12
311  DO ii=1,nifv
312  isz = isize(ifv(ii))
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), ','
316  ipt = ipt + isz + 1
317  ELSE
318  unit(12:23) = 'MANY BITS ON'
319  ipt = 25
320  ENDIF
321  ENDDO
322  unit(ipt-1:ipt-1) = ')'
323  ENDIF
324  ENDIF
325 
326  WRITE(luout,fmt) numb,nemo,rval,unit,desc
327 
328  IF( (unit(1:4).EQ.'FLAG' .OR. unit(1:4).EQ.'CODE') .AND.
329  . (cdmf.EQ.'Y') ) THEN
330 
331 C Print the meanings of the code and flag values.
332 
333  fmt = '(31X,I8,A,A)'
334  IF(unit(1:4).EQ.'CODE') THEN
335  nifv = 1
336  ifv(nifv) = nint(rval)
337  ENDIF
338  DO ii=1,nifv
339  icfdp(1) = (-1)
340  ifvd = (-1)
341  CALL srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
342  . cfmeang,lcfmeang,lcfmg,iersf)
343  IF(iersf.EQ.0) THEN
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***'
348  ELSE
349 
350 C The meaning of this value is dependent on the
351 C value of another mnemonic in the report. Look for
352 C that other mnemonic within the report and then use
353 C it and its associated value to retrieve and print
354 C the proper meaning from the code/flag tables.
355 
356  ierft = (-1)
357  jj = 0
358  DO WHILE((jj.LT.iersf).AND.(ierft.LT.0))
359  jj = jj + 1
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)
363  ENDIF
364  ENDDO
365  IF(ierft.EQ.0) THEN
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)
370  IF(iersf.EQ.0) THEN
371  WRITE(luout,fmt) ifv(ii),' = ',
372  . cfmeang(1:lcfmg)
373  ENDIF
374  ENDIF
375  ENDIF
376  ENDDO
377  ENDIF
378  ENDIF
379  ELSEIF(ityp.EQ.3) THEN
380 
381 C Character (CCITT IA5) value
382 
383  nchr = ibt(node)/8
384 
385  IF(ibfms(rval).NE.0) THEN
386  lchr = pmiss
387  ELSE IF(nchr.LE.8) THEN
388  lchr = cval
389  ELSE
390 
391 C Track the number of occurrences of this long character string, so
392 C that we can properly output each one.
393 
394  ii = 1
395  found = .false.
396  DO WHILE((ii.LE.nls).AND.(.NOT.found))
397  IF(nemo.EQ.lsnemo(ii)) THEN
398  found = .true.
399  ELSE
400  ii = ii + 1
401  ENDIF
402  ENDDO
403 
404  IF(.NOT.found) THEN
405  nls = nls+1
406  IF(nls.GT.mxls) goto 905
407  lsnemo(nls) = nemo
408  lsct(nls) = 1
409  nemo3 = nemo
410  ELSE
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)
415  ENDIF
416 
417  CALL readlc(lunit,lchr2,nemo3)
418  IF (icbfms(lchr2,nchr).NE.0) THEN
419  lchr = pmiss
420  ELSE
421  lchr = lchr2(1:20)
422  ENDIF
423  ENDIF
424 
425  IF ( nchr.LE.20 .OR. lchr.EQ.pmiss ) THEN
426  iret = rjust(lchr)
427  fmt = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)'
428  WRITE(luout,fmt) numb,nemo,lchr,nchr,unit,desc
429  ELSE
430  fmt = '(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)'
431  WRITE(luout,fmt) numb,nemo,lchr2(1:nchr),nchr,unit,desc
432  ENDIF
433  ENDIF
434 
435  ENDDO
436 
437  WRITE(luout,3)
438 3 FORMAT(/' >>> END OF SUBSET <<< '/)
439 
440 C EXITS
441 C -----
442 
443 100 RETURN
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')
455  END
INTEGER function icbfms(STR, LSTR)
This function provides a handy way to check whether a character string returned from a previous call ...
Definition: icbfms.f:31
function rjust(STR)
THIS FUNCTION RIGHT JUSTIFIES A CHARACTER STRING.
Definition: rjust.f:29
This module contains array and variable declarations for use with any 2-03-YYY (change reference valu...
Definition: moda_nrv203.F:15
subroutine strsuc(STR1, STR2, LENS)
THIS SUBROUTINE REMOVES LEADING AND TRAILING BLANKS FROM A STRING.
Definition: strsuc.f:34
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
Definition: moda_tababd.F:10
INTEGER function ibfms(R8VAL)
This function provides a handy way to check whether a real*8 data value returned from a previous call...
Definition: ibfms.f:39
subroutine numtbd(LUN, IDN, NEMO, TAB, IRET)
THIS SUBROUTINE SEARCHES FOR AN INTEGER IDN, CONTAINING THE BIT-WISE REPRESENTATION OF A DESCRIPTOR (...
Definition: numtbd.f:54
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:61
subroutine upftbv(LUNIT, NEMO, VAL, MXIB, IBIT, NIB)
Given a Table B mnemonic with flag table units and a corresponding numerical data value...
Definition: upftbv.f:35
INTEGER function ireadmt(LUN)
THIS FUNCTION CHECKS THE MOST RECENT BUFR MESSAGE THAT WAS READ AS INPUT VIA SUBROUTINE READMG...
Definition: ireadmt.F:54
subroutine ufdump(LUNIT, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
Definition: ufdump.f:71
subroutine nemtab(LUN, NEMO, IDN, TAB, IRET)
THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTI...
Definition: nemtab.f:66
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
INTEGER function isize(NUM)
THIS FUNCTION COMPUTES AND RETURNS THE NUMBER OF CHARACTERS NEEDED TO ENCODE THE INPUT INTEGER NUM AS...
Definition: isize.f:27
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) ...
Definition: srchtbf.c:72
subroutine fstag(LUN, UTAG, NUTAG, NIN, NOUT, IRET)
THIS SUBROUTINE FINDS THE (NUTAG)th OCCURRENCE OF MNEMONIC UTAG WITHIN THE CURRENT OVERALL SUBSET DEF...
Definition: fstag.f:40
subroutine readlc(LUNIT, CHR, STR)
This subroutine reads a long character string (greater than 8 bytes) from a data subset.
Definition: readlc.f:62