c -h- test.for	Fri Aug 22 13:35:58 1986	
	SUBROUTINE TEST(LOGTYP,FLAG,V1,V2)
	InTeGer*4 FLAG
	REAL*8 V1,V2
	FLAG=0
	IF(LOGTYP.EQ.1.AND.V1.GT.V2)FLAG=1
	IF(LOGTYP.EQ.2.AND.V1.LT.V2)FLAG=1
	IF(LOGTYP.EQ.3.AND.V1.EQ.V2)FLAG=1
	IF(LOGTYP.EQ.4.AND.V1.NE.V2)FLAG=1
	IF(LOGTYP.EQ.5.AND.V1.GE.V2)FLAG=1
	IF(LOGTYP.EQ.6.AND.V1.LE.V2)FLAG=1
C TEST LOGICAL RELATIONS FOR IF STATEMENT, FLAG=1 IF TRUE, 0 ELSE.
	RETURN
	END
c -h- ttydei.for	Fri Aug 22 13:35:58 1986	
	SUBROUTINE TTYDEI
	INCLUDE DOS.INC
	INTEGER *4 MODE
	Integer*4 Amiga
	External Amiga
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	COMMON/CONSFH/FH
	If (FH.ne.0)Call Amiga(Close,FH)
	RETURN
	END
c -h- ttyini.for	Fri Aug 22 13:35:58 1986	
	SUBROUTINE TTYINI
C PERFORM INITS ON UNIT 5. NORMALLY EITHER DO NOTHING OR
C REPLACE WITH SOMETHING THAT WORKS FOR YOUR SYSTEM. TYPICAL
C ACTIONS:
C  SET THE TERMINAL NOT TO WRAP AROUND
C  ATTACH TERMINAL SO TYPE-AHEAD WORKS
C  SET UP TERMINAL TO MUNGE AROUND THE ESCAPE SEQUENCES TO ALLOW
C  SPECIAL FUNCTION AND/OR ARROW KEYS TO WORK.
C ULTIMATELY USE WRITE OF UNIT 0 TO DUMP OUT SOME USEFUL ESCAPE SEQS.
C TO DEFINE FUNCTION KEYS A LA VT100 (SORT OF).
	INCLUDE DOS.INC
	CHARACTER*40 NAME
	INTEGER *4 MODE
	Integer*4 Amiga
	External Amiga
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 IDSPTP,Idol9
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9
C ***<<< RDD COMMON END >>>***
CCC	COMMON/CONSFH/FH
c Resize initial windows so all fit on NON interlace screen
	If(IDSPTP.NE.1)NAME=
     1  "RAW:0/0/639/169/AnalytiCalc-AMIGA" // CHAR(0)
	IF(IDSPTP.EQ.1)NAME=
     1  "RAW:0/0/639/369/AnalytiCalc-AMIGA" // CHAR(0)
	MODE=MODE_NEWFILE
	FH=AMIGA(Open,NAME,MODE)
	RETURN
	END
c -h- typget.for	Fri Aug 22 13:35:58 1986	
        SUBROUTINE TYPGET(ID1,ID2,IVAL)
C
C TYPGET - GET TYPE(60,301) ARRAY WORDS BACK
C RETURN TYPE(ID1,ID2) IN IVAL, BUT NOT REALLY...
C NEXT BITMAPS IMPLEMENT FVLD
        CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
	CHARACTER*1 FVXX(6792)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
	EQUIVALENCE (FV4(1),FVXX(4529))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
	LOGICAL*4 LB1,LB2
	InTeGer*4 KB1,KB2
	EQUIVALENCE(LB1,KB1),(LB2,KB2)
        CHARACTER*1 ITYP(2264)
        InTeGer*4 IATYP(27),LINTGR
        COMMON/TYP/IATYP,ITYP,LINTGR
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
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 76 FORMAT
C AREAS WITH DATA.
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC        CHARACTER*1 FMTDAT(9,76)
CCC        COMMON/FMTBFR/FMTDAT
        CHARACTER*1 ITST,ITST2
	LOGICAL*4 LTST,LTST2
	InTeGer*4 KTST,KTST2
	EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
	EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
        IF(ID1.LE.27.AND.ID2.LE.1)GOTO 1000
	IVAL=2
	IF(LINTGR.EQ.0)RETURN
	CALL FVLDGT(ID1,ID2,ITST)
	IF(ICHAR(ITST).EQ.0)GOTO 500
C        ID=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,ID)
        IBT=(ID-1)/8
	KB1=ID-1
	KB2=7
	LB1=LB1.AND.LB2
	IBIT=KB1+1
C        IBIT=((ID-1).AND.7)+1
	KTST=ICHAR(ITYP(IBT))
	KTST2=ICHAR(LBITS(IBIT))
	LTST=LTST.AND.LTST2
C        ITST=CHAR(ICHAR(ITYP(IBT)).AND.ICHAR(LBITS(IBIT)))
500     IVAL=2
        IF(KTST.NE.0)IVAL=4
        RETURN
1000    CONTINUE
C AN AC. RETURN FULL TYPE WORD
        IVAL=IATYP(ID1)
        RETURN
        END
c -h- typset.for	Fri Aug 22 13:35:58 1986	
        SUBROUTINE TYPSET(ID1,ID2,IVAL)
C
C TYPSET - STORE IVAL IN TYPE(60,301) ARRAY
C NEXT BITMAPS IMPLEMENT FVLD
        CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
	CHARACTER*1 FVXX(6792)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
	EQUIVALENCE (FV4(1),FVXX(4529))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
	LOGICAL*4 LTST,LTST2,LTST3,LT1,LT2
	InTeGer*4 KTST,KTST2,KTST3,KT1,KT2
	EQUIVALENCE(LT1,KT1),(LT2,KT2)
        CHARACTER*1 ITYP(2264)
        InTeGer*4 IATYP(27),LINTGR
        COMMON/TYP/IATYP,ITYP,LINTGR
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
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 76 FORMAT
C AREAS WITH DATA.
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC        CHARACTER*1 FMTDAT(9,76)
CCC        COMMON/FMTBFR/FMTDAT
        CHARACTER*1 ITST,ITST2,ITST3
	EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
	EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
	EQUIVALENCE(KTST3,ITST3),(KTST3,LTST3)
	IF(ID2.EQ.1.AND.ID1.LE.27)GOTO 2000
C KEEP TRACK OF WHEN WE START TO SET INTEGER TYPE
	IF(LINTGR.EQ.0.AND.IABS(IVAL).EQ.2)RETURN
C FOR SIMPLICITY SET FLAG ON 1ST NONFLOATING TYPE AND
C START KEEPING EXACT TRACK THEN ONLY.
	LINTGR=1
C        ID=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,ID)
        IBT=(ID-1)/8
	KT1=ID-1
	KT2=7
	LT1=LT1.AND.LT2
	IBIT=KT1+1
C        IBIT=((ID-1).AND.7)+1
	KTST2=ICHAR(LBITS(IBIT))
	KTST3=KTST2
	LTST2=.NOT.LTST2
C        ITST2=.NOT.LBITS(IBIT)
	KTST=ICHAR(ITYP(IBT))
	LTST2=LTST.AND.LTST2
C        ITST2=ITYP(IBT).AND.ITST2
	LTST=LTST.OR.LTST3
	ITST=CHAR(KTST)
	ITST2=CHAR(KTST2)
C        ITST=ITYP(IBT).OR.LBITS(IBIT)
        ITYP(IBT)=ITST2
        IF(IVAL.NE.-2.AND.IVAL.NE.2)ITYP(IBT)=ITST
	RETURN
2000    IATYP(ID1)=IVAL
C ACCUMULATORS JUST STORE NORMAL TYPE INTEGER.
        RETURN
        END
c -h- usrcmd.for	Fri Aug 22 13:36:30 1986	
c        interface to InTeGer*4 function system [c]
c     +          (string[reference])
c        character*1 string
c        end
	SUBROUTINE USRCMD(CMDLIN,ICODE,IGOTIT)
C --- FOR 320K AnalytiCalc only (to keep it able to fit on 256K
c     versions...)
c Add "annotation" commands via main force & awkwardness as follows:
c  1. ANN command will create a file named cell.ANN for the current
c     cell (or overwrite an old one) dynamically for up to 20 lines
c     of text, just firing up the command "EDIT namecell.ANN" so the user
c     gets to do full screen edits. THE "name" part of the files is
c     taken from the first 6 characters of the sheet name. If these
c     are not in the uppercase alpha range they will be ignored, however,
c     so it is a good idea for sheet titles to have recognizable initial
c     6 characters.
c  2. QUERY or ? command will display the name.ANN file if it exists
c     after setting cursor to top of screen and doing line erase
c     there.
c
	CHARACTER*81 CMDSTR
	CHARACTER*1 CMLN(80),CMLN2(84)
C	PARAMETER CUP=1,EL=12,ED=11,SGR=13
	InTeGer*4 IJUNK
c	InTeGer*4 SYSTEM
c	EXTERNAL SYSTEM
	EQUIVALENCE(CMLN2(5),CMLN(1),CMDSTR(1:1))
C	EQUIVALENCE(CMLN2(5),CMLN(1))
C DUMMY PLACE FOR USER COMMANDS TO PARSE CMDLIN AND HANDLE
C DEFINE VALUE AREA FOR SPREAD SHEET. MORE WILL BE NEEDED GENERALLY
C OUT OF COMMONS, BUT AT A MINIMUM, THIS WILL ALLOW SOME ACCESS TO
C USEFUL NUMBERS. LOOK IN XQTCMD FOR MORE...
	CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
	InTeGer*4 TYPE(1,1),VLEN(9)
	LOGICAL*4 LEXIST
	CHARACTER*1 NMSH(80)
	COMMON/NMSH/NMSH
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
	REAL*8 XAC,XVBLS(1,1)
	REAL*8 TAC,UAC,VAC
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(XAC,AVBLS(1,27))
	EQUIVALENCE(TAC,AVBLS(1,20))
	EQUIVALENCE(UAC,AVBLS(1,21))
	EQUIVALENCE(VAC,AVBLS(1,22))
	EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
C	CHARACTER*1 FORM(4)
	CHARACTER*1 CELNAM(5)
	character*18 annam
	CHARACTER*1 annams(18)
	equivalence(annam(1:1),annams(1))
	CHARACTER*5 CELNM
	CHARACTER*5 CELRW
	EQUIVALENCE(CELNM(1:1),CELRW(1:1),CELNAM(1))
C	EQUIVALENCE(FORM(1),CELNAM(1))
C	EQUIVALENCE(CELRW,CELNAM(1))
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC	CHARACTER*1 EDNAM(16)
CCC	common/ednam/ednam
c available parsing aid:
c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
c where line(ibgn... lend) is scanned. If variable found
c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
c variable found if any. lstchr is last char found+1...
C OTHER USEFUL ROUTINES IN THE SHEET:
C GN(LAST,LEND,NUMBER,LINE)
C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
C  NUMERIC.
C INDEX(LINE,CHAR)
C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
	CHARACTER*1 CMDLIN(132)
C	INTEGER*4 ISTTS
C
C 16 MUST BE LENGTH OF EDNAM IN BYTES
C KEEP NAME "EDIT " IN DATA SO IT CAN BE BASHED IF NEEDED TO BE...
C INSERT CODE FOR ADDING A LIB$SPAWN CALL HERE TO PASS COMMANDS TO
C 75 IF THEY BEGIN WITH A $ CHARACTER.
	IGOTIT=0
	IF(CMDLIN(1).NE.'}'.AND.CMDLIN(1).NE.'$')GOTO 8990
C
CC HERE CALL EXECIT WITH THE COMMAND LINE AS AN ARGUMENT...
	DO 1000 NN=1,80
1000	CMLN(NN)=CMDLIN(NN+1)
	CMLN(79)=Char(13)
	CMLN(80)=Char(0)
	DO 1002 NN=1,77
	N=78-NN
	IF(ICHAR(CMLN(N)).GT.32)GOTO 1004
1002	CONTINUE
C FINDING END OF REAL STRING THIS WAY
1004	CONTINUE
	CMLN(N+1)=0
c was =13, not =0 above...
C ADD C.R., THEN NULL
	CMLN(N+2)=0
	CMLN(N+3)=0
C INSERT LENGTH COUNT AS 1ST BYTE OF CMD LENGTH
C PER DOS 2.0 MANUAL PG F-1
ccc	CMLN2(1)=CHAR(N+3)
ccc	CMLN2(2)='/'
ccc	CMLN2(3)='C'
ccc	CMLN2(4)=' '
CC ! ADD C.R. AFTER LINE
CC ABOVE, INSERT A CR AFTER CMD LINE
C USE SYSTEM CALL INSTEAD OF OLDER CALL WHICH USES NOW-UNSUPPORTED
C FORTRAN FEATURES IN MS-FORTRAN V3.3
	call system(cmln2(5))
c	N=SYSTEM(CMLN2(5))
ccc	CALL EXECIT(CMLN2)
C ASSUME WE NEED A REDRAW AFTER THE SPAWN FINISHES
C EVENTUALLY FIGURE OUT HOW TO EXEC A ROUTINE THIS WAY, BUT JUST DUMMY OUT
C  AT FIRST.
	IF(CMDLIN(1).NE.'}')GOTO 2300
C IMPLEMENT WAIT ON } FORM...
	CALL UVT100(1,25,1)
	CALL VWRT('Push Return key to return to sheet>',35)
	READ(11,2400,END=2300,ERR=2300)IJUNK
2400	FORMAT(2A1)
2300	CONTINUE
	ICODE=2
C FLAG THE MAIN COMMAND PARSER WE HANDLED THE COMMAND
	IGOTIT=1
8990	CONTINUE
	IF(CMDLIN(1).NE.'F'.OR.
     1     CMDLIN(2).NE.'I'.OR.
     2     CMDLIN(3).NE.'L') GOTO 9000
	IGOTIT=1
	ICODE=3
	CALL DTRCMD(CMDLIN(4))
C ALLOW EXTRA COMMANDS OUT OF VAX VERSION...
C
9000	CONTINUE
	IF(CMDLIN(1).NE.'A'.OR.CMDLIN(2).NE.'N')GOTO 9200
