SUBROUTINE WRKFIL(NREC,ARRAY,IFUNC)
C COPYRIGHT 1983,1984,1985 GLENN C.EVERHART
C PERMISSION IS GRANTED TO COPY, BUT NOT FOR PROFIT
C
C WORKFILE PSEUDO-MAINTAINER FOR VAX
c **** note
c *** This file is obsoleted by WRKFIL.F40
c ***
c
c **** For PDp11 use wrkfil.fiv for most recent and best
c **** results. - gce 3/14/85
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*2 NREC,NRECWK
	LOGICAL*1 ARRAY(128)
	INTEGER*2 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,IFID(8,LFM),MFMOD
	INTEGER*2 RRWACT,RCLACT
	COMMON/RCLACT/RRWACT,RCLACT
	LOGICAL*1 LFID(16,LFM)
	integer*4 nnn,LLL,IPM,IHASH,JHASH,IBF,N,IPAG,KQ
	INTEGER*4 NNNW
	EQUIVALENCE(IFID(1,1),LFID(1,1))
	COMMON/FRM/MFID,IFID,MFMOD
	LOGICAL*1 LI,LJ,IBYTE
C DATA AREA. HANDLE AS "VIRTUAL FILE".
	INTEGER*4 QFID(LFM4)
	EQUIVALENCE(QFID(1),LFID(1,1))
	INTEGER*4 QFDAT(LPDM),QVDAT(IPDM)
	COMMON/QVCMN/QVDAT,QFDAT
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
	CALL FVLDGT(NREC,1,IBYTE)
	IF(IBYTE.NE.0)GOTO 1001
C UNINITIALIZED ARRAY ELEMENT: SET IT UP.
	DO 1003 N=1,128
1003	ARRAY(N)=0
	ARRAY(1)='P'
	ARRAY(2)='#'
	ARRAY(3)='#'
C ADD EXTRA 0 SO WE CAN TELL WHY LOCATE FAILED
	ARRAY(118)=15
	DO 1004 N=1,9
1004	ARRAY(N+119)=DEFFMT(N)
C RETURN THE DEFAULT FORMAT NOW.
	RETURN
1001	CONTINUE
	DO 1053 N=1,128
1053	ARRAY(N)=0
	ARRAY(119)=IBYTE
	ARRAY(118)=15
	ARRAY(1)='0'
C LET ARRAY INITIALLY BE SET SENSIBLY..
	DO 1054 N=1,9
1054	ARRAY(N+119)=DEFFMT(N)
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
C IBF IS NO. K IN MEMORY BUFFER
	IBF=(LFM+31)/32
	LLL=(LPGMXF*2)/IBF
	IPM=LLL
	IF(IPM.LT.1)IPM=1
C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
	IHASH=NREC
	JHASH=MOD(IHASH,LFM)
	IF(LPGMOD.NE.0)GOTO 5305
	IPAG=(IHASH/LFM)+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
	IF(IPAG.LE.0)IPAG=IPM
	IF(MFID.EQ.0)MFID=IPAG
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(IPAG.EQ.MFID)GOTO 1400
	IF(LPGMXF.LE.(LFM/64))GOTO 1400
C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
	IBF=(LFM+31)/32
	IF(IBF.LT.1)IBF=1
C IBF IS BLK FACTOR
	L=1
	LLBK=(MFID-1)*IBF+1
	LHBK=MFID*IBF
	DO 1170 N=LLBK,LHBK
	IF(MFMOD.EQ.0)GOTO 1170
C SKIP WRITING OUT IF BLOCK WAS NOT MODIFIED SINCE READIN
	LL=L+63
	NNNW=N-1
	NNN=128
	NNN=1+((NNNW)*NNN)
C COMPUTE STARTING INTEGER*4 IN DATA FILE TO USE FOR RECORD
C THEN COMPUTE QFID START SUBSCRIPT
	KNKK=L*2-1
	KNKK2=LL*2
	DO 801 KQ=KNKK,KNKK2
	NNNW=KQ-1
	NNNW=NNNW+NNN
