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   MODULE TABABD.
C
C PROGRAM HISTORY LOG:
C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR, USING LOGIC COPIED
C                           FROM PREVIOUS VERSION OF RDBFDX
C 2014-11-14  J. ATOR    -- REPLACE CHRTRNA CALLS WITH UPC CALLS
C 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
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    GETLENS  IGETNTBI
C                               IDN30    IFXY     IUPB     IUPBS01
C                               NENUBD   PKTDD    STNTBIA  UPC
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$$$

      USE MODV_MAXCD
      USE MODA_TABABD

      INCLUDE 'bufrlib.prm'

      COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10),
     .                LD30(10),DXSTR(10)

      CHARACTER*128 BORT_STR
      CHARACTER*128 TABB1,TABB2
      CHARACTER*56  DXSTR
      CHARACTER*55  CSEQ
      CHARACTER*50  DXCMP
      CHARACTER*24  UNIT
      CHARACTER*8   NEMO
      CHARACTER*6   NUMB,CIDN
      DIMENSION     LDXBD(10),LDXBE(10)

      DIMENSION     MESG(*)

      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  GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE
C  -------------------------------------------------

      IDXS = IUPBS01(MESG,'MSBT')+1
      IF(IDXS.GT.IDXV+1) IDXS = IUPBS01(MESG,'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(MESG,3,LEN0,LEN1,LEN2,LEN3,L4,L5)
      I3 = LEN0+LEN1+LEN2
      DXCMP = ' '
      JBIT = 8*(I3+7)
      CALL UPC(DXCMP,NXSTR(IDXS),MESG,JBIT,.FALSE.)
      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 = IUPB(MESG,IA,8)
      IB = JA(LA+1)
      LB = IUPB(MESG,IB,8)
      ID = JB(LB+1)
      LD = IUPB(MESG,ID,8)

C  TABLE A
C  -------

      DO I=1,LA
        N = IGETNTBI(LUN,'A')
        JBIT = 8*(JA(I)-1)
        CALL UPC(TABA(N,LUN),LDA,MESG,JBIT,.TRUE.)
        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')
        JBIT = 8*(JB(I)-1)
        CALL UPC(TABB1,LDBD,MESG,JBIT,.TRUE.)
        JBIT = 8*(JB(I)+LDBD-1)
        CALL UPC(TABB2,LDBE,MESG,JBIT,.TRUE.)
        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')
        JBIT = 8*ID
        CALL UPC(TABD(N,LUN),LDD,MESG,JBIT,.TRUE.)
        NUMB = TABD(N,LUN)(1:6)
        NEMO = TABD(N,LUN)(7:14)
        CALL NENUBD(NEMO,NUMB,LUN)
        IDND(N,LUN) = IFXY(NUMB)
        ND = IUPB(MESG,ID+LDD+1,8)
        IF(ND.GT.MAXCD) GOTO 903
        DO J=1,ND
          NDD = ID+LDD+2 + (J-1)*L30
          JBIT = 8*(NDD-1)
          CALL UPC(CIDN,L30,MESG,JBIT,.TRUE.)
          IDN = IDN30(CIDN,L30)
          CALL PKTDD(N,LUN,IDN,IRET)
          IF(IRET.LT.0) GOTO 904
        ENDDO
        ID = ID+LDD+1 + ND*L30
        IF(IUPB(MESG,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