C ANNOTATE COMMAND SEEN
	IGOTIT=1
	ICODE=2
	DO 9001 N=1,80
	CMLN(N)=Char(32)
9001	CONTINUE
C	CALL IN2AS(PROW,FORM)
	CALL REFLEC(PCOL,PROW,IRX)
	WRITE(CELRW(1:5),9002)IRX
9002	FORMAT(I5.5)
	ICM=17
	DO 9040 N=1,3
	IXX=ICHAR(NMSH(N))
	IF(IXX.GT.96)IXX=IXX-32
	IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9040
	CMLN(ICM)=CHAR(IXX)
	ICM=ICM+1
9040	CONTINUE
	ICM=ICM-1
	DO 9003 N=1,5
	CMLN(N+ICM)=CELNAM(N)
9003	CONTINUE
	CMLN(ICM+6)='.'
	CMLN(ICM+7)='A'
	CMLN(ICM+8)='N'
	CMLN(ICM+9)='N'
	CMLN(ICM+10)=' '
	CMLN(80)=13
	DO 9008 N=1,16
	CMLN(N)=EDNAM(N)
9008	CONTINUE
C NOW HAVE "EDIT name.ANN"
c built... go fire it up for creation or modification of annotation...
	DO 9150 N=17,ICM+9
	IF(CMLN(N).EQ.' ')CMLN(N)='0'
9150	CONTINUE
	DO 9162 NN=1,77
	N=78-NN
	IF(ICHAR(CMLN(N)).GT.32)GOTO 9164
9162	CONTINUE
C FINDING END OF REAL STRING THIS WAY
9164	CONTINUE
	CMLN(N+1)=Char(13)
C ADD C.R., THEN NULL
	CMLN(N+2)=Char(0)
	CMLN(N+3)=Char(0)
	N=SYSTEM(CMLN2(5))
	GOTO 9990
9200	CONTINUE
	IF(CMDLIN(1).NE.'?'.AND.(CMDLIN(1).NE.'Q'.OR.CMDLIN(2)
     1  .NE.'U'.OR.CMDLIN(3).NE.'E')) GOTO 9300
C QUERY COMMAND SEEN
	IGOTIT=1
	ICODE=2
	DO 9237 N=1,18
9237	ANNAMS(N)=CHAR(32)
	CALL REFLEC(PCOL,PROW,IRX)
	WRITE(CELRW(1:5),9002)IRX
	ICM=0
	do 9238 n=1,18
	annams(n)=char(32)
9238	continue
	DO 9240 N=1,3
C NOTE ANNOTATION NAMES ARE DIFFERENT HERE FROM VAX...
C USE NAMnnnnn.ANN WHERE nnnnn IS CELL HASH AND "NAM" COMES
C FROM 1ST 3 CHARS OF SHEET TITLE.
	IXX=ICHAR(NMSH(N))
	IF(IXX.GT.96)IXX=IXX-32
	IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9240
	ICM=ICM+1
	ANNAMS(ICM)=CHAR(IXX)
9240	CONTINUE
	DO 9241 N=1,5
	ANNAMS(ICM+N)=CELNAM(N)
9241	CONTINUE
	ANNAMS(ICM+6)='.'
	ANNAMS(ICM+7)='A'
	ANNAMS(ICM+8)='N'
	ANNAMS(ICM+9)='N'
	DO 9250 N=1,18
	IF(ANNAMS(N).EQ.' ')ANNAMS(N)='0'
9250	CONTINUE
	ANNAMS(ICM+10)=' '
C GO TO 9210 IF NO FILE
	INQUIRE (FILE=ANNAM,EXIST=LEXIST)
	IF(.NOT.LEXIST)GOTO 9210
	OPEN(UNIT=2,FILE=ANNAM,ACCESS='SEQUENTIAL',STATUS='OLD')
	DO 9030 N=1,20
	READ(2,9031,END=9032,ERR=9032)WRK
9031	FORMAT(128A1)
	CALL UVT100(1,N+2,1)
	CALL UVT100(12,2,0)
	call swrt(wrk,79)
c	WRITE(6,9035)WRK
9035	FORMAT(128A1)
9030	CONTINUE
9032	CONTINUE
C THIS DISPLAYS ALL THE ANNOTATION WE HAVE...
	CLOSE(UNIT=2)
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Push Return key to return to sheet>',35)
	READ(11,2400,END=9990,ERR=9990)IJUNK
	GOTO 9990
9210	CONTINUE
	ICODE=3
	CALL UVT100(1,LLDSP,1)
	call uvt100(12,2,0)
	CALL SWRT('No Annotation found on thic cell.',33)
c	WRITE(6,9211)
c9211	FORMAT(' No annotation found on this cell.')
9300	CONTINUE
C
9990	CONTINUE
	RETURN
	END
c -h- usrfct.for	Fri Aug 22 13:36:30 1986	
C USER FUNCTION ROUTINE
C GENERATES PARSING AND EXECUTION OF ROUTINE CALLS OF FORM
C  *U FNAME (ARGUMENTS)
C WHERE LINE (80 BYTES) CONTAINS COMMAND LINE AND ALL
C ARGUMENTS MAY BE PARSED.
C CALLED FROM CMND
C
C VAX VERSION: MOST MATRIX ROUTINES AVAILABLE
C BUT ASSUMES SUBSTANTIAL SPACE AVAILABLE.
C
c available parsing aid:
c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
c where line(ibgn... lend) is scanned. If variable found
c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
c variable found if any. lstchr is last char found+1...
C OTHER USEFUL ROUTINES IN THE SHEET:
C GN(LAST,LEND,NUMBER,LINE)
C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
C  NUMERIC.
C INDEX(LINE,CHAR)
C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
C VARIABLE NAMES. SUPPLIED VERSION CALLS IDATE WHICH RETURNS
C SYSTEM DATE IN RSX OR VMS AS INTEGER DAY, MONTH, AND YEAR.
C  THIS RETURNS HERE IN AC T, U, AND V
C
	SUBROUTINE USRFCT(LINE,RETCD,WRK2)
	CHARACTER*1 LINE(80)
	INTEGER RETCD
	CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
	CHARACTER*1 WRK2(128)
	InTeGer*4 TYPE(1,1),VLEN(9)
	EXTERNAL INDX
	REAL*8 XAC,XVBLS(1,1)
	REAL*8 TAC,UAC,VAC,WAC,YAC
	REAL*8 TMP,XXXX
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
	EQUIVALENCE(XAC,AVBLS(1,27))
	EQUIVALENCE(TAC,AVBLS(1,20))
	EQUIVALENCE(UAC,AVBLS(1,21))
	EQUIVALENCE(VAC,AVBLS(1,22))
	EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	InTeGer*4 XTNCNT,XTCFG,IPSET
CCC	CHARACTER*1 XTNCMD(80)
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	InTeGer*4 RRWACT,RCLACT
CCC	COMMON/RCLACT/RRWACT,RCLACT
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2

C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
CCC	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
C (IMPLEMENT FOR VAX ONLY)
CCC	INTEGER KALKIT
CCC	COMMON/VARYIT/KALKIT
C ARGUMENTS COME IN IN ARGUMENTS IN LINE
C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	CHARACTER*1 FNAMS(6,24)
C FNAMS IS NAME OF FUNCTION CALLED.
	DATA FNAMS /'I','D','A','T','E','0',
     1  'M','T','X','E','Q','0',
     2  'M','O','V','E','V','0',
     3  'M','D','E','T','0','0',
     4  'M','P','R','O','D','0',
     5  'M','A','D','D','V','0','M','S','U','B','V','0',
     7  'M','M','P','Y','T','0','M','M','P','Y','C','0',
     9  'V','A','R','Y','0','0','X','Q','T','C','M','0',
     2  'S','T','R','V','L','0','H','E','R','E','0','0',
     4  'Y','R','M','O','D','0','J','D','A','T','E','0',
     6  'J','T','O','C','H','0','D','A','T','E','0','0',
     1  'W','K','D','Y','S','0','W','K','D','I','N','0',
     2  'F','F','T','F','W','0','F','F','T','R','V','0',
     3  'L','I','N','E','F','0','D','B','0','0','0','0',
     4  'S','T','0','0','0','0'/
C NULL TERMINATE ANY NAMES (ALLOWS 5 CHARACTERS)
C START LOOKING PAST THE *U
C  GET FUNCTION NAME AND GO TO PROCESS EACH FUNCTION SEPARATELY
C GET NONBLANK CHAR FOR FUNCTION NAME START
C NO-OP THE XQTCM FUNCTION FOR PDP11-OVERLAIN VERSIONS BY ZAPPING
C THE NAME SO IT CAN'T EVER BE CALLED.
	K=3
30	IF(LINE(K).NE.' ')GOTO 40
	K=K+1
	IF(K.LT.60)GOTO 30
40	CONTINUE
C UNCOMMENT THE DO 100 STMT IF DIM 2 OF FNAMS > 1
	N=1
C **** BE SURE THE 2ND BOUND ON N IS THE SAME AS THE DIMENSION OF
C ****  FNAMS   **************************
C	DO 7771 N=1,24
C	DO 7771 NN=1,6
C	IF(FNAMS(NN,N).EQ.'0')FNAMS(NN,N)=0
C7771	CONTINUE
	DO 100 N=1,24
	KF=N
	DO 110 NN=1,6
C CHECK FOR '0' IN FUNCTION NAME AND SKIP ON THAT... 48 IS ASCII /0/
	IF(LINE(K+NN-1).NE.FNAMS(NN,N).AND.ICHAR(FNAMS(NN,N)).NE.48)
     1  GOTO 100
110	CONTINUE
	GOTO 200
100	CONTINUE
C UNRECOGNIZED FUNCTION... IGNORE
300	RETCD=3
	RETURN
200	CONTINUE
C NOW HAVE FOUND FUNCTION IDENTIFIED BY KF. CALL IT AND ALLOW TO WORK
	GOTO (1100,1200,1300,1400,1500,1600,1700,1800,
     1  1900,2000,2100,2200,2300,2400,2500,2600,2700,
     2  2900,3000,3100,3200,3300,3400,3500),KF
	GOTO 300
1100	CONTINUE
C IDATE FUNCTION
C RETURNS MONTH, DAY, YEAR IN AC'S T,U,V
C RETURN 4/1/85 (APRIL FOOLS DAY)
C	IDA=1
C	IMO=4
C	IYR=85
C	CALL IDATE(IMO,IDA,IYR)
	CALL DATE(IYR,IMO,IDA)
C CALL supplied GET-DATE FUNCTION AND HOPE IT'S OK
	TAC=IMO
	UAC=IDA
	IYR=IYR-1900
	VAC=IYR
C RETURN A FLOATING VALUE OF DATE FORM AS YYMMDD SO IT CAN BE
C USED FOR SORTING AND SIMILAR APPLICATIONS. COULD BE USED ALSO
C FOR INTERVALS IF A JULIAN DATE WERE RETURNED, BUT THIS WILL DO
C FOR COMPARISONS AND ORDERING.
	XAC=JULMDY(IYR,IMO,IDA)
C	XAC=VAC*10000.+TAC*100.+UAC
	RETURN
1200	CONTINUE
C MATRIX EQUATION. NOTE WE MUST NOW START SCAN FOR ARGUMENTS...
C K+5 IS START OF ARG LIST. START AT K+6 TO ALLOW ( TO BE THERE...
C FORMAT DESIRED:
C  *U MTXEQ(A1:A2,X1:X2,B1:B2) GENERATING SOLUTION MATRIX X1:X2
C  FROM MATRICES A,B AND SOLVING EQUATION AX=B WHERE A IS AN N BY
C  N SQUARE MATRIX, AND X AND B ARE N BY M MATRICES.
	RETCD=1
C COLLECT ARGUMENTS. NOTE THAT VARSCN AND GN TRASH POINTERS PASSED
C TO THEM IN IBGN, LEND, SO MAKE UP EVERY TIME. USE VARSCN TO
C COLLECT POINTERS TO THE SHEET ARRAY FIRST OFF COMMAND LINE,
C THEN PROCESS IN OUR MAGICAL MYSTICAL ROUTINE...
	IBGN=K+6
	LEND=IBGN+20
C GET LOCATIONS OF MATRICES A, X, AND B (FOR AX=B EQN)
C A MUST BER N BY N, SQUARE. X,B ARE N BY M.
	CALL PMTX2(RETCD,3,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1   IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	N=IABS(ID1B-ID1A)+1
C CHECK THAT MATRIX A IS SQUARE
	IF(N.NE.(IABS(ID2B-ID2A)+1))GOTO 300
C CHECK THAT MATRIX X AND B HAVE THE SAME DIMENSIONS
	IF((IDYA-IDXA).NE.(IDCA-IDBA))GOTO 300
	IF((IDYB-IDXB).NE.(IDCB-IDBB))GOTO 300
	M=IABS(IDYA-IDXA)+1
C CHECK THAT THE X AND B MATRIX DIMENSIONS ARE N BY M
C WHERE THE N IS THE SAME AS FOR THE A MATRIX
	NN=IABS(IDYB-IDXB)+1
	IF(NN.NE.N)GOTO 300
C NOW HAVE DIMENSIONS FOR ALL THIS STUFF...
C SINCE MTXEQU TRASHES ITS' B MATRIX, COPY IT INTO X MATRIX
C AND THEN CALL...
	DO 1210 NN=IDBA,IDCA
	DO 1210 MM=IDBB,IDCB
	CALL XVBLGT(NN,MM,XVBLS(1,1))
	CALL XVBLST(NN-IDBA+IDXA,MM-IDBB+IDXB,XVBLS(1,1))
C	XVBLS(NN-IDBA+IDXA,MM-IDBB+IDXB)=XVBLS(NN,MM)
1210	CONTINUE
C NOW ALL THE ARGUMENTS ARE SET UP... GO DO THE WORK.
C CALL UTILITY ROUTINE, THEN DONE...
	CALL MTXEQU(ID1A,ID2A,IDXA,IDXB,N,M,XAC)
	RETURN
1300	CONTINUE
C MOVEV  MTX1 MTX2  MOVE MTX1 VALUES TO MTX2
	RETCD=1
	IBGN=K+6
	CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
     1  IR2B,IC2B,KK,KK,KK,KK)
C CHECK FOR SAME SIZE MATRICES
	IF((IC1T-IC1B).NE.(IC2T-IC2B))GOTO 300
	IF((IR1T-IR1B).NE.(IR2T-IR2B))GOTO 300
C DO THE COPY HERE (EASIER THAN CALLING SOMETHING...)
	DO 1301 NN=IR1T,IR1B
	DO 1301 MM=IC1T,IC1B
	CALL XVBLGT(NN,MM,XVBLS(1,1))
	CALL XVBLST(NN-IR1T+IR2T,MM-IC1T+IC2T,XVBLS(1,1))
C	XVBLS(NN-IR1T+IR2T,MM-IC1T+IC2T)=XVBLS(NN,MM)
1301	CONTINUE
	RETURN
1400	CONTINUE
C MDET  - DETERMINANT OF SQUARE MATRIX
C  1 ARGUMENT, VIZ., MATRIX COORDS
	RETCD=1
C ACCOUNT FOR "MDET" BEING 4 CHARS NOT 5
	IBGN=K+5
	CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
     1  IV,IV,IV,IV,IV,IV,IV,IV)
