NCEPLIBS-bufr  11.5.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> - 1994-01-06 J. Woollen -- Original author
56 C> - 1998-07-08 J. Woollen -- Replaced call to Cray library routine ABORT
57 C> with call to new internal routine bort()
58 C> - 1999-11-18 J. Woollen -- The number of BUFR files which can be
59 C> opened at one time increased from 10 to 32
60 C> (necessary in order to process multiple
61 C> BUFR files under the MPI)
62 C> - 2002-05-14 J. Woollen -- Removed old Cray compiler directives
63 C> - 2003-11-04 S. Bender -- Added remarks and routine interdependencies
64 C> - 2003-11-04 D. Keyser -- Increased MAXJL from 15000 to 16000;
65 C> unified/portable for WRF; added history
66 C> documentation; outputs more complete
67 C> diagnostic info when routine terminates
68 C> abnormally, unusual things happen or for
69 C> informational purposes; allowed fuzziness
70 C> in test for missing values; added option
71 C> to print using either 'G15.6' or 'F15.6';
72 C> added several jump/link table values to
73 C> output
74 C> - 2004-08-18 J. Ator -- Modified fuzziness test; added readlc()
75 C> option; restructured some logic for clarity
76 C> - 2006-04-14 D. Keyser -- Add call to upftbv() for flag tables to get
77 C> actual bits that were set to generate value
78 C> - 2007-01-19 J. Ator -- Use function ibfms()
79 C> - 2014-12-10 J. Ator -- Use modules instead of COMMON blocks
80 C> - 2020-09-09 J. Ator -- Fix missing check for long character strings
81 C>
82  SUBROUTINE ufbdmp(LUNIN,LUPRT)
83 
84  USE moda_usrint
85  USE moda_msgcwd
86  USE moda_tababd
87  USE moda_tables
88 
89  CHARACTER*120 lchr2
90  CHARACTER*20 lchr,pmiss
91  CHARACTER*14 bits
92  CHARACTER*10 tg,tg_rj
93  CHARACTER*8 vc
94  CHARACTER*7 fmtf
95  CHARACTER*3 tp
96  CHARACTER*1 tab,you
97  equivalence(vl,vc)
98  REAL*8 vl
99 
100  parameter(mxfv=31)
101  integer ifv(mxfv)
102 
103  DATA pmiss /' MISSING'/
104  DATA you /'Y'/
105 
106 C----------------------------------------------------------------------
107 C----------------------------------------------------------------------
108 
109  IF(luprt.EQ.0) THEN
110  luout = 6
111  ELSE
112  luout = luprt
113  ENDIF
114 
115 C CHECK THE FILE STATUS AND I-NODE
116 C --------------------------------
117 
118  lunit = abs(lunin)
119  CALL status(lunit,lun,il,im)
120  IF(il.EQ.0) goto 900
121  IF(il.GT.0) goto 901
122  IF(im.EQ.0) goto 902
123  IF(inode(lun).NE.inv(1,lun)) goto 903
124 
125 C DUMP THE CONTENTS OF MODULE USRINT FOR UNIT ABS(LUNIN)
126 C ------------------------------------------------------
127 
128  DO nv=1,nval(lun)
129  IF(luprt.EQ.0 .AND. mod(nv,20).EQ.0) THEN
130 
131 C When LUPRT=0, the output will be scrolled, 20 elements at a time
132 C ----------------------------------------------------------------
133 
134  print*,'(<enter> for MORE, q <enter> to QUIT)'
135  READ(5,'(A1)') you
136 
137 C If the terminal enters "q" followed by "<enter>" after the prompt
138 C "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
139 C subroutine will return to the calling program
140 C -------------------------------------------------------------------
141 
142  IF(you.EQ.'q') THEN
143  print*
144  print*,'==> You have chosen to stop the dumping of this subset'
145  print*
146  goto 100
147  ENDIF
148  ENDIF
149  nd = inv(nv,lun)
150  vl = val(nv,lun)
151  tg = tag(nd)
152  tp = typ(nd)
153  it = itp(nd)
154  ib = ibt(nd)
155  is = isc(nd)
156  ir = irf(nd)
157  jp = jump(nd)
158  lk = link(nd)
159  jb = jmpb(nd)
160  tg_rj = tg
161  rj = rjust(tg_rj)
162  IF(tp.NE.'CHR') THEN
163  bits = ' '
164  IF(it.EQ.2) THEN
165  CALL nemtab(lun,tg,idn,tab,n)
166  IF(tabb(n,lun)(71:75).EQ.'FLAG') THEN
167 
168 C Print a listing of the bits corresponding to
169 C this value.
170 
171  CALL upftbv(lunit,tg,vl,mxfv,ifv,nifv)
172  IF(nifv.GT.0) THEN
173  bits(1:1) = '('
174  ipt = 2
175  DO ii=1,nifv
176  isz = isize(ifv(ii))
177  WRITE(fmtf,'(A2,I1,A4)') '(I', isz, ',A1)'
178  IF((ipt+isz).LE.14) THEN
179  WRITE(bits(ipt:ipt+isz),fmtf) ifv(ii), ','
180  ipt = ipt + isz + 1
181  ELSE
182  bits(2:13) = 'MANY BITS ON'
183  ipt = 15
184  ENDIF
185  ENDDO
186  bits(ipt-1:ipt-1) = ')'
187  ENDIF
188  ENDIF
189  ENDIF
190  IF(ibfms(vl).NE.0) THEN
191  WRITE(luout,2) nv,tp,it,tg_rj,pmiss,ib,is,ir,nd,jp,lk,jb
192  ELSE
193  IF(lunit.EQ.lunin) THEN
194  WRITE(luout,1) nv,tp,it,tg_rj,vl,bits,ib,is,ir,nd,jp,lk,
195  . jb
196  ELSE
197  WRITE(luout,10) nv,tp,it,tg_rj,vl,bits,ib,is,ir,nd,jp,lk,
198  . jb
199  ENDIF
200  ENDIF
201  ELSE
202  nchr=ib/8
203  IF(nchr.GT.8) THEN
204  CALL readlc(lunit,lchr2,tg_rj)
205  IF (icbfms(lchr2,nchr).NE.0) THEN
206  lchr = pmiss
207  ELSE
208  lchr = lchr2(1:20)
209  ENDIF
210  ELSE
211  IF(ibfms(vl).NE.0) THEN
212  lchr = pmiss
213  ELSE
214  lchr = vc
215  ENDIF
216  ENDIF
217  IF ( nchr.LE.20 .OR. lchr.EQ.pmiss ) THEN
218  rj = rjust(lchr)
219  WRITE(luout,2) nv,tp,it,tg_rj,lchr,ib,is,ir,nd,jp,lk,jb
220  ELSE
221  WRITE(luout,4) nv,tp,it,tg_rj,lchr2(1:nchr),ib,is,ir,nd,jp,
222  . lk,jb
223  ENDIF
224  ENDIF
225  ENDDO
226 
227  WRITE(luout,3)
228 
229 1 FORMAT(i5,1x,a3,'-',i1,1x,a10,5x,g15.6,1x,a14,7(1x,i5))
230 10 FORMAT(i5,1x,a3,'-',i1,1x,a10,5x,f15.6,1x,a14,7(1x,i5))
231 2 FORMAT(i5,1x,a3,'-',i1,1x,a10,1x, a20, 14x,7(1x,i5))
232 3 FORMAT(/' >>> END OF SUBSET <<< '/)
233 4 FORMAT(i5,1x,a3,'-',i1,1x,a10,1x, a, 7(1x,i5))
234 
235 C EXITS
236 C -----
237 
238 100 RETURN
239 900 CALL bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT '//
240  . 'MUST BE OPEN FOR INPUT')
241 901 CALL bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR '//
242  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
243 902 CALL bort('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT '//
244  . 'BUFR FILE, NONE ARE')
245 903 CALL bort('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '//
246  . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
247  . 'INTERNAL SUBSET ARRAY')
248  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 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
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
subroutine ufbdmp(LUNIN, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
Definition: ufbdmp.f:82
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
subroutine readlc(LUNIT, CHR, STR)
This subroutine reads a long character string (greater than 8 bytes) from a data subset.
Definition: readlc.f:62