Gold Fish 1/GoldFishApril1994_CD1.img/d1xx/d144/analyticalc/analysources.arc/AnalyTZ.Ftn

Text File | 1988-04-10 | 107KB | 3,703 lines

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 >>>***
CCC    COMMON/CONSFH/FH
    NAME="RAW:0/0/630/199/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