makestab.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE
C>  WITHIN MODULE TABLES, USING THE INFORMATION WITHIN THE
C>  INTERNAL BUFR TABLE ARRAYS (WITHIN MODULE 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> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2017-04-03  J. ATOR    -- INCLUDE MODULE BITMAPS AND INITIALIZATION
C>                           OF NTAMC
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>
      SUBROUTINE makestab

      USE modv_bmiss
      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).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