C CALL A DETERMINANT ROUTINE TO DO THE WORK
C NOTE IT CHECKS FOR SQUARE MATRIX INTERNALLY AND RETURNS 0 IF NOT
C SQUARE...
	CALL MDET(XVBLS,IR1T,IC1T,IR1B,IC1B,XAC)
	RETURN
1500	CONTINUE
C MPROD A,B,C  C=A*B MATRIX WISE
	IBGN=K+6
	RETCD=1
	IMXX=3
	CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
C A=N BY M
C B=M BY L
C C=N BY L
	N=1+ID1B-ID1A
	M=1+ID2B-ID2A
C	IF(M.NE.(1+IDYB-IDXB))GOTO 300
	L=1+IDYA-IDXA
C	IF(N.NE.(1+IDCB-IDBB))GOTO 300
C	IF(L.NE.(1+IDCA-IDBA))GOTO 300
C DIMENSIONS LOOK OK NOW SO DO THE WORK
C USE SLIGHTLY MODIFIED GMPRD
	CALL GMPRD(ID1A,ID2A,IDXA,IDXB,
     1  IDBA,IDBB,N,M,L)
	RETURN
1600	CONTINUE
C MADDV A,B,C  C=A+B
	IMXX=3
	IBGN=K+6
	RETCD=1
	CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	N=1+ID1B-ID1A
	M=1+ID2B-ID2A
C	IF(N.NE.(1+IDYA-IDXA))GOTO 300
C	IF(N.NE.(1+IDCA-IDBA))GOTO 300
C	IF(M.NE.(1+IDYB-IDXB))GOTO 300
C	IF(M.NE.(1+IDCB-IDBB))GOTO 300
C USE MODIFIED GMADD
	CALL GMADD(ID1A,ID2A,IDXA,IDXB,
     1  IDBA,IDBB,M,N)
	RETURN
1700	CONTINUE
C MSUBV A,B,C  C=A-B
	IMXX=3
	IBGN=K+6
	RETCD=1
	CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	N=1+ID1B-ID1A
	M=1+ID2B-ID2A
C	IF(N.NE.(1+IDYA-IDXA))GOTO 300
C	IF(N.NE.(1+IDCA-IDBA))GOTO 300
C	IF(M.NE.(1+IDYB-IDXB))GOTO 300
C	IF(M.NE.(1+IDCB-IDBB))GOTO 300
	CALL GMSUB(ID1A,ID2A,IDXA,IDXB,
     1  IDBA,IDBB,M,N)
	RETURN
1800	CONTINUE
C MMPYT A,B,C  C=AT*B
C GET 3 MATRICES
	IMXX=3
	IBGN=K+6
	RETCD=1
	CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
C TRANSPOSE DIMENSIONS OF A...
	M=1+ID1B-ID1A
	N=1+ID2B-ID2A
C	IF(M.NE.(1+IDYB-IDXB))GOTO 300
	L=1+IDYA-IDXA
C	IF(N.NE.(1+IDCB-IDBB))GOTO 300
C	IF(L.NE.(1+IDCA-IDBA))GOTO 300
	CALL GTPRD(ID1A,ID2A,IDXA,IDXB,
     1  IDBA,IDBB,N,M,L)
	RETURN
1900	CONTINUE
C MMPYC A,B,K  B=A*K (K=CONSTANT)
C FOR MPY BY CONSTANT WE GET MATRICES IN ORDER A,C, THEN AC WITH CONST
C IN IT LAST...
	IBGN=K+6
	RETCD=1
	IMXX=2
	CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	IF(LINE(IBGN-1).NE.',')GOTO 300
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,IDCA,IDCB,IVALID)
	IF(IVALID.EQ.0)GOTO 300
C NOW HAVE EVERYTHING OF ARGS... CHECK DIMENSIONS OF MATRICES....
	N=1+ID1B-ID1A
	M=1+ID2B-ID2A
C	IF(N.NE.(1+IDYA-IDXA))GOTO 300
C	IF(M.NE.(1+IDYB-IDXB))GOTO 300
	CALL XVBLGT(IDCA,IDCB,XXXX)
	DO 1901 NN=ID1A,ID1B
	DO 1901 MM=ID2A,ID2B
	CALL XVBLGT(NN,MM,XVBLS(1,1))
	XVBLS(1,1)=XVBLS(1,1)*XXXX
	CALL XVBLST(NN-ID1A+IDXA,MM-ID2A+IDXB,XVBLS(1,1))
C	XVBLS(NN-ID1A+IDXA,MM-ID2A+IDXB)=XVBLS(NN,MM)
C     1    *XVBLS(IDCA,IDCB)
1901	CONTINUE
	RETURN
C *U VARY X,A,W,I,P;Q;R;S;T
C  REPEATEDLY COMPUTE SHEET FOR I ITERATIONS (DEFAULTS TO 1
C  IF NONE GIVEN) AND VARY AC P,Q,R,S, T (POSITIONAL...WHATEVER
C  IS NAMED) UNTIL CONDITION THAT AC X (WHATEVER IS NAMED THERE)
C  IS MADE EQUAL TO AC A AS CLOSELY AS POSSIBLE. DOES MULTI-DIMENSIONAL
C  STEPPING SEARCH SAVING AC'S AND MODIFYING. ACTUALLY WILL HANDLE ANY
C  CELL. UP TO 8 DIMENSIONS PERMITTED (ARBITRARY LIMIT).
C  NOTE THAT RECALCULATE SPECIAL VARY FLAG WILL BE SET HERE IF
C  VARYING MORE THAN ONCE...
C  WILL VARY ONE OF THE AC'S IN THE LIST P,Q,R,S,T... BY INITIAL
C  FRACTION W (AN ARBITRARY "STEP SIZE" FRACTION) AND COMPUTE THE
C  GRADIENT OF (X-A) WRT THAT AC, THEN WILL REPLACE ALL AC'S AND
C  VARY THAT AC BY W * THE GRADIENT, MEANING THAT AS THE GRADIENT
C  DECREASES, THE VARIANCE DOES ALSO. LAST GRADIENTS ARE SAVED AND
C  USED AS INITIAL VARIANCES, SO THAT THE W FRACTION IS AN INITIAL
C  GUESS. HOWEVER IT ALSO IS A LIMIT SO NO STEP VARIES AN AC BY
C  MORE FRACTIONALLY THAN W.
C   ONCE THIS IS DONE ANOTHER ONE OF THE P,Q,R,S,T,... LIST IS
C  CHOSEN CIRCULARLY AND THE PROCESS REPEATS. THIS MAY CONTINUE
C  INDEFINITELY TO LOOK FOR CONVERGENCE.
C   NOTE THAT X AND A MAY BE ANY CELL AND NEED NOT BE ACCUMULATORS.
C  HOWEVER ALL OTHER CELLS TO VARY MUST BE AC'S AND MUST BE THE
C  INDEPENDENT VARIABLES. CALCULATIONS ELSEWHERE ON THE SHEET
C  (PERHAPS LATER IN THE SAME CELL...)MUST ESTABLISH DEPENDENT
C  VARIABLES OR BOUNDARY OR NORMALIZATION CONDITIONS.
2000	CONTINUE
	RETCD=1
C SPLIT OFF THESE FUNCTIONS INTO A COMMON SUBROUTINE
	CALL VVARY(LINE,RETCD,K)
	RETURN
2100	CONTINUE
C EXECUTE COMMAND. FILL IN COMMAND FROM GIVEN FUNCTION AND
C CALL XQTCMD TO DO IT. SETS UP NECESSARY VARIABLES FIRST.
C ASSUME THE COMMAND LINE MUST BE ALONE ON LINE AFTER THIS CALL...
	KK=1
	KKK=K+6
	DO 2101 NN=KKK,80
	XTNCMD(KK)=LINE(NN)
	IF(ICHAR(XTNCMD(KK)).LE.0)GOTO 2102
	KK=KK+1
2101	CONTINUE
2102	CONTINUE
	XTNCMD(KK+1)=0
	XTNCMD(KK+2)=0
	XTNCNT=KK
	XTCFG=1
	IPSET=1
	CALL XQTCMD(ICODE)
	RETURN
2200	CONTINUE
C RETURN PACKED FORMULA STRING TO EXTRACT UP TO 8 CHARS OF
C FORMULA.
C START AT K+6
	XAC=0.
	IBGN=K+6
	IEND=IBGN+20
	CALL VARSCN(LINE,IBGN,IEND,LSTC,I1,I2,IVLD)
	IF(IVLD.LE.0)RETURN
C GET START, LENGTH NOW IN FORMULA...
	IBGN=LSTC+1
	IEND=IBGN+20
	CALL GN(IBGN,IEND,ISTART,LINE)
	IBGN=INDX(LINE,ICHAR(';'))
C LOOK FOR ';' CHAR AS START OF 2ND NUMBER
	IF(IBGN.GT.50.OR.ISTART.LE.0.OR.ISTART.GT.80)RETURN
C BUMP IBGN PAST THE ; CHAR
	IBGN=IBGN+1
	IEND=80
	CALL GN(IBGN,IEND,ILN,LINE)
	ILN=MIN0(ILN,8)
	IF(ILN.LE.0)RETURN
C READ IN FORMULA INTO WRK ARRAY
C	IRX=(I2-1)*60+I1
	CALL REFLEC(I2,I1,IRX)
	CALL WRKFIL(IRX,WRK2,0)
	CALL CE2A(WRK2,WRK)
	KZ=0
	DO 991 NN=1,ILN
	K=ICHAR(WRK(ISTART+NN-1))
C	K=K.AND.127
	IF(K.EQ.0)KZ=1
	IF(KZ.EQ.1)K=0
C STOP THE ENCODE ON SEEING ANY NULLS
	TMP=K
	XAC=XAC*128.D0+TMP
991	CONTINUE
C XAC RETURNS WITH ENCODED VALUE.
	RETURN
2300	CONTINUE
C RETURN PRESENT LOCATION IN THE MATRIX.
	TAC=PROW
	UAC=PCOL
	XAC=(PCOL-1)*60+PROW
	VAC=4*FORMFG+2*RCFGX+RCONE
C	VAC=(DROW-1)*20+DCOL
C RESULT IN % IS PHYS SHEET HASHCODE
C RESULT IN V ACCUMULATOR IS DISPLAY SHEET LOC HASHCODE
C T AND U ACCUMULATORS GET PHYS COL, ROW OFFSET.
	WAC=RRWACT
	YAC=RCLACT
C W AND Y GET LIMITS CURRENTLY USED
	RETURN
2400	CONTINUE
C YRMOD
	RETCD=1
	IBGN=K+6
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
C
C V1, V2, V3 ARE YR, MONTH, DAY FOR RETURN OF JULIAN DATE
C
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	IYR=XVBLS(1,1)
	CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
	IMO=XVBLS(1,1)
	CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
	IDA=XVBLS(1,1)
C RETURN JULIAN DATE FROM Y, M, D GIVEN
	XAC=JULMDY(IYR,IMO,IDA)
	RETURN
2500	CONTINUE
C JDATE
	RETCD=1
	IBGN=K+6
	LEND=IBGN+20
C GET V1 WHICH HAS VARIABLE WITH THE STRING IN IT
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
C RETURN JULIAN DATE NOW AFTER FETCHING FORMULA.
C	IRX=(ID2A-1)*60+ID1A
	CALL REFLEC(ID2A,ID1A,IRX)
	CALL WRKFIL(IRX,WRK,0)
	XAC=JULIAN(WRK)
	RETURN
2600	CONTINUE
C JTOCH
	RETCD=1
	IBGN=K+6
	LEND=IBGN+20
C V1 = JULIAN DATE
C V2 IS WHERE TO STORE ASCII DATE STRING AS FORMULA.
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	IJUL=XVBLS(1,1)
C	IRX=(ID2B-1)*60+ID1B
	CALL REFLEC(ID2B,ID1B,IRX)
	CALL WRKFIL(IRX,WRK,0)
	DO 2502 N=1,110
2502	WRK(N)=0
	CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
	CALL WRKFIL(IRX,WRK,1)
C WRITE THE FORMULA BACK OUT
	TAC=IMO
	UAC=IDA
	VAC=IYR
C RETURN T,U,V AS M,D,Y ALSO
	RETURN
2700	CONTINUE
C DATE
	RETCD=1
	IBGN=K+5
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1D,ID2D,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	IYR=XVBLS(1,1)
	CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
	IMO=XVBLS(1,1)
	CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
	IDA=XVBLS(1,1)
C	IRX=(ID2D-1)*60+ID1D
	CALL REFLEC(ID2D,ID1D,IRX)
	CALL WRKFIL(IRX,WRK,0)
	DO 2702 N=1,110
2702	WRK(N)=0
	IJUL=JULMDY(IYR,IMO,IDA)
	CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
	CALL WRKFIL(IRX,WRK,1)
	GOTO 9300
2900	CONTINUE
	RETCD=1
C WKDYS - GIVE WEEKDAYS (M-F) BETWEEN 2 JULIAN DATES THAT MUST
C BE IN CELLS.
	IBGN=K+6
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	IYR=XVBLS(1,1)
	CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
	IMO=XVBLS(1,1)
