C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE MAKESTAB COMMON /QUIET/ IPRT COMMON /STBFR/ IOLUN(32),IOMSG(32) COMMON /MSGCWD/ NMSG(32),NSUB(32),MSUB(32),INODE(32),IDATE(32) COMMON /USRINT/ NVAL(32),INV(15000,32),VAL(15000,32) COMMON /TABABD/ NTBA(0:32),NTBB(0:32),NTBD(0:32),MTAB(50,32), . IDNA(50,32,2),IDNB(250,32),IDND(250,32), . TABA(50,32),TABB(250,32),TABD(250,32) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*10 TAG CHARACTER*8 NEMO CHARACTER*3 TYP DIMENSION LUS(32) LOGICAL EXPAND,PRTTAB REAL*8 VAL,BMISS DATA PRTTAB /.FALSE./ DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- PRTTAB = IPRT.GE.2 C RESET POINTER TABLE AND STRING CACHE C ------------------------------------ NTAB = 0 CALL STRCLN C FIGURE OUT WHICH UNITS SHARE TABLES C ----------------------------------- DO LUN=1,32 LUS(LUN) = 0 IF(IOLUN(LUN).NE.0) THEN DO LUM=1,LUN-1 IF(MTAB(1,LUN).EQ.MTAB(1,LUM)) LUS(LUN) = LUM ENDDO ENDIF ENDDO C INITIALIZE JUMP-LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS C ---------------------------------------------------------- DO LUN=1,32 IF(IOLUN(LUN).NE.0) THEN C RESET ANY EXISTING INVENTORY POINTERS C ------------------------------------- IF(IOMSG(LUN).NE.0) THEN IF(LUS(LUN).EQ.0) INC = (NTAB+1)-MTAB(1,LUN) IF(LUS(LUN).NE.0) INC = MTAB(1,LUS(LUN))-MTAB(1,LUN) DO N=1,NVAL(LUN) INV(N,LUN) = INV(N,LUN)+INC ENDDO ENDIF C CREATE NEW TABLE ENTRIES IF THIS UNIT DOESN'T SHARE EXISTING ONES C ----------------------------------------------------------------- IF(LUS(LUN).EQ.0) THEN 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 C DO N1=INOD,ISC(INOD)-1 C DO N2=N1+1,ISC(INOD) C IF(TAG(N1).EQ.TAG(N2)) GOTO 900 C ENDDO C ENDDO ENDDO 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,15000 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.15000) 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(PRTTAB) THEN PRINT* DO I=1,NTAB PRINT99,I, . TAG(I),TYP(I),JMPB(I),JUMP(I),LINK(I),IBT(I),IRF(I),ISC(I) ENDDO PRINT* 99 FORMAT(I5,2X,A10,A5,6I8) ENDIF RETURN 900 CALL BORT('MAKESTAB - DUP IN SUBSET: '//TAG(N1)//':'//NEMO) 901 CALL BORT('MAKESTAB - UNKNOWN TYPE : ' //TYP(NODE)) 902 CALL BORT('MAKESTAB - JSEQ OVERFLOW : ' //TAG(N )) 903 CALL BORT('MAKESTAB - FAILED TO CIRCULATE : ' //TAG(N )) END