801	QFDAT(NNNW)=QFID(KQ)
C	WRITE(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+64
1170	CONTINUE
C NOW READ IN THE DATA
	MFMOD=0
C MARK NEW BLOCK UNTOUCHED
	MFID=IPAG
	L=1
	LLBK=(MFID-1)*IBF+1
	LHBK=MFID*IBF
	DO 1171 N=LLBK,LHBK
	LL=L+63
	NNN=128
	NNNW=N-1
	NNN=1+((NNNW)*NNN)
C COMPUTE STARTING INTEGER*4 IN DATA FILE TO USE FOR RECORD
C THEN COMPUTE QFID START SUBSCRIPT
	KNKK=L*2-1
	KNKK2=LL*2
	DO 802 KQ=KNKK,KNKK2
	NNNW=KQ-1
	NNNW=NNNW+NNN
802	QFID(KQ)=QFDAT(NNNW)
C	READ(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+64
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
	NRECWK=NREC
	DO 2500 NN=1,LFM
	n=mod((nn+jhash),lfm)+1
	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.NRECWK)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 KEEP NULLS AFTER ANYTHING ENTERED...
	ARRAY(IARSUB+1)=0
	ARRAY(IARSUB+2)=0
	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
	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+31)/32
	LLL=(LPGMXF*2)/IBF
	IPM=LLL
	IF(IPM.LT.1)IPM=1
C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
	IHASH=NREC
	JHASH=MOD(IHASH,LFM)
	IF(LPGMOD.NE.0)GOTO 5307
	IPAG=(IHASH/LFM)+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
	IF(IPAG.LE.0)IPAG=IPM
	IF(MFID.EQ.0)MFID=IPAG
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(IPAG.EQ.MFID)GOTO 2400
	IF(LPGMXF.LE.(LFM/64))GOTO 2400
C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
	IBF=(LFM+31)/32
C IBF IS BLK FACTOR
	L=1
	LLBK=(MFID-1)*IBF+1
	LHBK=MFID*IBF
	DO 2170 N=LLBK,LHBK
	IF(MFMOD.EQ.0)GOTO 2170
C SKIP WRITEOUT IF OLD PAGE WAS NOT MODIFIED
	LL=L+63
	NNNW=N-1
	NNN=128
	NNN=1+((NNNW)*NNN)
C COMPUTE STARTING INTEGER*4 IN DATA FILE TO USE FOR RECORD
C THEN COMPUTE QFID START SUBSCRIPT
	KNKK=L*2-1
	KNKK2=LL*2
	DO 803 KQ=KNKK,KNKK2
	NNNW=KQ-1
	NNNW=NNNW+NNN
803	QFDAT(NNNW)=QFID(KQ)
C	WRITE(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+64
2170	CONTINUE
C NOW READ IN THE DATA
	MFID=IPAG
C MARK NEXT PAGE AS MODIFIED SINCE WE WILL NOW WRITE INTO IT
C	MFMOD=1
	L=1
	LLBK=(MFID-1)*IBF+1
	LHBK=MFID*IBF
	DO 2171 N=LLBK,LHBK
	LL=L+63
	NNN=128
	NNNW=N-1
	NNN=1+((NNNW)*NNN)
C COMPUTE STARTING INTEGER*4 IN DATA FILE TO USE FOR RECORD
C THEN COMPUTE QFID START SUBSCRIPT
	KNKK=L*2-1
	KNKK2=LL*2
	DO 804 KQ=KNKK,KNKK2
	NNNW=KQ-1
	NNNW=NNNW+NNN
804	QFID(KQ)=QFDAT(NNNW)
C	READ(7'N)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+64
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=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
	NRECWK=NREC
	DO 1490 NN=1,LFM
	n=mod((nn+jhash),lfm)+1
	IF(NN.GE.3.AND.IFID(1,N).EQ.-1)GOTO 6233
	IF(IFID(1,N).NE.NRECWK)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
	n=mod((nn+jhash),lfm)+1
	IF(IFID(1,N).NE.-1.AND.IFID(1,N).NE.0
     1     .AND.IFID(1,N).NE.NRECWK)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. Save, use larger version.')
1505	CONTINUE
C DONE NOW.
	GOTO 5000
3000	CONTINUE
C OPEN (CLR BITMAP)
	MFID=0
	GOTO 5000
4000	CONTINUE
C CLOSE (CLR BITMAP)
c	CLOSE(UNIT=7,DISP='DELETE')
	MFID=0
5000	RETURN
	END