C IYR HOLDS START JULIAN DATE, IMO HOLDS END ONE
	CALL WKDY(IYR,IMO,IDA)
C IDA = NUMBER WORK DAYS BETWEEN THE DATES
	XAC=IDA
C RETURN DAYS
	GOTO 9300
3000	CONTINUE
	RETCD=1
C WKDIN - GIVEN A JULIAN DATE AND A NUMBER WORKDAYS, RETURN THE
C ENDING JULIAN DATE AFTER THAT NUMBER JULIAN DAYS.
	IBGN=K+6
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	IF(LINE(LSTCHR).NE.',')GOTO 9300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 9300
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	IYR=XVBLS(1,1)
	CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
	IMO=XVBLS(1,1)
C IYR = START DATE, JULIAN. IMO = NUMBER DAYS. RETURN END DATE JULIAN.
	CALL WRKINT(IYR,IMO,IDA)
C IDA = RETURN JULIAN DATE
	XAC=IDA
	GOTO 9300
3100	CONTINUE
C FFTFW
	ISI=1
	GOTO 3210
3200	CONTINUE
C FFTRV
	ISI=-1
3210	CONTINUE
	RETCD=1
C MERGED FFT CODE
C *U FFTFW V1:V2 DOES FFT OF RANGE GIVEN (1-DIM)
C DITTO FFTRV BUT ONE IS REVERSE AND ONE IS FORWARD FFT
C REAL*8 FFT ROUTINE USED.
	IBGN=K+6
	CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
     1  IV,IV,IV,IV,IV,IV,IV,IV)
	IC=0
	IR=1
	IF(IR1T.EQ.IR1B)GOTO 3220
	IC=1
	IR=0
3220	CONTINUE
	KK=IABS(IR1T-IR1B)+1
	KKK=IABS(IC1T-IC1B)+1
	IV=MAX0(KK,KKK)
C IV = NO. POINTS.
	CALL FOUREA(IR1T,IC1T,IC,IR,IV,ISI)
C THAT'S ALL FOR FFT. REPLACES CELLS IN PLACE...
	GOTO 9300
3300	CONTINUE
C LINEF
C *U LINEF VY1:VY2[,VX1:VX2]
C WHERE X COORDS CAN BE SKIPPED...
	IBGN=K+6
	RETCD=1
C JUST GET 2 MATRICES' VALUES. IF RETCD=3 ON RETURN, 2ND MATRIX MUST HAVE
C BEEN MISSING SO FLAG IT THAT WAY.
	CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
     1  IR2B,IC2B,KK,KK,KK,KK)
	IF(RETCD.NE.1)IR2T=-1
	RETCD=1
	KK=IABS(IR1T-IR1B)+1
	KKK=IABS(IC1T-IC1B)+1
	IV=MAX0(KK,KKK)
	KK=0
	IF(IR1T.EQ.IR1B)GOTO 3320
	KK=1
3320	CONTINUE
	CALL LINFIT(IR2T,IC2T,KK,IR1T,IC1T,IV,TAC,UAC,XAC,WAC)
C RETURN A VALUE IN T, B VALUE IN U, AND DEL VALUE IN %.
C FOR Y = A + BX
C W AC RETURNS CORRELATION COEFFICIENT.
	GOTO 9300
3400	CONTINUE
C *U DBxxxx FUNCTIONS PARSED EXTERNALLY
C (SAVES MUCH SPACE AND EASES MODIFICATION...)
	RETCD=1
	CALL DTRFCT(LINE(K+2),RETCD)
	GOTO 9300
3500	CONTINUE
C *U STxxxx FUNCTIONS
	RETCD=1
C K SHOULD BE SUBSCRIPT OF THE 'S' OF "ST" SO SKIP BY THE
C "ST" PART AND JUST PASS THE REST OF THE FUNCTION NAME AT THE
C START OF THE STRING...
	CALL SCIFCT(LINE(K+2),RETCD)
C HANDLE ALL *U STXXXX FUNCTIONS IN SEPARATE ROUTINE FOR EASE OF
C MOVING IT AROUND. (MIGHT EVEN GO BACK TO PDP11!)
C	GOTO 9300
9300	RETURN
	END
c -h- scifct.fam
C SCIENTIFIC FUNCTION CALLER
C This version is a dummy placeholder.
C The SCIFCT subroutine exists to allow AnalytiCalc to call just
C about *ANY* Fortran callable routine.
C   The operation is to use a formula in AnalytiCalc which includes
c a call of form:
c  *U STxxxxxx range;range;range;range;range;...;range>outrange;outrange;outrange
c so that the "xxxxxx" part is the function name to be called.
c  input ranges are the parts of the sheet for input to the function; these
c are internally copied to a large array (defined here) which is a normal
c Fortran array. They are converted to integer*4 as needed if the function
c being called needs this. Once all conversion is done, the subroutine is
c called using an argument list built up by this call list. At the end,
c the output ranges are filled in from the internal Fortran array.
c   Because Fortran callable subroutines (e.g. those in the SSP) may pass
c their return arguments in ANY of their arguments, seeing a ; will increment
c the output range counter.
c
c To add more:
c  * Select desired sizes for work area (must be big enough to hold ALL
c  arguments used), max number of arguments per function, etc.
c  * Add new function name and characteristics to tables. Note that the
c  name, integer/float stuff for all args, which arg is first OUTPUT arg,
c  and map of output args, all are needed. Don't make first output arg
c  bigger than the max. number of args.
c  * Add another call and element in the computed GOTO for each function
c  desired.
c  * Build and enjoy.
c
c   Internally we need tables of
c      * Function names (up to 6 characters long per classical Fortran rules)
c      * Number of arguments needed per function
c      * Integer/real flags for arguments' data types
c      * First output argument number (user convenience and less error
c           prone than having to have a bunch of ;;;;'s to force the
c           outputrange to come from the right area
c      * Length of the Fortran array used for each input argument
c Note: Provision is made for "scratch array" arguments, but is a bit
c  crude. However, if extra space is needed, user can specify a larger
c  input area and the larger chunk of scratch space will be present.
c  Unused argument areas will generally be zeroed on each call.
c   It is perfectly reasonable to have input-only functions (e.g. plots)
c   or several subroutines called in sequence for a function.
c
	SUBROUTINE SCIFCT(LINE,RETCD)
	Integer BigSpc
	Parameter (BigSpc=256)
	Parameter (MaxArgs=10)
	Parameter (NFCT=3)
c NFCT is number of functions included in the list. Update the parameter
c and the tables together (please!)
	INTEGER RETCD
	Character*1 LINE(80)
	Real*8 ArgAry(BigSpc)
	INTEGER*4 IARGAR(2,BIGSPC)
	EQUIVALENCE(IARGAR(1,1),ARGARY(1))
	Integer*4 ArgCtr,IntPar
	Integer*4 ArgPtr(MaxArgs)
	Integer*4 NARGin(NFct)
c nargin is number input args needed.
	Integer*4 OutArg(MaxArgs,NFct)
	Integer*4 OutBgn(NFct)
c OutArg is 0 for no output, 1 for output area
	Integer*4 RevStr(MaxArgs,NFct)
c RevStr will be nonzero to reverse storage of arrays
c from normal row-first to column-first order.
	Integer*4 IsReal(MaxArgs,NFCT)
c
C Since there are some subs that need dummy argument scratch
c areas, encode IsReal as follows:
c  0 = Real
c  -1 = Integer
c  +nn = Use argument nn's VALUE (after grabbing it) for
c        size of area to allocate. Always allocate floats
c        since they're longer.
c
c Note: Due to the way the program allocates scratch array, the
c  arguments with size info for dummy arrays must be present
c  ahead of the scratch space arguments.
c
C Argument coordinate lists
	Integer*4 InCord(4,MaxArgs)
	Integer*4 InType(MaxArgs)
	Integer*4 OutCor(4,MaxArgs)
	REAL*8 R8WRK,R8WRK2
	INTEGER*4 I4WRK,I4WRK2
	Integer*4 OutTyp(MaxArgs)
c
	Character*6 WrkFnm
	Character*1 WFNm(6)
	Equivalence(WFNm(1),WrkFnm)
	Integer*4 IniOut(NFCT)
	Integer*4 AryPtr
	Character*6 FName(NFCT)
	Character*1 FNameB(6,NFCT)
	Equivalence(Fname(1),FNameB(1,1))
c allows access of function names by byte, but data stmts to set up
c as full names...
c    This example has only 2 functions:
c  *U STDLLSQ   and
c  *U STCHISQ
c        from the Scientific Subroutine Package library...
	Data FnameB/
     1  'D','L','L','S','Q',0,
     2  'C','H','I','S','Q',0,
     3  'V','E','C','N','O','R' /
	DATA IsReal/
     1  0,0,-1,-1,-1,0,5,0,-1,0,
     2  0,-1,-1,0,-1,-1,2,3,0,0,
     3  0,-1,0,0,0,0,0,0,0,0  /
	DATA OutBgn/
     1  6,4,3 /
	DATA OutArg/
     1  0,0,0,0,0,1,0,0,1,1,
     2  0,0,0,1,1,1,0,0,0,0,
     3  0,0,1,0,0,0,0,0,0,0 /
c Note OutArg is just which output arguments are really
c output data. 1 means they are, 0 means they're not.
c
C NARGIN is min number input arguments that must be present.
	Data NARGin/10,8,3/
	Data RevStr/
     1  0,0,0,0,0,0,0,0,0,0,
     2  0,0,0,0,0,0,0,0,0,0,
     3  0,0,0,0,0,0,0,0,0,0/
C
C FIRST, before we spend a lot of effort grabbing arguments, make
c  sure we know about the function to be called. If we don't, just
c  return an error.
	KK=0
	DO 101 N=1,NFCT
	DO 110 NN=1,6
	IF(Ichar(FNAMEB(NN,N)).LE.0)GOTO 110
	IF(LINE(NN).NE.FNAMEB(NN,N)) GOTO 112
110	CONTINUE
C WE FELL THRU AND FOUND THE NAME. SAVE ITS' INDEX.
	KK=N
112	CONTINUE
101	CONTINUE
	IF(KK.GT.0)GOTO 115
114	RETCD=3
	RETURN
115	CONTINUE
	NFUNCT=KK
c A little setup...
	ArgCtr=1
	IntPar=1
c integer "parity", used to pack integer args in work array
	Aryptr=1
	Do 1 n=1,MaxArgs
	Argptr(n)=1
	Do 11 nn=1,4
	InCord(nn,n)=0
	OutCor(nn,n)=0
11	Continue
1	CONTINUE
	DO 2 N=1,BigSpc
	ArgAry(N)=0.0D0
2	Continue
C arrange for all uninitialized numbers to contain zeroes
	RETCD=1
C HANDLE *U STXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
C STARTS AFTER THE "ST" SO WE CAN DECODE IT.
c if we can't get the function, return RETCD=3...
c
c Now grab the arguments and store them in InCord, Intype, OutCor, OutTyp
	K=INDXQ(LINE,32)
C FIND STUFF AFTER SPACE
	K=K+1
	NArg=1
	IBGN=1
100	Continue
	LEND=IBGN+20
C GET LOC OF MATRIX A (MUST BE SQUARE)
	ID1B=0
	ID2B=0
	ID1A=0
	ID2A=0
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 300
	IF(LINE(K+LSTCHR-1).NE.':')GOTO 1000
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 300
1000	CONTINUE
C GMTX GETS ARGS FOR ONE RANGE
	InCord(1,NArg)=ID1A
	InCord(2,NArg)=ID2A
	INCord(3,NARG)=ID1B
	INCORD(4,NARG)=ID2B
	IBGN=LSTCHR+1
	NARG=NARG+1
	IF(LINE(K+LSTCHR-1).EQ.';')GOTO 100
C
300	CONTINUE
C NOW HAVE ALL ARGS FOR INPUT COLLECTED
	INARGS=NARG
	If(INargs.lt.NARGin(NFunct)) GOTO 114
c Flag error if not enough input args presented.
	K=INDXQ(LINE,62)
C FIND STUFF AFTER > CHARACTER
	IF(K.EQ.0.OR.K.GT.70)GOTO 500
C MUST HAVE A > OR no outputs are present.
C This is perfectly legal; outputs like graphs or auxiliary
C files (unknown to rest of program) are possible too.
	K=K+1
	NArg=1
	IBGN=1
400	Continue
	LEND=IBGN+20
C GET LOC OF MATRIX A (MUST BE SQUARE)
	ID1B=0
	ID2B=0
	ID1A=0
	ID2A=0
C TEST FOR NULL ARGUMENT (;; PAIR)
	IF(LINE(K+IBGN-1).EQ.';')GOTO 450
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 500
	IF(LINE(K+LSTCHR-1).NE.':')GOTO 1500
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 500
1500	CONTINUE
	IBGN=LSTCHR+1
	GOTO 455
450	CONTINUE
	IBGN=IBGN+1
	LSTCHR=IBGN
C PASS ;
455	CONTINUE
C GMTX GETS ARGS FOR ONE RANGE
	OUTCor(1,NArg)=ID1A
	OUTCor(2,NArg)=ID2A
	OUTCor(3,NARG)=ID1B
	OUTCor(4,NARG)=ID2B
	NARG=NARG+1
	IF(LINE(K+LSTCHR-1).EQ.';')GOTO 400
C	GOTO 500
C
500	CONTINUE
C NOW HAVE OUTPUT ARGUMENT LIST COLLECTED
C BEGIN COLLECTING DATA
	NARG=1
	IntPar=1
2000	CONTINUE
	IACNTR=ARGCTR
C  GET INPUT DATA INTO OUR BIG ARRAY
	IF(INCORD(1,NARG).LE.0)GOTO 3000
	ARGPTR(NARG)=ARGCTR
	IF(INCORD(3,NARG).NE.0)GOTO 2011
C SINGLE ARGUMENT; GRAB IT
	nn=incord(1,narg)
	mm=incord(2,narg)
	call typget(nn,mm,itype)
	If(Itype.ne.4) then
	  CALL XVBLGT(NN,MM,R8WRK)
	Else
	  Call JVBLGT(NN,MM,I4wrk)
	  R8WRK=I4WRK
	End If
c	CALL XVBLGT(INCORD(1,NARG),INCORD(2,NARG),R8WRK)
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  INTPAR=1
	  I4WRK=R8WRK
	  IARGAR(IntPar,ARGCTR)=I4WRK
	ELSE
	  If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
	  IntPar=1
C if we last packed the second word of an integer, bump to next
	  ARGARY(ARGCTR)=R8WRK
	END IF
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
	NARG=NARG+1
	GOTO 2000
2011	CONTINUE
C 2-D AREA
	IntPar=1
	DO 2020 LNN=INCORD(1,NARG),INCORD(3,NARG)
	DO 2020 LMM=INCORD(2,NARG),INCORD(4,NARG)
	NN=LNN
	IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
	MM=LMM
	IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
	call typget(nn,mm,itype)
	If(Itype.ne.4) then
	  CALL XVBLGT(NN,MM,R8WRK)
	Else
	  Call JVBLGT(NN,MM,I4wrk)
	  R8WRK=I4WRK
	End If
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  I4WRK=R8WRK
	  IARGAR(IntPar,ARGCTR)=I4WRK
	  IntPar=3-IntPar
c if IntPar is 1 make it 2; if it's 2, make it 1
	ELSE
	  If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
	  IntPar=1
C if we last packed the second word of an integer, bump to next
	  ARGARY(ARGCTR)=R8WRK
	END IF
	If(IntPar.eq.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
2020	CONTINUE
	NARG=NARG+1
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
	IntPar=1
C
C FIX UP DUMMY ARGUMENTS
C
	IF(ISREAL(NARG,NFUNCT).GT.0.AND.ISREAL(NARG,NFUNCT)
     1  .LE.MAXARGS) THEN
c If user allocated more space than the dummy calc, use bigger
c allocation. However, add a little more and check for array
c overflow.
	  ARGCTR=MAX0(ARGCTR,IACNTR+IARGAR(1,ISREAL(NARG,NFUNCT)))
	  ARGCTR=ARGCTR+30
	  ARGCTR=MIN0(ARGCTR+1,BigSpc)
C ADD A LITTLE FOR GOOD LUCK
	END IF
	GOTO 2000
3000	CONTINUE
C NOW SHOULD BE READY TO CALL THIS STUFF...
C GENERATE CALLS LIKE THE TEMPLATES BELOW. NO NEED TO MODIFY
C THE FUNCTIONS, BUT WE DO NEED TO MESS WITH THIS STUFF BECAUSE
C I DON'T KNOW OFFHAND HOW TO DO A DYNAMIC CALLING LIST IN FORTRAN
C THAT'LL WORK ON STACK IMPLEMENTATIONS.
c
c Add more numbers to the list here to get more function calls.
c
	GOTO (4001,4002,4003),NFUNCT
	RETCD=3
	RETURN
c *************** BEGINNING OF CALLS ****************
4001	CONTINUE
C DLLSQ FUNCTION.... 10 ARGS
	CALL DLLSQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
     2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)),
     3  ARGARY(ARGPTR(9)),ARGARY(ARGPTR(10)))
	GOTO 5000
