NCEPLIBS-bufr  11.7.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> | Date | Programmer | Comments |
47 C> | -----|------------|----------|
48 C> | 2002-05-14 | J. Woollen | Original author |
49 C> | 2003-11-04 | J. Woollen | Modified to handle print of character values greater than 8 bytes |
50 C> | 2003-11-04 | S. Bender | Added remarks and routine interdependencies |
51 C> | 2003-11-04 | D. Keyser | Increased MAXJL from 15000 to 16000; unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally |
52 C> | 2004-08-18 | J. Ator | Added fuzziness test and threshold for missing value; added interactive and scrolling capability similar to ufbdmp() |
53 C> | 2006-04-14 | J. Ator | Add call to upftbv() for flag tables to get actual bits that were set to generate value |
54 C> | 2007-01-19 | J. Ator | Use function ibfms() |
55 C> | 2009-03-23 | J. Ator | Add level markers to output for sequences where the replication count is > 1; output all occurrences of long character strings |
56 C> | 2012-02-24 | J. Ator | Fix missing check for long character strings |
57 C> | 2012-03-02 | J. Ator | Label redefined reference values |
58 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
59 C> | 2015-09-24 | J. Woollen | Print level identifiers for event stacks |
60 C> | 2020-08-18 | J. Ator | Improve logic for sequence tracking |
61 C> | 2021-09-30 | J. Ator | Replace rjust with Fortran intrinsic adjustr |
62 C>
63  SUBROUTINE ufdump(LUNIT,LUPRT)
64 
65  USE moda_usrint
66  USE moda_msgcwd
67  USE moda_tababd
68  USE moda_tables
69  USE moda_nrv203
70 
71  COMMON /tablef/ cdmf
72 
73  CHARACTER*120 cfmeang
74  CHARACTER*80 fmt
75  CHARACTER*64 desc
76  CHARACTER*24 unit
77  CHARACTER*120 lchr2
78  CHARACTER*20 lchr,pmiss
79  CHARACTER*15 nemo3
80  CHARACTER*10 nemo,nemo2,tagrfe
81  CHARACTER*8 nemod
82  CHARACTER*6 numb
83  CHARACTER*7 fmtf
84  CHARACTER*8 cval
85  CHARACTER*3 type
86  CHARACTER*1 cdmf,tab,you
87  equivalence(rval,cval)
88  REAL*8 rval
89  LOGICAL track,found,rdrv
90 
91  parameter(mxcfdp=5)
92  INTEGER icfdp(mxcfdp)
93 
94  parameter(mxfv=31)
95  integer ifv(mxfv)
96 
97  parameter(mxseq=10)
98  INTEGER idxrep(mxseq)
99  INTEGER numrep(mxseq)
100  CHARACTER*10 seqnam(mxseq)
101  INTEGER lsqnam(mxseq)
102 
103  parameter(mxls=10)
104  CHARACTER*10 lsnemo(mxls)
105  INTEGER lsct(mxls)
106 
107  DATA pmiss /' MISSING'/
108  DATA you /'Y'/
109 
110 C----------------------------------------------------------------------
111 C----------------------------------------------------------------------
112 
113  nseq = 0
114  nls = 0
115  lcfmeang = len(cfmeang)
116 
117  IF(luprt.EQ.0) THEN
118  luout = 6
119  ELSE
120  luout = luprt
121  ENDIF
122 
123 C CHECK THE FILE STATUS AND I-NODE
124 C --------------------------------
125 
126  CALL status(lunit,lun,il,im)
127  IF(il.EQ.0) goto 900
128  IF(il.GT.0) goto 901
129  IF(im.EQ.0) goto 902
130  IF(inode(lun).NE.inv(1,lun)) goto 903
131 
132  WRITE(luout,fmt='(/,2A,/)') 'MESSAGE TYPE ',tag(inode(lun))
133 
134 C DUMP THE CONTENTS OF MODULE USRINT FOR UNIT LUNIT
135 C -------------------------------------------------
136 
137 C If code/flag table details are being printed, and if this is the
138 C first subset of a new message, then make sure the appropriate
139 C master tables have been read in to memory for this message.
140 
141  IF(cdmf.EQ.'Y' .AND. nsub(lun).EQ.1) itmp = ireadmt(lun)
142 
143  DO nv=1,nval(lun)
144  IF(luprt.EQ.0 .AND. mod(nv,20).EQ.0) THEN
145 
146 C When LUPRT=0, the output will be scrolled, 20 elements at a time
147 C ----------------------------------------------------------------
148 
149  print*,'(<enter> for MORE, q <enter> to QUIT)'
150  READ(5,'(A1)') you
151 
152 C If the terminal enters "q" followed by "<enter>" after the prompt
153 C "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
154 C subroutine will return to the calling program
155 C -------------------------------------------------------------------
156 
157  IF(you.EQ.'q') THEN
158  print*
159  print*,'==> You have chosen to stop the dumping of this subset'
160  print*
161  goto 100
162  ENDIF
163  ENDIF
164 
165  node = inv(nv,lun)
166  nemo = tag(node)
167  ityp = itp(node)
168  TYPE = typ (node)
169 
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)
175  rval = val(nv,lun)
176  ENDIF
177 
178  IF((ityp.EQ.0).OR.(ityp.EQ.1)) THEN
179 
180 C Sequence descriptor or delayed descriptor replication factor
181 
182  IF((type.EQ.'REP').OR.(type.EQ.'DRP').OR.
183  . (type.EQ.'DRB').OR.(type.EQ.'DRS')) THEN
184 
185 C Print the number of replications
186 
187  nseq = nseq+1
188  IF(nseq.GT.mxseq) goto 904
189  IF(type.EQ.'REP') THEN
190  numrep(nseq) = irf(node)
191  ELSE
192  numrep(nseq) = nint(rval)
193  ENDIF
194  CALL strsuc(nemo,nemo2,lnm2)
195  fmt = '(11X,A,I6,1X,A)'
196  WRITE(luout,fmt) nemo2(1:lnm2), numrep(nseq), 'REPLICATIONS'
197 
198 C How many times is this sequence replicated?
199 
200  IF(numrep(nseq).GT.1) THEN
201 
202 C Track the sequence
203 
204  seqnam(nseq) = nemo2
205  lsqnam(nseq) = lnm2
206  idxrep(nseq) = 1
207  ELSE
208 
209 C Don't bother
210 
211  nseq = nseq-1
212  ENDIF
213  ELSEIF( ((type.EQ.'SEQ').OR.(type.EQ.'RPC').OR.(type.EQ.'RPS'))
214  . .AND. (nseq.GT.0) ) THEN
215 
216 C Is this one of the sequences being tracked?
217 
218  ii = nseq
219  track = .false.
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
223  track = .true.
224 
225 C Mark this level in the output
226 
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
231 
232 C There are more levels to come
233 
234  idxrep(ii) = idxrep(ii)+1
235  ELSE
236 
237 C This was the last level for this sequence, so stop
238 C tracking it
239 
240  nseq = nseq-1
241  ENDIF
242  ELSE
243  ii = ii-1
244  ENDIF
245  ENDDO
246  ENDIF
247  ELSEIF(ityp.EQ.2) THEN
248 
249 C Other numeric value
250 
251 C First check if this node contains a redefined reference
252 C value. If so, modify the DESC field to label it as such.
253 
254  jj = 1
255  rdrv = .false.
256  DO WHILE ((jj.LE.nnrv).AND.(.NOT.rdrv))
257  IF (node.EQ.inodnrv(jj)) THEN
258  rdrv = .true.
259  desc = 'New reference value for ' // nemo
260  unit = ' '
261  ELSE
262  jj = jj + 1
263  ENDIF
264  ENDDO
265 
266 C Check if this element refers to another element via a bitmap.
267 C If so, modify the DESC field to identify the referred element.
268 
269  nrfe = nrfelm(nv,lun)
270  IF(nrfe.GT.0) THEN
271  tagrfe = tag(inv(nrfe,lun))
272  jj = 48
273  DO WHILE((jj.GE.1).AND.(desc(jj:jj).EQ.' '))
274  jj = jj - 1
275  ENDDO
276  IF(jj.LE.33) desc(jj+1:jj+15) = ' for ' // tagrfe
277  ENDIF
278 
279 C Now print the value
280 
281  IF(ibfms(rval).NE.0) THEN
282 
283 C The value is "missing".
284 
285  fmt = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)'
286  WRITE(luout,fmt) numb,nemo,pmiss,unit,desc
287  ELSE
288  fmt = '(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)'
289 
290 C Based upon the corresponding scale factor, select an
291 C appropriate format for the printing of this value.
292 
293  WRITE(fmt(19:20),'(I2)') max(1,isc(node))
294  IF(unit(1:4).EQ.'FLAG') THEN
295 
296 C Print a listing of the bits corresponding to
297 C this value.
298 
299  CALL upftbv(lunit,nemo,rval,mxfv,ifv,nifv)
300  IF(nifv.GT.0) THEN
301  unit(11:11) = '('
302  ipt = 12
303  DO ii=1,nifv
304  isz = isize(ifv(ii))
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), ','
308  ipt = ipt + isz + 1
309  ELSE
310  unit(12:23) = 'MANY BITS ON'
311  ipt = 25
312  ENDIF
313  ENDDO
314  unit(ipt-1:ipt-1) = ')'
315  ENDIF
316  ENDIF
317 
318  WRITE(luout,fmt) numb,nemo,rval,unit,desc
319 
320  IF( (unit(1:4).EQ.'FLAG' .OR. unit(1:4).EQ.'CODE') .AND.
321  . (cdmf.EQ.'Y') ) THEN
322 
323 C Print the meanings of the code and flag values.
324 
325  fmt = '(31X,I8,A,A)'
326  IF(unit(1:4).EQ.'CODE') THEN
327  nifv = 1
328  ifv(nifv) = nint(rval)
329  ENDIF
330  DO ii=1,nifv
331  icfdp(1) = (-1)
332  ifvd = (-1)
333  CALL srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
334  . cfmeang,lcfmeang,lcfmg,iersf)
335  IF(iersf.EQ.0) THEN
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***'
340  ELSE
341 
342 C The meaning of this value is dependent on the
343 C value of another mnemonic in the report. Look for
344 C that other mnemonic within the report and then use
345 C it and its associated value to retrieve and print
346 C the proper meaning from the code/flag tables.
347 
348  ierft = (-1)
349  jj = 0
350  DO WHILE((jj.LT.iersf).AND.(ierft.LT.0))
351  jj = jj + 1
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)
355  ENDIF
356  ENDDO
357  IF(ierft.EQ.0) THEN
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)
362  IF(iersf.EQ.0) THEN
363  WRITE(luout,fmt) ifv(ii),' = ',
364  . cfmeang(1:lcfmg)
365  ENDIF
366  ENDIF
367  ENDIF
368  ENDDO
369  ENDIF
370  ENDIF
371  ELSEIF(ityp.EQ.3) THEN
372 
373 C Character (CCITT IA5) value
374 
375  nchr = ibt(node)/8
376 
377  IF(ibfms(rval).NE.0) THEN
378  lchr = pmiss
379  ELSE IF(nchr.LE.8) THEN
380  lchr = cval
381  ELSE
382 
383 C Track the number of occurrences of this long character string, so
384 C that we can properly output each one.
385 
386  ii = 1
387  found = .false.
388  DO WHILE((ii.LE.nls).AND.(.NOT.found))
389  IF(nemo.EQ.lsnemo(ii)) THEN
390  found = .true.
391  ELSE
392  ii = ii + 1
393  ENDIF
394  ENDDO
395 
396  IF(.NOT.found) THEN
397  nls = nls+1
398  IF(nls.GT.mxls) goto 905
399  lsnemo(nls) = nemo
400  lsct(nls) = 1
401  nemo3 = nemo
402  ELSE
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)
407  ENDIF
408 
409  CALL readlc(lunit,lchr2,nemo3)
410  IF (icbfms(lchr2,nchr).NE.0) THEN
411  lchr = pmiss
412  ELSE
413  lchr = lchr2(1:20)
414  ENDIF
415  ENDIF
416 
417  IF ( nchr.LE.20 .OR. lchr.EQ.pmiss ) THEN
418  lchr = adjustr(lchr)
419  fmt = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)'
420  WRITE(luout,fmt) numb,nemo,lchr,nchr,unit,desc
421  ELSE
422  fmt = '(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)'
423  WRITE(luout,fmt) numb,nemo,lchr2(1:nchr),nchr,unit,desc
424  ENDIF
425  ENDIF
426 
427  ENDDO
428 
429  WRITE(luout,3)
430 3 FORMAT(/' >>> END OF SUBSET <<< '/)
431 
432 C EXITS
433 C -----
434 
435 100 RETURN
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')
447  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
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 character string.
Definition: strsuc.f:23
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:38
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...
Definition: numtbd.f:35
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:55
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:37
subroutine ufdump(LUNIT, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
Definition: ufdump.f:63
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.
Definition: nemtab.f:44
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
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
INTEGER function ireadmt(LUN)
This function checks the most recent BUFR message that was read via a call to one of the message-read...
Definition: ireadmt.f:42
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:74
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:58