C 2 BUFFER VERSION
	SUBROUTINE WRKFIL(NREC,ARRAY,IFUNC)
C COPYRIGHT 1983 GLENN C.EVERHART
C PERMISSION IS GRANTED TO COPY, BUT NOT FOR PROFIT
C
C WORKFILE PSEUDO-MAINTAINER FOR VAX
C
C THIS ROUTINE IS INTENDED TO PERMIT THE SCRATCH FILE OF
C PORTACALC TO BE DISPENSED WITH BY USING A LARGE IN-MEMORY
C ARRAY. A BITMAP WILL SET UP WHEN THE ELEMENT IS INIT'ED AND
C THE DEFAULT ELEMENT WILL BE COMPUTED AND RETURNED
C IF AN UNINITIALIZED ELEMENT IS USED.
	INCLUDE 'VKLUGPRM.FTN'
	PARAMETER CUP=1
C
C
	INTEGER*4 NRC
	INTEGER*2 NRC2(2)
	EQUIVALENCE(NRC2(1),NRC)
C RECORD NUMBER TO ACCESS
	INTEGER NREC 
	LOGICAL*1 ARRAY(128)
	INTEGER IFUNC
	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
	INTEGER*2 NCEL,NXINI
	COMMON/NCEL/NCEL,NXINI
	INTEGER*2 MFID(2),IFID(8,LFM),MFMOD(2)
	INTEGER*2 MFLAST,MFBASE,MVLAST,MVBASE
	COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
	INTEGER*2 RRWACT,RCLACT
	COMMON/RCLACT/RRWACT,RCLACT
	LOGICAL*1 LFID(16,LFM)
	EQUIVALENCE(IFID(1,1),LFID(1,1))
	COMMON/FRM/MFID,IFID,MFMOD
	LOGICAL*1 LI,LJ,IBYTE
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
	LOGICAL*1 DEFFMT(10),DVFMT(12)
	EQUIVALENCE(DVFMT(2),DEFFMT(1))
	COMMON/DEFVBX/DVFMT
C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 45 FORMAT
C AREAS WITH DATA.)
	LOGICAL*1 FMTDAT(9,45)
	COMMON/FMTBFR/FMTDAT
C
C IFUNC SPECIFIES WHAT TO DO:
C	=0	READ INTO ARRAY
C	=1	WRITE FROM ARRAY INTO WRKARY
C	=2	INITIALIZE (JUST CLEARS BITMAP HERE)(OPEN)
C	=3	CLOSE (CLEARS BITMAP HERE)
	IF(IFUNC.LT.0.OR.IFUNC.GT.3)RETURN
	JFUN=IFUNC+1
	GOTO (1000,2000,3000,4000),JFUN
1000	CONTINUE
C READ
	DO 1003 N=1,128
c set up as for uninitialized array element first
1003	ARRAY(N)=0
C	ARRAY(1)='P'
C	ARRAY(2)='#'
C	ARRAY(4)='#'
C	ARRAY(3)='0'
C	ARRAY(5)='0'
	ARRAY(1)='0'
	ARRAY(2)='.'
	ARRAY(118)=15
	DO 1004 N=1,9
1004	ARRAY(N+119)=DEFFMT(N)
	CALL FVLDGT(NREC,1,IBYTE)
	IF(IBYTE.NE.0)GOTO 1001
C UNINITIALIZED ARRAY ELEMENT: SET IT UP.
C RETURN THE DEFAULT FORMAT NOW.
	RETURN
1001	CONTINUE
c if element really is there set its fvld flag up from
c fvldgt returned value. The rest of the defaults are OK
c already.
	ARRAY(119)=IBYTE
