SUBROUTINE WRDXTB(LUNDX,LUNOT)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    WRDXTB
C   PRGMMR: J. ATOR          ORG: NP12       DATE: 2009-03-23
C
C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES
C   ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE BUFR FILE IN LUNOT.
C   BOTH UNITS MUST BE OPENED VIA PREVIOUS CALLS TO BUFR ARCHIVE
C   LIBRARY SUBROUTINE OPENBF, AND IN PARTICULAR LUNOT MUST HAVE
C   BEEN OPENED FOR OUTPUT.  THE TABLE MESSAGES ARE GENERATED FROM
C   ARRAYS IN INTERNAL MEMORY (COMMON BLOCK /TABABD/).  LUNDX CAN BE
C   THE SAME AS LUNOT IF IT IS DESIRED TO APPEND TO LUNOT WITH BUFR
C   MESSAGES GENERATED FROM ITS OWN INTERNAL TABLES.
C
C PROGRAM HISTORY LOG:
C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR, USING LOGIC FROM WRITDX
C 2012-04-06  J. ATOR    -- PREVENT STORING OF MORE THAN 255 TABLE A,
C                           TABLE B OR TABLE D DESCRIPTORS IN ANY
C                           SINGLE DX MESSAGE
C
C USAGE:    CALL WRDXTB (LUNDX,LUNOT)
C   INPUT ARGUMENT LIST:
C     LUNDX    - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED
C                WITH DX (DICTIONARY) TABLES TO BE WRITTEN OUT;
C                CAN BE SAME AS LUNOT
C     LUNOT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C                TO BE APPENDED WITH TABLES ASSOCIATED WITH LUNDX
C
C REMARKS:
C    THIS ROUTINE CALLS:        ADN30    BORT     CPBFDX   DXMINI
C                               GETLENS  IPKM     IUPM     MSGFULL
C                               MSGWRT   PKB      PKC      STATUS
C    THIS ROUTINE IS CALLED BY: MAKESTAB WRITDX
C                               Also called by application programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

      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)
      COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10),
     .                LD30(10),DXSTR(10)

      CHARACTER*600 TABD
      CHARACTER*128 BORT_STR
      CHARACTER*128 TABB
      CHARACTER*128 TABA
      CHARACTER*56  DXSTR
      CHARACTER*6   ADN30
      CHARACTER*1   MOCT(MXMSGL)

      LOGICAL MSGFULL

      DIMENSION     MBAY(MXMSGLD4)

      EQUIVALENCE   (MOCT(1),MBAY(1))

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C  CHECK FILE STATUSES
C  -------------------

      CALL STATUS(LUNOT,LOT,IL,IM)
      IF(IL.EQ.0) GOTO 900
      IF(IL.LT.0) GOTO 901

      CALL STATUS(LUNDX,LDX,IL,IM)
      IF(IL.EQ.0) GOTO 902

C  IF FILES ARE DIFFERENT, COPY INTERNAL TABLE
C  INFORMATION FROM LUNDX TO LUNOT
C  -------------------------------------------

      IF(LUNDX.NE.LUNOT) CALL CPBFDX(LDX,LOT)

C  GENERATE AND WRITE OUT BUFR DICTIONARY MESSAGES TO LUNOT
C  --------------------------------------------------------

      CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)

      LDA = LDXA(IDXV+1)
      LDB = LDXB(IDXV+1)
      LDD = LDXD(IDXV+1)
      L30 = LD30(IDXV+1)

C     Table A information

      DO I=1,NTBA(LOT)
      IF(MSGFULL(MBYT,LDA,MAXDX).OR.
     +    (IUPM(MOCT(MBYA),8).EQ.255)) THEN
         CALL MSGWRT(LUNOT,MBAY,MBYT)
         CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
      ENDIF
      CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDA)
      CALL IPKM(MOCT(MBYA),1,IUPM(MOCT(MBYA), 8)+  1)
      MBIT = 8*(MBYB-1)
      CALL PKC(TABA(I,LOT),LDA,MBAY,MBIT)
      CALL PKB(          0,  8,MBAY,MBIT)
      CALL PKB(          0,  8,MBAY,MBIT)
      MBYT = MBYT+LDA
      MBYB = MBYB+LDA
      MBYD = MBYD+LDA
      ENDDO

C     Table B information

      DO I=1,NTBB(LOT)
      IF(MSGFULL(MBYT,LDB,MAXDX).OR.
     +    (IUPM(MOCT(MBYB),8).EQ.255)) THEN
         CALL MSGWRT(LUNOT,MBAY,MBYT)
         CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
      ENDIF
      CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDB)
      CALL IPKM(MOCT(MBYB),1,IUPM(MOCT(MBYB), 8)+  1)
      MBIT = 8*(MBYD-1)
      CALL PKC(TABB(I,LOT),LDB,MBAY,MBIT)
      CALL PKB(          0,  8,MBAY,MBIT)
      MBYT = MBYT+LDB
      MBYD = MBYD+LDB
      ENDDO

C     Table D information

      DO I=1,NTBD(LOT)
      NSEQ = IUPM(TABD(I,LOT)(LDD+1:LDD+1),8)
      LEND = LDD+1 + L30*NSEQ
      IF(MSGFULL(MBYT,LEND,MAXDX).OR.
     +    (IUPM(MOCT(MBYD),8).EQ.255)) THEN
         CALL MSGWRT(LUNOT,MBAY,MBYT)
         CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
      ENDIF
      CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LEND)
      CALL IPKM(MOCT(MBYD),1,IUPM(MOCT(MBYD), 8)+   1)
      MBIT = 8*(MBYT-4)
      CALL PKC(TABD(I,LOT),LDD,MBAY,MBIT)
      CALL PKB(       NSEQ,  8,MBAY,MBIT)
         DO J=1,NSEQ
         JJ  = LDD+2 + (J-1)*2
         IDN = IUPM(TABD(I,LOT)(JJ:JJ),16)
         CALL PKC(ADN30(IDN,L30),L30,MBAY,MBIT)
         ENDDO
      MBYT = MBYT+LEND
      ENDDO

C     Write the unwritten (leftover) message.

      CALL MSGWRT(LUNOT,MBAY,MBYT)

C     Write out one additional (dummy) DX message containing zero
C     subsets.  This will serve as a delimiter for this set of
C     table messages within output unit LUNOT, just in case the
C     next thing written to LUNOT ends up being another set of
C     table messages.

      CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
      CALL GETLENS(MBAY,2,LEN0,LEN1,LEN2,L3,L4,L5)
      MBIT = (LEN0+LEN1+LEN2+4)*8
      CALL PKB(0,16,MBAY,MBIT)
      CALL MSGWRT(LUNOT,MBAY,MBYT)

C  EXITS
C  -----

      RETURN
900   CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR OUTPUT')
901   CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR '//
     . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
902   CALL BORT('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT '//
     . 'MUST BE OPEN')
      END