makestab.f

Go to the documentation of this file.

C> @file
C> @brief Build the internal jump/link table.
C>
C> @author J. Woollen @date 1994-01-06
 
C> This subroutine constructs the internal jump/link table within
C> module tables, using all of the internal BUFR table array information
C> from module @ref moda_tababd for all of the internal I/O streams that are
C> currently defined to the library in module @ref moda_stbfr.
C>
C> The entire jump/link table will always be completely reconstructed
C> from scratch, even if some of the information within the internal
C> BUFR table arrays already existed there at the time of the previous
C> call to this subroutine, because there may have been other events
C> that have taken place since the previous call to this subroutine and
C> which haven't yet been reflected within the internal jump/link table.
C> For example, an I/O stream may have recently been unlinked from the
C> library via an internal call to subroutine closbf(), or the DX BUFR
C> tables associated with an I/O stream may have changed.
C>
C> @author J. Woollen @date 1994-01-06
 
      SUBROUTINE makestab
 
      USE modv_bmiss
      USE modv_maxjl
      USE modv_nfiles
 
      USE moda_usrint
      USE moda_stbfr
      USE moda_lushr
      USE moda_xtab
      USE moda_tababd
      USE moda_tables
      USE moda_nrv203
      USE moda_bitmaps
 
      COMMON /quiet/  iprt
 
      CHARACTER*128 BORT_STR,ERRSTR
      CHARACTER*8   NEMO
      LOGICAL       EXPAND
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  RESET POINTER TABLE AND STRING CACHE
C  ------------------------------------
 
      ntab = 0
      nnrv = 0
      ntamc = 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).LE.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
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