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,LFMX),MFMOD INTEGER*2 RRWACT,RCLACT COMMON/RCLACT/RRWACT,RCLACT LOGICAL*1 LFID(16,LFMX) 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(LFM4X) 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 C DEFINE FILE AREAS FOR MAPPING FILES... C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE C INPUT - ONLY OR READ/WRITE. C C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL) C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED. C C MFIOPN = 0 IF NOT OPEN C 1 IF OPEN FOR READ ONLY, SEQUENTIAL C 2 IF OPEN READ ONLY, RANDOM C 3 IF OPEN READ/WRITE, RANDOM. C C MFOOPN = 0 IF NOT OPEN C 1 IF OPEN WRITE SEQUENTIAL C 2 IF OPEN WRITE RANDOM C C OTHER OPTIONS DON'T MAKE SENSE. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS C MFILUN,MFOLUN ARE LOGICAL UNITS. INTEGER*2 MFILO,MFOLO INTEGER*2 MFIOPN,MFIRL,MFIRH,MFICL,MFICH INTEGER*2 MFOOPN,MFORL,MFORH,MFOCL,MFOCH INTEGER*2 MFILUN,MFOLUN,MFIFLG,MFOFLG COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH, 1 MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG C 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,LFMY 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) C NOW MODFIY BY READING FROM FILE IF PRESET TO DO SO. CALL FNDRC(NREC,ARRAY,JFUN) 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,LFMY 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,LFMY 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. C TAKE ARRAY AND WRITE TO AUX FILE IF REQUIRED TO DO SO HOWEVER. CALL FNDRC(NREC,ARRAY,JFUN) 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 SUBROUTINE FNDRC(IREC,ARRAY,IFCT) INTEGER*2 IREC,IRRR,ICCC,IRREC,IFCT LOGICAL*1 ARRAY(128) C IREC= INPUT INDEX C IRRR,ICCC ARE EQUIV COL,ROW INDICES C IRREC = RECORD EQUIV. IN FILE C IFCT = 1 FOR READ, 2 FOR WRITE C IF 1, THEN USE READING INTO ARRAY. C IF 2, THEN WRITING FROM ARRAY TO FILE. C ARRAY GETS MODIFIED AS NEEDED. INCLUDE 'VKLUGPRM.FTN' C C C DEFINE FILE AREAS FOR MAPPING FILES... C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE C INPUT - ONLY OR READ/WRITE. C C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL) C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED. C C MFIOPN = 0 IF NOT OPEN C 1 IF OPEN FOR READ ONLY, SEQUENTIAL C 2 IF OPEN READ ONLY, RANDOM C 3 IF OPEN READ/WRITE, RANDOM. C C MFOOPN = 0 IF NOT OPEN C 1 IF OPEN WRITE SEQUENTIAL C 2 IF OPEN WRITE RANDOM C C OTHER OPTIONS DON'T MAKE SENSE. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS C MFILUN,MFOLUN ARE LOGICAL UNITS. INTEGER*2 MFIOPN,MFIRL,MFIRH,MFICL,MFICH INTEGER*2 MFOOPN,MFORL,MFORH,MFOCL,MFOCH INTEGER*2 MFILUN,MFOLUN,MFIFLG,MFOFLG COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH, 1 MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG LOGICAL*1 WRK(128) C C IF(MFIOPN.EQ.0.AND.MFOOPN.EQ.0)RETURN C DON'T DO ANY WORK IF NO FILE ARE OPEN...JUST SKIP OUT FAST. NRC=IREC IRRR=MOD(NRC,RRW) ICCC=((NRC-IRUSED)/RRW)+1 C NOW HAVE OFFSETS IN INPUT RECORD C (GUARTANTEED TO BE IN REAL SHEET...REFLECT NOT REQUIRED.) IF(MFIOPN.LE.0)GOTO 1000 IF(IFCT.EQ.2.AND.MFIOPN.LE.2)GOTO 1000 IF(MFIFLG.EQ.0)GOTO 1000 C ONLY WRITE INTO FILE(IFCT=2) IF FILE OPENED FOR UPDATE. C FIRST SEE IF THIS RECORD IS IN RANGE WE CARE ABOUT. IF(IRRR.LT.MFIRL.OR.IRRR.GT.MFIRH.OR.ICCC.LT.MFICL 1 .OR.ICCC.GT.MFICH)GOTO 1000 C IF WE MADE IT HERE WE HAVE A RECORD IN THE "IN" FILE RANGE C TO DEAL WITH. NRR=MFIRH-MFIRL+1 NCC=MFICH-MFICL+1 NNRR=IRRR-MFIRL+1 NNCC=ICCC-MFICL+1 KREC=(NNRR-1)*NCC+NNCC IF(IFCT.EQ.2)GOTO 500 IF(MFIOPN.EQ.1)READ(MFILUN,400,END=5000,ERR=5000)WRK 400 FORMAT(128A1) IF(MFIOPN.EQ.2)READ(MFILUN'KREC,ERR=5000)WRK C HAVING READ THE INPUT FILE, GRAB THE FORMULA PART AND RETURN C IT. FORGET FORMAT PART; LET THAT BE UNDER SPREADSHEET C CONTROL. DO 450 KREC=1,110 450 ARRAY(KREC)=WRK(KREC) GOTO 1000 500 CONTINUE C WRITE FROM ARRAY TO FILE ON RANDOM RECORD. WRITE(MFILUN'KREC,ERR=5000)ARRAY 1000 CONTINUE IF(MFOOPN.LE.0)GOTO 2000 IF(IFCT.NE.2)GOTO 2000 IF(MFOFLG.EQ.0)GOTO 2000 IF(IRRR.LT.MFORL.OR.IRRR.GT.MFORH.OR.ICCC.LT.MFOCL 1 .OR.ICCC.GT.MFOCH)GOTO 2000 NRR=MFORH-MFORL+1 NCC=MFOCH-MFOCL+1 NNRR=IRRR-MFORL+1 NNCC=ICCC-MFOCL+1 KREC=(NNRR-1)*NCC+NNCC IF(MFOOPN.GT.1)WRITE(MFOLUN'KREC,ERR=6000)ARRAY IF(MFOOPN.EQ.1)WRITE(MFOLUN,400,ERR=6000) 1 (ARRAY(KREC),KREC=1,110) 2000 CONTINUE RETURN 5000 CONTINUE CLOSE(UNIT=MFILUN) MFIOPN=0 RETURN 6000 CONTINUE CLOSE(UNIT=MFOLUN) MFOOPN=0 RETURN END