C 2-PAGE WSHEET SUBROUTINE WSSET C WORK SHEET MANAGMENT ROUTINES C HANDLE SPREADSHEET "IN MEMORY" STORAGE C COPYRIGHT GLENN EVERHART 1983 C C ALL RIGHTS RESERVED C C WSSET - INITIALIZE STORAGE TO START CONDITIONS INCLUDE 'VKLUGPRM.FTN' C EXPECT IMPLEMENTATION TO USE A COMMON BITMAP AND PROVIDE A VARIABLE C NCEL TO TELL HOW MANY CELLS ARE IN USE C NEXT BITMAPS IMPLEMENT FVLD PARAMETER CUP=1 LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 LBITS(8) COMMON/BITS/LBITS INTEGER*2 IPGMAX,LPGMXF COMMON/FILEMX/IPGMAX,LPGMXF C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF C USE LUN 7 FOR FORMULAS, 9 FOR VALUES FILE IF NEEDED... COMMON/FVLDM/FV1,FV2,FV4 C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR C TYPES OF AC'S STORAGE: INTEGER*2 DLFG COMMON/DLFG/DLFG LOGICAL*1 ITYP(BRRCL) INTEGER*2 IATYP(27),LINTGR COMMON/TYP/IATYP,ITYP,LINTGR C C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT C AREAS WITH DATA. LOGICAL*1 FMTDAT(9,45) COMMON/FMTBFR/FMTDAT LOGICAL*1 DVF(12),DFMT(10) EQUIVALENCE(DVF(2),DFMT(1)) COMMON/DEFVBX/DVF INTEGER*2 LVALBF(5,LVBF),MPAG(2),MPMOD DIMENSION MPMOD(2),MFMOD(2) COMMON/VB/MPAG,LVALBF,MPMOD INTEGER*2 MFID(2),IFID(8,LFM),MFMOD LOGICAL*1 LFID(16,LFM) EQUIVALENCE(IFID(1,1),LFID(1,1)) COMMON/FRM/MFID,IFID,MFMOD INTEGER*2 MFLAST,MFBASE,MVLAST,MVBASE COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE C COMMON /NCEL/NCEL,NXINI IBP=1 LINTGR=0 MPMOD(1)=0 MFMOD(1)=0 MPMOD(2)=0 MFMOD(2)=0 DLFG=0 C FLAG DLFG=0 ==> NO D## FORMS YET DO 2 N=1,9 2 FMTDAT(N,1)=DFMT(N) DO 3 N=2,45 DO 3 NN=1,9 3 FMTDAT(NN,N)=0 DO 1 N=1,8 LBITS(N)=128/IBP 1 IBP=IBP+IBP DO 4 N=1,BRRCL C CLEAR BITMAPS NOW FV1(N)=0 FV2(N)=0 FV4(N)=0 4 ITYP(N)=0 C OPEN THE WORK FILES SO WE DON'T NEED TO LATER... C LUN 7 IS FORMULAS; LUN 9 IS VALUES C HOWEVER, IF IPGMAX IS LESS THAN LVBF/205 (INDICATING ENTIRE FILE C FITS IN MEMORY) DON'T OPEN LUN 9 AND IF LPGMXF IS < LFM/64, LIKEWISE C FOR LUN 7. C INITIALLY CLOSE FILES IN CASE THEY WERE OPEN... CLOSE(UNIT=7,DISP='DELETE') CLOSE(UNIT=9,DISP='DELETE') C NOW OPEN THEM AS RANDOM ACCESS FILES. NBK=IPGMAX*2 C KEEP VALUE PAGES IN 500 BYTE UNITS, NOT 512 BYTE UNITS, TO COME C OUT EVEN... IF(IPGMAX.GT.(LVBF/100))OPEN(UNIT=9,FILE='PVBL.TMP', 1 ACCESS='DIRECT',DISPOSE='DELETE',FORM='UNFORMATTED', 2 INITIALSIZE=NBK,BLOCKSIZE=500,RECORDTYPE='FIXED', 3 RECL=125,STATUS='NEW') NBK=LPGMXF*2 IF(LPGMXF.GT.(LFM/64))OPEN(UNIT=7,FILE='PFMT.TMP', 1 ACCESS='DIRECT',DISPOSE='DELETE',FORM='UNFORMATTED', 2 INITIALSIZE=NBK,BLOCKSIZE=512,RECORDTYPE='FIXED', 3 RECL=128,STATUS='NEW') C SET NOTHING IN MEMORY YET MFID(1)=0 MPAG(1)=0 MFID(2)=0 MPAG(2)=0 MFLAST=1 MFBASE=0 MVLAST=1 MVBASE=0 C MARK BUFFER 1 AS LAST ONE BUT BOTH REALLY EMPTY AT START C ZERO MEMORY BUFFER AND FILES C SET TO -1 SO WE CAN RECOGNIZE VIRGIN CELLS DO 9 N=1,LVBF DO 9 M=1,5 9 LVALBF(M,N)=-1 NPG=(IPGMAX*2) IF(IPGMAX.LE.(LVBF/100))GOTO 11 DO 10 N=1,NPG 10 WRITE(9'N)((LVALBF(K,KKK),K=1,5),KKK=1,50) 11 CONTINUE C AGAIN FLAG VIRGIN CELLS WITH ID OF -1 DO 12 N=1,LFM DO 12 M=1,8 12 IFID(M,N)=-1 NPG=LPGMXF*2 IF(LPGMXF.LE.(LFM/64))GOTO 14 DO 13 N=1,NPG 13 WRITE(7'N)((IFID(K,KKK),K=1,8),KKK=1,32) 14 CONTINUE C SET ALL AC'S TO TYPE FLOATING... DO 8 N=1,27 8 IATYP(N)=2 C TYPE 2 IS REALS (DEFAULT) NCEL=0 NXINI=0 RETURN END C SUBROUTINE FVPEEK(ID1,ID2,IGO) C PEEK INTO FV1 THRU FV4 INDICES TO FIND COMPUTABLE CELLS. REQUIRES C FV4 BIT OFF, FV1 OR F2 BIT ON (OR BOTH). DESIGNED AS WAY FOR C RECALC TO CHEAT AND SKIP QUICKLY BY CELLS NOT IN MAP. IGO GETS C START INDEX FOR ID1 WITHIN RANGE OF ID1 FROM 1 TO RRW C INCLUDE 'VKLUGPRM.FTN' LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 LBITS(8) COMMON/BITS/LBITS COMMON/FVLDM/FV1,FV2,FV4 IGO=ID1 C DEFAULT IS ID1 IS GIVEN TO IGO. C ID=(ID2-1)*RRW+ID1 IRRR=ID2*RRW ID=IRRR-RRW+ID1 IBYT=((ID-1)/8)+1 IRRR=((IRRR-1)/8)+1 C IGO MUST NEVER GET BIGGER THAN RRW DO 1 N=IBYT,IRRR III=N IF(FV1(N).NE.0.OR.FV2(N).NE.0)GOTO 2 C SKIP BY UNLESS FV1 OR FV2 BITS ARE SET. ALLOW LABELS BY HERE SINCE C THIS IS A CRUDE TEST FOR MOSTLY TOTALLY UNINITIALIZED CELLS. 1 CONTINUE C ON FALL THROUGH WE LEAVE III AT MAX TO SKIP THIS AREA 2 CONTINUE N=((III-1)*8)+1 C COMPUTE FIRST CELL OF BITMAP BLK WE FOUND, RETURN IT AS NEW INDEX C UNLESS ALREADY PAST IT... N=N-RRW*(ID2-1) C NOTE WE PICK RRW IF N IS BIGGER SINCE WE CHECK ON AN INNER LOOP ONLY. IF(N.GT.IGO)IGO=MIN0(N,RRW) RETURN END SUBROUTINE TYPGET(ID1,ID2,IVAL) C C TYPGET - GET TYPE(RRW,RCL) ARRAY WORDS BACK C RETURN TYPE(ID1,ID2) IN IVAL, BUT NOT REALLY... INCLUDE 'VKLUGPRM.FTN' C NEXT BITMAPS IMPLEMENT FVLD LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 LBITS(8) COMMON/BITS/LBITS COMMON/FVLDM/FV1,FV2,FV4 C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR C TYPES OF AC'S STORAGE: LOGICAL*1 ITYP(BRRCL) INTEGER*2 IATYP(27),IVAL,LINTGR COMMON/TYP/IATYP,ITYP,LINTGR C C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT C AREAS WITH DATA. LOGICAL*1 FMTDAT(9,45) COMMON/FMTBFR/FMTDAT LOGICAL*1 ITST IF(ID1.LE.27.AND.ID2.LE.1)GOTO 1000 IVAL=2 IF(LINTGR.EQ.0)RETURN CALL FVLDGT(ID1,ID2,ITST) IF(ITST.EQ.0)GOTO 500 ID=(ID2-1)*RRW+ID1 IBT=(ID-1)/8 IBIT=((ID-1).AND.7)+1 ITST=ITYP(IBT).AND.LBITS(IBIT) 500 IVAL=2 IF(ITST.NE.0)IVAL=4 RETURN 1000 CONTINUE C AN AC. RETURN FULL TYPE WORD IVAL=IATYP(ID1) RETURN END SUBROUTINE TYPSET(ID1,ID2,IVAL) C C TYPSET - STORE IVAL IN TYPE(RRW,RCL) ARRAY INCLUDE 'VKLUGPRM.FTN' C NEXT BITMAPS IMPLEMENT FVLD INTEGER*2 IVAL LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 LBITS(8) COMMON/BITS/LBITS COMMON/FVLDM/FV1,FV2,FV4 C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR C TYPES OF AC'S STORAGE: LOGICAL*1 ITYP(BRRCL) INTEGER*2 IATYP(27),LINTGR COMMON/TYP/IATYP,ITYP,LINTGR C C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT C AREAS WITH DATA. LOGICAL*1 FMTDAT(9,45) COMMON/FMTBFR/FMTDAT LOGICAL*1 ITST,ITST2 IF(ID2.LE.1.AND.ID1.LE.27)GOTO 200 C SKIPPED THE AC'S HERE. RETURN INSTANTLY IF NO INTEGER C CELLS HAVE BEEN DEFINED (WHICH WILL BE MOST OF THE TIME) IF(LINTGR.EQ.0.AND.IABS(IVAL).EQ.2)RETURN LINTGR=1 ID=(ID2-1)*RRW+ID1 IBT=(ID-1)/8 IBIT=((ID-1).AND.7)+1 ITST2=.NOT.LBITS(IBIT) ITST2=ITYP(IBT).AND.ITST2 ITST=ITYP(IBT).OR.LBITS(IBIT) ITYP(IBT)=ITST2 IF(IVAL.NE.-2.AND.IVAL.NE.2)ITYP(IBT)=ITST RETURN 200 CONTINUE IATYP(ID1)=IVAL RETURN END SUBROUTINE FVLDGT(ID1,ID2,IVAL) C C FVLDGT - RETURN FVLD BYTE GIVEN 2 DIMS OF ITS "LOCATION" INTEGER*2 ID1,ID2 LOGICAL*1 IVAL INCLUDE 'VKLUGPRM.FTN' C NEXT BITMAPS IMPLEMENT FVLD LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 LBITS(8) COMMON/BITS/LBITS COMMON/FVLDM/FV1,FV2,FV4 C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR C TYPES OF AC'S STORAGE: LOGICAL*1 ITYP(BRRCL) INTEGER*2 IATYP(27) COMMON/TYP/IATYP,ITYP C C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT C AREAS WITH DATA. LOGICAL*1 FMTDAT(9,45) COMMON/FMTBFR/FMTDAT LOGICAL*1 I1,I2,I4 IF(ID2.GT.0)GOTO 2000 C TRICK ENTRY USING ID IN FIRST ARG, 0 IN 2ND ARG... C TELL XVBLST/XVBLGT ABOUT FV4 STATE (SET BY CALL WITH -4 BYTE ON FVLDST) ID=ID1 IBT=((ID-1)/8)+1 IBIT=((ID-1).AND.7)+1 I1=FV1(IBT).AND.LBITS(IBIT) I2=FV2(IBT).AND.LBITS(IBIT) I4=FV4(IBT).AND.LBITS(IBIT) IVAL=0 C RETURN NONZERO IF ANY BITS ARE SET. IF((I1+I2+I4).NE.0)IVAL=1 RETURN 2000 CONTINUE ID=(ID2-1)*RRW+ID1 IBT=((ID-1)/8)+1 IBIT=((ID-1).AND.7)+1 I1=FV1(IBT).AND.LBITS(IBIT) I2=FV2(IBT).AND.LBITS(IBIT) I4=FV4(IBT).AND.LBITS(IBIT) IVL=0 IF(I1.NE.0)IVL=1 IF(I2.NE.0)IVL=IVL+2 IF(I4.NE.0)IVL=-IVL IVAL=IVL C READS OFF FVLD BYTE FROM 3 BITS, HIGH ONE IS SIGN. TREAT AS SIGN- C MAGNITUDE NUMBER IN RANGE -3 TO +3, RETURN END SUBROUTINE FVLDST(ID1,ID2,IVAL) C C FVLDST - SET THE BYTE IN FVLD ARRAY INCLUDE 'VKLUGPRM.FTN' C NEXT BITMAPS IMPLEMENT FVLD LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 IVAL LOGICAL*1 LBITS(8) COMMON/BITS/LBITS COMMON/FVLDM/FV1,FV2,FV4 C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR C TYPES OF AC'S STORAGE: LOGICAL*1 ITYP(BRRCL) INTEGER*2 IATYP(27) COMMON/TYP/IATYP,ITYP C C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT C AREAS WITH DATA. LOGICAL*1 FMTDAT(9,45) INTEGER*2 IVV,I1,I2,I3 COMMON/FMTBFR/FMTDAT C LOGICAL*1 I4 ID=(ID2-1)*RRW+ID1 IBT=((ID-1)/8)+1 IBIT=((ID-1).AND.7)+1 C ZERO ALL 3 FVLD BITS FIRST FV1(IBT)=FV1(IBT).AND..NOT.LBITS(IBIT) FV2(IBT)=FV2(IBT).AND..NOT.LBITS(IBIT) FV4(IBT)=FV4(IBT).AND..NOT.LBITS(IBIT) IVVV=IVAL IVV=IABS(IVVV) I3=0 IF(IVAL.LT.0)I3=1 I1=0 I2=0 I2=IVV.AND.2 I1=IVV.AND.1 C NOTE WE ASSUME HEAVILY THAT LOGICAL OPERATIONS WORK BY BINARY C ANDS AND ORS IN DATA. IF(I1.NE.0)FV1(IBT)=FV1(IBT).OR.LBITS(IBIT) IF(I2.NE.0)FV2(IBT)=FV2(IBT).OR.LBITS(IBIT) IF(I3.NE.0)FV4(IBT)=FV4(IBT).OR.LBITS(IBIT) RETURN END SUBROUTINE VBLGET(ID1,ID2,ID3,IVAL) C C VBLGET - GET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY C DIMENSIONED (8,RRW,RCL). HANDLE BY CALLING XVBLGT TO GET C CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE INTEGER*2 ID1,ID2,ID3 LOGICAL*1 IVAL,LL(8) REAL*8 XX EQUIVALENCE(LL(1),XX) CALL XVBLGT(ID2,ID3,XX) IVAL=LL(ID1) RETURN END SUBROUTINE VBLSET(ID1,ID2,ID3,IVAL) C VBLSET - SET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY C DIMENSIONED (8,RRW,RCL). HANDLE BY CALLING XVBLST TO GET C CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE INTEGER*2 ID1,ID2,ID3 LOGICAL*1 IVAL,LL(8) REAL*8 XX EQUIVALENCE(LL(1),XX) C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONE WE WANT. THEN... CALL XVBLGT(ID2,ID3,XX) LL(ID1)=IVAL C PUT BACK THE 8 BYTES. CALL XVBLST(ID2,ID3,XX) RETURN END SUBROUTINE JVBLGT(ID1,ID2,ID3,IVAL) C C JVBLGT - GET INTEGER*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY C DIMENSIONED (2,RRW,RCL). HANDLE BY CALLING XVBLGT TO GET C CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE INTEGER*2 ID1,ID2,ID3 INTEGER*4 IVAL,LL(2) REAL*8 XX EQUIVALENCE(LL(1),XX) CALL XVBLGT(ID2,ID3,XX) IVAL=LL(ID1) RETURN END SUBROUTINE JVBLST(ID1,ID2,ID3,IVAL) C JVBLST - SET I*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY C DIMENSIONED (2,RRW,RCL). HANDLE BY CALLING XVBLST TO GET C CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE INTEGER*2 ID1,ID2,ID3 INTEGER*4 IVAL,LL(2) REAL*8 XX EQUIVALENCE(LL(1),XX) C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONES WE WANT. THEN... CALL XVBLGT(ID2,ID3,XX) LL(ID1)=IVAL C PUT BACK THE 8 BYTES. CALL XVBLST(ID2,ID3,XX) RETURN END SUBROUTINE XVBLST(ID1,ID2,XX) C C XVBLST - STORE 8 BYTES IN VARIABLES ARRAY C GIVEN DIMENSIONS FOR LOCATING THEM INTEGER*2 ID1,ID2 REAL*8 XX INCLUDE 'VKLUGPRM.FTN' INTEGER*2 TYPE(RRWP,RCLP),VLEN(9) LOGICAL*1 AVBLS(20,27),VBLS(8,RRWP,RCLP),VT(8) REAL*8 XVT EQUIVALENCE(XVT,VT(1)) REAL*8 XXV(RRWP,RCLP) EQUIVALENCE(XXV(1,1),VBLS(1,1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN INTEGER*2 IPGMAX,LPGMXF,IPGMOD,LPGMOD COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF C NEXT BITMAPS IMPLEMENT FVLD LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 LBITS(8) COMMON/BITS/LBITS COMMON/FVLDM/FV1,FV2,FV4 C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR C TYPES OF AC'S STORAGE: LOGICAL*1 ITYP(BRRCL) INTEGER*2 IATYP(27) COMMON/TYP/IATYP,ITYP C C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT C AREAS WITH DATA. LOGICAL*1 FMTDAT(9,45),LLTST COMMON/FMTBFR/FMTDAT INTEGER*2 LVALBF(5,LVBF),MPAG(2),MPMOD(2) COMMON/VB/MPAG,LVALBF,MPMOD INTEGER*2 MFLAST,MFBASE,MVLAST,MVBASE COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE INTEGER*2 LL(4) REAL*8 XA EQUIVALENCE(XA,LL(1)) INTEGER*2 NCEL,NXINI COMMON/NCEL/NCEL,NXINI IF(ID2.GT.1.OR.ID1.GT.27)GOTO 7780 C AN ACCUMULATOR. SET IT. XVT=XX DO 7781 IV=1,8 7781 AVBLS(IV,ID1)=VT(IV) RETURN 7780 CONTINUE ID=(ID2-1)*RRW+ID1 C SET UP HASH CODE NOW FOR THE WAY WE NEED... C IPM=(IPGMAX*200/LVBF) IF(ID.LE.0)RETURN C CALL FVLDGT TO TELL IF ANYTHING IS SET FOR THE CELL... CALL FVLDGT(ID1,ID2,LLTST) IF(LLTST.NE.0)GOTO 3419 CALL FVLDST(ID1,ID2,-4) C TRICK ... SET UP SIGN BIT IN FVLD SO XVBLGT CAN FIND OUT IF C VARIABLE HAS EVER BEEN WRITTEN AND EXIT IF NOT. INDEPENDENT OF C USUAL SETTING OF FVLD SINCE IT USES "SIGN" BIT ONLY. 3419 CONTINUE IBF=(LVBF+99)/100 C IBF IS NUMBER OF BLOCKS PER BUFFER, BLOCK=500 BYTES. C IF LVBF=200, IBF=2 SINCE THERE ARE 200 * 10 BYTES TOTAL C IN MEMORY, OR 1000 PER BUFFER OR 2 BLOCKS IF(IBF.LT.1)IBF=1 LLL=(IPGMAX*2)/IBF IPM=LLL IF(IPM.LE.2)IPM=2 IHASH=ID JHASH=MOD(IHASH,(LVBF/2))+1 IF(IPGMOD.NE.0)GOTO 3400 C SPACE-OPTIMIZING PACKING IPAG=(IHASH/(LVBF/2))+1 IPAG=MOD(IPAG,IPM)+1 GOTO 3401 3400 CONTINUE C SPEED-OPTIMIZING PACKING FPG=FLOAT(IPGMOD) IF(FPG.LT.0.)FPG=FPG+65536. FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG IPAG=FPG IPAG=MOD(IPAG,IPM) IPAG=IPAG+1 C IPAG=1+(IHASH*IPM)/RRCL 3401 CONTINUE C IF(IPAG.LE.0)IPAG=1 IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 850 IF(MPAG(1).NE.0)GOTO 851 MPAG(1)=IPAG GOTO 850 851 IF(MPAG(2).EQ.0)MPAG(2)=IPAG 850 CONTINUE IF(MPAG(1).EQ.IPAG)GOTO 852 IF(MPAG(2).NE.IPAG)GOTO 853 C MPAG(2)=IPAG MVLAST=2 MVBASE=LVBF/2 GOTO 1000 852 CONTINUE MVLAST=1 MVBASE=0 GOTO 1000 853 CONTINUE C REPLACE LRU PAGE. MVLAST HAS MOST RECENTLY USED SO FLIP. MVLAST=3-MVLAST C MVLAST IS EITHER 1 OR 2 MVBASE=(LVBF/2)-MVBASE C C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE C COMPILER AND MACHINE ALLOW. C IF(IPAG.EQ.MPAG)GOTO 1000 IF(IPGMAX.LE.(LVBF/100))GOTO 1000 C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE C TO DISK AND BRING IN THE ONE DESIRED. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE. IRCLO=(MPAG(MVLAST)-1)*IBF+1 IRCHI=MPAG(MVLAST)*IBF L=1+MVBASE DO 500 N=IRCLO,IRCHI C IF PAGE WAS NEVER MODIFIED, NO NEED TO WRITE IT OUT. IF(MPMOD(MVLAST).EQ.0)GOTO 500 LLL=L+49 WRITE(9'N)((LVALBF(KK,K),KK=1,5),K=L,LLL) L=L+50 500 CONTINUE MPMOD(MVLAST)=0 MPAG(MVLAST)=IPAG C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG IRCLO=(MPAG(MVLAST)-1)*IBF+1 IRCHI=MPAG(MVLAST)*IBF L=1+MVBASE DO 501 N=IRCLO,IRCHI LLL=L+49 READ(9'N)((LVALBF(KK,K),KK=1,5),K=L,LLL) L=L+50 501 CONTINUE 1000 CONTINUE C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG) C SET THE VALUE INTO IT AS REQUIRED... C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS MPMOD(MVLAST)=1 C FLAG PAGE MODIFIED IF WE TOUCH IT. C ASSUME WE ALWAYS TOUCH IT HERE. IF(NXINI.NE.0)GOTO 111 IH1=JHASH-1 DO 1 MMN=JHASH,LVBF/2 N=MMN+MVBASE C SKIP OUT ON HITTING VIRGIN CELL IF(LVALBF(1,N).EQ.-1)GOTO 111 IF(LVALBF(1,N).NE.ID)GOTO 1 C ZERO ALL REFS TO THIS CELL WE'RE ABOUT TO WRITE. C **** THIS IS QUITE TIME CONSUMING... OMIT IF POSSIBLE... LVALBF(1,N)=0 1 CONTINUE IF(IH1.LT.1)RETURN DO 33 MMN=1,IH1 N=MMN+MVBASE C SKIP OUT ON HITTING VIRGIN CELL IF(LVALBF(1,N).EQ.-1)GOTO 111 IF(LVALBF(1,N).NE.ID)GOTO 33 C ZERO ALL REFS TO THIS CELL WE'RE ABOUT TO WRITE. C **** THIS IS QUITE TIME CONSUMING... OMIT IF POSSIBLE... LVALBF(1,N)=0 33 CONTINUE 111 CONTINUE C SINCE ZERO VALUES ARE RETURNED BY DEFAULT, DON'T BOTHER STORING THEM IF(XX.EQ.0.)RETURN IH1=JHASH-1 DO 2 MMN=JHASH,LVBF/2 N=MMN+MVBASE NN=N IF(LVALBF(1,N).EQ.-1)GOTO 4 IF(LVALBF(1,N).EQ.0)GOTO 4 IF(LVALBF(1,N).EQ.ID)GOTO 4 2 CONTINUE IF(IH1.LT.1)RETURN DO 3 MMN=1,IH1 N=MMN+MVBASE NN=N C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT. IF(LVALBF(1,N).EQ.-1)GOTO 4 IF(LVALBF(1,N).EQ.0)GOTO 4 IF(LVALBF(1,N).EQ.ID)GOTO 4 3 CONTINUE C TELL USER VALUE AREA OVERFLOWED, USING ROW 1 END CALL UVT100(CUP,1,1) WRITE(6,8900) 8900 FORMAT(' Value Table Storage Overflowed - bigger file needed') RETURN C RETURN IF CAN'T FIND VALUE...TOO BAD 4 CONTINUE C SAVE VALUE AS 4 16-BIT WORDS XA=XX C SAVE ID AND VALUE IN CELL... LVALBF(1,NN)=ID DO 5 M=1,4 5 LVALBF(M+1,NN)=LL(M) RETURN END SUBROUTINE XVBLGT(ID1,ID2,XX) C C XVBLGT - LOAD 8 BYTES GIVEN DIMENSIONS FOR GETTING THEM C 2 DIM ARRAY, DIM'D (RRW,RCL) INTEGER*2 ID1,ID2 REAL*8 XX INCLUDE 'VKLUGPRM.FTN' INTEGER*2 IPGMAX,LPGMXF,IPGMOD,LPGMOD COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD INTEGER*2 TYPE(RRWP,RCLP),VLEN(9) LOGICAL*1 AVBLS(20,27),VBLS(8,RRWP,RCLP),VT(8) REAL*8 XVT EQUIVALENCE(XVT,VT(1)) REAL*8 XXV(RRWP,RCLP) EQUIVALENCE(XXV(1,1),VBLS(1,1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF C NEXT BITMAPS IMPLEMENT FVLD LOGICAL*1 FV1(BRRCL),FV2(BRRCL),FV4(BRRCL) LOGICAL*1 LBITS(8) COMMON/BITS/LBITS COMMON/FVLDM/FV1,FV2,FV4 C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR C TYPES OF AC'S STORAGE: LOGICAL*1 ITYP(BRRCL),LWK INTEGER*2 IATYP(27),LL(4) REAL*8 XA EQUIVALENCE(LL(1),XA) COMMON/TYP/IATYP,ITYP INTEGER*2 MFLAST,MFBASE,MVLAST,MVBASE COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE INTEGER*2 LVALBF(5,LVBF),MPAG(2),MPMOD(2) COMMON/VB/MPAG,LVALBF,MPMOD C C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT C AREAS WITH DATA. LOGICAL*1 FMTDAT(9,45) COMMON/FMTBFR/FMTDAT IF(ID2.GT.1.OR.ID1.GT.27)GOTO 7780 C AN ACCUMULATOR C GET IT AS IF IT WERE A CELL DO 7781 IV=1,8 7781 VT(IV)=AVBLS(IV,ID1) XX=XVT RETURN 7780 CONTINUE ID=(ID2-1)*RRW+ID1 XX=0. C NOTE THAT HERE IF FVLD IS 0, THIS MEANS RESULT IS 0 REGARDLESS OF C OTHER STUFF...RETURN 0 IMMEDIATELY. C NOTE TRICK CALL WHICH SIGNALS ANY INITIALIZATION GETS EVALUATED. CALL FVLDGT(ID,0,LWK) IF(LWK.EQ.0)RETURN C SET UP HASH CODE NOW FOR THE WAY WE NEED... C IPM=(IPGMAX*100/LVBF)+1 IBF=(LVBF+99)/100 IF(IBF.LT.1)IBF=1 LLL=(IPGMAX*2)/IBF IPM=LLL IF(IPM.LE.2)IPM=2 IHASH=ID JHASH=MOD(IHASH,(LVBF/2))+1 IF(IPGMOD.NE.0)GOTO 3402 IPAG=(IHASH/(LVBF/2))+1 IPAG=MOD(IPAG,IPM)+1 GOTO 3403 3402 CONTINUE C SPEED-OPTIMIZING PACKING FPG=FLOAT(IPGMOD) IF(FPG.LT.0.)FPG=FPG+65536. FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG IPAG=FPG IPAG=MOD(IPAG,IPM) IPAG=IPAG+1 C IPAG=1+(IHASH*IPM)/RRCL 3403 CONTINUE C IF(IPAG.LE.0)IPAG=1 IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 851 IF(MPAG(1).NE.0)GOTO 850 MPAG(1)=IPAG GOTO 851 850 IF(MPAG(2).EQ.0)MPAG(2)=IPAG 851 CONTINUE IF(MPAG(1).EQ.IPAG)GOTO 852 IF(MPAG(2).NE.IPAG)GOTO 853 C MPAG(2)=IPAG MVLAST=2 MVBASE=LVBF/2 GOTO 1000 852 CONTINUE MVLAST=1 MVBASE=0 GOTO 1000 853 CONTINUE C USE LRU BUFFER AND FLIP USES MVLAST=3-MVLAST C 1 OR 2 MVBASE=(LVBF/2)-MVBASE C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE C COMPILER AND MACHINE ALLOW. IF(IPGMAX.LE.(LVBF/100))GOTO 1000 C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE C TO DISK AND BRING IN THE ONE DESIRED. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE. IRCLO=(MPAG(MVLAST)-1)*IBF+1 IRCHI=MPAG(MVLAST)*IBF L=1+MVBASE DO 500 N=IRCLO,IRCHI IF(MPMOD(MVLAST).EQ.0)GOTO 500 LLL=L+49 WRITE(9'N)((LVALBF(KKK,K),KKK=1,5),K=L,LLL) L=L+50 500 CONTINUE MPMOD(MVLAST)=0 C THIS ONLY READS, SO NEVER SET MPMOD=1 IN XVBLGT. C ON THE CONTRARY, SPECIFY IT AS UNTOUCHED AS YET HERE. MPAG(MVLAST)=IPAG C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG IRCLO=(MPAG(MVLAST)-1)*IBF+1 IRCHI=MPAG(MVLAST)*IBF L=1+MVBASE DO 501 N=IRCLO,IRCHI LLL=L+49 READ(9'N)((LVALBF(KKK,K),KKK=1,5),K=L,LLL) L=L+50 501 CONTINUE 1000 CONTINUE C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG) C SET THE VALUE INTO IT AS REQUIRED... C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS IH1=JHASH-1 DO 2 MMN=JHASH,LVBF/2 N=MMN+MVBASE NN=N IF(LVALBF(1,N).EQ.-1)GOTO 3332 IF(LVALBF(1,N).EQ.ID)GOTO 4 2 CONTINUE IF(IH1.LT.1)RETURN DO 3 MMN=1,IH1 N=MMN+MVBASE C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT. NN=N IF(LVALBF(1,N).EQ.-1)GOTO 3332 IF(LVALBF(1,N).EQ.ID)GOTO 4 3 CONTINUE 3332 XX=0. RETURN C RETURN IF CAN'T FIND VALUE...TOO BAD C NOTE WE ALSO RETURN INSTANTLY IF WE SEE A VIRGIN CELL SINCE WE KNOW C THE REAL VALUE CANNOT LIE BEYOND IT. 4 CONTINUE C GET VALUE AS 4 16-BIT WORDS DO 5 M=1,4 5 LL(M)=LVALBF(M+1,NN) XX=XA RETURN END