SUBROUTINE WRKFIL(NREC,ARRAY,IFUNC)
C COPYRIGHT 1983,1984,1985 GLENN C.EVERHART
C PERMISSION IS GRANTED TO COPY, BUT NOT FOR PROFIT
C ** MUCH SIMPLER VERSION OF WRKFIL FOR VAX ONLY **
C USES BIG ARRAY (QFDAT) INSTEAD OF LOCAL PAGE.
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*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)
C HERE ADD DEFINITIONS FOR QLFID AND QIFID WHICH ARE THE WHOLE AREA
C TO BE USED. MAKE IT ALL ONE GIANT PAGE.
	LOGICAL*1 QLFID(16,LPDMF)
	INTEGER*2 QIFID(8,LPDMF)
	EQUIVALENCE(QLFID(1,1),QIFID(1,1),QFDAT(1))
	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...
CC NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
CC BUFFER.
	IARSUB=1
CC FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
CC FROM START...
	IFLAG=0
	IFMT=0
	JHASH=NREC
	NRECWK=NREC

	DO 2500 NN=1,LFM
	n=mod((nn+jhash),LPDMF)+1
C SKIP IF WE GET 0 ID CELL INDICATING NEVER-INITIALIZED CELL.
	IF(NN.GT.2.AND.QIFID(1,N).EQ.0)GOTO 2505
C SKIP OUT IF HIT A VIRGIN CELL AFTER 3 TRIES
	IF(QIFID(1,N).NE.NRECWK)GOTO 2500
	IFLAG=QLFID(3,N)
	IF(IFMT.EQ.0)IFMT=QLFID(4,N)
	DO 2502 K=1,12
	LI=QLFID(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
	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
	JHASH=NREC
	IF(NXINI.NE.0)GOTO 6233
c note that because we detect virgin entries (0 contents), we pay
c essentially no penalty for having one giant page. Here we only
c optimize storage by using no more for formulas than is really
c needed. We also avoid continual copying to/from a working page
c which is needed in the PDP11 (or MSDOS) environment. The system
c needs a fair amount of virtual address space to make this work,
c but VMS provides that.
	DO 1490 NN=1,LFM
	n=mod((nn+jhash),LPDMF)+1
	IF(NN.GE.2.AND.QIFID(1,N).EQ.0)GOTO 6233
	IF(QIFID(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
C SET TO -1 TO FLAG NON VIRGIN CELL BUT NOTHING IN IT.
1498	QIFID(KK,N)=-1
1490	CONTINUE
6233	CONTINUE
	IFLAG=0
	DO 1500 NN=1,LFM
	n=mod((nn+jhash),LPDMF)+1
	IF(QIFID(1,N).NE.-1.AND.QIFID(1,N).NE.0
     1     .AND.QIFID(1,N).NE.NREC)GOTO 1500
C FOUND A NULL NODE...
C FILL IT IN NOW.
	NCEL=NCEL+1
	QIFID(1,N)=NREC
	IFLAG=1
	QLFID(4,N)=IFMT
	QLFID(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
	QLFID(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
	QLFID(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
	QLFID(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 area 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