50 COMMON /reptab/ idnr(5,2),typs(5,2),reps(5,2),lens(5)
52 CHARACTER*80 card,cardi1,cardi2,cardi3,cardi4
60 LOGICAL tbskip, tdskip, xtrci1
73 . /
' |-------------|'/
75 . /
'|---------------------------------------'/
77 . /
'---------------------------------------|'/
80 tbskip(adn) = ((adn.EQ.
'063000').OR.(adn.EQ.
'063255').OR.
81 . (adn.EQ.
'031000').OR.(adn.EQ.
'031001').OR.
83 tdskip(adn) = ((adn.EQ.
'360001').OR.(adn.EQ.
'360002').OR.
84 . (adn.EQ.
'360003').OR.(adn.EQ.
'360004'))
89 CALL
status(lunit,lun,il,im)
98 WRITE (ldxot,
'(A)') card
103 card(15:64)=
' USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D '
104 WRITE (ldxot,
'(A)') card
106 WRITE (ldxot,
'(A)') cardi4
109 card( 3:10)=
'MNEMONIC'
111 card(23:33)=
'DESCRIPTION'
112 WRITE (ldxot,
'(A)') card
117 WRITE (ldxot,
'(A)') card
122 WRITE (ldxot,
'(A)') cardi1
126 IF(.NOT.tdskip(tabd(n,lun)(1:6)))
THEN
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)
139 IF(taba(na,lun)(4:11).EQ.tabd(n,lun)(7:14))
THEN
141 IF(na.EQ.ntba(lun)) xtrci1=.true.
145 10
WRITE (ldxot,
'(A)') card
147 WRITE (ldxot,
'(A)') cardi1
156 WRITE (ldxot,
'(A)') cardi1
159 IF(.NOT.tbskip(tabb(n,lun)(1:6)))
THEN
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
168 WRITE (ldxot,
'(A)') cardi1
173 WRITE (ldxot,
'(A)') cardi4
176 card( 3:10)=
'MNEMONIC'
177 card(14:21)=
'SEQUENCE'
178 WRITE (ldxot,
'(A)') card
182 WRITE (ldxot,
'(A)') card
187 WRITE (ldxot,
'(A)') cardi2
190 IF(.NOT.tdskip(tabd(n,lun)(1:6)))
THEN
192 card( 3:10)=tabd(n,lun)( 7:14)
199 CALL
nemtbd(lun,n,nseq,nem(1,1),irp(1,1),krp(1,1))
204 CALL
strsuc(nem(nc,1),wrk2,nch)
205 IF(irp(nc,1).NE.0)
THEN
210 cmstr(icms:icms)=reps(irp(nc,1),1)
212 cmstr(icms+1:icms+nch)=wrk2(1:nch)
214 IF(irp(nc,1).NE.0)
THEN
219 cmstr(icms:icms)=reps(irp(nc,1),2)
221 IF(krp(nc,1).NE.0)
THEN
226 WRITE (wrk1,
'(I3)') krp(nc,1)
227 CALL
strsuc(wrk1,wrk2,nch)
228 cmstr(icms+1:icms+nch)=wrk2(1:nch)
237 IF(ic.GT.(79-icms))
THEN
238 WRITE (ldxot,
'(A)') card
240 card( 3:10)=tabd(n,lun)( 7:14)
243 card(ic:ic+icms-1)=cmstr(1:icms)
251 WRITE (ldxot,
'(A)') card
252 WRITE (ldxot,
'(A)') cardi2
260 WRITE (ldxot,
'(A)') cardi4
263 card( 3:10)=
'MNEMONIC'
265 card(21:29)=
'REFERENCE'
268 WRITE (ldxot,
'(A)') card
276 WRITE (ldxot,
'(A)') card
281 WRITE (ldxot,
'(A)') cardi3
284 IF(.NOT.tbskip(tabb(n,lun)(1:6)))
THEN
286 card( 3:10)=tabb(n,lun)( 7:14)
287 card(41:64)=tabb(n,lun)(71:94)
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)=
'-'
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)=
'-'
303 CALL
strsuc(tabb(n,lun)(110:112),wrk2,nch)
304 card(37-nch+1:37)=wrk2
305 WRITE (ldxot,
'(A)') card
309 WRITE (ldxot,
'(A)') cardi3
316 WRITE (ldxot,
'(A)') card
319 900 CALL
bort(
'BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'//
subroutine dxdump(LUNIT, LDXOT)
This subroutine prints a copy of the DX BUFR table associated with a specified Fortran logical unit...
subroutine strsuc(STR1, STR2, LENS)
This subroutine removes leading and trailing blanks from a character string.
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
subroutine nemtbd(LUN, ITAB, NSEQ, NEMS, IRPS, KNTS)
This subroutine returns information about a Table D descriptor from the internal DX BUFR tables...