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