NCEPLIBS-bufr 11.7.1
All Data Structures Namespaces Files Functions Variables Pages
ufbdmp.f
Go to the documentation of this file.
1C> @file
2C> @brief Print the contents of a data subset.
3
4C> This subroutine prints a verbose listing of the contents of a data
5C> subset, including all data values and replicated sequences, as well
6C> as jump/link table information and other internal subset pointers.
7C>
8C> <p>This subroutine is similar to subroutine ufdump(), but it prints
9C> different characteristics of each data subset, and in a slightly
10C> different format. However, both subroutines can be useful for
11C> different diagnostic purposes, and both can also be run
12C> interactively to scroll through the contents of a data subset.
13C>
14C> @authors J. Woollen
15C> @authors J. Ator
16C> @authors D. Keyser
17C> @date 1994-01-06
18C>
19C> @param[in] LUNIN -- integer: Absolute value is Fortran logical
20C> unit number for BUFR file
21C> - If LUNIN > 0, data values are printed to
22C> LUPRT using the format descriptor code
23C> 'G15.6', meaning that all values will be
24C> printed (since the format adapts to the
25C> order of magnitude of each value), but
26C> values won't necessarily be lined up
27C> with the decimal point in the same column
28C> - If LUNIN < 0, data values are printed to
29C> LUPRT using the format descriptor code
30C> 'F15.6', meaning that all values will be
31C> lined up with the decimal point in the
32C> same column, but values exceeding the
33C> format width of 15 characters will print
34C> as overflow (e.g. '***************')
35C> @param[in] LUPRT -- integer: Fortran logical unit number for
36C> print output
37C> - 0 = Run interactively, printing to
38C> standard output
39C>
40C> <p>Logical unit ABS(LUNIN) should have already been opened for
41C> input operations via a previous call to subroutine openbf(), and a
42C> BUFR data subset should have already been read into internal arrays
43C> via a previous call to one of the
44C> [subset-reading subroutines](@ref hierarchy).
45C>
46C> <p>Except when LUPRT = 0, logical unit LUPRT must already be
47C> associated with a filename on the local system, typically via a
48C> Fortran "OPEN" statement. When LUPRT = 0, the subroutine will run
49C> interactively and print to standard output, scrolling 20 lines at
50C> a time and prompting each time whether to quit and return to the
51C> application program (by typing 'q' then '<Enter>') or continue
52C> scrolling (by typing anything else).
53C>
54C> <b>Program history log:</b>
55C> | Date | Programmer | Comments |
56C> | -----|------------|----------|
57C> | 1994-01-06 | J. Woollen | Original author |
58C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT with call to new internal routine bort() |
59C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 |
60C> | 2002-05-14 | J. Woollen | Removed old Cray compiler directives |
61C> | 2003-11-04 | S. Bender | Added remarks and routine interdependencies |
62C> | 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 |
63C> | 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 |
64C> | 2004-08-18 | J. Ator | Modified fuzziness test; added readlc() option; restructured some logic for clarity |
65C> | 2006-04-14 | D. Keyser | Add call to upftbv() for flag tables to get actual bits that were set to generate value |
66C> | 2007-01-19 | J. Ator | Use function ibfms() |
67C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
68C> | 2020-09-09 | J. Ator | Fix missing check for long character strings |
69C> | 2021-09-30 | J. Ator | Replace rjust with Fortran intrinsic adjustr |
70C>
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
95C----------------------------------------------------------------------
96C----------------------------------------------------------------------
97
98 IF(luprt.EQ.0) THEN
99 luout = 6
100 ELSE
101 luout = luprt
102 ENDIF
103
104C CHECK THE FILE STATUS AND I-NODE
105C --------------------------------
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
114C DUMP THE CONTENTS OF MODULE USRINT FOR UNIT ABS(LUNIN)
115C ------------------------------------------------------
116
117 DO nv=1,nval(lun)
118 IF(luprt.EQ.0 .AND. mod(nv,20).EQ.0) THEN
119
120C When LUPRT=0, the output will be scrolled, 20 elements at a time
121C ----------------------------------------------------------------
122
123 print*,'(<enter> for MORE, q <enter> to QUIT)'
124 READ(5,'(A1)') you
125
126C If the terminal enters "q" followed by "<enter>" after the prompt
127C "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
128C subroutine will return to the calling program
129C -------------------------------------------------------------------
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
156C Print a listing of the bits corresponding to
157C 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
2171 FORMAT(i5,1x,a3,'-',i1,1x,a10,5x,g15.6,1x,a14,7(1x,i5))
21810 FORMAT(i5,1x,a3,'-',i1,1x,a10,5x,f15.6,1x,a14,7(1x,i5))
2192 FORMAT(i5,1x,a3,'-',i1,1x,a10,1x, a20, 14x,7(1x,i5))
2203 FORMAT(/' >>> END OF SUBSET <<< '/)
2214 FORMAT(i5,1x,a3,'-',i1,1x,a10,1x, a, 7(1x,i5))
222
223C EXITS
224C -----
225
226100 RETURN
227900 CALL bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT '//
228 . 'MUST BE OPEN FOR INPUT')
229901 CALL bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR '//
230 . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
231902 CALL bort('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT '//
232 . 'BUFR FILE, NONE ARE')
233903 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
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
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
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:32
integer function isize(NUM)
THIS FUNCTION COMPUTES AND RETURNS THE NUMBER OF CHARACTERS NEEDED TO ENCODE THE INPUT INTEGER NUM AS...
Definition: isize.f:28
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
Definition: moda_tababd.F:10
character *128, dimension(:,:), allocatable tabb
Table B entries for each internal I/O stream.
Definition: moda_tababd.F:59
This module contains array and variable declarations used to store the internal jump/link table.
Definition: moda_tables.F:13
integer, dimension(:), allocatable link
Link indices corresponding to tag, typ and jmpb:
Definition: moda_tables.F:136
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Definition: moda_tables.F:141
integer, dimension(:), allocatable isc
Scale factors corresponding to tag and typ:
Definition: moda_tables.F:140
character *3, dimension(:), allocatable typ
Type indicators corresponding to tag:
Definition: moda_tables.F:133
integer, dimension(:), allocatable jump
Jump forward indices corresponding to tag and typ:
Definition: moda_tables.F:135
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
Definition: moda_tables.F:138
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
Definition: moda_tables.F:132
integer, dimension(:), allocatable irf
Reference values corresponding to tag and typ:
Definition: moda_tables.F:139
integer, dimension(:), allocatable jmpb
Jump backward indices corresponding to tag and typ:
Definition: moda_tables.F:137
subroutine nemtab(LUN, NEMO, IDN, TAB, IRET)
This subroutine returns information about a descriptor from the internal DX BUFR tables,...
Definition: nemtab.f:45
subroutine readlc(LUNIT, CHR, STR)
This subroutine reads a long character string (greater than 8 bytes) from a data subset.
Definition: readlc.f:59
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:56
subroutine ufbdmp(LUNIN, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
Definition: ufbdmp.f:72
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:38