SUBROUTINE DXDUMP(LUNIT,LDXOT)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: DXDUMP
C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18
C
C ABSTRACT: THIS SUBROUTINE WRITES, TO LOGICAL UNIT LDXOT, AN ASCII
C COPY OF THE BUFR DICTIONARY TABLE INFORMATION ASSOCIATED WITH
C THE BUFR FILE DEFINED BY LOGICAL UNIT LUNIT. IT IS ESPECIALLY
C USEFUL FOR DETERMINING THE CONTENTS OF ARCHIVE BUFR FILES WHICH
C MAY HAVE SUCH INFORMATION EMBEDDED AS DX MESSAGES AT THE FRONT
C OF THE FILE. THE OUTPUT FILE WILL BE IN A FORMAT SUITABLE FOR
C SUBSEQUENT INPUT AS A USER-DEFINED DICTIONARY TABLES FILE TO
C BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND IN THAT SENSE THIS
C SUBROUTINE CAN BE VIEWED AS THE LOGICAL INVERSE OF BUFR ARCHIVE
C LIBRARY SUBROUTINE RDUSDX. NOTE THAT THE BUFR FILE ASSOCIATED
C WITH LOGICAL UNIT LUNIT MUST HAVE ALREADY BEEN IDENTIFIED TO
C THE BUFR ARCHIVE LIBRARY SOFTWARE VIA A PRIOR CALL TO OPENBF.
C
C PROGRAM HISTORY LOG:
C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR
C 2007-01-19 J. ATOR -- CORRECTED OUTPUT FOR REFERENCE VALUES
C LONGER THAN 8 DIGITS
C
C USAGE: CALL DXDUMP (LUNIT, LDXOT)
C INPUT ARGUMENT LIST:
C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C LDXOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT FILE
C
C INPUT FILES:
C UNIT "LUNIT" - BUFR FILE WITH EMBEDDED DX DICTIONARY MESSAGES
C
C OUTPUT FILES:
C UNIT "LDXOT" - ASCII VERSION OF DX DICTIONARY INFORMATION, IN
C FORMAT SUITABLE FOR SUBSEQUENT INPUT TO OPENBF
C
C REMARKS:
C THIS ROUTINE CALLS: BORT NEMTBD STATUS STRSUC
C THIS ROUTINE IS CALLED BY: None
C Normally called only by application
C programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5)
COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
. MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
. IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
. TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
. TABD(MAXTBD,NFILES)
CHARACTER*600 TABD
CHARACTER*128 TABB
CHARACTER*128 TABA
CHARACTER*80 CARD,CARDI1,CARDI2,CARDI3,CARDI4
CHARACTER*20 CMSTR
CHARACTER*10 WRK3
CHARACTER*8 NEMS(MAXCD),WRK1,WRK2
CHARACTER*6 ADN
CHARACTER*3 TYPS
CHARACTER*1 REPS
DIMENSION IRPS(MAXCD),KNTS(MAXCD)
LOGICAL TBSKIP, TDSKIP, XTRCI1
DATA CARDI1( 1:40)
. /'| | | '/
DATA CARDI1(41:80)
. /' |'/
DATA CARDI2( 1:40)
. /'| | '/
DATA CARDI2(41:80)
. /' |'/
DATA CARDI3( 1:40)
. /'| | | | | '/
DATA CARDI3(41:80)
. /' |-------------|'/
DATA CARDI4( 1:40)
. /'|---------------------------------------'/
DATA CARDI4(41:80)
. /'---------------------------------------|'/
C-----------------------------------------------------------------------
TBSKIP(ADN) = ((ADN.EQ.'063000').OR.(ADN.EQ.'063255').OR.
. (ADN.EQ.'031000').OR.(ADN.EQ.'031001').OR.
. (ADN.EQ.'031002'))
TDSKIP(ADN) = ((ADN.EQ.'360001').OR.(ADN.EQ.'360002').OR.
. (ADN.EQ.'360003').OR.(ADN.EQ.'360004'))
C-----------------------------------------------------------------------
C DETERMINE LUN FROM LUNIT.
CALL STATUS(LUNIT,LUN,IL,IM)
IF(IL.EQ.0) GOTO 900
C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
C DESCRIPTOR DEFINITION SECTION.
CARD=CARDI4
CARD( 1: 1)='.'
CARD(80:80)='.'
WRITE (LDXOT,'(A)') CARD
CARD=CARDI4
CARD( 2: 2)=' '
CARD(79:79)=' '
CARD(15:64)=' USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D '
WRITE (LDXOT,'(A)') CARD
WRITE (LDXOT,'(A)') CARDI4
CARD=CARDI1
CARD( 3:10)='MNEMONIC'
CARD(14:19)='NUMBER'
CARD(23:33)='DESCRIPTION'
WRITE (LDXOT,'(A)') CARD
CARD=CARDI4
CARD(12:12)='|'
CARD(21:21)='|'
WRITE (LDXOT,'(A)') CARD
C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D DESCRIPTOR
C DEFINITION CARDS.
WRITE (LDXOT,'(A)') CARDI1
XTRCI1=.FALSE.
DO N=1,NTBD(LUN)
IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN
CARD=CARDI1
CARD( 3:10)=TABD(N,LUN)( 7:14)
CARD(14:19)=TABD(N,LUN)( 1: 6)
CARD(23:77)=TABD(N,LUN)(16:70)
C CHECK IF THIS TABLE D MNEMONIC IS ALSO A TABLE A MNEMONIC.
C IF SO, THEN LABEL IT AS SUCH AND ALSO CHECK IF IT IS THE
C LAST OF THE TABLE A MNEMONICS, IN WHICH CASE AN EXTRA
C CARDI1 LINE WILL BE WRITTEN TO LDXOT IN ORDER TO SEPARATE
C THE TABLE A MNEMONICS FROM THE OTHER TABLE D MNEMONICS.
DO NA=1,NTBA(LUN)
IF(TABA(NA,LUN)(4:11).EQ.TABD(N,LUN)(7:14)) THEN
CARD(14:14)='A'
IF(NA.EQ.NTBA(LUN)) XTRCI1=.TRUE.
GOTO 10
END IF
END DO
10 WRITE (LDXOT,'(A)') CARD
IF(XTRCI1) THEN
WRITE (LDXOT,'(A)') CARDI1
XTRCI1=.FALSE.
END IF
END IF
END DO
C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B DESCRIPTOR
C DEFINITION CARDS.
WRITE (LDXOT,'(A)') CARDI1
DO N=1,NTBB(LUN)
IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN
CARD=CARDI1
CARD( 3:10)=TABB(N,LUN)( 7:14)
CARD(14:19)=TABB(N,LUN)( 1: 6)
CARD(23:77)=TABB(N,LUN)(16:70)
WRITE (LDXOT,'(A)') CARD
END IF
END DO
WRITE (LDXOT,'(A)') CARDI1
C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
C SEQUENCE DEFINITION SECTION.
WRITE (LDXOT,'(A)') CARDI4
CARD=CARDI2
CARD( 3:10)='MNEMONIC'
CARD(14:21)='SEQUENCE'
WRITE (LDXOT,'(A)') CARD
CARD=CARDI4
CARD(12:12)='|'
WRITE (LDXOT,'(A)') CARD
C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D SEQUENCE
C DEFINITION CARDS.
WRITE (LDXOT,'(A)') CARDI2
DO N=1,NTBD(LUN)
IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN
CARD=CARDI2
CARD( 3:10)=TABD(N,LUN)( 7:14)
IC = 14
C GET THE LIST OF CHILD MNEMONICS FOR THIS TABLE D DESCRIPTOR,
C AND THEN ADD EACH ONE (INCLUDING ANY REPLICATION TAGS) TO
C THE SEQUENCE DEFINITION CARD FOR THIS TABLE D DESCRIPTOR.
CALL NEMTBD(LUN,N,NSEQ,NEMS,IRPS,KNTS)
IF(NSEQ.GT.0) THEN
DO NC=1,NSEQ
CMSTR=' '
ICMS=0
CALL STRSUC(NEMS(NC),WRK2,NCH)
IF(IRPS(NC).NE.0) THEN
C ADD THE OPENING REPLICATION TAG.
ICMS=ICMS+1
CMSTR(ICMS:ICMS)=REPS(IRPS(NC),1)
END IF
CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH)
ICMS=ICMS+NCH
IF(IRPS(NC).NE.0) THEN
C ADD THE CLOSING REPLICATION TAG.
ICMS=ICMS+1
CMSTR(ICMS:ICMS)=REPS(IRPS(NC),2)
END IF
IF(KNTS(NC).NE.0) THEN
C ADD THE FIXED REPLICATION COUNT.
WRK1=' '
WRITE (WRK1,'(I3)') KNTS(NC)
CALL STRSUC(WRK1,WRK2,NCH)
CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH)
ICMS=ICMS+NCH
END IF
C WILL THIS CHILD (AND ITS REPLICATION TAGS, IF ANY) FIT
C INTO THE CURRENT SEQUENCE DEFINITION CARD? IF NOT, THEN
C WRITE OUT (TO LDXOT) THE CURRENT CARD AND INITIALIZE A
C NEW ONE TO HOLD THIS CHILD.
IF(IC.GT.(79-ICMS)) THEN
WRITE (LDXOT,'(A)') CARD
CARD=CARDI2
CARD( 3:10)=TABD(N,LUN)( 7:14)
IC = 14
END IF
CARD(IC:IC+ICMS-1)=CMSTR(1:ICMS)
C NOTE THAT WE WANT TO LEAVE 2 BLANK SPACES BETWEEN EACH
C CHILD WITHIN THE SEQUENCE DEFINITION CARD (TO IMPROVE
C READABILITY).
IC=IC+ICMS+2
END DO
WRITE (LDXOT,'(A)') CARD
WRITE (LDXOT,'(A)') CARDI2
END IF
END IF
END DO
C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
C ELEMENT DEFINITION SECTION.
WRITE (LDXOT,'(A)') CARDI4
CARD=CARDI3
CARD( 3:10)='MNEMONIC'
CARD(14:17)='SCAL'
CARD(21:29)='REFERENCE'
CARD(35:37)='BIT'
CARD(41:45)='UNITS'
WRITE (LDXOT,'(A)') CARD
CARD=CARDI4
CARD(12:12)='|'
CARD(19:19)='|'
CARD(33:33)='|'
CARD(39:39)='|'
CARD(66:66)='|'
WRITE (LDXOT,'(A)') CARD
C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B ELEMENT
C DEFINITION CARDS.
WRITE (LDXOT,'(A)') CARDI3
DO N=1,NTBB(LUN)
IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN
CARD=CARDI3
CARD( 3:10)=TABB(N,LUN)( 7:14)
CARD(41:64)=TABB(N,LUN)(71:94)
C ADD THE SCALE FACTOR.
CALL STRSUC(TABB(N,LUN)(96:98),WRK2,NCH)
CARD(17-NCH+1:17)=WRK2
IF(TABB(N,LUN)(95:95).EQ.'-') CARD(17-NCH:17-NCH)='-'
C ADD THE REFERENCE VALUE.
CALL STRSUC(TABB(N,LUN)(100:109),WRK3,NCH)
CARD(31-NCH+1:31)=WRK3
IF(TABB(N,LUN)(99:99).EQ.'-') CARD(31-NCH:31-NCH)='-'
C ADD THE BIT WIDTH.
CALL STRSUC(TABB(N,LUN)(110:112),WRK2,NCH)
CARD(37-NCH+1:37)=WRK2
WRITE (LDXOT,'(A)') CARD
END IF
END DO
WRITE (LDXOT,'(A)') CARDI3
C CREATE AND WRITE OUT (TO LDXOT) THE CLOSING CARD.
CARD=CARDI4
CARD( 1: 1)='`'
CARD(80:80)=''''
WRITE (LDXOT,'(A)') CARD
RETURN
900 CALL BORT('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'//
. ' OPEN')
END