4002	CONTINUE
C CHISQ FUNCTION.... 8 ARGS
	CALL CHISQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
     2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)))
	GOTO 5000
4003	CONTINUE
C Vector Norm function
	CALL VECNOR(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)))
C Use this for debugging too...
c
c insert more function calls here... they all look alike except for
c function name.
c
c  It's also completely permissible to call several Fortran subroutines
c  in sequence here if it makes sense; it's up to the user. This code
c  just gives a way to call unmodified Fortran callable code and have
c  it make sense in the AnalytiCalc context. ANY Fortran callable code
c  is OK.
c
c *****************end of calls *****************
c
5000	CONTINUE
C NOW GET ARGUMENTS BACK TO DUMP TO SHEET
	KARG=0
	DO 5100 NARG=OUTBGN(NFUNCT),MAXARGS
	KARG=KARG+1
	IF(OUTARG(NARG,NFUNCT).LE.0)GOTO 5100
	IF(OUTCOR(1,KARG).EQ.0)GOTO 5100
C +++
	ARGCTR=ARGPTR(NARG)
	IF(OUTCOR(3,KARG).NE.0)GOTO 6014
C SINGLE ARGUMENT; GRAB IT
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  I4WRK=IARGAR(1,ARGCTR)
	  R8WRK=I4WRK
	ELSE
	  R8WRK=ARGARY(ARGCTR)
	END IF
	nn=outcor(1,karg)
	mm=outcor(2,karg)
	Call typget(nn,mm,itype)
	If (Itype.ne.4) then
	  CALL XVBLST(NN,MM,R8WRK)
	Else
	  I4WRK=R8WRK
	  CALL JVBLST(nn,mm,I4WRK)
	End If
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
	GOTO 5100
6014	CONTINUE
C 2-D AREA
	DO 6020 LNN=OUTCOR(1,KARG),OUTCOR(3,KARG)
	DO 6020 LMM=OUTCOR(2,KARG),OUTCOR(4,KARG)
	NN=LNN
	IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
	MM=LMM
	IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  I4WRK=IARGAR(1,ARGCTR)
	  R8WRK=I4WRK
	ELSE
	  R8WRK=ARGARY(ARGCTR)
	END IF
	Call typget(nn,mm,itype)
	If (Itype.ne.4) then
	  CALL XVBLST(NN,MM,R8WRK)
	Else
	  I4WRK=R8WRK
	  CALL JVBLST(nn,mm,I4WRK)
	End If
c	CALL XVBLST(NN,MM,R8WRK)
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
6020	CONTINUE
C +++
5100	CONTINUE
C AT LAST, DONE
	RETURN
	END
	Subroutine VecNor(InRng,NVEC,Val)
C test subroutine
c Computes norm of input range, where NVEC is number of
c elements in the INRNG array.
	REAL*8 InRng
	Dimension InRng(1)
	Integer*4 NVEC
	Real*8 Val,X
C	VAL=0.0d0
	If(NVEC.LE.0)val=-1.0
	If(NVEC.LE.0)return
c return -1 if bad dimensions.
	X=0.0D0
	Do 1 n=1,nvec
	x=x+InRng(n)*InRng(n)
1	Continue
	x=dsqrt(x)
	Val=X
	Return
	End
c -h- JunkDum.for
c completely dummy versions of dllsq and chisq
C REMOVE these if you want to use the real ones (from
c the SSP library)
	Subroutine DLLSQ(A,B,C,D,E,F,G,H,I,J)
	RETURN
	END
	SUBROUTINE CHISQ(A,B,C,D,E,F,G,H)
	RETURN
	END
