NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
ufbdmp.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 jump/link table information and other internal subset pointers.
7 C>
8 C> <p>This subroutine is similar to subroutine ufdump(), 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> @authors D. Keyser
17 C> @date 1994-01-06
18 C>
19 C> @param[in] LUNIN -- integer: Absolute value is Fortran logical
20 C> unit number for BUFR file
21 C> - If LUNIN > 0, data values are printed to
22 C> LUPRT using the format descriptor code
23 C> 'G15.6', meaning that all values will be
24 C> printed (since the format adapts to the
25 C> order of magnitude of each value), but
26 C> values won't necessarily be lined up
27 C> with the decimal point in the same column
28 C> - If LUNIN < 0, data values are printed to
29 C> LUPRT using the format descriptor code
30 C> 'F15.6', meaning that all values will be
31 C> lined up with the decimal point in the
32 C> same column, but values exceeding the
33 C> format width of 15 characters will print
34 C> as overflow (e.g. '***************')
35 C> @param[in] LUPRT -- integer: Fortran logical unit number for
36 C> print output
37 C> - 0 = Run interactively, printing to
38 C> standard output
39 C>
40 C> <p>Logical unit ABS(LUNIN) should have already been opened for
41 C> input operations via a previous call to subroutine openbf(), and a
42 C> BUFR data subset should have already been read into internal arrays
43 C> via a previous call to one of the
44 C> [subset-reading subroutines](@ref hierarchy).
45 C>
46 C> <p>Except when LUPRT = 0, logical unit LUPRT must already be
47 C> associated with a filename on the local system, typically via a
48 C> Fortran "OPEN" statement. When LUPRT = 0, the subroutine will run
49 C> interactively and print to standard output, scrolling 20 lines at
50 C> a time and prompting each time whether to quit and return to the
51 C> application program (by typing 'q' then '<Enter>') or continue
52 C> scrolling (by typing anything else).
53 C>
54 C> <b>Program history log:</b>
55 C> | Date | Programmer | Comments |
56 C> | -----|------------|----------|
57 C> | 1994-01-06 | J. Woollen | Original author |
58 C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT with call to new internal routine bort() |
59 C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 |
60 C> | 2002-05-14 | J. Woollen | Removed old Cray compiler directives |
61 C> | 2003-11-04 | S. Bender | Added remarks and routine interdependencies |
62 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 |
63 C> | 2003-11-04 | D. Keyser | Allowed fuzziness in test for missing values; added option to print using either 'G15.6' or 'F15.6'; added several jump/link table values to output |
64 C> | 2004-08-18 | J. Ator | Modified fuzziness test; added readlc() option; restructured some logic for clarity |
65 C> | 2006-04-14 | D. Keyser | Add call to upftbv() for flag tables to get actual bits that were set to generate value |
66 C> | 2007-01-19 | J. Ator | Use function ibfms() |
67 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
68 C> | 2020-09-09 | J. Ator | Fix missing check for long character strings |
69 C> | 2021-09-30 | J. Ator | Replace rjust with Fortran intrinsic adjustr |
70 C>
71  SUBROUTINE ufbdmp(LUNIN,LUPRT)
72 
73  USE moda_usrint
74  USE moda_msgcwd
75  USE moda_tababd
76  USE moda_tables
77 
78  CHARACTER*120 lchr2
79  CHARACTER*20 lchr,pmiss
80  CHARACTER*14 bits
81  CHARACTER*10 tg,tg_rj
82  CHARACTER*8 vc
83  CHARACTER*7 fmtf
84  CHARACTER*3 tp
85  CHARACTER*1 tab,you
86  equivalence(vl,vc)
87  REAL*8 vl
88 
89  parameter(mxfv=31)
90  integer ifv(mxfv)
91 
92  DATA pmiss /' MISSING'/
93  DATA you /'Y'/
94 
95 C----------------------------------------------------------------------
96 C----------------------------------------------------------------------
97 
98  IF(luprt.EQ.0) THEN
99  luout = 6
100  ELSE
101  luout = luprt
102  ENDIF
103 
104 C CHECK THE FILE STATUS AND I-NODE
105 C --------------------------------
106 
107  lunit = abs(lunin)
108  CALL status(lunit,lun,il,im)
109  IF(il.EQ.0) goto 900
110  IF(il.GT.0) goto 901
111  IF(im.EQ.0) goto 902
112  IF(inode(lun).NE.inv(1,lun)) goto 903
113 
114 C DUMP THE CONTENTS OF MODULE USRINT FOR UNIT ABS(LUNIN)
115 C ------------------------------------------------------
116 
117  DO nv=1,nval(lun)
118  IF(luprt.EQ.0 .AND. mod(nv,20).EQ.0) THEN
119 
120 C When LUPRT=0, the output will be scrolled, 20 elements at a time
121 C ----------------------------------------------------------------
122 
123  print*,'(<enter> for MORE, q <enter> to QUIT)'
124  READ(5,'(A1)') you
125 
126 C If the terminal enters "q" followed by "<enter>" after the prompt
127 C "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
128 C subroutine will return to the calling program
129 C -------------------------------------------------------------------
130 
131  IF(you.EQ.'q') THEN
132  print*
133  print*,'==> You have chosen to stop the dumping of this subset'
134  print*
135  goto 100
136  ENDIF
137  ENDIF
138  nd = inv(nv,lun)
139  vl = val(nv,lun)
140  tg = tag(nd)
141  tp = typ(nd)
142  it = itp(nd)
143  ib = ibt(nd)
144  is = isc(nd)
145  ir = irf(nd)
146  jp = jump(nd)
147  lk = link(nd)
148  jb = jmpb(nd)
149  tg_rj = adjustr(tg)
150  IF(tp.NE.'CHR') THEN
151  bits = ' '
152  IF(it.EQ.2) THEN
153  CALL nemtab(lun,tg,idn,tab,n)
154  IF(tabb(n,lun)(71:75).EQ.'FLAG') THEN
155 
156 C Print a listing of the bits corresponding to
157 C this value.
158 
159  CALL upftbv(lunit,tg,vl,mxfv,ifv,nifv)
160  IF(nifv.GT.0) THEN
161  bits(1:1) = '('
162  ipt = 2
163  DO ii=1,nifv
164  isz = isize(ifv(ii))
165  WRITE(fmtf,'(A2,I1,A4)') '(I', isz, ',A1)'
166  IF((ipt+isz).LE.14) THEN
167  WRITE(bits(ipt:ipt+isz),fmtf) ifv(ii), ','
168  ipt = ipt + isz + 1
169  ELSE
170  bits(2:13) = 'MANY BITS ON'
171  ipt = 15
172  ENDIF
173  ENDDO
174  bits(ipt-1:ipt-1) = ')'
175  ENDIF
176  ENDIF
177  ENDIF
178  IF(ibfms(vl).NE.0) THEN
179  WRITE(luout,2) nv,tp,it,tg_rj,pmiss,ib,is,ir,nd,jp,lk,jb
180  ELSE
181  IF(lunit.EQ.lunin) THEN
182  WRITE(luout,1) nv,tp,it,tg_rj,vl,bits,ib,is,ir,nd,jp,lk,
183  . jb
184  ELSE
185  WRITE(luout,10) nv,tp,it,tg_rj,vl,bits,ib,is,ir,nd,jp,lk,
186  . jb
187  ENDIF
188  ENDIF
189  ELSE
190  nchr=ib/8
191  IF(nchr.GT.8) THEN
192  CALL readlc(lunit,lchr2,tg_rj)
193  IF (icbfms(lchr2,nchr).NE.0) THEN
194  lchr = pmiss
195  ELSE
196  lchr = lchr2(1:20)
197  ENDIF
198  ELSE
199  IF(ibfms(vl).NE.0) THEN
200  lchr = pmiss
201  ELSE
202  lchr = vc
203  ENDIF
204  ENDIF
205  IF ( nchr.LE.20 .OR. lchr.EQ.pmiss ) THEN
206  lchr = adjustr(lchr)
207  WRITE(luout,2) nv,tp,it,tg_rj,lchr,ib,is,ir,nd,jp,lk,jb
208  ELSE
209  WRITE(luout,4) nv,tp,it,tg_rj,lchr2(1:nchr),ib,is,ir,nd,jp,
210  . lk,jb
211  ENDIF
212  ENDIF
213  ENDDO
214 
215  WRITE(luout,3)
216 
217 1 FORMAT(i5,1x,a3,'-',i1,1x,a10,5x,g15.6,1x,a14,7(1x,i5))
218 10 FORMAT(i5,1x,a3,'-',i1,1x,a10,5x,f15.6,1x,a14,7(1x,i5))
219 2 FORMAT(i5,1x,a3,'-',i1,1x,a10,1x, a20, 14x,7(1x,i5))
220 3 FORMAT(/' >>> END OF SUBSET <<< '/)
221 4 FORMAT(i5,1x,a3,'-',i1,1x,a10,1x, a, 7(1x,i5))
222 
223 C EXITS
224 C -----
225 
226 100 RETURN
227 900 CALL bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT '//
228  . 'MUST BE OPEN FOR INPUT')
229 901 CALL bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR '//
230  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
231 902 CALL bort('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT '//
232  . 'BUFR FILE, NONE ARE')
233 903 CALL bort('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '//
234  . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
235  . 'INTERNAL SUBSET ARRAY')
236  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 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
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 ufbdmp(LUNIN, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
Definition: ufbdmp.f:71
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
subroutine readlc(LUNIT, CHR, STR)
This subroutine reads a long character string (greater than 8 bytes) from a data subset.
Definition: readlc.f:58