SUBROUTINE MAKESTAB

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    MAKESTAB
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE
C  WITHIN COMMON BLOCK /TABLES/, USING THE INFORMATION WITHIN THE
C  INTERNAL BUFR TABLE ARRAYS (WITHIN COMMON BLOCK /TABABD/) FOR ALL OF
C  THE LUN (I.E., I/O STREAM INDEX) VALUES THAT ARE CURRENTLY DEFINED TO
C  THE BUFR ARCHIVE LIBRARY SOFTWARE.  NOTE THAT THE ENTIRE JUMP/LINK
C  TABLE WILL ALWAYS BE COMPLETELY RECONSTRUCTED FROM SCRATCH, EVEN IF
C  SOME OF THE INFORMATION WITHIN THE INTERNAL BUFR TABLE ARRAYS
C  ALREADY EXISTED THERE AT THE TIME OF THE PREVIOUS CALL TO THIS
C  SUBROUTINE, BECAUSE THERE MAY HAVE BEEN OTHER EVENTS THAT HAVE TAKEN
C  PLACE SINCE THE PREVIOUS CALL TO THIS SUBROUTINE THAT HAVE NOT YET
C  BEEN REFLECTED WITHIN THE INTERNAL JUMP/LINK TABLE, SUCH AS, E.G.
C  THE UNLINKING OF AN LUN VALUE FROM THE BUFR ARCHIVE LIBRARY SOFTWARE
C  VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CLOSBF.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
C                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C                           ROUTINE "BORT"
C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C                           BUFR FILES UNDER THE MPI)
C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C                           INCREASED FROM 15000 TO 16000 (WAS IN
C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C                           WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C                           TERMINATES ABNORMALLY; NOW ALLOWS FOR THE
C                           POSSIBILITY THAT A CONNECTED FILE MAY NOT
C                           CONTAIN ANY DICTIONARY TABLE INFO (E.G.,
C                           AN EMPTY FILE), SUBSEQUENT CONNECTED FILES
C                           WHICH ARE NOT EMPTY WILL NO LONGER GET
C                           TRIPPED UP BY THIS (THIS AVOIDS THE NEED
C                           FOR AN APPLICATION PROGRAM TO DISCONNECT
C                           ANY EMPTY FILES VIA A CALL TO CLOSBF)
C 2009-03-18  J. WOOLLEN -- ADDED LOGIC TO RESPOND TO THE CASES WHERE  
C                           AN INPUT FILE'S TABLES CHANGE IN MIDSTREAM.
C                           THE NEW LOGIC MOSTLY ADDRESSES CASES WHERE
C                           OTHER FILES ARE CONNECTED TO THE TABLES OF
C                           THE FILE WHOSE TABLES HAVE CHANGED.
C 2009-06-25  J. ATOR    -- TWEAK WOOLLEN LOGIC TO HANDLE SPECIAL CASE
C                           WHERE TABLE WAS RE-READ FOR A PARTICULAR
C                           LOGICAL UNIT BUT IS STILL THE SAME ACTUAL
C                           TABLE AS BEFORE AND IS STILL SHARING THAT
C                           TABLE WITH A DIFFERENT LOGICAL UNIT
C 2009-11-17  J. ATOR    -- ADDED CHECK TO PREVENT WRITING OUT OF TABLE
C                           INFORMATION WHEN A TABLE HAS BEEN RE-READ
C                           WITHIN A SHARED LOGICAL UNIT BUT HASN'T
C                           REALLY CHANGED
C
C USAGE:    CALL MAKESTAB
C
C REMARKS:
C    THIS ROUTINE CALLS:        BORT     CHEKSTAB CLOSMG   CPBFDX
C                               ERRWRT   ICMPDX   ISHRDX   STRCLN
C                               TABSUB   WRDXTB
C    THIS ROUTINE IS CALLED BY: RDBFDX   RDMEMM   RDUSDX   READDX
C                               READERME READS3
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 /QUIET/  IPRT
      COMMON /STBFR/  IOLUN(NFILES),IOMSG(NFILES)
      COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
      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 /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
     .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
     .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
     .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
     .                ISEQ(MAXJL,2),JSEQ(MAXJL)
      COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
     .                ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV
      COMMON /LUSHR/  LUS(NFILES)

      CHARACTER*600 TABD
      CHARACTER*128 TABB
      CHARACTER*128 TABA
      CHARACTER*128 BORT_STR,ERRSTR
      CHARACTER*10  TAG
      CHARACTER*8   NEMO,TAGNRV
      CHARACTER*3   TYP
      LOGICAL       EXPAND,XTAB(NFILES)
      REAL*8        VAL

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

C  RESET POINTER TABLE AND STRING CACHE
C  ------------------------------------

      NTAB = 0
      NNRV = 0
      CALL STRCLN

C  FIGURE OUT WHICH UNITS SHARE TABLES
C  -----------------------------------

C     The LUS array is static between calls to this subroutine, and it
C     keeps track of which logical units share dictionary table
C     information:
C        if LUS(I) = 0, then IOLUN(I) does not share dictionary table
C                       information with any other logical unit
C        if LUS(I) > 0, then IOLUN(I) shares dictionary table
C                       information with logical unit IOLUN(LUS(I))
C        if LUS(I) < 0, then IOLUN(I) does not now, but at one point in
C                       the past, shared dictionary table information
C                       with logical unit IOLUN(ABS(LUS(I)))

C     The XTAB array is non-static and is recomputed within the below
C     loop during each call to this subroutine:
C        if XTAB(I) = .TRUE., then the dictionary table information
C                             has changed for IOLUN(I) since the last
C                             call to this subroutine
C        if XTAB(I) = .FALSE., then the dictionary table information
C                              has not changed for IOLUN(I) since the
C                              last call to this subroutine

      DO LUN=1,NFILES
        XTAB(LUN) = .FALSE.
        IF(IOLUN(LUN).EQ.0) THEN

C          Logical unit IOLUN(LUN) is not defined to the BUFRLIB.

           LUS(LUN) = 0
        ELSE IF(MTAB(1,LUN).EQ.0) THEN

C          New dictionary table information has been read for logical
C          unit IOLUN(LUN) since the last call to this subroutine.

           XTAB(LUN) = .TRUE.
           IF(LUS(LUN).NE.0) THEN
             IF(IOLUN(ABS(LUS(LUN))).EQ.0) THEN
               LUS(LUN) = 0
             ELSE IF(LUS(LUN).GT.0) THEN

C              IOLUN(LUN) was sharing table information with logical
C              unit IOLUN(LUS(LUN)), so check whether the table
C              information has really changed.  If not, then IOLUN(LUN)
C              just re-read a copy of the exact same table information
C              as before, and therefore it can continue to share with
C              logical unit IOLUN(LUS(LUN)).

               IF(ICMPDX(LUS(LUN),LUN).EQ.1) THEN
                 XTAB(LUN) = .FALSE. 
                 CALL CPBFDX(LUS(LUN),LUN)
               ELSE
                 LUS(LUN) = (-1)*LUS(LUN)
               ENDIF
             ELSE IF(ICMPDX(ABS(LUS(LUN)),LUN).EQ.1) THEN

C              IOLUN(LUN) was not sharing table information with logical
C              unit IOLUN(LUS(LUN)), but it did at one point in the past
C              and now once again has the same table information as that
C              logical unit.  Since the two units shared table
C              information at one point in the past, allow them to do
C              so again.

               XTAB(LUN) = .FALSE. 
               LUS(LUN) = ABS(LUS(LUN))
               CALL CPBFDX(LUS(LUN),LUN)
             ENDIF
           ENDIF
        ELSE IF(LUS(LUN).GT.0) THEN

C          Logical unit IOLUN(LUN) is sharing table information with
C          logical unit IOLUN(LUS(LUN)), so make sure that the latter
C          unit is still defined to the BUFRLIB.

           IF(IOLUN(LUS(LUN)).EQ.0) THEN
             LUS(LUN) = 0
           ELSE IF( XTAB(LUS(LUN)) .AND.
     +             (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN 

C            The table information for logical unit IOLUN(LUS(LUN))
C            just changed (in midstream).  If IOLUN(LUN) is an output
C            file, then we will have to update it with the new table
C            information later on in this subroutine.  Otherwise,
C            IOLUN(LUN) is an input file and is no longer sharing
C            tables with IOLUN(LUS(LUN)).

             IF(IOLUN(LUN).LT.0) LUS(LUN) = (-1)*LUS(LUN)
           ENDIF
        ELSE

C          Determine whether logical unit IOLUN(LUN) is sharing table
C          information with any other logical units.

           LUM = 1
           DO WHILE ((LUM.LT.LUN).AND.(LUS(LUN).EQ.0))
              IF(ISHRDX(LUM,LUN).EQ.1) THEN
                 LUS(LUN) = LUM
              ELSE
                 LUM = LUM+1
              ENDIF
           ENDDO
        ENDIF
      ENDDO

C  INITIALIZE JUMP/LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS
C  -----------------------------------------------------------

      DO LUN=1,NFILES

       IF(IOLUN(LUN).NE.0 .AND. NTBA(LUN).GT.0) THEN

C        Reset any existing inventory pointers.

         IF(IOMSG(LUN).NE.0) THEN
            IF(LUS(LUN).EQ.0) THEN
              INC = (NTAB+1)-MTAB(1,LUN)
            ELSE
              INC = MTAB(1,LUS(LUN))-MTAB(1,LUN)
            ENDIF
            DO N=1,NVAL(LUN)
              INV(N,LUN) = INV(N,LUN)+INC
            ENDDO
         ENDIF

         IF(LUS(LUN).LE.0) THEN   

C           The dictionary table information corresponding to logical
C           unit IOLUN(LUN) has not yet been written into the internal
C           jump/link table, so add it in now.

            CALL CHEKSTAB(LUN)  
            DO ITBA=1,NTBA(LUN) 
              INOD = NTAB+1
              NEMO = TABA(ITBA,LUN)(4:11)
              CALL TABSUB(LUN,NEMO)
              MTAB(ITBA,LUN) = INOD
              ISC(INOD)      = NTAB
            ENDDO
         ELSE IF( XTAB(LUS(LUN)) .AND.
     +           (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN 

C           Logical unit IOLUN(LUN) is an output file that is sharing
C           table information with logical unit IOLUN(LUS(LUN)) whose
C           table just changed (in midstream).  Flush any existing data
C           messages from IOLUN(LUN), then update the table information
C           for this logical unit with the corresponding new table
C           information from IOLUN(LUS(LUN)), then update IOLUN(LUN)
C           itself with a copy of the new table information.

            LUNIT = ABS(IOLUN(LUN))
            IF(IOMSG(LUN).NE.0) CALL CLOSMG(LUNIT)    
            CALL CPBFDX(LUS(LUN),LUN)
            LUNDX = ABS(IOLUN(LUS(LUN)))
            CALL WRDXTB(LUNDX,LUNIT) 
         ENDIF

       ENDIF

      ENDDO

C  STORE TYPES AND INITIAL VALUES AND COUNTS
C  -----------------------------------------

      DO NODE=1,NTAB
      IF(TYP(NODE).EQ.'SUB') THEN
         VALI(NODE) = 0
         KNTI(NODE) = 1
         ITP (NODE) = 0
      ELSEIF(TYP(NODE).EQ.'SEQ') THEN
         VALI(NODE) = 0
         KNTI(NODE) = 1
         ITP (NODE) = 0
      ELSEIF(TYP(NODE).EQ.'RPC') THEN
         VALI(NODE) = 0
         KNTI(NODE) = 0
         ITP (NODE) = 0
      ELSEIF(TYP(NODE).EQ.'RPS') THEN
         VALI(NODE) = 0
         KNTI(NODE) = 0
         ITP (NODE) = 0
      ELSEIF(TYP(NODE).EQ.'REP') THEN
         VALI(NODE) = BMISS
         KNTI(NODE) = IRF(NODE)
         ITP (NODE) = 0
      ELSEIF(TYP(NODE).EQ.'DRS') THEN
         VALI(NODE) = 0
         KNTI(NODE) = 1
         ITP (NODE) = 1
      ELSEIF(TYP(NODE).EQ.'DRP') THEN
         VALI(NODE) = 0
         KNTI(NODE) = 1
         ITP (NODE) = 1
      ELSEIF(TYP(NODE).EQ.'DRB') THEN
         VALI(NODE) = 0
         KNTI(NODE) = 0
         ITP (NODE) = 1
      ELSEIF(TYP(NODE).EQ.'NUM') THEN
         VALI(NODE) = BMISS
         KNTI(NODE) = 1
         ITP (NODE) = 2
      ELSEIF(TYP(NODE).EQ.'CHR') THEN
         VALI(NODE) = BMISS
         KNTI(NODE) = 1
         ITP (NODE) = 3
      ELSE
         GOTO 901
      ENDIF
      ENDDO

C  SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES
C  ----------------------------------------------------------------

      NEWN = 0

      DO N=1,NTAB
      ISEQ(N,1) = 0
      ISEQ(N,2) = 0
      EXPAND = TYP(N).EQ.'SUB' .OR. TYP(N).EQ.'DRP' .OR. TYP(N).EQ.'DRS'
     .                         .OR. TYP(N).EQ.'REP' .OR. TYP(N).EQ.'DRB'
      IF(EXPAND) THEN
         ISEQ(N,1) = NEWN+1
         NODA = N
         NODE = N+1
         DO K=1,MAXJL
         KNT(K) = 0
         ENDDO
         IF(TYP(NODA).EQ.'REP') KNT(NODE) = KNTI(NODA)
         IF(TYP(NODA).NE.'REP') KNT(NODE) = 1

1        NEWN = NEWN+1
         IF(NEWN.GT.MAXJL) GOTO 902
         JSEQ(NEWN) = NODE
         KNT(NODE) = MAX(KNTI(NODE),KNT(NODE))
2        IF(JUMP(NODE)*KNT(NODE).GT.0) THEN
            NODE = JUMP(NODE)
            GOTO 1
         ELSE IF(LINK(NODE).GT.0) THEN
            NODE = LINK(NODE)
            GOTO 1
         ELSE
            NODE = JMPB(NODE)
            IF(NODE.EQ.NODA) GOTO 3
            IF(NODE.EQ.0   ) GOTO 903
            KNT(NODE) = MAX(KNT(NODE)-1,0)
            GOTO 2
         ENDIF
3        ISEQ(N,2) = NEWN
      ENDIF
      ENDDO

C  PRINT THE SEQUENCE TABLES
C  ------------------------

      IF(IPRT.GE.2) THEN
      CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
         DO I=1,NTAB
           WRITE ( UNIT=ERRSTR, FMT='(A,I5,2X,A10,A5,6I8)' )
     .      'BUFRLIB: MAKESTAB ', I, TAG(I), TYP(I), JMPB(I), JUMP(I),
     .      LINK(I), IBT(I), IRF(I), ISC(I)
           CALL ERRWRT(ERRSTR)
         ENDDO
      CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL ERRWRT(' ')
      ENDIF

C  EXITS
C  -----

      RETURN
900   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - MNEMONIC ",A," IS '//
     . 'DUPLICATED IN SUBSET: ",A)') NEMO,TAG(N1)
      CALL BORT(BORT_STR)
901   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - UNKNOWN TYPE ",A)')TYP(NODE)
      CALL BORT(BORT_STR)
902   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN'//
     . ' JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') MAXJL
      CALL BORT(BORT_STR)
903   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO '//
     . 'CIRCULATE (TAG IS ",A,")")') TAG(N)
      CALL BORT(BORT_STR)
      END