c -h- uvtgen.for	Fri Aug 22 13:36:30 1986	
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C	VT100 VIDEO DISPLAY COMMAND PROGRAM. CALLING SEQUENCE IS
C	CALL UVT100(CMD,N1,N2THE MANDS IN
C	THE PARAMETER LIST BELOW, AND N1 AND N2 ARE OPTIONAL PARAMETERS
C	DEPENDING UPON CMD. SEE THE UVT100 USER'S MANUAL FOR MORE DETAILS.
C
C
C BLACK AND WHITE SCREEN MODULE FOR ANSI TERMINALS
C ALSO COLOR SCREEN MODULE.
C COMMANDS 20 AND 21 SWITCH: 20 SETS B+W, 21 SETS COLOR MODE
C
C THIS VERSION MODIFIED FOR USE WITH PORTACALC.
C  ENTRIES NOT USED ARE DELETED, AND ALSO CODE ADDED TO SUPPORT COLOR
C  CRT'S THAT ARE BASICALLY VT100-LIKE WITH EXTENSIONS, OR VT100'S OR
C  EMULATORS WITH AVO OPTION.
C
C  OPERATION:
C    ON B+W VT100'S (WITH ADVANCED VIDEO), THE SET GRAPHICS CODES
C WILL BE USED AS FOLLOWS:
C  ALTERNATE ROWS WILL BE DISPLAYED IN BOLD
C  (ROW 3 TO 22 ONLY HOWEVER; THE REST IS NOT MATH AREA)
C COMMAND AND DISPLAY ROWS (23 AND 24 NORMALLY) WILL BE BOLDED ALWAYS.
C
C  IN COLOR MODE:
C    ON ED, SET BACKGROUND COLOR TO DARK BLUE
C    ALTERNATE ROWS WILL BE SET TO YELLOW OR GREEN
C  COLUMN LABEL ROW, LABEL ROW, AND ROW LABELS, AND COMMAND PROMPTS,
C  IN A DIFFERENT COLOR FOR EACH. DETERMINED AND SET AT TIME OF
C  CALL TO CURSOR POSITION.
C
C	AUTHOR:	GLENN EVERHART
C
      SUBROUTINE UVT100 ( CMD, N1, N2 )
      IMPLICIT INTEGER ( A - Z )
      DIMENSION PRL ( 6 )
C NOTE WE DECLARE THESE VARIABLES USED IN PORTACALC. THEY ARE ALL IN
C COMMONS, SO WE ADD NOTHING TO LENGTH OF THIS PROGRAM BY ADDING THEM.
	CHARACTER*1 FVLD
	DIMENSION FVLD(1,1)
	COMMON /FVLDC/FVLD
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	InTeGer*4 LLCMD,LLDSP
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
C ICPOS COMMON HAS PHYS COORDS BEING DISPLAYED. MUST QUERY FVLD TO
C SEE WHETHER TO INTENSIFY THE FIELD FOR NEGATIVE...
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IC1POS,IC2POS,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	InTeGer*4 IC1POS,IC2POS,MODFLG
CCC	COMMON/ICPOS/IC1POS,IC2POS,MODFLG
C CONTROLS TO SET VARIOUS VISUAL ATTRIBUTES
C NORMAL, BOLD
	InTeGer*4 N1SV,N2SV,N222
	CHARACTER*1 CLSV(8)
c        CHARACTER*1 ULIT(8)
c	CHARACTER*1 NORMIT(4)
	CHARACTER*1 OUTBUF(16)
C	CHARACTER*1 NORMIT(4),BOLDIT(8),OUTBUF(16),BOLDUL(10)
	CHARACTER*2 OBF3
	CHARACTER*3 OBF6
	EQUIVALENCE (OBF3,OUTBUF(3)),(OBF6,OUTBUF(6))
	InTeGer*4 COLSW
C COLOR SCHEME CODED DATA ABOVE...
	DATA N222/0/
	DATA COLSW/0/
C LEAVE IN THE BOLDING FOR NEGATIVE NUMBERS
c	DATA NORMIT/'','[','0','m'/
C SET ATTRIBUTE 4 (UNDERLINE) RATHER THAN 1 (BOLD) FOR ALTERNATE LINES.
c fill in initial escape character (27 decimal)
      OUTBUF ( 1 ) = Char(27)
      DO 20000  I = 2, 16
c fill in spaces in out buffer (32 decimal = ascii space)
      OUTBUF ( I ) = Char(32)
20000 CONTINUE
20001 CONTINUE
C CMD 20 TURNS COLOR ON, 21 TURNS IT OFF.
      IF ( CMD .NE. 1) GOTO 20002
C CURSOR POSITION.
C SHIP OUT APPROPRIATE CHARACTERISTICS.

7701	CONTINUE
1754	CONTINUE
1500	CONTINUE
7711	CONTINUE
      OUTBUF ( 2 ) = '['
      IF (.NOT.( N1 .GT. 0 . AND . N1 .LE. (LLDSP+1) )) GOTO 20004
       WRITE(OBF3(1:2),10,ERR=20004)N1
C      ENCODE ( 2, 10, OUTBUF ( 3 ) ) N1
20004 CONTINUE
      OUTBUF ( 5 ) = ';'
C ALLOW WIDE DISPLAYS FOR MACHINES LIKE THE RAINBOW...
C NOTE: USES MSDOS FORTRAN V3.2 FEATURE OF  I3.3 FORMAT...
      IF (.NOT.( N2 .GT. 0 . AND . N2 .LT. 233)) GOTO 20006
       WRITE(OBF6(1:3),105,ERR=20006)N2
C      ENCODE ( 3, 105, OUTBUF ( 6 ) ) N2
C FIX THE ABOVE FOR 132 COLUMN MAX ON RAINBOW. NO NEED TO LIMIT TO 80 COLS ON
C MACHINES THAT CAN HANDLE 132 OR MORE, BUT IBM MAY GOOF UP UNLESS LIMIT IS
C IN EFFECT. (LOSE LOSE)
	IF(OUTBUF(4).EQ.' ')OUTBUF(4)='0'
	IF(OUTBUF(7).EQ.' ')OUTBUF(7)='0'
	IF(OUTBUF(3).EQ.' ')OUTBUF(3)='0'
	IF(OUTBUF(6).EQ.' ')OUTBUF(6)='0'
20006 CONTINUE
      OUTBUF ( 9 ) = 'H'
      LEN = 9
      GOTO 20003
20002 CONTINUE
      IF ( CMD .NE. 11 ) GOTO 20036
C ERASE DISPLAY
C ALWSAYS ERASE WHOLE DISPLAY HERE.
	OUTBUF(1)=27
	call swrt(outbuf,1)
	call swrt('[0;0H',5)
	call swrt(outbuf,1)
	CALL SWRT('[2J',3)
	RETURN
20036 CONTINUE
      IF ( CMD .NE. 12 ) GOTO 20042
C ERASE LINE
C EITHER ERASE WHOLE LINE BY DOING CR FIRST, OR JUST END OF LINE
C IF HE USED CODE 2.
C CAN'T HANDLE ERASING START ONLY, BUT ANALYTICALC NEVER TRIES THIS.
C DO C.R. FIRST IF CALLED FOR
22001	CONTINUE
	if(n1.EQ.2)goto 20044
cc just emit line
	outbuf(1)=27
	outbuf(2)='['
	outbuf(3)='K'
	len=3
	goto 20003
C ERASE ALL BY RETURN, ERASE SEQ
20044	outbuf(1)=13
	outbuf(2)=27
	outbuf(3)='['
	outbuf(4)='K'
      LEN = 4
      GOTO 20003
20042 CONTINUE
      IF ( CMD .NE. 13 ) GOTO 20048
C SET GRAPHICS RENDITION (7=REVERSE VIDEO, 0=NORMAL,4=UNDERSCORE,1=BOLD
C  5=BLINK) (PORTACALC CALLS WITH 0 OR 7 (VT100 W/O AVO))
C	IF(MODFLG.NE.1)GOTO 22002
22002	CONTINUE
	OUTBUF(1)=27
	call swrt(outbuf,1)
	IF(N1.EQ.7)CALL SWRT('[7m',3)
	if(n1.ne.7)call swrt('[0m',3)
	return
20048 CONTINUE
c      IF (.NOT.( CMD .EQ. 15 )) GOTO 20054
C SCS. IGNORE THIS ... NEVER REALLY USED.
	RETURN
20003 CONTINUE
20073 CONTINUE
C USE A FORTRAN WRITE SO THIS WILL WORK ON VAX OR PDP11 (OR WHATEVER...)
C  UNIT 6 MUST BE THE TERMINAL...
	CALL SWRT(OUTBUF,LEN)
10    FORMAT ( I2 )
105    FORMAT(I3.3)
      RETURN
      END
c -h- varout.for	Fri Aug 22 13:37:17 1986	
	SUBROUTINE VAROUT (INDXX,IX2)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C
C **************************************************
C *                                                *
C *       SUBROUTINE   VAROUT                      *
C *                                                *
C **************************************************
C
C
C
C  OUTPUTS THE VALUE OF THE VARIABLE POINTED TO BY INDXX.
c modified version - multiple precision calls diked out - gce
C
C  ASCII     A1 FORMAT UNLESS THE ASCII VALUE IS LESS THAN 32.
C            IN SUCH CASES, 32 IS ADDED TO THE VALUE AND THE
C            CHARACTER IS OUTPUT  SO THAT IT IS PRECEDED BY THE
C            CHARACTER '^'.
C
C  DECIMAL   A COMPUTED F FORMAT.
C
C  HEXADECIMAL  LEADING ZEROES, "BASE 16" QUE.
C
C  INTEGER   I12 FORMAT
C
C  OCTAL     LEADING ZEROES, "BASE 8" QUE
C
C  REAL      D25.18 FORMAT
C
C
C  VAROUT CALLS
C
C ERRMSG   PRINTS OUT ERROR MESSAGES
C MOUT     OUTPUTS MULTIPLE PRECISION NUMBERS
C
C
C
C
C
C VAROUT IS CALLED BY CALC AND POSTVL
C
C
C
C  VARIABLE   USE
C
C  DEC        HOLDS NUMBER OF DIGITS TO THE RIGHT OF THE
C             DECIMAL POINT IN F FORMAT SPECIFICATION.
C  DFORM(11)  HOLDS FORMAT SPECIFICATION FOR F FORMAT
C             (OUTPUTTING VALUE OF VARIABLES WITH DECIMAL DATA TYPE).
C  DIGITS     HOLDS THE ASCII CHARACTERS FOR VARIOUS DIGITS.
C  EIGHT(8)   USED TO PICK OFF REAL*8 'S FROM VBLS.
C             ALSO HOLDS HEXADECIMAL DIGITS IF # IS DATA TYPE HEX.
C  FOUR(4)    USED TO PICK OFF INTEGER*4'S FROM VBLS.
C  I,K        HOLDS TEMPORARY VALUES.
C  I1         HOLDS THE FIRST DIGIT IN CREATING AN F FORMAT SPECIFICATION.
C  I2         HOLDS THE SECOND DIGIT IN CREATING AN F FORMAT SPEC.
C  INDXX      POINTS TO VARIABLE BEING OUTPUT.
C  IPT        POINTER FOR DFORM.
C  ISV        POINTER FOR VECTOR SIGN(2).
C  ITWO       TWO IS USED TO PICK OFF A BYTE OF THE INTEGER
C  TWO(2)     REPRESENTATION. THEN ITWO IS USED AS
C             THE VALUE. THIS IS DONE BECAUSE OTHERWISE
C             SOME COMPILERS WOULD FORCE A SIGN EXTEND.
C  L          TEMPORARY VALUES. POINTER FOR EIGHT(8).
C  LEVIN(11)  HOLDS PRINTABLE ASCII CHARACTERS WHICH REPRESENT
C             AN OCTAL NUMBER. EQUIVALENCED WITH EIGHT(8).
C  M1         HOLDS HIGH ORDER HEXADECIMAL DIGIT.
C  M2         HOLDS LOW ORDER HEXADECIMAL DIGIT.
C  MAG        HOLDS THE MAGNITUDE OF A REAL*8 NUMBER
C  P10        REAL*8 THAT HOLDS POWERS OF 10. (DECIMAL)
C  RETCD      HOLDS RETURN CODE FROM CALL TO MOUT.
C  RPAR       ')'
C  SIGN(2)    HOLDS PRINTABLE ASCII CHARACTERS FOR OUTPUTTING THE
C             SIGN OF A NUMBER.
C  STAR1      HOLDS A SINGLE CHARACTER.
C  VBLS(100,27)  HOLDS VALUE FOR EACH VARIABLE.
C  WIDTH      WIDTH SPECIFICATION FOR F FORMAT.
C
C
C
C	SUBROUTINE VAROUT (INDXX,IX2)
C
C NOTE THAT VAROUT IS USED TO DUMP ONLY VALUES FROM AVBLS, NOT
C VBLS (IX2=1 ALWAYS AT CALLS). THUS DON'T BOTHER TO PICK UP
C ANY FURTHER INFO FROM VBLS HERE.
	REAL*8 REAL,MAG,P10
C
	INTEGER*4 INT,L,K
C
	InTeGer*4 ITWO,INDXX
	InTeGer*4 TYPE(1,1),WIDTH,DEC,VLEN(9),RETCD
C
	CHARACTER*1 AVBLS(20,27),STAR1,EIGHT(8),FOUR(4)
	CHARACTER*1 VBLS(8,1,1)
	CHARACTER*1 TWO(2)
	CHARACTER*1 DFORM(11),DIGITS(16,3),LEVIN(11)
	CHARACTER*11 DFORM1
	EQUIVALENCE(DFORM1(1:1),DFORM(1))
	CHARACTER*1 SIGN(2)
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	InTeGer*4 OSWIT,OCNTR
C NOTE: OSWIT NONZERO MEANS OUTPUT TO OARRY.
C OSWIT=2 MEANS NO ZEROING OF OARRY; NOTHING MUCH COMES OUT.
CCC	CHARACTER*1 OARRY(100)
CCC	COMMON/OAR/OSWIT,OCNTR,OARRY
C
	COMMON /V/ TYPE,AVBLS,VBLS,VLEN
	COMMON /DIGV/ DIGITS
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
	EQUIVALENCE (TWO,ITWO)
	EQUIVALENCE (REAL,EIGHT),(INT,FOUR),(EIGHT,LEVIN)
C
	DATA SIGN/' ','-'/
	DATA DFORM /'(', '1', 'X', ',', 'F', ' ', ' ', '.', ' ', ' ',
     ;  ')'/
	DATA ITWO/0/
C
C
C
	CALL TYPGET(INDXX,IX2,K)
C	K=TYPE(INDXX,IX2)
	IF (K.GT.0) GOTO 10
C MODIFY TO ELIMINATE CALL TO ERRMSG HERE. JUST COMPLAIN LOCALLY.
	CALL SWRT('Invalid type argument',21)
	oarry(1)=13
	oarry(2)=10
	call swrt(oarry,2)
C	CALL ERRMSG (16)
	GOTO 10000
10	GOTO (100,200,300,400,500,600,700,800,900),K
	STOP 10
C
C
C
C
C **************************************************
C **************        ASCII        ***************
C **************************************************
100	STAR1=AVBLS(1,INDXX)
	IF(OSWIT.NE.0)GOTO 6006
	IF (ICHAR(STAR1).LT.32) GOTO 110
102	Continue
	Rewind 11
	WRITE (11,103) STAR1
	Rewind 11
103	FORMAT (1X,A1)
	RETURN
110	STAR1=CHAR(ICHAR(STAR1)+32)
	Rewind 11
	WRITE (11,112) STAR1
	Rewind 11
112	FORMAT (1X,'^',A1)
	RETURN
6006	OARRY(1)=STAR1
	OCNTR=1
	RETURN
C
C
C
C
C
C **************************************************
C ****************  DECIMAL   **********************
C **************************************************
200	CONTINUE
	DO 208 I=1,8
208	EIGHT(I)=AVBLS(I,INDXX)
	MAG=DABS(REAL)
	IF (MAG.LT.1.D0) GOTO 240
C
C
C COUNT THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
	P10=1.D0
	DO 210 I=1,38
	P10=10.D0*P10
	IF (P10.GT.MAG) GOTO 212
210	CONTINUE
C
C I COUNTS THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
	I=39
212	DEC=0
	WIDTH=17
	IF(I.GT.15)WIDTH=I+2
	IF(I.LE.15)DEC=15-I
C
C
C  CREATE PROPER FORMAT STATEMENT
215	I1=WIDTH/10
	I2=WIDTH-I1*10
	IF (I2.EQ.0) I2=10
	DFORM(6)=DIGITS(I1,1)
	DFORM(7)=DIGITS(I2,1)
	I1=DEC/10
	I2=DEC-I1*10
	IF (I1.EQ.0) I1=10
	IF (I2.EQ.0) I2=10
	IPT=9
	IF (I1.EQ.0) GOTO 220
	DFORM(9)=DIGITS(I1,1)
	IPT=IPT+1
220	DFORM(IPT)=DIGITS(I2,1)
	DFORM(IPT+1)=RPAR
	nnn=ipt+2
	if(nnn.ge.11)goto 223
	do 224 nnnn=nnn,11
224	dform(nnnn)=' '
223	continue
C
C
C
C
C  OUTPUT REAL USING NEWLY CREATED
C  FORMAT STATEMENT HELD BY DFORM
	IF(OSWIT.NE.0)GOTO 6009
	Rewind 11
	WRITE (11,DFORM,ERR=10000) REAL
	Rewind 11
	GOTO 10000
6009	CONTINUE
	IF(OSWIT.EQ.2) GOTO 6101
	IF(OSWIT.GT.3)GOTO 7101
	DO 6010 OCNTR=1,106
6010	OARRY(OCNTR)=0
6101	CONTINUE
C FORGET THE ENCODE ... NEVER USED
C6101	ENCODE(100,DFORM,OARRY)REAL
7101	OCNTR=100
	GOTO 10000
C
C
C  REAL LESS THAN 1.D0
240	P10=1.D0
	DO 245 I=1,38
	P10=P10*.1D0
	IF (MAG.GE.P10) GOTO 250
245	CONTINUE
	I=0
C
C I-1 REPRESENTS THE NUMBER OF LEADING ZEROS
250	DEC=14+I
	WIDTH=DEC+3
	GOTO 215
C
C
C **************************************************
C *************  HEXADECIMAL  **********************
C **************************************************
C  HEXADECIMAL
300	CONTINUE
	DO 302 I=1,4
302	FOUR(I)=AVBLS(I,INDXX)
	ISV=1
	IF (INT.LT.0) ISV=2
	INT=IABS(INT)
	L=8
	DO 304 I=1,4
C PICK UP A VALUE, THEN USE InTeGer*4 EQUIVALENT
C TO WORK WITH SO SIGN DOESN'T GET EXTENED.
	TWO(1)=ICHAR(FOUR(I))
	M1=ITWO/16
	M2=ITWO-M1*16
	IF(M1.EQ.0)M1=16
	IF(M2.EQ.0)M2=16
	EIGHT(L)=DIGITS(M2,3)
	L=L-1
	EIGHT(L)=DIGITS(M1,3)
	L=L-1
304	CONTINUE
	IF(OSWIT.NE.0)GOTO 6011
	Rewind 11
	WRITE (11,310,ERR=10000) SIGN(ISV), EIGHT
	Rewind 11
310	FORMAT (1X,1A1,8A1,2X,'(BASE 16)')
	GOTO 10000
6011	CONTINUE
	IF(OSWIT.EQ.2)GOTO 6102
	IF(OSWIT.GT.3)GOTO 7102
	DO 6013 OCNTR=1,106
6013	OARRY(OCNTR)=0
6102	CONTINUE
C FORGET UNUSED ENCODE
C6102	ENCODE(8,6012,OARRY)SIGN(ISV),EIGHT
6012	FORMAT(A1,8A1)
7102	OCNTR=9
	GOTO 10000
C
C
C **************************************************
C ***************   INTEGER   **********************
C **************************************************
400	DO 404 I=1,4
404	FOUR(I)=AVBLS(I,INDXX)
	IF(OSWIT.NE.0)GOTO 6014
	Rewind 11
	WRITE (11,410,ERR=10000) INT
	Rewind 11
410	FORMAT (1X,I12)
	GOTO 10000
6014	CONTINUE
	IF(OSWIT.EQ.2)GOTO 6103
	IF(OSWIT.GT.3)GOTO 7104
	DO 6015 OCNTR=1,106
6015	OARRY(OCNTR)=0
6103	CONTINUE
C6103	ENCODE(12,410,OARRY)INT
7104	OCNTR=12
	GOTO 10000
C
C
C **************************************************
C ***********    MULTIPLE PRECISION   **************
C **************************************************
C  MULTIPLE PRECISION
C  M10
500	CONTINUE
C
C  M8
600	CONTINUE
C
C  M16
700	continue
c700	CALL MOUT (INDXX,RETCD)
	GOTO 10000
C
C
C **************************************************
C ****************   OCTAL   ***********************
C **************************************************
C  OCTAL
800	DO 804 I=1,4
804	FOUR(I)=AVBLS(I,INDXX)
	ISV=1
	IF (INT.LT.0) ISV=2
	K=IABS(INT)
	DO 810 I=1,11
	L=K-K/8*8
C TAKE ABSOLUTE VALUE IN CASE FIRST IABS DIDN'T WORK ON -2**31
	L=IABS(L)
	IF(L.EQ.0)L=9
	LEVIN (12-I)=DIGITS(L,2)
	K=K/8
810	CONTINUE
	IF(OSWIT.NE.0)GOTO 6016
	Rewind 11
	WRITE (11,820,ERR=10000) SIGN(ISV), LEVIN
	Rewind 11
820	FORMAT (1X,1A1,11A1,2X,'(BASE 8)')
	GOTO 10000
6016	CONTINUE
	IF(OSWIT.EQ.2)GOTO 6100
	IF(OSWIT.GT.3)GOTO 7105
	DO 6018 OCNTR=1,106
6018	OARRY(OCNTR)=0
6100	CONTINUE
C6100	ENCODE(12,6017,OARRY)SIGN(ISV),LEVIN
6017	FORMAT(12A1)
7105	OCNTR=12
	GOTO 10000
C
C
C
C
C
C **************************************************
C ***************    REAL    ***********************
C **************************************************
900	DO 904 I=1,8
904	EIGHT(I)=AVBLS(I,INDXX)
	IF(OSWIT.NE.0)GOTO 6019
	Rewind 11
	WRITE (11,910,ERR=10000) REAL
	Rewind 11
910	FORMAT (1X,D25.18)
	GOTO 10000
6019	CONTINUE
	IF (OSWIT.EQ.2)GOTO 6020
	IF(OSWIT.GT.3)GOTO 7106
	DO 6321 OCNTR=1,106
6321	OARRY(OCNTR)=Char(0)
6020	CONTINUE
C	ENCODE(28,6021,OARRY)REAL
6021	FORMAT(D25.18)
7106	OCNTR=28
10000	RETURN
	END
c -h- vblget.for	Fri Aug 22 13:37:17 1986	
        SUBROUTINE VBLGET(ID1,ID2,ID3,IVAL)
C
C VBLGET - GET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLGT TO GET
C  CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE
        InTeGer*4 ID1,ID2,ID3
        CHARACTER*1 IVAL,LL(8)
        REAL*8 XX
        EQUIVALENCE(LL(1),XX)
        CALL XVBLGT(ID2,ID3,XX)
        IVAL=LL(ID1)
        RETURN
        END
c -h- vblset.for	Fri Aug 22 13:37:17 1986	
        SUBROUTINE VBLSET(ID1,ID2,ID3,IVAL)
C VBLSET - SET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLST TO GET
C  CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE
        InTeGer*4 ID1,ID2,ID3
        CHARACTER*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
c -h- wassig.fdd	Fri Aug 22 13:44:20 1986	
	SUBROUTINE WASSIG(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	InTeGer*4 IUNIT
	CHARACTER*20 WK
	CHARACTER*1 WK1(20)
	EQUIVALENCE(WK(1:1),WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
	DO 1 N=1,20
	WK1(N)=' '
1	CONTINUE
	DO 2 N=1,20
	II=ICHAR(NAME(N))
	IF(II.LT.32)GOTO 3
	WK1(N)=CHAR(II)
C1	CONTINUE
2	CONTINUE
3	OPEN(IUNIT,FILE=WK(1:20),STATUS='NEW',
     1  ACCESS='SEQUENTIAL',FORM='FORMATTED')
	RETURN
	END
c -h- wrkfil.f40	Fri Aug 22 13:44:46 1986	
	SUBROUTINE WRKFIL(NREC,ARRAY,IFUNC)
C COPYRIGHT 1983 GLENN C.EVERHART
C ALL RIGHTS RESERVED
C WORKFILE PSEUDO-MAINTAINER
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.
C
c nrc was i*4. make it i*2 here
	INTEGER NRC
C	InTeGer*4 NRC2(2)
C	EQUIVALENCE(NRC2(1),NRC)
C RECORD NUMBER TO ACCESS
	INTEGER NREC
	CHARACTER*1 ARRAY(128)
	INTEGER IFUNC
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
CCC	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	InTeGer*4 NCEL,NXINI
CCC	COMMON/NCEL/NCEL,NXINI
	InTeGer*4 MFID(2),MFMOD(2)
	InTeGer*2 IFID(8,2048)
	COMMON/IFIDC/IFID
CCC	InTeGer*4 RRWACT,RCLACT
C MFLAST = 1 OR 2 FOR LAST BUFFER USED. MFBASE IS HOLDER FOR "BASE ADDR"
C IN ARRAY TO USE IN SCANS.
	InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
	COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
CCC	COMMON/RCLACT/RRWACT,RCLACT
	CHARACTER*1 LFID(16,2048)
	EQUIVALENCE(IFID(1,1),LFID(1,1))
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
c	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC	COMMON/FRM/MFID,MFMOD
	CHARACTER*1 LI,IBYTE
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
	CHARACTER*1 DVFMT(12),DEFFMT(10)
	EQUIVALENCE(DVFMT(2),DEFFMT(1))
	COMMON/DEFVBX/DVFMT
C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
C AREAS WITH DATA.)
CCC	CHARACTER*1 FMTDAT(9,76)
CCC	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)
	CHARACTER*1 DTBL1(9,9,8)
C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
	InTeGer*2 BTBL(6,6,8)
C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
C NO NEED TO WASTE IT.
	INTEGER DTBLIN
C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
	EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
	InTeGer*2 BTBL1(6,6)
	InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
	InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
	EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
	EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
	EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
	EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
	COMMON /DECIDE/ DTBL1
	DATA DTBLIN/0/
	IF(IFUNC.NE.50)GOTO 34
	IF(DTBLIN.NE.0)RETURN
	DTBLIN=1
C FLAG WE DID THIS INITIALIZATION ONCE. SINCE BUFFER IS CLEARED WE MUST
C *** NOT *** DO IT AGAIN.
C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
C TYPES (WHICH ARE NOT SUPPORTED HERE)
C CALL SEPARATE ROUTINE TO CLEAR OUT THIS STUFF ONE-TIME. OVERLAY SAME.
C NOTE LOTS OF SILLY ARGUMENTS TO SUBROUTINE SINCE MS FORTRAN DISALLOWS
C EQUIVALENCES TO DUMMY ARGUMENTS.
	CALL WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,BTBL6,
     1  BTBL7,BTBL8)
