NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
dxdump.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Print the contents of a DX BUFR table.
3 
4 C> This subroutine prints a copy of the DX BUFR table associated
5 C> with a specified Fortran logical unit.
6 C>
7 C> This subroutine is especially useful for learning the structure
8 C> of existing BUFR files which contain DX BUFR table information
9 C> embedded as BUFR messages within those files.
10 C> The DX BUFR table is printed using the same ASCII format
11 C> described in the documentation for
12 C> [DX BUFR Tables](@ref dfbftab), so the output file is suitable
13 C> for use as Fortran logical unit LUNDX in subsequent calls to
14 C> subroutine openbf() for reading or writing additional BUFR
15 C> files with the same structure.
16 C>
17 C> @author J. Ator
18 C> @date 2004-08-18
19 C>
20 C> @param[in] LUNIT -- integer: Fortran logical unit number for
21 C> BUFR file
22 C> @param[in] LDXOT -- integer: Fortran logical unit number for
23 C> print output
24 C>
25 C> <p>Logical unit LUNIT must be open for either input or output
26 C> operations via a previous call to subroutine openbf().
27 C> Logical unit LDXOT must already be associated with a filename
28 C> on the local system, typically via a Fortran "OPEN" statement.
29 C>
30 C> @remarks
31 C> - This subroutine only prints the DX BUFR table that is currently
32 C> in scope for logical unit LUNIT. Therefore, if logical unit LUNIT
33 C> contains multiple embedded DX BUFR tables, then multiple calls to
34 C> this subroutine must be made to print out all of the tables,
35 C> once while each table is in scope for a data subset defined
36 C> within that particular table.
37 C>
38 C> <b>Program history log:</b>
39 C> | Date | Programmer | Comments |
40 C> | -----|------------|----------|
41 C> | 2004-08-18 | J. Ator | Original author |
42 C> | 2007-01-19 | J. Ator | Corrected output for reference values longer than 8 digits |
43 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
44 C>
45  SUBROUTINE dxdump(LUNIT,LDXOT)
46 
47  USE moda_tababd
48  USE moda_nmikrp
49 
50  COMMON /reptab/ idnr(5,2),typs(5,2),reps(5,2),lens(5)
51 
52  CHARACTER*80 card,cardi1,cardi2,cardi3,cardi4
53  CHARACTER*20 cmstr
54  CHARACTER*10 wrk3
55  CHARACTER*8 wrk1,wrk2
56  CHARACTER*6 adn
57  CHARACTER*3 typs
58  CHARACTER*1 reps
59 
60  LOGICAL tbskip, tdskip, xtrci1
61 
62  DATA cardi1( 1:40)
63  . /'| | | '/
64  DATA cardi1(41:80)
65  . /' |'/
66  DATA cardi2( 1:40)
67  . /'| | '/
68  DATA cardi2(41:80)
69  . /' |'/
70  DATA cardi3( 1:40)
71  . /'| | | | | '/
72  DATA cardi3(41:80)
73  . /' |-------------|'/
74  DATA cardi4( 1:40)
75  . /'|---------------------------------------'/
76  DATA cardi4(41:80)
77  . /'---------------------------------------|'/
78 
79 C-----------------------------------------------------------------------
80  tbskip(adn) = ((adn.EQ.'063000').OR.(adn.EQ.'063255').OR.
81  . (adn.EQ.'031000').OR.(adn.EQ.'031001').OR.
82  . (adn.EQ.'031002'))
83  tdskip(adn) = ((adn.EQ.'360001').OR.(adn.EQ.'360002').OR.
84  . (adn.EQ.'360003').OR.(adn.EQ.'360004'))
85 C-----------------------------------------------------------------------
86 
87 C DETERMINE LUN FROM LUNIT.
88 
89  CALL status(lunit,lun,il,im)
90  IF(il.EQ.0) goto 900
91 
92 C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
93 C DESCRIPTOR DEFINITION SECTION.
94 
95  card=cardi4
96  card( 1: 1)='.'
97  card(80:80)='.'
98  WRITE (ldxot,'(A)') card
99 
100  card=cardi4
101  card( 2: 2)=' '
102  card(79:79)=' '
103  card(15:64)=' USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D '
104  WRITE (ldxot,'(A)') card
105 
106  WRITE (ldxot,'(A)') cardi4
107 
108  card=cardi1
109  card( 3:10)='MNEMONIC'
110  card(14:19)='NUMBER'
111  card(23:33)='DESCRIPTION'
112  WRITE (ldxot,'(A)') card
113 
114  card=cardi4
115  card(12:12)='|'
116  card(21:21)='|'
117  WRITE (ldxot,'(A)') card
118 
119 C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D DESCRIPTOR
120 C DEFINITION CARDS.
121 
122  WRITE (ldxot,'(A)') cardi1
123 
124  xtrci1=.false.
125  DO n=1,ntbd(lun)
126  IF(.NOT.tdskip(tabd(n,lun)(1:6))) THEN
127  card=cardi1
128  card( 3:10)=tabd(n,lun)( 7:14)
129  card(14:19)=tabd(n,lun)( 1: 6)
130  card(23:77)=tabd(n,lun)(16:70)
131 
132 C CHECK IF THIS TABLE D MNEMONIC IS ALSO A TABLE A MNEMONIC.
133 C IF SO, THEN LABEL IT AS SUCH AND ALSO CHECK IF IT IS THE
134 C LAST OF THE TABLE A MNEMONICS, IN WHICH CASE AN EXTRA
135 C CARDI1 LINE WILL BE WRITTEN TO LDXOT IN ORDER TO SEPARATE
136 C THE TABLE A MNEMONICS FROM THE OTHER TABLE D MNEMONICS.
137 
138  DO na=1,ntba(lun)
139  IF(taba(na,lun)(4:11).EQ.tabd(n,lun)(7:14)) THEN
140  card(14:14)='A'
141  IF(na.EQ.ntba(lun)) xtrci1=.true.
142  goto 10
143  END IF
144  END DO
145  10 WRITE (ldxot,'(A)') card
146  IF(xtrci1) THEN
147  WRITE (ldxot,'(A)') cardi1
148  xtrci1=.false.
149  END IF
150  END IF
151  END DO
152 
153 C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B DESCRIPTOR
154 C DEFINITION CARDS.
155 
156  WRITE (ldxot,'(A)') cardi1
157 
158  DO n=1,ntbb(lun)
159  IF(.NOT.tbskip(tabb(n,lun)(1:6))) THEN
160  card=cardi1
161  card( 3:10)=tabb(n,lun)( 7:14)
162  card(14:19)=tabb(n,lun)( 1: 6)
163  card(23:77)=tabb(n,lun)(16:70)
164  WRITE (ldxot,'(A)') card
165  END IF
166  END DO
167 
168  WRITE (ldxot,'(A)') cardi1
169 
170 C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
171 C SEQUENCE DEFINITION SECTION.
172 
173  WRITE (ldxot,'(A)') cardi4
174 
175  card=cardi2
176  card( 3:10)='MNEMONIC'
177  card(14:21)='SEQUENCE'
178  WRITE (ldxot,'(A)') card
179 
180  card=cardi4
181  card(12:12)='|'
182  WRITE (ldxot,'(A)') card
183 
184 C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D SEQUENCE
185 C DEFINITION CARDS.
186 
187  WRITE (ldxot,'(A)') cardi2
188 
189  DO n=1,ntbd(lun)
190  IF(.NOT.tdskip(tabd(n,lun)(1:6))) THEN
191  card=cardi2
192  card( 3:10)=tabd(n,lun)( 7:14)
193  ic = 14
194 
195 C GET THE LIST OF CHILD MNEMONICS FOR THIS TABLE D DESCRIPTOR,
196 C AND THEN ADD EACH ONE (INCLUDING ANY REPLICATION TAGS) TO
197 C THE SEQUENCE DEFINITION CARD FOR THIS TABLE D DESCRIPTOR.
198 
199  CALL nemtbd(lun,n,nseq,nem(1,1),irp(1,1),krp(1,1))
200  IF(nseq.GT.0) THEN
201  DO nc=1,nseq
202  cmstr=' '
203  icms=0
204  CALL strsuc(nem(nc,1),wrk2,nch)
205  IF(irp(nc,1).NE.0) THEN
206 
207 C ADD THE OPENING REPLICATION TAG.
208 
209  icms=icms+1
210  cmstr(icms:icms)=reps(irp(nc,1),1)
211  END IF
212  cmstr(icms+1:icms+nch)=wrk2(1:nch)
213  icms=icms+nch
214  IF(irp(nc,1).NE.0) THEN
215 
216 C ADD THE CLOSING REPLICATION TAG.
217 
218  icms=icms+1
219  cmstr(icms:icms)=reps(irp(nc,1),2)
220  END IF
221  IF(krp(nc,1).NE.0) THEN
222 
223 C ADD THE FIXED REPLICATION COUNT.
224 
225  wrk1=' '
226  WRITE (wrk1,'(I3)') krp(nc,1)
227  CALL strsuc(wrk1,wrk2,nch)
228  cmstr(icms+1:icms+nch)=wrk2(1:nch)
229  icms=icms+nch
230  END IF
231 
232 C WILL THIS CHILD (AND ITS REPLICATION TAGS, IF ANY) FIT
233 C INTO THE CURRENT SEQUENCE DEFINITION CARD? IF NOT, THEN
234 C WRITE OUT (TO LDXOT) THE CURRENT CARD AND INITIALIZE A
235 C NEW ONE TO HOLD THIS CHILD.
236 
237  IF(ic.GT.(79-icms)) THEN
238  WRITE (ldxot,'(A)') card
239  card=cardi2
240  card( 3:10)=tabd(n,lun)( 7:14)
241  ic = 14
242  END IF
243  card(ic:ic+icms-1)=cmstr(1:icms)
244 
245 C NOTE THAT WE WANT TO LEAVE 2 BLANK SPACES BETWEEN EACH
246 C CHILD WITHIN THE SEQUENCE DEFINITION CARD (TO IMPROVE
247 C READABILITY).
248 
249  ic=ic+icms+2
250  END DO
251  WRITE (ldxot,'(A)') card
252  WRITE (ldxot,'(A)') cardi2
253  END IF
254  END IF
255  END DO
256 
257 C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
258 C ELEMENT DEFINITION SECTION.
259 
260  WRITE (ldxot,'(A)') cardi4
261 
262  card=cardi3
263  card( 3:10)='MNEMONIC'
264  card(14:17)='SCAL'
265  card(21:29)='REFERENCE'
266  card(35:37)='BIT'
267  card(41:45)='UNITS'
268  WRITE (ldxot,'(A)') card
269 
270  card=cardi4
271  card(12:12)='|'
272  card(19:19)='|'
273  card(33:33)='|'
274  card(39:39)='|'
275  card(66:66)='|'
276  WRITE (ldxot,'(A)') card
277 
278 C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B ELEMENT
279 C DEFINITION CARDS.
280 
281  WRITE (ldxot,'(A)') cardi3
282 
283  DO n=1,ntbb(lun)
284  IF(.NOT.tbskip(tabb(n,lun)(1:6))) THEN
285  card=cardi3
286  card( 3:10)=tabb(n,lun)( 7:14)
287  card(41:64)=tabb(n,lun)(71:94)
288 
289 C ADD THE SCALE FACTOR.
290 
291  CALL strsuc(tabb(n,lun)(96:98),wrk2,nch)
292  card(17-nch+1:17)=wrk2
293  IF(tabb(n,lun)(95:95).EQ.'-') card(17-nch:17-nch)='-'
294 
295 C ADD THE REFERENCE VALUE.
296 
297  CALL strsuc(tabb(n,lun)(100:109),wrk3,nch)
298  card(31-nch+1:31)=wrk3
299  IF(tabb(n,lun)(99:99).EQ.'-') card(31-nch:31-nch)='-'
300 
301 C ADD THE BIT WIDTH.
302 
303  CALL strsuc(tabb(n,lun)(110:112),wrk2,nch)
304  card(37-nch+1:37)=wrk2
305  WRITE (ldxot,'(A)') card
306  END IF
307  END DO
308 
309  WRITE (ldxot,'(A)') cardi3
310 
311 C CREATE AND WRITE OUT (TO LDXOT) THE CLOSING CARD.
312 
313  card=cardi4
314  card( 1: 1)='`'
315  card(80:80)=''''
316  WRITE (ldxot,'(A)') card
317 
318  RETURN
319 900 CALL bort('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'//
320  . ' OPEN')
321 
322  END
subroutine dxdump(LUNIT, LDXOT)
This subroutine prints a copy of the DX BUFR table associated with a specified Fortran logical unit...
Definition: dxdump.f:45
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
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 bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
subroutine nemtbd(LUN, ITAB, NSEQ, NEMS, IRPS, KNTS)
This subroutine returns information about a Table D descriptor from the internal DX BUFR tables...
Definition: nemtbd.f:54