SUBROUTINE STBFDX(LUN,MESG)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    STBFDX
C   PRGMMR: J. ATOR          ORG: NP12       DATE: 2009-03-23
C
C ABSTRACT: THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE
C   FROM THE INPUT ARRAY MESG INTO THE INTERNAL MEMORY ARRAYS IN
C   COMMON BLOCK /TABABD/.
C
C PROGRAM HISTORY LOG:
C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR, USING LOGIC COPIED
C                           FROM PREVIOUS VERSION OF RDBFDX
C
C USAGE:    CALL STBFDX (LUN,MESG)
C   INPUT ARGUMENT LIST:
C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C     MESG     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING
C                BUFR TABLE (DICTIONARY) MESSAGE
C
C REMARKS:
C    THIS ROUTINE CALLS:        BORT     CAPIT    CHRTRN   CHRTRNA
C                               GETLENS  IGETNTBI IDN30    IFXY
C                               IUPBS01  IUPM     NENUBD   NMWRD
C                               PKTDD    STNTBIA
C    THIS ROUTINE IS CALLED BY: RDBFDX   RDMEMM   READERME
C                               Normally not called by any application
C                               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,TABB1,TABB2
      CHARACTER*128 TABA
      CHARACTER*56  DXSTR
      CHARACTER*55  CSEQ
      CHARACTER*50  DXCMP
      CHARACTER*24  UNIT
      CHARACTER*8   NEMO
      CHARACTER*6   NUMB,CIDN
      CHARACTER*1   MOCT(MXMSGL)
      DIMENSION     MBAY(MXMSGLD4),LDXBD(10),LDXBE(10)

      DIMENSION     MESG(*)

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

      DATA LDXBD /38,70,8*0/
      DATA LDXBE /42,42,8*0/

C-----------------------------------------------------------------------
      JA(I) = IA+1+LDA*(I-1)
      JB(I) = IB+1+LDB*(I-1)
C-----------------------------------------------------------------------

C  MAKE A LOCAL COPY OF THE MESSAGE (SO IT CAN BE EQUIVALENCED!)
C  -------------------------------------------------------------

      DO II = 1,NMWRD(MESG)
	MBAY(II) = MESG(II)
      ENDDO

C  GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE
C  -------------------------------------------------

      IDXS = IUPBS01(MBAY,'MSBT')+1
      IF(IDXS.GT.IDXV+1) IDXS = IUPBS01(MBAY,'MTVL')+1
      IF(LDXA(IDXS).EQ.0) GOTO 901
      IF(LDXB(IDXS).EQ.0) GOTO 901
      IF(LDXD(IDXS).EQ.0) GOTO 901

      CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5)
      I3 = LEN0+LEN1+LEN2
      DXCMP = ' '
      CALL CHRTRN(DXCMP,MOCT(I3+8),NXSTR(IDXS))
      IF(DXCMP.NE.DXSTR(IDXS)) GOTO 902

C  SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D
C  --------------------------------------------------

      LDA  = LDXA (IDXS)
      LDB  = LDXB (IDXS)
      LDD  = LDXD (IDXS)
      LDBD = LDXBD(IDXS)
      LDBE = LDXBE(IDXS)
      L30  = LD30 (IDXS)

      IA = I3+LEN3+5
      LA = IUPM(MOCT(IA),8)
      IB = JA(LA+1)
      LB = IUPM(MOCT(IB),8)
      ID = JB(LB+1)
      LD = IUPM(MOCT(ID),8)

C  TABLE A
C  -------

      DO I=1,LA
        N = IGETNTBI(LUN,'A')
        CALL CHRTRNA(TABA(N,LUN),MOCT(JA(I)),LDA)
        NUMB = '   '//TABA(N,LUN)(1:3)
        NEMO = TABA(N,LUN)(4:11)
        CSEQ = TABA(N,LUN)(13:67)
        CALL STNTBIA(N,LUN,NUMB,NEMO,CSEQ)
      ENDDO

C  TABLE B
C  -------

      DO I=1,LB
        N = IGETNTBI(LUN,'B')
        CALL CHRTRNA(TABB1,MOCT(JB(I)     ),LDBD)
        CALL CHRTRNA(TABB2,MOCT(JB(I)+LDBD),LDBE)
        TABB(N,LUN) = TABB1(1:LDXBD(IDXV+1))//TABB2(1:LDXBE(IDXV+1))
        NUMB = TABB(N,LUN)(1:6)
        NEMO = TABB(N,LUN)(7:14)
        CALL NENUBD(NEMO,NUMB,LUN)
        IDNB(N,LUN) = IFXY(NUMB)
        UNIT = TABB(N,LUN)(71:94)
        CALL CAPIT(UNIT)
        TABB(N,LUN)(71:94) = UNIT
        NTBB(LUN) = N
      ENDDO

C  TABLE D
C  -------

      DO I=1,LD
        N = IGETNTBI(LUN,'D')
        CALL CHRTRNA(TABD(N,LUN),MOCT(ID+1),LDD)
        NUMB = TABD(N,LUN)(1:6)
        NEMO = TABD(N,LUN)(7:14)
        CALL NENUBD(NEMO,NUMB,LUN)
        IDND(N,LUN) = IFXY(NUMB)
        ND = IUPM(MOCT(ID+LDD+1),8)
        IF(ND.GT.MAXCD) GOTO 903
        DO J=1,ND
          NDD = ID+LDD+2 + (J-1)*L30
          CALL CHRTRNA(CIDN,MOCT(NDD),L30)
          IDN = IDN30(CIDN,L30)
          CALL PKTDD(N,LUN,IDN,IRET)
          IF(IRET.LT.0) GOTO 904
        ENDDO
        ID = ID+LDD+1 + ND*L30
        IF(IUPM(MOCT(ID+1),8).EQ.0) ID = ID+1
        NTBD(LUN) = N
      ENDDO

C  EXITS
C  -----

      RETURN
901   CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
     . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '//
     . 'KNOWN)')
902   CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
     . 'CONTENTS')
903   WRITE(BORT_STR,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '//
     . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '//
     . ' (",I4,")")') NEMO,ND,MAXCD
      CALL BORT(BORT_STR)
904   CALL BORT('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '//
     . 'PKTDD, SEE PREVIOUS WARNING MESSAGE')
      END