C
C14      CONTINUE
CC FILE IS NOW CLEARED
	RETURN
34	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(ICHAR(IBYTE).NE.0)GOTO 1001
C UNINITIALIZED ARRAY ELEMENT: SET IT UP.
C JUST LEAVES DUMMY CELL CONTENTS WHERE NOTHING IS REALLY INIT'D.
	DO 1003 N=1,128
1003	ARRAY(N)=char(0)
	ARRAY(1)='P'
	ARRAY(2)='#'
	ARRAY(3)='0'
	ARRAY(5)='0'
	ARRAY(4)='#'
	ARRAY(118)=CHAR(15)
C NOTE ARRAY(119) (WHICH BECOMES FVLD) IS 0 TOO.
	DO 1004 N=1,9
1004	ARRAY(N+119)=DEFFMT(N)
C RETURN THE DEFAULT FORMAT NOW.
	RETURN
1001	CONTINUE
C HERE HAVE TO GET THE WHOLE THING REALLY
	DO 1053 N=1,128
1053	ARRAY(N)=char(0)
	ARRAY(119)=IBYTE
	ARRAY(118)=CHAR(15)
	ARRAY(1)=char(48)
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 76 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/2048)+1
C	IBF=64
CC	IBF=(2048+31)/32
C IBF IS NO. OF ENTRIES IN A BUFFER. OF 512 BYTES
C	IBF=32
	IBF=32
C	LLL=(LPGMXF)/IBF
C	LLL=LPGMXF
C IPM IS NO. PAGES MAX IN FILS
	IPM=LPGMXF/16
C EACH BUFFER HAS 16KB SO MAX PAGES IS (FILE LENGTH)/16
C	IPM=LLL
	IF(IPM.LT.2)IPM=2
C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
	IHASH=NREC
C	JHASH=IMASK(IHASH,2047)
	JHASH=MOD(IHASH,1024)
C	JHASH=IMASK(IHASH,1023)
C	JHASH=MOD(IHASH,2048)
	IF(LPGMOD.NE.0)GOTO 5305
C	IPAG=(IHASH/2048)+1
	IPAG=(IHASH/1024)+1
	IPAG=MOD(IPAG,IPM)+1
	GOTO 5306
5305	CONTINUE
C SPEED OPTIMAL PACK
	FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
	IPAG=FPG
	IPAG=MOD(IPAG,IPM)
	IPAG=IPAG+1
C	IPAG=1+(IHASH*IPM)/18060
5306	CONTINUE
C HERE DECIDED IF PAGE IS WHAT WE NEED.
C
C	IF(IPAG.LE.0)IPAG=1
C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
	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
C PAGE 1 IS THE ONE WE NEED.
	MFLAST=1
	MFBASE=0
	GOTO 1400
851	CONTINUE
C NEED SECOND PAGE
	MFLAST=2
	MFBASE=1024
C BASE IS HASFWAY ALONG FILE...
	GOTO 1400
854	CONTINUE
C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
	MFLAST=3-MFLAST
	MFBASE=1024-MFBASE
