var/external/bufr/dxdump.f

   1       SUBROUTINE DXDUMP(LUNIT,LDXOT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    DXDUMP
   6 C   PRGMMR: ATOR             ORG: NP12       DATE: 2004-08-18
   7 C
   8 C ABSTRACT: THIS SUBROUTINE WRITES, TO LOGICAL UNIT LDXOT, AN ASCII
   9 C   COPY OF THE BUFR DICTIONARY TABLE INFORMATION ASSOCIATED WITH
  10 C   THE BUFR FILE DEFINED BY LOGICAL UNIT LUNIT.  IT IS ESPECIALLY
  11 C   USEFUL FOR DETERMINING THE CONTENTS OF ARCHIVE BUFR FILES WHICH
  12 C   MAY HAVE SUCH INFORMATION EMBEDDED AS DX MESSAGES AT THE FRONT
  13 C   OF THE FILE.  THE OUTPUT FILE WILL BE IN A FORMAT SUITABLE FOR
  14 C   SUBSEQUENT INPUT AS A USER-DEFINED DICTIONARY TABLES FILE TO
  15 C   BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND IN THAT SENSE THIS
  16 C   SUBROUTINE CAN BE VIEWED AS THE LOGICAL INVERSE OF BUFR ARCHIVE
  17 C   LIBRARY SUBROUTINE RDUSDX.  NOTE THAT THE BUFR FILE ASSOCIATED
  18 C   WITH LOGICAL UNIT LUNIT MUST HAVE ALREADY BEEN IDENTIFIED TO
  19 C   THE BUFR ARCHIVE LIBRARY SOFTWARE VIA A PRIOR CALL TO OPENBF.
  20 C
  21 C PROGRAM HISTORY LOG:
  22 C 2004-08-18  J. ATOR    -- ORIGINAL AUTHOR
  23 C 2007-01-19  J. ATOR    -- CORRECTED OUTPUT FOR REFERENCE VALUES
  24 C                           LONGER THAN 8 DIGITS
  25 C
  26 C USAGE:    CALL DXDUMP (LUNIT, LDXOT)
  27 C   INPUT ARGUMENT LIST:
  28 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  29 C     LDXOT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT FILE
  30 C
  31 C   INPUT FILES:
  32 C     UNIT "LUNIT" - BUFR FILE WITH EMBEDDED DX DICTIONARY MESSAGES
  33 C
  34 C   OUTPUT FILES:
  35 C     UNIT "LDXOT" - ASCII VERSION OF DX DICTIONARY INFORMATION, IN
  36 C                    FORMAT SUITABLE FOR SUBSEQUENT INPUT TO OPENBF
  37 C
  38 C REMARKS:
  39 C    THIS ROUTINE CALLS:        BORT     NEMTBD   STATUS   STRSUC
  40 C    THIS ROUTINE IS CALLED BY: None
  41 C                               Normally called only by application
  42 C                               programs.
  43 C
  44 C ATTRIBUTES:
  45 C   LANGUAGE: FORTRAN 77
  46 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  47 C
  48 C$$$
  49
  50       INCLUDE 'bufrlib.prm'
  51
  52       COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5)
  53       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  54      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  55      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
  56      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
  57      .                TABD(MAXTBD,NFILES)
  58
  59       CHARACTER*600 TABD
  60       CHARACTER*128 TABB
  61       CHARACTER*128 TABA
  62       CHARACTER*80  CARD,CARDI1,CARDI2,CARDI3,CARDI4
  63       CHARACTER*20  CMSTR
  64       CHARACTER*10  WRK3
  65       CHARACTER*8   NEMS(MAXCD),WRK1,WRK2
  66       CHARACTER*6   ADN
  67       CHARACTER*3   TYPS
  68       CHARACTER*1   REPS
  69
  70       DIMENSION     IRPS(MAXCD),KNTS(MAXCD)
  71
  72       LOGICAL       TBSKIP, TDSKIP, XTRCI1
  73
  74       DATA          CARDI1( 1:40)
  75      .              /'|          |        |                   '/
  76       DATA          CARDI1(41:80)
  77      .              /'                                       |'/
  78       DATA          CARDI2( 1:40)
  79      .              /'|          |                            '/
  80       DATA          CARDI2(41:80)
  81      .              /'                                       |'/
  82       DATA          CARDI3( 1:40)
  83      .              /'|          |      |             |     | '/
  84       DATA          CARDI3(41:80)
  85      .              /'                         |-------------|'/
  86       DATA          CARDI4( 1:40)
  87      .              /'|---------------------------------------'/
  88       DATA          CARDI4(41:80)
  89      .              /'---------------------------------------|'/
  90
  91 C-----------------------------------------------------------------------
  92       TBSKIP(ADN) = ((ADN.EQ.'063000').OR.(ADN.EQ.'063255').OR.
  93      .               (ADN.EQ.'031000').OR.(ADN.EQ.'031001').OR.
  94      .               (ADN.EQ.'031002'))
  95       TDSKIP(ADN) = ((ADN.EQ.'360001').OR.(ADN.EQ.'360002').OR.
  96      .               (ADN.EQ.'360003').OR.(ADN.EQ.'360004'))
  97 C-----------------------------------------------------------------------
  98
  99 C     DETERMINE LUN FROM LUNIT.
 100
 101       CALL STATUS(LUNIT,LUN,IL,IM)
 102       IF(IL.EQ.0) GOTO 900
 103
 104 C     CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
 105 C     DESCRIPTOR DEFINITION SECTION.
 106
 107       CARD=CARDI4
 108       CARD( 1: 1)='.'
 109       CARD(80:80)='.'
 110       WRITE (LDXOT,'(A)') CARD
 111
 112       CARD=CARDI4
 113       CARD( 2: 2)=' '
 114       CARD(79:79)=' '
 115       CARD(15:64)='   USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D   '
 116       WRITE (LDXOT,'(A)') CARD
 117
 118       WRITE (LDXOT,'(A)') CARDI4
 119
 120       CARD=CARDI1
 121       CARD( 3:10)='MNEMONIC'
 122       CARD(14:19)='NUMBER'
 123       CARD(23:33)='DESCRIPTION'
 124       WRITE (LDXOT,'(A)') CARD
 125
 126       CARD=CARDI4
 127       CARD(12:12)='|'
 128       CARD(21:21)='|'
 129       WRITE (LDXOT,'(A)') CARD
 130
 131 C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE D DESCRIPTOR
 132 C     DEFINITION CARDS.
 133
 134       WRITE (LDXOT,'(A)') CARDI1
 135
 136       XTRCI1=.FALSE.
 137       DO N=1,NTBD(LUN)
 138         IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN
 139           CARD=CARDI1
 140           CARD( 3:10)=TABD(N,LUN)( 7:14)
 141           CARD(14:19)=TABD(N,LUN)( 1: 6)
 142           CARD(23:77)=TABD(N,LUN)(16:70)
 143
 144 C         CHECK IF THIS TABLE D MNEMONIC IS ALSO A TABLE A MNEMONIC.
 145 C         IF SO, THEN LABEL IT AS SUCH AND ALSO CHECK IF IT IS THE
 146 C         LAST OF THE TABLE A MNEMONICS, IN WHICH CASE AN EXTRA
 147 C         CARDI1 LINE WILL BE WRITTEN TO LDXOT IN ORDER TO SEPARATE
 148 C         THE TABLE A MNEMONICS FROM THE OTHER TABLE D MNEMONICS.
 149
 150           DO NA=1,NTBA(LUN)
 151             IF(TABA(NA,LUN)(4:11).EQ.TABD(N,LUN)(7:14)) THEN
 152               CARD(14:14)='A'
 153               IF(NA.EQ.NTBA(LUN)) XTRCI1=.TRUE.
 154               GOTO 10
 155             END IF
 156           END DO
 157    10     WRITE (LDXOT,'(A)') CARD
 158           IF(XTRCI1) THEN
 159             WRITE (LDXOT,'(A)') CARDI1
 160             XTRCI1=.FALSE.
 161           END IF
 162         END IF
 163       END DO
 164
 165 C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE B DESCRIPTOR
 166 C     DEFINITION CARDS.
 167
 168       WRITE (LDXOT,'(A)') CARDI1
 169
 170       DO N=1,NTBB(LUN)
 171         IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN
 172           CARD=CARDI1
 173           CARD( 3:10)=TABB(N,LUN)( 7:14)
 174           CARD(14:19)=TABB(N,LUN)( 1: 6)
 175           CARD(23:77)=TABB(N,LUN)(16:70)
 176           WRITE (LDXOT,'(A)') CARD
 177         END IF
 178       END DO
 179
 180       WRITE (LDXOT,'(A)') CARDI1
 181
 182 C     CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
 183 C     SEQUENCE DEFINITION SECTION.
 184
 185       WRITE (LDXOT,'(A)') CARDI4
 186
 187       CARD=CARDI2
 188       CARD( 3:10)='MNEMONIC'
 189       CARD(14:21)='SEQUENCE'
 190       WRITE (LDXOT,'(A)') CARD
 191
 192       CARD=CARDI4
 193       CARD(12:12)='|'
 194       WRITE (LDXOT,'(A)') CARD
 195
 196 C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE D SEQUENCE
 197 C     DEFINITION CARDS.
 198
 199       WRITE (LDXOT,'(A)') CARDI2
 200
 201       DO N=1,NTBD(LUN)
 202         IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN
 203           CARD=CARDI2
 204           CARD( 3:10)=TABD(N,LUN)( 7:14)
 205           IC = 14
 206
 207 C         GET THE LIST OF CHILD MNEMONICS FOR THIS TABLE D DESCRIPTOR,
 208 C         AND THEN ADD EACH ONE (INCLUDING ANY REPLICATION TAGS) TO
 209 C         THE SEQUENCE DEFINITION CARD FOR THIS TABLE D DESCRIPTOR.
 210
 211           CALL NEMTBD(LUN,N,NSEQ,NEMS,IRPS,KNTS)
 212           IF(NSEQ.GT.0) THEN
 213             DO NC=1,NSEQ
 214               CMSTR=' '
 215               ICMS=0
 216               CALL STRSUC(NEMS(NC),WRK2,NCH)
 217               IF(IRPS(NC).NE.0) THEN
 218
 219 C               ADD THE OPENING REPLICATION TAG.
 220
 221                 ICMS=ICMS+1
 222                 CMSTR(ICMS:ICMS)=REPS(IRPS(NC),1)
 223               END IF
 224               CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH)
 225               ICMS=ICMS+NCH
 226               IF(IRPS(NC).NE.0) THEN
 227
 228 C               ADD THE CLOSING REPLICATION TAG.
 229
 230                 ICMS=ICMS+1
 231                 CMSTR(ICMS:ICMS)=REPS(IRPS(NC),2)
 232               END IF
 233               IF(KNTS(NC).NE.0) THEN
 234
 235 C               ADD THE FIXED REPLICATION COUNT.
 236
 237                 WRK1=' '
 238                 WRITE (WRK1,'(I3)') KNTS(NC)
 239                 CALL STRSUC(WRK1,WRK2,NCH)
 240                 CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH)
 241                 ICMS=ICMS+NCH
 242               END IF
 243
 244 C             WILL THIS CHILD (AND ITS REPLICATION TAGS, IF ANY) FIT
 245 C             INTO THE CURRENT SEQUENCE DEFINITION CARD?  IF NOT, THEN
 246 C             WRITE OUT (TO LDXOT) THE CURRENT CARD AND INITIALIZE A
 247 C             NEW ONE TO HOLD THIS CHILD.
 248
 249               IF(IC.GT.(79-ICMS)) THEN
 250                 WRITE (LDXOT,'(A)') CARD
 251                 CARD=CARDI2
 252                 CARD( 3:10)=TABD(N,LUN)( 7:14)
 253                 IC = 14
 254               END IF
 255               CARD(IC:IC+ICMS-1)=CMSTR(1:ICMS)
 256
 257 C             NOTE THAT WE WANT TO LEAVE 2 BLANK SPACES BETWEEN EACH
 258 C             CHILD WITHIN THE SEQUENCE DEFINITION CARD (TO IMPROVE
 259 C             READABILITY).
 260
 261               IC=IC+ICMS+2
 262             END DO
 263             WRITE (LDXOT,'(A)') CARD
 264             WRITE (LDXOT,'(A)') CARDI2
 265           END IF
 266         END IF
 267       END DO
 268
 269 C     CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
 270 C     ELEMENT DEFINITION SECTION.
 271
 272       WRITE (LDXOT,'(A)') CARDI4
 273
 274       CARD=CARDI3
 275       CARD( 3:10)='MNEMONIC'
 276       CARD(14:17)='SCAL'
 277       CARD(21:29)='REFERENCE'
 278       CARD(35:37)='BIT'
 279       CARD(41:45)='UNITS'
 280       WRITE (LDXOT,'(A)') CARD
 281
 282       CARD=CARDI4
 283       CARD(12:12)='|'
 284       CARD(19:19)='|'
 285       CARD(33:33)='|'
 286       CARD(39:39)='|'
 287       CARD(66:66)='|'
 288       WRITE (LDXOT,'(A)') CARD
 289
 290 C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE B ELEMENT
 291 C     DEFINITION CARDS.
 292
 293       WRITE (LDXOT,'(A)') CARDI3
 294
 295       DO N=1,NTBB(LUN)
 296         IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN
 297           CARD=CARDI3
 298           CARD( 3:10)=TABB(N,LUN)( 7:14)
 299           CARD(41:64)=TABB(N,LUN)(71:94)
 300
 301 C         ADD THE SCALE FACTOR.
 302
 303           CALL STRSUC(TABB(N,LUN)(96:98),WRK2,NCH)
 304           CARD(17-NCH+1:17)=WRK2
 305           IF(TABB(N,LUN)(95:95).EQ.'-') CARD(17-NCH:17-NCH)='-'
 306
 307 C         ADD THE REFERENCE VALUE.
 308
 309           CALL STRSUC(TABB(N,LUN)(100:109),WRK3,NCH)
 310           CARD(31-NCH+1:31)=WRK3
 311           IF(TABB(N,LUN)(99:99).EQ.'-') CARD(31-NCH:31-NCH)='-'
 312
 313 C         ADD THE BIT WIDTH.
 314
 315           CALL STRSUC(TABB(N,LUN)(110:112),WRK2,NCH)
 316           CARD(37-NCH+1:37)=WRK2
 317           WRITE (LDXOT,'(A)') CARD
 318         END IF
 319       END DO
 320
 321       WRITE (LDXOT,'(A)') CARDI3
 322
 323 C     CREATE AND WRITE OUT (TO LDXOT) THE CLOSING CARD.
 324
 325       CARD=CARDI4
 326       CARD( 1: 1)='`'
 327       CARD(80:80)=''''
 328       WRITE (LDXOT,'(A)') CARD
 329
 330       RETURN
 331 900   CALL BORT('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'//
 332      . ' OPEN')
 333
 334       END