C WE MAY MODIFY FORMAT LATER TOO...
C NOW HAVE A NON-DEFAULT ELEMENT TO READ... GO THROUGH SYMBOL TBL LOGIC
C FOR THESE, WE USE 16-BYTE "CELLS" WHICH HAVE THE FOLLOWING FORMAT:
C	ID	2 BYTES (CELL ADDRESS, MUST BE 1 OR MORE FOR VALID)
C	FLAG	1 BYTE  (TYPE OF CELL:
C				0 = UNUSED
C				1 = 1 OF 1 CELLS
C				2 = NONTERMINAL OF MORE THAN 1 CELL
C				3 = LAST OF >1 CELLS
C	FORMAT	1 BYTE  (INDEX OF FORMAT STRING FOR THIS CELL; FORMATS
C				ARE STORED RESIDENT, UP TO 45 OF THEM,
C				SET BY DF COMMAND.)
C	FORMULA	12 BYTES  (FORMULA TEXT)
C SET UP HASH CODE NOW FOR THE WAY WE NEED...
C	IPM=(LPGMXF*64/LFM)+1
	IBF=(LFM+63)/64
	LLL=(LPGMXF*2)/IBF
	IPM=LLL
	IF(IPM.LT.2)IPM=2
C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
	IHASH=NREC
	JHASH=MOD(IHASH,(LFM/2))
	IF(LPGMOD.NE.0)GOTO 5305
	IPAG=(IHASH/(LFM/2))+1
	IPAG=MOD(IPAG,IPM)+1
	GOTO 5306
5305	CONTINUE
C SPEED OPTIMAL PACK
	FPG=FLOAT(LPGMOD)
	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
5306	CONTINUE
C	IF(IPAG.LE.0)IPAG=1
	IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 853
	IF(MFID(1).NE.0)GOTO 852
	MFID(1)=IPAG
	GOTO 853
852	IF(MFID(2).EQ.0)MFID(2)=IPAG
853	CONTINUE
	IF(MFID(1).EQ.IPAG)GOTO 850
	IF(MFID(2).EQ.IPAG)GOTO 851
	GOTO 854
850	CONTINUE
	MFLAST=1
	MFBASE=0
	GOTO 1400
851	CONTINUE
C 2ND PAGE
	MFLAST=2
	MFBASE=LFM/2
	GOTO 1400
854	CONTINUE
	MFLAST=3-MFLAST
	MFBASE=(LFM/2)-MFBASE
C FLIP AND USE LRU BUFFER OF THE 2 IN MEMORY
C
C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
C WIN.....
	IF(LPGMXF.LE.(LFM/64))GOTO 1400
C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
	IBF=(LFM+63)/64
	IF(IBF.LT.1)IBF=1
C IBF IS BLK FACTOR
	L=1+MFBASE
	LLBK=(MFID(MFLAST)-1)*IBF+1
	LHBK=MFID(MFLAST)*IBF
	DO 1170 N=LLBK,LHBK
	IF(MFMOD(MFLAST).EQ.0)GOTO 1170
C SKIP WRITING OUT IF BLOCK WAS NOT MODIFIED SINCE READIN
	LL=L+31
	WRITE(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+32
1170	CONTINUE
C NOW READ IN THE DATA
	MFMOD(MFLAST)=0
C MARK NEW BLOCK UNTOUCHED
	MFID(MFLAST)=IPAG
	L=1+MFBASE
	LLBK=(MFID(MFLAST)-1)*IBF+1
	LHBK=MFID(MFLAST)*IBF
	DO 1171 N=LLBK,LHBK
	LL=L+31
	READ(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+32
1171	CONTINUE
C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
1400	CONTINUE
C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
C BUFFER.
	IARSUB=1
C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
C FROM START...
	IFLAG=0
	IFMT=0
	DO 2500 NN=1,LFM/2
	n=mod((nn+jhash),(lfm/2))+1+MFBASE
	IF(NN.GT.2.AND.IFID(1,N).EQ.-1)GOTO 2505
C SKIP OUT IF HIT A VIRGIN CELL AFTER 3 TRIES
	IF(IFID(1,N).NE.NREC)GOTO 2500
	IFLAG=LFID(3,N)
	IF(IFMT.EQ.0)IFMT=LFID(4,N)
	DO 2502 K=1,12
	LI=LFID(K+4,N)
C COPY FORMULA TEXT INTO ARRAY. END ON NULLS...
	IF(LI.LE.0)GOTO 2500
	ARRAY(IARSUB)=LI
C NULL OUT COUPLE EXTRA BYTES TO TERMINATE REGARDLESS OF
C WHATEVER USED TO BE THERE...
C NOTE THAT STD FORMULA BUFFER DOESN'T REALLY USE 111,112 FOR
C ANYTHING MUCH...
	ARRAY(IARSUB+1)=0
	ARRAY(IARSUB+2)=0
C *** END EXTRA NULLING
	IARSUB=IARSUB+1
2502	CONTINUE
	IF(IFLAG.EQ.1.OR.IFLAG.EQ.3)GOTO 2505
2500	CONTINUE
2505	CONTINUE
C GET FORMAT NOW...
	IF(IFMT.LE.0)RETURN
	DO 2510 N=1,9
2510	ARRAY(119+N)=FMTDAT(N,IFMT)
	GOTO 5000
2000	CONTINUE
C WRITE
C NOW SET INIT'D BIT; WRITE ARRAY ELEMENT OUT.
C FIRST FIND FORMAT AREA OR SET IT UP.
	IFMT=0
	LFF=0
C FAKE OUT THE SAVING OF FVLD INFO IN THIS ARRAY TOO.
C THIS IS INCOMPLETE AND NO LITTLE OF A KLUDGE BUT THE CODE WILL
C GENERALLY SET THEM TOGETHER, AND THIS GUARANTEES THAT IF
C FURTHER SETS TRY TO SET FVLD TO ARRAY(119), THEY'LL WORK AS
C THEY SHOULD.
C HERE SET MAX ARRAY ELEMENTS USED
C EXPECT (ID2-1)*RRW+ID1
C ID1 IS RRW DIM, ID2 IS RCL DIM
	NRC2(1)=NREC
C KEEP TRACK OF LOWER RIGHT CORNER OF USED AREA
	IRUSED=MOD(NRC,RRW)
	ICUSED=((NRC-IRUSED)/RRW)+1
	IF(ICUSED.GT.RCLACT)RCLACT=ICUSED
	IF(IRUSED.GT.RRWACT)RRWACT=IRUSED
C SET RRWACT, RCLACT
	IF(ARRAY(119).NE.0)CALL FVLDST(NREC,1,ARRAY(119))
	DO 2011 N=1,45
	IF(FMTDAT(1,N).LE.0.AND.LFF.EQ.0)LFF=N
C SAVE FIRST FREE FORMAT AREA IN CASE THIS IS A NEW FORMAT...
	DO 2010 M=1,9
	IF(ARRAY(M+119).NE.FMTDAT(M,N))GOTO 2011
2010	CONTINUE
	IFMT=N
	GOTO 2012
2011	CONTINUE
C ON FALL THROUGH, WE FOUND NOTHING FOR IT...
C USE HIS FORMAT UNLESS WE HAVE NO ROOM, IN WHICH CASE USE LAST AREA
	IF(LFF.EQ.0)LFF=45
	IFMT=LFF
	DO 2013 N=1,9
2013	FMTDAT(N,LFF)=ARRAY(119+N)
C SAVE FORMAT DATA WE NOW POINT TO...
2012	CONTINUE
C NOW THE HARDER PART... MUST WRITE THE ARRAY'S FORMULA TOO...
C	IPM=(LPGMXF*64/LFM)+1
	IBF=(LFM+63)/64
	LLL=(LPGMXF*2)/IBF
	IPM=LLL
	IF(IPM.LT.2)IPM=2
C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
	IHASH=NREC
	JHASH=MOD(IHASH,(LFM/2))
	IF(LPGMOD.NE.0)GOTO 5307
	IPAG=(IHASH/(LFM/2))+1
	IPAG=MOD(IPAG,IPM)+1
	GOTO 5308
5307	CONTINUE
C SPEED OPTIMAL PACK
	FPG=FLOAT(LPGMOD)
	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
5308	CONTINUE
C	IF(IPAG.LE.0)IPAG=1
	IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 953
	IF(MFID(1).NE.0)GOTO 952
	MFID(1)=IPAG
	GOTO 953
952	IF(MFID(2).EQ.0)MFID(2)=IPAG
953	CONTINUE
	IF(MFID(2).EQ.IPAG)GOTO 951
	IF(MFID(1).NE.IPAG)GOTO 954
950	CONTINUE
C PAGE 1 = NEEDED
	MFLAST=1
	MFBASE=0
	GOTO 2400
951	CONTINUE
C NEED 2ND BUFFER
	MFLAST=2
	MFBASE=LFM/2
	GOTO 2400
954	CONTINUE
C USE LRU BUFFER AND SWAP TO DISK.
	MFLAST=3-MFLAST
C MFLAST IS 1 OR 2 ONLY
	MFBASE=(LFM/2)-MFBASE
C
C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
C WIN.....
	IF(LPGMXF.LE.(LFM/64))GOTO 2400
C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
	IBF=(LFM+63)/64
C IBF IS BLK FACTOR
	L=1+MFBASE
	LLBK=(MFID(MFLAST)-1)*IBF+1
	LHBK=MFID(MFLAST)*IBF
	DO 2170 N=LLBK,LHBK
	IF(MFMOD(MFLAST).EQ.0)GOTO 2170
C SKIP WRITEOUT IF OLD PAGE WAS NOT MODIFIED
	LL=L+31
	WRITE(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+32
2170	CONTINUE
C NOW READ IN THE DATA
	MFID(MFLAST)=IPAG
C MARK NEXT PAGE AS MODIFIED SINCE WE WILL NOW WRITE INTO IT
C	MFMOD=1
	L=1+MFBASE
	LLBK=(MFID(MFLAST)-1)*IBF+1
	LHBK=MFID(MFLAST)*IBF
	DO 2171 N=LLBK,LHBK
	LL=L+31
	READ(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+32
2171	CONTINUE
C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
2400	CONTINUE
C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
C BUFFER.
	MFMOD(MFLAST)=1
	IARSUB=1
C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
C FROM START...
C OMIT THE ZEROING WHEN READING IN FROM FILE EXCEPT IN /MERGE MODE
	IF(NXINI.NE.0)GOTO 6233
	DO 1490 NN=1,LFM/2
	n=mod((nn+jhash),(lfm/2))+1+MFBASE
	IF(NN.GE.2.AND.IFID(1,N).EQ.-1)GOTO 6233
	IF(IFID(1,N).NE.NREC)GOTO 1490
C ZERO OLD RECORDS OF THIS ONE...
	NCEL=NCEL-1
	IF(NCEL.LT.0)NCEL=0
	DO 1498 KK=1,8
1498	IFID(KK,N)=0
1490	CONTINUE
6233	CONTINUE
	IFLAG=0
	DO 1500 NN=1,LFM/2
	n=mod((nn+jhash),(lfm/2))+1+MFBASE
	IF(IFID(1,N).NE.-1.AND.IFID(1,N).NE.0
     1     .AND.IFID(1,N).NE.NREC)GOTO 1500
C FOUND A NULL NODE...
C FILL IT IN NOW.
	NCEL=NCEL+1
	IFID(1,N)=NREC
	IFLAG=1
	LFID(4,N)=IFMT
	LFID(3,N)=IFLAG
	DO 1502 K=1,12
	LI=ARRAY(IARSUB)
	IF(LI.LE.0)GOTO 1505
C CHOP IT OFF AT 109 ALSO...
	IF(IARSUB.GT.109)GOTO 1560
	LFID(K+4,N)=LI
	IARSUB=IARSUB+1
1502	CONTINUE
C NONTERMINAL COPY...NEED ANOTHER CELL. FIRST TEST FOR EXACT FIT,
C HOWEVER.
	IF(ARRAY(IARSUB).LE.0)GOTO 1560
	IFLAG=2
	LFID(3,N)=IFLAG
C NOW GO GET MORE SPACE FOR NEXT NODE.
C NOTE IT COULD RUN OUT, BUT JUST PUNT THAT.
	GOTO 1500
1560	CONTINUE
	IF(IFLAG.EQ.1)IFLAG=3
	LFID(3,N)=IFLAG
C SETS UP EITHER 1 OR 3 FOR TERMINAL NODES
	GOTO 1505
C ESCAPE FROM LOOP ON ENDS...
1500	CONTINUE
C HERE WE RAN OUT OF ROOM. TOO BAD...CAN'T REALLY HELP IT OR
C DO MUCH. JUST FORGET IT.
C HOWEVER, PRINT A MESSAGE ON SCREEN AT LEAST...
	CALL UVT100(CUP,1,1)
	WRITE(6,8970)
8970	FORMAT(' Formula file overflowed. Try a larger file.')
1505	CONTINUE
C DONE NOW.
	GOTO 5000
4000	CONTINUE
C CLOSE (CLR BITMAP)
	CLOSE(UNIT=7,DISP='DELETE')
3000	CONTINUE
C OPEN (CLR BITMAP)
	MFID(1)=0
	MFID(2)=0
	MFBASE=0
	MFLAST=1
5000	RETURN
	END