C SIMILAR LOGIC SAYS MFBAS4E IS EITHER 0 OR 1024. INITIALIZED IN
C WSSET TO 0.
C NOTE THAT IF MFLAST=1,MBFN=1 AND IF MFLAST=2,NEW MFLAST=1
C THIS GIVES BUFFER TO REPLACE... (LRU)
C
C IF MFLAST=2 REPLACE BUFFER 1, ELSE REPLACE BUFFER 0
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.32)GOTO 1400
C	IF(LPGMXF.LE.(2048/64))GOTO 1400
C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
C	IBF=32
CC	IBF=(1024+31)/32
C	IF(IBF.LT.1)IBF=1
C IBF IS BLK FACTOR FOR ONE WRITE
C WRITE 512 BYTES AT A TIME.
	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
	LL=L+31
	WRITE(7,REC=N,ERR=1170)((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 PAGE UNTOUCHED. READING DOES NOT ALTER DATA SO NO NEED
C TO WRITE OUT UNLESS MODIFIED.
	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,REC=N,ERR=1171)((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,1024
c	N=MOD((NN+JHASH-1),1024)
	N=MOD((NN+JHASH),1024)
	N=N+1+MFBASE
C	N=IMASK((NN+JHASH-1),1023)+1+MFBASE
	KKKKK=IFID(1,N)
	IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 2505
	IF(KKKKK.NE.NREC)GOTO 2500
	IFLAG=ICHAR(LFID(3,N))
	IF(IFMT.EQ.0)IFMT=ICHAR(LFID(4,N))
	DO 2502 K=1,12
	LI=LFID(K+4,N)
C COPY FORMULA TEXT INTO ARRAY. END ON NULLS...
	IF(ICHAR(LI).LE.0)GOTO 2505
	ARRAY(IARSUB)=LI
c null out following characters since -1's could be misinterpreted as data
	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)*60+ID1
C ID1 IS 60 DIM, ID2 IS 301 DIM
C	NRC2(2)=0
C	NRC2(1)=NREC
C JUST EQUATE NRC TO NREC
C ALLOW LATER FOR OVER 32768 ELEMENTS... NO NEED TO JUST YET
C WHEN WE DO, REPLACE NRC2 STUFF (WHOSE PURPOSE IS TO AVOID
C SIGN EXTENSIONS).
C NEXT KEEP TRACK OF LOWER RIGHT CORNER OF AREA IN USE.
	NRC=NREC-1
	IRUSED=MOD(NRC,60)+1
	ICUSED=((NRC-IRUSED+1)/60)+1
	IF(ICUSED.GT.RCLACT)RCLACT=ICUSED
	IF(IRUSED.GT.RRWACT)RRWACT=IRUSED
C SET RRWACT, RCLACT
	IF(ICHAR(ARRAY(119)).NE.0)CALL FVLDST(NREC,1,ARRAY(119))
	DO 2011 N=1,76
	IF(ICHAR(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=76
	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/2048)+1
	IBF=32
C	IBF=(2048+31)/32/2
C	LLL=(LPGMXF*2)/IBF
C	IPM=LLL
	IPM=LPGMXF/16
C IPM = NO. PAGES IN FILE. LPGMXF/(LENGTH OF ONE MEM BUFFER IN K).
	IF(IPM.LT.2)IPM=2
C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
	IHASH=NREC
C	JHASH=IMASK(IHASH,1023)
	JHASH=MOD(IHASH,1024)
	IF(LPGMOD.NE.0)GOTO 5307
	IPAG=(IHASH/1024)+1
	IPAG=MOD(IPAG,IPM)+1
	GOTO 5308
5307	CONTINUE
C SPEED OPTIMAL PACK
	FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
	IPAG=FPG
	IPAG=MOD(IPAG,IPM)
	IPAG=IPAG+1
C	IPAG=1+(IHASH*IPM)/18060
5308	CONTINUE
C ***
C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
	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 IS THE ONE WE NEED.
	MFLAST=1
	MFBASE=0
	GOTO 2400
951	CONTINUE
C NEED SECOND PAGE
	MFLAST=2
	MFBASE=1024
C BASE IS HASFWAY ALONG FILE...
	GOTO 2400
954	CONTINUE
C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
	MFLAST=3-MFLAST
	MFBASE=1024-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.32)GOTO 2400
C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
C	IBF=(1024+31)/32
C	IBF=32
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
	LL=L+31
	WRITE(7,REC=N,ERR=2170)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+32
2170	CONTINUE
C NOW READ IN THE DATA
C MARK NEW PAGE TOUCHED SINCE WE WILL DO SO HERE
C	MFMOD=1
	MFID(MFLAST)=IPAG
	L=1+MFBASE
	LLBK=(MFID(MFLAST)-1)*IBF+1
	LHBK=MFID(MFLAST)*IBF
	DO 2171 N=LLBK,LHBK
	LL=L+31
	READ(7,REC=N,ERR=2171)((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,1024
	N=MOD((NN+JHASH),1024)+1+MFBASE
C	N=IMASK((NN+JHASH),1023)+1+MFBASE
	KKKKK=IFID(1,N)
	IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 6233
C SKIP ZEROING ONCE WE ENCOUNTER A VIRGIN CELL SINCE WE WOULD ALWAYS
C CLEAR TO NONVIRGIN STATUS AFTERWARDS.
	IF(KKKKK.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,1024
	N=MOD((NN+JHASH),1024)+1+MFBASE
C	N=IMASK((NN+JHASH),1023)+1+MFBASE
	KKKKK=IFID(1,N)
	IF(KKKKK.NE.-1.AND.KKKKK.NE.0
     1     .AND.KKKKK.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)=CHAR(IFMT)
	LFID(3,N)=CHAR(IFLAG)
c zero new elements to ensure no extra -1's get handled as
c data. Important because they could be mistaken for cell codings now.
	do 4502 k=1,12
4502	lfid(k+4,n)=CHAR(0)
	DO 1502 K=1,12
	LI=ARRAY(IARSUB)
	IF(ICHAR(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(ICHAR(ARRAY(IARSUB)).LE.0)GOTO 1560
	IFLAG=2
	LFID(3,N)=CHAR(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)=CHAR(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(1,1,1)
	CALL SWRT('Formula file overflowed. Try larger file.',41)
1505	CONTINUE
C DONE NOW.
	GOTO 5000
3000	CONTINUE
C OPEN (CLR BITMAP)
	MFID(1)=0
	MFID(2)=0
	MFBASE=0
	MFLAST=1
	GOTO 5000
4000	CONTINUE
C CLOSE (CLR BITMAP)
	CLOSE(7,STATUS='DELETE')
	MFBASE=0
	MFLAST=1
	MFID(1)=0
	MFID(2)=0
5000	RETURN
	END
c -h- xvblgt.f40	Fri Aug 22 13:45:23 1986	
        SUBROUTINE XVBLGT(ID1,ID2,XX)
C
C XVBLGT - LOAD 8 BYTES GIVEN DIMENSIONS FOR GETTING THEM
C 2 DIM ARRAY, DIM'D (60,301)
        InTeGer*4 ID1,ID2
        REAL*8 XX
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1),VT(8)
	REAL*8 XXV(1,1),XVT
	EQUIVALENCE(XVT,VT(1))
	EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
	COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C NEXT BITMAPS IMPLEMENT FVLD
        CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
	CHARACTER*1 FVXX(6792)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
	EQUIVALENCE (FV4(1),FVXX(4529))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
        CHARACTER*1 ITYP(2264),LWK
        InTeGer*4 IATYP(27)
	INTEGER*2 LL(4)
	REAL*8 XA
	EQUIVALENCE(LL(1),XA)
        COMMON/TYP/IATYP,ITYP
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
        InTeGer*2 LVALBF(5,800)
        InTeGer*4 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 76 FORMAT
C AREAS WITH DATA.
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC        CHARACTER*1 FMTDAT(9,76)
CCC        COMMON/FMTBFR/FMTDAT
	IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
C AN ACCUMULATOR. GET IT.
	DO 7801 IV=1,8
7801	VT(IV)=AVBLS(IV,ID1)
	XX=XVT
	RETURN
7800	CONTINUE
C FILTER OUT TOO-LARGE ID1, ID2 THAT ARE "REFLECTED" UP
C        ID=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,ID)
        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(ICHAR(LWK).EQ.0)RETURN
C SET UP HASH CODE NOW FOR THE WAY WE NEED...
	IBF=8
C	IBF=(800+49)/50/2
C	IF(IBF.LT.1)IBF=1
C
C	LLL=(IPGMAX*2)/IBF
	LLL=IPGMAX/4
C WAS IPGMAX*2
	IPM=LLL
	IF(IPM.LE.2)IPM=2
	IHASH=ID
        JHASH=MOD(IHASH,400)+1
	IF(IPGMOD.NE.0)GOTO 3402
        IPAG=(IHASH/400)+1
        IPAG=MOD(IPAG,IPM)+1
	GOTO 3403
3402	CONTINUE
C SPEED-OPTIMIZING PACKING
	FPG=IPGMOD
C	IF(FPG.LE.0)FPG=FPG+65536.
	FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
	IPAG=FPG
	IPAG=MOD(IPAG,IPM)
	IPAG=IPAG+1
C	IPAG=1+(IHASH*IPM)/18060
3403	CONTINUE
C        IF(IPAG.LE.0)IPAG=1
C TAKE CARE OF EMPTY INITIAL BUFFER...
	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=400
	GOTO 1000
852	CONTINUE
	MVLAST=1
	MVBASE=0
	GOTO 1000
853	CONTINUE
C SWITCH BUFFER USED LEAST RECENTLY
	MVLAST=3-MVLAST
	MVBASE=400-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.
	IF(IPGMAX.LE.8)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(13,REC=N,ERR=500)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
        L=L+50
500     CONTINUE
	MPMOD(MVLAST)=0
C MARK NEW PAGE UNMODIFIED IN THIS READ PROGRAM
        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(13,REC=N,END=501,ERR=501)((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,400
	N=MMN+MVBASE
	NN=N
C SKIP OUT IF WE SEE VIRGIN CELLS, LEAVING XX=0.
	KKKKK=LVALBF(1,N)
	IF(KKKKK.EQ.-1)GOTO 3332
        IF(KKKKK.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
	KKKKK=LVALBF(1,N)
	IF(KKKKK.EQ.-1)GOTO 3332
        IF(KKKKK.EQ.ID)GOTO 4
3       CONTINUE
3332	XX=0.
        RETURN
C RETURN IF CAN'T FIND VALUE...TOO BAD
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
c -h- xvblst.f40	Fri Aug 22 13:45:23 1986	
        SUBROUTINE XVBLST(ID1,ID2,XX)
C
C XVBLST - STORE 8 BYTES IN VARIABLES ARRAY
C GIVEN DIMENSIONS FOR LOCATING THEM
        InTeGer*4 ID1,ID2
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1),VT(8)
	REAL*8 XVT
	EQUIVALENCE(VT(1),XVT)
	REAL*8 XXV(1,1)
	EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
        REAL*8 XX
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C NEXT BITMAPS IMPLEMENT FVLD
        CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
	CHARACTER*1 FVXX(6792)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
	EQUIVALENCE (FV4(1),FVXX(4529))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
        CHARACTER*1 ITYP(2264)
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
        InTeGer*4 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 76 FORMAT
C AREAS WITH DATA.
        CHARACTER*1 LLTST
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC        COMMON/FMTBFR/FMTDAT
        InTeGer*2 LVALBF(5,800)
        InTeGer*4 MPAG(2),MPMOD(2)
        COMMON/VB/MPAG,LVALBF,MPMOD
	InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
	COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
        InTeGer*2 LL(4)
        REAL*8 XA
        EQUIVALENCE(XA,LL(1))
CCC	InTeGer*4 NCEL,NXINI
CCC	COMMON/NCEL/NCEL,NXINI
	IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
C AN ACCUMULATOR. SET IT.
	XVT=XX
	DO 7801 IV=1,8
7801	AVBLS(IV,ID1)=VT(IV)
	RETURN
7800	CONTINUE
C        ID=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,ID)
C SET UP HASH CODE NOW FOR THE WAY WE NEED...
C       IPM=(IPGMAX*200/800)
	IF(ID.LE.0)RETURN
C CALL FVLDGT TO TELL IF ANYTHING IS SET FOR THE CELL...
	CALL FVLDGT(ID1,ID2,LLTST)
	IF(ICHAR(LLTST).NE.0)GOTO 3419
	CALL FVLDST(ID1,ID2,Char(252))
c 252 = -4 to 8 bits
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=8
C	IBF=(800+49)/50/2
C	IF(IBF.LT.1)IBF=1
	LLL=IPGMAX/4
C 4000 BYTES PER BUFFER (400 CELLS AT 10 PER CELL)
C	LLL=(IPGMAX*2)/IBF
C WAS IPGMAX*2
	IPM=LLL
	IF(IPM.LE.2)IPM=2
	IHASH=ID
        JHASH=MOD(IHASH,400)+1
	IF(IPGMOD.NE.0)GOTO 3400
C SPACE-OPTIMIZING PACKING
        IPAG=(IHASH/400)+1
        IPAG=MOD(IPAG,IPM)+1
	GOTO 3401
3400	CONTINUE
C SPEED-OPTIMIZING PACKING
	FPG=FLOAT(IPGMOD)
C	IF(FPG.LE.0.)FPG=FPG+65536.
	FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
	IPAG=FPG
	IPAG=MOD(IPAG,IPM)
	IPAG=IPAG+1
C	IPAG=1+(IHASH*IPM)/18060
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=400
	GOTO 1000
852	CONTINUE
	MVLAST=1
	MVBASE=0
	GOTO 1000
853	CONTINUE
C NEED NEW PAGE. FIX TO USE LEAST RECENTLY USED PAGE FOR SWAPOUT.
	MVLAST=3-MVLAST
C MVLAST = 1 OR 2
	MVBASE=400-MVBASE
C MVBASE = 0 OR 400. INITIALLY 0.
C        IF(MPAG.EQ.0)MPAG=IPAG
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.8)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(13,REC=N,ERR=500)((LVALBF(KK,K),KK=1,5),K=L,LLL)
        L=L+50
500     CONTINUE
C MARK NEW PAGE MODIFIED SINCE WE WILL TOUCH IT HERE
	MPMOD(MVLAST)=1
        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(13,REC=N,END=501,ERR=501)((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
	IF(NXINI.NE.0)GOTO 111
        IH1=JHASH-1
        DO 1 MMN=JHASH,400
	N=MMN+MVBASE
C WHILE ZEROING THE ARRAY, START AT THE HASH ADDRESS AND STOP THE ZEROING
C ONCE WE ENCOUNTER A VIRGIN RECORD. THIS WILL HOPEFULLY REDUCE OVERALL
C TIME MOST TIMES FOR ZEROING THE ARRAY.
	KKKKK=LVALBF(1,N)
	IF(KKKKK.EQ.-1)GOTO 111
        IF(KKKKK.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
	NN=N
	KKKKK=LVALBF(1,N)
	IF(KKKKK.EQ.-1)GOTO 111
        IF(KKKKK.NE.ID)GOTO 33
	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,400
	N=MMN+MVBASE
	NN=N
	KKKKK=LVALBF(1,N)
	IF(KKKKK.EQ.-1)GOTO 4
        IF(KKKKK.EQ.0)GOTO 4
	IF(KKKKK.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.
	KKKKK=LVALBF(1,N)
	IF(KKKKK.EQ.-1)GOTO 4
        IF(KKKKK.EQ.0)GOTO 4
	IF(KKKKK.EQ.ID)GOTO 4
3       CONTINUE
C TELL USER VALUE AREA OVERFLOWED, USING ROW 1 END
	CALL UVT100(1,1,1)
	CALL SWRT('Value Table Storage overflowed. Try larger file.',48)
        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
c -h- zero.for	Fri Aug 22 13:46:23 1986	
	SUBROUTINE ZERO
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *         SUBROUTINE  ZERO                       *
C *                                                *
C **************************************************
C
C
C
C  ZEROS OUT ALL VARIABLES EXCEPT %
C
C
C ZERO CALLS IABS
C
C
C ZERO IS CALLED BY CMND
C
C
C
C   VARIABLE    USE
C
C      I      POINTS TO VARIABLE
C      J      INDEXES DOWN ELEMENTS OF A VARIABLE
C
C
C
C	SUBROUTINE ZERO
C
	InTeGer*4  TYPE(1,1),VLEN(9)
C
	CHARACTER*1  AVBLS(20,27)
	CHARACTER*1 VBLS(8,1,1)
C
	COMMON  /V/TYPE,AVBLS,VBLS,VLEN
C
C
C
C JUST ZERO THE ACCUMULATORS HERE ... LEAVE REGULAR SHEET STUFF ALONE.
C	TYPE(1,1)=IABS(TYPE(1,1))
	VBLS(1,1,1)=0
C ZERO OUT ACCUMULATORS
	DO 1 I=1,27
	DO 1 J=1,20
1	AVBLS(J,I)=0
	RETURN
	END
c -h- zneg.for	Fri Aug 22 13:46:23 1986	
	INTEGER FUNCTION ZNEG(INDXX)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *        InTeGer*4 FUNCTION ZNEG(INDXX)          *
C *                                                *
C **************************************************
C
C DETERMINES IF VARIABLE POINTED TO BY INDXX IS ZERO OR NEGATIVE
C OR UNDEFINED AS OPPOSED TO BEING DEFINED AND POSITIVE
C
C     RETURNS      1   IF TRUE (ZERO OR NEGATIVE OR UNDEFINED)
C                  0   IF FALSE (POSITIVE)
C
C ZNEG CALLS ERRMSG TO PRINT ERROR MESSAGES.
C
C ZNEG IS CALLED BY CALC AND CMND.
C
C   VARIABLE       USE
C
C     INDXX      POINTER TO VARIABLE BEING TESTED
C     I,K        HOLDS TEMPORARY VALUES
C     ZNEG       RETURN VALUE
C     INT        HOLD INTEGER*4 VALUES
C     REAL       HOLD REAL*8 VALUES
C
C
C
C	INTEGER FUNCTION ZNEG*4(INDXX)
	REAL*8 REAL
C
	INTEGER*4 INT
C
	InTeGer*4 TYPE(1,1),VLEN(9),INDXX
C
	CHARACTER*1 AVBLS(20,27),FOUR(4),EIGHT(8)
	CHARACTER*1 VBLS(8,1,1)
C
	EQUIVALENCE (EIGHT,REAL),(FOUR,INT)
C
	COMMON/V/ TYPE,AVBLS,VBLS,VLEN
C
C DEFAULT SETTING OF TRUE
	ZNEG=1
	CALL TYPGET(INDXX,1,K)
C	K=TYPE(INDXX,1)
	IF(K.GT.0)GO TO 50
C
C VARIABLE UNDEFINED
	CALL UVT100(1,1,1)
	CALL SWRT('Undefined Vbl',13)
C	CALL ERRMSG(16)
	GO TO 10000
C
50	GOTO(100,200,300,300,400,400,400,300,200),K
	STOP 50
C
C ASCII
100	IF(AVBLS(1,INDXX).LE.0)GO TO 10000
	GO TO 9998
C
C DECIMAL AND REAL
200	DO 210 I=1,8
210	EIGHT(I)=AVBLS(I,INDXX)
	IF(REAL.LE.0.D0)GO TO 10000
	GO TO 9998
C
C INTEGER, HEX, AND OCTAL
300	DO 310 I=1,4
310	FOUR(I)=AVBLS(I,INDXX)
	IF(INT.LE.0)GO TO 10000
	GO TO 9998
C
C MULTIPLE PRECISION
400	IF(ICHAR(AVBLS(20,INDXX)).NE.0) GOTO 10000
	GO TO 9998
C
9998	ZNEG=0
10000	RETURN
	END
