c ********** ANALYAC.FTN ##########################################
C This version of AnalytiCalc uses the include file AParms.inc to
C contain parameters. These specify the "prime area" of the
C spreadsheet, and also the size of in-memory buffers that
C are used for in-memory storage of spreadsheet data. Larger
C spreadsheets may of course be stored using the software
C paging built in, but at much reduced speed.
C  Glenn Everhart 9/20/1989
C
C parameter relationships implicit below:
C mval, nominal 800, multiple of 100
C mfrm, nominal 2048, multiple of 128
C Mvlov2=mval/2
C mfrmo2=mfrm/2
C MVal/16=mvlo16
C mfrm/64=mfro64
c -h- analy.for	Fri Aug 22 12:54:45 1986	
       PROGRAM ANALY(INPUT=15,OUTPUT=16,TAPE=17,ERR=1)
C ANALYTICALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
	Include aparms.inc
C COPYRIGHT (C) 1983-1990 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C MAX SHEET DIMS ARE MCOLS BY mrows-1 (MROWS SINCE ACCUMULATORS ARE A PSEUDO ROW)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
C
	InTeGer*4 PRL(6)
        CHARACTER*1 NOWRAP ( 2 )
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	INTEGER IFCW
C	EXTERNAL LCWRQQ
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C
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,k3dfg,kcdelt,krdelt,kpag
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,igold
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 Idsptp,Idol9
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
C ***<<< RDD COMMON END >>>***
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XXV(1,1)
	EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
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))
	CHARACTER*12 CDVFMT
	EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
	COMMON/DEFVBX/DVFMT
	CHARACTER*1 NMSH(80)
	CHARACTER*80 NMSH80
	EQUIVALENCE(NMSH80(1:1),NMSH(1))
	COMMON/NMSH/NMSH
	CHARACTER*1 FORM2(4)
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	INTEGER*4 I4TMP
	REAL*8 DVS(20,75)
	COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
	REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
	InTeGer*4 QCAC,QCENT(8),ACV(8)
	COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
C BITMAP
C	CHARACTER*1 IBITMP
C	DIMENSION IBITMP(2258)
C	COMMON/INITD/IBITMP
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
C	character*35 fwt
C COMMONS FROM OTHER MISC. ROUTINES, ADDED TO ALLOW AMIGA FORTRAN TO
C ALLOCATE COMMONS ON STACK...
	CHARACTER*1 LBITS(8)
	COMMON/BITS/LBITS
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	COMMON/CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	CHARACTER*1 DTBL1(9,9,8)
	COMMON/DECIDE/DTBL1
	CHARACTER*1 DIGITS(16,3)
	COMMON/DIGV/DIGITS
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 >>>***
C
C
        CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
	CHARACTER*1 FVXX(Imps3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
	EQUIVALENCE (FV4(1),FVXX(Imp3s))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
	InTeGer*2 IFID(8,MFrm)
	COMMON/IFIDC/IFID
	InTeGer*4 ILNFG,ILNCT
	CHARACTER*1 ILINE(106)
	COMMON/ILN/ILNFG,ILNCT,ILINE
	InTeGer*4 ITCNTV(6)
	COMMON/ITERA/ITCNTV
	InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
	InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
	InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
	COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
     1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
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,MROWS)
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 >>>***
	CHARACTER*1 STACK1(8,40),STACK2(8,40)
	InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
	COMMON/STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     1  ST1LIM,ST2LIM
	InTeGer*4 IATYP(27),LINTGR
	CHARACTER*1 ITYP(Imp1s)
	COMMON/TYP/IATYP,ITYP,LINTGR
	InTeGer*4 MPAG(2),MPMOD(2)
	InTeGer*2 LVALBF(5,800)
	COMMON/VB/MPAG,LVALBF,MPMOD
	InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
	COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
	InTeGer*4 LEVEL,NONBLK,LEND,VIEWSW,BASED
	CHARACTER*1 LINE(80)
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C *** END COMMONS FROM OTHER PLACES.
	Character*1 IYN
	FH=0
	NCEL=0
c	IFCW=4927
C DISABLE FLOATING EXCEPTIONS
c	CALL LCWRQQ(IFCW)
C INITIAL DEFAULT FORMAT FOR NUMERICS is set at runtime
C INIT COMMON DATA FIRST OF ALL.
	IDOL7=1
C INITIALLY IN ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
	CALL BLOCK
	IKONS=0
	write(*,6402)
6402	Format(' Compiled by Absoft Fortran 2.3.')
        IYN=27
        Write(*,6398)iyn,iyn
6398    Format(A,'[H',A,'[J')
	Write(*,6403)
6403	Format(' Is Workbench screen 640 by 400 or over [Y/N]:')
	IDSPTP=0
	Read(*,6406)IYN
6406	Format(1A1)
	If(IYN.eq.'Y'.or.IYN.eq.'y')IDSPTP=1
c IDSPTP now is 0 for non interlace, 1 for interlace.
	CALL INITA1(KMAP,KWID,ICODE)
3002	CONTINUE
	CALL INITA2(KMAP,KWID,ICODE,IKONS)
	IKONS=1
3000	CONTINUE
	CALL INITB(KMAP,KWID,ICODE)
	LINIZZ=0
C	IF(IOLDFL.GT.1)GOTO 2000
2000	CONTINUE
C DRAW OUR LABELS AND OTHERWISE INITIALIZE DISPLAY SHEET
	KZPPD=0
	IF(IPSET.NE.0)GOTO 1000
	IF(PZAP.EQ.0)CALL UVT100(11,2,0)
	CALL UVT100(1,1,1)
	OSWIT=20
	IPRSS=PROW
	IPCSS=PCOL
	IDRW=DROW
	IDCL=DCOL
	IF(LINIZZ.LE.1)CALL RECALC
	IF(PZAP.EQ.0)CALL DSPSHT(2)
	DCOL=IDCL
	DROW=IDRW
	PROW=IPRSS
	PCOL=IPCSS
3006	FORMAT(80A1)
C
1000	CONTINUE
	IPSET=0
	LINIZZ=LINIZZ+1
	OSWIT=20
C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
	ICODE=0
	CALL XQTCMD(ICODE)
	IF(ICODE.LT.30)GOTO 1843
C HELP COMMAND AND SIMILAR...
	IF(ICODE.NE.400)GOTO 1847
	CALL DSPSHT(10)
	ICODE=1
C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
	GOTO 1843
1847	CONTINUE
	IF(ICODE.NE.420)GOTO 1849
C CLOSE UNIT 1 JUST IN CASE...
	CLOSE(1)
	KLVL=1
	IPRSSS=PROW
	IPCSSS=PCOL
	CALL CALC
	PROW=IPRSSS
	PCOL=IPCSSS
C CLOSE CONSOLE LUN USED BY CALC.
	CLOSE(1)
C CLOSE ANY OTHER LUNS CALC MAY HAVE USED...
	CLOSE(2)
	CLOSE(3)
C SET UP FOR REDRAW WHEN BACK...
	ICODE=-1
	GOTO 1843
1849	CONTINUE
	IF(ICODE.NE.430)GOTO 1845
C TEST FUNCTION, TESTING EXPRESSION.
C INHIBIT RECALCULATION...
C COMMAND IS IN "XTNCMD" STRING.
	LLST=MIN0(80,XTNCNT+1)
	LFST=1
	CALL DOENTR(XTNCMD,LFST,LLST)
C THIS SETS % VARIABLE AND WILL DO A CALC DIRECTLY. THEREFORE
C WE MUST INHIBIT AUTO RECALCULATION.
C NOTE WE HAVE TO CALL THIS FROM THE ROOT SINCE THE RECALC OVERLAY
C TREE OVERWRITES THE XQTCMD ONE.
	ICODE=1
	GOTO 1843
1845	CONTINUE
	IVVV=ICODE-30
9308	CALL HELP(IVVV)
	IVVV=0
	CALL VWRT('Type return to continue, Hn for other Help pages:',
     1  49)
	ILL=IOLVL
C	IF(ILL.EQ.5)ILL=0
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)(FORM2(K),K=1,4)
	if(ill.eq.11)call vget(form2,4)
	IVVVV=ichar(FORM2(2))
	IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
	IF(FORM2(1).EQ.'H'.OR.FORM2(1).EQ.'h')GOTO 9308
C NOW CLEAR SCREEN AND TRY MORE COMMANDS AS BEFORE...
	ICODE=6
C
1843	CONTINUE
	OSWIT=20
	IPRSS=PROW
	IPCSS=PCOL
	IDRW=DROW
	IDCL=DCOL
	IF(LINIZZ.LE.1)CALL RECALC
	IF(IPSET.NE.0)GOTO 4110
	DCOL=IDCL
	DROW=IDRW
	PROW=IPRSS
	PCOL=IPCSS
4110	CONTINUE
	IPSET=0
	IF(ICODE.EQ.-1)GOTO 2000
C IN PORTACALC-VM, S COMMAND ALLOWS DEFAULT FORMAT CHANGE AND
C TITLE CHANGE, BUT DOES NOT ALTER SHEET IN MEMORY... DON'T ALLOW
C SCRATCH FILE SAVE STUFF...
C	IF(ICODE.EQ.-2)CALL WRKFIL(1,FORM,3)
C	IF (ICODE.EQ.-2)CALL CLOSE(7)
	IF(ICODE.LE.-2)GOTO 3002
C
C RECALCULATE SHEET NOW AUTOMAGICALLY
C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
C THE ENTIRE SHEET.
C LIMIT NUMBER OF ITERATIONS AT ANY ONE TIME TO 20 HOWEVER
	KKMAX=20
3670	CONTINUE
	IF(ICODE.EQ.5.OR.ICODE.EQ.1
     1  .OR.ICODE.EQ.6.OR.RCFGX.EQ.1)GOTO 3671
	CALL RECALC
	IPSET=0
	KKMAX=KKMAX-1
C IMPLEMENT VARY LOOP...
C ASSUME USRFCT MUSTR CONTOL KALKIT VARIABLE THEN TO GET LOOP TO
C TERMINATE SOMETIME.
	KKMAX=MIN0(KKMAX,KALKIT)
	IF(KKMAX.GT.0)GOTO 3670
3671	CONTINUE
C	IF(ICODE.NE.1.AND.RCFGX.NE.1)CALL RECALC
C
C DISPLAY SHEET NOW. ONLY ALTERS ENTRIES INVALIDATED BY COMMAND.
	IF(ICODE.NE.2.AND.ICODE.NE.6)GOTO 21
C ICODE=2 = REFRESH DISPLAY. ZERO ALL NUMBERS AND CAUSE TOTAL REDISPLAY.
	DO 22 N1=1,20
	DO 22 N2=1,75
C SET NUMBER DISPLAYED TO WEIRD VALUE.
22	DVS(N1,N2)=DVS(N1,N2)+.000000000034
	IF(PZAP.EQ.0)CALL UVT100(11,2,0)
	CALL UVT100(1,1,1)
21	CONTINUE
	IF(ICODE.EQ.6)ICODE=2
	IF(ICODE.NE.5.AND.PZAP.EQ.0)CALL DSPSHT(ICODE)
	DCOL=IDCL
	DROW=IDRW
	PROW=IPRSS
	PCOL=IPCSS
	GOTO 1000
5600	CONTINUE
C ERROR ON READ FROM IOLVL HANDLED HERE.
c	REWIND 5
c	CLOSE(11)
c	OPEN(11,FILE='CON:50/150/300/40/Analy Command',STATUS='OLD',
c     1  FORM='FORMATTED')
	CLOSE(3)
	IOLVL=11
	GOTO 1000
	END
c -h- assign.for	Fri Aug 22 12:56:01 1986	
	SUBROUTINE ASSIGN(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	InTeGer*4 IUNIT
C &&&& MS FTN 3.2
	LOGICAL LEXIST
C &&&&
	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	CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C	INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
	INQUIRE(FILE=WK,EXIST=LEXIST)
	IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
	CALL UVT100(1,1,1)
	CALL SWRT('File not found. Using window instead.',37)
	Open(IUNIT,'CON:200/100/300/80/Nonexistent file')
C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
C WILL GET EOF ON START, BUT THAT'S TOO BAD...
	Return
100	CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
	OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
77	CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
	RETURN
	END
c -h- at.for	Fri Aug 22 12:56:23 1986	
	SUBROUTINE AT (RETCD)
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  AT                            *
C *                                                     *
C *******************************************************
C SUBROUTINE AT IS CALLED WHEN THE  *@  CALC COMMAND IS ENCOUNTERED.
C IT CHANGES  THE  VALUE  OF LEVEL  WHICH  HOLDS THE  NUMBER OF THE
C LOGICAL  I/O  UNIT WHERE INPUT COMMAND LINES ARE TO BE OBTAINED.
C THE FILE ASSOCIATED WITH THAT I/O UNIT IS OPENED UNDER THE PROPER
C CONDITIONS.
C
C MODIFICATION CLASSES: M1,M2,M9
C
C      MODIFIED 3-OCT-77 P.B.
C      MODIFIED 10-JAN-78 P.B.  TO PUT SY: BEFORE FILENAMES
C         WITH NO DEVICE SPECIFIED SO THAT DEFAULT IS USER'S SY:
C         AND NOT THE SYSTEM SY:
C
C
C    AT CALLS
C
C  ASSIGN  (TO ASSOCIATE A FILE NAME WITH A LOGICAL I/O UNIT)
C  ERRMSG  (TO PRINT ERROR MESSAGES)
C  GETNNB  (TO GET NEXT NON-BLANK FROM THE INPUT LINE)
C  ZNEG    (TO TEST IF A VARIABLE IS POSITIVE)
C
C
C
C   AT IS CALLED BY ROUTINE CMND WHICH IS THE MODULE THAT DETERMINES
C   WHAT CALC COMMAND WAS REQUESTED.
C
C
C
C         VARIABLE          USE
C
C   ALPHA(27)         HOLDS LEGAL VARIABLE NAMES.
C   I,J               HOLD TEMPORARY VALUES.
C   IPT               POINTS TO NEXT NON-BLANK CHARACTER IN LINE(80).
C   ITCNTV(6)         INDEXED BY LEVEL. HOLDS 0 IF NO ITERATION ON THAT
C                     LEVEL, OTHERWISE INDEX INTO VBLS FOR THE VARIABLE
C                     THAT CONTROLS ITERATION.
C   LEVEL             HOLDS NUMBER OF LOGICAL I/O UNIT WHERE NEXT INPUT
C                     LINE IS EXPECTED.
C   LINE(80)          HOLDS COMMAND INPUT LINE.
C   NBLINE(78)        HOLDS THE INPUT FILE NAME WITHOUT BLANKS.
C   NONBLK            POINTS TO THE LAST NON-BLANK CHARACTER IN LINE(80).
C   RETCD             RETURN CODE: 1=O.K.  2=ERROR.
C   SY                "SY:" USED TO OPEN FILES WITH A DEFAULT OF
C                     USER'S SY: (OTHERWISE SYSTEM SY: IS USED) P.B.
C                     10-JAN-78
C
C
C
C	SUBROUTINE AT (RETCD)
C
	InTeGer*4 IPT,J,I
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 RETCD,VIEWSW,BASED
	InTeGer*4 ITCNTV(6),ZNEG
C
	CHARACTER*1  LINE(80),NBLINE(78)
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C	CHARACTER*1 SY(3)
C
C
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON/ITERA/ITCNTV
C
C	DATA SY/'S','Y',':'/
C
C
C
C UPON ENTRANCE, NONBLK POINTS TO THE CHARACTER @
C
C  MODIFICATION CLASSES:  M1,M2,M9
C
C PICK UP FIRST NON-BLANK AFTER THE @
	CALL GETNNB(IPT,RETCD)
	GO TO (10,1050),RETCD
	STOP 10
C
C
C START BUILDING FILE NAME AS A COMPRESSED VERSION (BLANKS REMOVED)
C OF THE REST OF LINE(80)
10	J=0
15	NONBLK=IPT
	J=J+1
	NBLINE(J)=LINE(NONBLK)
	CALL GETNNB(IPT,RETCD)
	GO TO (15,50),RETCD
	STOP 50
C
C
C SET RETURN CODE AND INDICATE THAT WE WILL BE AT A NEW LEVEL.
C J HOLDS THE COUNT OF THE NUMBER OF CHARACTERS IN NBLINE.
C IF J=1 THEN NO ITERATION IS POSSIBLE BECAUSE FILENAME IS THE
C SINGLE CHARACTER.
50	RETCD=1
	LEVEL=LEVEL+1
	IF (LEVEL.GT.6) GOTO 1000
C
	IF(J.EQ.1) GO TO 200
C
C NBLINE HOLDS THE COMPRESSED FILENAME. NOW WE CHECK TO SEE IF AN
C ITERATION VARIABLE WAS SPECIFIED. THIS IS INDICATED BY A LEGAL
C VARIABLE NAME PRECEEDED BY A BLANK (IN LINE(80))
C NOTE THAT ONLY ONE OF THE ACCUMULATORS A-Z MAY BE USED FOR THIS.
	DO 60 I=1,27
C A-Z OR % LEGAL
	IF(ALPHA(I).EQ.LINE(NONBLK))GO TO 100
60	CONTINUE
	GO TO 200
100	IF(LINE(NONBLK-1).NE.BLANK)GO TO 200
C
C
C ITERATION INDICATOR IS PRESENT
C (ALPHABETIC CHARACTER OR % PRECEEDED BY A BLANK)
C IF THE VALUE OF THE VARIABLE IS NOT POSITIVE, THE FILE IS IGNORED.
	IF(ZNEG(I).EQ.1)GO TO 150
C
C
C RETAIN INDEX INTO VBLS AND DECREASE J SO THAT THE FILENAME
C DOES NOT INCLUDE THE ITERATION SPECIFICATION.
	ITCNTV(LEVEL)=I
	J=J-1
	GO TO 300
C
C
C FILE NOT ENTERED, ITERATION VARIABLE IS ZERO, NEGATIVE, OR UNDEFINED
150	LEVEL=LEVEL-1
	GO TO 350
C
C
C IF NO ITERATION, SET ITCNTV TO ZERO BECAUSE NOT ZEROED BY EXIT
C ROUTINES
200	ITCNTV(LEVEL)=0
300	CONTINUE
	NBLINE(J+1)=0
C	OPEN(UNIT=LEVEL,NAME=NBLINE)
C	CALL RASSIG (LEVEL,NBLINE,J)
	CALL RASSIG (LEVEL,NBLINE)
350	RETURN
C
C *** ERROR PROCESSING ***
C
C  TOO MANY LEVELS
1000	I=2
1010	CALL ERRMSG(I)
1020	RETCD=2
	RETURN
C
C
C UNIDENTIFIED COMMAND (ARGUMENT)
1050	I=3
	GO TO 1010
	END
c -h- bascng.for	Fri Aug 22 12:57:23 1986	
	SUBROUTINE BASCNG(RETCD)
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 SUBROUTINE BASCNG IS CALLED WHEN THE *B CALC COMMAND IS
C ENCOUNTERED. THIS COMMAND INDICATES THAT THE DEFAULT BASE
C FOR CONSTANTS IS TO BE CHANGED. THE ROUTINE READS IN ONE
C OR TWO DIGITS AND CHANGES THE DEFAULT BASE SPECIFICATION
C AS IS APPROPRIATE.
C
C MODIFICATION CLASS M2
C
C   BASCNG CALLS
C
C  ERRMSG  (PRINTS ERROR MESSAGES)
C  GETNNB  (GETS THE NEXT NON-BLANK IN INPUT LINE LINE(80))
C
C
C  BASCNG IS CALLED BY ROUTINE CMND WHICH IDENTIFIES THE COMMAND THAT
C  THE USER WANTS TO EXECUTE.
C
C
C    VARIABLE       USE
C
C    BASED       HOLDS THE DEFAULT BASE.
C    IPT         POINTS TO THE NEXT NON-BLANK IN LINE(80).
C    I1          BINARY VALUE OF FIRST DIGIT, VALUE OF NEW BASE.
C    I2          BINARY VALUE OF SECOND DIGIT.
C    NONBLK      POINTS TO THE LAST NON-BLANK IN LINE(80)
C    RETCD       RETURN CODE: 1=O.K.  2=ERROR.
C    RETCD2      HOLDS RETURN CODE FROM CALL TO GETNNB
C
C
C
C
C	SUBROUTINE BASCNG(RETCD)
C
C
C UPON ENTRANCE, NONBLK POINTS TO THE 'B' IN '*B' IN LINE
C
	InTeGer*4 IPT,I1,I2
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
C
	CHARACTER*1 DIGITS(16,3),LINE(80)
C
	COMMON /DIGV/ DIGITS
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C IF NO ARGUMENT, RETURN WITH NORMAL RETURN CODE. THIS ALLOWS THE
C USER TO SEE WHAT THE PRESENT DEFAULT BASE IS.
	RETCD=1
	CALL GETNNB(IPT,RETCD2)
	IF(RETCD2.GT.1)GO TO 1000
C
C
C CHECK OUT FIRST DIGIT
	DO 300 I1=1,10
	IF(DIGITS(I1,1).EQ.LINE(IPT)) GO TO 400
300	CONTINUE
	GO TO 999
C
C
C SEE IF THERE IS A SECOND DIGIT
400	NONBLK=IPT
	IF(I1.EQ.10)I1=0
	CALL GETNNB(IPT,RETCD2)
	IF(RETCD2.EQ.1)GO TO 500
C
C
C IF NOT, CONVERT TO A TWO DIGIT NUMBER WITH A LEADING ZERO.
	I2=I1
	I1=0
	GO TO 700
C
C A SECOND CHARACTER WAS FOUND; FIGURE OUT WHAT THE BINARY
C VALUE IS (IF IT IS A DIGIT AT ALL).
500	DO 600 I2=1,10
	IF(DIGITS(I2,1).EQ.LINE(IPT))GO TO 700
600	CONTINUE
	GO TO 999
C
C CONVERT DIGITS TO A NUMBER IF IT IS LEGAL
700	IF(I2.EQ.10)I2=0
	I1=I1*10+I2
	IF(I1.NE.8.AND.I1.NE.10.AND.I1.NE.16) GO TO 999
	BASED=I1
	GO TO 1000
C
C
C ILLEGAL BASE SPECIFICATION
999	RETCD=2
	call vwrt(' Illegal Base. (Only 8,10, and 16 OK). Ignored.',
     1  48)
c	WRITE(11,998)
c998	FORMAT(' Illegal Base. (Only 8,10,and 16 OK). Ignored.')
C	CALL ERRMSG(19)
C
C RETURN
1000	RETURN
	END
c -h- blkdat.for	Fri Aug 22 12:57:49 1986	
	BLOCK DATA
C COPYRIGHT 1983 GLENN C.EVERHART
C ALL RIGHTS RESERVED
	Include AParms.inc
C	InTeGer*4 MFID(2),MFMOD(2)
	InTeGer*2 IFID(8,MFrm)
	COMMON/IFIDC/IFID
	CHARACTER*1 LFID(16,MFrm)
	EQUIVALENCE(IFID(1,1),LFID(1,1))
C	COMMON/FRM/MFID,MFMOD
	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.
c	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
cc	DATA DTBLIN/0/
	DATA BTBL1 /4,2,3,4,8,9,
     1  6*0,0,2,0,0,0,9,0,2,0,0,0,9,
     2  0,2,3,0,0,9,0,2,4*0/
	DATA BTBL2/
     3  4,5*0,2,0,3*2,0,3,3*0,2*0,4,3*0,2*0,
     4  8,5*0,9,0,3*9,0/
	DATA BTBL3/4,2,3,4,8,9,
     5  6*2,3,2,3,3,3,9,4,2,3,4,4,9,
     6  8,2,3,4,8,9,9,2,4*9/
	DATA BTBL4/
     7  4,2,3,4,8,9,6*2,3,2,3,3,3,9,4,2,3,4,4,9,
     8  8,2,3,4,8,9,
     9  9,2,4*9/
	DATA BTBL5/4,2,3,3*4,6*0,6*0,6*0,
     1  6*0,6*0/
	DATA BTBL6/4,3*0,4,0,4,3*0,0,0,4,3*0,2*0,4,3*0,2*0,
     2  4,3*0,2*0,
     3  4,3*0,2*0/
        DATA BTBL7/4,2,3,3*4,6*2,6*3,6*4,
     4  6*8,6*9/
	DATA BTBL8/4,1,4,4,4,3,2,1,2,2,2,1,4,3,4,4,
     5  4,3,4,3,4,4,4,3,4,3,4,4,
     6  4,3,2,1,2,2,2,1/
	END
c -h- ca2e.for	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CA2E(LNIN,LNOUT)
C CONVERT NORMAL ASCII FORM TO ENCODED
	INCLUDE APARMS.INC
	CHARACTER*1 NAME(4),NUMBER(6)
	CHARACTER*1 LNIN,LNOUT
	CHARACTER*6 NUMBR6
	EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
	DIMENSION LNIN(128),LNOUT(128)
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
C	LOGICAL*2 L63,L192,L255,L128
	LOGICAL*4 L1,L2
C	InTeGer*4 I63,I192,I255,I128
	InTeGer*4 I63,I192,I127
	InTeGer*4 I1,I2
C	EQUIVALENCE(L128,I128)
C	EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
	EQUIVALENCE (I1,L1),(I2,L2)
C	DATA I63/63/,I192/192/,I255/255/,I128/128/
	DATA I63/63/,I192/192/,I127/127/
	LI=1
	LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100	CONTINUE
	LCC=ICHAR(LNIN(LI))
	IF(LCC.EQ.255)GOTO 500
C IF BINARY FORM, COPY 3 BYTES TO AVOID ERRORS.
D	If(K3dfg.gt.0)goto 200
	IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
	IL1=LI
	LE=110
	LSTC=LE
	CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
C AVOID MESSING UP FUNCTION NAMES
	IF(ID2.EQ.1)IVLD=0
	IF(IDOL1.NE.0.OR.IDOL2.NE.0)IVLD=0
C ONLY REPACK NORMAL FORM NAMES
C NOTE THAT SINCE THESE HAVE $ AFTER THE FIELDS, NO PARTIAL NAME
C WILL EVER GET RECOGNIZED WITHOUT IDOL1 OR IDOL2 GETTING SET.
	IF(IVLD.EQ.0)GOTO 200
C ALIASED NAMES MIGHT GET SCANNED WITHIN PRIME AREA IF THE FIRST
C ONE OR TWO CHARS GET STRIPPED OFF, SO TREAT LIKE P## OR D## FORMS
C AND COPY THE WHOLE NAME HERE.
C NOTE: WE LEAVE THE LIMITS HERE AT 60 AND 301 EVEN IF THE
C SHEET DIMENSIONS CHANGE. THE ENCODING SCHEME BREAKS
C DOWN OVER 63 BY 255 ANYWAY, SO JUST LEAVE LARGER NAMES
C ALONE.
	If(Kpag.gt.0)goto 250
	If(K3DFG.GT.0)GOTO 250
C Don't encode variables if using 3D addressing since this
C could force the 3D addressing information to be lost.
	IF(ID1.GT.60.OR.ID2.GT.301)GOTO 250
C ALSO DON'T PACK ALIASED NAMES; THEY WON'T FIT IN CODED VALUES.
C FOUND VARIABLE.
C FIRST DON'T PACK P## AND D## FORMS.
	IF(LNIN(LI+1).EQ.'#')GOTO 250
C REPACK NORMAL VARIABLE HERE.
	LI=LSTC
	LNOUT(LO)=CHAR(255)
	I1=IMASK(ID1,I63)
C	I1=ID1
C	L1=L1.AND.L63
	I2=ID2/2
	I2=IMASK(I2,I192)
C	L2=L2.AND.L192
C	L1=L1.OR.L2
	I1=I1+I2
	LNOUT(LO+1)=CHAR(I1)
C	I2=ID2
	I2=IMASK(ID2,I127)+128
C	L2=L2.AND.L255
C	L2=L2.OR.L128
	LNOUT(LO+2)=CHAR(I2)
	LO=MIN0(109,LO+3)	
	GOTO 300
250	CONTINUE
C JUST COPY DISPLAY FORMS.
	IL1=LSTC-1
	DO 251 N=LI,IL1
	LNOUT(LO)=LNIN(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
251	CONTINUE
	LI=LSTC
C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
	GOTO 300
200	CONTINUE
C HERE CHECK FOR FORMULA...
C NOTE THAT SOME NAMES (E.G. "AVG" COULD CONFLICT WITH VERY LARGE COLUMN
C NAMES. HOWEVER, IGNORE THAT POSSIBILITY. THAT'S AWFULLY FAR OUT.
	CALL FNAME(LNIN(LI),II,INDX)
	IF(INDX.LE.0.OR.INDX.GT.25)GOTO 220
C Ensure that functions with indices too large to encode are
C just treated literally. 229+25=254, the largest index we can have
C before colliding with the 255 used to encode variable names.
C thus all function names past the 25th must just be literally
C entered. This is not really a problem as logic to find them
C will work in either encoded or unencoded cases.
C BE SURE A [ CHAR FOLLOWS NAME FOR THIS TO BE ACCEPTED...
	IF(LNIN(LI+3).NE.'[')GOTO 220
C FOUND MULTI-INPUT FUNCT NAME
	LNOUT(LO)=CHAR(229+INDX)
C SIMPLE 1-BYTE ENCODE OF NEEDED FUNCT NAME. NOT IN ANY CRITICAL RANGES...
	LO=LO+1
	LI=LI+3
	GOTO 300
220	CONTINUE
	LNOUT(LO)=LNIN(LI)
C JUST COPY MISC. CHARACTER.
	LO=LO+1
	LI=LI+1
300	IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
	LO=MIN0(LO,110)
	DO 400 N=LO,110
400	LNOUT(N)=0
C COPY REST OF 128 BYTE ARRAY
	DO 1 N=111,128
1	LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
	RETURN
500	CONTINUE
C SPECIAL COPY OF 3 BYTE PACKED FORMS FOR SPEED
	LNOUT(LO)=LNIN(LI)
	LNOUT(LO+1)=LNIN(LI+1)
	LNOUT(LO+2)=LNIN(LI+2)
	LO=LO+3
	LI=LI+3
	GOTO 300
	END
c -h- calbin.for	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CALBIN(RETCD)
C COPYRIGHT (C) 1983,1984 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  CALBIN                      *
C *                                                     *
C *******************************************************
C
C  SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
C
C special version with multiple precision diked out - gce (to save space
C on 256K PC)
C  UPON ENTRANCE TO ROUTINE:
C	OPERAND1 IS IN STACK1  (ST1PT-1)
C	OPERAND2 IS ON TOP OF STACK2  (ST2PT-1)
C	OPERATOR IS BELOW OPERAND2  (ST2PT-2)
C  UPON EXIT:
C	RESULT IS IN STACK1
C	STACK2 HAS BEEN CLEANED UP
C
C  RETURN CODE	MEANING
C	1	NORMAL RETURN
C	2	OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C	3	ERROR RETURN
C
C
C
C  MODIFICATION CLASSES: M3, M4, AND M8
C
C
C
C  CALBIN CALLS
C
C  CONTYP   CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
C  ERRMSG   PRINTS OUT ERROR MESSAGES
C  MULADD   PERFORMS MULTIPLE PRECISION ADDITION
C  MULDIV   PERFORMS MULTIPLE PRECISION DIVISION
C  MULMUL   PERFORMS MULTIPLE PRECISION MULTIPLICATION
C
C
C
C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
C
C
C
C
C   VARIABLE     USE
C
C  EIGHT(8)      PICKS OUT A REAL CONSTANT FROM STACK.
C  FOUR(4)       PICKS OUT AN INTEGER CONSTANT FROM STACK.
C  I,J           HOLD TEMPORARY VALUES.
C  IA            FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
C                VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
C  ID            USED TO CONVERT DECISION TABLE CHARACTER*1 VALUE TO
C                AN InTeGer*4 VALUE THAT CAN BE USED AS AN ARGUMENT
C                IN A CALL TO CONTYP.
C  INT,IHOLD     HOLD INTEGER*4 VALUES.
C  IOP           HOLDS THE BINARY OPERATOR.
C  IOP2          USED TO INDEX A COMPUTED GO.
C  ISW           HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
C  MINUS         VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C                NUMBER THAT IS USED TO INDICATE A NEGATIVE.
C  OP1TYP        TYPE OF OPERAND 1.
C  OP2TYP        TYPE OF OPERAND 2.
C  PLUS          VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C                NUMBER THAT IS USED TO INDICATE POSITIVE.
C  PT1,PT2       POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
C  REAL,RHOLD    HOLD TEMPORARY REAL*8 VALUES.
C  RETCD         ERROR RETURN:  1 = O.K.   2 = RESULT WAS OUTPUT
C                3 = ERROR
C
C
C	SUBROUTINE CALBIN(RETCD)
	REAL*8 REAL,RHOLD,DFLOAT
C
	INTEGER*4 INT,IHOLD
C
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 VLEN(9)
	InTeGer*4 IOP,IA,ID,IOP2,ISW
	InTeGer*4 PLUS,MINUS
	InTeGer*4 OLDTYP,VIEWSW,BASED
	InTeGer*4 TYPE(1,1)
	InTeGer*4 RETCD,RETCD2
	InTeGer*4 OP1TYP,OP2TYP
	InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
	InTeGer*4 PT1,PT2
C
	CHARACTER*1 STACK1(8,40),STACK2(8,40)
	InTeGer*4 STK12(2,40)
	REAL*8 XVBLK
	EQUIVALENCE(STK12(1,1),STACK1(1,1))
	CHARACTER*1 AVBLS(20,27), DTBL1(9,9,8)
	CHARACTER*1 VBLS(8,1,1)
	EQUIVALENCE (XVBLK,VBLS(1,1,1))
	CHARACTER*1 EIGHT(8),FOUR(4)
	CHARACTER*1 LINE(80)
C
	EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
C
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON/V/ TYPE,AVBLS,VBLS,VLEN
	COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;         ST1LIM,ST2LIM
	COMMON /DECIDE/DTBL1
C
C
	DATA PLUS/0/,MINUS/1/
C
C
	RETCD=1
	PT1=ST1PT-1
	PT2=ST2PT-1
C
	IOP=ST2TYP(ST2PT-2)
	OP1TYP=ST1TYP(PT1)
	OP2TYP=ST2TYP(PT2)
C NOTE THAT IA IS UNUSED HERE... SAVE BIG DIMENSIONS
	IA=ICHAR(STACK1(1,PT1))
	ID1=STK12(1,PT1)
	ID2=STK12(2,PT1)
C	CALL GETDM(STACK1(1,PT1),ID1,ID2)
C ****&&&& ABOVE GETS LOCS IN 2 DIM ARRAY OF VARIABLES
	IF (IOP.NE.200) GOTO 100
C
C
C
C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
	IF(OP1TYP.GE.0) GO TO 5
C
C
C
C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
	OP1TYP=-OP1TYP
	ST1TYP(PT1)=OP1TYP
C
C
C
C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE  I=J=2
5	J=VLEN(OP2TYP)
C	TYPE(IA)=OP1TYP
	CALL TYPSET(ID1,ID2,OP1TYP)
C	TYPE(ID1,ID2)=OP1TYP
C *&*****&&&&& NOTE TYPE ARRAY AND VBLS ARRAY NOW ARE HUGE
C  NOTE FURTHER THAT AVBLS IS OLD VBLS ARRAY. SWITCHED ON IF
C ID1 =< 27 AND ID2=1.
	DO 10 I=1,J
10	STACK1(I,PT1)=STACK2(I,PT2)
	CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
	GOTO (20,9999), RETCD2
	STOP 20
C
C
C THE SPECIFIED VARIABLE GETS NEW VALUE.
C ***&&&& HERE'S WHERE WE STORE A VALUE INTO A VARIABLE...
20	J=VLEN(OP1TYP)
	DO 30 I=1,J
C	VBLS(I,IA)=STACK1(I,PT1)
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 22
C REPLACE VBLSET CALL WITH XVBLST CALL ON LAST PASS TO AVOID
C MULTIPLE REPLACEMENT OF STORAGE FOR EVERY PASS.
	VBLS(I,1,1)=STACK1(I,PT1)
	IF(I.EQ.J)CALL XVBLST(ID1,ID2,XVBLK)
C	CALL VBLSET(I,ID1,ID2,STACK1(I,PT1))
C	VBLS(I,ID1,ID2)=STACK1(I,PT1)
	GOTO 30
22	AVBLS(I,ID1)=STACK1(I,PT1)
C *****&&&&&
30	CONTINUE
	GOTO 10000
C
C
C  IOP2 VALUES 1="**"  2="*"   3="/"   4="+"   5="-"
100	IOP2=IOP-111
	GOTO (1000,2000,2000,2000,2000),IOP2
C
C
C    ********************************************
C    ***********  EXPONENTIATION  ***************
C    ********************************************
C
C
C  FIRST CONVERT TO PROPER TYPE
1000	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,5))
	CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,6))
	CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
C
C
C  GOTO APPROPRIATE PLACE TO PERFORM OPERATION
	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,8))
	GOTO (1100,1200,1300,1400,1500,1600,1700),ID
	STOP 1000
C
C
C  REAL**REAL
1100	DO 1104 I=1,8
1104	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 1108 I=1,8
1108	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD**REAL
C
C
C  USED BY REAL**I
1109	DO 1110 I=1,8
1110	STACK1(I,PT1)=EIGHT(I)
C
C
C  USED BY I**REAL,I**I
1114	ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,7))
	GOTO 10000
C
C
C
C  REAL**I
1200	DO 1204 I=1,8
1204	EIGHT(I)=STACK1(I,PT1)
	DO 1208 I=1,4
1208	FOUR(I)=STACK2(I,PT2)
	REAL=REAL**INT
	GOTO 1109
C
C
C
C  I**REAL (PARTS USED BY I**I)
1300	DO 1304 I=1,4
1304	FOUR(I)=STACK1(I,PT1)
	DO 1308 I=1,8
1308	EIGHT(I)=STACK2(I,PT2)
C
C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
C
	INT=DFLOAT(INT)**REAL
1310	DO 1314 I=1,4
1314	STACK1(I,PT1)=FOUR(I)
	GOTO 1114
C
C
C
C  I**I
1400	DO 1404 I=1,4
1404	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 1408 I=1,4
1408	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD**INT
	GOTO 1310
C
C
C
C  M8**I    (PARTS USED BY M10**I, M16**I)
1500	ISW=8
1501	IF(ST2PT.LE.ST2LIM)GO TO 1502
C
C
C STACK OVERFLOW
	CALL ERRMSG(9)
	GO TO 9999
C
C
C GET EXPONENT AS AN INTEGER
1502	DO 1504 I=1,4
1504	FOUR(I)=STACK2(I,PT2)
	IF (INT.GE.0) GOTO 1520
C
C
C EXPONENT NOT POSITIVE OR 0
	CALL ERRMSG (15)
	GOTO 9999
1520	IF (INT.GT.0) GOTO 1530
C
C
C I**0 = 1
	STACK1(8,PT1)=PLUS
	DO 1522 I=2,7
1522	STACK1(I,PT1)=0
C LEAVE AS INTEGER SETS HERE RATHER THAN EXPLICIT CHAR() CALLS
	STACK1(1,PT1)=1
	GOTO 10000
C
C
C EXPONENT IS > 0
1530	INT=INT-1
C
C
C IF EXPONENT = 1 WE ARE DONE
	IF(INT.EQ.0)GO TO 10000
C
C
C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
C FACTOR.
	DO 1534 I=1,8
1534	STACK2(I,ST2PT)=STACK1(I,PT1)
	ST2TYP(ST2PT)=ST1TYP(PT1)
C
C
C
C
1549	continue
c1549	DO 1550 I=1,INT
c	CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
c	IF(RETCD2.GE.2)GO TO 9999
c1550	CONTINUE
	GOTO 10000
C
C  M10**I
1600	ISW=10
	GOTO 1501
C
C
C
C  M16**I
1700	ISW=16
	GOTO 1501
C
C
C  *****************************************
C  * MAKE CONVERSIONS APPROPRIATE FOR */+- *
C  *****************************************
2000	CONTINUE
	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,1))
	CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
	IF(ID.EQ.0)GO TO 2010
	ST1TYP(PT1)=ID
	OP1TYP=ID
2010	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,2))
	CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
	IF(ID.EQ.0)GOTO 2020
	ST2TYP(PT2)=ID
	OP2TYP=ID
C
2020	CONTINUE
C
C
C  GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
	GOTO (2100,3000,4000,5000,6000),IOP2
2100	STOP 2100
C
C
C
C
C
C
C  **********************************************
C  ***********  MULTIPLICATION  *****************
C  **********************************************
3000	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
	GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
	STOP 3000
C
C
C  ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
3100	CALL ERRMSG (12)
	GOTO 9999
C
C
C  DECIMAL, REAL
3200	DO 3204 I=1,8
3204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 3208 I=1,8
3208	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD*REAL
3209	DO 3210 I=1,8
3210	STACK1(I,PT1)=EIGHT(I)
C
C
C  FOLLOWING USED BY OTHER SECTIONS
3220	ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,3))
	GOTO 10000
C
C
C
C  HEX,INTEGER,OCTAL
3300	DO 3304 I=1,4
3304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 3308 I=1,4
3308	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD*INT
3309	DO 3310 I=1,4
3310	STACK1(I,PT1)=FOUR(I)
	GOTO 3220
C
C
C
C  M10
3500	continue
c3500	CALL MULMUL (PT1,PT2,RETCD2,10)
C
C
C  FOLLOWING USED BY OTHER SECTIONS
3510	IF (RETCD2.EQ.2) GOTO 9999
	GOTO 3220
C
C
C
C  M8
3600	continue
c3600	CALL MULMUL (PT1,PT2,RETCD2,8)
	GOTO 3510
C
C
C
C  M16
3700	continue
c3700	CALL MULMUL (PT1,PT2,RETCD2,16)
	GOTO 3510
C
C
C  **************************************************
C  ******************  DIVISION  ********************
C  **************************************************
4000	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
	GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
	STOP 4000
C
C
C  DECIMAL,REAL
4200	DO 4204 I=1,8
4204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 4208 I=1,8
4208	EIGHT(I)=STACK2(I,PT2)
	IF(REAL.NE.0.D0)GO TO 4210
	CALL ERRMSG(23)
	GO TO 9999
4210	REAL=RHOLD/REAL
	GOTO 3209
C
C
C  HEX,INTEGER,OCTAL
4300	DO 4304 I=1,4
4304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 4308 I=1,4
4308	FOUR(I)=STACK2(I,PT2)
	IF(INT.NE.0)GO TO 4310
	CALL ERRMSG(23)
	GO TO 9999
4310	INT=IHOLD/INT
	GOTO 3309
C
C
C  M10
4500	continue
c4500	CALL MULDIV (PT1,PT2,RETCD2,10)
	GOTO 3510
C
C
C  M8
4600	continue
c4600	CALL MULDIV (PT1,PT2,RETCD2,8)
	GOTO 3510
C
C
C  M16
4700	continue
c4700	CALL MULDIV (PT1,PT2,RETCD2,16)
	GOTO 3510
C
C
C
C
C
C **************************************************
C *****************  ADDITION  *********************
C **************************************************
C
5000	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
	GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
	STOP 5000
C
C
C  DECIMAL, REAL
5200	DO 5204 I=1,8
5204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 5208 I=1,8
5208	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD+REAL
	GOTO 3209
C
C
C  HEX,INTEGER,OCTAL
5300	DO 5304 I=1,4
5304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 5308 I=1,4
5308	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD+INT
	GOTO 3309
C
C
C  M10
5500	continue
c5500	CALL MULADD (PT1,PT2,RETCD2,1)
	GOTO 3510
C
C
C  M8
5600	continue
c5600	CALL MULADD (PT1,PT2,RETCD2,2)
	GOTO 3510
C
C
C  M16
5700	continue
c5700	CALL MULADD(PT1,PT2,RETCD2,3)
	GOTO 3510
C
C
C
C
C
C
C  ***************************************************
C  ******************  SUBTRACTION  ******************
C  ***************************************************
C
6000	ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
	GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
	STOP 6000
C
C
C  DECIMAL,REAL
6200	DO 6204 I=1,8
6204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 6208 I=1,8
6208	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD-REAL
	GOTO 3209
C
C
C  HEX,INTEGER,OCTAL
6300	DO 6304 I=1,4
6304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 6308 I=1,4
6308	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD-INT
	GOTO 3309
C
C
C  M10
6500	continue
c6500	CALL MULADD (PT1,PT2,RETCD2,4)
	GOTO 3510
C
C
C  M8
6600	continue
c6600	CALL MULADD (PT1,PT2,RETCD2,5)
	GOTO 3510
C
C
C  M16
6700	continue
c6700	CALL MULADD (PT1,PT2,RETCD2,6)
	GOTO 3510
C
C
C
C
C
C	EXIT
9999	RETCD=3
C
C
C
10000	ST2PT=ST2PT-2
	RETURN
	END
c -h- calc.for	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CALC
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 ***               CALC   MAINLINE                   ***
C
C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN
C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
C POSSIBLE COMMANDS.
C
C    CALC CALLS
C
C  ASSIGN    OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
C  CLOSE     CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
C  CMND      DETERMINES WHAT CALC COMMAND IS REQUIRED.
C  ERRCX     CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
C  ERRMSG    PRINTS OUT ERROR MESSAGES.
C  EXIT      RETURNS TO OPERATING SYSTEM.
C  GETMCR    GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
C            IS PRESENT, CALC EXITS AFTER THAT ONE COMMAND IS EXECUTED.
C  INPOST    CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
C  LIST      LISTS THE LEGAL CALC COMMANDS.
C  POSTVL    CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
C            A VALUE.
C  SLEND     FINDS THE LAST NON-BLANK IN LINE(80).
C  VAROUT    PRINTS OUT THE VALUE OF A VARIABLE.
C  ZNEG      DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
C
C
C
C   VARIABLE      USE
C
C  BASED        DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
C  BLANK        ' '
C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
C               SECOND SUBSCRIPT IS
C                     1 FOR DECIMAL
C                     2 FOR OCTAL
C                     3 FOR HEXADECIMAL
C  I,J          HOLD TEMPORARY VALUES.
C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
C               USED TO CONTROL ITERATION.
C		THIS VARIABLE IS GUARANTEED TO BE 1-27.
C  LEND         POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
C  LEVEL        HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
C               LINES COME FROM.
C  LINE(80)     COMMAND INPUT LINE.
C  NONBLK       POINTS TO LAST NON-BLANK FOUND IN LINE(80).
C  ONCE         HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
C               0 OTHERWISE.
C  STAR         '*'
C  VIEWSW           VIEW SWITCH
C                    0 = OUTPUT ERROR MESSAGES
C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
C                        EVALUATED.
C                    3 = OUTPUT EVERYTHING
C  WHAT         '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
C               SHOULD BE OUTPUT.
C
C	MODIFIED	REASON
C
C	18-MAY-1981	DELETED LINE THAT CAUSED DEFAULT BASE TO BE RESET
C			WHEN AN ERROR OCCURS (PB)
C
C	18-MAY-1981	ADDED CODE AT LINES 106 TO 108 TO CONVERT FROM LOWER
C			TO UPPER CASE  (PB)
C
C CHANGED TO SUBROUTINE GCE TO ALLOW EXTERNAL CONTROL OF CALCULATOR.
C
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 RETCD,VIEWSW,BASED
	InTeGer*4 ONCE
	InTeGer*4 ZNEG,ITCNTV(6)
C
	CHARACTER*1  LINE(80),WHAT,STAR,QUOTE
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	CHARACTER*1 DIGITS(16,3)
	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
	InTeGer*4 ILNFG,ILNCT
	CHARACTER*1 ILINE(106)
	COMMON/ILN/ILNFG,ILNCT,ILINE
C
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C	COMMON/KLVL/KLVL
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON /DIGV/ DIGITS
	COMMON/ITERA/ITCNTV
	Character*2 crlf
	character*127 cwrk
C
	DATA  WHAT/'?'/, STAR/'*'/, QUOTE/''''/
	DATA ONCE/0/
C
	crlf(1:1)=char(13)
	crlf(2:2)=char(10)
C
C
C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
C THE MODULES PROPERLY, PUT IN A
	IF(KLVL.EQ.1)LEVEL=KLVL
	ONCE=0
C	IF(ILNFG.NE.0) GOTO 6000
C	CALL ASSIGN (1,'TT:')
6000	CONTINUE
C CHANGE TI: TO TT: FOR VMS.
C
	IF(ILNFG.EQ.0)GOTO 6010
	IF(ILNCT.GT.0)GOTO 6010
C INVALID INPUTS...NO LINE TO DO BUT FLAGGED TO DO. CLEAN UP.
	ILNFG=0
	RETURN
6010	CONTINUE
	IF(ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6001
C ++++++
C FOR DEC FORTRAN:
C	CALL GETMCR(LINE,LEND)
C	IF(LEND)20,20,5
C FOR NON-DEC FORTRAN: (OR VAX VERSIONS)
	GOTO 20
C ++++++  END OF CHOICES...
5	CONTINUE
	GOTO 6003
6001	CONTINUE
	DO 6007 LENDX=1,80
6007	LINE(LENDX)=CHAR(32)
	IF(ILNFG.EQ.1)ONCE=1
	I255X=0
	DO 6002 LENDX=1,ILNCT
	LINE(LENDX)=ILINE(LENDX)
	IF(ICHAR(LINE(LENDX)).EQ.255)I255X=3
	IF(I255X.LE.0)GOTO 4602
	I255X=I255X-1
	GOTO 6002
C SKIP ENTIRE 3-CHR PACKED CODES
4602	CONTINUE
	IF(ICHAR(LINE(LENDX)).GT.0.AND.ICHAR(LINE(LENDX)).LT.32)
     1  LINE(LENDX)=CHAR(32)
C LEAVE ANY EXISTING NULLS IN.
6002	CONTINUE
	LEND=ILNCT
CD	CALL FRMEDT(LINE,LEND)
C FRMEDT IMPLEMENTS EDITS OF {VAR INTO THAT VARIABLE'S FORMULA
CC NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
C	ICCC=MIN0(80,(LEND+1))
C	LINE(ICCC)=0
	GOTO 103
6003	CONTINUE
	DO 6 NONBLK=1,7
	IF(LINE(NONBLK).EQ.BLANK)GO TO 7
	IF(ICHAR(LINE(NONBLK)).EQ.13)GO TO 20
6	CONTINUE
	STOP 6
7	NONBLK=NONBLK+1
	ONCE=1
	GO TO 106
C
C  ERROR RESET

10	IF(LEVEL.LE.1) GO TO 12
	CLOSE(LEVEL)
	LEVEL=LEVEL-1
	GO TO 10
12	CONTINUE
	VIEWSW=3
C
C
C  GET NEXT INPUT LINE
20	CONTINUE
	LINE(1)=0
	LINE(2)=0
	IF(ONCE.EQ.1.AND.LEVEL.LE.1) RETURN
C20	IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL EXIT
C	IF (ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6004
	IF (LEVEL.LE.1.AND.ILNFG.NE.0.AND.ILNCT.GT.0)RETURN
	IF(LEVEL.LT.1)RETURN
	IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)call vwrt(crlf,2)
	IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)call vwrt('Calc>',5)
c22	FORMAT(' CALC>')
C
C
	LLLV=LEVEL
	IF(LLLV.EQ.1)LLLV=11
c	rewind 11
	if(lllv.ne.11)goto 6008
	call vget(line,80)
	do 6009 iii=1,80
C Force chars read in to spaces like Fortran system would.
C This includes controls like crlf.
	if(ichar(line(iii)).le.31)line(iii)=' '
6009	Continue
6008	Continue
c	if(lllv.eq.11)call vget(line,80)
	if(lllv.ne.11)READ (LLLV,24,END=900,ERR=1000) LINE
c	rewind 11
24	FORMAT (80A1)
C	GOTO 6005
C SECTION BELOW COMMENTED OUT BECAUSE IT SHOULD NEVER BE CALLED (GCE).
C6004	CONTINUE
C	DO 6006 LENDX=1,80
C6006	LINE(LENDX)=CHAR(32)
CC ABOVE BLANKS OUT LINE ARRAY
C	DO 6007 LENDX=1,ILNCT
C6007	LINE(LENDX)=ILINE(LENDX)
CC ABOVE COPIES INPUT FROM OUR CALLER...
C6005	CONTINUE
C
C
C
C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
CD	CALL FRMEDT(LINE,LEND)
	CALL SLEND(RETCD)
	GO TO(30,20),RETCD
	STOP 30
30	CONTINUE
C
C
	IF(ILNFG.EQ.0.AND.ILNCT.GT.0)GOTO 103
C SHOW WHAT WAS READ FROM FILE
c	rewind 11
	cwrk=' '
	IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
     1  write(cwrk,40)level,(line(i),i=1,lend)
	cwrk= crlf // cwrk
	iii=lend+10
	IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
     1  call vwrt(cwrk,iii)
c     1 WRITE(11,40)LEVEL,(LINE(I),I=1,LEND)
c	rewind 11
40	FORMAT (' CALC<',I1,'>',80A1)
103	CONTINUE
C NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
	ICCC=MIN0(80,(LEND+1))
	LINE(ICCC)=0
C
C  IDENTIFY FIRST NON-BLANK
	DO 104 NONBLK=1,LEND
	IF (LINE(NONBLK).NE.BLANK) GOTO 106
104	CONTINUE
	RETURN
C	STOP 104
C
C CONVERT LOWER CASE TO UPPER CASE
106	CONTINUE
	I255X=0
	DO 108 I=NONBLK,LEND
	J=ICHAR(LINE(I))
	IF(J.EQ.255)I255X=3
	IF(I255X.LE.0)GOTO 3107
C SKIP ENCODED VARIABLE NAMES
	I255X=I255X-1
	GOTO 107
3107	CONTINUE
	IF (I.EQ.NONBLK) GOTO 107
	IF (LINE(I-1).EQ.QUOTE) GOTO 108
	IF(J.GE.97.AND.J.LE.122) LINE(I)=CHAR(J-32)
107	CONTINUE
108	CONTINUE
C
C  SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
	IF (LINE(NONBLK).NE.WHAT) GOTO 110
	CALL LIST
	GOTO 20
C
C  SEE IF IT IS A COMMAND
110	IF (LINE(NONBLK).NE.STAR) GOTO 120
	CALL CMND (RETCD)
	GOTO (20,115,10,6120), RETCD
6120	RETURN
C	STOP 110
C
C
C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
115	CALL SLEND(RETCD)
	GO TO (103,20),RETCD
	RETURN
C	STOP 115
C
C  SEE IF ONLY ONE ALPHA CHARACTER
120	J=NONBLK+1
	IF (LEND.NE.NONBLK) GOTO 130
	DO 124 I=1,27
	IF (LINE(NONBLK).EQ.ALPHA(I)) GOTO 126
124	CONTINUE
C
C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
	DO 125 I=1,10
	IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
125	CONTINUE
C
C
C ALLOW FOR ENTERING THE ASCII BLANK
	IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
	I=1
	GOTO 1001
C
C  OUTPUT VALUE OF SINGLE VARIABLE
126	CALL VAROUT(I,1)
	GOTO 20
C
C
C CHECK INPUT FOR SYNTAX ERRORS
130	CALL ERRCX (RETCD)
	GOTO (140,10),RETCD
	RETURN
C	STOP 130
C
C  CHANGE FROM INFIX TO POSTFIX NOTATION
140	CALL INPOST (RETCD)
	GOTO (150,10), RETCD
C
C
C EVALUATE EXPRESSION
150	CONTINUE
	CALL POSTVL(RETCD)
	GOTO(20,10),RETCD
	RETURN
C	STOP 150
C
C
C  EXIT
900	CONTINUE
	IF (LEVEL.EQ.1) RETURN
C	IF (LEVEL.EQ.1) CALL EXIT
	IF(ITCNTV(LEVEL).EQ.0)GOTO 910
	IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
C
C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
C AND EXECUTE AGAIN.
	REWIND LEVEL
	GO TO 20
C
C
C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
C OF LEVEL BY ONE.
910	CLOSE(LEVEL)
	LEVEL=LEVEL-1
	GOTO 20
C
C
C
C *** ERROR PROCESSING ***
1000	I=27
1001	CALL ERRMSG(I)
	GO TO 10
	END
c -h- calun.for	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CALUN(RETCD)
C COPYRIGHT (C) 1983,1984 GLENN AND MARY 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  *             SUBROUTINE   CALUN                    *
C  *****************************************************
C
C  SUBROUTINE CALUN PERFORMS A UNARY OPERATION.
C
C  UPON ENTRANCE:
C	OPERATOR IS ON STACK 2
C	OPERAND IS ON STACK 1
C  UPON EXIT:
C	OPERATOR HAS BEEN POPPED OFF STACK 2
C	RESULT IS ON STACK 1
C
C	RETCD	MEANING
C
C	1	O.K.
C	2	ERROR
C
C   MODIFICATION CLASSES: M3, M4, AND M8
C
C  CALUN CALLS
C
C  CONTYP   CONVERTS DATA TYPES
C  ERRMSG   PRINTS ERROR MESSAGES
C  $DATAN   ARC TANGENT
C  $DCOS    COSINE
C  $DEXP    E**X
C  $DLOG    NATURAL LOG
C  $DLOG10  LOG BASE 10
C  $DSIN    SINE
C  $DSQRT   SQUARE ROOT
C  $DTANH   HYPERBOLIC TANGENT
C
C  CALUN IS CALLED BY POSTVL WHICH CONVERTS FROM INFIX TO POSTFIX
C
C     VARIABLE    USE
C
C  RETCD      RETURN CODE:  1 = O.K.   2 = ERROR
C  J,K,K2,I   HOLD TEMPORARY VALUES
C  MINUS      VALUE IN LAST MULTIPLE PRECISION BYTE.
C             USED TO INDICATE A NEGATIVE NUMBER.
C  PLUS       VALUE IN LAST MULTIPLE PRCISION BYTE.
C             USED TO INDICATE A POSITIVE NUMBER.
C  REAL       TEMPORARY DOUBLE PRECISION VALUES.
C  INT        TEMPORARY INTEGER*4 VALUES.
C  ST1TYP(40) TYPE FOR EACH ELEMENT ON STACK 1
C  ST2TYP(40) TYPE FOR EACH ELEMENT OF STACK 2
C  ST1PT      POINTS TO TOP OF STACK 1
C  ST2PT      POINTS TO TOP OF STACK 2
C  STACK1     HOLDS OPERAND
C  STACK2     HOLDS UNARY OPERATOR
C
C	SUBROUTINE CALUN(RETCD)
	REAL*8 REAL
	REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
	REAL*8 DASIN,DACOS,DTAN
	REAL*8 DTANH,DATAN
C
	REAL*4 FLOAT
C
	INTEGER*4 INT
C
	InTeGer*4 RETCD,RETCD2
	InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT,ST1LIM,ST2LIM
	InTeGer*4 K,K2
C
	CHARACTER*1 STACK1(8,40),STACK2(8,40),FOUR(4),EIGHT(8)
	CHARACTER*1 PLUS,MINUS
C
	EQUIVALENCE (FOUR,INT),(EIGHT,REAL)
C
	COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,
     ;          ST1TYP,ST2TYP,ST1LIM,ST2LIM
C
C	DATA PLUS/0/,MINUS/1/
C
	PLUS=0
	MINUS=1
	RETCD=1
	K=ST2TYP(ST2PT-1)
	K2=ST1TYP(ST1PT-1)
C
C
C MAKE SURE VARIABLE IS DEFINED
	IF(K2.GT.0)GOTO 50
C IF NOT, PRINT MESSAGE AND RETURN
	CALL ERRMSG(16)
	GOTO 89999
C
50	J=K
C
C
C SEE IF IT IS A UNARY MINUS
	IF (J.EQ.111) GOTO 100
C
C
C  FUNCTIONS START AT 31
	K=K-30
	GOTO (100,100,300,400,500,400,10000),K
	GOTO 10000
C
C
C  ***************************************
C  *** ABS (=DABS), IABS, AND UNARY -  ***
C  ***************************************
100	CONTINUE
	IF(K2.GT.0)GO TO 105
	CALL ERRMSG(16)
	GO TO 89999
105	GOTO (110,120,130,130,140,140,140,130,120),K2
	STOP 100
C
C
C  ASCII
110	CALL ERRMSG (12)
	GOTO 89999
C
C
C  DECIMAL AND REAL
120	DO 121 I=1,8
121	EIGHT(I)=STACK1(I,ST1PT-1)
	IF (K.NE.111) GOTO 123
C
C
C  UNARY -
	REAL=-REAL
	GOTO 124
123	REAL=DABS(REAL)
124	DO 125 I=1,8
125	STACK1(I,ST1PT-1)=EIGHT(I)
	GOTO 90000
C
C
C  INTEGER, HEXADECIMAL, AND OCTAL
130	DO 131 I=1,4
131	FOUR(I)=STACK1(I,ST1PT-1)
	IF (K.NE.111) GOTO 133
	INT=-INT
	GO TO 134
133	IF(INT.LT.0)INT=-INT
134	DO 135 I=1,4
135	STACK1(I,ST1PT-1)=FOUR(I)
	GOTO 90000
C
C
C  MULTIPLE PRECISION
140	IF (K.NE.111) GOTO 150
	IF (STACK1(8,ST1PT-1).EQ.PLUS)GOTO 160
150	STACK1(8,ST1PT-1)=PLUS
	GOTO 90000
160	STACK1(8,ST1PT-1)=MINUS
	GOTO 90000
C
C
C  ***************************************
C  ************  FLOAT  ******************
C  ***************************************
300	CONTINUE
	GOTO (310,320,330,330,340,340,340,330,320),K2
C
C
C  ASCII
310	CALL ERRMSG(12)
	GOTO 89999
C
C
C  REAL (=DECIMAL)
320	CALL ERRMSG (13)
	GOTO 89999
C
C
C  INTEGER=HEXADECIMAL=OCTAL
330	DO 333 I=1,4
333	FOUR(I)=STACK1(I,ST1PT-1)
	REAL=FLOAT(INT)
	DO 335 I=1,8
335	STACK1(I,ST1PT-1)=EIGHT(I)
	ST1TYP(ST1PT-1)=2
	GOTO 90000
C
C
C  MULTIPLE PRECISION
340	CALL ERRMSG (11)
	GOTO 89999
C
C
C
C  ***************************************
C  *******  IFIX AND INT (=IDINT)  *******
C  ***************************************
400	CONTINUE
	GOTO (410,420,430,430,440,440,440,430,420),K2
	STOP 400
C
C
C  ASCII
410	CALL ERRMSG (12)
	GOTO 89999
C
C
C  REAL AND DECIMAL
420	DO 421 I=1,8
421	EIGHT(I)=STACK1(I,ST1PT-1)
	INT=IDINT(REAL)
	DO 424 I=1,4
424	STACK1(I,ST1PT-1)=FOUR(I)
	ST1TYP(ST1PT-1)=4
	GOTO 90000
C
C
C  INTEGER, HEXADECIMAL, AND OCTAL
430	CALL ERRMSG (10)
	GOTO 89999
C
C
C  MULTIPLE PRECISION
440	CALL ERRMSG (11)
	GOTO 89999
C
C
C
C  ***************************************
C  ***************  AINT  ****************
C  ***************************************
C
C  REAL TO REAL TRUNCATION
500	CONTINUE
	GOTO (510,520,530,530,540,540,540,530,520),K2
C
C
C  ASCII
510	CALL ERRMSG (12)
	GOTO 89999
C
C
C  REAL AND DECIMAL
520	DO 522 I=1,8
522	EIGHT(I)=STACK1(I,ST1PT-1)
C
C DON'T USE AINT(SNGL(REAL)) BECAUSE THEN
C 2.9999999 RESULTS IN 3.0
	REAL=DINT(REAL)
	DO 524 I=1,8
524	STACK1(I,ST1PT-1)=EIGHT(I)
	GOTO 90000
C
C
C  INTEGER, HEXADECIMAL, AND OCTAL
530	CALL ERRMSG (10)
	GOTO 89999
C
C
C  MULTIPLE PRECISION
540	CALL ERRMSG(11)
	GOTO 89999
C
C
C
C
C  ****************************************
C  ****************************************
C  ********                        ********
C  ******** REAL TO REAL FUNCTIONS ********
C  ********                        ********
C  ********  EXP      (=DEXP)      ********
C  ********  ALOG     (=DLOG)      ********
C  ********  ALOG10   (=DLOG10)    ********
C  ********  SQRT     (=DSQRT)     ********
C  ********  SIN      (=DSIN)      ********
C  ********  COS      (=DCOS)      ********
C  ********  TANH     (DTANH)      ********
C  ********  ATAN     (=DATAN)     ********
C  ********                        ********
C  ****************************************
C  ****************************************
C
C
C
10000	CONTINUE
	GOTO (11000,12000,15000,15000,15000,15000,15000,15000,12000),K2
	STOP 10000
C
C
C  ASCII
11000	CALL ERRMSG (12)
	GOTO 89999
C
C
C  REAL AND DECIMAL
12000	DO 12010 I=1,8
12010	EIGHT(I)=STACK1(I,ST1PT-1)
	K=K-6
	GOTO (12100,12200,12300,12400,12500,12600,12700,12800,
     1  12840,12860,12880),K
C
C
C  EXP
12100	REAL=DEXP(REAL)
	GOTO 14000
C
C
C  ALOG
12200	REAL=DLOG(REAL)
	GOTO 14000
C
C
C  DLOG10
12300	REAL=DLOG10(REAL)
	GOTO 14000
C
C
C  DSQRT
12400	IF (REAL.GE.0.D0) GOTO 12410
12405	CALL ERRMSG (14)
	GOTO 89999
12410	REAL=DSQRT (REAL)
	GOTO 14000
C
C
C  DSIN
12500	REAL=DSIN(REAL)
	GOTO 14000
C
C
C  DCOS
12600	REAL=DCOS(REAL)
	GOTO 14000
C
C
C  DTANH
12700	REAL=DTANH(REAL)
	GOTO 14000
C
C
C  DATAN
12800	REAL=DATAN(REAL)
	GOTO 14000
C
C ASIN
12840	CONTINUE
	IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
	REAL=DASIN(REAL)
	GOTO 14000
C
C ACOS
12860	CONTINUE
	IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
	REAL=DACOS(REAL)
	GOTO 14000
C
C TAN
12880	CONTINUE
	IF(REAL.GT.1.570795)REAL=1.570795
	IF(REAL.LT. -1.570795) REAL = -1.570795
C CLAMP TO AVOID OVERFLOW
	REAL=DTAN(REAL)
C	GOTO 14000
C (GOTO NOT NEEDED IF THIS IS THE LAST FUNCTION)
14000	DO 14010 I=1,8
14010	STACK1(I,ST1PT-1)=EIGHT(I)
	GOTO 90000
C
C
C  INTEGER, HEXADECIMAL, OCTAL, AND MULTIPLE PRECISION
15000	CONTINUE
	CALL CONTYP(STACK1,ST1PT-1,K2,2,RETCD2)
	GO TO(15010,89999),RETCD2
	STOP 15000
15010	ST1TYP(ST1PT-1)=2
	GO TO 12000
C
C
C  EXIT
89999	RETCD=2
90000	ST2PT=ST2PT-1
	RETURN
	END
c -h- ce2a.fms	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CE2A(LNIN,LNOUT)
C CONVERT ENCODED FORMULAS TO NORMAL ASCII
C NOTE: ONLY HAS TO HANDLE STANDARD NAMES AS A$5$ TYPE FORMS AND P# AND D# FORMS
C ARE NOT TRANSLATED TO PACKED ONES.
	CHARACTER*1 NAME(4),NUMBER(6)
	CHARACTER*1 LNIN,LNOUT
	CHARACTER*6 NUMBR6
	EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
	DIMENSION LNIN(128),LNOUT(128)
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C	LOGICAL*2 L63,L192,L255,L127
	LOGICAL*4 L1,L2
C	InTeGer*4 I63,I192,I255,I127
	InTeGer*4 I63,I192,I127
	InTeGer*4 I1,I2
C	EQUIVALENCE(L127,I127)
C	EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
	EQUIVALENCE (I1,L1),(I2,L2)
	INTEGER*4 FNAM(25)
	character*4 fnmx(25)
	CHARACTER*1 FCHNM(4,25)
	equivalence(fnmx(1)(1:1),fnam(1),fchnm(1,1))
c	EQUIVALENCE(FNAM(1),FCHNM(1,1))
	DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
     1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
     2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
     3  'RND ','PMT','PVL','AVE','CHS'/
C	DATA I63/63/,I192/192/,I255/255/,I128/128/
	DATA I63/63/,I192/192/,I127/127/
	LI=1
	LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100	CONTINUE
	LCC=ICHAR(LNIN(LI))
	IF(LCC.NE.255)GOTO 200
C FIND BINARY PATTERNS TO USE
	I1=ICHAR(LNIN(LI+1))
	I2=IMASK(I1,I192)
C	L2=L1.AND.L192
	I1=IMASK(I1,I63)
C	L1=L1.AND.L63
	ID1=I1
	I1=ICHAR(LNIN(LI+2))
	I1=IMASK(I1,I127)
C	L1=L1.AND.L127
	ID2=I2*2+I1
	LI=MIN0(LI+3,109)
C DO MASKING TO GET BINARY COORDS
	CALL IN2AS(ID1,NAME)
C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
	IL2=ID2-1
	WRITE(NUMBR6(1:6),1000)IL2
C	ENCODE(6,1000,NUMBER)IL2
1000	FORMAT(I6)
C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
C THROW OUT SPACES AND COPY THE REST.
	DO 202 N=1,4
	IF(ICHAR(NAME(N)).LE.32)GOTO 202
	LNOUT(LO)=NAME(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
202	CONTINUE
	DO 203 N=1,6
	IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
C IF 32 ISN'T SPACE, LOSE
	LNOUT(LO)=NUMBER(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
203	CONTINUE
	GOTO 300
C COPY MISC. CHARACTER
200	CONTINUE
	II=ICHAR(LNIN(LI))
	IF(II.LT.230.OR.II.GT.254)GOTO 220
C FUNCTION NAME...
	II=II-229
	LNOUT(LO)=FCHNM(1,II)
	LNOUT(LO+1)=FCHNM(2,II)
	LNOUT(LO+2)=FCHNM(3,II)
	LI=LI+1
	LO=LO+3
C FILL IN ASCII FORM OF FUNCTION HERE...
	GOTO 300
220	CONTINUE
	LNOUT(LO)=LNIN(LI)
	LO=LO+1
	LI=LI+1
300	IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
	LO=MIN0(LO,110)
	DO 400 N=LO,110
400	LNOUT(N)=0
	DO 1 N=111,128
1	LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
	RETURN
	END
c -h- cmdmun.for	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CMDMUN(LINE)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
ccc
ccc junk VT100 escape sequence parsing except for arrow keys and
ccc PF2 since it's mostly not useful in MSDOS anyway.
ccc
	CHARACTER*1 LINE(120),LC,LINBUF(120),CW(120)
C	InTeGer*4 IOLVL,IGOLD
	EXTERNAL INDX
C	COMMON/IOLVL/IOLVL,IGOLD
	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
	Logical LEXIST
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 FH
	Common/CONSFH/FH
	Integer Initd,UseDK,UseDF
	Data Initd/0/
c Assume compilation with -h so this stays around
	If(Initd.ne.0)Goto 2408
	Initd=1
	UseDF=0
	UseDK=0
c Before inserting the DK: part, check that dk:AKA.CMD can be found.
	Inquire(File='AKA.CMD',Exist=Lexist)
	If(Lexist)UseDF=1
	If(LExist)goto 2408
C Inquire on login directory first; if file not there THEN look in DK:
c This allows one to avoid a system requestor for device DK
	Inquire(File='DK:AKA.CMD',EXIST=LEXIST)
	If(Lexist)UseDF=1
	IF(Lexist)UseDK=1
c Usedk = 1 if stuff is seen in dk:
c usedf = 1 if stuff found in default OR dk:
2408	Continue
	ITERX=0
C ALLOW RESCAN OF READ-IN COMMANDS UP TO 10 TIMES.
6501	CONTINUE
	ITERX=ITERX+1
	IF(ITERX.GT.10)RETURN
	LI=1
C ALLOW ARROWS OR OTHER SIMILAR KEYS TO BE RECOGNIZED
	LL=ICHAR(LINE(LI))
C ALLOW ! OR ESCAPE TO BE LEADIN FOR ESCAPE SEQUENCES
	IF(LL.EQ.155.OR.LL.EQ.33.OR.LL.EQ.27)GOTO 1000
C ALLOW % SPECIAL TREATMENT
	IF(ICHAR(LINE(1)).EQ.37)GOTO 7000
	IF(LINE(1).EQ.'^')IGOLD=IGOLD+1
	IF(LINE(1).EQ.'^')GOTO 7223
C IF WE SEE , COULB BE THAT ESC GOT EATEN BY VMS...
	IF(LINE(LI).EQ.'[')GOTO 1000
C CONVERT LOWER TO UPPER CASE
	NMX=120
	DO 41 N=1,120
C CHECK FOR DOUBLE QUOTE (34 DECIMAL). LEAVE L.C. IF SO
	NNN=ICHAR(LINE(N))
	IF(NNN.EQ.34)NMX=2
C IF WE SEE " CHARACTER THEN ONLY CONVERT 1ST 2 CHARACTERS TO U.C.
41	CONTINUE
	JFED=0
	DO 1 N=1,NMX
	LL=ICHAR(LINE(N))
	IF(LL.GT.96.AND.LL.LT.123)LL=LL-32
	LINE(N)=CHAR(LL)
	IF(LINE(N).EQ.'_'.AND.LINE(N+1).EQ.'_')JFED=N
1	CONTINUE
	IF(JFED.LE.0)GOTO 520
C IF __ SEEN (2 UNDERSCORES IN A ROW), CALL FRMEDT AFTER REMOVING THE __ FROM
C THE COMMAND LINE.
	DO 521 KKK=JFED,118
	LINE(KKK)=LINE(KKK+2)
521	CONTINUE
	LINE(119)=Char(0)
	LINE(120)=Char(0)
	KKK=110
	CALL FRMEDT(LINE,KKK)
520	CONTINUE
	IF(LINE(1).NE.'M')GOTO 2000
C	IF(LINE(1).NE.'M')RETURN
	LI=2
	GOTO 1000
1000	CONTINUE
C HANDLE ESCAPE SEQUENCES
C ENCODE VT100 SEQUENCES HERE. MUST MODIFY FOR OTHERS.
C IF VMS PASSES 2 ESCS, PASS 1ST, TEST SECOND.
C NOTE CURSOR UP,DOWN, RIGHT, LEFT ARE CODED AS ESC A,B,C, OR D
C WITH POSSIBLE CRUFT BETW ESC AND THE LETTER.
	LL=ICHAR(LINE(LI+1))
	IF(LL.EQ.155.OR.LL.EQ.27)LI=LI+1
	LC=ICHAR(LINE(LI+1))
	IF(LC.EQ.'['.OR.LC.EQ.'O')LC=ICHAR(LINE(LI+2))
	IF(LC.NE.'?'.AND.LC.NE.'Q')GOTO 10
C MAKE PF2 MEAN HELP, JUST LIKE EDT
C FIX UP AMIGA HELP KEY ALSO TO MEAN HELP...
	LINE(LI)=CHAR(72)
C 72 = ASCII FOR 'H'
	LGGG=IGOLD+8
	IF(IGOLD.LE.0)GOTO 488
	LINE(LI+1)=CHAR((LGGG/10)+48)
	LINE(LI+2)=CHAR(MOD(LGGG,10)+48)
488	CONTINUE
C	RETURN
	GOTO 2000
10	CONTINUE
C HANDLE AUX KEYPAD KEYS AS INDIRECTS (FOR NOW)
C MAP ENTER KEY INTO AUX KEYPAD RANGE
	IF(LC.EQ.'M')LC='o'
	IF(LC.GE.'l'.AND.LC.LE.'y')GOTO 2650
	IF(LC.GE.'P'.AND.LC.LE.'S')GOTO 2100
C HANDLE INDIRECT CALLS AT 2100 FOR PF1 THRU PF4 IF AANY
	LL=ICHAR(LC)
	IF(LL.GE.48.AND.LL.LE.63)GOTO 2640
	LL=LL-65
C SUBTRACT ASCII A
	IF (LL.LT.0.OR.LL.GT.3)GOTO 2000
C ARROW KEYS HERE. ADJUST AND PASS THEM TO REST OF PROGRAM
	LK=LL
	IF(LL.EQ.3)LK=2
	IF(LL.EQ.2)LK=3
	LK=LK+49
C ADJUST FOR ASCII VALUE
	LINE(LI)=CHAR(LK)
C STASH NEW CELL IN.
C DON'T DISTURB GOLD STATUS ON MOTION OR ON HELP. ONLY ON INDIRECT
C COMMAND FILES.
	RETURN
C	GOTO 2000
2640	CONTINUE
C AMIGA FUNCTION KEYS
	LL=LL-48+ICHAR('l')
	LC=CHAR(LL)
c Fix up as though VT100 function chars and go on
2650	CONTINUE
	LL=ICHAR(LC)
	LL=LL-ICHAR('l')+ICHAR('A')
C MAPPING IS:
C  KEY	CHAR	AKx.CMD  x=
C  0	p	E
c  1    q	F
C  2	r	G
c  3	s	H
c  4    t       I
c  5	u	J
c  6	v	K
c  7	w	L
c  8	x	M
c  9	y	N
c  ,	l	A
c  -	m	B
c  .	n	C
c ENTER o	D
	LC=CHAR(LL)
	LINE(1)=CHAR(64)
C 64 IS ASCII @ CHARACTER
	IVL=0
C INCLUDE "DK:" IN STRING
c
	If(UseDF.eq.0) Goto 7223
	If(UseDK.eq.0) Goto 2099
	LINE(2)='D'
	LINE(3)='K'
	LINE(4)=':'
	IVL=3
2099	Continue
	LINE(2+IVL)='A'
	LINE(3+IVL)='K'
	GOTO 2600
2100	CONTINUE
C GENERATE INDIRECT FILE CALLS FROM PF1, PF3, PF4 KEYS IF ANY
C (THESE GIVE LETTERS P, R, OR S)
	LINE(1)=CHAR(64)
	IVL=0
	If(UseDF.eq.0) Goto 7223
	If(UseDK.eq.0) Goto 2098
	LINE(2)='D'
	LINE(3)='K'
	LINE(4)=':'
	IVL=3
2098	Continue
	LINE(2+IVL)='K'
	LINE(3+IVL)='Y'
2600	CONTINUE
	LINE(4+IVL)=LC
	IF(IGOLD.LE.0)GOTO 7202
C GOLD ADDS EXTRA A,B,C,D,E,... ETC. AFTER FILENAME
	LINE(5+IVL)=CHAR(64+IGOLD)
	IVL=IVL+1
C ADD EXTRA LETTER FOR GOLDED COMMANDS
7202	CONTINUE
	LINE(5+IVL)='.'
	LINE(6+IVL)='C'
	LINE(7+IVL)='M'
	LINE(8+IVL)='D'
	LINE(9+IVL)=0
C GENERATE @KYP, @KYR, OR @KYS COMMAND ON PF1, PF3, PF4
2000	CONTINUE
	IGOLD=0
	RETURN
7000	CONTINUE
C PROCESS %%% FORMS
	I1=INDX(LINE(2),37)
C IF I1 IS 1, THEN WE JUST HAVE %% AND THERE'S NOTHING TO DUMP TO
C THE SCREEN. OTHERWISE DUMP IT OUT HERE..
	I1=I1+1
	IF(I1.LE.2.OR.I1.GT.80)GOTO 7002
	II1=I1-1
	IV=II1-1
	CALL SWRT(LINE(2),IV)
7301	FORMAT(80A1,60A1)
7002	CONTINUE
	IF(I1.GT.80)RETURN
C COPY WHATEVER NEEDS TO BE COPIED TO LINBUF
	DO 7003 II=1,80
7003	LINBUF(II)=0
	I2=INDX(LINE(I1+1),37)
	IF(I2.GT.80)RETURN
	I2=I2+I1
	I1=I1+1
	II2=I2-1
	II=0
	IF(II2.LT.I1)GOTO 7540
	DO 7004 LL=I1,II2
	II=II+1
7004	LINBUF(II)=LINE(LL)
7540	CONTINUE
	IF(I2.GT.80)RETURN
C IF LINE(I2+1) HAS & THEN CLOSE FILE RIGHT HERE AND BUG OFF
	IF(LINE(I2+1).NE.'&')GOTO 8005
	CLOSE (IOLVL)
	IOLVL=11
	LINE(I2+1)='\'
8005	CONTINUE
C SEE IF LINE(I2+1) CONTAINS A ?
	IF(LINE(I2+1).NE.'?'.AND.LINE(I2+1).NE.'\')GOTO 7005
C HAVE TO READ IN USER'S LINE HERE... READ OFF UNIT 5 ALWAYS...
	LX=II+1
c	rewind 11
c	If(FH.NE.0)goto 9201
c	READ(11,7301,END=7035,ERR=7035)(LINBUF(II),II=LX,120)
c	rewind 11
c	Goto 9202
c9201	Continue
c read in main window
	Call Getttl(CW)
	If(ichar(cw(1)).eq.26.or.
     1  ichar(cw(1)).eq.28)goto 7035
c filter so funny chars are treated as eof... ctl Z or ctl \ are eof.
	KK=1
c copy to Linbuf array (as much as fits, anyway
	Do 9203 II=LX,120
	Linbuf(II)=CW(KK)
	KK=KK+1
9203	Continue
c9202	Continue
c For AMIGA we use lun 11 for console, both input and output,
c for all commands except normal sheet operation (e.g. help etc.)
C NOW SEE IF LINBUF(LX) IS EITHER A \ CHAR OR ANY CONTROL CHARACTER
	LC=LINBUF(LX)
	IF(LINE(I2+1).EQ.'\'.OR.LINE(I2+1).EQ.'!')GOTO 7005
	IF(IOLVL.EQ.11)GOTO 7005
C IF WE SEE ANYTHING EXCEPT A CONTROL CHAR OR \, REWIND THE FILE...
C THIS ALLOWS US TO HAVE A SORT OF "ENTER MODE" AND A "COMMAND MODE"
C A LA SUPERCALC ETC.
	IF(LC.NE.'\'.AND.LC.GT.CHAR(32))REWIND IOLVL
C COMMENT OUT ANY TERMINAL COMMAND
	IF(LC.EQ.'\'.OR.LC.EQ.'!'.OR.LC.LE.CHAR(32))LINBUF(1)='*'
	GOTO 7005
7035	CONTINUE
C RECOVER AFTER CTL-Z ON EXPECTED INPUT.
C	REWIND 5
	LINBUF(1)='*'
	CLOSE (IOLVL)
c	IF(IOLVL.EQ.11)OPEN(11,FILE='CON:40/150/300/40/Analy Command')
	IOLVL=11
7005	CONTINUE
	DO 7006 II=1,120
7006	LINE(II)=LINBUF(II)
	GOTO 6501
C ALLOW RESCAN OF COMMAND LINE AFTER READ-IN.
C	RETURN
C RETURN AFTER BUMPING IGOLD. COMMENT OUT CMD
7223	CONTINUE
	LINE(1)='*'
	RETURN
	END
c -h- cmnd.f40	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CMND(RETCD)
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  CMND                        *
C   *                                                 *
C   ***************************************************
C
C
C  UPON ENTRANCE, NONBLK POINT TO THE "*" IN LINE
C  INDICATING A COMMAND.  THIS ROUTINE DETERMINES WHICH COMMAND
C  IS DESIRED AND CALLS THE APPROPRIATE SUBROUTINE.
C
C  RETCD:
C  1=NORMAL
C  2=BYPASS NEXT READ BECAUSE READ COMMAND HAS BEEN EXECUTED
C     TO CHANGE LINE(80)
C  3=ERROR, SO GO TO 1000 TO SET LEVEL=1
C
C
C MODIFY CLASSES: M1
C

C
C   CMND CALLS
C
C  AT      TO PROCESS A FILE OF CALC COMMANDS
C  BASCNG  TO CHANGE THE DEFAULT BASE FOR CONSTANTS
C  CLOSE   CLOSE FILE OF CALC COMMANDS
C  DECLR   DECLARE VAIABLES TO BE A CERTAIN DATA TYPE
C  ERRMSG  PRINTS ERROR MESSAGES
C  EXIT    RETURN TO OPERATING SYSTEM
C  GETNNB  GETS NEXT NON-BLANK FROM LINE(80)
C  STRCMP  LOOKS FOR A SPECIFIED STRING IN LINE(80)
C  ZERO    ZEROES ALL VARIABLES
C  ZNEG    TO SEE IF A VARIABLE HAS POSITIVE VALUE
C
C
C
C  CMND IS CALLED BY CALC WHO HAS IDENTIFIED THE '*'
C  INDICATING A COMMAND IS DESIRED.
C
C
C
C
C   VARIABLE      USE
C
C
C  CCHAR      TEMPORARILY HOLDS A SINGLE CHARACTER.
C  DIGITS    HOLDS ASCII REPRESENTATION OF DIGITS.
C  I         TEMPORARY INDEX.
C  ID        ARGUMENT FOR SUBROUTINE DECLR. INDICATES
C            A PARTICULAR DATA TYPE.
C  IPT       POINTER FOR LINE(80).
C  ITCNTV    0 IF NO ITERATION. IF POSITIVE, INDEX
C            OF VARIABLE USED TO CONTROL ITERATION ON THAT LEVEL.
C  KIND(15)  HOLDS FIRST LETTER OF ALL LEGAL COMMANDS.
C  LEVEL     HOLDS LOGICAL I/O UNIT WHERE NEXT COMMAND COMES FROM.
C  LINE(80)  HOLDS COMMAND LINE.
C  NONBLK    POINTER FOR LINE(80).
C  RETCD     HOLDS RETURN CODE.
C  RETCD2    HOLDS RETURN CODE.
C  VIEWSW    VIEW SWITCH:
C            0 = OFF
C            1 = DISPLAY COMMAND LINES
C            2 = DISPLAY VALUE OF EXPRESSIONS
C            3 = DISPLAY ALL
C
C
C
C	SUBROUTINE CMND(RETCD)
C
C
C	EXTERNAL INDX
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
C	InTeGer*4 IOLVL
C	COMMON/IOLVL/IOLVL
	InTeGer*4 ZNEG,ITCNTV(6)
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
	Character*1 WRK(130)
	CHARACTER*1 WRKX(130),WRK2X(130)
	CHARACTER*1 WRK2(128)
	CHARACTER*35 CWRK,CWRKX,CWRK2
	CHARACTER*11 CWRK2B
	Character*1 wrk2b(11)
	EQUIVALENCE(CWRK2B(1:1),WRK2(1),wrk2b(1))
	EQUIVALENCE(CWRK2(1:1),WRK2(1))
	EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
C	EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
c	EQUIVALENCE(WRK(1),WRKX(1))
	EQUIVALENCE(WRK2(1),WRK2X(1))
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XAC,XVBLS(1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(XAC,AVBLS(1,27))
	EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	CHARACTER*1 FVLD(1,1)
	COMMON/FVLDC/FVLD
C
	CHARACTER*1  LINE(80),KIND(23),ASCII(4),DEC(6),HEX(2),INT(6),
     ;  M10(2),M8(1),M16(2),OCTAL(4),REAL(3),CCHAR
	CHARACTER*1 DIGITS(16,3)
C
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /ITERA/ITCNTV
	COMMON /DIGV/ DIGITS
	character*127 c11wrk
C
	DATA KIND
     1/'@','A','B','C','D','E','H','I','M','N','O','R','S','V','Z'
     2,'P','W','G','Q','F','J','X','U'/
C NOTE PWGQFJX ADDED BY GCE FOR PORTACALC INTERFACE.
C  FREE: K,U,Y, + SPECIAL CHARACTERS (LIKE .,;'"#$%^, ETC.)
	DATA  ASCII/'S','C','I','I'/,  DEC/'E','C','I','M','A','L'/
	DATA  HEX/'E','X'/, INT/'N','T','E','G','E','R'/
	DATA  M10/'1','0'/,  M8/'8'/
	DATA  M16/'1','6'/
	DATA  OCTAL/'C','T','A','L'/
	DATA  REAL/'E','A','L'/
C	DATA WRKX/130*0/,WRK2X/130*0/
C
C
C
C PICK UP NON-BLANK CHARACTER AFTER '*'
	RETCD=1
	CALL GETNNB(IPT,RETCD2)
	GOTO(2,4),RETCD2
	STOP 2
2	NONBLK=IPT
C NONBLK POINTS TO 1ST NONBLANK CHARACTER AFTER *
C
	DO 3 I=1,23
	IF (LINE(NONBLK).EQ.KIND(I)) GOTO 6
3	CONTINUE
C
C
C UNIDENTIFIED COMMAND
4	GOTO 995
C
C
C
C GO TO DIFFERENT SECTIONS ON THE BASIS OF THE FIRST CHARACTER
C OF THE COMMAND.
6	GOTO (10,20,30,1000,40,50,60,70,80,90,100,110,50,
     1  130,140,210,220,250,290,330,360,480,780),I
	STOP 6
C
C
C
C
C **************************************************
C *****    *@  INDIRECT COMMAND PROCESSING    ******
C **************************************************
10	CALL AT(RETCD)
	GOTO (1000,999),RETCD
	STOP 10
C
C
C
C
C **************************************************
C ******      *A     DECLARE TYPE ASCII       ******
C **************************************************
20	CALL STRCMP (ASCII,4,RETCD2)
	ID=1
	GOTO (200,995),RETCD2
	STOP 20
C
C
C
C
C **************************************************
C ******       *B      BASE DEFAULT          *******
C **************************************************
30	CONTINUE
	CALL BASCNG(RETCD2)
	write(c11wrk,34)based
	c11wrk(20:20)=char(13)
	c11wrk(21:21)=char(10)
	IF(VIEWSW.NE.0)call vwrt(c11wrk,21)
34	FORMAT(' DEFAULT BASE IS ',I2)
	GO TO (1000,999),RETCD2
	STOP 30
C
C
C
C
C ********************************************************
C **   *C   COMMENT, JUST RETURN (VIA STATEMENT 1000)   **
C ********************************************************
C
C
C
C **************************************************
C *******     *D     DECLARE TYPE DECIMAL    *******
C **************************************************
40	CALL STRCMP(DEC,6,RETCD2)
	ID=2
	GOTO (200,995),RETCD2
	STOP 40
C
C
C **************************************************
C **********          *E   EXIT             ********
C **************************************************
50	CONTINUE
C SET RETCD=4 ON EXIT IF EXIT COMMAND, SO CALC RETURNS TO ITS CALLER.
	IF (LEVEL.EQ.1) RETCD=4
	IF (LEVEL.EQ.1) RETURN
C	IF (LEVEL.EQ.1) CALL EXIT
	IF(ITCNTV(LEVEL).EQ.0)GOTO 55
	IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
C ITERATION VARIABLE IS POSITIVE SO EXECUTE FILE AGAIN
	REWIND LEVEL
	GO TO 1000
C
C NOTE THAT WHEN EXITING A LEVEL THAT WAS ITERATED, ITCNTV
C IS NOT SET TO ZERO. THIS REQUIRES THAT WHEN ENTERED AT
C SUBROUTINE 'AT' AND ITERATION IS NOT DESIRED, THAT ITCNTV
C MUST BE SET TO ZERO THERE

55	CLOSE(LEVEL)
	LEVEL=LEVEL-1
59	GOTO 1000
C
C
C
C
C
C **************************************************
C * *H DECLARE VARIABLES TO BE OF TYPE HEXADECIMAL *
C **************************************************
60	CALL STRCMP (HEX,2,RETCD2)
	ID=3
	GOTO (200,995),RETCD2
	STOP 60
C
C
C
C
C **************************************************
C * *I DECLARE VARIABLE TO BE OF TYPE INTEGER (*4) *
C **************************************************
70	CALL STRCMP (INT,6,RETCD2)
	ID=4
	GOTO (200,995),RETCD2
	STOP 70
C
C
C **************************************************
C *  *M  DECLARE VARIABLE TO BE MULTIPLE PRECISION *
C **************************************************
80	CALL STRCMP (M10,2,RETCD2)
	ID=5
	GOTO (200,84),RETCD2
	STOP 80
C
C
C  SEE IF MULTIPLE PRECISION IS OCTAL
84	CALL STRCMP (M8,1,RETCD2)
	ID=6
	GOTO (200,88),RETCD2
	STOP 84
C
C
C  SEE IF MULTIPLE PRECISION HEXADECIMAL
88	CALL STRCMP (M16,2,RETCD2)
	ID=7
	GOTO (200,995),RETCD2
	STOP 88
C
C
C
C
C ************************************************************
C **  *N SUPPRESS PRINTING OF VARIABLES WHEN VALUES CHANGE  **
C ************************************************************
90	VIEWSW=1
	GOTO 1000
C
C
C
C
C **************************************************
C ***  *O  DECLARE VARIABLE TO BE OF TYPE OCTAL  ***
C **************************************************
100	CALL STRCMP (OCTAL,4,RETCD2)
	ID=8
	GOTO (200,995),RETCD2
	STOP 100
C
C
C
C
C
C **************************************************
C ***********     *R ENCOUNTERED       *************
C **************************************************
C
C  *R	SEE IF A REAL DECLARATION
110	CALL STRCMP (REAL,3,RETCD2)
	ID=9
	GOTO (200,114),RETCD2
	STOP 110
C
C
C  OTHERWISE ASSUME A READ IS REQUIRED
114	IF (LEVEL.NE.1) GOTO 117
c	Rewind 11
	c11wrk=char(13) // char(10) // 'Calr>'
	call vwrt(c11wrk,7)
c	WRITE(11,116)
c	Rewind 11
	GOTO 118
c116	FORMAT(' CALR>',$)
117	Continue
c	Rewind 11
	c11wrk=char(13) // char(10) // 'Calc0>'
	c11wrk(7:7)=char(48+level)
	call vwrt(c11wrk,8)
cc	WRITE (11,119) LEVEL
c	Rewind 11
119	FORMAT (' CALC<',I1,'>',$)
118	Continue
c	Rewind 11
	Call vget(line,80)
c	READ (11,115,END=1000,ERR=990) LINE
c	Rewind 11
115	FORMAT (80A1)
C
C  NOTE THAT IF <CR> IS HIT AS THE ONLY INPUT, RETURN IS NORMAL
C  AND PROCESSING CONTINUES ON LEVEL (RETCD=2)
	RETCD=2
	GOTO 1000
C
C
C
C
C
C ************************************************************
C ***  *V ACTIVATE PRINTING OF VARIABLE WHEN VALUES CHANGE ***
C ************************************************************
129	NONBLK=IPT
130	CALL GETNNB(IPT,RETCD2)
	GO TO (129,132),RETCD2
	STOP  130
132	CCHAR=LINE(NONBLK)
	IF(CCHAR.NE.DIGITS(10,1))GO TO 134
C
C  *VIEW 0 ENCOUNTERED
	VIEWSW=0
	GO TO 1000
134	IF(CCHAR.NE.DIGITS(1,1))GO TO 136
C
C *VIEW 1 ENCOUNTERED
	VIEWSW=1
	GO TO 1000
136	IF(CCHAR.NE.DIGITS(2,1))GO TO 138
	VIEWSW=2
	GO TO 1000
138	VIEWSW=3
	GOTO 1000
C
C
C
C
C **************************************************
C **********   *Z   ZERO OUT ALL VARIABLES  ********
C **************************************************
140	CALL ZERO
	GOTO 1000
C
C
C
C
C
C MAKE DECLARATIONS
200	CALL DECLR(ID,RETCD2)
	GO TO(1000,999),RETCD2
	STOP 200
C
C
C
C
C
C **** ERROR PROCESSING ****
C
990	I=27
	REWIND LEVEL
	GO TO 998
995	I=3
998	CALL ERRMSG(I)
999	RETCD=3
1000	CONTINUE
	RETURN
C
C P COMMAND - SET PLACEMENT OF PHYSICAL POSN IN SHEET
C *P WILL PROMPT FOR INPUTS OF LOCATIONS.
C
210	CONTINUE
C
	RETCD=1
	CALL CMND2(RETCD,1)
	RETURN
C W COMMAND - WRITE % TO CURRENT PHYSICAL LOC IN SHEET. USE E32.25
C FORMAT.
C  DOES NOT PROMPT. THEREFORE, IF USED INSIDE SPREADSHEET, HAS THE
C  EFFECT OF CONVERTING CURRENT CELL'S FORMULA TO A LITERAL NUMBER
C  AND FREEZING IT THAT WAY. THEREFORE A FORMULA CONTAINING *W WILL
C  NORMALLY ONLY EXECUTE THE *W ONCE (AFTERWARDS BEING OVERWRITTEN).
C
220	CONTINUE
	RETCD=1
	CALL CMND2(RETCD,2)
C
	RETURN
C
C *G SEEN.
C THE SYNTAX OF *G IS *G V1,V2 WHICH WILL GET VALUE OF VBLS(G1,G2)
C  AND LOAD IT INTO %. THE DIMENSIONS ARE CLAMPED TO LEGAL BOUNDS
C  AND TYPE=4 MEANS USE INTEGER, TYPE=2 CONVERTS VARIABLES TO
C  INTEGER. CALLS VARSCN TO DO THIS STUFF.
C  THIS GIVES A MEASURE OF INDIRECTION.
250	CONTINUE
	RETCD=1
C SAY ALL'S WELL.
	CALL CMND2(RETCD,3)
C
	RETURN
C
C *Q QUERY DATABASE COMMAND
C
C
290	CONTINUE
	RETCD=1
	CALL CMND2(RETCD,4)
C
	RETURN
C
C *F LABEL  GOTO LABEL COMMAND (CONDITIONAL)
C
C
C THE SYNTAX OF THE *F COMMAND IS :
C  *F LABEL
C  WITH THE OPERATION OF LOCATING A LINE BEGINNING WITH THE
C  STRING "*CLABEL" (SO IT IS PASSED OVER BY NORMAL CALC
C  PROCESSING). THE INPUT FILE ON IOLVL IS REWOUND AND
C  SCANNING GOES TO THE EOF OR UNTIL THE STRING IS FOUND.
C  RETCD=2 IF NO SUCH LABEL IS FOUND.
C
C  AS A FURTHER AID, IF THE % VARIABLE IS 0 OR NEGATIVE, THE
C  COMMAND IS IGNORED.
330	CONTINUE
	RETCD=1
	CALL CMND2(RETCD,5)
C
	RETURN
C
C *J LABEL - JUST LIKE *F LABEL BUT ON CALC'S COMMAND FILES.
C I.E., FINDS A LINE STARTING WITH *CLABEL
C (NOTE IT STARTS FROM START OF FILE AND DOES THIS ONLY IF % IS POSITIVE).
C ITERATION OF COMMAND FILES REMAINS UNDER NORMAL CONTROL.
360	CONTINUE
	RETCD=1
	CALL CMND2(RETCD,6)
	RETURN
C *X COMMAND
C  XC FILESPEC CELLNAME
C    READS FILESPEC AS A SAVED SPEADSHEET (NUMERIC OR FORMULA)
C  AND LOADS ITS VALUE INTO CURRENT CELL AND % ACCUMULATOR. DOES
C  NOT LOAD FORMULA UNLESS F SEEN. THUS 2 VARIANTS:
C   *XF FILESPEC CELLNAME	LOAD FORMULA AND VALUE
C   *XV FILESPEC CELLNAME	LOAD VALUE
C NOTE ANY CHARACTER AFTER *X THAT ISN'T "F" IS EQUIVALENT TO V FOR EASY USE.
480	CONTINUE
	RETCD=1
	CALL CMND2(RETCD,7)
	RETURN
C *U FUNCTION ARGS
C HANDLE USER FUNCTION CALL...
780	CONTINUE
	RETCD=1
C PASS LINE AND ARGS TO SUBROUTINE TO PARSE (EXTERNALIZE THE WORK)
C COMMON /V/ HAS DATA NEEDED FOR ARGUMENTS...
	CALL USRFCT(LINE,RETCD,WRK2)
C IF RETCD CHANGES IN USRFCT THIS ALLOWS ERROR CODES BACK.
	RETURN
	END
c -h- cmnd2.f40	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CMND2(RETCD,I)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C
C EXTRA ROUTINES MOVED HERE FROM INSIDE CMND SO THAT THEY CAN BE OVERLAIN IN
C 256K VERSION TO GAIN A GREAT DEAL OF SPACE.
	INCLUDE APARMS.INC
	EXTERNAL INDX
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
C	InTeGer*4 IOLVL
C	COMMON/IOLVL/IOLVL
	InTeGer*4 ZNEG,ITCNTV(6)
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
	CHARACTER*1 WRK2(128),LETA
	CHARACTER*35 CWRK,CWRKX,CWRK2
	CHARACTER*50 CWRK50
	EQUIVALENCE (CWRK50(1:1),CWRK(1:1))
	CHARACTER*11 CWRK2B
	Character*1 wrk2b(11)
	CHARACTER*1 WRKX(130),WRK2X(130)
	Character*1 WRK(128)
	EQUIVALENCE(CWRK2B,WRK2(1),Wrk2b(1),Cwrk2)
c	EQUIVALENCE(CWRK2,WRK2(1))
	EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
C	EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
c	EQUIVALENCE(WRK(1),WRKX(1))
	EQUIVALENCE(WRK2(1),WRK2X(1))
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XAC,XVBLS(1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(XAC,AVBLS(1,27))
	EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	CHARACTER*1 FVLD(1,1)
	COMMON/FVLDC/FVLD
C
	CHARACTER*1  LINE(80),CCHAR
	CHARACTER*1 DIGITS(16,3)
C
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /ITERA/ITCNTV
	COMMON /DIGV/ DIGITS
C I ARGUMENT SELECTS COMMAND.
C 1 = *P
C 2 = *W
C 3 = *G 
C 4 = *Q
C 5 = *F
C 6 = *G
C 7 = *X
	IF(I.NE.1)GOTO 7000
C *P COMMANDS
C IF THE COMMAND IS *P VAR THEN SET TO VARIABLE LOCATION.
	KK1=3
	KK2=20
	IF(LINE(3).EQ.'@')GOTO 217
C ONLY LOOK IN COLS 3-20. COLUMNS 1,2 ARE THE *W COMMAND.
	CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
	IF(IVLD.NE.0)GOTO 216
	GOTO 218
217	CONTINUE
C ALLOW *W@V1,V2 TO GOTO LOCATION OF V1,V2 (COL,ROW)
C  THIS ALLOWS PROGRAMMED ACCESS TO VARIABLES.
	L1=4
	L2=60
	CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
	IF(IVLD1.EQ.0)GOTO 1000
	CALL TYPGET(ID1A,ID2A,TYPE(1,1))
	IF(TYPE(1,1).EQ.2)GOTO 219
	CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
	LCL=JVBLS(1,1,1)
	GOTO 2200
219	CONTINUE
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	LCL=XVBLS(1,1)
2200	CONTINUE
C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
	L1=LSTCH+1
	L2=60
C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
	CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
	IF(IVLD2.EQ.0)GOTO 1000
C SEEMS LIKE OK VARIABLE... GO AHEAD
	CALL TYPGET(ID1B,ID2B,TYPE(1,1))
	CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
	LRW=JVBLS(1,1,1)
	IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
	IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
	LRW=LRW+1
C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
C CLAMPING TO MAX VALUES.
	LCL=MAX0(1,LCL)
	LRW=MAX0(1,LRW)
	LCL=MIN0(LCL,MCOLS)
	LRW=MIN0(LRW,MROWS)
	KK=LCL
	KKK=LRW
	GOTO 216
218	CONTINUE
c	rewind 11
	IF(LEVEL.EQ.1)call Vwrt(' Set Phys loc. Column=',22)
c211	FORMAT(' SET PHYS LOC. COLUMN=')
c	rewind 11
	LLLV=LEVEL
	IF(LEVEL.EQ.1)LLLV=11
	if(lllv.ne.11)READ(LLLV,212,END=700,ERR=700)KK
	if(lllv.eq.11)call vgeti(kk)
212	FORMAT(I7)
c	rewind 11
	IF(LEVEL.EQ.1)Call Vwrt(' Set Phys loc. Row=',19)
c213	FORMAT(' SET PHYS LOC. ROW =')
c	rewind 11
	If(lllv.ne.11)READ(LLLV,212,END=700,ERR=700)KKK
	if(lllv.eq.11)call Vgeti(kkk)
c	rewind 11
	KKK=KKK+1
216	KK=MAX0(1,KK)
	KKK=MAX0(1,KKK)
	KK=MIN0(MCOLS,KK)
	KKK=MIN0(MROWS,KKK)
C CLAMP TO LEGAL SIZE
	PROW=KK
	PCOL=KKK
C
	RETURN
C TERMINAL READ ERROR AND END PROCESSING
700	CONTINUE
c	IF(LEVEL.EQ.1)CLOSE(11)
c	IF(LEVEL.EQ.1)OPEN(11,FILE='CON:20/100/300/40/Analy Command')
	IF(LEVEL.NE.1)REWIND LEVEL
	IF(ITCNTV(LEVEL).EQ.0)GOTO 55
	IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
	RETURN
7000	CONTINUE
	IF(I.NE.2)GOTO 7200
C *W COMMANDS
C	IRX=(PCOL-1)*60+PROW
	CALL REFLEC(PCOL,PROW,IRX)
	CALL WRKFIL(IRX,WRK,0)
C	READ(7'IRX)WRK
C GET RECORD INTO MEMORY
	IF(LINE(3).EQ.'F')GOTO 224
	WRITE(CWRK(1:35),221)XAC
C	ENCODE(35,221,WRK)XAC
C PUT VARIABLE VALUE AS STRING INTO FILE BUFFER
221	FORMAT(D32.25)
	GOTO 225
224	CONTINUE
C WRITE AND USE LOCAL FORMAT
	WRK2(1)='('
	DO 226 K=1,9
	WRK2(1+K)=WRK(119+K)
226	CONTINUE
	WRK2(11)=')'
	WRITE(CWRK(1:35),WRK2B)XAC
225	CONTINUE
	DO 222 K=36,110
222	WRK(K)=CHAR(32)
	CALL WRKFIL(IRX,WRK,1)
C	WRITE(7'IRX)WRK
	RETURN
7200	CONTINUE
	IF(I.NE.3)GOTO 7400
C *G COMMANDS
	L1=3
	L2=60
	CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
	IF(IVLD1.EQ.0)GOTO 1000
	CALL TYPGET(ID1A,ID2A,TYPE(1,1))
	IF(TYPE(1,1).EQ.2)GOTO 251
	CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
	LCL=JVBLS(1,1,1)
	GOTO 252
251	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	LCL=XVBLS(1,1)
252	CONTINUE
C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
	L1=LSTCH+1
	L2=60
C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
	CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
	IF(IVLD2.EQ.0)GOTO 1000
C SEEMS LIKE OK VARIABLE... GO AHEAD
	CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
	CALL TYPGET(ID1B,ID2B,TYPE(1,1))
	LRW=JVBLS(1,1,1)
	IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
	IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
	LRW=LRW+1
C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
C CLAMPING TO MAX VALUES.
	LCL=MAX0(1,LCL)
	LRW=MAX0(1,LRW)
	LCL=MIN0(LCL,MCOLS)
	LRW=MIN0(LRW,MROWS)
C RETURN VALUE.
	CALL TYPGET(LCL,LRW,TYPE(1,1))
	IF(TYPE(1,1).EQ.2)CALL XVBLGT(LCL,LRW,XAC)
	IF(TYPE(1,1).NE.2)CALL JVBLGT(1,LCL,LRW,JVBLS(1,1,1))
	IF(TYPE(1,1).NE.2)XAC=JVBLS(1,1,1)
C USE IMPLICIT CONVERSION FROM FORTRAN HERE. NOTE WE RETURN WITH
C THE LOOKED UP VALUE IN XAC.
	RETURN
7400	CONTINUE
	IF(I.NE.4)GOTO 7600
C *Q COMMANDS
C *Q QUERY DATABASE COMMAND
C
C
C THIS COMMAND IS DESIGNED TO PERMIT CALC TO ACCESS SEQUENTIAL (FOR NOW)
C FILES AND PULL IN VALUES. ARRAY WRK IS USED TO HOLD THE RECORDS AND
C MAY DISPLAY WHATEVER IS DESIRED.
C
C OPERATION IS AS FOLLOWS:
C
C *QW/F filespec ?KEYSTRING? <cc>
C WHERE THE W/F FLAG MEANS WRITE TO FORMULA AT CURRENT LOC (MAYBE MODIFIED
C EARLIER BY THE *P COMMAND) AND F FLAG MEANS RETURN % AS VALUE OBTAINED BY
C ATTEMPTING A DECODE ON THE FILE LINE BETWEEN DELIMITER CHARACTERS
C cc GIVEN INSIDE  CHARACTERS. FILE IS ASSUMED TO START WITH
C "KEYSTRING" WHERE ANY CHARACTER IS A MATCH EXACTLY EXCEPT THAT
C THE _ CHARACTER INDICATES A WILDCARD.
C SPECIAL CASES:
C  IF ` IS 1ST CHAR OF KEYSTRING, RECORDS MUST HAVE KEYSTRING STARTING
C AT COL 1 (EXCLUDING THE `)
C  IF <CC> STRING HAS ` AS 1ST CHARACTER, THEN IT IS OF FORM
C <`NM> WHERE N=ASCII CODE FOR COLUMN WANTED + 32 AND M = ASCII CODE
C   FOR LENGTH DESIRED + 32
C  THIS ALLOWS POSITIONAL RETRIEVAL (THOUGH PAINFULLY)
C
C A SECOND KEYSTRING MAY BE ENTERED INSIDE A SECOND PAIR OF ? CHARACTERS TOO.
C  THE SEARCH WILL SEEK THE KEYS ANYWHERE IN THE RECORDS READ, UP TO 128
C  CHARACTERS LONG EACH.
C SECOND KEYSTRING MAY NOT BE ANCHORED TO START OF LINE.
C  AS AN ADDED ATTRACTION:
C   *QFK  OR *QFN  WON'T CLOSE LUN 4 AT END. IN ADDITION *QFN WON'T
C  CLOSE IT AT START EITHER ALLOWING SEQUENTIAL RETRIEVALS OUT OF
C  DATA FILES. DITTO *QW VARIANTS.
C	IRX=(PCOL-1)*60+PROW
	CALL REFLEC(PCOL,PROW,IRX)
C	IF(LINE(3).EQ.'W')READ(7'IRX)WRK
	IF(LINE(3).EQ.'W')CALL WRKFIL(IRX,WRK,0)
	IF(LINE(3).NE.'W'.AND.LINE(3).NE.'F')RETURN
	IL=INDX(LINE,32)
	IF(IL.GT.40)GOTO 299
	IL2=INDX(LINE(IL+1),32)
	IF(IL2.GT.38)GOTO 299
C ENSURE LUN 4 AVAILABLE
	IF(LINE(4).NE.'C'.AND.LINE(4).NE.'N')CLOSE(4)
	LINE(IL2+IL)=CHAR(0)
	IF(LINE(4).NE.'N'.AND.LINE(4).NE.'C')
     1   CALL RASSIG(4,LINE(IL+1))
C THIS MAKES LUN 4 BE THE ONE WE WANT
	LINE(IL2+IL)=CHAR(32)
	KKK=ICHAR('?')
	IQ1=INDX(LINE,KKK)
C LOCATE THE KEY
	IF(IQ1.GE.70)GOTO 299
	KKK=ICHAR('?')
	IQ2=INDX(LINE(IQ1+1),KKK)
	IF(IQ2.GE.72)GOTO 299
C NOW KNOW KEY IS IQ2-1 LONG, STARTS AT IQ1+1
C
C ALLOW DOUBLE KEYS IF ANOTHER ?? PAIR IS SEEN.
	KEYS2=0
	KKK=ICHAR('?')
	IQ3=INDX(LINE(IQ1+IQ2+1),KKK)
	IF(IQ3.GT.3)GOTO 297
C WELL, THERE'S A 2ND STRING THERE MAYBE.
	IQ4=INDX(LINE(IQ3+IQ1+IQ2+1),KKK)
	IF(IQ4.GT.30)GOTO 297
	IF(IQ4.EQ.1)GOTO 297
	KEYS2=1
C FLAG WE HAVE A SECOND KEY. SOMETHING'S THERE.
	LCL=IQ3+IQ2+IQ1+1
	LRW=LCL+IQ4-1
297	READ(4,332,END=299,ERR=299)WRK2
	IQQ=IQ2-1
	IXX=128-IQ2
C COMPARE THE ENTIRE RECORD FOR THE KEY, MATCH ANYWHERE.
	IF(LINE(IQ1+1).NE.'`')GOTO 376
C IF 1ST CHAR OF KEY IS ` THEN SEARCH BEGINS AT LINE START ONLY. KEY IS
C 1 LESS.
	IQ1=1+IQ1
	IXX=1
	IQQ=IQQ-1
C ADJUST SO SEARCH IS 1 CHAR LESS.
376	CONTINUE
	DO 350 KKK=1,IXX
	CALL SCMP(LINE(IQ1+1),WRK2(KKK),IQQ,ICOD)
	IF(ICOD.NE.0)GOTO 351
350	CONTINUE
C DON'T JUST FALL THRU
	GOTO 353
351	CONTINUE
	IF(KEYS2.EQ.0)GOTO 353
C CHECK SECOND KEY STRING IN RECORD IF ANY WAS ASKED FOR.
C (THAT'S ALL YOU GET. 2 KEYS MAX.)
C LINE(LCL) TO LINE(LRW) CONTAINS KEY.
	IXY=128-IQ4+1
	ICC=IQ4-1
	DO 354 KKK=1,IXY
	CALL SCMP(LINE(LCL),WRK2(KKK),ICC,ICOD)
	IF(ICOD.NE.0)GOTO 355
354	CONTINUE
355	CONTINUE
353	IF(ICOD.EQ.0)GOTO 297
C HERE FOUND THE KEYED RECORD. NOW EXAMINE COMMAND LINE FOR
C SPECIAL CHARACTERS. IF NONE, JUST COPY THE FIRST CHARACTERS
C IN THE TEXT INTO EITHER THE BUFFER OR ENCODE THEM.
	KKK=ICHAR('<')
	IQ1=INDX(LINE,KKK)
	IF(IQ1.LE.0.OR.IQ1.GT.75)GOTO 296
	KKK=ICHAR('>')
	IQ2=INDX(LINE(IQ1+1),KKK)
	IF(IQ2.LE.0.OR.IQ2.GT.8)GOTO 296
	KKQ=ICHAR(LINE(IQ1+1))
	KK=INDX(WRK2,KKQ)
C MUNGE THE SEARCH SO THAT IF THE SPECIAL CHAR IS ` THEN THE NEXT 2
C CHARACTERS HAVE START AND LENGTH ENCODED AS ASCII CODE -32 DECIMAL
C WHICH ALLOWS FIELDS TO BE PLACED ANYWHERE (THOUGH SOMEWHAT PAINFULLY)
	IF(LINE(IQ1+1).EQ.'`')KK=ICHAR(LINE(IQ1+2))-32
	IF(KK.GT.125)GOTO 299
C NOTE THAT THE KEY FORM WOULD THEN GIVE
C  <`!@> FOR START COLUMN=1 AND LENGTH =32 (ASCII 64 = @ AND ASCII 33 = !)
C THIS MEANS USER HAS TO KNOW ASCII ORDER BUT AT LEAST IT'S IN MANUAL.
	IF(LINE(IQ1+1).EQ.'`')KKK=ICHAR(LINE(IQ1+3))-32
	KKQ=ICHAR(LINE(IQ1+2))
	IF(LINE(IQ1+1).NE.'`')KKK=INDX(WRK2(KK+1),KKQ)+KK
	GOTO 295
296	CONTINUE
C DEFAULT, NO SPECIAL CHARS.
	KK=0
	KKK=110
295	CONTINUE
	KL=KKK-KK-1
	KK=KK+1
	IF(LINE(3).NE.'W')GOTO 294
	KL=MIN0(KL,109)
	DO 293 N=1,KL
	WRK(N)=WRK2(KK)
293	KK=KK+1
	WRK(KL+1)=0
C WRITE OUT THE RECORD'S KEY PART INTO SHEET FILE
	CALL WRKFIL(IRX,WRK,1)
C	WRITE(7'IRX)WRK
	XAC=1.
	GOTO 298
294	CONTINUE
C FLOAT THE VALUE, RETURN IN XAC
	DO 750 N=1,35
	WRK(N)=CHAR(32)
	IF(N.LE.KL)WRK(N)=WRK2(KK-1+N)
750	CONTINUE
	READ(CWRK(1:35),221,ERR=299)XAC
C	DECODE(KL,221,WRK2(KK),ERR=299)XAC
298	CONTINUE
C IF IT'S A KEEP OR NEXT TYPE OPERATION, LEAVE LUN 4 OPEN.
C FIRST ONE MUST BE A KEEP (TO OPEN FILE IN THE FIRST PLACE)
C AND SUBSEQUENT OPERATIONS MAY BE A N OPERATIONS, WHICH
C WILL JUST CONTINUE SEQUENTIAL READIN OF DATA. USER HAS TO
C KEEP TRACK. NOTE RETURN VALUE IS -999999. (6 9'S) IF WE
C FAIL AND HAVE TO CLOSE FILE.
	IF(LINE(4).EQ.'K'.OR.LINE(4).EQ.'N')RETURN
	CLOSE(4)
	RETURN
299	CONTINUE
C RETURN -999999 IF WE FAIL IN FINDING FILE.
	XAC=-999999.
	CLOSE(4)
C	COME HERE FOR NON-RECOVERABLE ERRORS IN FORMAT TOO.
C
	RETURN
7600	CONTINUE
	IF(I.NE.5)GOTO 7800
C *F COMMANDS
	IF(XAC.LE.0)RETURN
	REWIND IOLVL
	IF(IOLVL.EQ.11)RETURN
333	READ(IOLVL,332,END=331,ERR=331)WRK
332	FORMAT(128A1)
	IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 333
	ISSL=2
	ISSS=2
	IF(LINE(3).EQ.' ')ISSL=3
	IF(WRK(3).EQ.' ')ISSS=3
	CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
	IF(ICODE.EQ.0)GOTO 333
	RETURN
C ERROR ENTRY WHERE WE SEE WE FAILED TO FIND LABEL.
331	CONTINUE
	IF(IOLVL.NE.11)CLOSE(IOLVL)
	IOLVL=11
	RETCD=2
C
	RETURN
7800	CONTINUE
	IF(I.NE.6)GOTO 8000
C *G
	IF(LEVEL.EQ.1.OR.XAC.LE.0)RETURN
	REWIND LEVEL
363	READ(LEVEL,362,END=55,ERR=55)WRK
362	FORMAT(128A1)
	IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 363
	ISSL=2
	ISSS=2
	IF(LINE(3).EQ.' ')ISSL=3
	IF(WRK(3).EQ.' ')ISSS=3
	CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
	IF(ICODE.EQ.0)GOTO 363
C
	RETURN
8000	CONTINUE
	IF(I.NE.7)GOTO 8200
C *X COMMANDS
C NOW GET THE ARGS
	JFFG=0
	IF(LINE(3).EQ.'F')JFFG=1
C NOW HAVE FORMULA FLAG.
	IQ3=4
C ALLOW 1 SPACE OPTIONALLY
	IF(LINE(IQ3).EQ.' ')IQ3=5
	IQ1=INDX(LINE(IQ3),32)
	IQ1=IQ1+IQ3-1
C NULL TERMINATE FILENAME WHILE PARSING IT (DON'T LET ASSIGN SEE VBL NAME)
	LINE(IQ1)=0
	CLOSE(4)
9770	CALL RASSIG(4,LINE(IQ3))
C REPLACE THE SPACE FOR VARSCN'S SIGHT
	LINE(IQ1)=CHAR(32)
C IQ1 NOW HAS START INDEX FOR VARSCN DESIRED... GO GET VRBL NAME.
	KK1=IQ1
	KK2=IQ1+20
	CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
	IF(IVLD.LE.0)GOTO 481
C GOT VALID VARIABLE NAME. KK,KKK ARE ROW,COL
C NOW WE KNOW HOW TO RETRIEVE THE DATA OFF FILE IN UNIT 4
C READ INTO WRK ARRAY TILL WE GET IT.
	IQ3=KK
	IQ4=KKK-1
483	READ(4,332,END=488,ERR=488)WRK
C IGNORE TITLE
486	CONTINUE
C NOTE WE READ IN THE NUMBER IN NUMERIC FORMAT. EASIER THAT WAY.
c	IF(JFFG.EQ.0)READ(4,484,END=488,ERR=488)IRRW,ICCL,XYVAL
c	IF(JFFG.NE.0)READ(4,489,END=488,ERR=488)IRRW,ICCL,
c     1  (WRK(IV),IV=1,110)
c484	FORMAT(1X,I5,1X,I5,1X,E50.35)
c489	FORMAT(1X,I5,1X,I5,1X,110A1)
	READ(4,484,END=488,ERR=488)LETA,IRRW,ICCL,
     1  (WRK(IV),IV=1,110)
C ALWAYS READ TEXT AS ALPHA
	READ(CWRK50(1:50),6486,ERR=5486)XYVAL
C DECODE AND STORE IN XYVAL IF POSSIBLE
6486	FORMAT(BN,D50.35)
5486	CONTINUE
C HACK OUT TRAILING BLANKS
	DO 5322 IV=1,110
	IVV=111-IV
	IF(ICHAR(WRK(IVV)).GT.32)GOTO 5323
	WRK(IVV)=CHAR(0)
5322	CONTINUE
5323	CONTINUE
C &&&&
484	FORMAT(1A1,I5,1X,I5,1X,110A1,50A1)
	READ(4,485,END=488,ERR=488)LFVLD,(WRK(IV),IV=120,128),KKTYP
C ALLOW FLAG OF 3 FOR NUMERIC,RECALCULATE... 2 FOR NUMERIC, NO RECALC.
C 1 CONTINUES TO MEAN ALWAYS RECALCULATE.
	IF(LFVLD.LT.-1)LFVLD=-3
	IF(LFVLD.GT.1)LFVLD=3
C
485	FORMAT(I3,1X,9A1,1X,I5)
C READS IN AN ENTRY OF SAVED SHEET. TEST IF IN OUR RANGE.
	IF(IRRW.EQ.IQ3.AND.ICCL.EQ.IQ4)GOTO 487
	GOTO 486
487	CONTINUE
C SUCCESS. NOW FILL IN VALUE OR FORMULA.
	IF(JFFG.EQ.0)GOTO 6487
C IF READING IN FORMULA, TRY AND GET VALUE OUT OF VALUE
C RECORD
	IF(LETA.NE.'p')GOTO 6487
C OK, THIS IS A VALUE RECORD WHICH SHOULD BE IMMEDIATELY FOLLOWED
C BY A FORMULA RECORD.
C   JUST DECODE THE VALUE AND RECORD IT.
C  ... ACTUALLY IT'S ALREADY DECODED SO JUST RECORD IT.
	CALL XVBLST(PROW,PCOL,XYVAL)
	XAC=XYVAL
C GO BACK AND GET FORMULA
	GOTO 486
6487	CONTINUE
C	IRX=(PCOL-1)*60+PROW
	CALL REFLEC(PCOL,PROW,IRX)
	WRK(118)=CHAR(15)
	WRK(119)=CHAR(LFVLD)
	CALL FVLDST(PROW,PCOL,LFVLD)
C	FVLD(PROW,PCOL)=LFVLD
C SET UP TO SAVE FORMULA.
C SAVE EITHER FORMULA OR VALUE.
	IF(JFFG.EQ.0)GOTO 4890
	CALL CA2E(WRK,WRK2)
	CALL WRKFIL(IRX,WRK2,1)
	GOTO 488
4890	CONTINUE
C SET UP NUMBER IF HERE.
	CALL TYPSET(PROW,PCOL,KKTYP)
C	TYPE(PROW,PCOL)=KKTYP
	CALL FVLDST(PROW,PCOL,LFVLD)
C	FVLD(PROW,PCOL)=LFVLD
	CALL XVBLST(PROW,PCOL,XYVAL)
C	XVBLS(PROW,PCOL)=XYVAL
	XAC=XYVAL
488	CONTINUE
	CLOSE(4)
	RETURN
481	CONTINUE
	CLOSE(4)
	RETCD=2
C
	RETURN
8200	CONTINUE
55	CLOSE(LEVEL)
	LEVEL=LEVEL-1
1000	CONTINUE
	RETURN
	END
c -h- contyp.for	Fri Aug 22 13:00:17 1986	
	SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
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 *            SUBROUTINE CONTYP                   *
C
C
C  CONVERTS CONSTANT IN STACK(I,INDXX) FROM OLDTYP TO NEWTYP
C  IF OLDTYP.EQ.NEWTYP A RETURN IS MADE IMMEDIATELY.
C  NOTE THAT TYPE(INDXX) IS NOT CHANGED BY THIS ROUTINE
C  TYPE CODES:
C
C	0	NO CHANGE
C	1	ASCII
C	2	DECIMAL
C	3	HEXADECIMAL
C	4	INTEGER
c note: multiple precision conversions diked out
C	5	M10
C	6	M8
C	7	M16
C	8	OCTAL
C	9	REAL
C
C  RETCD	MEANING
C
C	1	O.K.
C	2	ERROR
C
C
C   MODIFY CLASSES:  M3,M4,M8
C
C  CONTYP CALLS:
C
C   ERRMSG   PRINTS OUT ERROR MESSAGES
C   MULCON   CONVERTS MULTIPLE PRECISION TO MULTIPLE PRECISION
C            OF A DIFFERENT BASE
C
C
C
C  CONTYP IS CALLED BY
C
C   CALUN    CALCULATES UNARY OPERATIONS
C   CALBIN   CALCULATES BINARY OPERATIONS
C   VARIABLE     USE
C
C  BASE        HOLDS BASE OR POWERS OF THAT BASE (INTEGER*4).
C  BASVEC      HOLDS LEGAL BASES: 8,10, AND 16
C  EIGHT(8)    CHARACTER*1 ARRAY TO PICK OFF REAL*8 VALUES.
C  FOUR(4)     CHARACTER*1 ARRAY TO PICK OFF INTEGER*4 VALUES.
C  I,J,M       TEMPORARY VALUES.
C  IBASE       HOLDS BASE OF A NUMBER WHEN BASE HOLDS THE POWERS
C              OF THAT BASE.
C  IEND        HOLDS THE NUMBER OF MULTIPLE PRECISION DIGITS THAT
C              WILL BE PICKED UP WHEN CONVERTING TO INTEGER*4.
C  INDXX       POINTER TO VARIABLE BEING CONVERTED.
C  INT         HOLDS INTEGER*4 VALUES EQUIVALENCED TO VECTOR FOUR.
C  IS          TEMPORARILY HOLDS MULTIPLE PRECISION BASE 8 OR BASE
C              16 DIGITS.
C  IS2         TEMPORARILY HOLDS A DIGIT VALUE WHEN CHECKING MULTIPLE
C              PRECISION BASE 8 AND BASE 16 NUMBERS TO SEE IF THEY
C              ARE TOO LARGE TO FIT IN INTEGER*4.
C  ISGN        USED WHEN DETERMINING THE MAXIMUM NUMBER THAT CAN BE
C              HELD BY INTEGER*4. 1=POSITIVE, 2= NEGATIVE. ALSO HOLDS
C              0 OR 7 FOR BASE 8 MAXIMUM NUMBER CHECK. HOLDS 0 OR 15
C              FOR BASE 16 MAXIMUM NUMBER CHECK.

C  K           TEMPORARILY HOLDS INTEGER*4 VALUES.
C  NEWTYP      NEW DATA TYPE REQUESTED.
C  OLDTYP      DATA TYPE OF THE VARIABLE TO BE CONVERTED.
C  RBASE       BASE WHEN CONVERTING FROM MULTIPLE PRECISION TO REAL*8.
C  REAL        HOLDS REAL*8 VALUES. EQUIVALENCED TO ARRAY EIGHT.
C  RETCD       RETURN CODE. 1=O.K.  2=ERROR.
C  RPOWER      HOLDS POWERS OF RBASE WHEN CONVERTING FROM MULTIPLE
C              PRECISION TO REAL*8.
C  STACK(I,INDXX)  HOLDS VARIABLE TO BE CONVERTED.
C
C
C	SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
C
	REAL*8 REAL,RBASE,RPOWER,DFLOAT
C
	INTEGER*4 K,INT,BASE
C
	InTeGer*4 OLDTYP,NEWTYP,RETCD,BASVEC(3),INDXX
	InTeGer*4 MAX10(10,2)
	InTeGer*4 I,M,J
	InTeGer*4 ISGN,IS,IS2
C
	CHARACTER*1 EIGHT(8),FOUR(4)
	CHARACTER*1 STACK(8,40)
C
	EQUIVALENCE (FOUR,INT),(REAL,EIGHT)
C
	DATA BASVEC/10,8,16/
	DATA MAX10/2,1,4,7,4,8,3,6,4,7,2,1,4,7,4,8,3,6,4,8/
C
C
C  SET DEFAULT RETURN CODE
	RETCD=1
	IF(OLDTYP.GT.0)GO TO 910
C
C VARIABLE UNDEFINED
	CALL ERRMSG(16)
	RETCD=2
	RETURN
C
C
C
910	IF(NEWTYP.EQ.0) RETURN
	IF (OLDTYP.EQ.NEWTYP) RETURN
	GOTO (1000,2000,3000,3000,4000,5000,6000,3000,2000), OLDTYP
	STOP 1000
C
C
C
C **************************************************
C **************  OLDTYP = ASCII  ******************
C **************************************************
C
C  START BY CONVERTING TO INTEGER*4
1000	CONTINUE
C
C
C  IF INTEGER, HEXADECIMAL OR OCTAL, ALMOST DONE
	DO 1002 I=2,8
1002	STACK(I,INDXX)=0
	IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
C
C
C
	DO 1008 I=1,4
1008	FOUR(I)=STACK(I,INDXX)
	IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) GOTO 1200
C
C
C  MULTIPLE PRECISION
1010	continue
	RETURN
C
C
C  DECIMAL OR REAL
1200	REAL=DFLOAT(INT)
	DO 1210 I=1,8
1210	STACK(I,INDXX)=EIGHT(I)
	RETURN
C
C
C
C **************************************************
C *********  OLDTYP = DECIMAL OR REAL  *************
C **************************************************
C
2000	IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) RETURN
C
C
	DO 2002 I=1,8
2002	EIGHT(I)=STACK(I,INDXX)
C
C
C  ZERO STACK(I,INDXX)
	DO 2004 I=1,8
2004	STACK(I,INDXX)=CHAR(0)
C
C
C  CONVERT TO INTEGER
C  MAKE SURE CONVERSION DOESN'T BLOW UP
	IF(REAL.LT.-2147483648.D0.OR.REAL.GT.2147483647.D0)
     1 GOTO 6050
C
C
C
2007	INT=REAL
C
C SEE IF NEWTYP IS MULTIPLE PRECISION
	IF (NEWTYP.GE.5.AND.NEWTYP.LE.7) GOTO 1010
	DO 2008 I=1,4
2008	STACK(I,INDXX)=FOUR(I)
C
C RETURN IF TYPE IS INTEGER, HEX, OR OCTAL
	IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
C
C ASCII SO CLEAR OUT BYES 2,3, AND 4
2009	DO 2010 I=2,4
2010	STACK(I,INDXX)=CHAR(0)
	RETURN
C
C
C
C
C
C
C **************************************************
C *******  OLDTYP = INTEGER, HEX, OR OCTAL  ********
C **************************************************
C
3000	IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
	DO 3002 I=1,4
3002	FOUR(I)=STACK(I,INDXX)
C
C SEE IF NEWTYP IS ASCII
	IF (NEWTYP.EQ.1) GOTO 2009
C
C IF NOT REAL*8 THEN IT IS MULTIPLE PRECISION (PROCESS AT 1010)
	IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 1010
C
C PROCESS AS REAL*8
	GOTO 1200
C
C *************  OLDTYP = M10  *********************
C
4000	CONTINUE
	RETURN
4040	continue
	RETURN
C
C **************  OLDTYP = M8  *********************
C
5000	CONTINUE
C ***************  OLDTYP = M16  *******************
C
6000	CONTINUE
	RETURN
C
C ***** ERROR RETURN ******
6050	RETCD=2
C ILLEGAL CONVERSION ATTEMPTED.
	CALL ERRMSG(26)
	RETURN
C
	END
c -h- imask.for	Fri Aug 22 12:54:45 1986	
	INTEGER FUNCTION IMASK(I1,I2)
	InTeGer*4 I1,I2
	InTeGer*4 IXX
	IXX=I1.AND.I2
	IMASK=IXX
	RETURN
	END
	REAL*8 FUNCTION DFLOAT(IN)
	INTEGER IN
	REAL*8 XX
	XX=IN
	DFLOAT=XX
	RETURN
	END
C ********ANALYASM.FTN ##################################3
c AnalytiCalc Amiga specific terminal I/O routines.
c note ttyini is also special and opens console window...
	Subroutine SWRT(ibuf,isz)
c write isz bytes from ibuf onto console window
	Include dos.inc
	Integer*4 Isz,i
	Integer*4 Amiga
	External Amiga
C	common/consfh/fh
	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
	If(fh.ne.0)I=amiga(Write,fh,ibuf,isz)
	return
	end
	Subroutine ttyin(IIMODE,line)
c read 132 char line off console
C iimode=0 in Command-Mostly mode, 1 in Enter mostly mode.
	Integer*4 iact,n,IIMODE
	include dos.inc
	Integer*4 Amiga
	External Amiga
C	common/consfh/fh
	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
	Character*1 wrkchr,lstchr
	Integer*4 iescst
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
	character*1 line(132)
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
	Integer*4 Kone
	Character*1 xlf
CCC	InTeGer*4 LLCMD,LLDSP
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
	xlf=char(10)
	iescst=0
	Kone=1
	wrkchr=char(0)
c initially, no ESC seen
c Set up to read raw: device OK.
c If we see an ESC character then look for either a return
c (to terminate in any case) or some character whose value is
c greater than 64. However ESC O will be passed and the scan will
c continue.
C implement deletion of last character also with DEL or with
C backspace keys
c
c Initially zero entire buffer so we later can find length via looking
c for anything non-zero. Also serves to put in terminators for things
c like the INDX function to prevent them from running on indefinitely.
	do 1 n=1,132
1	line(n)=char(0)
c if mode 0, (command mostly) then / is NOT special
	if(fh.eq.0)goto 1000
c Here begin the read loop
	n=1
4000	continue
	lstchr=wrkchr
	wrkchr=char(0)
C zero wrkchr for safety
	iact=amiga(Read,fh,wrkchr,Kone)
	If(Iact.le.0)goto 4000
	If(ichar(wrkchr).eq.0)goto 4000
CCC Add this to just read the line
CC	iact=amiga(Read,fh,line,132)
4050	Continue
	If(ichar(wrkchr).ne.8.and.ichar(wrkchr).ne.127)goto 4100
C back up a character and try again
c Last char was backspace or DEL, so back up by one, echo backspace.
	n=max0(1,(n-1))
	lstchr=char(8)
C echo a backspace
C 8 is ASCII backspace...
	ii=Amiga(Write,fh,Lstchr,Kone)
	Goto 4000
4100	Continue
c C.R. is 13, LF is 10, FF is 14, so terminate on any of these
c traditional line terminators.
	If(ichar(wrkchr).lt.16)goto 5000
c Normal character, just echo it.
	ii=Amiga(Write,fh,wrkchr,kone)
c echo the character back
c Then store it.
	line(n)=wrkchr
	n=min0(n+1,131)
	if(ichar(wrkchr).eq.27.or.ichar(Wrkchr).eq.155)iescst=1
c <ESC>O is actually an escape sequence initiator
	If(iescst.eq.1.and.wrkchr.eq.'O'.and.ichar(lstchr)
     1  .eq.27) goto 4200
c Otherwise an escape sequence ends in a letter
	If(Iescst.eq.0)goto 4200
	ii=ichar(wrkchr)
	If(ii.eq.91)goto 4200
c 91 is ascii for [
	If(ii.gt.64.and.ii.lt.127)Return
C terminate read at end of any escape sequence
c from A to z except [ are possible esc seq delimiters.
4200	Continue
c The above condition terminates an ESC sequence after ESC and any other
c characters followed by (and including) any character greater than 'A'
c which should take care of just about every ANSI escape sequence.
	if(n.lt.131)goto 4000
c Terminate even if we never get C.R. but not 'till we've got
c all there is to get...
	Return
5000	continue
c Echo line terminator
	line(n)=wrkchr
	ii=Amiga(Write,fh,wrkchr,kone)
	If(ichar(wrkchr).eq.13)ii=Amiga(Write,fh,xlf,Kone)
c echo lf after cr
c done reading now.
	Return
1000	Continue
C fakeout fallback position, reading workbench window
	Read(*,1500)line
1500	format(132a1)
	return
	end
	subroutine swset(i)
	integer*4 i
c dummy setup sub
	return
	end
	subroutine exitqq
c exit routine ... just do fortran stop to make it complete
	stop "AnalytiCalc exiting..."
	end
	subroutine system(line)
	include dos.inc
c execute an amigados command
	integer*4 inp,outp
	character*80 line
	character*80 l2
	logical*4 succ
	Logical*4 Amiga
	External Amiga
	do 1 n=1,79
	m=81-n
c space is ascii code 32
c look for trailing whitespace to remove
	if(ichar(line(m:m)).gt.32)goto 2
1	continue
2	n=m
c n= last character of non-null
	k=1
	if((line(1:1).eq.'$').or.(line(1:1).eq.'}'))k=2
	open(unit=2,file='ram:AnalyJnk.Tmp',status='new')
	write(2,1000)line(k:n)
	if(line(1:1).eq.'$')write(2,1001)
1000	format(A)
1001	Format('EndCLI')
	close(unit=2)
	inp=0
	outp=0
	if(line(1:1).eq.'$')l2=
     1  'NEWCLI CON:0/0/600/190/ASpwn FROM ram:AnalyJnk.Tmp'
     2  // char(0)
	if(line(1:1).ne.'$')l2=
     1  'NEWSHELL CON:0/0/600/190/ASpwn FROM ram:AnalyJnk.Tmp'
     2  // char(0)
	succ=amiga(Execute,l2,
     2  inp,outp)
	return
	end
C ************ AnalyDM.Ftn ######################################
c -h- declr.for	Fri Aug 22 13:02:54 1986	
	SUBROUTINE DECLR(ITYP,RETCD)
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  DECLR (ITYP,RETCD)           *
C *                                                *
C **************************************************
C
C
C ANALYZES VECTOR LINE TO DETERMINE WHAT VARIABLES GET THEIR
C TYPES CHANGED. THE NEW TYPE IS SPECIFIED AS AN ARGUMENT IN
C THE CALL:
C
C
C  TYPE CODE
C	1  ASCII
C	2  DECIMAL (REAL BUT DECIMAL POINT FOR OUTPUT)
C	3  HEXADECIMAL
C	4  INTEGER
C	5  MULTIPLE PRECISION (BASE 10)
C	6  MULTIPLE PRECISION (BASE 8)
C	7  MULTIPLE PRECISION (BASE 16)
C	8  OCTAL
C	9  REAL
C
C  IF NEGATIVE, TYPE IS DEFINED BUT VARIABLE HAS
C  NOT BEEN ASSIGNED A VALUE
C
C
C  RETCD     MEANING
C  1    =    O.K.
C  2    =    ERROR
C
C  NOTE:  AS IN FORTRAN, VARIABLES IN DECLARATIONS MUST BE SEPARATED
C         BY COMMAS
C
C
C  MODIFICATION CLASSES: M1, M2
C
C
C
C
C DECLR CALLS:
C
C  ERRMSG   PRINTS ERROR MESSAGES
C
C
C
C DECLR IS CALLED BY CMND, THE ROUTINE THAT DECODES COMMANDS.
C
C
C
C
C       VARIABLE        USE
C
C    ALPHA           LIST OF LEGAL VARIABLE NAMES. THE FIRST 26 ARE
C                    ALPHABETIC, THE 27TH IS THE CHARACTER '%'.
C    BLANK           ' '
C    I,I2,I3         TEMPORARY VALUES.
C    ITYP            CODE THAT GIVES THE TYPE OF VARIABLE FOR A
C                    PARTICULAR CALL TO THIS ROUTINE. VARIABLES ARE
C                    EITHER DECLARED TO BE OF THIS TYPE OR, IF NO
C                    VARIABLES ARE SPECIFIED, A LIST OF ALL THE
C                    VARIABLES OF THAT TYPE ARE GIVEN.
C    LEND            LAST NON-BLANK IN VECTOR LINE(80).
C    LINE(80)        HOLDS INPUT COMMAND LINE. IF DECLARATION HAS
C                    NO ARGUMENT, THIS VECTOR IS THEN USED TO OUTPUT
C                    A LIST OF VARIABLES OF THE TYPE SPECIFIED.
C    NONBLK          START SCAN OF VARIABLE LIST.
C    TYPE            HOLDS THE TYPE CODE FOR EACH VARIABLE.
C
C
C
C
C
C
C
C	SUBROUTINE DECLR(ITYP,RETCD)
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4  RETCD,VIEWSW,BASED,VLEN(9)
	InTeGer*4 TYPE(1,1)
	InTeGer*4 I,I2,I3,ITYP
C
	CHARACTER*1  LINE(80),AVBLS(20,27),VBLS(8,1,1)
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	Character*127 cwrk
C
	COMMON  /V/TYPE,AVBLS,VBLS,VLEN
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C
	IF(NONBLK.EQ.LEND)GO TO 500
C
C
C **************************************************
C ****** DECLARE VARIABLES TO BE OF TYPE ITYP ******
C **************************************************
	I2=NONBLK+1
10	CONTINUE
C10	IF (LINE(I2).EQ.BLANK) GOTO 60
C	DO 20 I3=1,26
C	IF (LINE(I2).EQ.ALPHA(I3)) GOTO 30
C20	CONTINUE
C *****&&&&& ADD VARIABLE SIZE SUPPORT - GCE
	CALL VARSCN(LINE,I2,LEND,LSTCHR,ID1,ID2,IVALID)
C VARSCN SEARCHES FOR VALID VARIABLE NAME STRINGS INCLUDING C$+EXPR
C AND R$+EXPR FOR LOC-RELATIVE NAMES IN ABSOLUTE AND C@+N, R@+N FOR RELATIVE
C NAMES IN DISPLAY SYSTEM. IT RETURNS THE ID1, ID2 INDICES FOR
C THE VARIABLES IN VBLS ARRAY AND TYPE ARRAY. FOR SINGLE ALPHAS
C A-Z, ID1 RETURNS 1-26 AND ID2=1. % RETURNS ID1=27, ID2=1.
	IF(IVALID.EQ.0) GOTO 22
C VALID FLAG IS NONZERO IF VARIABLE NAME IS VALID, ELSE 0.
	I2=LSTCHR
C LSTCHR RETURNS LAST CHARACTER OF NAME
	GOTO 30
C
C  ILLEGAL CHARACTER IN DECLARATION'S VARIABLE LIST
22	I=4
C
C
C
C ******* ERROR RETURN *******
25	RETCD=2
	CALL ERRMSG(I)
	RETURN
C
C
C
C
30	CONTINUE
C IF OLD VARIABLE WAS UNDEFINED, MAKE NEW TYPE LESS THAN 0 ALSO.
C THIS ALLOWS ONE TO EXAMINE INTERNAL VALUES FOR DIFFERENT DATA
C TYPES. IF THIS IS NOT NEEDED, IT WOULD BE CLEANER TO ALWAYS MAKE
C VARIABLES UNDEFINED WHEN THEIR DATA TYPE IS CHANGED. TO DO THIS
C JUST USE THE STATEMENT
C	I=-ITYP
	I=ITYP
C ****&&&&&& NOTE TYPE NOW 2-DIM
	CALL TYPGET(ID1,ID2,TYPE(1,1))
	IF(TYPE(1,1).LE.0)I=-I
	CALL TYPSET(ID1,ID2,I)
C	TYPE(ID1,ID2)=I
	I3=I2+1
	IF (I3.GT.LEND) GOTO 1000
	DO 40 I2=I3,LEND
	IF (LINE(I2).EQ.BLANK) GOTO 40
	IF (LINE(I2).EQ.COMMA) GOTO 45
C
C VARIABLES NOT SEPARATED BY COMMAS
	I=5
	GO TO 25
40	CONTINUE
	GOTO 1000
45	IF (I2.EQ.LEND) GOTO 22
60	I2=I2+1
	IF (I2.LE.LEND) GOTO 10
	GO TO 1000
C
C
C
C
C
C
C **********************************************************************
C ** NO ARGUMENTS SO SHOW WHAT VARIABLES HAVE BEEN DECLARED THAT TYPE **
C **********************************************************************
500	CONTINUE
	IF(VIEWSW.EQ.0) GO TO 1000
C PERHAPS THE ABOVE LINE SHOULD BE REMOVED (???)
C
C
C BLANK OUT OUTPUT LINE.
	DO 510 I=1,80
510	LINE(I)=BLANK
C
C
C SEARCH FOR VARIABLES OF TYPE ITYP. PUT THEM IN LINE(I2) WHEN FOUND FOR
C LATER PRINTING.
	I2=0
	DO 550 I=1,27
C FAKE UP DISPLAY
C ****&&&&&
	CALL TYPGET(I,1,TYPE(1,1))
	IF(IABS(TYPE(1,1)).NE.ITYP)GO TO 550
	I2=I2+1
	LINE(I2)=ALPHA(I)
550	CONTINUE
C
C
C GO TO SECTION APPROPRIATE FOR PRINTING EITHER THE LIST OF VARIABLES OR
C A MESSAGE INDICATING THAT NO VARIABLES ARE OF THAT TYPE.
	IF(I2.EQ.0) GO TO 600
C
C
C OUTPUT A LIST OF VARIABLES OF TYPE ITYP
	write(cwrk,560)(line(i),i=1,i2)
	Call vwrt(char(13)//char(10),2)
	call vwrt('Variables so declared=',22)
	call vwrt(cwrk,i2)
c	WRITE(11,560) (LINE(I),I=1,I2)
560	format(30a1)
c560	FORMAT(' VARIABLES SO DECLARED = ',30A1)
	GO TO 1000
C
C
C
C
C NO VARIABLES OF THAT TYPE
600	Continue
	Call vwrt(char(13)//char(10),2)
	Call vwrt(' No variables of that type',26)
c600	WRITE(11,610)
610	FORMAT(' NO VARIABLES OF THAT TYPE')
C
C
C
C **** NORMAL RETURN ****
1000	RETCD=1
	RETURN
	END
c -h- doentr.for	Fri Aug 22 13:03:06 1986	
	SUBROUTINE DOENTR(FORM,LOW,LHIGH)
C +++++++++++++++++++++++++++++++++++
C PARAMETER 18060=60*301
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
	EXTERNAL INDX
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 ACY
	EQUIVALENCE(ACY,AVBLS(1,27))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	COMMON/FVLDC/FVLD
C +++++++++++++++++++++++++++++++++++
C ENABLE { FORMS TO HANDLE ALL POSSIBLE EQUATIONS.
	CALL FRMEDT(FORM,LLST)
	IITR=0
5050	IITR=IITR+1
	FORM(111)=Char(0)
	LCURR=LOW
C DO AN ENTRY. MUST SCAN FOR MULTIPLE STATEMENTS PER LINE AND ALSO
C RECOGNIZE FUNCTION NAMES.
1000	CONTINUE
	KKK=ICHAR('\')
	LSL=INDX(FORM(LCURR),KKK)
	IF(LSL.EQ.0)LSL=LHIGH-LCURR+1
C CLAMP AT 80 CHARS LONG INPUT.
	IF(LSL.LE.79)GOTO 1200
C STMT HAS NO MULTIPLES. SQUASH IT TO USE ONLY 1ST PART...
	LSL=79
	LCURR=LHIGH
	FORM(80)=Char(0)
1200	CONTINUE
	IF(FORM(LCURR).NE.'<')GOTO 5052
	IF(ACY.GT.0. .AND.
     2  IITR.LT.100)GOTO 5050
C ALLOW IN-FORMULA LOOPING PROVIDED % IS POSITIVE AND
C WITH LIMITED RETRIES...
C AVOID CALLING DOSTMT WITH BOGUS < CHARACTER AS "FORMULA" SO
C WE AVOID ERROR MESSAGES.
	GOTO 5051
5052	CONTINUE
	CALL DOSTMT(FORM(LCURR),LSL)
5051	IF (LCURR.GE.LHIGH)RETURN
	LCURR=LCURR+LSL
	If(Lcurr.lt.Lhigh)GOTO 1000
	Return
	END
c -h- doif.for	Fri Aug 22 13:03:17 1986	
	SUBROUTINE DOIF(LINE,LLB,LRB,LLAST)
C	PARAMETER 1=1,12=12
	EXTERNAL INDX
	CHARACTER*1 LINE(110)
	REAL*8 V1,V2
	V1=0.
	V2=0.
	LS=LRB-LLB+1
	CALL GETLOG(LINE(LLB),LS,LOGTYP,LASST)
	LOV1=LLB
	LHIV1=LASST+LLB-1
	IF(LOV1.GE.LHIV1)GOTO 100
C USE SUM FUNCTION HERE AS TYPE OF FCN
	LT=4
	CALL DOMFCN(LINE,LOV1,LHIV1,LT,V1)
100	CONTINUE
	IF(LOGTYP.EQ.0)GOTO 1000
	LOV2=LASST+2+LLB
	LHIV2=LRB
	IF(LOV2.GE.LHIV2)GOTO 200
	LT=4
	CALL DOMFCN(LINE,LOV2,LHIV2,LT,V2)
200	CONTINUE
	CALL TEST(LOGTYP,LFLAG,V1,V2)
	IF(LFLAG.EQ.0)GOTO 700
C HERE HAVE "TRUE" ALTERNATIVE OF IF STMT
	KKK=ICHAR('|')
	LBAR=INDX(LINE,KKK)
	LBAR=MIN0(LBAR,LLAST)
	LSTM=LRB+1
C LSTM TO LBAR IS NOW THE STMT TO EVALUATE. SINCE WE ALREADY HAVE A
C ROUTINE TO EVALUATE A STMT, DO SO. NOTE PARTIAL RECURSION, SO
C NO NESTED IFS ALLOWED, AND CALL MUST PERMIT RECURSION ON YOUR
C MACHINE OR FORGET IT. (OK ON PDP11, VAX).
	LSZ=LBAR-LSTM
	IF(LSZ.LT.1)GOTO 1000
	LSZ=LSZ+1
	CALL DOSTMI(LINE(LSTM),LSZ)
	GOTO 1000
700	CONTINUE
C HERE HAVE "FALSE" ALTERNATIVE OF IF STMT
	KKK=ICHAR('|')
	LBAR=INDX(LINE,KKK)+1
	LBAR=MIN0(LBAR,LLAST)
	LSZ=LLAST-LBAR
	IF(LSZ.LT.1)GOTO 1000
	LSZ=LSZ+1
	CALL DOSTMI(LINE(LBAR),LSZ)
1000	CONTINUE
C THAT'S ALL.
	RETURN
	END
c -h- domath.fms	Fri Aug 22 13:03:28 1986	
	SUBROUTINE DOMATH(INDEXF,VAR,AC,SS,CTR,ACX)
C COPYRIGHT (C) 1985, 1986 GLENN C.EVERHART
C ALL RIGHTS RESERVED
	INCLUDE APARMS.INC
C	EXTERNAL INDX
	REAL*8 AC,SS,CTR,ACX,RWRK1,RWRK2
	DIMENSION EP(20)
	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
CCC	REAL*8 EP,PV,FV
CCC	COMMON/ERNPER/EP,PV,FV,KIRR
	REAL*8 VAR,TE
	INTEGER*4 IWRK1,IWRK2,IDUM
	LOGICAL*4 LWRK1,LWRK2,LWRK3
	INTEGER*4 IWRK3
	EQUIVALENCE(IWRK1,LWRK1),(IWRK2,LWRK2),(IWRK3,LWRK3)
	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,MROWS)
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
CCC	REAL*8 AACP,AACQ
CCC	InTeGer*4 KLKC,KLKR
CCC	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	IF(INDEXF.NE.1)GOTO 100
C MIN
	IF(VAR.GE.AC)GOTO 105
	AC=VAR
	AACP=KLKC
	AACQ=KLKR
105	CONTINUE
	ACX=AC
	RETURN
100	IF(INDEXF.NE.2)GOTO 200
C MAX
	IF(VAR.LE.AC)GOTO 107
	AC=VAR
	AACP=KLKC
	AACQ=KLKR
107	CONTINUE
C	IF(VAR.GT.AC)AC=VAR
	ACX=AC
	RETURN
200	IF(INDEXF.NE.3)GOTO 300
C AVG
	AC=AC+VAR
	CTR=CTR+1.
	ACX=AC/CTR
	RETURN
300	IF(INDEXF.NE.4)GOTO 400
C SUM
	AC=AC+VAR
	ACX=AC
	RETURN
400	IF(INDEXF.NE.5)GOTO 500
C STD (STANDARD DEVIATION SQUARED)
	AC=AC+VAR
	SS=SS+(VAR*VAR)
	CTR=CTR+1.
	ACX=(SS-((AC*AC)/CTR))/CTR
	RETURN
500	CONTINUE
	IF(INDEXF.NE.7)GOTO 600
C AND
	IF(SS.NE.0.)IWRK1=AC
	IF(SS.EQ.0.)IWRK1=VAR
	SS=1.
	IWRK2=VAR
	LWRK1=LWRK1.AND.LWRK2
	AC=IWRK1
	ACX=AC
	RETURN
600	IF(INDEXF.NE.8)GOTO 700
C INCLUSIVE OR
	IWRK1=AC
	IWRK2=VAR
	LWRK1=LWRK1.OR.LWRK2
	AC=IWRK1
	ACX=AC
	RETURN
700	IF (INDEXF.NE.9)GOTO 800
C NOT
	IWRK1=VAR
	LWRK1=.NOT.LWRK1
	AC=IWRK1
	ACX=AC
	RETURN
800	IF(INDEXF.NE.10)GOTO 1000
C CNT
C COUNT NONZERO ENTRIES
	IF(VAR.NE.0.)AC=AC+1.
	ACX=AC
	RETURN
1000	CONTINUE
	IF(INDEXF.NE.11)GOTO 1100
C NPV
	IF(SS.EQ.0.)GOTO 1050
	CTR=CTR+1.
C	AC=AC+VAR*CTR/SS
	AC=AC+VAR/(SS**(CTR-1))
	ACX=AC
	RETURN
C	GOTO 1200
1050	CONTINUE
	SS=VAR+1.
	ACX=0.
	RETURN
1100	if(indexf.ne.12) GOTO 1200
C LKP
	IF(SS.NE.0.)GOTO 1150
	SS=1.
	AC=VAR
	ACX=-1.
	RETURN
C	GOTO 1200
1150	CONTINUE
C	IF(VAR.GE.AC.AND.ACX.LT.0.)ACX=CTR
	IF(VAR.LT.AC.OR.ACX.GE.0.)GOTO 1155
	ACX=CTR
	AACP=KLKC
	AACQ=KLKR
1155	CONTINUE
	CTR=CTR+1.
	RETURN
1200	CONTINUE
	IF(INDEXF.NE.13)GOTO 1300
C LKN
	IF(SS.NE.0.)GOTO 1250
	SS=1.
	AC=VAR
	ACX=-1.
	GOTO 1300
1250	CONTINUE
C	IF(VAR.LE.AC.AND.ACX.LT.0.)ACX=CTR
	IF(VAR.GT.AC.OR.ACX.GT.0.)GOTO 1256
	ACX=CTR
	AACP=KLKC
	AACQ=KLKR
1256	CONTINUE
	CTR=CTR+1.
	RETURN
1300	CONTINUE
	IF(INDEXF.NE.14)GOTO 1400
C LKE
	IF(SS.NE.0.)GOTO 1350
	SS=1.
	AC=VAR
	ACX=-1.
	GOTO 1400
1350	CONTINUE
C	IF(VAR.EQ.AC.AND.ACX.LT.0.)ACX=CTR
	IF(VAR.NE.AC.OR.ACX.GE.0.)GOTO 1355
	ACX=CTR
	AACP=KLKC
	AACQ=KLKR
1355	CONTINUE
	CTR=CTR+1.
	RETURN
1400	CONTINUE
	IF(INDEXF.NE.15)GOTO 1500
C XOR
	IF(SS.NE.0)IWRK1=AC
	IF(SS.EQ.0)IWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1405
	IWRK2=VAR
	LWRK3=LWRK1.OR.LWRK2
	LWRK1=LWRK1.AND.LWRK2
	IWRK1=IWRK3-IWRK1
1405	AC=IWRK1
	ACX=AC
	RETURN
1500	CONTINUE
	IF(INDEXF.NE.16)GOTO 1600
C EQV
C NOTE THE EQUIVALENCE FUNCTION IS JUST THE COMPLEMENT OF
C THE XOR FUNCTION. DO THE COMPLEMENT VIA THE .NOT. OPERATOR.
	IF(SS.NE.0)IWRK1=AC
	IF(SS.EQ.0)IWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1505
	IWRK2=VAR
	LWRK3=LWRK1.OR.LWRK2
	LWRK1=LWRK1.AND.LWRK2
	IWRK1=IWRK3-IWRK1
	LWRK1=.NOT.LWRK1
1505	AC=IWRK1
	ACX=AC
	RETURN
1600	CONTINUE
	IF(INDEXF.NE.17)GOTO 1700
C MOD
C MODULO (V1 MOD V2)
	IF(SS.NE.0)RWRK1=AC
	IF(SS.EQ.0)RWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1605
	RWRK2=VAR
	RWRK1=DMOD(RWRK1,RWRK2)
1605	AC=RWRK1
	ACX=AC
	RETURN
1700	CONTINUE
	IF(INDEXF.NE.18)GOTO 1800
C REMAINDER -- INTEGER MODULO
	IF(SS.NE.0)IWRK1=AC
	IF(SS.EQ.0)IWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1705
	IWRK2=VAR
	IWRK1=JMOD(IWRK1,IWRK2)
1705	AC=IWRK1
	ACX=AC
	RETURN
1800	CONTINUE
	IF(INDEXF.NE.19)GOTO 1900
C SGN
C RETURN 1.0 * SIGN OF ARGUMENT.
	AC=DSIGN(1.0D0,VAR)
	ACX=AC
	RETURN
1900	CONTINUE
	IF(INDEXF.NE.20)GOTO 2000
C IRR - INTERNAL RATE OF RETURN
	AC=0.
	ACX=0.
	IF(KIRR.LT.20)KIRR=KIRR+1
	IF(KIRR.EQ.1)PV=VAR
	IF(KIRR.EQ.2)FV=VAR
	IF(KIRR.LT.3)RETURN
C IRRPV,FV,RETURNS...
	IWRK1=KIRR-2
	EP(IWRK1)=VAR
	RWRK1=.15
	RWRK2=.25
C ITERATIVELY SOLVE FOR INTERNAL RATE OF RETURN.
1903	TE=0.
	SS=FV/((1.D0+RWRK1)**(IWRK1))
	DO 1905 IWRK2=1,IWRK1
	AC=EP(IWRK2)/((1.D0+RWRK1)**IWRK2)
	SS=SS+AC
1905	CONTINUE
	RWRK2=RWRK1*(SS+TE)/PV
	IF(DABS(RWRK1-RWRK2).LT..00001)GOTO 1910
	RWRK1=RWRK2
	GOTO 1903
1910	CONTINUE
	AC=RWRK2
	ACX=AC
	RETURN
2000	CONTINUE
	IF(INDEXF.NE.21)GOTO 2100
C RND[] - RANDOM NUMBER RETURN
	AC=RND(IDUM)
	ACX=AC
	RETURN
2100	CONTINUE
   	IF(INDEXF.NE.22)GOTO 2200
C PMT FUNCTION
C PMT[PRINCIPAL, INTEREST, NPERIODS] ARE ARGS
C PAYMENT (MORTGAGE PAYMENT PER PERIOD
C COMPUTED AS PAYMENT=PRINCIPAL*(INTEREST/(1-(1+INTEREST)**NPERIODS))
C (CORRECT EVEN IF INTEREST=0
C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
	AC=0.
	ACX=0.
	KIRR=KIRR+1
	EP(KIRR)=VAR
	IF(KIRR.LT.3)RETURN
C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
	AC=EP(1)*(EP(2)/(1.-((1.+EP(2))**(-EP(3)))))
	ACX=AC
	RETURN
2200	CONTINUE
	IF(INDEXF.NE.23)GOTO 2300
C PVL FUNCTION
C PVL[PAYMENT,INTEREST,NPERIODS] ARE ARGS
C PRESENT VALUE COMPUTED AS
C PV=PAYMENT*(1.-(1.+INTEREST)**-NPERIODS)/INTEREST
C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
	AC=0.
	ACX=0.
	KIRR=KIRR+1
	EP(KIRR)=VAR
	IF(KIRR.LT.3)RETURN
C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
	AC=EP(1)*EP(3)
	IF(EP(3).EQ.0..OR.EP(2).EQ.0.)GOTO 2205
	AC=EP(1)*((1.-(1.+EP(2))**(-EP(3)))/EP(2))
2205	ACX=AC
	RETURN
2300	CONTINUE
	IF(INDEXF.NE.24)GOTO 2400
C AVE AVERAGE EXCLUDING ZERO CELLS
	IF(VAR.EQ.0.)GOTO 2305
	AC=AC+VAR
	CTR=CTR+1.
2305	ACX=AC/DMAX1(CTR,1.0D0)
	RETURN
2400	CONTINUE
	IF(INDEXF.NE.25)GOTO 2500
C CHS
C CHOOSE FROM ARGS USING 1ST ARG AS COUNT INTO RANGE...
C (SIMILAR TO CLASSICAL "CHOOSE" FUNCTION...)
C RETURNS 0.0 OR VALUE OF NTH ARG WHERE N IS INDEX OF ARG...
C	IF(KIRR.EQ.0)ACX=0.
	KIRR=KIRR+1
	IF(KIRR.EQ.1)IWRK1=VAR+1.
	IF(KIRR.NE.IWRK1)GOTO 2450
C SAVE LOCATION ALSO OF CELLS.
C THIS ALLOWS US TO FIND ADDRESSES OF SELECTED CELLS IN CHOOSE FOR ADDRESS MATH.
	AACP=KLKC
	AACQ=KLKR
	SS=VAR
2450	CONTINUE
	ACX=SS
	AC=ACX
	RETURN
2500	CONTINUE
	IF(INDEXF.NE.26)GOTO 2600
C ATM ARCTAN OF 2 ARGS
	IF(SS.NE.0.)RWRK1=AC
	IF(SS.EQ.0.)RWRK1=VAR
	SS=SS+1.
	IF(SS.LE.1.1)GOTO 2505
	RWRK2=VAR
C GET 4 QUADRANT ARCTAN
	RWRK1=DATAN2(RWRK1,RWRK2)
2505	AC=RWRK1
	ACX=AC
	RETURN
2600	CONTINUE
	RETURN
	END
c -h- domfcn.for	Fri Aug 22 13:03:40 1986	
	SUBROUTINE DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
C LLB = LOC OF
C LRB = LOC OF
C INDEXF IS AS ABOVE. GUARANTEED IN RANGE 1-5.
	INCLUDE APARMS.INC
	CHARACTER*1 LINE(110)
C +++++++++++++++++++++++++++++++++++
C PARAMETER 18060=60*301
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	EXTERNAL INDX
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	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,k3dfg,kcdelt,krdelt,kshtf
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kshtf
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
c     3  K3DFG,KCDelt,KRDelt,kpag
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	REAL*8 XXX
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	REAL*8 ACX,ACY
	REAL*8 AC,SS,CTR
	EQUIVALENCE(ACY,AVBLS(1,27))
	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
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	CHARACTER*1 ILINE(106)
	InTeGer*4 ILNFG,ILNCT
	COMMON/ILN/ILNFG,ILNCT,ILINE
	COMMON/FVLDC/FVLD
	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,MROWS)
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
CCC	InTeGer*4 KLKC,KLKR
	REAL*8 ACP,ACQ
CCC	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	EQUIVALENCE(ACP,AVBLS(1,16)),(ACQ,AVBLS(1,17))
C +++++++++++++++++++++++++++++++++++
C
C FIRST GET A VARIABLE NAME. ALL MATH FUNCTIONS REQUIRE VARIABLE
C NAMES SINCE THEIR VARIABLES ARE THEIR ONLY VALID ARGS.
	CALL MTHINI(INDEXF,AC,SS,CTR,ACX)
C SET UP PROPER INITS
C KV2=1 IF A 2ND VBL EXISTS
	LCR=LLB+1
	AACP=ACP
	AACQ=ACQ
C INIT SAVED P, Q AC'S HERE IN CASE DOMATH MODIFIES...
C THIS ALLOWS SELECTION FUNCTIONS TO SET COL, ROW IN P AND Q AC.
100	CONTINUE
	KV2=0
	LB=LCR
	LE=LRB-1
	IF(LB.GE.LE)RETURN
	CALL VARSCN(LINE,LB,LE,LASST,ID1,ID2,IVALID)
	IF(IVALID.EQ.0)RETURN
C USE extra cell to check for different sheets, same row/col
C use separator of } to indicate range is depth.
	KPG1=KSHTF
	KDEPSP=0
	if(Line(Lasst).eq.'}')Goto 8601
	IF(LINE(LASST).NE.':')GOTO 110
	Goto 8603
8601	Continue
	KDepsp=1
8603	Continue
	LB=LASST+1
	LE=LRB-1
	CALL VARSCN(LINE,LB,LE,LASST,ID1B,ID2B,IVALID)
	IF(IVALID.NE.0)KV2=1
	KPG2=KSHTF
	If(KDepsp.ne.1)goto 8604
	KDp=0
	If (kv2.eq.0)goto 8606
	KDp=kpg2-kpg1
C KDp is depth to go through. If negative set to zero.
	if(KDp.lt.0)kdp=0
8606	Continue
8605	Continue
	CALL XVBLGT(ID1,ID2,XVBLS(1,1))
	XXX=XVBLS(1,1)
	CALL TYPGET(ID1,ID2,TYPE(1,1))
C USE EQUIVALENCE OF JVBLS AND XVBLS
	IF(ABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
	KLKC=ID1
	KLKR=ID2-1
	CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
	id1=id1+kcdelt
	id2=id2+krdelt
	kdp=kdp-1
C Handle all math over the depth argument.
C (Only partially decode; if argument is ill-formed
C  then just act as if range were directly below the
C  top cell.)
	if(KDp.ge.0)goto 8605
	GoTo 200
8604	Continue
110	CONTINUE
	CALL XVBLGT(ID1,ID2,XVBLS(1,1))
	XXX=XVBLS(1,1)
C	XXX=XVBLS(ID1,ID2)
	CALL TYPGET(ID1,ID2,TYPE(1,1))
C USE EQUIVALENCE OF JVBLS AND XVBLS
	IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
	KLKC=ID1
	KLKR=ID2-1
	CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
	IF(KV2.EQ.0)GOTO 200
	IF(ID1.NE.ID1B) GOTO 120
	IF(ID2.GT.ID2B)GOTO 200
	M=ID2+1
	DO 121 MM=M,ID2B
	CALL XVBLGT(ID1,MM,XVBLS(1,1))
	XXX=XVBLS(1,1)
	CALL TYPGET(ID1,MM,TYPE(1,1))
C	XXX=XVBLS(ID1,MM)
	IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
	KLKC=ID1
	KLKR=MM-1
	CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
121	CONTINUE
	GOTO 200
120	CONTINUE
	IF(ID2.NE.ID2B)GOTO 130
	IF(ID1.GT.ID1B)GOTO 200
	M=ID1+1
	DO 131 MM=M,ID1B
	CALL XVBLGT(MM,ID2,XVBLS(1,1))
	XXX=XVBLS(1,1)
C	XXX=XVBLS(MM,ID2)
	CALL TYPGET(MM,ID2,TYPE(1,1))
	IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
	KLKC=MM
	KLKR=ID2-1
	CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
131	CONTINUE
130	CONTINUE
200	CONTINUE
C IF NEXT CHAR IS A COMMA, SKIP IT AND KEEP UP SCAN UNLESS DONE
	IF(LINE(LASST).EQ.',')GOTO 300
	ACP=AACP
	ACQ=AACQ
C USE P, Q ACCUMULATORS FOR SELECTED COL, ROW COORDS FROM DOMATH
	RETURN
300	LCR=LASST+1
	GOTO 100
	END
c -h- dostmi.for	Fri Aug 22 13:03:55 1986	
	SUBROUTINE DOSTMI(LINE,LLAST)
C COPY OF DOSTMT FOR IF FUNCTION.
C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
	CHARACTER*1 LINE(110)
C +++++++++++++++++++++++++++++++++++
C PARAMETER 18060=60*301
	EXTERNAL INDX
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
	COMMON/FVLDC/FVLD
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	REAL*8 ACX,ACY,AACY
	INTEGER*4 IACY,IIJACY
	EQUIVALENCE(IIJACY,AACY)
	EQUIVALENCE(IACY,AVBLS(1,27))
	EQUIVALENCE(ACY,AVBLS(1,27))
	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
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	CHARACTER*1 ILINE(106)
	InTeGer*4 ILNFG,ILNCT
	COMMON/ILN/ILNFG,ILNCT,ILINE
C +++++++++++++++++++++++++++++++++++
	CALL FNAME(LINE,LLAST,INDEXF)
C ABOVE GETS FUNCTION NAMES.
C	NAME	INDEXF
C	MIN	1
C	MAX	2
C	AVG	3
C	SUM	4
C	STD	5	(STD DEVIATION)
C	IF	6	(IF STMT)
C	AND	7
C	OR	8
C	NOT	9
C	CNT	10 (COUNTS NONZERO ENTRIES)
C	NPV	11 NET PRESENT VALUE
C	LKP	12 LOOKUP IN LIST, GIVE OFFSET 0 BASED
C	LKN	13	LOOKUP NEGATIVE (INVERSE OF LKP)
C	LKE	14	LOOKUP EQUAL
C	XOR	15	EXCLUSIVE OR
C	EQV	16	EQUIVALENCE (TRUE IF BITS EQUAL)
C	MOD	17	V1 MODULO V2
C	REM	18	REMAINDER OF V1/V2
C	SGN	19	SIGN OF V1 (-1.,0., OR +1.)
C	IRR	20	INTERNAL RATE OF RETURN
C USE  AND  TO DELIMIT FUNCTION ARGS.
C *****************************************************************************
C **** NOTE: MAX 20 IS KEPT AS A LITERAL IN NEXTEL ALSO AS FLAG THAT FUNCTION
C **** FAILED TO FIND VALID LITERAL. CHANGE THERE TOO IF YOU ADD MORE FUNCTIONS.
	IF(INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 1000
C HERE IF A FUNCTION OR AN IF STMT (FORMAT= IF varRELvarstmt|else-stmt)
C
C ALLOW CALC TO HANDLE ALL BUT IF STMTS
	IF(INDEXF.NE.6)GOTO 1000
C
C **** FIXUP '' NEXT. 2 LINES. REPLACE HERE... ***
	KKK=ICHAR('[')
	LLB=INDX(LINE,KKK)
	KKK=ICHAR(']')
	LRB=INDX(LINE,KKK)
C *** ERROR WITH FORMAT -- NO  SEEN IN TIME. JUST IGNORE IT.
	IF(LLB.GT.LLAST)RETURN
	IF(LRB.GT.LLAST)LRB=LLAST
C ** COMMENT OUT NEVER-USED CODE NEXT AREA...
C
C	IF(INDEXF.EQ.6)GOTO 2000
CC ISOLATE MATH FUNCTIONS
C	CALL DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
CC GET % ABOVE
C	CALL TYPGET(KDRW,KDCL,TYPE(1,1))
C	IF(IABS(TYPE(1,1)).NE.2)GOTO 1760
C	CALL XVBLST(KDRW,KDCL,ACX)
CC	XVBLS(KDRW,KDCL)=ACX
CC LEAVE RESULT IN % TOO.
C	ACY=ACX
C	CALL TYPSET(27,1,TYPE(1,1))
CC	TYPE(27,1)=TYPE(KDRW,KDCL)
C	RETURN
C1760	JVBLS(1,1,1)=ACX
C	CALL JVBLST(1,KDRW,KDCL,JVBLS(1,1,1))
CC	JVBLS(1,KDRW,KDCL)=ACX
C	RETURN
2000	CONTINUE
C HANDLE AN "IF" STATEMENT
C ILLEGAL HERE INSIDE AN IF, SO JUST IGNORE IT.
C	CALL DOIF(LINE,LLB,LRB,LLAST)
C PASS LLAST TO DOIF SINCE WE DON'T EXPECT ] AS LAST CHAR OF STMT.
C NO DIRECT SET OF VRBL HERE...
	RETURN
1000	CONTINUE
C HERE JUST HAVE SOMETHING TO PASS TO CALC. DO SO.
	ILNFG=1
	LMX=LLAST-1
	DO 1001 N1=1,LMX
1001	ILINE(N1)=LINE(N1)
	ILNCT=LMX
C PROTECT CALC FROM ANY PART OF A LINE LONGER THAN 80 CHARS (ITS MAX)
	IF(ILNCT.GT.80)ILNCT=80
	CALL CALC
C STORE EXPRESSION RESULT.
C CONVERT BETWEEN TYPES FIRST IF NEED BE
	CALL TYPGET(KDRW,KDCL,LMX)
	CALL TYPGET(27,1,N1)
	LMX=IABS(LMX)
	N1=IABS(N1)
	IF(N1.EQ.1.OR.(N1.GE.3.AND.N1.LE.8))GOTO 8739
	N1=2
	GOTO 8740
8739	CONTINUE
	N1=4
8740	CONTINUE
C ONLY CONCERN HERE IS REAL TYPES (CODE=2) AND INT TYPES (CODE=4)
	AACY=ACY
	IF(N1.EQ.LMX)GOTO 2670
	IF(N1.EQ.2)IIJACY=ACY
	IF(N1.EQ.4)AACY=IACY
C DO WHICHEVER CONVERSION IS NEEDED IF ONE IS NEEDED AT ALL.
2670	CONTINUE
	CALL XVBLST(KDRW,KDCL,AACY)
C	XVBLS(KDRW,KDCL)=ACY
	RETURN
	END
c -h- dostmt.for	Fri Aug 22 13:03:55 1986	
	SUBROUTINE DOSTMT(LINE,LLAST)
C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
	CHARACTER*1 LINE(110)
C +++++++++++++++++++++++++++++++++++
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	EXTERNAL INDX
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
	COMMON/FVLDC/FVLD
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	REAL*8 ACX,ACY,AACY
	INTEGER*4 IACY,IIJACY
	EQUIVALENCE(IACY,AVBLS(1,27))
	EQUIVALENCE(ACY,AVBLS(1,27))
	EQUIVALENCE(IIJACY,AACY)
	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
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	CHARACTER*1 ILINE(106)
	InTeGer*4 ILNFG,ILNCT
	COMMON/ILN/ILNFG,ILNCT,ILINE

C +++++++++++++++++++++++++++++++++++
	CALL FNAME(LINE,LLAST,INDEXF)
C ABOVE GETS FUNCTION NAMES.
C	NAME	INDEXF
C	MIN	1
C	MAX	2
C	AVG	3
C	SUM	4
C	STD	5	(STD DEVIATION)
C	IF	6	(IF STMT)
C	AND	7
C	OR	8
C	NOT	9
C	CNT	10 (COUNTS NONZERO ENTRIES)
C	NPV	11 NET PRESENT VALUE
C	LKP	12 LOOKUP IN LIST, GIVE OFFSET 0 BASED
C	LKN	13	LOOKUP NEGATIVE (INVERSE OF LKP)
C	LKE	14	LOOKUP EQUAL
C	XOR	15	EXCLUSIVE OR
C	EQV	16	EQUIVALENCE (TRUE IF BITS EQUAL)
C	MOD	17	V1 MODULO V2
C	REM	18	REMAINDER OF V1/V2
C	SGN	19	SIGN OF V1 (-1.,0., OR +1.)
C	IRR	20	INTERNAL RATE OF RETURN
C	RND	21	RANDOM NUMBER BETWEEN 0 AND 1.
C	PMT	22	PAYMENT FUNCTION
C	PVL	23	PRESENT VALUE
C	AVE	24	AVEREAGE EXCLUDING ZERO CELLS
C	CHS	25	CHOOSE
C	ATM	26	ARC TAN OF MULTIPLE ARGS (2 ARGS)
C USE  AND  TO DELIMIT FUNCTION ARGS.
C *****************************************************************************
C **** NOTE: MAX 26 IS KEPT AS A LITERAL IN NEXTEL ALSO AS FLAG THAT FUNCTION
C **** FAILED TO FIND VALID LITERAL. CHANGE THERE TOO IF YOU ADD MORE FUNCTIONS.
	IF(INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 1000
C HERE IF A FUNCTION OR AN IF STMT (FORMAT= IF varRELvarstmt|else-stmt)
C
C ALLOW CALC TO HANDLE ALL BUT IF STMTS
	IF(INDEXF.NE.6)GOTO 1000
C
	KKK=ICHAR('[')
	LLB=INDX(LINE,KKK)
	KKK=ICHAR(']')
	LRB=INDX(LINE,KKK)
C *** ERROR WITH FORMAT -- NO  SEEN IN TIME. JUST IGNORE IT.
	IF(LLB.GT.LLAST)RETURN
	IF(LRB.GT.LLAST)LRB=LLAST
C *** NOTA BENE
C NEXT STUFF COMMENTED BECAUSE WE CAN NEVER EXECUTE IT...
C	IF(INDEXF.EQ.6)GOTO 2000
CC ISOLATE MATH FUNCTIONS
C	CALL DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
CC GET % ABOVE
C	CALL TYPGET(KDRW,KDCL,TYPE(1,1))
C	IF(IABS(TYPE(1,1)).NE.2)GOTO 1760
C	CALL XVBLST(KDRW,KDCL,ACX)
CC	XVBLS(KDRW,KDCL)=ACX
CC LEAVE RESULT IN % TOO.
C	ACY=ACX
C	CALL TYPSET(27,1,TYPE(1,1))
CC	TYPE(27,1)=TYPE(KDRW,KDCL)
C	RETURN
C1760	JVBLS(1,1,1)=ACX
C	CALL JVBLST(1,KDRW,KDCL,JVBLS(1,1,1))
CC	JVBLS(1,KDRW,KDCL)=ACX
C	RETURN
2000	CONTINUE
C HANDLE AN "IF" STATEMENT
	CALL DOIF(LINE,LLB,LRB,LLAST)
C PASS LLAST TO DOIF SINCE WE DON'T EXPECT  AS LAST CHAR OF STMT.
C NO DIRECT SET OF VRBL HERE...
	RETURN
1000	CONTINUE
C HERE JUST HAVE SOMETHING TO PASS TO CALC. DO SO.
	ILNFG=1
	LMX=LLAST-1
	DO 1001 N1=1,LMX
1001	ILINE(N1)=LINE(N1)
	ILNCT=LMX
C PROTECT CALC FROM ANY PART OF A LINE LONGER THAN 80 CHARS (ITS MAX)
	IF(ILNCT.GT.80)ILNCT=80
	CALL CALC
C STORE EXPRESSION RESULT.
C FIRST BE SURE STORING RIGHT TYPE
	CALL TYPGET(KDRW,KDCL,LMX)
C ONLY WORRY HERE ABOUT INTEGER VS REAL (INT=4, REAL=2 CODE)
	CALL TYPGET(27,1,N1)
	N1=IABS(N1)
	LMX=IABS(LMX)
C LET ALL DEFAULT TO TYPE 2 (FLOATING) EXCEPT EXPLICIT INTS
	IF((N1.EQ.1).OR.(N1.GE.3.AND.N1.LE.8))GOTO 2739
	N1=2
	GOTO 2740
2739	CONTINUE
	N1=4
2740	CONTINUE
	AACY=ACY
	IF((N1).EQ.(LMX))GOTO 2670
C TYPES DIFFER. CONVERT BETWEEN ACY AND IACY.
	IF((N1).EQ.4)AACY=IACY
	IF((N1).EQ.2)IIJACY=ACY
2670	CONTINUE
	CALL XVBLST(KDRW,KDCL,AACY)
C	XVBLS(KDRW,KDCL)=ACY
	RETURN
	END
c -h- dspfil.for	Fri Aug 22 13:04:12 1986	
	SUBROUTINE DSPFIL(ICODE,FORM,FORM2,FVLDTP,
     1  LFTMST,LENTL,LOCOL,FILINE,LLVL,LLU,LLVLF,J)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C DISPLAY SPREAD SHEET ON SCREEN OR IN FILE IF ICODE=10
C USES UVT100 TO TWEAK THE VT100. NO WRAP IS ASSUMED SO
C OUTPUT UP TO 132 COLS BY 24 LINES IS OK. ONLY CHECK
C WIDTH TO ALLOW VT100 LOOKALIKES WITH MORE DISPLAY LINES TOO.
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
C	CHARACTER*127 CWRK
C	CHARACTER*1 CCWRK(128)
	InTeGer*4 ICODE,LFTMST
C	EQUIVALENCE(CWRK,CCWRK(1))
	InTeGer*4 LLU,LLVL,LLVLF
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
	EXTERNAL INDX
	CHARACTER*7 PRTLX
	CHARACTER*1 FORM,FVLD,CMDLIN(132),PRTLIN(132)
	EQUIVALENCE(PRTLX(1:1),PRTLIN(1))
C	INTEGER*4 VNLT
	CHARACTER*1 FVLDTP
	CHARACTER*1 LBEL(4)
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
	COMMON/NMSH/NMSH
C FLAG BORDR=1 IF WE WANT TO OMIT BORDERS ON DRAWING
C THE SCREEN DISPLAY TO A FILE.
	InTeGer*4 BORDR,TOMT
C COMMON ICPOS ALLOWS UVT100 ROUTINE ACCESS TO DISPLAYED NUMBERS
C FOR USES SUCH AS SETTING COLORS...
	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
CCC	InTeGer*4 IC1POS,IC2POS
CCC	COMMON/ICPOS/IC1POS,IC2POS
	REAL*8 XVBLS(1,1),VDSP,VCLC
	CHARACTER*1 DFE(14)
	CHARACTER*14 CDFE
	EQUIVALENCE(CDFE(1:1),DFE(1))
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 ILNFG,ILNCT,RCF
	CHARACTER*1 ILINE(106)
	COMMON/ILN/ILNFG,ILNCT,ILINE
	INTEGER LENTL(5),LOCOL(5)
	CHARACTER*1 FILINE(208)
CCC	CHARACTER*1 OARRY(100)
CCC	InTeGer*4 OSWIT,OCNTR
CCC	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	InTeGer *4 FORMFG,RCFGX
CCC	COMMON/FFGG/FORMFG,RCFGX
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	REAL*8 DVS(20,75)
	INTEGER*4 LDVS(2,20,75)
	EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
	COMMON /FVLDC/FVLD
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
C	COMMON/DSPCMN/DVS,DFMTS,CWIDS
	COMMON/DSPCMN/DVS,CWIDS
C THISRW,THISCL = CURRENT DISPLAYED LOCS.
	InTeGer*4 THISRW,THISCL
C NOTE ROWS ARE DOWN, COLS ACROSS INTERNALLY.
C COLUMN 2 = NUMBERS. DISPLAY COLS 2-22 WITH COL 1=TITLE
C COL 23,24 FOR COMMANDS.(23 (PARAMETER) ACTUALLY.)
C ROW OFFSET BY 6 FOR NUMBERS.
C
C MAINTAIN AN "INITIALIZED" BITMAP HERE TO USE TO AVOID GOING TO
C FVLD.
C	CHARACTER*1 IBITMP
C	DIMENSION IBITMP(2258)
C	COMMON/INITD/IBITMP
C NOTE BITMAP IS ZEROED IN SPREDSHT MAIN PROGRAM (OR AT SAVE CMD)
C AND IS SET HERE (AND HERE ONLY). ONLY USED HERE TOO...
C	character*100 fwt
C
C CODE FOR WINDOW TILING AND FILE READIN...
C &%FILENAME,NSKIP,NLEN READS FILE SKIPPING NSKIP RECS AND
C GETS NLEN RECS IN
C
C &&%FILENAME,NSKIP,NLEN JUST INSERTS FILE INTO PRINTOUT
	IF(IDOL4.EQ.0)GOTO 9880
	LFTMST=J
C NEED TO DO IT HERE...
C FORM ARRAY HAS FILE NAME INFO, IF ANY...
	KKK=ICHAR('&')
	LLA=INDX(FORM,KKK)
	IF(LLA.LE.0.OR.LLA.GT.100)GOTO 9882
	IF(FORM(LLA+1).EQ.'&')GOTO 9881
C CHECK &% FORM
	IF(FORM(LLA+1).NE.'%')GOTO 9882
C GOT &% FORM HERE.
	IF(LLVL.EQ.0.OR.LLVLF.EQ.1)GOTO 9885
	DO 9886 LNNN=1,LLVL
	LLVLN=LLVL+10
	CLOSE(LLVLN)
9886	CONTINUE
	LLVL=0
9885	CONTINUE
	LTST=LLA+2
	LLVLF=1
C OPEN LLVL
	CALL GETFNL(FORM(LTST),LSKIP,LLEN)
	IF(LLEN.LE.0)GOTO 9882
	LLVL=LLVL+1
	LLU=LLVL+10
	IF(LLVL.GT.4)GOTO 9931
	CALL RASSIG(LLU,FORM(LTST))
	GOTO 9930
9931	CONTINUE
	LENTL(LLVL)=0
	LOCOL(LLVL)=0
	CLOSE(LLU)
	LLVL=LLVL-1
	LLU=LLVL+10
	GOTO 9882
9930	CONTINUE
	LOCOL(LLVL)=LFTMST
	LENTL(LLVL)=LLEN
	IF(LSKIP.LE.0)GOTO 9906
	DO 9907 LL=1,LSKIP
9907	READ(LLU,9889,END=9909,ERR=9909)FILINE
	DO 9910 N=1,208
9910	FILINE(N)=CHAR(32)
	GOTO 9911
9909	CONTINUE
C EOF SO CLOSE LUN
	LENTL(LLVL)=0
	CLOSE(LLU)
	LLVL=LLVL-1
	IF(LLVL.LE.0)GOTO 9880
	LLU=LLVL+10
9911	CONTINUE
9906	CONTINUE
C FILE SET UP NOW... READ IN AT 9982...
C RECORD COL # OVER FOR THIS RECURSION LEVEL
	GOTO 9882
9881	CONTINUE
C HERE LOOK FOR && FORM. IF NONE SEEN, SKIP THIS
	IF(FORM(LLA+1).NE.'&'.OR.FORM(LLA+2).NE.'%')GOTO 9882
C HERE HAVE A FORM &&%FILE,NS,NL
C SO CLOSE OFF ALL WINDOWS IN USE AND READ IN FIRST LEVEL FILE SEEN.
	IF(LLVL.EQ.0.OR.LLVLF.EQ.2)GOTO 9884
	DO 9883 LNN=1,LLVL
	LNN1=LNN+10
	CLOSE(LNN1)
9883	CONTINUE
C NOW ALL OPEN UNITS CLOSED
	LLVLF=2
	LLVL=0
9884	CONTINUE
	LTST=LLA+3
C OPEN LLVL
9937	CALL GETFNL(FORM(LTST),LSKIP,LLEN)
	IF(LLEN.LE.0)GOTO 9882
	LLVL=LLVL+1
	LLU=LLVL+10
	IF(LLVL.GT.4)GOTO 9933
C	OPEN(LLU,NAME=FORM(LTST),TYPE='OLD',
C     1  ERR=9933)
	CALL RASSIG(LLU,FORM(LTST))
	GOTO 9934
9933	CONTINUE
	LLVL=LLVL-1
	LLU=LLVL+10
	GOTO 9882
9934	CONTINUE
	LOCOL(LLVL)=LFTMST
	LENTL(LLVL)=LLEN
	IF(LSKIP.LE.0)GOTO 9888
	DO 9887 LL=1,LSKIP
9887	READ(LLU,9889,ERR=9901,END=9901)FILINE
9889	FORMAT(208A1)
C8998	FORMAT(1X,208A1)
9898	FORMAT(132A1)
	DO 9908 N=1,208
9908	FILINE(N)=Char(32)
C PUT IN LEADING SPACES INTO FILINE
	GOTO 9902
9901	CONTINUE
	CLOSE(LLU)
	LLVL=LLVL-1
	IF(LLVL.LE.0)GOTO 9880
	LLU=LLVL+10
C HIT EOF ON READ, SO BACK UP A LEVEL
9902	CONTINUE
C NOW GO AHEAD & READ... GOT PAST SKIP STUFF.
9888	CONTINUE
C RECORD COL # OVER FOR THIS RECURSION LEVEL
9904	IF(LENTL(LLVL).LE.0) GOTO 9901
	READ(LLU,9889,END=9901,ERR=9901)(FILINE(IV),IV=LOCOL(LLVL),208)
	LENTL(LLVL)=lentl(llvl)-1
c update lines left to read in
C LOOK FOR RECURSIVE CALLS TO DEEPER NESTED FILES TO INCLUDE
	KKK=ICHAR('&')
	LTST=INDX(FILINE,KKK)+3
	LFTMST=LTST-3
C UPDATE SO IF IT IS A CALL,WE CAN GO HANDLE IT TILL ITS EOF OR A DEEPER CALL
	IF(LTST.GT.0.AND.LTST.LT.207.AND.FILINE(LTST+1).EQ.'&'
     1  .AND.FILINE(LTST+2).EQ.'%') GOTO 9937
C WELL, NOT A DEEPER LEVEL SO JUST GO ON AND READ THIS LEVEL TILL DONE.
	IF(ICODE.EQ.10)WRITE(8,9889,ERR=9904)FILINE
c only write 80 chars on ibmpc and its ilk since they screw up on wider.
	call swrt(filine,80)
c	WRITE(0,9898,ERR=9904)(FILINE(IVV),IVV=1,132)
	GOTO 9904
9882	CONTINUE
C HERE HANDLE OLD WINDOW READS IN PROCESS OR JUST EXIT WITHOUT DOING MUCH
	IF(LLVLF.NE.1)GOTO 9880
C ONLY HANDLE "OVERLAY" STYLE READS HERE.
C NORMAL OR-ING IN OF WINDOWS
C LOOK FOR LUN SUCH THAT J=LOCOL(LUN) INDICATING IT STARTS HERE.
C READ THIS CELL INTO IT AND FAKE OUT FVLD(1,1) TO GET IT DISPLAYED.
	IF(LLVL.LE.0)GOTO 9880
	DO 9912 N=1,LLVL
	LLM=N+10
	IF(J.EQ.LOCOL(N))GOTO 9913
9912	CONTINUE
	GOTO 9880
9913	CONTINUE
C NOW READ THE FILE INTO "THIS" CELL (DISPLAY PURPOSES ONLY!)
C AND FLAG FVLD
	LENTL(LLM-10)=LENTL(LLM-10)-1
	IF(LENTL(LLM-10).GT.0)
     1  READ(LLM,9889,END=9940,ERR=9940)(FORM(IV),IV=1,109)
	IF(LENTL(LLM-10).GT.0)FVLDTP=-1
	IF(LENTL(LLM-10).LT.0)GOTO 9940
C -1 FLAGS THIS AS A "TEXT" CELL DISPLAY.
	GOTO 9880
9940	CONTINUE
	LENTL(LLM-10)=0
	LOCOL(LLM-10)=0
	CLOSE(LLM)
9880	CONTINUE
	RETURN
	END
c -h- dspsht.f40	Fri Aug 22 13:04:12 1986	
	SUBROUTINE DSPSHT(ICODE)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
	INCLUDE APARMS.INC
C DISPLAY SPREAD SHEET ON SCREEN OR IN FILE IF ICODE=10
C USES UVT100 TO TWEAK THE VT100. NO WRAP IS ASSUMED SO
C OUTPUT UP TO 132 COLS BY 24 LINES IS OK. ONLY CHECK
C WIDTH TO ALLOW VT100 LOOKALIKES WITH MORE DISPLAY LINES TOO.
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	CHARACTER*127 CWRK
	CHARACTER*1 CCWRK(128)
	InTeGer*4 ICODE,LLU,LLVL,LLVLF
	EQUIVALENCE(CWRK(1:1),CCWRK(1))
	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,K3DFG,KCDelt,KRDelt,kpag
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,IDSPTP,IDOL9,
     3  K3DFG,KCDelt,KRDelt,kpag
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	InTeGer*4 LLCMD,LLDSP
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	EXTERNAL INDX
	CHARACTER*7 PRTLX
	CHARACTER*1 FORM,FVLD,CMDLIN(132),PRTLIN(132)
	EQUIVALENCE(PRTLX(1:1),PRTLIN(1))
C	INTEGER*4 VNLT
	CHARACTER*1 FVLDTP
	CHARACTER*1 LBEL(4)
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
	COMMON/NMSH/NMSH
C FLAG BORDR=1 IF WE WANT TO OMIT BORDERS ON DRAWING
C THE SCREEN DISPLAY TO A FILE.
	InTeGer*4 BORDR,TOMT
C COMMON ICPOS ALLOWS UVT100 ROUTINE ACCESS TO DISPLAYED NUMBERS
C FOR USES SUCH AS SETTING COLORS...
	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
CCC	InTeGer*4 IC1POS,IC2POS
CCC	COMMON/ICPOS/IC1POS,IC2POS
CCC	InTeGer*4 NULAST,LFVD
C	INTEGER*4 IOLVL
C	COMMON/IOLVL/IOLVL
	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,MROWS)
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
CCC	COMMON/NULXXX/NULAST,LFVD
	REAL*8 XVBLS(1,1),VDSP,VCLC
	CHARACTER*1 DFE(14)
	CHARACTER*14 CDFE
	EQUIVALENCE(CDFE(1:1),DFE(1))
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 ILNFG,ILNCT,RCF
	CHARACTER*1 ILINE(106)
	COMMON/ILN/ILNFG,ILNCT,ILINE
	INTEGER LENTL(5),LOCOL(5)
	CHARACTER*1 FILINE(208)
CCC	CHARACTER*1 OARRY(100)
CCC	InTeGer*4 OSWIT,OCNTR
CCC	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	InTeGer *4 FORMFG,RCFGX
CCC	COMMON/FFGG/FORMFG,RCFGX
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	REAL*8 DVS(20,75)
	INTEGER*4 LDVS(2,20,75)
	EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
	COMMON /FVLDC/FVLD
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
C	COMMON/DSPCMN/DVS,DFMTS,CWIDS
	COMMON/DSPCMN/DVS,CWIDS
C THISRW,THISCL = CURRENT DISPLAYED LOCS.
	InTeGer*4 LFTMST
	InTeGer*4 THISRW,THISCL
C NOTE ROWS ARE DOWN, COLS ACROSS INTERNALLY.
C COLUMN 2 = NUMBERS. DISPLAY COLS 2-22 WITH COL 1=TITLE
C COL 23,24 FOR COMMANDS.(23 (PARAMETER) ACTUALLY.)
C ROW OFFSET BY 6 FOR NUMBERS.
C
C MAINTAIN AN "INITIALIZED" BITMAP HERE TO USE TO AVOID GOING TO
C FVLD.
C	CHARACTER*1 IBITMP
C	DIMENSION IBITMP(2258)
C	COMMON/INITD/IBITMP
C NOTE BITMAP IS ZEROED IN SPREDSHT MAIN PROGRAM (OR AT SAVE CMD)
C AND IS SET HERE (AND HERE ONLY). ONLY USED HERE TOO...
	character*100 fwt
C	CHARACTER*1 LBITS(8)
CC	DATA LBITS/1,2,4,8,16,32,64,128/
C	LBITS(1)=1
C	LBITS(2)=2
C	LBITS(3)=4
C	LBITS(4)=8
C	LBITS(5)=16
C	LBITS(6)=32
C	LBITS(7)=64
C	LBITS(8)=128
	IF(ICODE.NE.10)GOTO 3000
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	call Vwrt('Enter Print File Spec, / after to omit borders>',47)
	if(iolvl.ne.11)READ(IOLVL,26,END=8884,ERR=8884)FORM2
	if(iolvl.eq.11)call vget(form2,128)
26	FORMAT(128A1)
C FIND SIZE OF LINE READ IN
	DO 750 N=1,128
	ISZ=129-N
	IF(FORM2(N).GT.' ')GOTO 751
750	CONTINUE
751	CONTINUE
	ISZ=ISZ+1
	ISZ=MIN0(127,ISZ)
	FORM2(ISZ+1)=0
	BORDR=0
	TOMT=0
	DO 4111 N=1,ISZ
C IF FILENAME HAS / AFTERWARDS, OMIT BORDER
	IF(FORM2(N).EQ.'/')BORDR=1
C NULL OUT THE / SO THAT FILENAME WILL PARSE CORRECTLY.
	IF(FORM2(N).EQ.'/')FORM2(N)=0
	IF(FORM2(N).EQ.'%')TOMT=1
4111	CONTINUE
C	OPEN(8,FILE=FORM2,RECL=132,STATUS='NEW')
	CALL WASSIGN(8,FORM2)
	KSHEET=0
	IF(K3DFG.LE.0)GOTO 2890
	LR=NRDSP(1,1)
	LC=NCDSP(1,1)
	CALL GETSHT(LR,LC,KSHEET)
	IF(KSHEET.EQ.0)GOTO 2890
	DO 27 N=1,132
27	PRTLIN(N)=Char(32)
	WRITE(PRTLX(1:7),1891)ksheet
c	ENCODE(7,1891,PRTLIN)KSHEET
	GOTO 3666
2890	CONTINUE
	DO 9127 N=1,132
9127	PRTLIN(N)=Char(32)
	WRITE(PRTLX(1:7),2)
C	ENCODE(7,2,PRTLIN)
	GOTO 3666
3000	CONTINUE
	NULAST=-4
3666	CONTINUE
	CALL UVT100(13,0,0)
	IF(TOMT.EQ.0.AND.ICODE.EQ.10)WRITE(8,17)NMSH
	IF(ICODE.EQ.10)GOTO 2000
	IF(ICODE.NE.2)GOTO 1000
C DRAW LABELS FIRST
	CALL UVT100(1,1,1)
	CALL UVT100(12,2,0)
	IF(ICODE.NE.10)call swrt(nmsh,80)
	CALL UVT100(1,2,1)
	CALL UVT100(12,2,0)
C ERASE TOP LINE, START AT COL 7
	KSHEET=0
	IF(K3DFG.LE.0)GOTO 1890
	LR=NRDSP(1,1)
	LC=NCDSP(1,1)
	CALL GETSHT(LR,LC,KSHEET)
	IF(KSHEET.EQ.0)GOTO 1890
	write(fwt(1:7),1891)ksheet
	call swrt(fwt,7)
c	WRITE(6,1891)KSHEET
1891	FORMAT('PG=',I4)
	GOTO 2000
1890	CONTINUE
	call swrt('ROW\COL',7)
2	FORMAT('ROW\COL')
C NOTE EXACTLY 7 CHARACTERS IN FORMAT #2
2000	CONTINUE
	J=8
	CALL UVT100(13,7,0)
	DO 1 N1=1,DRWV
	LR=NRDSP(N1,1)
C NOTE PHYS SHEET OFFSET BY 1 (SEE VARSCN)
C DISPLAY SHEET NUMBERS START AT 1
	IF(ICODE.NE.10)CALL UVT100(1,2,J)
	IF(KSHEET.GT.0.AND.LR.GE.NRDSP(1,1).AND.
     1   (LR-(KSHEET)*KCDELT).GE.1) LR=LR-(KSHEET)*KCDELT
	CALL IN2AS(LR,LBEL)
	IF(ICODE.EQ.10)GOTO 2020
	write(fwt(1:100),3)LBEL
	CALL SWRT(fwt(1:100),4)
c	WRITE(0,3)LBEL
3	FORMAT(4A1)
	IF(LBEL(4).EQ.' '.AND.LBEL(3).EQ.' ')CALL UVT100(1,2,J+2)
	IF(LBEL(4).EQ.' '.AND.LBEL(3).NE.' ')CALL UVT100(1,2,J+3)
	write(fwt(1:100),7)n1
	call swrt(fwt(1:100),3)
7	FORMAT('=',I2)
	GOTO 2030
2020	CONTINUE
	IF((J+CWIDS(N1)-7).GT.121)GOTO 2030
	ICWD=MAX0(7,CWIDS(N1))
	WRITE(CWRK(1:127),2021,ERR=2030)LBEL,N1
	DO 752 N=1,ICWD
	PRTLIN(J-1+N)=CCWRK(N)
752	CONTINUE
C	ENCODE(ICWD,2021,PRTLIN(J),ERR=2030),LBEL,N1
2021	FORMAT(4A1,'=',I2)
2030	CONTINUE
	J=J+CWIDS(N1)
	IF(J.GT.132)GOTO 40
1	CONTINUE
40	CONTINUE
C NOW COL LBLS DONE
C DO NUMBERS ACROSS LEFT.
C ONLY DO SO ON SCREEN.
	IF(BORDR.EQ.0.AND.ICODE.EQ.10)WRITE(8,18)PRTLIN
	DO 2031 KKK=1,132
	FILINE(KKK)=Char(32)
2031	PRTLIN(KKK)=Char(32)
	IF(ICODE.EQ.10)GOTO 1000
	CALL UVT100(13,7,0)
	MCX=MIN0(LLCMD-1,DCLV)+2
C	LLVL=0
C ROWS ARE JUST OFFSET...NO MONKEY BUSINESS.
	DO 6 N1=3,MCX
	M1=N1-2
	LC=NCDSP(1,M1)-1
C N1=DISPLAY ROW
	CALL UVT100(1,N1,1)
C ADJUST DISPLAY LABELS FOR PAGE
	IF(KSHEET.GT.0.AND.LC.GE.(NCDSP(1,1)-1).AND.
     1   (LC-KSHEET*KRDELT).GE.1)LC=LC-KSHEET*KRDELT
	write(fwt(1:100),8)lc
	call swrt(fwt(1:100),6)
8	FORMAT(I5,'>')
6	CONTINUE
C NOW DISPLAY VALUES.
1000	CONTINUE
	CALL UVT100(13,0,0)
C main screen display loop here.
	If (NCEL.eq.0) GOTO 1011
	DO 10 N2=1,DCLV
	JP=8
	JPL=125
	DO 110 N1=1,DRWV
	M1=NRDSP(N1,N2)
	M2=NCDSP(N1,N2)
C M1,M2 = PHYS SHEET COORDS OF WHAT IS DISPLAYED.
	M2M1=M2-1
	IF(BORDR.EQ.0.AND.ICODE.EQ.10)WRITE(PRTLX(1:7),8)M2-1
C *** OMIT DISPLAY IF FVLD=0 ***
C
	CALL FVLDGT(M1,M2,FVLD(1,1))
	IF((ICHAR(FVLD(1,1)).EQ.0).AND.ICODE.NE.2.AND.ICODE.NE.
     1  10.AND.IDOL4.EQ.0) GOTO 100
C ******************************
	VDSP=DVS(N1,N2)
	CALL XVBLGT(M1,M2,VCLC)
C	VCLC=XVBLS(M1,M2)
C SEE IF DISPLAYED AND CALCULATED NUMBERS ARE IDENTICAL.
C ONLY DISPLAY IF CHANGED.
	IF(IDOL4.NE.0)GOTO 620
	IF(VDSP.EQ.VCLC.AND.ICODE.NE.2.AND.ICODE.NE.10)GOTO 100
620	IC1POS=M1
	IC2POS=M2
C FALL THRU HERE IF WE NEEDTO DISPLAY A NUMBER IN ROW 3+N2, COL N1
C THEN RE-ESTABLISH FORMAT, ETC.
	M23=N2+2
	J=8
	DO 11 N11=1,N1
C GET THE COORDS OF OUR CELL.
11	J=J+CWIDS(N11)
	J=J-CWIDS(N1)
C CURRENT CHARACTER COL NUMBER IS NOW J.
C	CALL UVT100(1,M23,J)
C	IRX=(M2-1)*60+M1
	CALL REFLEC(M2,M1,IRX)
C
C GET FORMULA IN NOW
	CALL WRKFIL(IRX,CWRK(1:127),0)
	CALL CE2A(CWRK(1:127),FORM)
C CONVERT ENCODED FORMS TO REGULAR ASCII
C	READ(7'IRX)FORM
C ALLOW FOR FVLD TO HAVE CONSTANT VS FORMULA SIGNIFICANCE
	IF(JCHAR(FORM(119)).LT.-1)FORM(119)=Char(253)
	IF(JCHAR(FORM(119)).GT.1)FORM(119)=Char(3)
C
c try & omit reset here... could mess other places up.
cC FVLD VALUES OF 2 INDICATE ALREADY-COMPUTED CONSTANTS.DON'T
cC FORCE THEM TO BE REDONE. OTHERWISE DO FILL IN HOWEVER.
c	CALL FVLDGT(M1,M2,FVLD(1,1))
c	IF(ICHAR(FVLD(1,1)).NE.2)CALL FVLDST(M1,M2,FORM(119))
cC	FVLD(M1,M2)=FORM(119)
cC	IF(FORM(120).LE.0)CALL FVLDST(M1,M2,char(0))
	CALL FVLDGT(M1,M2,FVLD(1,1))
	FVLDTP=FVLD(1,1)
C HANDLE FILE INCLUSION IN SUBROUTINE...
	IF (IDOL4.NE.0)CALL DSPFIL(ICODE,FORM,FORM2,FVLDTP,LFTMST,
     1  LENTL,LOCOL,FILINE,LLVL,LLU,LLVLF,J)
C NOTE WE CALL DSPFIL SO IT CAN BE OVERLAIN AND LET THE REST
C OF DSPSHT STAY RESIDENT. (SHOULD SPEED THINGS UP MOST OF
C THE TIME)...
C THIS SETTING OF FVLD ALLOWS THE Q OPTION TO WORK.
	IF(ICHAR(FVLDTP).NE.0)CALL UVT100(1,M23,J)
13	CONTINUE
	CALL XVBLGT(M1,M2,DVS(N1,N2))
C	DVS(N1,N2)=XVBLS(M1,M2)
	IF(ICHAR(FVLDTP).EQ.0)GOTO 100
	IF(FORMFG.LE.0.AND.JCHAR(FVLDTP).GE.0)GOTO 756
	DO 757 N=1,100
757	FORM2(N)=FORM(N)
756	CONTINUE
C     1  ENCODE(100,17,FORM2)(FORM(II),II=1,100)
17	FORMAT(1X,80A1)
	IF(FORMFG.NE.0)GOTO 4321
	DO 6304 KKKK=1,9
	KKKKK=ICHAR(FORM(KKKK+119))
C	KKKKK=DFMTS(KKKK,N1,N2)
6304	DFE(KKKK+1)=Char(MAX0(32,KKKKK))
	DFE(11)=Char(32)
	DFE(1)='('
	DFE(12)=' '
c omit any \ formats from dfe since encode fouls up with them.
	DFE(13)=' '
	DFE(14)=')'
	CALL TYPGET(M1,M2,TYPE(1,1))
c	IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
c     1  WRITE(CWRK(1:127),CDFE(1:14),ERR=4321)DVS(N1,N2)
c	IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
c     1  WRITE(CWRK(1:127),CDFE(1:14),ERR=4321)LDVS(1,N1,N2)
	IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
     1  WRITE(CWRK(1:127),DFE,ERR=4321)DVS(N1,N2)
	IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
     1  WRITE(CWRK(1:127),DFE,ERR=4321)LDVS(1,N1,N2)
	IF(JCHAR(FVLDTP).LE.0)GOTO 4321
	DO 758 N=1,100
758	FORM2(N)=CCWRK(N)
4321	CONTINUE
	KWID=CWIDS(N1)
C  *** FIND OUT HOW MUCH ROOM THERE IS NOW. WE KNOW WHERE WE'RE DISPLAYING, SO
C  *** ALLOW NULL CELLS TO BE SHOWN PROVIDED WE ARE:
C  1. DISPLAYING TEXT IN THE CELL, OR
C  2. IN VIEW FORMULA MODE, AND THE NEXT CELL(S) OVER ARE NULL (FVLD=0)
	IF(FORMFG.EQ.0.AND.JCHAR(FVLDTP).GE.0)GOTO 8444
	III=N1+1
	IF(III.GT.DRWV)GOTO 8446
	DO 8445 II=III,DRWV
C FOLLOW ALONG WITH THE DISPLAY'S MAPPING TO SHEET.
	IIII=NRDSP(II,N2)
	IIIII=NCDSP(II,N2)
	CALL FVLDGT(IIII,IIIII,FVLD(1,1))
	IF(ICHAR(FVLD(1,1)).NE.0)GOTO 8444
	KWID=KWID+CWIDS(II)
8445	CONTINUE
8446	CONTINUE
C TEST IF LAST CELL IS NULL
8444	CONTINUE
	KWID=MIN0(KWID,JPL)
C ****** END OF MODS FOR PRINTING INTO ADJACENT NULL CELLS.
	IF(ICODE.NE.10)CALL SWRT(FORM2,KWID)
	IF(ICODE.NE.10)GOTO 100
	IF(JPL-KWID.LT.0)GOTO 115
	DO 759 II=1,KWID
	IIII=JP+II-1
759	PRTLIN(IIII)=FORM2(II)
C	ENCODE(KWID,17,PRTLIN(JP),ERR=100)(FORM2(II),II=1,KWID)
100	CONTINUE
115	CONTINUE
C HERE KEEP TRACK OF AMOUNT PRINTED.
	JP=JP+CWIDS(N1)
	JPL=JPL-CWIDS(N1)
110	CONTINUE
	IF(ICODE.NE.10)GOTO 10
	DO 634 KKKQ=1,132
	IF(ICHAR(PRTLIN(KKKQ)).LT.32)PRTLIN(KKKQ)=Char(32)
634	CONTINUE
	WRITE(8,18)(PRTLIN(II),II=1,JP)
18	FORMAT(1X,100A1,34A1)
	DO 19 LN1=1,132
19	PRTLIN(LN1)=Char(32)
10	CONTINUE
1011	Continue
	IF(ICODE.EQ.10)CLOSE(8)
	IF(IDOL4.EQ.0)RETURN
	DO 9915 N=1,4
	LLU=N+10
	CLOSE(LLU)
9915	CONTINUE
	LLVL=0
8884	RETURN
	IOLVL=11
	CLOSE(3)
c	CLOSE(11)
c	OPEN(UNIT=11,FILE='CON:0/0/100/100/Analy Command')
	RETURN
	END
	SUBROUTINE GETSHT(LR,LC,KSHEET)
c FIGURE CORRECT SHEET, ENSURING THAT THE LR,LC PAIR IS
c SENSIBLY WITHIN IT.
	Include aparms.inc
c	INCLUDE 'VKLUGPRM.FTN'
	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,K3DFG,KCDelt,KRDelt,kpag
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,IDSPTP,IDOL9,
     3  K3DFG,KCDelt,KRDelt,kpag
	KSHEET=0
	KK1=MRC
	KK2=MRC
	IF(KRDELT.GT.0)KK1=(LC-2)/KRDELT
	IF(KCDELT.GT.0)KK2=(LR-1)/KCDELT
	KK=MIN0(KK1,KK2)
	IF(KK.GE.(MRC-100))GOTO 222
C IF BOTH DELTAS ARE ZERO DON'T TOUCH ANYTHING.
	KSHEET=MAX0(KK,0)
C KSHEET NONZERO FLAGS WE MAKE THE MOD
	IF(LR.LT.KSHEET*KCDELT)GOTO 2220
	IF((LC-1).LT.KSHEET*KRDELT)GOTO 2220
222	CONTINUE
	GOTO 2221
2220	CONTINUE
	KSHEET=0
2221	CONTINUE
	RETURN
	END
c -h- errcx.for	Fri Aug 22 13:08:07 1986	
	SUBROUTINE ERRCX (RETCD)
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 ERRCX                    *
C *                                                *
C **************************************************
C
C
C THIS SUBROUTINE DOES INITIAL SYNTAX CHECKING ON THE INPUT
C LINE. THE CHECKS MAKE SURE THAT PARENTHESES ARE BALANCED
C AND THAT THE EQUAL SIGN IS NOT MISUSED.
C
C RETCD     MEANING
C
C   1        NO ERRORS DETECTED
C   2        ERROR FOUND
C
C
C
C
C   MODIFICATION CLASSES: M1
C
C
C
C
C ERRCX CALLS ERRMSG WHICH PRINTS ERROR MESSAGES.
C
C
C
C ERRCX IS CALLED BY CALC
C
C
C
C   VARIABLE       USE
C
C    ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC
C                 OR THE CHARACTER %.
C    BLANK        ' '
C    I,J          HOLDS TEMPORARY VALUES.
C    LAST         HOLDS A CODE WHEN LOOKING FOR ERRORS INVOLVING
C                 THE EQUAL SIGN.
C    LEND         LAST NON-BLANK CHARACTER IN LINE(80).
C    LPAR         '('

C    PARCNT       0 IF PARENTHESIS ENCOUNTERED BALANCE. INCREASED
C                 BY 1 FOR EVERY LEFT PARENTHESIS, DECREASED BY
C                 BY 1 FOR EVERY RIGHT PERENTHESIS FOUND.
C    RETCD        HOLDS RETURN CODE. 1=O.K.  2=ERROR
C    RPAR         ')'
C
C
C
C	MODIFIED	REASON
C
C	18-MAY-1981	WHEN CHECKING FOR BALANCED PARENTHESIS, DON'T
C			INCLUDE THOSE THAT ARE PRECEEDED BY A SINGLE QUOTE
C			(CODE AT DO 100) (PB)
C
C
C
C	SUBROUTINE ERRCX (RETCD)
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 RETCD,PARCNT,VIEWSW,BASED
	InTeGer*4 I,J,LAST
C
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	CHARACTER*1 LINE(80)
	CHARACTER*1 QUOTE
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	DATA QUOTE/''''/
C
C
C
	RETCD=1
C
C **************************************************
C ******  MAKE SURE PARENTHESIS ARE BALANCED  ******
C **************************************************
C
	PARCNT=0
	I=NONBLK
4100	CONTINUE
C	DO 100 I=NONBLK,LEND
C SKIP VARIABLE NAMES WHICH ARE IN ENCODED FORM
	IF(ICHAR(LINE(I)).NE.255)GOTO 4101
	I=I+2
	GOTO 100
C AT 100 ADD 1 MORE TO I, SKIPPING CRUFT.
4101	CONTINUE
	IF (LINE(I).EQ.LPAR) GOTO 50
	IF (LINE(I).EQ.RPAR) GOTO 80
	GOTO 100
C
C ENCOUNTERED A LEFT PARENTHESIS, COUNT IT ONLY IF PRECEEDING
C CHARACTER IS NOT A SINGLE QUOTE
50	IF(I.EQ.NONBLK) GOTO 60
	IF(LINE(I-1).EQ.QUOTE) GOTO 100
60	PARCNT=PARCNT+1
	GOTO 100
C
C ENCOUNTERED A RIGHT PARENTHESIS, COUNT IT ONLY IF PRECEEDING
C CHARACTER IS NOT A SINGLE QUOTE
80	IF(I.EQ.NONBLK) GOTO 90
	IF(LINE(I-1).EQ.QUOTE) GOTO 100
90	PARCNT=PARCNT-1
	IF(PARCNT.LT.0)GOTO 160
100	CONTINUE
	I=I+1
	IF(I.LE.LEND)GOTO 4100
C
	IF (PARCNT.EQ.0) GOTO 200
C
C
C UNBALANCED PARENTHESIS
	I=6
140	CALL ERRMSG(I)
150	RETCD=2
	RETURN
C
C
C ILLEGAL EXPRESSION LIKE ')))X((('
160	I=8
	GOTO 140
C
C
C **************************************************
C *********   = SIGN SYNTAX CHECK   ****************
C **************************************************
C
200	CONTINUE
C
C
C  ALLOW A=B=C+2
C  MAY ONLY ASSIGN VALUES TO SINGLE UNSIGNED VARIABLES.
C  ALSO CATCH  =A
C       AND    A==B
C
C  LAST	=  0	FIRST CHAR OR FOUND =
C	   1	1 ALPHA CHARACTER
C	   2	MORE THAN 1 ALPHA OR
C		ENCOUNTERED NON-ALPHA
C		(BUT NOT = OR BLANK)
C
C
	LAST=0
	I=NONBLK
271	CONTINUE
C	DO 270 I=NONBLK,LEND
	IF (LINE(I).EQ.BLANK) GOTO 270
	IF (LINE(I).EQ.EQ) GOTO 230
C
C
C  LOOK FOR ALPHA
C	DO 220 J=1,27
C	IF (LINE(I).EQ.ALPHA(J)) GOTO 240
C220	CONTINUE
C LOOK FOR ANY VARIABLE NAME (NOT JUST ALPHA) (GCE)
	LLND=LEND
	CALL VARSCN(LINE,I,LLND,LSTCHR,ID1,ID2,IVALID)
	IF(IVALID.EQ.0) GOTO 220
	I=LSTCHR
	IF(LSTCHR.LT.LEND)I=LSTCHR-1
C IF WE GET A GOOD VARIABLE NAME POINT AT ITS END AND GO SAY WE'RE OK.
	GOTO 240
220	CONTINUE
C
C
C   MORE THAN 1 ALPHA OR ENCOUNTERED NON-ALPHA
C (BUT NOT = SIGN OR BLANK)
225	LAST=2
	GOTO 270
C
C
C = SIGN ENCOUNTERED
230	IF (LAST.EQ.1) GOTO 235
C
C ILLEGAL USE OF = SIGN
	GOTO 290
C
C HAD 1 ALPHA CHARACTER FOLLOWED BY = SIGN
235	LAST=0
	GOTO 270
C
C ENCOUNTERED A VARIABLE NAME (1 CHARACTER)
240	IF (LAST.EQ.2) GOTO 270
	IF (LAST.EQ.1) GOTO 225
C
C
C EXACTLY 1 ALPHA CHARACTER EITHER AS FIRST CHARACTER
C ENCOUNTERED OR AS THE 1ST CHARACTER AFTER AN = SIGN.
	LAST=1
270	CONTINUE
	I=I+1
	IF(I.LE.LEND) GOTO 271
C *****&&&&&  SIMULATE DO LOOP TO ALLOW MONKEYING WITH INDEX INSIDE.
C WHICH IS DONE SO WE CAN HUNT FOR VARIABLES BY NAME...
C
C
C <<<<<<<<<<<< ADD ADDITIONAL CHECKS HERE >>>>>>>>>>
C
	RETURN
C
C
C ILLEGAL USE OF = SIGN
290	I=17
	GO TO 140
	END
c -h- errmsg.for	Fri Aug 22 13:08:07 1986	
	SUBROUTINE ERRMSG (IMSG)
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  ERRMSG(MSG)                  *
C *                                                *
C **************************************************
C
C
C PRINTS OUT ERROR MESSAGES AS REQUESTED BY CODE IN MSG.
C
C ERRMSG IS CALLED BY THE FOLLOWING ROUTINES:
C
C AT
C BASCNG
C CALBIN
C CALC
C CALUN
C CMND
C CONTYP
C DECLR
C ERRCX
C INPOST
C MULADD
C MULDIV
C MULMUL
C NEXTEL
C POSTVL
C VAROUT
C ZNEG
C
C
C    VARIABLE    USE
C
C   I         TEMPORARY VARIABLE TO AVOID SIDE-EFFECT WITH CALLS
C             THAT USE A CONSTANT FOR THE ARGUMENT.
C   MSG       ERROR MESSAGE CODE.
C
C
C
C  NOTE: USE CODE 25 FOR UNKNOWN CAUSES.
C
C
C
C	SUBROUTINE ERRMSG (MSG)
C
	InTeGer*4 IMSG,I
	CHARACTER*20 MSG(27)
	CHARACTER*8 EMSG
	DATA EMSG/'*ERROR* '/
	DATA MSG(1)/'1ST CHAR ILLEGAL   '/
	DATA MSG(2)/'INDIR.NEST OVFLOW  '/
	DATA MSG(3)/'UNIDENTIFIED CMND  '/
	DATA MSG(4)/'ILL CHR IN VBL LIST'/
	DATA MSG(5)/'VBLS NT SEP W/COMMA'/
	DATA MSG(6)/'UNBAL PARENTHESIS  '/
	DATA MSG(7)/'STACK 1 OVERFLOW   '/
	DATA MSG(8)/'ILLEGAL EXPRESSION '/
	DATA MSG(9)/'STACK 2 OVERFLOW   '/
	DATA MSG(10)/'FCN ILL W/INT ARGS '/
	DATA MSG(11)/'FCN ILL W/MPR ARGS '/
	DATA MSG(12)/'FCN ILL W/ASCI ARG '/
	DATA MSG(13)/'FCN ILL W/REAL ARG '/
	DATA MSG(14)/'SQRT OF NEG NUMBER '/
	DATA MSG(15)/'MP EXP W/NEG POWER '/
	DATA MSG(16)/'UNDEFINED VARIABLE '/
	DATA MSG(17)/'ILL USE OF = SIGN  '/
	DATA MSG(18)/'UNIDENTIFIED FUNCT '/
	DATA MSG(19)/'ILLEGAL BASE SPEC  '/
	DATA MSG(20)/'ILLEGAL CHARACTER  '/
	DATA MSG(21)/'. OK ONLY W/BASE 10'/
	DATA MSG(22)/'OVER 19 DIGIT MP NO'/
	DATA MSG(23)/'DIVIDE BY ZERO ERR '/
	DATA MSG(24)/'ILL REAL EXP FIELD '/
	DATA MSG(25)/'WEIRD BUG. CALL GE.'/
	DATA MSG(26)/'ILLEG CONVERSION   '/
	DATA MSG(27)/'READ ERROR         '/
C
C
	CALL UVT100(1,1,10)
C WRITE "*ERROR*" FOLLOWED BY MESSAGE TEXT/
	CALL SWRT(EMSG,8)
	I=IMSG
	IF(I.LE.0.OR.I.GT.27)I=25
	CALL SWRT(MSG(I),20)
C
99	RETURN
	END
c -h- flip.for	Fri Aug 22 13:09:05 1986	
	SUBROUTINE FLIP (VEC,SIZE,PT)
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 FLIP(VEC,SIZE,PT)           *
C *                                                *
C **************************************************
C
C
C  FLIPS THE NON-ZERO DIGITS UP TO PT IN VECTOR VEC IN REVERSE
C  ORDER.  USED TO PLACE NUMBERS IN PROPER ORDER INTO VBLS THAT
C  HAVE BEEN READ IN HIGH ORDER FIRST.
C
C FLIP IS CALLED BY NEXTEL
C
C   VARIABLE   USE
C
C     H1     TEMPORARILY HOLDS A CHARACTER*1 VALUE
C     I      INDEXES DIGITS THAT ARE FLIPPED.
C     K      THE MIDPOINT OF THE FLIPPING ACTION.
C     PT     HOLDS THE RANGE OF THE FLIPPING ACTION.
C            (USUALLY THE HIGH ORDER NON-ZERO DIGIT)
C
C
C
C	SUBROUTINE FLIP (VEC,SIZE,PT)
C
C
	InTeGer*4 SIZE,PT
	InTeGer*4 K
C
	CHARACTER*1 VEC(SIZE), H1
C
C
	K=PT/2
	IF (K.EQ.0) GOTO 20
	DO 10 I=1,K
	H1=VEC(I)
	VEC(I)=VEC(PT+1-I)
10	VEC(PT+1-I)=H1
20	RETURN
	END
c -h- fname.fms	Fri Aug 22 13:09:16 1986	
	SUBROUTINE FNAME(LINE,LLAST,INDEXF)
C RETURN FUNCTION NAME IF ANY
C IMPLEMENT CODE RECOGNITION ALSO...
C CODES 230-254 ARE THE FUNCTION NAMES... REPLACE THE 3 BYTES BY 1
C CODE BYTE TO IMPLEMENT...
C
	CHARACTER*1 LINE(110)
c	EXTERNAL INDX
	INTEGER*4 FNAM(26)
	character*4 fnmx(26)
	equivalence(fnmx(1)(1:1),fnam(1))
	CHARACTER*1 FCHNM(4,26)
	EQUIVALENCE(FNAM(1),FCHNM(1,1))
	DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
     1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
     2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
     3  'RND ','PMT','PVL','AVE','CHS','ATM'/
	INDEXF=0
	N1=ICHAR(LINE(1))
C RECOGNIZE ENCODED VARIABLE NAMES.
	IF(N1.LT.230.OR.N1.GT.254)GOTO 3000
	INDEXF=N1-229
	RETURN
3000	CONTINUE
	DO 1 N1=1,26
	DO 2 N2=1,3
	IF(LINE(N2).NE.FCHNM(N2,N1))GOTO 1
2	CONTINUE
C IF WE FALL THROUGH, WE HAVE A VALID FCN NAME INDEX IN INDEXF
	INDEXF=N1
	GOTO 3
1	CONTINUE
3	CONTINUE
	RETURN
	END
c -h- frmedt.ftn	Fri Aug 22 13:09:29 1986	
	SUBROUTINE FRMEDT(INLIN,LEND)
C COPYRIGHT 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C FORMULA EDIT TO FIND AND EDIT FORMULAS OF FORM
C	{VAR
C AND REPLACE THE VARIABLE SPEC BY FORMULA FOR THAT VARIABLE
	INCLUDE APARMS.INC
	CHARACTER*1 INLIN(110),WRK1(120),WRK2(128)
	CHARACTER*3 WRK13
	EQUIVALENCE(WRK13(1:1),WRK1(23))
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
CCC	InTeGer*4 LLCMD,LLDSP
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C ADD LOGICAL NAMES IN THE FOLLOWING FASHION, TO BE MANIPULATED
C HERE ALONE:
C
C STORE LOGICAL NAMES, UP TO 16 CHARS, HERE IN AN ARRAY WITH
C DESIRED ID1,ID2 VALUES OF CELLS TO LOAD. WHERE A {NAME IS SEEN,
C REPLACE WITH DESIRED CELL ADDRESS.
C  TO DEFINE LOGICAL NAMES, LOOK FOR = AFTER A NAME. IF = IS SEEN
C  AFTER THE { CHARACTER, ASSUME IT'S A LINE OF FORM {SALES=AA0
C  (OR {SALES=00 TO DEASSIGN) AND STORE THE NAME. UP TO THE USER
C  TO PUT THE DESIRED FORMULA IN AS HE LIKES. MAY USE A TEST STMT
C  IF DESIRED.
CCC	CHARACTER*1 NAMARY(20,301)
C ALLOW AS MANY NAMES AS THERE ARE ROWS... ARBITRARY...
	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,MROWS)
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
	InTeGer*2 NAMNUM(10,MROWS)
	EQUIVALENCE(NAMARY(1,1),NAMNUM(1,1))
CCC	COMMON/NMNMNM/NAMARY
C NAMNUM(9,RCL) AND NAMNUM(10,RCL) ARE RRW AND RCL
C STORAGE. NAMARY(1-18,RCL) STORES NAME ASCII TEXT (POSSIBLY
C NULL TERMINATED). FIND CELLS VIA LINEAR SEARCH.
	SAVE NAMMAX
	InTeGer*4 NAMMAX
C NAMMAX IS MAX DIM OF NAMARY THAT'S FILLED IN.
	EXTERNAL INDX
	InTeGer*4 LEND
	DATA NAMMAX/0/
	LCNT=0
1000	IF(LCNT.GT.20)RETURN
	KKK=ICHAR('{')
	I1=INDX(INLIN,KKK)
	IF(I1.LE.0.OR.I1.GT.70)RETURN
C ONLY ALLOW IF THERE IS A { CHAR THERE
	IF(INLIN(I1).NE.'{')RETURN
	KKK=ICHAR('=')
	I2=INDX(INLIN,KKK)
	IF(I2.LE.0.OR.I2.LT.I1.OR.I2.GT.70.OR.INLIN(I2)
     1  .NE.'=')GOTO 5400
	IF((I2-I1).LE.1)GOTO 5400
C HERE SEE AN = SIGN AFTER A {VAR STRING. ATTEMPT TO EVALUATE.
C GUARANTEED AT LEAST 1 CHARACTER OF NAME.
	I3=MIN0((I2-I1-1),16)
c check if * seen ( text would then be  {*= ) for printout

c of symbol table
	IF(INLIN(I1+1).NE.'*')GOTO 5600
	IF(NAMMAX.LE.0)GOTO 5600
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
C ERASE LINE
	CALL VWRT('Output File:',12)
	call vget(wrk1,80)
c	read(11,5602,end=5419,err=5419)(wrk1(II),II=1,80)
5602	format(80a1)
	DO 5603 N=1,79
	NN=80-N
	IF(JCHAR(WRK1(NN)).GT.32)GOTO 5604
	WRK1(NN)=Char(0)
5603	CONTINUE
5604	CONTINUE
	close(8)
	CALL WASSIG(8,WRK1)
C OPEN OUTPUT FOR WRITE
C THEN DUMP SYMBOLS THERE
C SYMBOL TABLE DUMP CAN BE SAVED ANYWHERE AND REENTERED AS
C ASSIGNMENT STMTS.
	WRK1(1)='{'
	DO 5607 N=2,110
5607	WRK1(N)=0
	WRK1(18)='='
	DO 5605 N=1,NAMMAX
	IF(NAMNUM(9,N)+NAMNUM(10,N).LE.0)GOTO 5605
	DO 5608 NN=1,16
5608	WRK1(NN+1)=NAMARY(NN,N)
	CALL IN2AS(KK,WRK1(19))
	NAMNUM(9,N)=KK
	WRITE(WRK13(1:3),5606,ERR=5419)NAMNUM(10,N)-1
C	ENCODE(3,5606,WRK1(23))NAMNUM(10,N)-1
5606	FORMAT(I3)
	K=3
	WRK2(1)='T'
	WRK2(2)='E'
	WRK2(3)=' '
	DO 5609 KK=1,106
	I4=JCHAR(WRK1(KK))
	IF(I4.LE.32)GOTO 5609
	K=K+1
	WRK2(K)=CHAR(I4)
5609	CONTINUE
C WRITE OUT DEFINITIONS AS IF THEY WERE ASSIGMNENT STMTS.
	WRITE(8,5610)(WRK2(KK),KK=1,K)
5610	FORMAT(110A1)
5605	CONTINUE
	CLOSE(8)
	GOTO 5419
5600	CONTINUE
	LO=I2+1
	IHI=LO+25
	CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
C IF IVLD=0 ASSUME WE'RE UNDEFINING THE SYMBOL
	IF(IVLD.GT.0)GOTO 5402
C INVALID SYMBOL. UNDEFINE THE STRING.
	DO 5403 I4=1,NAMMAX
	DO 5404 I5=1,I3
C REQUIRE WHOLE STRING FOR SEARCH.
	IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5403
5404	CONTINUE
C GOT IT IF WE FALL THRU
	NAMNUM(9,I4)=0
	NAMNUM(10,I4)=0
C ZERO THE ELEMENT DEFINITION AND FORGET IT...
	DO 5432 I5=1,16
5432	NAMARY(I5,I4)=Char(0)
5403	CONTINUE
	GOTO 5419
5402	CONTINUE
C VALID ARRAY ELEMENT, DEFINE IT.
	IF(NAMMAX.LE.0)GOTO 5406
	DO 5405 I4=1,NAMMAX
	IF(NAMNUM(9,I4)+NAMNUM(10,I4).EQ.0)GOTO 5410
5405	CONTINUE
	GOTO 5406
5410	CONTINUE
C GOT IT IF WE FALL THRU
	NAMNUM(9,I4)=ID1
	NAMNUM(10,I4)=ID2
C ZERO THE ELEMENT DEFINITION AND FORGET IT...
	GOTO 5407
5406	CONTINUE
	IF(NAMMAX.LT.0)NAMMAX=0
	NAMMAX=MIN0(NAMMAX+1,MROWS)
	NAMNUM(9,NAMMAX)=ID1
	NAMNUM(10,NAMMAX)=ID2
C NOW SAVE THE SYMBOL NAME
	I4=NAMMAX
5407	CONTINUE
	DO 5409 I5=1,16
5409	NAMARY(I5,I4)=0
	DO 5408 I5=1,I3
	NAMARY(I5,I4)=INLIN(I1+I5)
5408	CONTINUE
C NO FURTHER PROCESSING IF WE DID ANY DEFINITION... JUST EXIT
5419	CONTINUE
	INLIN(1)='%'
C IF A DEFINITION, JUST PUT SOMETHING INNOCUOUS INTO LINE FOR
C LATER PROCESSING.
	DO 5421 I5=2,110
5421	INLIN(I5)=0
	RETURN
5400	CONTINUE
C NOW THAT DEFINITIONS ARE TAKEN CARE OF (IF ANY)
C HANDLE SYMBOLIC SEARCHES
	if(nammax.le.0)goto 5505
	LSTCHR=I1+1
	DO 5501 I4=1,NAMMAX
	DO 5502 I5=1,16
	IF(JCHAR(NAMARY(I5,I4)).LE.47)GOTO 5502
	IF(JCHAR(INLIN(I1+I5)).LE.47)GOTO 5502
	LSTCHR=I1+I5+1
	IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5501
CC SKIP OUT IF WE HAVE A TERMINATING CHARACTER IN DEF
CC AND HAD AT LEAST 1 NONTERMINATING CHAR IN DEFINITION.
C	IF(JCHAR(NAMARY(1,I4)).GT.47.AND.
C     1     JCHAR(NAMARY(I5,I4)).LE.47) GOTO 5560
5502	CONTINUE
5560	CONTINUE
C IF WE FALL THRU WE HAVE A MATCH
	ID1=NAMNUM(9,I4)
	ID2=NAMNUM(10,I4)
C LAST CHECK: BE SURE WE AREN'T GIVING A DELETED SYMBOL.
	IF((ID1+ID2).GT.0)GOTO 5500
5501	CONTINUE
5505	continue
	LO=I1+1
	IHI=LO+25
	CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
	IF(IVLD.LE.0)RETURN
5500	CONTINUE
	DO 11 N1=1,120
11	WRK1(N1)=0
C HERE HAVE A VALID CONSTRUCT SO REPLACE IT
C (ONLY ONE PER LINE THIS TIME ROUND)
C	IRX=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,IRX)
C COPY FIRST PART OF FORMULA TO WORK ARRAY
	LO=I1-1
	IHI=0
	IF(LO.LE.0)GOTO 10
	DO 1 N1=1,LO
	IHI=N1
	WRK1(IHI)=INLIN(N1)
1	CONTINUE
10	CONTINUE
	IHI=IHI+1
	CALL WRKFIL(IRX,WRK2,0)
C WRKFIL READS THE FORMULA INTO WRK2. NEXT FIND END OF TEXT
	DO 2 N1=1,110
	LO=111-N1
	IF(ICHAR(WRK2(LO)).GT.32)GOTO 3
2	CONTINUE
3	CONTINUE
C LO NOW IS LENGTH OF FORMULA
	DO 4 N1=1,LO
	WRK1(IHI)=WRK2(N1)
	IF(IHI.LT.110)IHI=IHI+1
4	CONTINUE
C TACK ON ANY MORE TEXT
C RELY ON INLIN BEING 110 CHARS LONG
	DO 5 N1=LSTCHR,110
	WRK1(IHI)=INLIN(N1)
	IF(IHI.LT.110)IHI=IHI+1
5	CONTINUE
C NOW COPY 110 CHARS BACK TO INLIN
	DO 6 N1=1,110
6	INLIN(N1)=WRK1(N1)
	DO 7 N1=1,110
	LO=111-N1
	IF(ICHAR(INLIN(LO)).GT.32)GOTO 8
C	INLIN(LO)=CHAR(32)
7	CONTINUE
8	LEND=LO
	LCNT=LCNT+1
	GOTO 1000
C KEEP LOOKING & RECURSING BUT IMPOSE LIMIT
C	RETURN
	END
c -h- fvldgt.for	Fri Aug 22 13:10:38 1986	
        SUBROUTINE FVLDGT(ID1,ID2,IVAL)
C
C FVLDGT - RETURN FVLD BYTE GIVEN 2 DIMS OF ITS "LOCATION"
	INCLUDE APARMS.INC
        InTeGer*4 ID1,ID2
        CHARACTER*1 IVAL
C NEXT BITMAPS IMPLEMENT FVLD
	EXTERNAL INDX
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
        CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
	CHARACTER*1 FVXX(Imps3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
	EQUIVALENCE (FV4(1),FVXX(Imp3s))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
        CHARACTER*1 ITYP(Imp1s)
        InTeGer*4 IATYP(27)
        COMMON/TYP/IATYP,ITYP
	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,Mrows)
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
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.
	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
CCC        CHARACTER*1 FMTDAT(9,76)
CCC        COMMON/FMTBFR/FMTDAT
        CHARACTER*1 I1,I2,I4
	CHARACTER*1 IT1,IT2,IT4,IT8
	LOGICAL*4 LT1,LT2,LT4,LT8
	InTeGer*4 KT1,KT2,KT4,KT8
	CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
       EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
     1(LT8,IT82(1))
       EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
     1 (KT8,IT82(1))
C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
C ORDER BYTE WITH EQUIVALENCES
	EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
     1 (IT82(2),IT8)
	IF(ID2.GT.0)GOTO 2000
C TRICK ENTRY USING ID IN FIRST ARG, 0 IN 2ND ARG...
C TELL XVBLST/XVBLGT ABOUT FV4 STATE (SET BY CALL WITH -4 BYTE ON FVLDST)
	ID=ID1
        IBT=((ID-1)/8)+1
	KT1=ID-1
	KT2=7
	KT1=IMASK(KT1,KT2)
C	LT1=LT1.AND.LT2
	IBIT=KT1+1
C        IBIT=((ID-1).AND.7)+1
C        I1=FV1(IBT).AND.LBITS(IBIT)
C        I2=FV2(IBT).AND.LBITS(IBIT)
C        I4=FV4(IBT).AND.LBITS(IBIT)
	KT1=ICHAR(FV1(IBT))
	KT2=ICHAR(FV2(IBT))
	KT4=ICHAR(FV4(IBT))
	KT8=ICHAR(LBITS(IBIT))
	KT1=IMASK(KT1,KT8)
C	LT1=LT1.AND.LT8
	KT2=IMASK(KT2,KT8)
C	LT2=LT2.AND.LT8
	KT4=IMASK(KT4,KT8)
C	LT4=LT4.AND.LT8
	I1=CHAR(KT1)
	I2=CHAR(KT2)
	I4=CHAR(KT4)
	IVAL=0
C RETURN NONZERO IF ANY BITS ARE SET.
	IF((KT1+KT2+KT4).NE.0)IVAL=1
C	IF((I1+I2+I4).NE.0)IVAL=1
	RETURN
2000	CONTINUE
C REFLECT ALL BACK TO PRIME STORAGE REGION
C        ID=(ID2-1)*60+ID1
	IF(ID2.EQ.1.AND.ID1.LE.MRC)GOTO 7806
	CALL REFLEC(ID2,ID1,ID)
	GOTO 7807
7806	CONTINUE
	ID=ID1
7807    IBT=((ID-1)/8)+1
	KT1=ID-1
	KT2=7
	KT1=IMASK(KT1,KT2)
C	LT1=LT1.AND.LT2
	IBIT=KT1+1
C        IBIT=((ID-1).AND.7)+1
C        I1=FV1(IBT).AND.LBITS(IBIT)
C        I2=FV2(IBT).AND.LBITS(IBIT)
C        I4=FV4(IBT).AND.LBITS(IBIT)
	KT1=ICHAR(FV1(IBT))
	KT2=ICHAR(FV2(IBT))
	KT4=ICHAR(FV4(IBT))
	KT8=ICHAR(LBITS(IBIT))
C	LT1=LT1.AND.LT8
C	LT2=LT2.AND.LT8
C	LT4=LT4.AND.LT8
	KT1=IMASK(KT1,KT8)
	KT2=IMASK(KT2,KT8)
	KT4=IMASK(KT4,KT8)
C	I1=CHAR(KT1)
C	I2=CHAR(KT2)
C	I4=CHAR(KT4)
        IVL=0
        IF(KT1.NE.0)IVL=1
        IF(KT2.NE.0)IVL=IVL+2
        IF(KT4.NE.0)IVL=-IVL
        IVAL=CHAR(IVL)
C READS OFF FVLD BYTE FROM 3 BITS, HIGH ONE IS SIGN. TREAT AS SIGN-
C MAGNITUDE NUMBER IN RANGE -3 TO +3,
        RETURN
        END
c -h- fvldst.for	Fri Aug 22 13:10:51 1986	
        SUBROUTINE FVLDST(ID1,ID2,IVAL)
C
C FVLDST - SET THE BYTE IN FVLD ARRAY
C NEXT BITMAPS IMPLEMENT FVLD
	Include Aparms.inc
        CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
	CHARACTER*1 FVXX(IMps3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
	EQUIVALENCE (FV4(1),FVXX(Imp3s))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
        CHARACTER*1 IVAL
        CHARACTER*1 LBITS(8)
	EXTERNAL INDX
        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(Imp1s)
        InTeGer*4 IATYP(27)
        COMMON/TYP/IATYP,ITYP
	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,MRows)
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
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.
	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
CCC        CHARACTER*1 FMTDAT(9,76)
	InTeGer*4 IVV,I1,I2,I3,ITA
	LOGICAL*4 L2,L1,LVV,LTA
	EQUIVALENCE(L2,I2),(L1,I1),(LVV,IVV)
	EQUIVALENCE(LTA,ITA)
CCC        COMMON/FMTBFR/FMTDAT
	CHARACTER*1 IT1,IT2,IT4,IT8
	LOGICAL*4 LT1,LT2,LT4,LT8
	InTeGer*4 KT1,KT2,KT4,KT8,KW1,KW2
	CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
	EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
     1  (LT8,IT82(1))
	EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
     1  (KT8,IT82(1))
C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
C ORDER BYTE WITH EQUIVALENCES
C	EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
C     1  (IT82(2),IT8)
C        CHARACTER*1 I4
	IF(ID2.EQ.1.AND.ID1.LE.MRC)GOTO 7806
C ALLOW DELIBERATE CALL WITH EFFECTIVELY ONE ARG.
7807	CALL REFLEC(ID2,ID1,ID)
	GOTO 7808
7806	CONTINUE
C        ID=(ID2-1)*60+ID1
	ID=ID1
7808    IBT=((ID-1)/8)+1
	KT1=ID-1
	KT2=7
	KT1=IMASK(KT1,KT2)
C	LT1=LT1.AND.LT2
	IBIT=KT1+1
C        IBIT=((ID-1).AND.7)+1
C ZERO ALL 3 FVLD BITS FIRST
C        FV1(IBT)=FV1(IBT).AND..NOT.LBITS(IBIT)
C        FV2(IBT)=FV2(IBT).AND..NOT.LBITS(IBIT)
C        FV4(IBT)=FV4(IBT).AND..NOT.LBITS(IBIT)
	KT1=ICHAR(FV1(IBT))
	KT2=ICHAR(FV2(IBT))
	KT4=ICHAR(FV4(IBT))
	KT8=ICHAR(LBITS(IBIT))
	ITA=-KT8-1
C ITA IS NOW THE COMPLEMENT OF KT8
C THUS, THE SELECTED BIT IS OFF IN IT, ALL OTHERS ON.
C	LT1=LT1.AND.LTA
C	LT2=LT2.AND.LTA
C	LT4=LT4.AND.LTA
	KT1=IMASK(KT1,ITA)
	KT2=IMASK(KT2,ITA)
	KT4=IMASK(KT4,ITA)
C FILL IN ALL 3 BITMAPS WITH THEIR PREVIOUS CONTENTS EXCEPT THE
C CHOSEN BITS.
	FV1(IBT)=CHAR(KT1)
	FV2(IBT)=CHAR(KT2)
	FV4(IBT)=CHAR(KT4)
	IVVV=JCHAR(IVAL)
        IVV=IABS(IVVV)
        I3=0
        IF(IVVV.LT.0)I3=1
C	I1=1
C	I2=2
	KW2=2
	KW1=1
	I2=IMASK(IVV,KW2)
	I1=IMASK(IVV,KW1)
C        L2=LVV.AND.L2
C        L1=LVV.AND.L1
C NOTE WE ASSUME HEAVILY THAT LOGICAL OPERATIONS WORK BY BINARY
C ANDS AND ORS IN DATA.
C ** NOTE WE DON'T NEED TO RELOAD THE KT1 THRU KT4 INTEGERS... ALL ALREADY
C ARE LOADED... DITTO KT8
C	KT1=ICHAR(FV1(IBT))
C	KT2=ICHAR(FV2(IBT))
C	KT4=ICHAR(FV4(IBT))
C	KT8=ICHAR(LBITS(IBIT))
	LT1=LT1.OR.LT8
	LT2=LT2.OR.LT8
	LT4=LT4.OR.LT8
C        IF(I1.NE.0)FV1(IBT)=FV1(IBT).OR.LBITS(IBIT)
C        IF(I2.NE.0)FV2(IBT)=FV2(IBT).OR.LBITS(IBIT)
C        IF(I3.NE.0)FV4(IBT)=FV4(IBT).OR.LBITS(IBIT)
        IF(I1.NE.0)FV1(IBT)=CHAR(KT1)
        IF(I2.NE.0)FV2(IBT)=CHAR(KT2)
        IF(I3.NE.0)FV4(IBT)=CHAR(KT4)
        RETURN
        END
c -h- fvpeek.fms	Fri Aug 22 13:11:27 1986	
C DUMMY FVPEEK
	SUBROUTINE FVPEEK(ID1,ID2,IGO)
	InTeGer*4 ID1,ID2,IGO
	IGO=ID1
	RETURN
	END
c -h- getfnl.for	Fri Aug 22 13:12:09 1986	
	SUBROUTINE GETFNL(LINE,LSKP,LLEN)
C PARSE OUT FILENAME AND GET LSKP, LLEN NUMBERS
	EXTERNAL INDX
	CHARACTER*1 LINE(80)
	InTeGer*4 LSKP,LLEN,LO,HI
	LSKP=0
	LLEN=32000
C SET INITIAL NUMBERS TO READ WHOLE FILE
	KKK=ICHAR(',')
	N=INDX(LINE,KKK)
	IF(N.LE.0.OR.N.GT.78)RETURN
C IF CANNOT FIND COMMA, JUST SKIP OUT & TRY TO CATCH ERRORS ON OPEN.
	LINE(N)=0
C NULL TERMINATE FILENAME
	LO=N+1
	HI=LO+20
	CALL GN(LO,HI,LSKP,LINE)
	LO=N+1
	KKK=ICHAR(',')
	N=INDX(LINE(LO),KKK)
	IF(N.LE.0.OR.N.GT.30)RETURN
	LO=LO+N
	HI=LO+20
	CALL GN(LO,HI,LLEN,LINE)
C SHOULD HAVE NUMBERS NOW
	RETURN
	END
c -h- getlog.for	Fri Aug 22 13:12:16 1986	
	SUBROUTINE GETLOG(LINE,LMX,LOGTYP,LASST)
	CHARACTER*1 LINE(110)
	EXTERNAL INDX
	CHARACTER*1 LFN(4,6)
	CHARACTER*4 XLF(6)
	INTEGER*4 LF(6)
	EQUIVALENCE(XLF(1)(1:1),LF(1),LFN(1,1))
C	EQUIVALENCE(LF(1),LFN(1,1))
	DATA XLF/'.GT.','.LT.','.EQ.','.NE.','.GE.','.LE.'/
C LOGTYP RELATIONSHIP TO RELATIONSHIPS OF 2 VARIABLES
C IS DEFINED IN ABOVE DATA STMT.
C IF LINE CONTAINS STRING IN NAME, RETURN TYPE AND END LOC.
	LMX4=LMX-3
	DO 100 LL=1,6
	LOGTYP=LL
	DO 1 N1=1,LMX4
	IF(LINE(N1  ).NE.LFN(1,LL))GOTO 2
	IF(LINE(N1+1).NE.LFN(2,LL))GOTO 2
	IF(LINE(N1+2).NE.LFN(3,LL))GOTO 2
	IF(LINE(N1+3).NE.LFN(4,LL))GOTO 2
C HERE HAVE A MATCH
	LASST=N1
C RETURN LOC OF NEXT CHAR AFTER RELATION.
	GOTO 200
2	CONTINUE
1	CONTINUE
100	CONTINUE
	LOGTYP=0
200	CONTINUE
	RETURN
	END
c -h- getnnb.for	Fri Aug 22 13:13:44 1986	
	SUBROUTINE GETNNB(IPT,RETCD)
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 GETNNB(IPT,RETCD)           *
C *                                                *
C **************************************************
C
C
C  GET NEXT NON-BLANK ELEMENT FROM LINE STARTING AT NONBLK+1
C
C  RETCD =  1   O.K.
C	    2   NO NON-BLANK FOUND
C
C  IPT POINTS TO POSITION IN LINE WHERE NEXT NON-BLANK IS FOUND.
C  IT IS UP TO CALLING PROGRAM TO RESET NONBLK FOR NEXT SCAN.
C
C
C
C GETNNB IS CALLED BY
C
C AT
C BASCNG
C CMND
C NEXTEL
C STRCMP
C
C
C   VARIABLE    USE
C
C    BLANK      ' '
C    IPT        RETURNS POSITION OF NEXT NON-BLANK.
C    K          HOLDS TEMPORARY VALUES.
C    LEND       LAST NON-BLANK IN LINE(80).
C    NONBLK     HOLDS CHARACTER TO LEFT OF THE START OF THE SCAN.
C    RETCD      HOLDS THE RETURN CODE. 1=O.K.  2=THE REST IS BLANKS.
C
C
C	SUBROUTINE GETNNB(IPT,RETCD)
C
C
	InTeGer*4 IPT
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 VIEWSW,BASED,BASE,RETCD
	InTeGer*4 K
C
	CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
	RETCD=1
	IF (NONBLK.GE.LEND) GOTO 999
C
C AT LEAST 1 NON-BLANK EXISTS.
	K=NONBLK+1
	DO 10 IPT=K,LEND
	IF (LINE(IPT).NE.BLANK) GOTO 1000
10	CONTINUE
C
C
C ACTUALLY, SHOULD NEVER FALL THROUGH IF 'LEND' IS SET CORRECTLY.
C
C
C THE REST ARE BLANKS
999	RETCD=2
1000	RETURN
	END
c -h- getttl.for	Fri Aug 22 13:14:41 1986	
	SUBROUTINE GETTTL(LINE)
	Include AParms.inc
	CHARACTER*1 LINE(132)
	CHARACTER*3 FNAME
	CHARACTER*1 FN(3)
	EQUIVALENCE (FN(1),FNAME(1:1))
	InTeGer*4 IBBX
	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,MRows)
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
CCC	COMMON/MODPUB/MODPUB,LIMODE
C MODPUB = MODE USED IN CMD MODE GTMODE ROUTINE
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
CCC	InTeGer*4 LLCMD,LLDSP
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C LIMODE IS WHAT GETS SET UP IN /# CMND
	IBBX=0
C
C
C
C
C CODE FOR FORTRAN READ...
C  **** HERE IS THE SECTION OF CODE YOU NEED FOR NON-VMS-SPECIFIC VERSION
C NOTE READS UNIT 0 TO GET CONSOLE.
C CHECK THAT WE'RE READING CONSOLE. IF LUN 5 IS OFF CONSOLE, THEN
C READ USING DIRECT DOS CALLS.
C  IF (STILL) IN AN INITIALIZER FILE, READ USING REGULAR FORTRAN READS
C AND ACT NORMALLY.
C  DISCOVER CONSOLE BECAUSE FILENAME IS 'CON:' OR 'CON'.
CC	INQUIRE(UNIT=5,NAME=FNAME)
CC	IF (FN(1).NE.'C'.OR.FN(2).NE.'O'.OR.FN(3).NE.'N')
CC     1 GOTO 5000
C CALL ASSEMBLER ROUTINE TO GET CHARACTERS.
	DO 5001 N=1,132
5001	LINE(N)=CHAR(0)
C FIX IT UP SO A NULL LINE LOOKS HARMLESS...
	LINE(1)=' '
C NULL THE LINE FIRST IN FORTRAN; MAKES IT EASIER TO DO ASSEMBLER STUFF.
	CALL TTYIN(MODPUB,LINE)
	IF(LINE(1).NE.'/')GOTO 5540
C DISPLAY HELP MSG AT BOTTOM
	IF(MODPUB.EQ.0)GOTO 5540
C ONLY DISPLAY IF IN "AUTOENTER" MODE
c	CALL UVT100(1,LLDSP,1)
c	CALL SWRT('Add,Cpy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set',46)
c	CALL SWRT(',Tst,View,Wrt,Xit,Zap,/,Help',28)
c	CALL UVT100(1,LLCMD,11)
C CALL TTYIN NEXT WITH 0 SO / ISN'T TERMINATOR.
c	N=0
C	CALL TTYIN(N,LINE(2))
5540	CONTINUE
	IF(ICHAR(LINE(1)).EQ.26)
     1  GOTO 2000
C Add,Copy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set,Test,View,Wrt,Xit,Zap,Help,/
C READ IN AFTER CLOSE AND RE-OPEN IF WE GET EOF ON INPUT SIGNALLED
C BY CONTROL Z.
C ASSUME WE'LL USE DOS FUNCTION 1 FOR READIN AND ECHO
C AND THEN END THE READIN AFTER FIRST CONTROL SEQUENCE.
C	GOTO 6000
C5000	CONTINUE
C	READ(5,1000,END=2000,ERR=2000)LINE
1000	FORMAT(132A1)
6000	CONTINUE
CC	IF(ICHAR(LINE(1)).NE.0)RETURN
CCC IF WE GET 0 MAYBE IT'S AN EXTENDED CODE. TRY RETURNING A HASHED
CCC VALUE HERE. USE __{CELL WHERE CELL IS A FOLLOWED BY (B+CODE) WHERE
CC CODE IS THE VALUE RETURNED...
CC	LINE(5)=CHAR(ICHAR(LINE(2))+66-59)
CC EXTENDED CODES WE CARE ABOUT START AT 59.
CC MAP INTO EXTENDED AC'S STARTING AT AB SINCE AA IS THE SAME AS % ACCUMULATOR
CC WHICH CAN'T BE REASSIGNED THIS WAY.
C	LINE(5)=CHAR(ICHAR(LINE(2))+7)
C	LINE(1)='_'
C	LINE(2)='_'
C	LINE(3)='{'
C	LINE(4)='A'
C
C WE SHOULD "KNOW" COORDS HERE DESIRED...
C THEY RUN FROM B TO Z...IMPLYING ID1=28 THRU 53
CC	II=ICHAR(LINE(5))-66+28
C	II=ICHAR(LINE(5))-38
C SCREEN OUT EXTRA JUNK THAT WOULD COME FROM HIGH FUNCT CODES...
C (DON'T BOTHER MAPPING A<Z+1> TO BA AND SO ON... ONLY 6
C KEYS IN USABLE RANGE ANYHOW...
C	IF(II.GT.52)GOTO 1200
C	III=1
C	CALL FVLDGT(II,III,IBBX)
C	IF(IBBX.EQ.0)GOTO 1200
C SKIP OVER CELLS THAT ARE EMPTY.
C
C NULL OUT REMAINDER OF THE LINE TO AVOID CONFUSION HERE.
C NOTE WE ONLY DO THIS WHERE WE SAW AN INITIAL NULL INDICATING AN
C EXTENDED FUNCTION INPUT.
C	IBBX=6
C	GOTO 1201
C1200	IBBX=1
C1201	CONTINUE
C	DO 1100 N=IBBX,132
C1100	LINE(N)=CHAR(0)
	RETURN
2000	CONTINUE
c	CLOSE(18)
	IOLVL=11
c	OPEN(18,FILE='CON:20/40/150/150/Analy Command Input')
	CLOSE(3)
CC RETRY A READ AFTER EOF...
Cc try a write to 5 to see if that'll reset the file
c	Rewind 11
c	write(11,4002)
4002	format(' *eof*')
c	Rewind 11
	Call vget(line,80)
c	READ(11,1000,END=4000,ERR=4000)LINE
c	rewind 11
	RETURN
4000	CONTINUE
CC IF WE KEEP GETTING ERRORS, JUST QUIT.
CC AT LEAST STAY AROUND. USER CAN DO @\DEV\CON
CC TO PARTLY RECOVER...
C	STOP
C TRY TO RESET TTY EOF
C *********
	RETURN
	END
c -h- gmadd.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMADD(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
C MODIFIED FOR PCCPC
	Include AParms.Inc
C      SUBROUTINE GMADD(A,B,R,N,M)
       REAL*8 A,B,R
       DIMENSION A(1),B(1),R(1)
C      NM=N*M
	IAB=(IA2-1)*MCols+IA1-1
	IBB=(IB2-1)*MCols+IB1-1
	IRB=(IR2-1)*MCols+IR1-1
      DO 10 I=1,N
      DO 10 J=1,M
	IJ=(I-1)*MCols+J
	CALL XVBLGT(IJ+IAB,0,A)
	CALL XVBLGT(IJ+IBB,0,B)
	R(1)=A(1)+B(1)
	CALL XVBLST(IJ+IRB,0,R)
10	CONTINUE
C   10 R(IJ)=A(IJ)+B(IJ)
      RETURN
      END
c -h- gmprd.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMPRD(IA1,IA2,IB1,IB2,IR1,IR2,N,M,L)
	Include AParms.Inc
C      SUBROUTINE GMPRD(A,B,R,N,M,L)
	REAL*8 A,B,R
        DIMENSION A(1),B(1),R(1)
C SPECIAL MATRIX MULTIPLY WITHIN SPREADSHEET MATRIX
	IAB=(IA2-1)*MCols+IA1-1
	IBB=(IB2-1)*MCols+IB1-1
	IRB=(IR2-1)*MCols+IR1-1
	DO 10 K=1,L
	DO 10 J=1,M
	NL=(J-1)*MCols+K
	R(1)=0.
	CALL XVBLST(IRB+NL,0,R)
	DO 10 I=1,N
	NM=(J-1)*MCols+I
	ML=(I-1)*MCols+K
	CALL XVBLGT(IAB+NM,0,A)
	CALL XVBLGT(IBB+ML,0,B)
	A(1)=A(1)*B(1)
	CALL XVBLGT(IRB+NL,0,R)
	R(1)=R(1)+A(1)
10	CALL XVBLST(IRB+NL,0,R)
C	R(NL)=R(NL)+A(NM)*B(ML)
C10	CONTINUE
      RETURN
      END
c -h- gmsub.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMSUB(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
C      SUBROUTINE GMSUB(A,B,R,N,M)
	Include AParms.Inc
	REAL*8 A,B,R
	IAB=(IA2-1)*MCols+IA1-1
	IBB=(IB2-1)*MCols+IB1-1
	IRB=(IR2-1)*MCols+IR1-1
C      NM=N*M
      DO 10 I=1,N
      DO 10 J=1,M
      IJ=(I-1)*MCols+J
	CALL XVBLGT(IAB+IJ,0,A)
	CALL XVBLGT(IBB+IJ,0,B)
	A=A-B
	CALL XVBLST(IRB+IJ,0,A)
10	CONTINUE
C   10 R(IJ)=A(IJ)-B(IJ)
      RETURN
      END
c -h- gmtx.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
     1  ID2B,RETCD)

	CHARACTER*1 LINE(80)
C REQ END MTX NAME IN 20 CHARS.
C SHOULD BE OK
	LEND=IBGN+20
C GET LOC OF MATRIX A (MUST BE SQUARE)
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 300
	IF(LINE(LSTCHR).NE.':')GOTO 300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 300
1000	RETURN
300	RETCD=3
	RETURN
	END
c -h- gn.for	Fri Aug 22 13:16:49 1986	
	SUBROUTINE GN(LAST,LEND,NUM,LINE)
	IMPLICIT InTeGer*4(A-Z)
C	PARAMETER 1=1,14=14
	DIMENSION LINE(110)
	CHARACTER*1 LINE
	EXTERNAL INDX
	CHARACTER*1 NCH
	InTeGer*4 CH,SFG
	NUM=0
	JSSF=0
	ISSF=0
	CH=0
	SFG=1
	NCH=0
	DO 1 N=LAST,LEND
	M=N
	NCH=LINE(N)
	CH=ICHAR(NCH)
	IF(CH.EQ.0)GOTO 2
	IF(CH.EQ.45)SFG=-1
C SFG=SIGN FLAG
C 43 IS ASCII FOR +; 45 IS ASCII FOR - SIGN.
C IGNORE + SIGNS
	IF(CH.GT.32)ISSF=ISSF+1
	IF(ISSF.EQ.0.AND.CH.EQ.32)GOTO 1
C IGNORE SPACES TOO, PROVIDED THEY ARE LEADING SPACES.
C (OTHERS MAY BE DELIMITERS.)
	IF(CH.EQ.43.OR.CH.EQ.45)JSSF=JSSF+1
	IF(JSSF.GT.1.AND.(CH.EQ.43.OR.CH.EQ.45))GOTO 2
C IF WE HAVEN'T SEEN A +/- PROCESS IT HERE.
	IF(CH.EQ.43)GOTO 1
	IF(CH.EQ.45)GOTO 1
	IF(CH.LT.48.OR.CH.GT.57)GOTO 2
C TERMINATE ON ANY NON NUMERIC. SHOULD ALLOW TERMINATE ON SECOND #.
	IF(NUM.LT.3100)NUM=10*NUM+(CH-48)
1	CONTINUE
C NEXT LINE WAS MAX0...
2	LAST=MIN0(M,LEND)
	NUM=NUM*SFG
C ACCOUNTED FOR SIGN; NOW RETURN
	RETURN
	END
c -h- gtmung.for	Fri Aug 22 13:17:12 1986	
	SUBROUTINE GTMUNG(LINE)
	Include AParms.inc
	CHARACTER*1 LINE(132)
	InTeGer*4 IMODE
	CHARACTER*1 C2
	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,MRows)
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
CCC	COMMON/MODPUB/MODPUB,LIMODE
	DATA IMODE/0/
C HANDLE EXTRA MODE PARSING...DEFAULT,TO AVOID ENTER CMD IF NOT NEEDED.
	I=ICHAR(LINE(1))
	IF(I.LT.34.OR.I.GT.122)GOTO 6000
	IF(I.EQ.42)GOTO 6000
C ASSUME OTHER REASONABLE CHARS ARE CMDS
	IF(I.GT.34.AND.I.LT.40)GOTO 6000
	IF(I.EQ.95)GOTO 6000
	IF(I.GE.58.AND.I.LE.64)GOTO 6000
	IF(LINE(1).NE.'/')GOTO 100
	IF(LINE(2).NE.'/')GOTO 110
C SETUP OLD MODE WITH //
	IMODE=0
	GOTO 900
110	CONTINUE
	IF(LINE(2).NE.';')GOTO 120
C SETUP NEW MODE WITH /;
	IMODE=1
	GOTO 900
120	CONTINUE
	IF(LINE(2).NE.'#')GOTO 124
C SWAP OLD, CURRENT MODES
C USE IN CMD FILES SO /# SWAPS MODES, THEN // SETS OLD MODE,
C THEN /# SWAPS BACK
C (THAT WAY, USER'S MODE DOESN'T CHANGE.)
	I=LIMODE
	LIMODE=IMODE
	IMODE=I
	GOTO 900
124	CONTINUE
	IF(IMODE.EQ.0)GOTO 6000
C IF WE JUST SAW /COMMAND, MUNGE OUT THE INITIAL /
	DO 130 I=1,131
130	LINE(I)=LINE(I+1)
	GOTO 6000
100	CONTINUE
	IF(IMODE.EQ.0)GOTO 6000
C INPUT DIDN'T START WITH / SO TRY AND MAKE UP AN ENTER
	IF(LINE(2).EQ.'&')GOTO 6000
C 1& 2& ETC WORK STILL AS CURSOR CONTROLS
	C2='N'
	IF(LINE(1).EQ.'"')C2='"'
C	IF(LINE(1).GE.'0'.AND.LINE(1).LE.'9')C2='V'
	IF(LINE(1).LT.'0'.OR.LINE(1).GT.'9')GOTO 170
C INITIAL CHAR IS A DIGIT. IF 2ND CHAR IS ALSO A DIGIT OR
C SOMETHING REASONABLE THEN TREAT AS "EV" CMD. OTHERWISE
C JUST PASS AS A COMMAND SO CURSOR CTLS WORK STILL.
	IF(LINE(2).LE.' ')GOTO 6000
C ALLOW DIGIT FOLLOWED BY SPACE OR C.R. TO BE JUST CURSOR MOVE
	C2='V'
170	CONTINUE
C MOVE DOWN PAST 'EV'
	II=3
C ALLOW US TO REMOVE INITIAL " IN E" CASE...
	IF(C2.EQ.'"')II=2
	DO 150 I=1,129
	M=133-I
	MM=M-II
150	LINE(M)=LINE(MM)
	LINE(1)='E'
	LINE(2)=C2
	LINE(3)=' '
	GOTO 6000
900	LINE(1)='*'
C MAKE COMMENT, THEN GO
6000	CONTINUE
C MAINTAIN MODE FOR REST OF WORLD
	MODPUB=IMODE
	RETURN
	END
c -h- gtprd.for	Fri Aug 22 13:17:12 1986	
	SUBROUTINE GTPRD(IA1,IA2,IB1,IB2,IR1,IR2,N,M,L)
	Include Aparms.inc
	REAL*8 A,B,R
      DIMENSION A(1),B(1),R(1)
C SPECIAL MATRIX MULTIPLY WITHIN SPREADSHEET MATRIX
	IAB=(IA2-1)*MCols+IA1-1
	IBB=(IB2-1)*MCols+IB1-1
	IRB=(IR2-1)*MCols+IR1-1
	DO 10 K=1,L
	DO 10 J=1,M
	NL=(J-1)*MCols+K
	R(1)=0.
	CALL XVBLST(NL+IRB,0,R)
	DO 10 I=1,N
C INVERT ROW/COLUMN USE FOR MATRIX A
	NM=(I-1)*MCols+J
	ML=(I-1)*MCols+K
	CALL XVBLGT(IAB+NM,0,A)
	CALL XVBLGT(IBB+ML,0,B)
	A(1)=A(1)*B(1)
	CALL XVBLGT(IRB+NL,0,R)
	R(1)=R(1)+A(1)
	CALL XVBLST(IRB+NL,0,R)
C	R(NL)=R(NL)+A(NM)*B(ML)
10	CONTINUE
      RETURN
      END
c -h- index.fdd	Fri Aug 22 13:20:45 1986	
      INTEGER FUNCTION INDX ( STR, C )
C
	INTEGER*4 C
      CHARACTER * 1 STR ( 1 )
C
C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
	I3B=0
      DO 20019  I = 1, 256
      IF (ICHAR(STR(I)).NE.0) GOTO 20021
C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR 0
      INDX=0
      RETURN
20021 CONTINUE
	IF(ICHAR(STR(I)).EQ.255)I3B=3
	IF(I3B.LE.0)GOTO 2000
C SKIP ENCODED VARIABLES
	I3B=I3B-1
	GOTO 20019
2000	CONTINUE
      IF (.NOT.( STR ( I ) .EQ. CHAR(C) )) GOTO 20023
	ix=i
	if(i.gt.250)ix=0
      INDX = ( IX )
      RETURN
20023 CONTINUE
20022 CONTINUE
C
20019 CONTINUE
20020 CONTINUE
	INDX=255
	RETURN
      END
c -h- in2as.for	Fri Aug 22 13:21:02 1986	
	SUBROUTINE IN2AS(ROW,CHRS)
	InTeGer*4 ROW
	CHARACTER*1 CHRS(4)
	INTEGER*4 AC,AC1,AC2
	DO 1 N1=1,4
1	CHRS(N1)=CHAR(32)
C CONVERT ROW TO LETTERS. ASSUMES COL=2 OR MORE. ROW 1=A-Z
C ROW 2=AA-AZ, THEN BA-BZ ETC.
	AC=ROW
	DO 2 N=1,4
	M=5-N
C CONVERT BACKWARDS INTO CHRS
	AC1=(AC/26)
	AC2=AC1*26
	IX=AC-AC2
	IF(.NOT.(IX.EQ.0.AND.AC1.GT.0))GOTO 772
C CORRECT SO WE GET Z, NOT A<NULL> FOR LABELS.
	IX=26
	AC1=AC1-1
772	CONTINUE
	IF(IX.GT.0)CHRS(M)=CHAR(IX+64)
C CONVERT TO ASCII A-Z CHARACTER
	AC=AC1
2	CONTINUE
C JUST IGNORE ANY OVERFLOW.
	RETURN
	END
c -h- indxq.for	Fri Aug 22 13:21:14 1986	
      INTEGER FUNCTION INDXQ ( STR, C )
C
	INTEGER*4 C
      CHARACTER * 1 STR ( 1 )
C
C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
	I3B=0
      DO 20019  I = 1, 256
      IF (ICHAR(STR(I)).NE.0) GOTO 20021
C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR OF THE
C END OF THE STRING FOR ANALYTICALC. NOTE THAT THIS DIFFERS
C FROM USUAL RATFOR VERSION.
      INDXQ=I
      RETURN
20021 CONTINUE
	IF(ICHAR(STR(I)).EQ.255)I3B=3
	IF(I3B.LE.0)GOTO 2000
C SKIP ENCODED VARIABLES
	I3B=I3B-1
	GOTO 20019
2000	CONTINUE
      IF (.NOT.( STR ( I ) .EQ. CHAR(C) )) GOTO 20023
      INDXQ = ( I )
      RETURN
20023 CONTINUE
20022 CONTINUE
C
20019 CONTINUE
20020 CONTINUE
	INDXQ=0
	RETURN
      END
c -h- inpost.for	Fri Aug 22 13:21:23 1986	
	SUBROUTINE INPOST (RETCD)
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  INPOST                  *
C *                                                *
C **************************************************
C
C
C  CONVERTS THE INPUT STRING (INFIX NOTATION) TO POSTFIX
C  FOR LATER EVALUATION BY POSTVL
C
C
C
C  MODIFICATION CODES:  M3,M10
C
C
C MODIFIED 10-MAR-78 P.B. CHANGED STACK VALUE FOR FUNCTIONS FROM 15 TO 45
C   THIS CORRECTS IMPROPER EVALUATION OF SQRT(1.)-2.
C
C
C
C
C INPOST CALLS
C
C  ERRMSG   PRINTS ERROR MESSAGES
C  NEXTEL   GETS THE NEXT ELEMENT FROM LINE(80)
C
C
C
C INPOST IS CALLED BY CALC
C
C
C
C
C
C
C        THE VARIABLE AND FUNCTION CODES.
C TABLE ALSO GIVES COMPARE VALUES AND STACK VALUES OF
C FUNCTIONS THAT OCCUR WHEN EXPRESSIONS ARE EVALUATED.
C
C
C
C
C	STACK
C	ELEMENT				COMPARE	STACK
C	CODE	TYPE		BYTES	VALUE	VALUE
C
C	0	UNDEFINED	-	-	-
C	1	ASCII		1	-	-
C	2	DECIMAL		8	-	-
C	3	HEXADECIMAL	4	-	-
C	4	INTEGER		4	-	-
C	5	MULT.PREC.(10)	20	-	-
C	6	MULT.PREC.(8)	20	-	-
C	7	MULT.PREC.(16)	20	-	-
C	8	OCTAL		4	-
C	9	REAL		8	-	-
C	10-30	UNDEFINED	-	-	-
C
C	----------FUNCTIONS------------
C
C	31	ABS (=DABS)	-	70	45
C	32	IABS		-	70	45
C	33	FLOAT		-	70	45
C	34	IFIX		-	70	45
C	35	AINT		-	70	45
C	36	INT (=IDINT)	-	70	45
C	37	EXP (=DEXP)	-	70	45
C	38	ALOG (=DLOG)	-	70	45
C	39	ALOG10(=DLOG10)	-	70	45
C	40	SQRT (=DSQRT)	-	70	45
C	41	SIN (=DSIN)	-	70	45
C	42	COS (=DCOS)	-	70	45
C	43	TANH (=DTANH)	-	70	45
C	44	ATAN (=DATAN)	-	70	45
C	45-47	ASIN,ACOS,TAN	-	70	45
C	45	RESERVED	-	-	-
C       48-100  RESERVED        -       -       -
C
C       110     (               -       70      15
C       111     UNARY -         -       50      49
C       112     **              -       40      39
C       113     *               -       30      31
C       114     /               -       30      31
C       115     +               -       20      21
C       116     -               -       20      21
C       117     )               -       10      -
C
C       200     =               -       10      10
C
C
C
C    VARIABLE      USE
C
C    I,K          HOLDS TEMPORARY InTeGer*4 VALUES.
C    LASTOP       HOLDS THE TYPE OF LAST ELEMENT OBTAINED
C                 ON LINE(80). SET AT 0 AT BEGINNING OF EXPRESSION.
C                 USED BY NEXTEL TO IDENTIFY UNARY OPERATORS.
C    NONBLK       POINTER IN LINE(80). NEXTEL STARTS SCAN AT NONBLK+1.
C    OPVAL(200,2)   HOLDS THE COMPARE AND STACK VALUE OF EACH OPERATOR.
C    PARVAL       HOLDS 110 WHICH IS THE CODE FOR '(' IN STACK 2.
C    RETCD        RETURN CODE. 1=O.K.  2=ERROR.
C    RETCD2       RETURN CODE FOR CALL TO NEXTEL.
C    RETTYP       HOLDS TYPE OF NEXT ELEMENT IN LINE, EITHER A FUNCTION
C                 CODE OR A DATA TYPE CODE.
C    RETVAL(100)  HOLDS VALUE OF NEXT ELEMENT IN LINE(80).
C    ST1LIM       HOLDS LIMIT OF STACK 1.
C    ST2LIM       HOLDS LIMIT OF STACK 2.
C    ST1PT        STACK 1 POINTER.
C    ST2PT        STACK 2 POINTER.
C    ST1TYP       TYPE OF EACH ELEMENT IN STACK 1
C    ST2TYP       TYPE OF EACH ELEMENT IN STACK 2
C    VLEN         HOLDS THE NUMBER OF BYTES USED BY EACH DATA TYPE.
C
C
C
C
C	SUBROUTINE INPOST (RETCD)
C
C
C
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 LASTOP
	InTeGer*4 VIEWSW,BASED
	InTeGer*4 OPVAL(200,2),PARVAL
	InTeGer*4 RETCD,RETCD2,RETTYP
	InTeGer*4 TYPE(1,1)
	InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT
	InTeGer*4 ST1LIM,ST2LIM
	InTeGer*4 VLEN(9)
	InTeGer*4 I,K
C
	CHARACTER*1 LINE(80)
	CHARACTER*1 AVBLS(20,27),RETVAL(20)
	CHARACTER*1 VBLS(8,1,1)
	CHARACTER*1 STACK1(8,40),STACK2(8,40)
C
C
	COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     1  ST1LIM,ST2LIM
	COMMON /V/TYPE,AVBLS,VBLS,VLEN
	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
c	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
CCC	COMMON /ERROR/ LASTOP
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
	DATA OPVAL/30*-1,17*70,62*-1,70,50,40,30,30,20,20,10,82*-1,10,
     1             30*-1,17*45,62*-1,15,49,39,31,31,21,21,-1,82*-1,10/
	DATA PARVAL/110/
C
C
C
C
C
C  INITIALIZE STACKS, RETURN CODE DEFAULT, AND LASTOP
	RETCD=1
	ST1PT=1
	ST2PT=1
	LASTOP=0
C
C SET UP FOR NEXTEL CALL
	NONBLK=NONBLK-1
C
C
C
C
C **************************************************
C ***** GET NEXT ELEMENT OF EXPRESSION *************
C **************************************************
C
C
C
C  NEXTEL RETURNS
C	1	IF OPERAND
C	2	IF OPERATOR (VALUE IN RETTYP)
C	3	IF NO MORE ELEMENTS
C	4	IF ERROR
C
C
50	CALL NEXTEL (RETVAL,RETTYP,RETCD2)
	GOTO (100,200,300,999),RETCD2
	STOP 50
C
C
C
C
C
C **************************************************
C ********  OPERAND FOUND, PUT ON STACK 1  *********
C **************************************************
C
C STACK 1 OVERFLOW CHECK
100	IF (ST1PT.GT.ST1LIM) GOTO 990
C
C
C
C
C
109	CONTINUE
C
C  SUBROUTINE ERRCX HAS ALREADY ASSURED THAT
C  IF AN OPERAND IS FOLLOWED BY AN = SIGN, THAT VARIABLE
C  IS NOT PART OF AN EXPRESSION.
C
C  VARIABLE INDEX IS TO BE PLACED IN STACK1 (1,ST1PT)
C  SO IF YOU WANTED TO SPEED THE OPERATION AT THE EXPENSE
C  OF SPACE, YOU WOULD ONLY COPY RETVAL(1) IF RETTYP < 0
	K=VLEN(IABS(RETTYP))
	DO 110 I=1,K
110	STACK1(I,ST1PT)=RETVAL(I)
	ST1TYP(ST1PT)=RETTYP
	ST1PT=ST1PT+1
	GOTO 50
C
C
C
C
C
C
C
C
C **************************************************
C *****************  OPERATOR  *********************
C **************************************************
C
200	CONTINUE
C
C IF NO OTHER OPERATOR ON STACK 2, PLACE ON STACK 2
	IF (ST2PT.EQ.1) GOTO 222
C
C
C COMPARE VALUE WITH OPERATOR IN STACK2, IF GREATER OR EQUAL THEN
C PLACE IN STACK 2 BECAUSE IT HAS HIGHER PRECEDENCE AND IS ASSOCIATED
C WITH PREVIOUSLY ENCOUNTERED OPERAND, IS A UNARY OPERATOR ASSOCIATED
C WITH THE FOLLOWING ELEMENT, OR IS A '(' WHICH IS SAVED UNTIL A ')'
C IS FOUND.
C
	K=ST2TYP(ST2PT-1)
	IF (OPVAL(RETTYP,1).GE.OPVAL(K,2)) GOTO 220
C
C
C IF POPPING OFF ELEMENTS FROM STACK2 BECAUSE ')' WAS FOUND THEN WHEN
C ')' IS FOUND WE GO TO 230 TO REMOVE THE OPERATOR '(' FROM STACK 2.
C
	IF (PARVAL.EQ.K) GOTO 230
	IF (ST1PT.GT.ST1LIM) GOTO 990
C
C
C
C OPERATOR ON STACK 2 GOES ONTO STACK 1.
C
	ST1TYP(ST1PT)=K
	ST1PT=ST1PT+1
	ST2PT=ST2PT-1
	GOTO 200
C
C
C  PUT OPERATOR ON STACK 2
220	IF (ST2PT.GT.ST2LIM) GOTO 992
222	ST2TYP(ST2PT)=RETTYP
	ST2PT=ST2PT+1
	GOTO 50
C
C
C REMOVE '(' FROM STACK 2
230	ST2PT=ST2PT-1
	GOTO 50
C
C
C
C
C
C **************************************************
C ******* NO MORE ELEMENTS IN LINE *****************
C **************************************************
C
C CLEAN OFF STACK 2
300	IF (ST2PT.EQ.1) GOTO 1000
C
C IF A '(' GO TO 350 TO THROW IT AWAY.
	IF (ST2TYP(ST2PT-1).EQ.PARVAL) GOTO 350
	IF (ST1PT.GT.ST1LIM) GOTO 990
C
C
C
C PLACE ELEMENT ON STACK 2 ONTO STACK 1.
C
	ST1TYP(ST1PT)=ST2TYP(ST2PT-1)
	ST1PT=ST1PT+1
C
C THROW AWAY '(' FROM STACK 2.
350	ST2PT=ST2PT-1
	GOTO 300
C
C
C
C
C *** ERROR HANDLING ***
C
C STACK 1 OVERFLOW
990	I=7
	GO TO 998
C
C STACK 2 OVERFLOW
992	I=9
C
C
998	CALL ERRMSG(I)
999	RETCD=2
1000	RETURN
C
	END
c -h- isgn.for	Fri Aug 22 13:21:52 1986	
      INTEGER FUNCTION ISGN(IARG)
      InTeGer*4 IARG
      IF(IARG.EQ.0)ISGN=0
      IF(IARG.GT.0)ISGN=1
      IF(IARG.LT.0)ISGN=-1
      RETURN
      END
c -h- jchar.for	Fri Aug 22 13:22:15 1986	
	INTEGER FUNCTION JCHAR(CHR)
	CHARACTER*1 CHR
c	INTEGER*1 ICH
C RETURN INTEGER VALUE OF CHARACTER AS IF IT WERE A SIGNED
C INTEGER BETWEEN -128 AND +127
	INTEGER*4 I
c	EQUIVALENCE(CHR,ICH)
	I=ICHAR(CHR)
c	I=ICH
	IF(I.GT.127)I=I-256
	JCHAR=I
	RETURN
	END
c -h- jmod.for	Fri Aug 22 13:22:15 1986	
C INTEGER*4 MODULO FUNCTION
	INTEGER*4 FUNCTION JMOD(I1,I2)
	INTEGER*4 I1,I2,I
	I=MOD(I1,I2)
	JMOD=I
	RETURN
	END
c -h- julasc.for	Fri Aug 22 13:22:15 1986	
	SUBROUTINE JULASC(N,DATST,IYR,IMO,IDA)
C CONVERT JULIAN DATE N INTO ASCII STRING STR
	INTEGER*4 DATST(2),DAT(2)
	CHARACTER*1 DATSTR(8)
	CHARACTER*2 YRST(1),MOST(1),DAST(1)
	EQUIVALENCE(YRST(1)(1:1),DATSTR(1)),
     1  (MOST(1)(1:1),DATSTR(4))
	EQUIVALENCE(DAT(1),DATSTR(1))
	EQUIVALENCE(DAST(1)(1:1),DATSTR(7))
	InTeGer*4 MLEN(12)
	DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/
	DATSTR(3)='/'
	DATSTR(6)='/'
C FIRST SUBTRACT OFF WHOLE YEARS
	IYR=N/365
	N=N-(365*IYR)
C ADJUST FOR LEAP YRS SINCE 1981
	IAC=IYR/4
	N=N-IAC
C Account for when this year is a leap year
	MLEN(2)=28
	IF(Mod((IYR+81),4).eq.0) MLEN(2)=29
c (OK for rest of 20th century, anyhow.)
C (Also OK in 21st, since 2000 IS a leap year (divisible by 400))
C NOW SUBTRACT OFF MONTHS AS LONG AS POSSIBLE
	DO 1 NN=1,12
	IMO=NN
	IF(N.LE.MLEN(NN))GOTO 2
	N=N-MLEN(NN)
1	CONTINUE
2	CONTINUE
	IDA=N
	IYR=IYR+81
	WRITE(YRST(1)(1:2),3,ERR=5)IYR
C	ENCODE(2,3,YRST,ERR=5)IYR
3	FORMAT(I2)
	WRITE(MOST(1)(1:2),3,ERR=5)IMO
C	ENCODE(2,3,MOST,ERR=5)IMO
	WRITE(DAST(1)(1:2),3,ERR=5)IDA
C	ENCODE(2,3,DAST,ERR=5)IDA
5	CONTINUE
	IF(DATSTR(1).EQ.' ')DATSTR(1)='0'
	IF(DATSTR(4).EQ.' ')DATSTR(4)='0'
	IF(DATSTR(7).EQ.' ')DATSTR(7)='0'
	DATST(1)=DAT(1)
	DATST(2)=DAT(2)
C USE INTEGERS SINCE REAL*8 MIGHT OMIT FULL COPY IF
C EXPONENT BYTE IS 0, AND CHARS MAY CAUSE NORMALIZATION
C PROBLEMS SOMETIMES.
	RETURN
	END
c -h- julian.for	Fri Aug 22 13:22:15 1986	
C JULIAN DATE ROUTINES
C CALLS:
C	N=JULIAN(YY/MM/DD)
C	RETURNS JULIAN DATE BASED ON 1/1/80 FOR THAT DATE
C
C	CALL JULASC(N,STRADR)
C	TAKES JULIAN DATE AND DECODES TO ASCII YY/MM/DD
C
C	N=JULMDY(IYR,IMO,IDA)
C	RETURNS JULIAN DATE GIVEN SEPARATE Y,M,D
C
	FUNCTION JULIAN(DATST)
	INTEGER*4 DATST(2),DAT(2)
	CHARACTER*1 DATSTR(8)

	CHARACTER*1 YRST(2),MOST(2),DAST(2)
	CHARACTER*2 YRST2,MOST2,DAST2
	EQUIVALENCE(YRST2(1:1),YRST(1),DATSTR(1),DAT(1)),
     1  (MOST2(1:1),MOST(1),DATSTR(4)),
     2  (DAST2(1:1),DAST(1),DATSTR(7))
C	EQUIVALENCE(DATSTR(1),DAT(1))
C	EQUIVALENCE(YRST(1),DATSTR(1)),(MOST(1),DATSTR(4))
C	EQUIVALENCE(DAST(1),DATSTR(7))
	DAT(1)=DATST(1)
	DAT(2)=DATST(2)
	IJUL=1
	READ(YRST2(1:2),1,ERR=2)IYR
C	DECODE(2,1,YRST,ERR=2)IYR
1	FORMAT(I2)
	READ(MOST2(1:2),1,ERR=2)IMO
	READ(DAST2(1:2),1,ERR=2)IDA
C	DECODE(2,1,MOST,ERR=2)IMO
C	DECODE(2,1,DAST,ERR=2)IDA
	IJUL=JULMDY(IYR,IMO,IDA)
2	CONTINUE
	JULIAN=IJUL
	RETURN
	END
c -h- julmdy.for	Fri Aug 22 13:22:15 1986	
	FUNCTION JULMDY(IYR,IMO,IDA)
	InTeGer*4 MLEN(12)
	DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/
C JULIAN DATE FROM Y,M,D
C BASE=1/1/81
	IJUL=1
	IF(IYR.LT.80)GOTO 999
	IYR=IYR-81
	IF(IMO.LE.0.OR.IMO.GT.12)GOTO 999
	IF(IDA.GT.31)GOTO 999
C JUST RETURN ILLEGAL ENTRIES AS 1/1/80
	AC=365.25*FLOAT(IYR)
	IAC=AC
C SLIGHTLY CRUDE BUT WORKABLE TREATMENT OF YEARS
	IJUL=IJUL+IAC
C NOW ADD IN MONTHS.
	IF(IMO.GT.2.AND.MOD(IYR+1,4).EQ.0)IJUL=IJUL+1
C ABOVE ACCOUNTS FOR LEAP YEARS
	III=IMO-1
	IF(III.LE.0)GOTO 22
	DO 2 N=1,III
2	IJUL=IJUL+MLEN(N)
22	CONTINUE
C NEXT DO DAYS
	IJUL=IJUL+IDA-1
C JUST ADD IN DAYS. SHOULD BE GOOD ENOUGH.
999	CONTINUE
	JULMDY=IJUL
	RETURN
	END
c -h- jvblgt.for	Fri Aug 22 13:22:15 1986	
        SUBROUTINE JVBLGT(ID1,ID2,ID3,IVAL)
C
C JVBLGT - GET INTEGER*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY
C  DIMENSIONED (2,60,301). HANDLE BY CALLING XVBLGT TO GET
C  CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE
        InTeGer*4 ID1,ID2,ID3
        INTEGER*4 IVAL,LL(2)
        REAL*8 XX
        EQUIVALENCE(LL(1),XX)
        CALL XVBLGT(ID2,ID3,XX)
        IVAL=LL(ID1)
        RETURN
        END
c -h- jvblst.for	Fri Aug 22 13:22:15 1986	
        SUBROUTINE JVBLST(ID1,ID2,ID3,IVAL)
C JVBLST - SET I*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY
C  DIMENSIONED (2,60,301). HANDLE BY CALLING XVBLST TO GET
C  CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE
        InTeGer*4 ID1,ID2,ID3
        INTEGER*4 IVAL,LL(2)
        REAL*8 XX
        EQUIVALENCE(LL(1),XX)
C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONES 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- mdet.for	Fri Aug 22 13:25:39 1986	
	SUBROUTINE MDET(XVBLS,I1,I2,J1,J2,DET)
	Include Aparms.inc
	REAL*8 XVBLS(1),DET,SUMA,SUMB
C NOTE XVBLS IS 60 BY 301 MATRIX IN PORTACALC
C I1,I2 ARE TOP COL,ROW COORD; J1,J2 ARE BOTTOM
C STORAGE OF XVBLS IS (COL,ROW) SO LOCATIONS INSIDE
C IT ARE
C  ADDR=(ROW-1)*60+COL (60 IS # OF COLS)
	DET=0.
	N=J1-I1+1
	M=J2-I2+1
	IF(N.NE.M)RETURN
	IF(N.LE.1)RETURN
C ONLY SQUARE MATRICES MAY HAVE NONZERO DETERMINANTS
C ALSO, DIMENSION HAS TO BE > 1
	NN=N
C  FIXUP... (OK FOR N=2,3 ANYHOW)
	IF(N.EQ.2)NN=N-1
C  SUM OVER DIAGS...
C MULTIPLY DIAGONALS FROM TOP AND BOTTOM ROWS OF MATRIX AND GET
C DIFFERENCE EACH TIME FOR ACCURACY
	DO 1 N1=1,NN
	SUMA=1.
	SUMB=1.
	DO 2 N2=1,N
	NCL=N1+N2-1
	N2L=N+1-N2
	IF(NCL.GT.N)NCL=NCL-N
C NOW MULTIPLY SUMA (POSITIVE TERMS) BY X(NCL,N2) AND SUMB(NEG TERMS)
C BY X(NCL,N2L)
	LA=(N2-2+I2)*MCols+I1+NCL-1
	LB=(N2L-2+I2)*MCols+I1+NCL-1
	CALL XVBLGT(LA,0,XVBLS(1))
	SUMA=SUMA*XVBLS(1)
	CALL XVBLGT(LB,0,XVBLS(1))
	SUMB=SUMB*XVBLS(1)
2	CONTINUE
C NOW ACCUMULATE TERMS IN DETERMINANT
	DET=DET+SUMA-SUMB
C DO IN THIS ORDER TO AVOID EXCESSIVE LOSS OF PRECISION DUE TO
C DIFFERENCES OF LARGE TERMS. THIS IS BAD ENOUGH AS IT IS...
1	CONTINUE
	RETURN
	END
c -h- mthini.for	Fri Aug 22 13:25:45 1986	
	SUBROUTINE MTHINI(INDEXF,AC,SS,CTR,ACX)
	DIMENSION EP(20)
	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
CCC	REAL*8 EP,PV,FV
CCC	COMMON/ERNPER/EP,PV,FV,KIRR
	REAL*8 AC,SS,CTR,ACX
	KIRR=0
	SS=0.
	CTR=0.
	ACX=0.
	DO 1 N=1,20
1	EP(N)=0.
	AC=0.
	IF(INDEXF.EQ.1)AC=1.E20
	IF(INDEXF.EQ.2)AC=-1.E20
	RETURN
	END
c -h- mtxequ.for	Fri Aug 22 13:25:54 1986	
       SUBROUTINE MTXEQU(A1,A2,B1,B2,N,M,D)
	Include AParms.inc
C A1,A2 ARE DIMENSIONS OF A SUBMATRIX ORIGIN IN XVBLS
C B1,B2 ARE DIMS OF B SUBMATRIX
C
C NOTE THIS PROGRAM MUST BE MODIFIED TO WORK WITHIN THE SPREAD
C SHEET MATRIX RATHER THAN JUST ASSUMING THAT THE N DIMENSION
C AND M DIMENSION GIVE THE STORAGE ADDRESSES... ALTERNATIVELY,
C THE PROGRAM MUST OPERATE ONLY ON COPIED, DENSELY STORED
C MATRICES.
C
C
C   ORIGINAL PROGRAM TEXT FOLLOWS:
C       DIMENSION A(1),B(1)
CC ALTER DECLARATIONS FOR USE WITH SPREAD SHEET
C	REAL*8 A,B
C       KMAX=N-1
C       DO 90 K=1,KMAX
C       AMAX=0.
C       J2=K
C       DO 20 J1=K,N
C       IK=(J1-1)*N+K
C       IF(ABS(AMAX)-ABS(A(IK)))10,20,20
C10       AMAX=A(IK)
C       J2=J1
C20       CONTINUE
CC       EXCHANGE ROW K,J2 IF NECESSARY
C       IF(J2-K)30,60,30
C30       DO 40 J=K,N
C       J3=(K-1)*N+J
C       J4=(J2-1)*N+J
C       SAVE=A(J3)
C       A(J3)=A(J4)
C       A(J4)=SAVE
C40       CONTINUE
C       DO 50 J=1,M
C       J3=(K-1)*M+J
C       J4=(J2-1)*M+J
C       SAVE=B(J3)
C       B(J3)=B(J4)
C50       B(J4)=SAVE
CC       REDUCTION
C60       K1=K+1
C       KK=(K-1)*N+K
C       DO 80 I=K1,N
C       IK=(I-1)*N+K
C       DO 70 J=K1,N
C       IJ=(I-1)*M+J
C       KJ=(K-1)*M+J

C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
C       DO 80 J=1,M
C       IJ=(I-1)*M+J
C       KJ=(K-1)*N+J
C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
C90       CONTINUE
CC       SUBSTITUTE BACK
CC       NN=(N-1)*N+N
C       NN=N*N
C       DO 110 J=1,M
C       NJ=(N-1)*M+J
C       B(NJ)=B(NJ)/A(NN)
C       I1MAX=N-1
C       IF(I1MAX)110,110,95
C95       DO 111 I1=1,I1MAX
C       I=N-I1
C       IJ=(I-1)*M+J
C       II=(I-1)*N+I
C       I2=I+1
C       DO 100 L=I2,N
C       IL=(I-1)*N+L
C       LJ=(L-1)*M+J
C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
C       B(IJ)=B(IJ)/A(II)
C111       CONTINUE
C110       CONTINUE
C       RETURN
C       END
	INTEGER A1,A2,B1,B2
C       DIMENSION A(1),B(1)
C ALTER DECLARATIONS FOR USE WITH SPREAD SHEET
C NOTE THAT OUR COLUMN DIMENSION IS 60, NOT N OR M HERE
C SUBSCRIPTS ARE (ROW-1)*COL-DIMENSION + COL
C  THEREFORE, CHANGE *N OR *M IN SUBSCRIPT COMPUTATIONS TO
C  *60
	REAL*8 A,B,AW1,AW2,BW1,BW2,AW3,AW4,AMAX
	INTEGER ABASE,BBASE
	ABASE=(A2-1)*MCols+A1-1
	BBASE=(B2-1)*MCols+B1-1
	D=1.
       KMAX=N-1
       DO 90 K=1,KMAX
       AMAX=0.
       J2=K
       DO 20 J1=K,N
       IK=(J1-1)*MCols+K
	CALL XVBLGT(IK+ABASE,0,A)
       IF(DABS(AMAX)-DABS(A))10,20,20
10       AMAX=A
       J2=J1
20       CONTINUE
C       EXCHANGE ROW K,J2 IF NECESSARY
       IF(J2-K)30,60,30
30       DO 40 J=K,N
       J3=(K-1)*MCols+J
       J4=(J2-1)*MCols+J
	CALL XVBLGT(J3+ABASE,0,SAVE)
C       SAVE=A(J3)
	CALL XVBLGT(J4+ABASE,0,AW1)
	CALL XVBLST(J3+ABASE,0,AW1)
	CALL XVBLST(J4+ABASE,0,SAVE)
C       A(J3)=A(J4)
C       A(J4)=SAVE
40       CONTINUE
       DO 50 J=1,M
       J3=(K-1)*MCols+J
       J4=(J2-1)*MCols+J
C       SAVE=B(J3)
C       B(J3)=B(J4)
C50       B(J4)=SAVE
	CALL XVBLGT(J3+BBASE,0,SAVE)
	CALL XVBLGT(J4+BBASE,0,BW1)
	CALL XVBLST(J3+BBASE,0,BW1)
	CALL XVBLST(J4+BBASE,0,SAVE)
50	CONTINUE
C       REDUCTION
60       K1=K+1
       KK=(K-1)*MCols+K
	CALL XVBLGT(KK+ABASE,0,A)
	IF(A.EQ.0)GOTO 999
C	IF(A(KK).EQ.0.)GOTO 999
       DO 80 I=K1,N
       IK=(I-1)*MCols+K
       DO 70 J=K1,N
       IJ=(I-1)*MCols+J
       KJ=(K-1)*MCols+J
C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
	CALL XVBLGT(IJ+ABASE,0,AW1)
	CALL XVBLGT(KJ+ABASE,0,AW2)
	CALL XVBLGT(IK+ABASE,0,AW3)
	CALL XVBLGT(KK+ABASE,0,AW4)
	AW1=AW1-AW2*AW3/AW4
	CALL XVBLST(IJ+ABASE,0,AW1)
70	CONTINUE
       DO 80 J=1,M
       IJ=(I-1)*MCols+J
       KJ=(K-1)*MCols+J
C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
	CALL XVBLGT(IJ+BBASE,0,BW1)
	CALL XVBLGT(KJ+BBASE,0,BW2)
	BW1=BW1-BW2*AW3/AW4
	CALL XVBLST(IJ+BBASE,0,BW1)
80	CONTINUE
90       CONTINUE
C       SUBSTITUTE BACK
       NN=(N-1)*MCols+N
C       NN=N*N
	CALL XVBLGT(NN+ABASE,0,AW1)
	IF(AW1.EQ.0.)GOTO 999
       DO 110 J=1,M
       NJ=(N-1)*MCols+J
C       B(NJ)=B(NJ)/A(NN)
	CALL XVBLGT(NJ+BBASE,0,BW1)
	BW1=BW1/AW1
	CALL XVBLST(NJ+BBASE,0,BW1)
       I1MAX=N-1
       IF(I1MAX)110,110,95
95       DO 111 I1=1,I1MAX
       I=N-I1
       IJ=(I-1)*MCols+J
       II=(I-1)*MCols+I
       I2=I+1
	CALL XVBLGT(II+ABASE,0,AW1)
       DO 100 L=I2,N
       IL=(I-1)*MCols+L
       LJ=(L-1)*MCols+J
C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
	CALL XVBLGT(IJ+BBASE,0,BW1)
	CALL XVBLGT(IL+ABASE,0,AW2)
	CALL XVBLGT(LJ+BBASE,0,BW2)
	BW1=BW1-AW2*BW2
	CALL XVBLST(IJ+BBASE,0,BW1)
100	CONTINUE
C       B(IJ)=B(IJ)/A(II)
	BW1=BW1/AW1
	CALL XVBLST(IJ+BBASE,0,BW1)
111       CONTINUE
110       CONTINUE
       RETURN
999	CONTINUE
	D=0.
	RETURN
       END
C *********************  AnalyF6.Ftn ###################################
c -h- varscn.for	Fri Aug 22 13:37:17 1986	
C $DO66
	SUBROUTINE VARSCN(LINE,IBGN,LEND,LSTCHR,ID1,ID2,IVALID)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C VARSCN - SCAN COMMAND LINE FOR VARIABLE NAMES.
C
C	SCANS FOR VARIABLE NAMES OF FORM AAANNN WHERE AAA = LETTERS
C BETWEEN A AND Z UP TO NON-ALPHA, CORRESPONDING TO ROW, FOLLOWED BY
C NUMBERS IN THE 0-9 RANGE MAKING A DECIMAL COLUMN NUMBER.
C
C THE LETTERS ARE FORMED BY
C A-Z ALONE GIVE ROW 1-26, COL 1. % IS ROW 27,COL1
C A1-Z1 GIVE ROW 1-26, COL 2
C AA1-ZZ1 ARE ROW 27-52, COL 2
C
C In this version we also recognize cell names using an optional third
C dimension. Forms like B14#2 would be interpreted as cell B14 of sheet
C 2 (sheets start at 0). This is a display trick mainly, as cell offsets
C will be treated as simple 2D addresses as before. However, it will allow
C some greater automation of the notion of multiple areas. Each "page" is
C formed by adding constants KCDELT and KRDELT to the column and row
C of the base number, multiplied by the offset in sheets. These constants
C are initially zero, collapsing all "pages" on top of one another. This
C interpretation will occur provided K3DFG is 0 or positive. If it is 
C negative all 3D interpretation will be ignored, and even parsing of
C the cell names for trailing # characters will be disabled. (This will
C allow strict return to the older meanings.)
	IMPLICIT InTeGer*4 (A-Z)
C NOTE COL 1 IS DUMMY. DISPLAY THE SHEET SIDEWAYS SO WE GET USUAL VISUAL
C ROWS, COLS., AND ACCUMULATORS A-Z,% JUST APPEAR AS A FICTITIOUS ROW 0
C ON DISPLAY, INSTEAD OF REAL COLUMN 1 HERE.
	Include AParms.Inc
	DIMENSION LINE(LEND)
	CHARACTER*1 LINE
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XAVB,xac
	REAL*4 XAV2(2)
	CHARACTER*1 XAV1(8)
	EXTERNAL INDX
	EQUIVALENCE(XAVB,XAV2(1)),(XAVB,XAV1(1))
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
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	InTeGer*4 DLFG
CCC	COMMON/DLFG/DLFG
C DLFG=1 IF D## FORMS ARE SEEN
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
C NRDSP AND NCDSP ARE REAL ROW, COL OF DISPLAY ROW, COL CELLS. NOTE THAT
C NOT ALL DISPLAY CELLS ARE ALWAYS ACTUALLY SHOWN; ONLY THOSE THAT FIT
C ARE SHOWN; THE REST "EXIST" BUT DON'T APPEAR UNLESS ROWS ARE SMALL
C ENOUGH.
C
C THIS PROGRAM ALSO HANDLES CELL SPECS OF FORM
C P#+nnn#+nnn (or P#-nnn#-mmm) FOR Physical cells relative to our current
C physical cell on the sheet (clamped at boundaries), or of form
C D#+nnn#+mmm etc for Display cells relative to our current display
C location as held in the DROW,DCOL cells in commons.
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 k3dfg,kcdelt,krdelt,kshtf
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kshtf
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 PROW,PCOL
C ! PHYSICAL ROW, COL BEING HANDLED.
CCC	InTeGer*4 DROW,DCOL,DCLV,DRWV
	InTeGer*4 RSM,CSM,AFG,ASM,VCF,CH
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	LOGICAL*4 L1,L2
C	LOGICAL*2 L63,L192,L127
	InTeGer*4 I1,I2
	InTeGer*4 I63,I192,I127
	EQUIVALENCE(I1,L1),(I2,L2)
C	EQUIVALENCE (I63,L63),(I192,L192),(L127,I127)
	DATA I63/63/,I192/192/,I127/127/
C DRWV,DCLV = # OF MAX ROWS, COLS ACTUALLY ON SCREEN NOW. DROW,DCOL
C ARE ACTUAL "CURSOR" LOCATION.
C
C ZERO OUR VARIABLES
	LPFG=0
C ! FLAG WE GOT A LOGICAL/PHYSICAL # FORM AND TYPE
	AFG=0
C ! FLAG WE SAW AN ALPHA
	ASM=0
C ! SUM OF ALPHAS HASHCODED (ACCUMULATOR)
	NSM=0
C ! ACCUMULATOR FOR NUMERICS
	NFG=0
C ! FLAG WE SAW A NUMERIC
	RSM=0
C ! AC FOR ROWS IN # FORMS
	CSM=0
C ! AC FOR COLS IN # FORMS
	ISPC=0
C ! COUNTER FOR NONSPACES SEEN (USED TO STOP ON TRAILING SPACES)
	ktpnd=0
	idol1=0
	idol2=0
	IF(LINE(IBGN).NE.'%')GOTO 2000
	ID1=27
	ID2=1
	IVALID=1
	LSTCHR=IBGN+1
C SPECIAL CASE FOR % = AC #27
	RETURN
2000	CONTINUE
	DO 1 N=IBGN,LEND
	VCF=0
	LSTCHR=N
	CH=ICHAR(LINE(N))
	IF (CH.EQ.255)GOTO 5000
C 5000 DECODES ENCODED FORMS AND RETURNS THEM...
C
C IGNORE SPACES AND TABS IF LEADING
	IF(CH.GT.32)ISPC=ISPC+1
	IF(CH.GT.0.AND.CH.LE.32.AND.ISPC.EQ.0)GOTO 1
C SPECIAL CASE TRAILING DOLLAR SIGNS... SKIP AND FLAG
	IF(CH.NE.36)GOTO 3443
C 36 IS ASCII FOR $ SIGN
C SAW A DOLLAR SIGN
	IF(AFG.EQ.1.AND.NFG.EQ.0)IDOL1=1
	IF(AFG.EQ.1.AND.NFG.EQ.1)IDOL2=1
C LEAVES WITH IDOL1 FLAGGED AS 1 IF LETTER PART WAS FOLLOWED BY
C DOLLAR SIGN, AND IDOL2 FLAGGED IF NUMBER PART WAS FOLLOWED
C BY DOLLAR. IGNORES ALL OTHER DOLLAR SIGNS.
	GOTO 1
3443	CONTINUE
C GET CHARACTER VALUE IN.
C MUST BE UPPERCASE.
	IF(.NOT.(CH.GE.65.AND.CH.LT.91)) GOTO 100
C CH IS AN ALPHA, RANGE A-Z
	VCF=1
C ! VALID CHAR SEEN
	AFG=1
C !SAW THE ALPHA
	IF(ASM.LT.MRC)ASM=(CH-64)+26*ASM
	IF(NFG.NE.0)GOTO 103
C FILTER OUT TOO-LARGE VALUES...
C leave the 18000 limit in for now; seems big enough!
	IF(ASM.GT.(mrc-MCols))GOTO 103
C 60 * 26 IS LIM ABOVE
	IF(CH.EQ.80)LPFG=1
C ! FLAG WE GOT PHYS. FORM MAYBE
	IF(CH.EQ.68)LPFG=2
C ! FLAG WE GOT DISPLAY FORM MAYBE
100	CONTINUE
C EXPECT # FORMS TO HAVE # JUST AFTER 1ST ALPHA.
C 35 IS ASCII VALUE OF '#' CHAR.
	IF(CH.EQ.35)GOTO 1000
C NEXT TEST NUMERICS
	IF(.NOT.(CH.GE.48.AND.CH.LE.57))GOTO 101
C CH IS A NUMERIC, RANGE 0-9
	VCF=1
C ! VALID CHAR SEEN
	NFG=1
C ! FLAG WE SAW NUMERIC
	IF(AFG.NE.0)GOTO 102
	GOTO 103
102	CONTINUE
	IF(NSM.LT.MRC)NSM=(CH-48)+10*NSM
C FILTER OUT TOO-LARGE VALUES EARLY
C 301 * 10 IS LIMIT...
	IF(NSM.GT.(MRC-MCols))GOTO 103
C ! CONVERT CHARS TO BINARY AS SEEN
101	CONTINUE
	IF(VCF.EQ.0)GOTO 2
C !END ON ANY INVALID CHARACTER
1	CONTINUE
2	CONTINUE
	IF(AFG.EQ.0)GOTO 103
	GOTO 950
103	CONTINUE
C INVALID ... NUMERIC AND NO PRIOR ALPHA. FLAG BAD NAME AND EXIT.
	IVALID=0
	RETURN
950	ID1=ASM
	ID2=1+NSM
C ! NOTE ID2=1 IF NO NUMERICS SEEN, MORE OTHERWISE.
	GOTO 1201
1000	CONTINUE
C HERE HANDLE CURRENT-REFERENCED FORMS USING # AS SPECIAL CHARACTER MEANING
C THE CURRENT POSITION. THESE TYPES OF REFERENCES MAY BE MOVED AROUND THE
C SHEET WHICH ACCOUNTS FOR THEIR USEFULNESS. SINCE THERE IS A DISPLAY
C AND PHYSICAL SHEET WHICH ARE MAPPED BY A MAPPING, ALLOW EITHER
C TO BE REFERENCED. THUS, COMPLEX CALCULATIONS MAY BE DONE BUT LARGELY
C HIDDEN. THE ACCUMULATORS MAY BE USED AS SCRATCH STORAGE FOR THIS
C SORT OF THING.
C SAW THE # SIGN, SO SEE IF THE + OR - N CAN BE DECODED.
C IF NO P OR D WAS SEEN HOWEVER WE HAVE AN INVALID NAME, SO FLAG IT.
	IF(LPFG.EQ.0)GOTO 103
C PASS THE # SIGN PRIOR TO GETTING THE NUMERIC.
	LSTCHR=LSTCHR+1
	iundr=0
	if(line(lstchr).eq.'_')iundr=1
	if(line(lstchr).eq.'$')iundr=2
	if(line(lstchr).ne.'%'.and.iundr.eq.0)goto 3900
c allow p#%ab form to mean use ac a and b to get offsets from "here"
c allow P#_ab to be absolute address ref for cells (otherwise like p#%ab)
	CSM=0
	RSM=0
C DEFAULT TO "THIS" CELL
	LSTCHR=LSTCHR+1
C PASS THE % SIGN (or other special char we recognize)
	if(Iundr.lt.2)goto 3906
c
c P#$var1var2 is a form that allows relative addressing using ANY of the
c cells for col and row. First cell is col, 2nd is row
c The pointers so derived are ABSOLUTE, relative to absolute beginning of
c the sheet. This seems to me more useful than the relative addressing forms.
c However, I dislike the offset by 1 for rows so will subtract it off so the
c accumulators will be addressed as row 0.
	kkk=lstchr
	kkkk=lstchr+20
	klstc=kkk
c
c Call copy (without this mod) of varscn subroutine to do the examining of 
c variable names, so we don't wind up recursively calling ourselves.
c
	call varsc2(line,kkk,kkkk,klstc,kr1,kr2,kvld)
	if(kvld.eq.0)goto 3906
c try normal processing if this doesn't look like regular variables
	if(line(klstc).eq.':')klstc=klstc+1
	kkk=klstc
	kkkk=kkk+20
	call varsc2(line,kkk,kkkk,klstc,kc1,kc2,kvld)
	if(kvld.eq.0)goto 3906
c Update last chharacter seen pointer to pass these variables.
	if(line(klstc).eq.':')klstc=klstc+1
	lstchr=klstc
c Get the values of the variables and store as integers
	call xvblgt(kr1,kr2,xac)
	rsm=xac
	call xvblgt(kc1,kc2,xac)
	csm=xac
	goto 3901
3906	continue
	RSM=ICHAR(LINE(LSTCHR))
	CSM=ICHAR(LINE(LSTCHR+1))
	LSTCHR=LSTCHR+2
C FIX UP ASCII OFFSETS, AND MEANWHILE REQUIRE UPPERCASE
C AND THAT THERE BE 2 AC'S NAMES AFTER THE %.
C THIS SHOULD BE HANDY FOR COMMAND FILES.
	RSM=RSM-64
	CSM=CSM-64
C NOW RSM, CSM ARE SUBSCRIPTS. PULL OUT VALUES FROM XVBLS
	IF(RSM.LE.0.OR.RSM.GT.27)GOTO 103
	IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
	DO 3902 IV=1,8
3902	XAV1(IV)=AVBLS(IV,RSM)
	RSM=XAVB
	DO 3903 IV=1,8
3903	XAV1(IV)=AVBLS(IV,CSM)
	CSM=XAVB
C LOADS THE 2 AC'S TO THE OFFSETS AND GOES ON...JUST NEEDS THE
C 2 LETTERS AFTER P#% OR D#%.
	goto 3901
3900	continue
	CALL GN(LSTCHR,LEND,NUM,LINE)
C GN GETS THE +- NN NUMBER AND RETURNS VALUE IN NUM.
C LSTCHR RETURNS AS NEXT CHAR NOT USED.
	RSM=NUM
C 35 IS ASCII FOR '#'
C allow any delimiter between numbers, though we must have # at start
C  to delimit valid relative coordinates.
C	IF(ICHAR(LINE(LSTCHR)).NE.35) GOTO 103
C IF NO SECOND # SEEN, THE FORM IS INVALID SO SAY SO AND EXIT.
	LSTCHR=MIN0(LSTCHR+1,LEND)
CC BUMP PAST THE # IF WE SAW IT.
C now get the second numeric string and bump LSTCHR past it.
	NUM=0
	CALL GN(LSTCHR,LEND,NUM,LINE)
	CSM=NUM
C NOW HAVE THE NUMBERS ENCODED. NOTE THAT ## IS VALID.
3901	CONTINUE
	IF(LPFG.EQ.2) GOTO 1200
C IF HERE, LPFG=1 AND WE ARE ON PHYSICAL SHEET.
	if(Iundr.ne.0)goto 3908
	ID2=CSM+PCOL
	ID1=RSM+PROW
	goto 1201
3908	Continue
	id2=CSM+1
	id1=RSM
c Subtract 1 from row to make accumulator row be number zero. This is more
c symmetrical with other usages in the sheet cell names. I like it better than
c making cell A1 be col 1 row 2.
1201	CONTINUE
C Add-in for 3d cells
	kshtf=0
	If(k3dfg.lt.0)goto 1202
C 37 is ascii %
	IF(LINE(LSTCHR).NE.'%') GOTO 1202
C pass the trailing % character now
	LSTCHR=MIN0(LSTCHR+1,LEND)
C limited form of syntax: either a number is to be used
C or an accumulator.
	If(ichar(line(lstchr)).gt.64) goto 1203
C a number.
	NUM=0
	CALL GN(LSTCHR,LEND,NUM,LINE)
	CSM=NUM
	Goto 1204
1203	Continue
C a (possible) accumulator
	csm=ichar(line(lstchr))
	LSTCHR=MIN0(LSTCHR+1,LEND)
	CSM=CSM-64
C Csm now is index to accumulator. Validity check it.
	IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
	DO 2902 IV=1,8
2902	XAV1(IV)=AVBLS(IV,csm)
C convert the accumulator value.
	CSM=XAVB
1204	Continue
C now fix up the col and row returned.
	id1=id1+(csm*kcdelt)
	id2=id2+(csm*krdelt)
	kshtf=csm
C allow our callers to see what (if any) "page" was flagged.
C note that zero and no page flagged are treated the same.
1202	Continue
C TO ALLOW REFLECTED VALUES TO WORK, LET ALL NORMAL VALUES BY...
C	IF(ID1.GT.60.OR.ID1.LE.0)GOTO 103
C	IF(ID2.GT.301.OR.ID2.LE.0)GOTO 103
	IVALID=1
C ALL IS WELL
	RETURN
1200	CONTINUE
C DISPLAY COLUMN RELATIVE.
	DLFG=1
C FLAG WE SAW A D## FORM FOR RECALC
	DRRW=DROW+RSM
	DRRW=MAX0(1,DRRW)
	DRRW=MIN0(20,DRRW)
	DCCL=DCOL+CSM
C ENSURE DISPLAY COORDS IN LEGAL BOUNDS
	DCCL=MAX0(1,DCCL)
	DCCL=MIN0(75,DCCL)
C CLAMP TO WITHIN LEGAL DIMENSIONS.
	ID1=NRDSP(DRRW,DCCL)
	ID2=NCDSP(DRRW,DCCL)
	GOTO 1201
5000	CONTINUE
	IF(ASM.NE.0.OR.NSM.NE.0)GOTO 103
C HANDLE 255,CODE1,CODE2 FORMS
C FIRST BYTE IS ALWAYS 255
C 2ND BYTE IS: HI 2 BITS ARE HI 2 BITS OF ID2. LO 6 BITS ARE ID1
C 3RD BYTE IS: LO 8 BITS OF ID2
	I1=ICHAR(LINE(LSTCHR+1))
	I2=IMASK(I1,I192)
C	L2=L1.AND.L192
C	L1=L1.AND.L63
	I1=IMASK(I1,I63)
	ID1=I1
	I1=ICHAR(LINE(LSTCHR+2))
C	L1=L1.AND.L127
	I1=IMASK(I1,I127)
C MUST HAVE 128 BIT ON IN LOW BYTE TO AVOID NULLS IN IT.
	ID2=I2*2+I1
	LSTCHR=LSTCHR+3
	GOTO 1201
	END
c -h- varsc2.for
C $DO66
	SUBROUTINE VARSC2(LINE,IBGN,LEND,LSTCHR,ID1,ID2,IVALID)
	Include AParms.inc
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C VARSC2 - SCAN COMMAND LINE FOR VARIABLE NAMES.
C    This copy of VARSCN lacks the P#@var1var2 construct and exists to
C    be called from VARSCN for that construct to parse the var1 and var2
C    variable names without risk of a recursive call to varscn (which
C    Fortran generally cannot handle.)
C
C	SCANS FOR VARIABLE NAMES OF FORM AAANNN WHERE AAA = LETTERS
C BETWEEN A AND Z UP TO NON-ALPHA, CORRESPONDING TO ROW, FOLLOWED BY
C NUMBERS IN THE 0-9 RANGE MAKING A DECIMAL COLUMN NUMBER.
C
C THE LETTERS ARE FORMED BY
C A-Z ALONE GIVE ROW 1-26, COL 1. % IS ROW 27,COL1
C A1-Z1 GIVE ROW 1-26, COL 2
C AA1-ZZ1 ARE ROW 27-52, COL 2
	IMPLICIT InTeGer*4 (A-Z)
C NOTE COL 1 IS DUMMY. DISPLAY THE SHEET SIDEWAYS SO WE GET USUAL VISUAL
C ROWS, COLS., AND ACCUMULATORS A-Z,% JUST APPEAR AS A FICTITIOUS ROW 0
C ON DISPLAY, INSTEAD OF REAL COLUMN 1 HERE.
	DIMENSION LINE(LEND)
	CHARACTER*1 LINE
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XAVB
	REAL*4 XAV2(2)
	CHARACTER*1 XAV1(8)
	EXTERNAL INDX
	EQUIVALENCE(XAVB,XAV2(1)),(XAVB,XAV1(1))
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
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	InTeGer*4 DLFG
CCC	COMMON/DLFG/DLFG
C DLFG=1 IF D## FORMS ARE SEEN
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
C NRDSP AND NCDSP ARE REAL ROW, COL OF DISPLAY ROW, COL CELLS. NOTE THAT
C NOT ALL DISPLAY CELLS ARE ALWAYS ACTUALLY SHOWN; ONLY THOSE THAT FIT
C ARE SHOWN; THE REST "EXIST" BUT DON'T APPEAR UNLESS ROWS ARE SMALL
C ENOUGH.
C
C THIS PROGRAM ALSO HANDLES CELL SPECS OF FORM
C P#+nnn#+nnn (or P#-nnn#-mmm) FOR Physical cells relative to our current
C physical cell on the sheet (clamped at boundaries), or of form
C D#+nnn#+mmm etc for Display cells relative to our current display
C location as held in the DROW,DCOL cells in commons.
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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 PROW,PCOL
C ! PHYSICAL ROW, COL BEING HANDLED.
CCC	InTeGer*4 DROW,DCOL,DCLV,DRWV
	InTeGer*4 RSM,CSM,AFG,ASM,VCF,CH
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	LOGICAL*4 L1,L2
C	LOGICAL*2 L63,L192,L127
	InTeGer*4 I1,I2
	InTeGer*4 I63,I192,I127
	EQUIVALENCE(I1,L1),(I2,L2)
C	EQUIVALENCE (I63,L63),(I192,L192),(L127,I127)
	DATA I63/63/,I192/192/,I127/127/
C DRWV,DCLV = # OF MAX ROWS, COLS ACTUALLY ON SCREEN NOW. DROW,DCOL
C ARE ACTUAL "CURSOR" LOCATION.
C
C ZERO OUR VARIABLES
	LPFG=0
C ! FLAG WE GOT A LOGICAL/PHYSICAL # FORM AND TYPE
	AFG=0
C ! FLAG WE SAW AN ALPHA
	ASM=0
C ! SUM OF ALPHAS HASHCODED (ACCUMULATOR)
	NSM=0
C ! ACCUMULATOR FOR NUMERICS
	NFG=0
C ! FLAG WE SAW A NUMERIC
	RSM=0
C ! AC FOR ROWS IN # FORMS
	CSM=0
C ! AC FOR COLS IN # FORMS
	ISPC=0
C ! COUNTER FOR NONSPACES SEEN (USED TO STOP ON TRAILING SPACES)
	idol1=0
	idol2=0
	IF(LINE(IBGN).NE.'%')GOTO 2000
	ID1=27
	ID2=1
	IVALID=1
	LSTCHR=IBGN+1
C SPECIAL CASE FOR % = AC #27
	RETURN
2000	CONTINUE
	DO 1 N=IBGN,LEND
	VCF=0
	LSTCHR=N
	CH=ICHAR(LINE(N))
	IF (CH.EQ.255)GOTO 5000
C 5000 DECODES ENCODED FORMS AND RETURNS THEM...
C
C IGNORE SPACES AND TABS IF LEADING
	IF(CH.GT.32)ISPC=ISPC+1
	IF(CH.GT.0.AND.CH.LE.32.AND.ISPC.EQ.0)GOTO 1
C SPECIAL CASE TRAILING DOLLAR SIGNS... SKIP AND FLAG
	IF(CH.NE.36)GOTO 3443
C 36 IS ASCII FOR $ SIGN
C SAW A DOLLAR SIGN
	IF(AFG.EQ.1.AND.NFG.EQ.0)IDOL1=1
	IF(AFG.EQ.1.AND.NFG.EQ.1)IDOL2=1
C LEAVES WITH IDOL1 FLAGGED AS 1 IF LETTER PART WAS FOLLOWED BY
C DOLLAR SIGN, AND IDOL2 FLAGGED IF NUMBER PART WAS FOLLOWED
C BY DOLLAR. IGNORES ALL OTHER DOLLAR SIGNS.
	GOTO 1
3443	CONTINUE
C GET CHARACTER VALUE IN.
C MUST BE UPPERCASE.
	IF(.NOT.(CH.GE.65.AND.CH.LT.91)) GOTO 100
C CH IS AN ALPHA, RANGE A-Z
	VCF=1
C ! VALID CHAR SEEN
	AFG=1
C !SAW THE ALPHA
	IF(ASM.LT.MRC)ASM=(CH-64)+26*ASM
	IF(NFG.NE.0)GOTO 103
C FILTER OUT TOO-LARGE VALUES...
	IF(ASM.GT.(MRC-MCOls))GOTO 103
C 60 * 26 IS LIM ABOVE
	IF(CH.EQ.80)LPFG=1
C ! FLAG WE GOT PHYS. FORM MAYBE
	IF(CH.EQ.68)LPFG=2
C ! FLAG WE GOT DISPLAY FORM MAYBE
100	CONTINUE
C EXPECT # FORMS TO HAVE # JUST AFTER 1ST ALPHA.
C 35 IS ASCII VALUE OF '#' CHAR.
	IF(CH.EQ.35)GOTO 1000
C NEXT TEST NUMERICS
	IF(.NOT.(CH.GE.48.AND.CH.LE.57))GOTO 101
C CH IS A NUMERIC, RANGE 0-9
	VCF=1
C ! VALID CHAR SEEN
	NFG=1
C ! FLAG WE SAW NUMERIC
	IF(AFG.NE.0)GOTO 102
	GOTO 103
102	CONTINUE
	IF(NSM.LT.MRC)NSM=(CH-48)+10*NSM
C FILTER OUT TOO-LARGE VALUES EARLY
C 301 * 10 IS LIMIT...
	IF(NSM.GT.(MRC-MCols))GOTO 103
C ! CONVERT CHARS TO BINARY AS SEEN
101	CONTINUE
	IF(VCF.EQ.0)GOTO 2
C !END ON ANY INVALID CHARACTER
1	CONTINUE
2	CONTINUE
	IF(AFG.EQ.0)GOTO 103
	GOTO 950
103	CONTINUE
C INVALID ... NUMERIC AND NO PRIOR ALPHA. FLAG BAD NAME AND EXIT.
	IVALID=0
	RETURN
950	ID1=ASM
	ID2=1+NSM
C ! NOTE ID2=1 IF NO NUMERICS SEEN, MORE OTHERWISE.
	GOTO 1201
1000	CONTINUE
C HERE HANDLE CURRENT-REFERENCED FORMS USING # AS SPECIAL CHARACTER MEANING
C THE CURRENT POSITION. THESE TYPES OF REFERENCES MAY BE MOVED AROUND THE
C SHEET WHICH ACCOUNTS FOR THEIR USEFULNESS. SINCE THERE IS A DISPLAY
C AND PHYSICAL SHEET WHICH ARE MAPPED BY A MAPPING, ALLOW EITHER
C TO BE REFERENCED. THUS, COMPLEX CALCULATIONS MAY BE DONE BUT LARGELY
C HIDDEN. THE ACCUMULATORS MAY BE USED AS SCRATCH STORAGE FOR THIS
C SORT OF THING.
C SAW THE # SIGN, SO SEE IF THE + OR - N CAN BE DECODED.
C IF NO P OR D WAS SEEN HOWEVER WE HAVE AN INVALID NAME, SO FLAG IT.
	IF(LPFG.EQ.0)GOTO 103
C PASS THE # SIGN PRIOR TO GETTING THE NUMERIC.
	LSTCHR=LSTCHR+1
	iundr=0
	if(line(lstchr).eq.'_')iundr=1
	if(line(lstchr).ne.'%'.and.iundr.eq.0)goto 3900
c allow p#%ab form to mean use ac a and b to get offsets from "here"
c allow P#_ab to be absolute address ref for cells (otherwise like p#%ab)
	CSM=0
	RSM=0
C DEFAULT TO "THIS" CELL
	LSTCHR=LSTCHR+1
C PASS THE % SIGN
	RSM=ICHAR(LINE(LSTCHR))
	CSM=ICHAR(LINE(LSTCHR+1))
	LSTCHR=LSTCHR+2
C FIX UP ASCII OFFSETS, AND MEANWHILE REQUIRE UPPERCASE
C AND THAT THERE BE 2 AC'S NAMES AFTER THE %.
C THIS SHOULD BE HANDY FOR COMMAND FILES.
	RSM=RSM-64
	CSM=CSM-64
C NOW RSM, CSM ARE SUBSCRIPTS. PULL OUT VALUES FROM XVBLS
	IF(RSM.LE.0.OR.RSM.GT.27)GOTO 103
	IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
	DO 3902 IV=1,8
3902	XAV1(IV)=AVBLS(IV,RSM)
	RSM=XAVB
	DO 3903 IV=1,8
3903	XAV1(IV)=AVBLS(IV,CSM)
	CSM=XAVB
C LOADS THE 2 AC'S TO THE OFFSETS AND GOES ON...JUST NEEDS THE
C 2 LETTERS AFTER P#% OR D#%.
	goto 3901
3900	continue
	CALL GN(LSTCHR,LEND,NUM,LINE)
C GN GETS THE +- NN NUMBER AND RETURNS VALUE IN NUM.
C LSTCHR RETURNS AS NEXT CHAR NOT USED.
	RSM=NUM
C 35 IS ASCII FOR '#'
C allow any delimiter between numbers, though we must have # at start
C  to delimit valid relative coordinates.
C	IF(ICHAR(LINE(LSTCHR)).NE.35) GOTO 103
C IF NO SECOND # SEEN, THE FORM IS INVALID SO SAY SO AND EXIT.
	LSTCHR=MIN0(LSTCHR+1,LEND)
CC BUMP PAST THE # IF WE SAW IT.
C now get the second numeric string and bump LSTCHR past it.
	NUM=0
	CALL GN(LSTCHR,LEND,NUM,LINE)
	CSM=NUM
C NOW HAVE THE NUMBERS ENCODED. NOTE THAT ## IS VALID.
3901	CONTINUE
	IF(LPFG.EQ.2) GOTO 1200
C IF HERE, LPFG=1 AND WE ARE ON PHYSICAL SHEET.
	if(Iundr.eq.1)goto 3908
	ID2=CSM+PCOL
	ID1=RSM+PROW
	goto 1201
3908	Continue
	id2=CSM
	id1=RSM
1201	CONTINUE
C TO ALLOW REFLECTED VALUES TO WORK, LET ALL NORMAL VALUES BY...
C	IF(ID1.GT.60.OR.ID1.LE.0)GOTO 103
C	IF(ID2.GT.301.OR.ID2.LE.0)GOTO 103
	IVALID=1
C ALL IS WELL
	RETURN
1200	CONTINUE
C DISPLAY COLUMN RELATIVE.
	DLFG=1
C FLAG WE SAW A D## FORM FOR RECALC
	DRRW=DROW+RSM
	DRRW=MAX0(1,DRRW)
	DRRW=MIN0(20,DRRW)
	DCCL=DCOL+CSM
C ENSURE DISPLAY COORDS IN LEGAL BOUNDS
	DCCL=MAX0(1,DCCL)
	DCCL=MIN0(75,DCCL)
C CLAMP TO WITHIN LEGAL DIMENSIONS.
	ID1=NRDSP(DRRW,DCCL)
	ID2=NCDSP(DRRW,DCCL)
	GOTO 1201
5000	CONTINUE
	IF(ASM.NE.0.OR.NSM.NE.0)GOTO 103
C HANDLE 255,CODE1,CODE2 FORMS
C FIRST BYTE IS ALWAYS 255
C 2ND BYTE IS: HI 2 BITS ARE HI 2 BITS OF ID2. LO 6 BITS ARE ID1
C 3RD BYTE IS: LO 8 BITS OF ID2
	I1=ICHAR(LINE(LSTCHR+1))
	I2=IMASK(I1,I192)
C	L2=L1.AND.L192
C	L1=L1.AND.L63
	I1=IMASK(I1,I63)
	ID1=I1
	I1=ICHAR(LINE(LSTCHR+2))
C	L1=L1.AND.L127
	I1=IMASK(I1,I127)
C MUST HAVE 128 BIT ON IN LOW BYTE TO AVOID NULLS IN IT.
	ID2=I2*2+I1
	LSTCHR=LSTCHR+3
	GOTO 1201
	END
c -h- vvary.for	Fri Aug 22 13:37:17 1986	
C $DO66
C VARY CONTROL ROUTINE
C NOTE: THIS ROUTINE RELIES UPON HAVING ITS DATA AREAS REMAIN INTACT
C ACROSS CALLS. IT MUST NOT BE IN AN OVERLAY SEGMENT OR THAT WILL FAIL
C AND IT WILL NOT WORK. SPECIFICALLY IT EXPECTS THE AC ARRAY TO BE
C SET CORRECTLY.
	SUBROUTINE VVARY(LINE,RETCD,K)
	CHARACTER*1 LINE(80)
	INTEGER RETCD
	CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XAC,XVBLS(1,1)
	EQUIVALENCE(XAC,AVBLS(1,27))
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
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)
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
C	InTeGer*4 IPS1,IPS2,MODFLG
	InTeGer*4 IC1POS,IC2POS,MODFLG
CCC	COMMON/ICPOS/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 KALKIT
CCC	COMMON/VARYIT/KALKIT
	EXTERNAL SIGN
	INTEGER LPUT,LGET
	REAL*8 SIGN
	CHARACTER*1 LAC(8)
	REAL*8 XVAC,VW
	EQUIVALENCE(LAC(1),XVAC)
	REAL *8 AC(26)
	REAL*8 DERIV(8)
	REAL*8 DEL(8)
	REAL*8 OLDVV,OLDX,OLDA
	INTEGER ACV(8)
	INTEGER CAC
	INTEGER CCNT(8)
C UNCOMMENT THIS COMMON DECLARATION AND MOVE DATA STMTS INTO BLOCK
C IN ORDER TO OVERLAY THIS...
	COMMON/VRYDAT/AC,DERIV,DEL,CAC,CCNT,OLDVV,OLDX,OLDA,ACV
C
C ACV POINTS TO AC'S VARYING
C CAC = CURRENT INDEX INTO ACV TO FIND AC BEING VARIED
C AC IS LAST SET OF ACCUMULATORS SEEN
C IF ACV ENTRY IS 0, MEANS NO AC TO VARY THERE.
	INTEGER LW,LX,LI
C ! LOGICAL W,X,I AC'S
	INTEGER LA
C ! LOGICAL A AC
C
C	DATA DERIV/8*1./,DEL/8*0./
C	DATA CAC/1/,CCNT/8*0/
C	DATA ACV/8*0/
C	DATA OLDVV/1./
C
C PARSE ARGUMENTS FIRST
C FIRST 2 ARGS ARE X AND A AC'S (OR GENERAL CELLS)
C DEFAULT NO REDOING THIS...
	KALKIT=0
	IBGN=K+5
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LX,ID2A,IVALID)
	IF (IVALID.EQ.0)GOTO 9900
	IF(LINE(LSTCHR).NE.',')GOTO 9900
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LA,ID2B,IVALID)
	IF (IVALID.EQ.0)GOTO 9900
	IF(LINE(LSTCHR).NE.',')GOTO 9900
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LW,ID3B,IVALID)
	IF (IVALID.EQ.0)GOTO 9900
	IF(LINE(LSTCHR).NE.',')GOTO 9900
	IF(ID3B.NE.1)GOTO 9900
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LI,ID3B,IVALID)
	IF (IVALID.EQ.0)GOTO 9900
	IF(LINE(LSTCHR).NE.',')GOTO 9900
	IF(ID3B.NE.1)GOTO 9900
C	IBGN=LSTCHR+1
C	LEND=IBGN+20
C LOOP OVER VALUES TO VARY NOW
	DO 99 N=1,8
99	ACV(N)=0.
	DO 100 N=1,8
C ALLOW UP TO 8 DIMENSIONS VARIATION
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ACV(N),ID3B,IVALID)
	IF (IVALID.EQ.0)GOTO 9900
	IF(LINE(LSTCHR).NE.';')GOTO 110
	IF(ID3B.NE.1)GOTO 9900
	IBGN=LSTCHR+1
	LEND=IBGN+20
100	CONTINUE
110	CONTINUE
C NOW HAVE ALL AC POINTERS SET UP.
C IF I IS NOW 0 OR NEGATIVE (ITER COUNT), REINITIALIZE.
	ASSIGN 111 TO LGET
	LLL=LI
	GOTO 500
111	CONTINUE
	IF(XVAC.GT.0.)GOTO 112
C INITIALIZE COUNTS
	LLL=LW
C GET VALUE OF W FRACTION
	ASSIGN 114 TO LGET
	GOTO 500
114	CONTINUE
	VW=XVAC
	OLDVV=1.
	DO 113 N=1,8
	CCNT(N)=0
	DERIV(N)=1.
	DEL(N)=VW
113	CONTINUE
	CAC=1
C COPY CURRENT AC'S INTO SAVED ONES NOW.
	DO 117 N=1,26
	LLL=N
	ASSIGN 118 TO LGET
	GOTO 500
118	AC(N)=XVAC
117	CONTINUE
C AFTER THE INIT, JUST RETURN SINCE WE DON'T WANT TO TRY ANY ITERATIONS
C WHEN ITER COUNT EXPIRES.
	KALKIT=0
	RETURN
C HERE WHEN ITER COUNT IS POSITIVE.
112	CONTINUE
	XVAC=XVAC-1.
C UPDATE ITERATION COUNT NOW...
	KALKIT=XVAC
	ASSIGN 120 TO LPUT
	GOTO 600
120	CONTINUE
C
C NOW PROCEED WITH VARIATIONS...
	IF(CAC.LT.1.OR.CAC.GT.8)CAC=1
	IF(CCNT(CAC).GE.1)GOTO 200
C CCNT WAS 0 SO WE DIDN'T GET OUR PARTIAL YET. VARY THE
C AC WE'RE LOOKING AT (CAC = CURRENT AC) AND USE NEW VALUE OF
C (X-A) FOR A NUMERICAL DERIVATIVE RESULT AFTER A RECALC OF SCREEN...
	CCNT(CAC)=1
C JUST STARTED THIS AC SO VARY BY THE APPROPRIATE DELTA AND
C EXIT, ALLOWING PARTIAL TO BE COMPUTED NEXT TIME.
	LLL=LW
	ASSIGN 400 TO LGET
	GOTO 500
400	CONTINUE
C GET W ACC. VALUE
	VW=XVAC
	IF(VW.EQ.0.)VW=.5
C GET CURRENT AC, FIND HOW TO UPDATE IT.
	LLL=ACV(CAC)
	IF(LLL.LE.0)GOTO 9900
	ASSIGN 121 TO LGET
	GOTO 500
121	CONTINUE
C NOW XVAC HAS CURRENT AC FOR THE ONE WE'RE VARYING
C ADD DEL TO IT AND GET NEW ONE...
C SAVE OLD X AC VALUE FOR NEXT ITERATION.
C NOTE LLL IS STILL SET AT CURRENTLY VARYING AC
C SAVE CURRENT (UNVARIED) VALUE TOO FOR NEXT TIME AROUND.
	OLDVV=XVAC
	IF(OLDVV.EQ.0.)OLDVV=1.
	IF(DEL(CAC).EQ.0.)DEL(CAC)=VW
	XVAC=XVAC*(1.+DEL(CAC))
C NOW ALL SET... JUST SAVE CURRENT AC'S AND CURRENT X,A
C SO WE CAN GET DIFFERENCE NEXT TIME AROUND.
C	AC(ACV(CAC))=XVAC
C STORE XVAC INTO REAL ACCUMULATORS TOO, SO IT'LL WORK
C WHEN ALL AC'S ARE RELOADED BELOW.
	ASSIGN 412 TO LPUT
	GOTO 600
412	CONTINUE
C AT 1000, RELOAD AC ARRAY FROM REAL AC'S... BUT GET OUR MODIFIED
C ONE WE JUST STORED TOO.
	GOTO 1000
200	CONTINUE
C COUNT HERE IS 1 SO WE ALREADY HAVE INFO NOW FOR OUR PARITAL
C DERIVATIVE. COMPUTE IT AND VARY THE SELECTED AC USING IT
C THEN STORE IT AND RESET CCNT(CAC) TO 0
	CCNT(CAC)=0
C MUST GET NEW X AND A VALUES NOW.
	CALL XVBLGT(LX,ID2A,XVAC)
C	XVAC=XVBLS(LX,ID2A)
	IF(ID2A.NE.1)GOTO 201
	LLL=LX
	ASSIGN 201 TO LGET
C EXTRACT CURRENT X FROM AVBLS
	GOTO 500
201	CONTINUE
	XCURR=XVAC
	CALL XVBLGT(LA,ID2B,XVAC)
C	XVAC=XVBLS(1,1)
	IF(ID2B.NE.1)GOTO 202
	LLL=LA
	ASSIGN 202 TO LGET
	GOTO 500
202	CONTINUE
	ACURR=XVAC
C NOW WE HAVE ENOUGH TO COMPUTE PARTIAL DERIVATIVE WE NEED.
	IF(ACV(CAC).LE.0)GOTO 9900
	IF(OLDVV.EQ.0.)OLDVV=AC(ACV(CAC))
	IF(OLDVV.EQ.0.)OLDVV=1.
	DERIV(CAC)=((XCURR-ACURR)-(OLDX-OLDA))/(DEL(CAC)*OLDVV)
C NEGATIVE FEEDBACK: IF GOING POSITIVE, MAKE IT NEGATIVE...
C THIS IS NOT AN ANALYTICAL PROCEDURE ... JUST STEPS IN RIGHT DIRECTION
C BY APPROPRIATE AMOUNT AND CONTINUES...
C CLAMP VARIATION TO INITIAL PERCENTAGE IN W ACCUMULATOR
	LLL=LW
C OBTAIN VALUE OF W VARIATION NOW...IN CASE USER SETS IT UP TO VARY
	ASSIGN 203 TO LGET
	GOTO 500
203	CONTINUE
	VW=XVAC
C
C TO ATTEMPT TO GET TO THE ZERO OF (X-A), WE REALLY NEED TO
C DIVIDE BY THE DERIVATIVE. HOWEVER, IN CASES WHERE THE FUNCTION
C IS NEAR ITS LOCAL MINIMUM AND SLOWLY VARYING, WE REALLY DON'T WANT
C TO STEP FAR AWAY (IT MAY NEVER REACH THE ZERO). THEREFORE, TEST
C TO SEE IF THE DERIVATIVE IS LARGE AND ALLOW DIVISION WHERE IT IS
C OVER A SOMEWHAT ARBITRARY THRESHOLD (USED 1.0 BELOW), BUT
C MULTIPLY BY DERIVATIVE OTHERWISE, SO THAT AS THE FUNCTION APPROACHES
C ZERO SLOPE, THE STEPS GET FINER TO GET INTO THE LOCAL MINIMUM (IF ANY).
C
C FORCE NONZERO VARIATION JUST SO WE DON'T GET STUCK.
	IF(DERIV(CAC).EQ.0.)DERIV(CAC)=.01
	IF(DABS(DERIV(CAC)).GT.1.)GOTO 405
	DEL(CAC)=-(OLDX-OLDA)*VW*DERIV(CAC)
	GOTO 406
405	CONTINUE
	DEL(CAC)=-(OLDX-OLDA)*VW/DERIV(CAC)
406	CONTINUE
C VERY IMPORTANT TO CLAMP SIZE OF STEPS HERE SO WE DON'T WILDLY DIVERGE
C IN EARLY GOING. SMALL STEPS TAKE LONGER BUT GET TO MINIMA; LARGER ONES
C WHERE WE DON'T KNOW FUNCTION SHAPE CAN BE DISASTERS.
	IF(DABS(DEL(CAC)).GT.VW)DEL(CAC)=VW*SIGN(DEL(CAC))
C NOW RESTORE AC'S TO OLD ONES AND VARY CURRENT ONE BY
C THE NEW DELTA.
	IF(ACV(CAC).LE.0)GOTO 9900
C NEXT LINE MAKES ADJUSTMENT NEEDED TO OUR VARYING AC.
	AC(ACV(CAC))=OLDVV*(1.+DEL(CAC))
C NOW COPY SAVED OLD AC'S ONTO NEW ONES SO WE START WITH AC'S ALL AS THEY
C WERE IN FIRST STEP SO WE VARY FROM INITIAL X, NOT FROM FIRST VARIED X
C LOCATION...
	DO 204 N=1,26
	XVAC=AC(N)
	LLL=N
	ASSIGN 205 TO LPUT
	GOTO 600
205	CONTINUE
204	CONTINUE
C MOVE ON TO THE NEXT CAC VALUE
	CAC=CAC+1
	IF(ACV(CAC).LE.0.OR.CAC.GT.8)CAC=1
1000	CONTINUE
C SAVE OLD AC'S NOW FOR NEXT TIME
	DO 1100 N=1,26
	LLL=N
	ASSIGN 1101 TO LGET
	GOTO 500
1101	AC(N)=XVAC
1100	CONTINUE
C REMEMBER OLD X AND A VALUES SINCE WE LOOK FOR X=A AS
C A SEARCH CONDITION. WE MUST ASSUME THAT SOME SORT OF
C VARIATION OF ACCUMULATORS GIVEN WILL ALLOW US TO SATISFY
C THE EQUATION (X-A)=0.
	OLDX=AC(LX)
	IF(ID2A.NE.1)CALL XVBLGT(LX,ID2A,OLDX)
C	IF(ID2A.NE.1)OLDX=XVBLS(LX,ID2A)
	OLDA=AC(LA)
	IF(ID2B.NE.1)CALL XVBLGT(LA,ID2B,OLDA)
C	IF(ID2B.NE.1)OLDA=XVBLS(LA,ID2B)
	RETURN
9900	CONTINUE
	RETCD=3
	RETURN
C PROC TO LOAD XVAC WITH VBLS(LLL)
500	CONTINUE
	DO 501 KKKKN=1,8
501	LAC(KKKKN)=AVBLS(KKKKN,LLL)
	GOTO LGET,(111,114,118,400,121,201,202,203,1101)
C PROC TO STORE XVAC INTO VBLS(LLL)
600	CONTINUE
	DO 601 KKKKN=1,8
601	AVBLS(KKKKN,LLL)=LAC(KKKKN)
	GOTO LPUT,(120,412,205)
	END
c -h- xqtcmd.for	Fri Aug 22 13:45:23 1986	
C $DO66
	SUBROUTINE XQTCMD(ICODE)
C COPYRIGHT (C) 1983-1990 GLENN AND MARY EVERHART
c All Rights Reserved
	Include AParms.inc
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	CHARACTER*1 FORM,FVLD,CMDLIN(132),CL127(127)
C ALLOCATE EXTRA SLOP SPACE AFTER CMDLIN
	CHARACTER*1 CLWW(136)
	EQUIVALENCE(CLWW(1),CMDLIN(1))
	CHARACTER*127 CMDLNA
	EQUIVALENCE(CMDLIN(1),CL127(1),CMDLNA(1:1))
C	EQUIVALENCE(CMDLNA,CMDLIN(1))
	CHARACTER*127 WRKCHR,FORMCH,fwt
C	equivalence(fwt(1:1),formch(1:1))
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
	CHARACTER*1 WRKCHA(132),WRK127(127)
	EQUIVALENCE(WRKCHA(1),WRKCHR(1:1),WRK127(1),FORM2(1))
C	EQUIVALENCE(FORM2(1),WRK127(1))
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
c	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kpag
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
c     3  k3dfg,kcdelt,krdelt,kpag
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 RRWACT,RCLACT
CCC	COMMON/RCLACT/RRWACT,RCLACT
	INTEGER*4 VNLT
	EXTERNAL INDX
c	EQUIVALENCE(FORM2(1),WRKCHR)
	COMMON/NMSH/NMSH
	REAL*8 XVBLS(1,1)
	INTEGER KPYBAK
CCC	Integer*4 FH
CCC	Common/CONSFH/FH
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	InTeGer*4 JMVFG,JMVOLD
	INTEGER*4 JVBLS(2,1,1)
CCC	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.
C PUT JMVFG INTO A PSECT BY ITSELF SO IT WILL SURVIVE OVERLAYS.
CCC	COMMON/FUBAR/JMVFG,JMVOLD
	DIMENSION FORM(128),FVLD(1,1)
	CHARACTER*1 DFE,FVWRK,FVWRK2,FRM127(127)
	EQUIVALENCE(FORM(1),FORMCH(1:1),FRM127(1))
C	EQUIVALENCE(FORM(1),FRM127(1)),(FRM127(1),FORMCH)
	DIMENSION DFE(14)
	CHARACTER*14 CDFE
	EQUIVALENCE(CDFE(1:1),DFE(1))
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
CCC     1  IDOL7,IDOL8

CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
CCC     1  IDOL7,IDOL8
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
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 ILNFG,ILNCT,RCF
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	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 ILINE(106)
	COMMON/ILN/ILNFG,ILNCT,ILINE
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
C	InTeGer*4 IPS1,IPS2,MODFLG
	InTeGer*4 IC1POS,IC2POS,MODFLG
CCC	COMMON/ICPOS/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
CCC	CHARACTER*1 OARRY(100)
CCC	InTeGer*4 OSWIT,OCNTR
CCC	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	CHARACTER*1 FVLDTP
	REAL*8 XAC,ZAC
	EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
	REAL*8 XXAC,XYAC
	EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
CCC	InTeGer*4 NULAST,LFVD
CCC	COMMON/NULXXX/NULAST,LFVD
CCC	CHARACTER*1 ARGSTR(52,4)
CCC	COMMON/ARGSTR/ARGSTR
C	EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	COMMON/KLVL/KLVL
	CHARACTER*1 DEFVB(12)
CCC	InTeGer*4 MODPUB,LIMODE
CCC	COMMON/MODPUB/MODPUB,LIMODE
	COMMON/DEFVBX/DEFVB
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCC     1  IRCE1,IRCE2
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCC     1  IRCE1,IRCE2
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).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	REAL*8 DVS(20,75)
	INTEGER*4 LDVS(2,20,75)
	EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
	COMMON /FVLDC/FVLD
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
C THISRW,THISCL = CURRENT DISPLAYED LOCS.
	InTeGer*4 THISRW,THISCL
C	CHARACTER*1 IBITMP(2258)
C	COMMON/INITD/IBITMP
C FOLLOWING COMMON IS TO CONTROL "EXTERNAL" CALL OF XQTCMD
C TO ALLOW USE FROM INSIDE CELLS.
CCC	CHARACTER*1 XTNCMD(80)
CCC	InTeGer*4 XTCFG,XTNCNT,IPSET
CCC	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
	CHARACTER*1 blanks
	dimension blanks(30)
	data blanks/30*' '/
C
	OSWIT=2
C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
C
C  COMMANDS INCLUDE:
C E = ENTER NUMBERS OR FORMULAS
C M = MOVE DIRECTION (1,2,3,4 = U,D,L,R)
C D = DISPLAY CHARACTERISTIC CHANGES
C
C DISPLAY ALTERING SUBCOMMANDS:
C  DL V1:V2 RN:M OR CN:M - DISPLAY VARIABLE RANGE V1:V2 AT DISPLAY
C  ROW OR COL N THRU M.
C  RN:M MEANS ACROSS A ROW ON DISPLAY STARTING AT DISPLAY COORD N,M
C  CN:M MEANS DOWN A DISPLAY COLUMN STARTING AT DISPLAY COORD N,M
C  DF V1:V2 FORMAT
C  SET FORMAT FOR DISPLAY OF V1 THRU V2 TO FORMAT (NOT INCL. )
C  A OR L DESIGNATOR SAYS SHOW TEXT IN FORMULA BUFFER. ELSE SHOW
C  NUMBER VALUE AT THAT LOC.
C  DT V1:V2 F OR I - SET NUMERIC TYPE OF V1 THRU V2 TO FLOAT OR INT.
C  DW N,M - SET WIDTH OF COL. N TO M CHARS WIDE.
C  DB MC,MR - SET MAX COLS TO MC, MAX ROWS TO MR.
C
C V = VIEWSCREEN UPDATE. REDISPLAY EVERYTHING FROM SCRATCH.
C VF = VIEW BUT DISPLAY FORMULAS ALL LOCS.
C VM = DISABLE REDRAWING SCREEN UNTIL A V IS SEEN.
C C = COPY NUMBERS/FORMULAS/DISPLAY STUFF(FORMAT)/ALL/RELOCATING
C 1,2,3,4 = MOVE CURSOR UP,DOWN,LEFT,RIGHT 1 ROW/COL
C (THESE DO NOT INVALIDATE CALCULATION SO RECALCULATION IS NOT
C DONE FOR THESE COMMANDS.)
C F FILENAME/NNN  FILL SCREEN (DISPLAYED PART ONLY) FROM FILENAME,
C    SKIPPING NNN RECORDS FIRST IF CALLED FOR. /NNN PART OPTIONAL.
C  (SPLITS STUFF READ IN ACROSS COLUMNS CURRENTLY DEFINED AND
C   SETS FVLD FOR DISPLAY OF TEXT, NOT #S.)
C AR/A n R/C ADDS/SUBTRACTS (INSERTS/DELETES) n ROWS OR COLUMNS
C   AT CURENT LOCATION. AR/AA SELECTS RELOCATING/ABSOLUTE.
C R = RECALCULATE SHEET. 17 = RECALCULATE MANUALLY ONLY (R RESETS)
C K = DROP INTO CALC CALCULATOR (*E RETURNS TO SHEET)
C L = LOCATE CURSOR (MOVE TO POSITION ON SHEET)
C (L VARIABLE IS THE COMMAND, AND IT LOCATES ORIGIN ON PHYSICAL
C SHEET. WILL ALSO MOVE CURSOR ON DISPLAY SHEET IF THAT CELL IS
C DISPLAYED, BUT OTHERWISE DOES NOT DISPLAY THE NUMBER.)
C Z = ZERO FORMULA/NUMBERS (OR ALL SHEET)
C  ZERO VARIABLE ZEROES THAT VARIABLE
C  ZERO VARIABLE1:VARIABLE2 ZEROES THAT RANGE (ROW OR COL)
C  ZERO * ZEROES ALL OF THE SHEET.
C X = EXIT (RETURNS TO OS)
C P = PUT NUMBERS TO FILE. ALWAYS GENERATES P#+nn#+mm forms based on
C current location.
C G = GET NUMBERS OUT OF FILE. USES CURRENT ORIGIN FROM L COMMAND OR 1,1
C TO ENTER NUMBERS (ALLOWS COMBINING DATA).
C W = WRITE SCREEN ON PRINTER (HARDCOPY FORMAT APPROX. AS DISPLAY.)
C OA VARIABLE = SET ORIGIN OF DISPLAY SHEET TO VARIABLE LOC IN
C  PHYSICAL SHEET (CLAMPED TO MAX. SIZE OF SHEET). STARTS AT R1,C1 OF
C  DISPLAY SHEET.
C OR VARIABLE = SET ORIGIN OF DISPLAY SHEET TO LOC'N OF VARIABLE IN
C  PHYSICAL SHEET. MODIFIES DISPLAY SHEET STARTING AT CURRENT DISPLAY
C  LOCATION RATHER THAN AT 1,1.
C
C NOTE THAT N-ARY FUNCTIONS ARE FNAMEARGS,ARGS,...
C AND RANGES ARE CELL1:CELLN. MULTIPLE COMMANDS IN FORMULA ARE
C DELIMITED BY \ CHARACTER.
C
C RETURN CODES:
C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
C THE ENTIRE SHEET.
C ICODE =-1 ==> REINITIALIZE DISPLAY DEFAULTS
C ICODE =2  ==> REDRAW WHOLE SCREEN
C ICODE =-2 ==> NEW SPREAD SHEET FILE SETUP.
C OTHER: ALL OK.
498	CONTINUE
	KLVL=1
	ICODE=3
C DEFAULT RETURN CODE SAYING ALL WELL
C FIRST DISPLAY CURRENT CELL AGAIN IN NORMAL.
	THISRW=DROW
	THISCL=DCOL
	FORM(1)=0
C GET IN THE CURRENT FORMAT WHEREVER WE ARE, EVEN IF NOT ON DISPLAY SHEET.
C	IRRX=(PCOL-1)*60+PROW
	CALL REFLEC(PCOL,PROW,IRRX)
	CALL WRKFIL(IRRX,FORM2,0)
	CALL CE2A(FORM2,FORM)
C	READ(7'IRRX)FORM
	IF(THISRW.LE.0.OR.THISCL.LE.0)GOTO 200
	N1=NRDSP(THISRW,THISCL)
	N2=NCDSP(THISRW,THISCL)
	IXLSTC=THISCL
	IXLSTR=THISRW
	IF(THISCL.GT.DCLV.OR.THISRW.GT.DRWV)GOTO 200
C REDRAW LAST DISPLAYED CELL IN NORMAL (I.E., NOT REVERSE) VIDEO.
C	IF(ICHAR(FVLD(N1,N2)).EQ.0)GOTO 200
C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
	J=8
C	IRRX=(N2-1)*60+N1
	CALL REFLEC(N2,N1,IRRX)
C ADD 6 COLS FOR LABELS
	DO 1 M1=1,DROW
C FIND DISPLAY COLUMN TO USE
1	J=J+CWIDS(M1)
	J=J-CWIDS(DROW)
C USE THISCL+1 TO LET 1ST ROW BE LABELS.
	ICCC=THISCL+2
C 0 = 1 IF VT100, 0 IF VT52
C SAVE PHYS COORDS BEING DISPLAYED NEXT. FVLD CAN BE TESTED FOR NUMERICS
C DIRECTLY, IF UVT100 NEEDS THAT ACCESS.
	IC1POS=N1
	IC2POS=N2
	IF(PZAP.NE.0)GOTO 3607
	CALL UVT100(1,ICCC,J)
C SELECT ROW "THISCL", COL "J"
	CALL UVT100(13,7,0)
	CALL FVLDGT(N1,N2,FVLD(1,1))
C	IF(FVLD(1,1).EQ.0)WRITE(6,5538)
C5538	FORMAT('>-<')
	ivv=min0(30,cwids(DROW))
c reset blanks to be sure we write something even for vt52
ccc	blanks(1)='>'
	IF(ICHAR(FVLD(1,1)).EQ.0)CALL SWRT(BLANKS,IVV)
ccc	blanks(1)=32
cccccc no VT52's in PCs...
C5538	FORMAT(1H+,30(a1,'\'))
3607	CONTINUE
C WE CAN BE SURE THE COLUMN IS 3 WIDE OR MORE...
	CALL FVLDGT(N1,N2,FVLDTP)
	IF(ICHAR(FVLDTP).EQ.0)GOTO 200
C	IRRX=(N2-1)*60+N1
C SELECT REVERSE VIDEO
	DO 5540 KKKK=1,100
5540	CMDLIN(KKKK)=char(32)
	CALL WRKFIL(IRRX,FORM2,0)
	CALL CE2A(FORM2,FORM)
C	READ(7'IRRX)FORM
C	IF(JCHAR(FORM(120)).LE.0)GOTO 200
	IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
     1  WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
8201	FORMAT(128A1)
	IF(FORMFG.NE.0)GOTO 4320
	DO 6301 KKK=1,9
	KKKK=ICHAR(FORM(KKK+119))
C	KKKK=DFMTS(KKK,THISRW,THISCL)
6301	DFE(KKK+1)=CHAR(MAX0(32,KKKK))
	DFE(11)=CHAR(32)
C 32 = ASCII SPACE
	DFE(1)='('
	DFE(12)=' '
	DFE(13)=' '
	DFE(14)=')'
	CALL TYPGET(N1,N2,TYPE(1,1))
	IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
     1  WRITE(CMDLNA(1:127),DFE,ERR=4320)DVS(THISRW,THISCL)
	IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
     1   WRITE(CMDLNA(1:127),DFE,ERR=4320)LDVS(1,THISRW,THISCL)
C REDRAW THIS COL. WITH REVERSE VIDEO HERE.
4320	IF(PZAP.EQ.0)CALL SWRT(CMDLIN,CWIDS(THISRW))
C9800	FORMAT('+',128(A,'\'))
9000	FORMAT(128A1)
	IF(PZAP.EQ.0)CALL UVT100(13,0,0)
C NOTE THIS REDRAWS PREVIOUS COL. IN REVERSE VIDEO.
C NO CARRIAGE CTL
200	CONTINUE
	IF(PZAP.NE.0)GOTO 3608
	KKKK=JCHAR(FVLDTP)
C SKIP LAST LINE UPDATE IF NOT NEEDED FOR SPEEDIER CURSOR
C POSITIONING.
	IF(NULAST.EQ.NCEL.AND.LFVD.EQ.0.AND.KKKK.EQ.0)GOTO 222
	CALL UVT100(1,LLDSP,1)
	CALL UVT100(12,2,0)
	IF(JCHAR(FORM(1)).LE.0)GOTO 222
	DO 1711 IVVVV=1,109
    	IVV=110-IVVVV
	IF(JCHAR(FORM(IVV)).GT.32)GOTO 2711
1711	CONTINUE
2711	CONTINUE
	write(fwt(1:127),9092)ncel,(form(ii),ii=1,IVV)
9092	FORMAT(1X,I5,' Used. Curr=',109A1)
	IVV=IVV+18
	call swrt(fwt(1:127),IVV)
C3608	CONTINUE
222	CALL UVT100(1,LLCMD,1)
	NULAST=NCEL
	LFVD=KKKK
	CALL UVT100(12,2,0)
C NOTE PROW IS ACROSS TOP, PCOL IS DOWN SIDE
C PROW GOES AS ID1, ALPHAS
C PCOL GOES AS ID2, NUMERICS
	CALL IN2AS(PROW,FORM)
C NOTE PCOL STARTS AT 2 FOR NORMAL SHEET VARIABLES. PCOL=1 IS FOR ACCUMULATORS
	CALL UVT100(13,0,0)
C WRITE OUT LABEL WITH APPROPRIATE SIZE TO HOLD ROW NUMBER
C LET PROMPT END WITH > OR : DEPENDING ON OPERATING MODE.
	FVLDTP='>'
	IF(MODPUB.EQ.1)FVLDTP=':'
	IF(PCOL.GE.10000)GOTO 6401
	ii=pcol-1
	write(fwt(1:127),9001,err=3608)
     1   (form(i),i=1,4),ii,FVLDTP
C	FORM(9)=FVLDTP
	III=9
	GOTO 6402
6401	CONTINUE
	ii=pcol-1
	write(fwt(1:127),9401,err=3608)
     1   (form(i),i=1,4),ii,FVLDTP
C	FORM(10)=FVLDTP
	III=10
6402	CONTINUE
	CALL SWRT(fwt(1:127),III)
9401	FORMAT(4A1,I5,1A1)
9001	FORMAT(4A1,I4,1A1)
3608	CONTINUE
	IF(XTCFG.NE.0)GOTO 3870
	Rewind 11
	IF(IOLVL.NE.11.or.FH.eq.0)READ(IOLVL,9002,END=510,ERR=510)CMDLIN
C FOR READING THE CONSOLE, WE NEED A QIO$ TO CAPTURE ESCAPE SEQUENCES.
	IF(IOLVL.EQ.11.and.FH.ne.0)CALL GETTTL(CMDLIN)
	CALL GTMUNG(CMDLIN)
C ALLOW CMD LANGUAGE TO LOOK MORE "STANDARD" VIA MUNGE OF INPUTS
C TO DO THE "EV" OR "ET" OR "EN" FOR USER AND TREAT / AS CMD
C PREFIX...
	GOTO 3871
3870	CONTINUE
	XTCFG=0
	DO 3872 I=1,XTNCNT
	CMDLIN(I)=XTNCMD(I)
3872	CONTINUE
C COPY IN EXTERNAL COMMAND AND LET IT BE EXECUTED. IT'S THE USER'S
C PROBLEM IF THE COMMAND REQUIRES STILL FURTHER INPUT...
C ALSO NULL OUT SOME DELIMITER CHARS AFTER THE COMMAND READ IN.
	CMDLIN(XTNCNT+1)=Char(0)
	CMDLIN(XTNCNT+2)=Char(0)
3871	CONTINUE
9002	FORMAT(64A1,64A1,32A1)
	CMDLIN(132)=Char(0)
	CMDLIN(131)=Char(0)
	CMDLIN(130)=Char(0)
C  SAVE CURRENT PHYS ROW, COL IN AC'S X AND Y
	XXAC=PROW
	XYAC=PCOL
C ZAP IN SPECIAL FUNCTION KEY REPLIES INTO NORMAL FORMS
	CALL CMDMUN(CMDLIN)
	DO 9048 I=1,129
	K=130-I
C START AT BACK OF LINE AND ZAP WHITESPACE BY NULL TERMINATOR
	IF(ICHAR(CMDLIN(K)).GT.32)GOTO 9049
	CMDLIN(K)=Char(0)
C ALSO GET RID OF POSSIBLE TRAILING CR, LF.
9048	CONTINUE
9049	CONTINUE
C
C THIS GETS COMMAND LINE IN. NOW ACTON IT.
C REPOS'N TO OLD LINE NOW.
	CALL UVT100(1,LLCMD,1)
C
C THE FOLLOWING SECTION IMPLEMENTS THE ADDITIONAL FUNCTION OF
C JOURNALING: (DONE ON VAX ONLY SINCE SPACE REQUIREMENTS FOR FILE
C OPERATIONS MAY BE A PROBLEM ON PDP11'S).
C	Command +J FILENAME will record all remaining
C	line inputs at this point in it. (Assumes JNLFLG=0 initially)
C	Command +N closes journal file.
	K=K+1
	IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'J'.AND.JNLFLG.NE.1)
     1   GOTO 4290
	IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'N')GOTO 4292
	IF(JNLFLG.EQ.1)WRITE(10,9002)(CMDLIN(IV),IV=1,K)
	GOTO 4291
4292	CONTINUE
	CLOSE(10)
	JNLFLG=0
	GOTO 9990
4290	CONTINUE
	JNLFLG=1
C	USE WHATEVER FILE NAME THE USER HAS SUPPLIED AFTER THE +J
C	FOR FILE TO JOURNAL ONTO. (NO MORE QUESTIONS NEEDED.)
	CALL WASSIG(10,CMDLIN(4))
	GOTO 9990
4291	CONTINUE
C
C
C ALLOW COMMENTS IF LINE BEGINS WITH * (JUST LIKE CALC)
	IF(CMDLIN(1).NE.'*')GOTO 6002
	ICODE=1
C NO RECALC JUST FOR COMMENTS...
	GOTO 9990
6002	CONTINUE
C
C * NEW ****************
C ADD PLACE TO PUT IN USER COMMANDS. DEFAULT IS NONE EXIST, DO NOTHING
	IGOTIT=0
	CALL USRCMD(CMDLIN,ICODE,IGOTIT)
C WHEN WE GET A COMMAND, SET IGOTIT TO 1 AND WE THEN PROCESS COMMAND NORMALLY
	IF(IGOTIT.EQ.1)GOTO 9990
C * NEW ****************
C
C COMMAND -PROMPT  WILL READ FROM LUN 5 TO ARGSTR
C TERMINATING WITH SPACES.
	IF(CMDLIN(1).NE.'-')GOTO 350
	ICODE=5
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT(CMDLIN(2),49)
C	WRITE(0,9800)(CMDLIN(IV),IV=2,50)
	call vget(form2,128)
c	READ(11,9000,END=510,ERR=510)FORM2
	II=1
	KK=1
	DO 351 KKK=1,128
C LOAD UP OUR ARGUMENTS IN ARGSTR(N,1) TO ARGSTR(N,4)
	ARGSTR(KK,II)=FORM2(KKK)
	KK=KK+1
	ARGSTR(KK,II)=0
	IF(KK.LT.52)GOTO 352
354	KK=1
	II=II+1
	IF(II.GT.4)GOTO 353
352	CONTINUE
	IF(ICHAR(FORM2(KKK)).GT.32)GOTO 351
C ON SPACE, GO TO THE NEXT ARGUMENT. ALSO SPILL INTO
C THE NEXT ARGUMENT IF WE SEE NO SPACES AND JUST TRAIL ALONG.
	GOTO 354
351	CONTINUE
353	GOTO 9990
350	CONTINUE
C
C CONTROL SCROLLING. PERMIT THE COMMAND "SC" TO TURN SCROLLING ON
C AND "NS" TO TURN IT BACK OFF.
	IVV=-1
	IF(CMDLIN(1).EQ.'S'.AND.CMDLIN(2).EQ.'C')IVV=1
	IF(CMDLIN(1).EQ.'N'.AND.CMDLIN(2).EQ.'S')IVV=0
	IF(IVV.GE.0)IDOL7=IVV
	IF(IVV.GE.0)ICODE=5
	IF(IVV.GE.0)GOTO 9990
C
C ALLOW PROGRAMMED "REWIND" OF INPUT COMMAND LINE ON
C COMMAND LINE BEGINNING WITH "<". MAKE IT CONDITIONAL
C BY SAYING THAT IF % IS NEGATIVE WE WON'T DO IT.
	IF(CMDLIN(1).NE.'<')GOTO 356
	ICODE=5
	IF(XAC.GT.0..AND.IOLVL.NE.11)REWIND IOLVL
	GOTO 9990
356	CONTINUE
C
C HANDLE @FILE COMAND TO CHANGE TO INPUT OFF THAT FILE.
	IF(CMDLIN(1).NE.'@')GOTO 511
C WOW, A FILE. (OR AT LEAST SO WE HOPE).
	CALL RASSIG(3,CMDLIN(2))
C USE FACT THAT WE JUST NULL TERMINATED THE FILENAME PART AND SET
C IT TO BE LUN 3.
	IOLVL=3
C NOW GO BACK FOR ANOTHER COMMAND...NO SENSE WASTING RECALC TIME SINCE
C NOTHING HAS REALLY HAPPENED YET.
C NOTE EVERY READ TO LUN 3 HAS EOF/ERROR CHECK TO GO TO 510 TO RESET
C TO LUN 5 INPUT AND CLOSE FILE WE OPENED ON 3.
	GOTO 498
511	CONTINUE
C
C AA n R, AA n C, AR n R, AR n C COMMANDS
C
	IF(CMDLIN(1).NE.'O'.OR.CMDLIN(2).NE.'V')GOTO 6887
C OV + TURNS ON OVERRIDE
C OV - TURNS OFF OVERRIDE
C ALLOWS ONE TO OVERRIDE $ SIGN FORMS' ABSOLUTE NATURE
	IF(CMDLIN(3).EQ.'+'.OR.CMDLIN(4).EQ.'+')IDOL3=1
	IF(CMDLIN(3).EQ.'-'.OR.CMDLIN(4).EQ.'-')IDOL3=0
	GOTO 9990
6887	CONTINUE
	IF(CMDLIN(1).NE.'A')GOTO 8845
C ADD ROWS OR COLUMNS (OR REMOVE THEM) AT THE CURRENT PHYSICAL LOCATION
C WHERE AA MEANS ADD ABSOLUTE (NO RELOCATION), AR MEANS ADD RELOCATING
C (RELOCATE ALL VARIABLES BELOW), AND R OR C SAYS TO ADD/SEBTRACT ROWS
C OR COLUMNS.
C
C FIRST COLLECT THE ARGUMENTS TO THE FUNCTION.
	KM1=3
	KM2=10
	CALL GN(KM1,KM2,ICNT,CMDLIN)
C GETS THE NUMBER. IF NO NUMBER SEEN OR ZERO, RETURNS 0. IGNORE THEN.
	IF(ICNT.EQ.0)GOTO 9990
	ICR=0
C LOOK FOR THE R OR C
C START AT CMDLIN(4) TO PASS THE AR/AA AND THE NUMBER IF ANY.
	DO 8844 KKK=4,50
	IF(CMDLIN(KKK).EQ.'R')ICR=1
	IF(CMDLIN(KKK).EQ.'C')ICR=2
	IF(ICR.NE.0)GOTO 8846
C SKIP OUT ON FIRST ROW OR COLUMN DESIGNATOR SEEN
8844	CONTINUE
8846	CONTINUE
	IF(ICR.EQ.0)GOTO 9990
	ICODE=2
C NOW WE HAVE ALL ARGUMENTS. SET UP FOR THE COPY AND PARASITE THE
C LOGIC USED FOR THE CA OR CR COMMANDS. (NOTE THAT 2ND CHARACTER
C IS A OR R IN CMDLIN ALREADY SO THOSE COMMANDS' LOGIC WILL BE OK.)
	JRTR=PROW
	JRTC=PCOL
	IF(ICR.EQ.2)JRTC=1
	IF(ICR.EQ.1)JRTR=1
C RELOC THESHOLD IS PHYSICAL CURRENT POSITION.
	IF(ICR.EQ.1)GOTO 8843
C INSERT OR DELETE COLUMNS
C FIRST FIGURE OUT HOW MANY COLUMNS MUST BE MOVED RIGHT
	KD=MCols-PROW-IABS(ICNT)+1
C LET THIS WORK ONLY ON PRIME SHEET. TOO HARD TO FIGURE IT OUT ON REFLECTED
C ONES AND IT'LL FOUL LOTS OF USERS UP.
	IF(KD.LE.0)GOTO 9990
C CAN'T MOVE 0 COLUMNS. DOESN'T MAKE SENSE.
	DO 8842 KR=1,KD
	IRA=MCols-KR+1
C IRA IS DESTINATION COLUMN IN EACH LOOP.
	IF(ICNT.LT.0)IRA=PROW-1+KR
C IRS IS SOURCE COLUMN
	IRS=MCols-KR+1-ICNT
	IF(ICNT.LT.0)IRS=PROW+KR-ICNT-1
C
C IF DELETING COLUMNS AND DESTINATION IS PAST CURRENT
C ACTIVE MAX, SKIP THE MOVE SINCE WE'RE NOT ACCOMPLISHING ANYTHING.
	IF(ICNT.LT.0.AND.IRA.GT.RRWACT)GOTO 8842
C IF ADDING COLUMNS AND SOURCE IS PAST CURRENT MAX ACTIVE THEN
C WE'RE DOING NOTHING, SO SKIP THE WORK
	IF(ICNT.GT.0.AND.IRS.GT.RRWACT)GOTO 8842
	JDELT=RCLACT
C	JDELT=301
C LOOP WE'LL CALL IS OVER ENTIRE ROWS, BUT ONLY DO ONE AT A TIME HERE
	JD1A=IRA
	JD1B=1
	ID1A=IRS
	ID2A=1
	I1IN=0
	I2IN=1
	JIN1=0
	JIN2=1
	ASSIGN 8840 TO KPYBAK
C CALL INTERNAL COPY-RANGE PROCEDURE INSIDE CA/CR LOGIC
	GOTO 8364
8840	CONTINUE
8842	CONTINUE
C
C NOW CLEAN UP THE REST OF FORMULAS IF THERE ARE ANY TO DO...
C MUST RELOCATE OTHER FORMULAE IF CMDLIN(2) IS R
	KX=PROW-1
C RELY ON RCLACT HAVING BEEN UPDATED TO REFLECT NEW
C ADDITIONS IF ANY
	KY=RCLACT
C	KY=301
C RELOCATE UPPER LEFT PART OF SHEET
C NOTE II1,II2,JJ1,JJ2,JRTR,JRTC ARE UNCHANGED FROM PRIOR CALL SO
C MAY BE USED... RELVBL ONLY CARES ABOUT RELATIVE MOTION ANYHOW...
3600	CONTINUE
	IF(CMDLIN(2).NE.'R'.OR.KX.LE.0.OR.KY.LE.0)GOTO 9990
	DO 3601 KK=1,KX
	DO 3601 KK2=1,KY
	CALL FVLDGT(KK,KK2,FVLD(1,1))
	IF(ICHAR(FVLD(1,1)).NE.1)GOTO 3601
C ONLY RELOCATE FORMULAS, NOT TEXT OR NUMBERS (OR EMPTIES...)
C	IRX=(KK2-1)*60+KK
	CALL REFLEC(KK2,KK,IRX)
	CALL WRKFIL(IRX,FORM,0)
C	READ(7'IRX)FORM
	CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
	CALL WRKFIL(IRX,FORM2,1)
C	WRITE(7'IRX)FORM2
3601	CONTINUE
	GOTO 9990
8843	CONTINUE
C ROW INSERT/DELETE
C AGAIN FIND HOW MANY ROWS TO MOVE.
	KD=MRows-PCOL-IABS(ICNT)+1
	IF(KD.LE.0)GOTO 9990
	DO 8839 KC=1,KD
C ICA = DESTINATION AND ICS IS SOURCE
	ICA=MRows-KC+1
	ICS=MRows-KC+1-ICNT
	IF(ICNT.GT.0)GOTO 8838
	ICA=PCOL-1+KC
	ICS=PCOL+KC-1-ICNT
8838	CONTINUE
C IF INSERTING ROWS AND SRC ROW IS BEYOND ACTIVE AREA, SKIP
	IF(ICNT.GT.0.AND.ICS.GT.RCLACT)GOTO 8839
C IF DELETING ROWS AND DST ROW IS BEYOND ACTIVE AREA, SKIP
	IF(ICNT.LT.0.AND.ICA.GT.RCLACT)GOTO 8839
C NOW CALL COPY LOOP AGAIN.
	JDELT=RRWACT
C	JDELT=60
	JD1A=1
	JD1B=ICA
C DEST
	ID1A=1
	ID2A=ICS
C SOURCE
	I1IN=1
	I2IN=0
	JIN1=1
	JIN2=0
	ASSIGN 8836 TO KPYBAK
C CALL INTERNAL RANGE COPY PROCEDURE TO COPY A ROW
	GOTO 8364
8836	CONTINUE
8839	CONTINUE
	KX=RRWACT
C	KX=60
	KY=PCOL-1
	GOTO 3600
8845	CONTINUE
C OA AND OR COMMANDS. SET DISPLAY SHEET MAPPING TO ORIGIN AS FOUND BY
C  VARIABLE, STARTING AT 1,1 OR (DROW,DCOL) FOR OA AND OR RESPECTIVELY.
	IF(CMDLIN(1).NE.'O')GOTO 650
C PROCESS COMMAND...
	LRO=1
	LCO=1
	IF(CMDLIN(2).EQ.'R')LRO=MAX0(1,DROW)
	IF(CMDLIN(2).EQ.'R')LCO=MAX0(1,DCOL)
C OM will act like OR in that it will set the mapping of a
C display starting at the cursor, but unlike OR it will
C map multiple pages. When 3D actions are disabled it will
C do nothing.
	KORM=0
	IF(CMDLIN(3).NE.'M')GOTO 3944
	IF(K3DFG.LE.0)GOTO 3924
C OAMC/ORMC cell remaps display so that each display column is
C a column from the next lower sheet, so that, for example,
C a first column might be a1:a20, the next might be a1%1:a20%1,
C the next a1%2:a20%2 and so on.
C
C OAMR/ORMR cell remaps display so that each display row is a row
C from the next lower sheet, so that for example the first
C row might be a1:g1, the next a1%1:g1%1, the next a1%2:g1%2
C and so on. 
C
C  Thus the operation ORMC fills the 1st column with the current
C sheet, then the next with the offsets of the first plus the
C sheet offset, and so on. ORMR fills the 1st row with the
C current sheet, then sheet offsets down.
	IF(CMDLIN(4).EQ.'C')KORM=1
	IF(CMDLIN(4).EQ.'R')KORM=2
	IF(KORM.EQ.0)GOTO 3924
3944	CONTINUE
c *** 20 by 75 display constants hardcoded here:
	LRO=MIN0(LRO,19)
	LCO=MIN0(LCO,74)
C	LRO=MIN0(LRO,(20-1))
C	LCO=MIN0(LCO,(75-1))
C NOW HAVE CORRECT ORIGIN IN DISPLAY SHEET TO USE SET UP.
C GRAB VARIABLE ID.
	LA=INDX(CMDLIN,32)
	IF(LA.GT.20)LA=3
	LE=40
	CALL VARSCN(CMDLIN,LA,LE,LSTCX,ID1,ID2,IVLD)
	IF(IVLD.EQ.0)GOTO 651
C NOW HAVE VARIABLE NAME AND LOCATION... CAN DO IT FINALLY.
C NOTE WE'RE GUARANTEED WE START OFF IN BOUNDS BUT MUST CHECK
C ALONG THE WAY TO BE SURE WE STAY THAT WAY.
	IQQ=0
	KKKK=0
C allow a D modifier (for whatever it's worth) after
C the ORMR/ORMC/OAMR/OAMC commands. It will be as close to
C the normal OAD/ORD as practical under the circumstances of
C a totally different mapping scheme.
	IF(KORM.NE.0.and.CMDLIN(5).eq.'D')KKKK=1
	IF(CMDLIN(3).NE.'D')GOTO 6712
c allow ORA or ORD commands to leave window displacements
c alone. Fix up so this is default mode for scrolling (making
c program behavior easier to understand.)
7112	CONTINUE
	KKKK=1
6712	CONTINUE
	KKKKK=NRDSP(LRO,LCO)
	KKKKKK=NCDSP(LRO,LCO)
5711	CONTINUE
C TO ALLOW REFLECTIONS MUST ALLOW ALL SORTS OF ORIGINS.
	DO 652 IRO=LRO,DRWV
	DO 653 ICO=LCO,DCLV
C HERE CAN SET UP NRDSP AND NCDSP SUITABLY
	IVV=IRO-LRO
	IVVV=ICO-LCO
	IF(KKKK.EQ.0)GOTO 1653
	IVV=NRDSP(IRO,ICO)-KKKKK
	IVVV=NCDSP(IRO,ICO)-KKKKKK
1653	CONTINUE
	if(korm.ne.1)goto 2653
C OMC column mode remap.
C Bump offsets by kcdelt/krdelt as iro grows BUT
C not as ico grows.
	IVV=(LRO-1)+(iro-lro)*kcdelt
	IVVV=IVVV+(iro-lro)*krdelt
2653	Continue
	if(korm.ne.2)goto 2654
C OMR row mode remap.
C bump offsets by kcdelt/krdelt as ico grows BUT not as
C iro grows.
	IVV=IVV+(ico-lco)*kcdelt
	IVVV=(LCO-1)+(ico-lco)*krdelt
2654	Continue
	NRDSP(IRO,ICO)=ID1+IVV
	NCDSP(IRO,ICO)=ID2+IVVV
653	CONTINUE
652	CONTINUE
	IF(DROW.LE.0.OR.DCOL.LE.0)GOTO 3924
	PROW=NRDSP(DROW,DCOL)
	PCOL=NCDSP(DROW,DCOL)
3924	CONTINUE
C FORCE REDRAW OF WHOLE SHEET.
	ICODE=6
	IF(RCMODE.LE.0)GOTO 9990
C SKIP RECALC IF IN OLD MODE...
	ICODE=2
651	GOTO 9990
650	CONTINUE
C F FILENAME/NNN
C READ IN TEXT FROM FILE NAMED AND SPREAD ACROSS DISPLAY SCREEN. SET
C DISPLAYED SCREEN INTO FVLD(NN)=-1 TO SHOW TEXT ONLY.
	IF(CMDLIN(1).NE.'F')GOTO 1740
	LA=INDX(CMDLIN,32)
C PASS SPACE
	KKK=ICHAR('/')
	LB=INDX(CMDLIN(LA+1),KKK)
	LB=LB+LA
C LB= LOC OF / CHARACTER
	LB=MIN0(80,LB)
	IF(LB.LE.2)GOTO 1741
	IF((LB-LA).LE.1) GOTO 1741
	CMDLIN(LB)=0
	CALL RASSIG(4,CMDLIN(LA+1))
C THIS OUGHT TO OPEN THE FILE IF IT EXISTS..
C NOW IF THERE'S A NUMBER THERE, EXTRACT IT.
	LSKP=0
	IF(LB.GT.78.OR.LB.LE.5)GOTO 1743
	LAA=LB+1
	LAAA=LB+7
	CALL GN(LAA,LAAA,LSKP,CMDLIN)
1743	CONTINUE
C NOW SKIP THE LINES
	IF(LSKP.LE.0)GOTO 1744
	DO 1745 IV=1,LSKP
	READ(4,8201,END=1742,ERR=1742)FORM2
1745	CONTINUE
1744	CONTINUE
C NOW WE'RE READY TO READ IN THE STUFF.
	ICODE=2
	DO 1746 LA=1,DCLV
	DO 1751 IV=1,128
1751	FORM2(IV)=Char(32)
	READ(4,8201,END=1742,ERR=1742)FORM2
	IXC=0
	DO 1747 LB=1,DRWV
C DRWV = # ACROSS TOP...
C DCLV=LENGTH
	ID1=NRDSP(LB,LA)
	ID2=NCDSP(LB,LA)
C GET PHYSICAL SHEET COORDINATES AS ID1,ID2
C MUST THEN COPY CWIDS(LB) CHARS ONTO FILE...
	CALL FVLDST(ID1,ID2,char(255))
C	FVLD(ID1,ID2)=-1
C	IRX=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,IRX)

	CALL WRKFIL(IRX,FORM,0)
C	READ(7'IRX)FORM
	FORM(119)=Char(255)
	DO 1749 IVV=1,110
1749	FORM(IVV)=0
	DO 1748 IVV=1,CWIDS(LB)
	IXC=IXC+1
1748	FORM(IVV)=FORM2(IXC)
	CALL WRKFIL(IRX,FORM,1)
1747	CONTINUE
1746	CONTINUE
1742	CLOSE(4)
1741	GOTO 9990
1740	CONTINUE
	IF(CMDLIN(1).NE.'E')GOTO 8000
C ENTER COMMAND
C EN expression. expression may be numbers/text.
	LA=INDX(CMDLIN,32)
	LA=LA+1
C SKIP SPACE AFTER "EN"
	IF(LA.GT.4)LA=4
	IF (LA.GE.100)GOTO 7901
	LE=132-LA
	LE=MIN0(110,LE)
C	IRX=(PCOL-1)*60+PROW
	CALL REFLEC(PCOL,PROW,IRX)
C FIND WHERE IN FILE TO STORE.
	CALL WRKFIL(IRX,FORM2,0)
	CALL CE2A(FORM2,FORM)
C	READ(7'IRX)FORM
	IF(CMDLIN(2).EQ.'D')
     1   CALL SED(CMDLIN(LA),FORM,FORM2,ARGSTR,ZAC,110)
C IF COMMAND IS "ED <DELIM>STRING1<DELIM>STRING2<DELIM>" THEN
C  SUBSTITUTE STRING2 FOR STRING1 IN FORMULA, RETURN IT TO THE
C  COMMAND LINE, AND REENTER IT.
C  NOTE THAT THE STRINGS MAY CONTAIN &n FORMS WHERE 1-4 MEAN
C  ENTERED ARGUMENTS 1-4, 5 TREATS XAC AS A NUMBER, AND 6
C  TREATS ZAC AS A SINGLE CHARACTER (ZAC IS VARIABLE Z).
	DO 5133 II=1,110
5133	FORM(II)=0
	NALF=0
	NSG=-1
	NXNUM=3
	KSG=0
	N=1
	IRCE1=PROW
	IRCE2=PCOL
C SAVE FOR RE, RI MODES
	IF(CMDLIN(2).EQ.'T'.OR.CMDLIN(2).EQ.'"')KSG=1
C "ET" FORMULA ENTERS TEXT ONLY
C "EV" FORMULA ENTERS NUMBER
	IF(CMDLIN(2).EQ.'V')NSG=1
2097	CONTINUE
	IF(N.GT.LE)GOTO 7902
C	DO 7902 N=1,LE
C LOOK FOR ALPHAS. IF WE FIND ANY, FLAG NOT NUMERIC
C NOTE @ INCLUDED SINCE COULD HAVE A *@3 COMMAND TO CALL 3.CMD
C AND REFER TO OTHER CELLS.
C THIS IS A RESTRICTION: COMMANDS TO CMND NEED TO HAVE ALPHAS
C SOMEWHERE OR THIS WILL BE FOOLED.
	IF(CMDLIN(LA).EQ.'P'.AND.
     1  CMDLIN(LA+1).EQ.'#'.AND.
     2  CMDLIN(LA+2).EQ.'0'.AND.
     3  CMDLIN(LA+3).EQ.'#'.AND.
     4  CMDLIN(LA+4).EQ.'0') GOTO 3356
	IF(ICHAR(CMDLIN(LA)).GE.ICHAR('@').AND.ICHAR(CMDLIN(LA))
     1  .LE.ICHAR('Z'))NXNUM=1
3356	CONTINUE
	IF(CMDLIN(LA).EQ.'+'.OR.CMDLIN(LA).EQ.'-')NSG=1
	IF(CMDLIN(LA).EQ.'['.OR.CMDLIN(LA).EQ.'.')NSG=1
	IF(CMDLIN(LA).EQ.'(')NSG=1
	IF(CMDLIN(LA).EQ.'"')KSG=1
C ON SEEING THE _@V1,V2 CONSTRUCT, REPLACE WITH THE VARIABLE
C ADDRESSED BY V1,V2 (COL,ROW) BY NAME.
C ON SEEING THE _#V1 CONSTRUCT, UNPACK UP TO 8 CHARS OUT OF
C REAL*8 VARIABLE (PACKED BY MULTIPLYING BY 128 EARLIER).
C  IN EACH CASE, ADJUSTN AND LE TO CONTINUE APPROPRIATELY.
	IF(ICHAR(CMDLIN(LA)).GT.32)NALF=NALF+1
	IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'@')CALL
     1  SVBL(CMDLIN,LA,N,LE,FORM)
	IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'#')CALL
     1  SSTR(CMDLIN,LA,N,LE,FORM)
	FORM(N)=CMDLIN(LA)
	LA=LA+1
C FAKE OUT DO LOOP SINCE SVBL OR SSTR MAY MUNG INDICES INSIDE IT
	N=N+1
	GOTO 2097
7902	CONTINUE
	IF(KSG.NE.0)NSG=-1
	FORM(110)=0
	IF(ICHAR(FORM(119)).NE.0)GOTO 7903
C LEAVE DISPLAY INDICATOR ALONE IF SET BUT SET VBL OTHERWISE.
	IVVVV=NSG*NXNUM
	FORM(119)=CHAR(IVVVV)
C SET NEG FOR DISPLAY OF FORMULA, NOT NUMBER. ALLOWS TEXT ENTRY.
C ASSUME FORMULA IF WE SEE + OR -
7903	CONTINUE
C FORCE FORM TO FOLLOW EDITS EVEN IF FORMAT/TYPE PRESET.
	IVVVV=JCHAR(FORM(119))
	IF(IVVVV.NE.0)FORM(119)=CHAR(ISGN(IVVVV)*NXNUM)
	IF(NALF.LE.0)GOTO 6221
	CALL FVLDST(PROW,PCOL,FORM(119))
C ENCODE CELL NAMES PRIOR TO STORING
	CALL CA2E(FORM,FORM2)
	CALL WRKFIL(IRX,FORM2,1)
6221	CONTINUE
	ASSIGN 7904 TO NBK
	GOTO 7905
C LOOK UP PROW, PCOL, LEAVE DISPLAY COORDS IN LR,LC
7905	CONTINUE
	DO 7906 LA1=1,DRWV
	LR=LA1
	DO 7906 LA2=1,DCLV
	LC=LA2
	IF(NRDSP(LA1,LA2).EQ.PROW.AND.NCDSP(LA1,LA2).EQ.PCOL)GOTO7907
7906	CONTINUE
C IF WE FALL OUT OF THE LOOP, WE DIDN'T FIND THE LOC; FLAG BY PUTTING 0'S.
	LR=0
	LC=0
	GOTO 7908
7907	CONTINUE
C ARRIVE HERE ON SUCCESS. LR, LC ALL SET UP.
7908	CONTINUE
	GOTO NBK,(7904,8901,8957)
7904	CONTINUE
	IF(LR.EQ.0.OR.LC.EQ.0)GOTO 7901
	THISRW=LR
	THISCL=LC
C	ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
	LRO=1
	LCO=1
	ID1=NRDSP(1,1)
	ID2=NCDSP(1,1)
	IF(.NOT.(JMVFG.EQ.51.AND.THISRW.EQ.1))GOTO 7110
C MUST SCROLL LEFT
	IF(IDOL7.EQ.0)GOTO 7110
	IF(ID1.LE.1)GOTO 7110
	ID1=MAX0(1,ID1-DRWV+2)
	DROW=MAX0(1,DRWV-2)
	IQQ=1
	GOTO 7112
7110	CONTINUE
	IF(JMVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
	IF(.NOT.(JMVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 7116
C MUST SCROLL RIGHT
	IF(IDOL7.EQ.0)GOTO 7116
	DROW=3
C	ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
	ID1=ID1+DRWV-MIN0(DRWV,2)
	IQQ=1
	GOTO 7112
C 7112 FAKES OUT OA CALL TO SCROLL OVER.
7116	CONTINUE
	IF(JMVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
	IF(.NOT.(JMVFG.EQ.49.AND.THISCL.EQ.1))GOTO 7117
C MUST SCROLL UP
	IF(IDOL7.EQ.0)GOTO 7117
	IF(ID2.LE.2)GOTO 7117
	DCOL=MAX0(1,DCLV-2)
	ID2=MAX0(2,ID2-DCLV+2)
	IQQ=1
	GOTO 7112
7117	CONTINUE
	IF(JMVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
	IF(.NOT.(JMVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 7118
C MUST SCROLL DOWN
	IF(IDOL7.EQ.0)GOTO 7118
	DCOL=3
C	ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
	ID2=ID2+DCLV-MIN0(DCLV,2)
	IQQ=1
	GOTO 7112
7118	CONTINUE
	IF(JMVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
	DROW=THISRW
	DCOL=THISCL
	PROW=NRDSP(DROW,DCOL)
	PCOL=NCDSP(DROW,DCOL)
C FORCE REDO OF BOTH LAST AND NEW COLUMN BY DISPLAYER.
	DVS(LR,LC)=DVS(LR,LC)+.0000000057
	DVS(DROW,DCOL)=DVS(DROW,DCOL)+.000000062
7901	GOTO 9990
8000	IF(CMDLIN(1).NE.'M')GOTO 8001
	ICODE=1
C MACROCELL COMMAND IF MH (HIDE) OR MS (SHOW)
	IF(CMDLIN(2).EQ.'S')IDOL4=1
	IF(CMDLIN(2).EQ.'H')IDOL4=0
	IF(CMDLIN(2).EQ.'S'.OR.CMDLIN(2).EQ.'H')GOTO 9990
	IF(CMDLIN(2).NE.'D')GOTO 4401
C MD MODE COMMAND.
C  MDD=DISABLE 3D AND DISALLOW 3D VBL NAMES
C  MDN=NO 3D BUT ALLOW 3D VBL NAMES
C  MDE=ENABLE 3D. DON'T TRANSLATE VARIABLE NAMES
C  MDF=FORCE 3D, TRANSLATING VARIABLE NAMES
C    ALL THESE ALLOW 2 NUMBERS TO FOLLOW, BEING COLUMN AND
C    ROW DELTAS TO THE NEXT "PLANE".
	K3DFG=0
	IF(CMDLIN(3).EQ.'D')K3DFG=-2
	IF(CMDLIN(3).EQ.'N')K3DFG=0
	IF(CMDLIN(3).EQ.'E')K3DFG=1
	IF(CMDLIN(3).EQ.'F')K3DFG=999
C NOW GRAB ARGS IF ANY.
C USE INTERNAL PROCEDURE TO DECODE 2 NUMBERS STARTING AT CMDLIN(4)
C SKIP IF NEXT CHAR IS NOT NUMERIC.
	If(cmdlin(4).eq.' ')goto 4404
	IF(Ichar(CMDLIN(4)).LE.47.OR.
     1   Ichar(CMDLIN(4)).GT.57)GOTO 9990
4404	continue
	ASSIGN 4402 TO KBACK
	GOTO 8132
4402	CONTINUE
	IF(NCL.GE.0.AND.NCL.LT.Mrows)KCDELT=NCL
	IF(LCWID.GE.0.AND.LCWID.LT.Mcols)KRDELT=LCWID
	GOTO 9990
4401	CONTINUE
C MOVE COMMAND
C M1,M2,M3,M4 MOTION DIRECTION IS U,D,L,R
	IVVV=ICHAR(CMDLIN(2))
C ALLOW M0 TO MEAN RESTORE PRIOR STATE OF AUTOMOVE AND
C SAVE CURRENT STATE AS NEW PRIOR ONE. M1 THRU M5 MEAN SET
C AUTOMOVE TO 1-5 (5=NO MOTION) AND SAVE OLD STATE AS LAST
C STATE.
	IF(CMDLIN(2).EQ.'0')IVVV=JMVOLD
	JMVOLD=JMVFG
	JMVFG=IVVV
C	JMVFG=ICHAR(CMDLIN(2))
C STORE CHARACTER AS MOVE FLAG
	GOTO 9990
8001	IF(CMDLIN(1).NE.'D')GOTO 8002
C DISPLAY COMMANDS
C
C DISPLAY SORT
C DSRA 1
C DS = CONSTANT KEYWORD
C R/C=ROW/COL (DISPLAY COORD #S)
C A/D=ASCENDING/DESCENDING ORDER
C NUMBER= DISPLAY COORD ROW/COL # TO SORT ON.
C SORTS NUMERIC FIELDS ONLY.
	IF(CMDLIN(2).NE.'S')GOTO 1752
	ICODE=2
C MUST REDRAW. WE DO WHOLESALE RELOCATIONS OF THINGS HERE.
C FIRST GET ARGUMENTS
	LAA=6
	LBB=15
	CALL GN(LAA,LBB,NBR,CMDLIN)
C THIS EXTRACTS THE NUMBER OF ROW/COL TO USE.
C DEFAULT IS PHYS, COL, ASCENDING
C	IF(NBR.LE.0.OR.NBR.GT.MAX0(20,75))GOTO 9990
	IF(NBR.LE.0.OR.NBR.GT.75)GOTO 9990
	SSIGN=1.
	IF(CMDLIN(4).EQ.'D')SSIGN=-1.
C SSIGN USED TO CONTROL ASCENDING/DESCENDING SORT (MULTIPLY BY IT)
C GET LENGTH TO GO THRU IN SORT
	IF(CMDLIN(3).EQ.'C')IDELTA=DCLV-1
	IF(CMDLIN(3).EQ.'R')IDELTA=DRWV-1
	I1IN=0
	I2IN=1
C GET PHYSICAL COORDINATES OF ROW/COL WE'RE SORTING ON.
	IF(CMDLIN(3).EQ.'R')GOTO 6222
	ID1=NRDSP(NBR,1)
	ID2=NCDSP(NBR,1)
	GOTO 1753
6222	CONTINUE
	ID1=NRDSP(1,NBR)
	ID2=NCDSP(1,NBR)
	I1IN=1
	I2IN=0
C HACK TO HANDLE ROW/COL ALIKE
1753	CONTINUE
	IFLIP=0
C IFLIP = BUBBLESORT FLAG WE CHANGED SOMETHING
C (USE SIMPLE MINDED SMALL SORT. TOO MUCH OVHD FOR BETTER ONE...NO ROOM)
	ID1A=ID1
	ID2A=ID2
C IGNORE CASE OF IDELTA=0... SHOULDN'T BE ANY WAY FOR THAT TO HAPPEN
	DO 1754 IV=1,IDELTA
C SORT HERE. IFLIP=1 IF WE INVERT ANYTHING.
C JUST COMPARE XVBLS...
C NOTE WE ASSUME A "NORMAL" TYPE DISPLAY, JUST RESET PHYSICAL STUFF.
	CALL XVBLGT(ID1A,ID2A,XAC)
	CALL XVBLGT(ID1A+I1IN,ID2A+I2IN,XVBLS(1,1))
	IF(XAC*SSIGN.LE.XVBLS(1,1)*SSIGN)GOTO 1755
C FLIP ASSIGNMENTS
C FLIP XVBLS NUMBERS TOO TO MAINTAIN SORT. WE RECOMPUTE ANYWAY..
	CALL XVBLST(ID1A+I1IN,ID2A+I2IN,XAC)
	CALL XVBLST(ID1A,ID2A,XVBLS(1,1))
	IFLIP=1
C SWAP ASSIGNMENTS OF DISPLAY STUFF IF IN RANGE
C OPERATES LIKE A SORTED OA COMMAND
C CURRENT PHYSICAL ROW IS ID2A (1...RCL LIMITS)
C AND PHYS COL IS ID1A.
C	LDELTA=DRW-1
	LDELTA=19
C FOR REASSIGNMENT, ROLE OF I1IN,I2IN CAN BE REVERSED...
	ID1B=1
C NOTE DISPLAY ID2 IS 1 LESS THAN PHYSICAL ONE. (AC'S)
	ID2B=ID2A-1
	IF(ID2B.LE.0)GOTO 1754
	IF(CMDLIN(3).NE.'R')GOTO 1756
C ROW...
C	LDELTA=DCL-1
	LDELTA=74
C ID1 SAME AS DISPLAY COORDS
	ID1B=ID1A
	ID2B=1
1756	CONTINUE
	DO 1757 IVV=1,LDELTA
C FLIP THE ROW/COL 1 ENTRY AT A TIME. JUST CHANGES ASSIGNMENTS.
	JD1=NRDSP(ID1B,ID2B)
	JD2=NCDSP(ID1B,ID2B)
	NRDSP(ID1B,ID2B)=NRDSP(ID1B+I1IN,ID2B+I2IN)
	NCDSP(ID1B,ID2B)=NCDSP(ID1B+I1IN,ID2B+I2IN)
	NRDSP(ID1B+I1IN,ID2B+I2IN)=JD1
	NCDSP(ID1B+I1IN,ID2B+I2IN)=JD2
	ID1B=ID1B+I2IN
	ID2B=ID2B+I1IN
1757	CONTINUE
C WE CAN ALWAYS FLIP SINCE WE STAY ON DISPLAY SHEET.
1755	CONTINUE
	ID1A=ID1A+I1IN
	ID2A=ID2A+I2IN
1754	CONTINUE
C DONE 1 PASS. IF ANYTHING CHANGED, TRY AGAIN.
	IF(IFLIP.NE.0)GOTO 1753
C DONE SORT AT END
	GOTO 9990
1752	CONTINUE
C
	IF(CMDLIN(2).NE.'L')GOTO 8101
C DL = DISPLAY LOCATE V1:V2 N:M
	ASSIGN 8103 TO IBACK
	GOTO 8104
C STRIP VARIABLE NAMES OFF CMD LINE STARTING AT POSITION 3
8104	LA=3
	LE=98
	L1=0
	LPagmd=0
	LPag1=0
	LPag2=0
	CALL VARSCN(CMDLIN(1),LA,LE,LSTC,ID1A,ID2A,IVLD)
	L2=0
C L1,L2 = FLAGS VARIABLE 1,2 FOUND VALIDLY
	LA=LSTC+1
	LE=100-LA
	IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8102
	L1=1
	lpag1=kpag
	IF(CMDLIN(LSTC).eq.'}')Lpagmd=1
	IF((CMDLIN(LSTC).NE.':').and.(Cmdlin(Lstc).ne.'}'))
     1   GOTO 8102
	IF(CMDLIN(LSTC).NE.':')GOTO 8102
C MUST SEE : BETWEEN NAMES. NO SPACES PERMITTED.
	CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1B,ID2B,IVLD)
	IF(IVLD.LE.0)GOTO 8102
	lpag2=kpag
	L2=1
8102	CONTINUE
C NOTE THAT LSTC RETURNS AS CHARACTER AFTER VARIABLE LAST GRABBED IN INPUT LINE.
	GOTO IBACK,(8103,8112,8121,8301,8953,8900)
C NOW PICK UP RN:M OR CN:M (R=ROW,C=COL)
8103	CONTINUE
	IF(L1.LT.1)GOTO 8101
C INVALID UNLESS AT LEAST 1 VBL NAME SEEN.
	LA=LSTC+2
	RCF=0
	IF(CMDLIN(LSTC+1).EQ.'R')RCF=2
	IF(CMDLIN(LSTC+1).EQ.'C')RCF=1
	IF(RCF.EQ.0)GOTO 8101
	KM1=1
	CALL GN(KM1,LE,NUM1,CMDLIN(LA))
	IF(NUM1.EQ.0)GOTO 8101
	KKK=ICHAR(':')
	LE=INDX(CMDLIN(LA),KKK)
	NUM2=0
	IF(LE.GT.100)GOTO 8101
	LA=LA+LE
	KM1=1
	KM8=8
	CALL GN(KM1,KM8,NUM2,CMDLIN(LA))
C NOW NUM1,NUM2 ARE DESIRED ROW/COL RANGE. NOW SET UP DISPLAY.
	IF(NUM2.EQ.0.OR.NUM2.GT.75)GOTO 8101
	IF(NUM1.GT.20)GOTO 8101
C ILLEGAL ROW/COL IS A NO-GO.
C R N:M MEANS STARTING AT COL N ROW M GOING L TO R.
C C N:M MEANS DOWN STARTING THERE. DISPLAY COORDS ASSUMED.
	IF(ID1A.NE.ID1B.AND.ID2A.NE.ID2B)GOTO 8101
C ONLY HANDLE ROWS OR COLS, NOT DIAGONALS.
C MUST BE A PHYS MTX ROW OR COL.
	LRINC=0
	LCINC=0
	IF(RCF.EQ.1)LRINC=1
	IF(RCF.EQ.2)LCINC=1
	ASSIGN 8108 TO JBACK
	GOTO 8109
C COPY DATA
8109	CONTINUE
	ICODE=6
	IDELT=1
	IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B))+1
	I1IN=0
	I2IN=1
	IF(ID1A.EQ.ID1B)GOTO 8106
	I1IN=1
	I2IN=0
8106	CONTINUE
	ID1=ID1A
	ID2=ID2A
	GOTO JBACK,(8108,8113,8122,8307,8954)
8108	CONTINUE
	ICODE=1
	IR=NUM1
	IC=NUM2
C 1 DIM COPY OF DATA, FOR IDELT ELEMENTS.
	DO 8105 NM=1,IDELT
C CLAMP TO MAX DISPLAY ARRAY
	IF(IR.GT.20.OR.IC.GT.75)GOTO 8105
	NRDSP(IR,IC)=ID1
	NCDSP(IR,IC)=ID2
	DVS(IR,IC)=DVS(IR,IC)-1.E-14
C	THISRW=IR
C	THISCL=IC
C	JRX=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,JRX)
	CALL WRKFIL(JRX,FORM2,0)
C	READ(7'JRX)FORM2
C	DO 7104 N7=1,9
C7104	DFMTS(N7,IR,IC)=FORM2(N7+119)
C	DFMTS(10,IR,IC)=0
	IR=IR+LCINC
	IC=IC+LRINC
C NOTE REVERSAL FOR DISPLAY.
	ID1=ID1+I1IN
	ID2=ID2+I2IN
8105	CONTINUE
8101	CONTINUE
	IF(CMDLIN(2).NE.'F')GOTO 8111
C DF STUFF - SET FORMAT.
	ASSIGN 8112 TO IBACK
	GOTO 8104
8112	CONTINUE
C NOW HAVE VARIABLE ID'S SET UP
	IF(L1.LE.0)GOTO 8120
C MUST HAVE 1 OR MORE...
	ASSIGN 8113 TO JBACK
	GOTO 8109
C IDELT NOW SET UP. SET FORMATS UP NOW.
C FORMATS ARE IN [] BRACKETS. FIND THESE AND USE.
8113	CONTINUE
	ICODE=1
	KKK=ICHAR('[')
	LA=INDX(CMDLIN,KKK)+1
	KKK=ICHAR(']')
	LB=INDX(CMDLIN,KKK)-1
	LDELT=LB-LA+1
	LDELT=MIN0(LDELT,9)
	DO 8114 LN=1,IDELT
C IDELT IS OVER VRBL LIST GIVEN. MAY BE 1 ONLY.
C	IRRX=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,IRRX)
	CALL WRKFIL(IRRX,FORM,0)
C	READ(7'IRRX)FORM
	IF(CMDLIN(LA).EQ.'*')GOTO 7115
	IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')GOTO 7115
C KEEP EXISTING FORMAT IF [*] IS USED.
	DO 7989 KKKK=1,9
7989	FORM(119+KKKK)=Char(0)
	DO 8115 LNA=1,LDELT
	FORM(LNA+119)=CMDLIN(LA-1+LNA)
	IF(LNA.LT.9)FORM(LNA+120)=0
8115	CONTINUE
7115	CONTINUE
C	FORM(128)=0
	CALL FVLDGT(ID1,ID2,FVWRK)
	IVVVV=JCHAR(FVWRK)
	IF(IVVVV.EQ.0)IVVVV=3
C SET UP DEFAULT AS NUMERIC.
C	IVVVV=FVLD(ID1,ID2)
C	FVLD(ID1,ID2)=MAX0(1,IABS(IVVVV))
	IVVVV=MAX0(1,IABS(IVVVV))
	IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')IVVVV=
     1  MIN0(-1,-IABS(IVVVV))
	CALL FVLDST(ID1,ID2,CHAR(IVVVV))
	IF(CMDLIN(LA).EQ.'I')CALL TYPSET(ID1,ID2,4)
	IF(CMDLIN(LA).EQ.'F'.OR.CMDLIN(LA).EQ.'E')
     1   CALL TYPSET(ID1,ID2,2)
	FORM(119)=CHAR(IVVVV)
C
C TO BE SURE WE DON'T FOUL UP THE FILE, TRY AN ENCODE ON THIS FORMAT
C PRIOR TO THE WRITE. THAT WAY IF WE BOMB, THE FILE WE HAVE DIRECT ACCESS
C DATA ON IS NOT CLOBBERED.
	IF(IVVVV.LE.0)GOTO 7990
	DO 7988 KKK=1,9
	KKKK=ICHAR(FORM(119+KKK))
7988	DFE(KKK+1)=CHAR(MAX0(32,KKKK))
	DFE(1)='('
	DFE(12)=' '
	DFE(13)=' '
	DFE(14)=')'
	CALL TYPGET(N1,N2,TYPE(1,1))
	CALL FVLDGT(N1,N2,FVLD(1,1))
	IF(JCHAR(FVLD(1,1)).LE.0)GOTO 7990
	IF(TYPE(1,1).NE.2)GOTO 6223
	WRITE(WRKCHR(1:127),DFE,ERR=4302)DVS(THISRW,THISCL)
	GOTO 7990
6223	CONTINUE
        WRITE(WRKCHR(1:127),DFE,ERR=4302)LDVS(1,THISRW,THISCL)
7990	CONTINUE
	CALL WRKFIL(IRRX,FORM,1)
	DO 8116 NX1=1,20
	DO 8116 NX2=1,75
C LOCATE DISPLAY CELL IF ANY
	IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8117
8116	CONTINUE
	GOTO 8118
8117	CONTINUE
	DVS(NX1,NX2)=DVS(NX1,NX2)-1.23E-12
8118	CONTINUE
	ID1=ID1+I1IN
	ID2=ID2+I2IN
8114	CONTINUE
8111	CONTINUE
	IF(CMDLIN(2).NE.'T')GOTO 8120
C DT DISPLAY TYPE
	ASSIGN 8121 TO IBACK
	GOTO 8104
C GET VBL NAMES
8121	ASSIGN 8122 TO JBACK
	GOTO 8109
8122	LA=LSTC+1
	IF(L1.LE.0)GOTO 8120
	KTYP=2
	IF(CMDLIN(LA).EQ.'I')KTYP=4
	ICODE=1
	DO 8123 LNA=1,IDELT
	CALL TYPSET(ID1,ID2,KTYP)
C	TYPE(ID1,ID2)=KTYP
	DO 8126 NX1=1,DRWV
	DO 8126 NX2=1,DCLV
	IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8127
C FIND DISPLAY LOC IF ANY AND SET IT UP FOR REDRAW
8126	CONTINUE
	GOTO 8128
8127	CONTINUE
	DVS(NX1,NX2)=DVS(NX1,NX2)-1.211E-16
8128	CONTINUE
	ID1=ID1+I1IN
	ID2=ID2+I2IN
8123	CONTINUE
8120	CONTINUE
	IF(CMDLIN(2).NE.'W')GOTO 8130
C DW SETS COL WIDTH
	ASSIGN 8131 TO KBACK
	GOTO 8132
C GET 2 NUMBERS STARTING AT CMDLIN(4)
8132	CONTINUE
	KM1=1
	KM6=6
	CALL GN(KM1,KM6,NCL,CMDLIN(4))
	KKK=ICHAR(',')
	LA=INDX(CMDLIN(4),KKK)
C COMMA MUST BE SEPARATOR
	LCWID=7
	IF(LA.GT.100)GOTO 8138
	KM1=1
	CALL GN(KM1,KM6,LCWID,CMDLIN(LA+4))
8138	GOTO KBACK,(8131,8141,4402)
8131	CONTINUE
	ICODE=6
	NCL=MAX0(1,NCL)
	NCL=MIN0(NCL,20)
	LCWID=MAX0(1,LCWID)
	LCWID=MIN0(LCWID,110)
C COL WIDTH IS 3 TO 110 CHARS.
	IF(NCL.GT.0)CWIDS(NCL)=LCWID
8133	CONTINUE
8130	CONTINUE
	IF(CMDLIN(2).NE.'B')GOTO 8140
C DB = BOUNDS ON ROW,COL
	ASSIGN 8141 TO KBACK
	GOTO 8132
C PARASITE OTHER CODE TO GET DIGITS
8141	MC=NCL
	MR=LCWID
	MC=MIN0(MC,20)
	MR=MIN0(MR,75)
C CLAMP RANGE TO LEGAL
	IF(MC.GT.0)DRWV=MC
	IF(MR.GT.0)DCLV=MR
	ICODE=2
C REDRAW SCREEN WHEN BOUNDS CHANGE.
8140	CONTINUE
	GOTO 9990
8002	IF(CMDLIN(1).NE.'V')GOTO 8003
C VIEW REDRAW COMMAND
	IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')CALL SWSET(0)
	IF(CMDLIN(2).EQ.'I')CALL SWSET(1)
	IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')MODFLG=0
	IF(CMDLIN(2).EQ.'I')MODFLG=1
C VI MEANS VIEW IBM MODE, USING BIOS CALLS FOR DIRECT SCREEN OUTPUT.
	IF(CMDLIN(2).EQ.'C')CALL UVT100(20,0,0)
	IF(CMDLIN(2).EQ.'B')CALL UVT100(21,0,0)
C VC SETS VIEW COLOR MODE
C VB SETS VIEW B+W MODE
C REQUIRES UVTGEN MODULE...
	IF(CMDLIN(2).EQ.'H')GOTO 8320
8324	CONTINUE
	PZAP=0
	FORMFG=0
	IF(CMDLIN(2).EQ.'F')FORMFG=1
	IF(CMDLIN(2).EQ.'M')PZAP=1
	ICODE=6
	IF(CMDLIN(2).EQ.'E')ICODE=1
C VE JUST TURNS ON VIEW MODE, DOESN'T REPAINT ALL.
	GOTO 9990
8320	CONTINUE
	IF(CMDLIN(3).NE.'+'.AND.CMDLIN(3).NE.'-')GOTO 8324
C VH+ OR VH-, FLIP VIEW HACK TO SHOW PROGRESS
C DYMANICALLY
	IDOL8=1
	IF(CMDLIN(3).EQ.'-')IDOL8=0
C IDOL8 = 1 MEANS DO THE DISPLAY, 0 MEANS DON'T.
	ICODE=3
	GOTO 9990
8003	IF(CMDLIN(1).NE.'C'.AND.CMDLIN(1).NE.'I')GOTO 8004
C COPY NUMBERS COMMAND
C COPY (NUMBERS,FORMAT,DISPLAY,ALL)
C CV=COPY VALUE, CD=COPY DISPLAY FMT, CF=COPY FORMULA, CA=COPY ALL
C Ca V1:V2 V3:V4 COPIES FIRST RANGE TO SECOND.
C IR RANGES DOES INPLACE RELOCATION...
C
C COLLECT ARGS
	ASSIGN 8301 TO IBACK
	GOTO 8104
8301	CONTINUE
C NOW L1,L2 SAY IF VBLS(ID1A,ID2A) AND (ID1B,ID2B) EXIST
C also Lpagmd says if the first range is page range and
C Lpag1 and Lpag2 have page ranges.
C COLLECT JD2A,JD2B. USE SIMILAR INTERNAL PROCEDURE CODE.
	IF(L1.LE.0)GOTO 8399
	ASSIGN 8302 TO MBACK
	GOTO 8303
8303	CONTINUE
C COLLECT 2 VARS STARTING AT LSTC+3
C SKIPS LSTC DELIMITER.
	LJ1=0
	LJ2=0
	LA=LSTC+1
	LE=110-LA
	KPagmd=0
	KPag1=0
	KPag2=0
	IF(LE.LE.0)GOTO 8304
	CALL VARSCN(CMDLIN,LA,LE,LSTC,JD1A,JD1B,IVLD)
	LA=LSTC+1
	LE=110-LA
	IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8304
	KPag1=kpag
	LJ1=1
C allow } to indicate DEPTH oriented ranges but flag it.
	If(Cmdlin(lstc).eq.'}')KPagmd=1
	IF((CMDLIN(LSTC).NE.':').and.(Cmdlin(Lstc).ne.'}'))
     1    GOTO 8304
	CALL VARSCN(CMDLIN,LA,LE,LSTC,JD2A,JD2B,IVLD)
	IF(IVLD.LE.0)GOTO 8304
	KPag2=kpag
	LJ2=1
8304	GOTO MBACK,(8302)
8302	CONTINUE
	IF(LJ1.LE.0)GOTO 8399
	IDELT=1
	IPDL=0
	If(LPagmd.ne.0.and.Lpag2.gt.LPag1)ipdl=Lpag2-Lpag1
	If(K3Dfg.le.0)ipdl=0
	IF(L2.NE.0.AND.(ID1A.NE.ID1B.AND.ID2A.NE.ID2B))GOTO 8305
	IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B),
     1   IPDL)+1
	if(k3dfg.gt.0.and.lpagmd.ne.0.and.ipdl.gt.0)
     1  idelt=ipdl+1
	IKDelt=IDelt
8305	CONTINUE
	JDELT=1
	JPDL=0
	If(KPagmd.ne.0.and.Kpag2.gt.KPag1)JPDL=KPag2-KPag1
	If(K3Dfg.le.0)jpdl=0
	IF(LJ2.EQ.0)GOTO 8306
	IF(JD1A.NE.JD2A.AND.JD1B.NE.JD2B)GOTO 8306
	JDELT=MAX0(IABS(JD1A-JD2A),IABS(JD1B-JD2B),
     1    JPDL)+1
8306	IF(L2.NE.0)JDELT=MIN0(IDELT,JDELT)
C For page mode, difference is depth, not row or cols.
	if(k3dfg.gt.0.and.kpagmd.ne.0.and.jpdl.gt.0)
     1  jdelt=jpdl+1
C CHANGE FOR REPLICATE :  JDELT CAN BE JUST JDELT IF L2=0
	ASSIGN 8307 TO JBACK
C 8109 IS WHERE WE SET UP I1IN AND I2IN ASSUMING THAT THE VARIABLES
C ARE SET PROPERLY. HANDLED AS AN INTERNAL PROCEDURE.
	GOTO 8109
8307	CONTINUE
C 8109 procedure also resets IDELT
	If(k3dfg.gt.0)IDelt=IKDelt
	JIN1=1
	JIN2=0
	IF(JD1B.EQ.JD2B)GOTO 8308
	JIN1=0
	JIN2=1
8308	CONTINUE
C
C Change for 3D depth ranges:
C Reset I1IN and I2IN to KRDELT and KCDELT if depth mode and
C 3D stuff enabled. Reset JIN1 and JIN2 likewise if depth
C mode there.
C This has the advantage that it allows cells to be copied
C from any one dimensional range to any other, even if one
C or both 1-D ranges are in depth. A certain amount of hacking
C can allow cells possibly to be copied in overlapping pages
C also (for stuff like matrix traces).
	If(K3DFG.LE.0)goto 8610
	If(LPagmd.le.0)goto 8611
	I1IN=KCDELT
	I2IN=KRDELT
8611	Continue
	If(KPagmd.le.0)goto 8610
	JIN1=KCDELT
	JIN2=KRDELT
8610	Continue
C CHANGE FOR REPLICATE: IF L2 IS 0 (NO 2ND SRC VARIABLE), NO BUMPS
C PAST THE SINGLE VARIABLE SPECIFIED.
	IF(L2.EQ.0)I1IN=0
	IF(L2.EQ.0)I2IN=0
C FOR PCC-PC DO RECALC ALWAYS TO ALLOW DISPLAY TO LOOK OK
	ICODE=3
C	ICODE=1
C FORCE RECALC IF ONLY 1 SOURCE VARIABLE.
C	IF(L2.EQ.0)ICODE=3
	JRTR=PROW
	JRTC=PCOL
C JRTR AND JRTC = RELOCATION THRESHOLDS
C CELLS ABOVE OR LEFT OF JRTR,JRTC WILL NOT BE RELOCATED IN A CR
C OPERATION. THIS WILL GENERALLY BE THE PHYSICAL COLUMN OR ROW
C OF THE CURRENT POSITION. CELLS LOWER OR EQUAL, OR TO THE RIGHT
C OF THE CURRENT LOCATION OR EQUAL, WILL BE RELOCATED. (VARIABLE
C NAMES GET EDITED)
	ASSIGN 8365 TO KPYBAK
	GOTO 8364
C 8364 BEGINS COPY PROCEDURE SECTION
C GOES FOR JDELT CELLS WITH I1IN AND I2IN BEING SOURCE INCREMENTS FOR
C RRW DIMENSION, RCL DIMENSION, AND JIN1,2 BEING INCREMENTS FOR
C DESTINATION RRW,RCL DIMENSIONS RESPECTIVELY. USES CMDLIN(2) TO
C FLAG WHETHER TO HANDLE ALL, JUST FORMAT, RELOCATE, ETC.
C  ALSO ID1A,ID2A ARE START SOURCE LOCATION
C  JD1A,JD1B = DEST START LOCATION.
C
C COPIES 1 ROW OR COLUMN AT A TIME.
8364	CONTINUE
C	ICODE=1
C SET DISPLAY UPDATE ON COPIED CELLS
CCD	DO 3620 JV=1,BRRCL
CCD3620	IBITMP(JV)=0
	DO 8309 JV=1,JDELT
	DO 8380 NX1=1,DRWV
	DO 8380 NX2=1,DCLV
C LOCATE DISPLAY CELL IF ANY
	IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8387
8380	CONTINUE
	GOTO 8388
8387	CONTINUE
	DVS(NX1,NX2)=DVS(NX1,NX2)+1.245E-14
8388	CONTINUE
C	JRXX=(JD1B-1)*60+JD1A
C	IRXX=(ID2A-1)*60+ID1A
	CALL REFLEC(JD1B,JD1A,JRXX)
	CALL REFLEC(ID2A,ID1A,IRXX)
	CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
	KKKKK=JCHAR(FVLD(1,1))
	CALL FVLDGT(JD1A,JD1B,FVLD(1,1))
	IF(KKKKK.EQ.0.AND.ICHAR(FVLD(1,1)).EQ.0)GOTO 8314
C	IF(FVLD(ID1A,ID2A).EQ.0.AND.FVLD(JD1A,JD1B).EQ.0)GOTO 8314
	CALL WRKFIL(IRXX,FORM,0)
	CALL WRKFIL(JRXX,FORM2,0)
	IF(KKKKK.EQ.-2)CALL FVLDST(ID1A,ID2A,CHAR(253))
	IF(KKKKK.EQ.2)CALL FVLDST(ID1A,ID2A,CHAR(3))
	IF(jchar(FORM (119)).EQ. 2)FORM (119)=Char(3)
	IF(jchar(FORM (119)).EQ.-2)FORM (119)=Char(253)
	IF(jchar(FORM2(119)).EQ. 2)FORM2(119)=Char(3)
	IF(jchar(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
	IF(CMDLIN(2).NE.'R'.AND.CMDLIN(2).NE.'A')GOTO 8310
	IF(CMDLIN(2).NE.'R')GOTO 8366
C RELOCATE, THEN WRITE NEW CELL
	II1=ID1A
	II2=ID2A
	JJ1=JD1A
	JJ2=JD1B
	CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
C THE ABOVE WILL RELOCATE FORM INTO FORM2 WHICH WE NOW EMIT.
C ALLOW IR COMMAND TO DO INPLACE RELOCATION.
	IF(CMDLIN(1).NE.'I')GOTO 6224
	CALL WRKFIL(IRXX,FORM2,1)
	GOTO 9222
6224	CONTINUE
	CALL WRKFIL(JRXX,FORM2,1)
	GOTO 8367
8366	CONTINUE
	CALL WRKFIL(JRXX,FORM,1)
C	WRITE(7'JRXX)FORM
8367	CONTINUE
	CALL TYPGET(ID1A,ID2A,TYPE(1,1))
	CALL TYPSET(JD1A,JD1B,TYPE(1,1))
C	TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
C	XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
	CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
	CALL FVLDST(JD1A,JD1B,FVLD(1,1))
C	FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
9222	ID1A=ID1A+I1IN
	ID2A=ID2A+I2IN
	JD1A=JD1A+JIN1
	JD1B=JD1B+JIN2
	GOTO 8309
8310	CONTINUE
	IF(CMDLIN(2).NE.'V')GOTO 8312
	CALL TYPGET(ID1A,ID2A,TYPE(1,1))
	CALL TYPSET(JD1A,JD1B,TYPE(1,1))
C	TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
	CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
	CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
C	XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
8312	IF(CMDLIN(2).NE.'D')GOTO 8313
	CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
	CALL FVLDST(JD1A,JD1B,FVLD(1,1))
C	FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
	DO 8315 LXQ=1,10
8315	FORM2(118+LXQ)=FORM(118+LXQ)
	CALL WRKFIL(JRXX,FORM2,1)
C	WRITE(7'JRXX)FORM2
8313	IF(CMDLIN(2).NE.'F')GOTO 8314
	DO 8316 LXQ=1,110
8316	FORM2(LXQ)=FORM(LXQ)
	CALL WRKFIL(JRXX,FORM2,1)
8314	CONTINUE
	ID1A=ID1A+I1IN
	ID2A=ID2A+I2IN
	JD1A=JD1A+JIN1
	JD1B=JD1B+JIN2
8309	CONTINUE
C RETURN POINT FROM COPY LOOP IN NORMAL COPY
	GOTO KPYBAK,(8840,8836,8365)
8365	CONTINUE
8399	GOTO 9990
8004	IF(CMDLIN(1).LT.'1'.OR.CMDLIN(1).GT.'4')GOTO 8005
C 1,2,3,4 POSITIONING COMMANDS
C USE LLT AND LGT LEXICAL ORDERING TESTS, NOT ARITHMETIC ONES...
	ICODE=5
C	IF(CMDLIN(1).EQ.'3')THISRW=MAX0(1,(THISRW-1))
C	IF(CMDLIN(1).EQ.'4')THISRW=MIN0((THISRW+1),DRWV)
C	IF(CMDLIN(1).EQ.'1')THISCL=MAX0(1,(THISCL-1))
C	IF(CMDLIN(1).EQ.'2')THISCL=MIN0((THISCL+1),DCLV)
C COULD ADD SCROLLING HERE IF DESIRED.
C	ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
	MVFG=ICHAR(CMDLIN(1))
	LRO=1
	LCO=1
	ID1=NRDSP(1,1)
	ID2=NCDSP(1,1)
	IF(.NOT.(MVFG.EQ.51.AND.THISRW.EQ.1))GOTO 2110
C MUST SCROLL LEFT
	IF(IDOL7.EQ.0)GOTO 2110
	IF(ID1.LE.1)GOTO 2110
	ID1=MAX0(1,ID1-DRWV+2)
	DROW=MAX0(1,DRWV-2)
	IQQ=1
	GOTO 7112
2110	IF(MVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
	IF(.NOT.(MVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 2116
C MUST SCROLL RIGHT
	IF(IDOL7.EQ.0)GOTO 2116
	DROW=3
C	ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
	ID1=ID1+DRWV-MIN0(DRWV,2)
	IQQ=1
	GOTO 7112
C 7112 FAKES OUT OA CALL TO SCROLL OVER.
2116	IF(MVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
	IF(.NOT.(MVFG.EQ.49.AND.THISCL.EQ.1))GOTO 2117
C MUST SCROLL UP
	IF(IDOL7.EQ.0)GOTO 2117
	IF(ID2.LE.2)GOTO 2117
	DCOL=MAX0(1,DCLV-2)
	ID2=MAX0(2,ID2-DCLV+2)
	IQQ=1
	GOTO 7112
2117	IF(MVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
	IF(.NOT.(MVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 2118
C MUST SCROLL DOWN
	IF(IDOL7.EQ.0)GOTO 2118
	DCOL=3
C	ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
	ID2=ID2+DCLV-MIN0(DCLV,2)
	IQQ=1
	GOTO 7112
2118	IF(MVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
	PROW=NRDSP(THISRW,THISCL)
	PCOL=NCDSP(THISRW,THISCL)
	DROW=THISRW
	DCOL=THISCL
	GOTO 9990
8005	CONTINUE
8007	IF(CMDLIN(1).NE.'R')GOTO 8008
	IF(CMDLIN(2).NE.'B')GOTO 7333
C RB VAR SETS RELOCATE BOUNDARY TO VAR COORDS
	IF(CMDLIN(3).EQ.'*')GOTO 7332
C NORMAL RB COMMAND
C RB VAR USES VAR NAME TO RESET BDY
	LO=3
	KKKK=20
	CALL VARSCN(CMDLIN,LO,KKKK,IV,ID1,ID2,IVALID)
	IF(IVALID.LE.0)GOTO 9990
C IGNORE ERRORS
	IDOL5=ID1
	IDOL6=ID2
	GOTO 9990
7332	IDOL5=20000
	IDOL6=20000
C RB* RESETS RELOCATE BDY TO END OF SHEET
	GOTO 9990
7333	CONTINUE
C RECOMPUTE SHEET.
C RM COMMAND SETS MANUAL FLAG.
	RCFGX=0
c
	RCONE=0
	IF(CMDLIN(2).NE.'S')GOTO 5114
	RRWACT=MCols
	RCLACT=MRows
5114	CONTINUE
C RCFGX NONZERO INHIBITS RECALCULATION.
C RCONE SET 1 TO FORCE RECALC OF ALL.
C CHANGE FROM OTHER SYNTAX: RF FORCES RECALC, R DOES NOT.
	IF(CMDLIN(2).EQ.'F'.OR.CMDLIN(2).EQ.'R')RCONE=1
C NOTE RXF (X=ANY CHAR BUT F) ACTS LIKE OLD VERSION RXF.
C BARE R COMMAND HOWEVER JUST REDOES CALC. F NOW MEANS "FORCE"
C AND SEEMS A BIT MORE MNEMONIC THIS WAY. ALLOW RR COMMAND
C TO WORK AS WELL AS RF.
	IF(CMDLIN(2).NE.'R')RCMODE=0
	IF(CMDLIN(2).EQ.'E')RCMODE=1
	IF(CMDLIN(2).EQ.'I')RCMODE=2
C RE, RI MODE CONTROLS... ALSO RR ACTS LIKE RF BUT STAYS IN
C RE OR RI MODE... RECALC ENTRY OR INCREMENTAL...
	IF(CMDLIN(2).EQ.'M')RCFGX=1
	ICODE=3
C 3rd char I Inhibits recalc this time but sets modes...
	IF(CMDLIN(3).EQ.'I')ICODE=1
	GOTO 9990
8008	IF(CMDLIN(1).NE.'K')GOTO 8009
C DROP INTO CALC BARE.
	IF(IPSET.NE.0)GOTO 9990
C CAN'T CALL CALC RECURSIVELY
	OSWIT=0
	ILNFG=0
C	ICODE=-1
C CLOSE UNIT 1 JUST IN CASE...
	CLOSE(1)
	CALL UVT100(11,2,0)
C ERASE DSPLY
	KLVL=1
	ILNCT=0
C ICODE SET TO 420 SPECIAL CODE TO TELL MAIN PGM TO CALL INTERACTIVE
C CALCULATOR FCN.
	ICODE=420
	GOTO 9990
8009	IF(CMDLIN(1).NE.'L')GOTO 8010
C LOCATE CURSOR ORIGIN
C FORMAT IS L VARIABLE
C ONLY 1 VARIABLE NAME TO BE ENTERED.
	LA=2
	LE=30
	CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1A,ID2A,IVLD)
	L1=IVLD
C	ASSIGN 8900 TO IBACK
C	GOTO 8104
8900	IF(L1.LT.1)GOTO 9990
3800	PROW=ID1A
	PCOL=ID2A
C LOOK UP DISPLAY COORDS IF ANY
	ASSIGN 8901 TO NBK
	GOTO 7905
8901	CONTINUE
	DROW=LR
	DCOL=LC
	THISRW=LR
	THISCL=LC
3801	ICODE=1
	GOTO 9990
8010	CONTINUE
	IF(CMDLIN(1).NE.'>')GOTO 3802
C >STRING SEARCHES FORMULAE FOR STRING
	LA=MIN0(IDOL5,RRWACT)
	LB=MIN0(IDOL6,RCLACT)
C NO ACTION UNLESS VALID SEARCH REGION (CURRENT TO RELOC BDY)
C EXISTS.
	IF(LA.LT.PROW.OR.LB.LT.PCOL)GOTO 3801
	DO 3803 ID1=PROW,LA
	DO 3803 ID2=PCOL,LB
	ID1A=ID1
	ID2A=ID2
	CALL FVLDGT(ID1,ID2,FVLD(1,1))
	IF(JCHAR(FVLD(1,1)).EQ.0)GOTO 3803
C HAVE VALID CELL HERE, SO GRAB ITS FORMULA AND COMPARE FOR THE ONE
C WE'RE LOOKING FOR. IF CMD LINE STARTS WITH >> ANCHOR THE SEARCH AT 1ST
C COL.
	LMX=50
	LMN=2
	IF(CMDLIN(2).NE.'>')GOTO 3805
	LMX=1
	LMN=3
3805	CONTINUE
C	IRX=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,IRX)
	CALL WRKFIL(IRX,FORM,0)
	CALL CE2A(FORM,FORM2)
	DO 3804 IV=1,LMX
	KKKK=109-IV
C COMPARE FORMULA TEXT. USE EXISTING SCMP ROUTINE.
	CALL SCMP(CMDLIN(LMN),FORM2(IV),KKKK,KKK)
	IF(KKK.EQ.1.AND.JCHAR(FORM2(IV)).GT.0)GOTO 3800
	IF(JCHAR(FORM2(IV)).LE.0)GOTO 3803
3804	CONTINUE
3803	CONTINUE
C IF WE FALL THROUGH, WE FAILED TO FIND FORMULA SO FORGET IT.
	GOTO 3801
3802	CONTINUE
	IF(CMDLIN(1).NE.'Z')GOTO 8011
C ZERO COMMAND
C ZA OR ZE V1:V2
	IF(CMDLIN(2).NE.'A')GOTO 8950
C ZA = ZERO ALL. BE SURE HE MEANS IT.
	CALL UVT100(1,LLDSP,1)
c	WRITE(0,8951)
c8951	FORMAT('Really Zero All of sheet [Y/N]?\')
	call Vwrt('Really Zero ALL of sheet [Y/N]?',31)
	III=IOLVL
C	IF(III.EQ.5)III=0
	if(iii.ne.11)READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
	if(iii.eq.11)call vget(form2,4)
8952	FORMAT(4A1)
	ICODE=6
	IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
	CALL UVT100(11,2,0)
	ICODE=-4
	GOTO 9990
8950	IF(CMDLIN(2).NE.'E')GOTO 9990
	ASSIGN 8953 TO IBACK
	GOTO 8104
C GET NAMES
8953	IF(L1.LE.0)GOTO 9990
	ASSIGN 8954 TO JBACK
	GOTO 8109
8954	CONTINUE
	DO 8955 NI=1,128
8955	FORM2(NI)=0
	FORM2(118)=Char(15)
	DO 8823 NI=1,9
8823	FORM2(119+NI)=DEFVB(1+NI)
	DO 8956 NI=1,IDELT
C	IRX=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,IRX)
	CALL WRKFIL(IRX,FORM2,1)
	CALL FVLDST(ID1,ID2,CHAR(0))
	CALL XVBLST(ID1,ID2,0.0D0)
	IPRS=PROW
	IPCS=PCOL
	PROW=ID1
	PCOL=ID2
	ASSIGN 8957 TO NBK
C FIND DISPLAY LOC IF ANY
	GOTO 7905
8957	PROW=IPRS
	PCOL=IPCS
	IF(LR.EQ.0.OR.LC.EQ.0)GOTO 8958
	DVS(LR,LC)=DVS(LR,LC)+1.E-11
8958	CONTINUE
	ID1=ID1+I1IN
	ID2=ID2+I2IN
8956	CONTINUE
	GOTO 9990
8011	IF(CMDLIN(1).NE.'X')GOTO 8012
C EXIT TO OS
C SINCE THERE'S NO WORKFILE HERE, MAKE SURE HE MEANS IT...
	IF(IPSET.NE.0)GOTO 9990
	ICODE=2
	CALL UVT100(1,LLDSP,1)
        call 
     1 swrt('Exit now may lose data unless sheet has been saved'
     2 ,50)
	CALL UVT100(1,LLCMD,1)
	call Vwrt('Confirm Exit Request [Y/N]:',27)
	III=IOLVL
C	IF(IOLVL.EQ.5)III=0
	if(iii.ne.11)READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
	if(iii.eq.11)call vget(form2,4)
	IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
C END CALL TO GET OUT OF HERE
c	Close(unit=11)
	Close(unit=3)
	Call TTYDEI
        STOP
C	CALL EXIT
8012	IF(CMDLIN(1).NE.'S')GOTO 8013
C SAVE SHEET TO DISK (NEW SET OF DATA)
C NOW JUST PERMITS RESTART...
	ICODE=-2
	ISTAT=-2
	CALL UVT100(11,2,0)
	GOTO 9990
8013	IF(CMDLIN(1).NE.'P')GOTO 8014
	IRTN=0
	CALL PGET(CMDLIN,ICODE,IRTN)
	IF(IRTN.EQ.1)GOTO 510
	GOTO 9990
8014	CONTINUE
8015	IF(CMDLIN(1).NE.'G')GOTO 8016
C GET INPUT NUMBERS OFF SEQUENTIAL FILE. USE CURRENT ORIGIN
	ICODE=2
	IRTN=0
	CALL PGGET(CMDLIN,ICODE,IRTN)
	IF(IRTN.EQ.1)GOTO 510
C FLAG WE NEED AT LEAST ONE FULL CALC BEFORE GOING TO PARTIALS...
C (OK TOO IF IN OLD RCMODE=0 MODE)
	RCMODE=-IABS(RCMODE)
	GOTO 9990
8016	IF(CMDLIN(1).NE.'W')GOTO 8017
C WRITE (PRINT) SCREEN OUT TO FILE (MAY BE PRINTER)
C	CALL DSPSHT(10)
C	ICODE=1
	ICODE=400
C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
	GOTO 9990
8017	CONTINUE
	IF(CMDLIN(1).NE.'H')GOTO 5019
	IF(IPSET.NE.0)GOTO 9990
	IVVV=0
	IVVVV=ICHAR(CMDLIN(2))
	ivvx=ICHAR(cmdlin(3))
9308	CONTINUE
	IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
	if(ivvx.lt.48.or.ivvx.gt.57)goto 9381
c implement 2 digit help code.
	ivvvx=ivvx-48
	ivvv=(ivvv*10)+ivvvx
	ivvv=min0(ivvv,99)
9381	continue
C SELECT HELP LEVEL 0-9 IF SPECIFIED.
	ICODE=30+IVVV
	GOTO 9990
5019	CONTINUE
C *** ALLOW EVALUATION OF A CELL TO PERMIT INTERACTIVE COMMAND FILES TO
C *** BE CONTROLLED RATIONALLY. KEYWORD IS "TEST"
	IF(CMDLIN(1).NE.'T'.OR.CMDLIN(2).NE.'E')GOTO 4302
C TEST EXPRESSION IS SYNTAX.
C COPY CMDLIN INTO XTNCMD AND FLAG VIA ICODE=430
	XTNCNT=0
	ICODE=430
	DO 4307 N=1,80
4307	XTNCMD(N)=Char(0)
C FIRST ZERO OUT EXTERNAL CMD LINE, THEN FILL IN WHAT'S NEEDED.
	DO 4303 N=1,79
	XTNCMD(N)=CMDLIN(3+N)
C ALLOW "TE <ANY EXPRESSION>" WITH OPTIONAL SPACE. JUST RETURNS VALUE IN
C % VARIABLE.
	IF(ICHAR(XTNCMD(N)).LT.32)GOTO 4304
	XTNCNT=N
4303	CONTINUE
4304	CONTINUE
	XTNCMD(XTNCNT+1)=Char(0)
	GOTO 9990
4302	CONTINUE
C LET DOUBLE DOT (..) INDICATE TO GO BACK TO CONSOLE, CLOSING INPUT FILE
	IF (CMDLIN(1).EQ.'.'.AND.CMDLIN(2).EQ.'.')GOTO 510
C ELSE PRINT MESSAGE THAT WE DON'T UNDERSTAND THAT ONE & GO ON
C PRINT INVALID CMD MSG IF NOT JUST A SPACE OR C.R.
	IF(ICHAR(CMDLIN(1)).GT.32)CALL SWRT('Invalid Command.',16)
	GOTO 200
C ERROR ON READIN ADDRESS. REWIND TERMINAL IF USER
C TYPES CTRL Z (EOF), ELSE LEAVE INDIRECT FILES.
510	CONTINUE
C	IF(IOLVL.EQ.5)REWIND 5
	CLOSE(3)
c	CLOSE(11)
c	Rewind 11
c	OPEN(11,FILE='CON:0/0/100/100/Analy Command')
	IOLVL=11
	GOTO 498
9990	CONTINUE
C HERE CLEAN UP AND RETURN
C FIRST DISPLAY LAST CURRENT COL IN NORMAL VIDEO
	IF(IXLSTR.LE.0.OR.IXLSTC.LE.0)GOTO 2000
	N1=NRDSP(IXLSTR,IXLSTC)
	N2=NCDSP(IXLSTR,IXLSTC)
C	IRRX=(N2-1)*60+N1
	CALL REFLEC(N2,N1,IRRX)
C REWRITE LAST LOCATION WITH NO REVERSE VIDEO.
C	IF(FVLD(N1,N2).EQ.0)GOTO 2000
	IF(IXLSTC.GT.DCLV.OR.IXLSTR.GT.DRWV)GOTO 2000
C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
	IF(ICODE.LT.0.OR.ICODE.EQ.2)GOTO 2000
C NO SENSE REDRAWING IF WE'RE ABOUT TO ERASE DISPLAY ANYWAY.
	IF(ICODE.GT.30)GOTO 2000
	J=8
C ADD 6 COLS FOR LABELS
C DROW,DCOL IS CURRENT DISPLAY LOC.
	DO 3301 M1=1,IXLSTR
C FIND DISPLAY COLUMN TO USE
3301	J=J+CWIDS(M1)
	J=J-CWIDS(IXLSTR)
C USE THISCL+1 TO LET 1ST ROW BE LABELS.
	ICCC=IXLSTC+2
C JVTINC = 1 IF VT100, 0 IF VT52
C JVTINC NEEDED SINCE UVT100 FOR VT100 DOES BACKSPACE AT THE SGR ENTRY
C AND THUS WE NEED TO CORRECT FOR IT. THIS WAS FIXED IN THE UVT52
C VERSION AND ITS DESCENDANTS.
	IC1POS=N1
	IC2POS=N2
	IF(PZAP.NE.0)GOTO 2000
	CALL UVT100(1,ICCC,J)
C SELECT ROW "IXLSTC", COL "J"
	CALL UVT100(13,0,0)
C DESELECT REVERSE VIDEO
	CALL FVLDGT(N1,N2,FVLDTP)
	ivv=min0(30,cwids(IXLSTR))
	IF(ICHAR(FVLDTP).EQ.0)CALL SWRT(BLANKS,IVV)
	IF(ICHAR(FVLDTP).EQ.0)GOTO 2000
	CALL WRKFIL(IRRX,FORM2,0)
	CALL CE2A(FORM2,FORM)
C	READ(7'IRRX)FORM
	DO 5546 KKKK=1,100
	IV=ICHAR(FORM(KKKK))
	IV=MAX0(IV,32)
5546	FORM(KKKK)=Char(IV)
	IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
     1  WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
C FILL IN TEXT FOR FORMULA IF FVLD < 0 HERE; BELOW, FILL IN VALUE TEXT IF FVLD
C > 0.
	IF(FORMFG.NE.0)GOTO 4324
C ALWAYS DO FORMULAS IF FORMFG SET (VF MODE).
	DO 6302 KKK=1,9
	KKKK=ICHAR(FORM(KKK+119))
C	KKKK=DFMTS(KKK,IXLSTR,IXLSTC)
6302	DFE(KKK+1)=CHAR(MAX0(32,KKKK))
	DFE(11)=char(32)
C 32 = ASCII SPACE
	DFE(1)='('
C REMEMBER: NO \ EDITING IN INTERNAL WRITES!
	DFE(12)=' '
	DFE(13)=' '
	DFE(14)=')'
	CALL TYPGET(N1,N2,TYPE(1,1))
	IF(JCHAR(FVLDTP).LE.0)GOTO 4324
	IF(TYPE(1,1).NE.2)GOTO 6226
        WRITE(CMDLNA(1:127),DFE,ERR=4324)DVS(IXLSTR,IXLSTC)
	GOTO 4324
6226	CONTINUE
	WRITE(CMDLNA(1:127),DFE,ERR=4324)LDVS(1,IXLSTR,IXLSTC)
C REDRAW THIS COL. WITHOUT REVERSE VIDEO HERE.
4324	CALL SWRT(CMDLIN,CWIDS(IXLSTR))
C NOTE THIS REDRAWS PREVIOUS COL. IN NORMAL VIDEO.
C NO CARRIAGE CTL
2000	CONTINUE
C NOW COMPLETE ANY CLEANUP.
C SET CMDLIN TO 0 AT START TO INHIBIT ANY MISINTERPRETATION.
C WE USE CMDLIN AS A BUFFER IN REDRAWIND DSPLY SO DON'T LET IT GET
C CLOBBERED.
	DO 945 K=1,132
945	CMDLIN(K)=Char(0)
	RETURN
	END

C *************** AnalyNS.Ftn #####################################
c -h- nextel.fms	Tue Sep  2 10:58:55 1986	
	SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C  SCANS LINE(80) FROM NONBLK+1 AND RETURNS THE NEXT ELEMENT.
C  THIS ELEMENT COULD BE A CONSTANT, VALUE OF A VARIABLE, A
C  BINARY FUNCTION CODE, OR A UNARY FUNCTION CODE. UPON RETURN,
C  NONBLK POINTS TO LAST CHARACTER OF NEXT ELEMENT.
C
C  RETCD  =	1  IF OPERAND (VALUE IN RETVAL(100)
C		2  IF OPERATOR (VALUE IN RETTYP)
C		3  NO MORE ELEMENTS
C		4  IF ERROR
C
C  RETVAL  HOLDS VALUE OF OPERAND FOUND (EITHER CONSTANT OR IF
C	   A VARIABLE (A-Z,%), THE VALUE OF THAT VARIABLE)
C
C  RETTYP  IS THE TYPE CODE
C NEXTEL CALLS
C
C ERRMSG     PRINTS OUT ERROR MESSAGES
C FLIP       REVERSES THE NON-LEADING ZERO DIGITS IN A VECTOR
C GETNNB     GETS THE NEXT NON-BLANK FROM LINE(80)
C
C NEXTEL IS CALLED BY INPOST
C
C
C    VARIABLE    USE
C    ---------   ----------------------------------
C
C    ALPHA(27)   HOLDS LEGAL VARIABLE NAMES.
C
C    ARROW       '^'
C
C    B10         SWITCH SET WHEN CONSTANT IS NOT OCTAL (MAY BE
C                DECIMAL OR HEX BECAUSE THE DIGIT 8 OR 9 WAS FOUND).
C
C    B16         SWITCH SET WHEN CONSTANT IS HEXADECIMAL BECAUSE
C                DIGIT A, B, C, D, E, OR F WAS FOUND.
C
C    BASE        HOLDS BASE OF CONSTANT.
C
C    CHAR1       HOLDS A SINGLE CHARACTER FROM LINE.
C
C    DEFBAS      THE DEFAULT BASE SPECIFIED.
C
C    DIGITS(16,3) HOLDS ASCII CHARACTERS FOR THE DIGITS OF BASES
C                 8, 10, AND 16.
C
C    DOT          '.'
C
C    EQ           '='
C
C    EXCODE       CODE FOR EXPONENTIATION.
C
C    FCNT         NUMBER OF UNARY FUNCTIONS DEFINED BY VECTOR FUNCT
C
C    FUNCT (NAME,INDXX) HOLDS FUNCTION NAMES.
C
C    FUNVAL(I,J)
C     IF I=1, THE VALUE IS THE NUMBER OF CHARACTERS IN THE J-TH
C             FUNCTION WHOSE NAME IS THE FUNCT(K,J) WHERE K=1,2,3...10
C     IF I=2, THE VALUE IS THE STACK ELEMENT CODE FOR THE J-TH
C             FUNCTION WHOSE NAME IS IN FUNCT(K,J), K=1,2,3...10
C
C
C    I,J,K,L  HOLDS TEMPORARY VALUES
C
C    I1,I2    HOLD VALUE OF DIGITS IN E OR D SPECIFICATION.
C
C    IALPHA   INDEX INTO ALPHA OF THE FIRST NON-BLANK CHARACTER FOUND.
C
C    IHOLD    HOLDS TEMPORARY VALUES
C
C    INT      PICKS UP INTEGER*4 VALUES.
C
C    IPT      POINTER TO ELEMENTS IN LINE(80).
C
C    IPT2     POINTER TO ELEMENTS IN LINE(80).
C
C    LASTOP  USED TO HOLD VALUE OF LAST OPERATOR SO THAT UNARY OPERATORS
C            CAN BE IDENTIFIED IN CASES LIKE A*-B AND A/(-3).
C
C    MINUS   '-'
C
C    OPER(9) HOLDS LEGAL ONE CHARACTER OPERATORS LIKE '+' AND '*'.
C
C    PLUS    '+'
C
C    QUOTE   "'"
C
C    RB      HOLDS NEGATIVE POWERS OF 10.(BASE 10)
C
C    REAL    PICKS UP REAL*8 CONSTANTS.
C
C    RETCD   RETURN CODE:
C              1 IF OPERAND (VALUE IN RETVAL(100))
C              2 IF OPERATOR (VALUE IN RETTYP)
C              3 NO MORE ELEMENTS.
C              4 IF ERROR.
C
C    RETCD2  RETURN CODE WHEN CALLING GETNNB.
C
C    RETPT   INDEXES DIGITS PICKED UP FOR A CONSTANT.
C
C    RETTYP  THE TYPE CODE OF THE RETURNED ELEMENT.
C
C    TYPE    TYPE CODE FOR EACH VARIABLE.
C
C    VBLS    HOLDS VALUE OF VARIABLES.
C
C    VLEN    GIVES LENGTH IN BYTES FOR EACH DATA TYPE.
C
C LASTOP MUST BE SET TO ZERO AT START OF EXPRESSION
C
C
	REAL*8 REAL,RB,ACX,XAC
	INTEGER*4 INT
	EXTERNAL INDX,DFLOAT
	REAL*8 DFLOAT
	InTeGer*4 INDXX
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 LASTOP
	InTeGer*4 VIEWSW,BASED,VLEN(9),DEFBAS
	InTeGer*4 TYPE(1,1)
	InTeGer*4 RETCD,RETCD2,RETTYP,EXCODE
	InTeGer*4 B10,B16,RETPT,BASE
	InTeGer*4 FCNT,AHOLD
	InTeGer*4 I,J,K,L,IALPHA,IHOLD,IPT,IPT2,I1,I2
C
	CHARACTER*1 CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
	CHARACTER*1 RETVAL(20)
C	REAL*8 RVLF
C	EQUIVALENCE (FVLF,RETVAL(1))
	CHARACTER*1 FUNCT(10,40)
	InTeGer*4   FUNVAL(2,40)
	CHARACTER*1 AVBLS(20,27)
	EQUIVALENCE(XAC,AVBLS(1,27))
	CHARACTER*1 VBLS(8,1,1)
	CHARACTER*1 OPER(9),DIGITS(16,3)
	CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	CHARACTER*1 FOUR(4),EIGHT(8)
C
	COMMON /V/ TYPE,AVBLS,VBLS,VLEN
	COMMON /DIGV/ DIGITS
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
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
c	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 /ERROR/ LASTOP
C
	EQUIVALENCE (REAL,EIGHT),(FOUR,INT)
C
	DATA DOT/'.'/,ARROW/'^'/,QUOTE/''''/,STAR/'*'/
	DATA MINUS/'-'/,PLUS/'+'/
	DATA OPER/'(','-','!','*','/','+','-',')','='/
C
C  NUMBER OF FUNCTIONS
	DATA FCNT/30/
C
	DATA FUNCT/'A','B','S',' ',' ',' ',' ',' ',' ', ' ',
     1             'D','A','B','S',' ',' ',' ',' ',' ',' ',
     2             'I','A','B','S',' ',' ',' ',' ',' ',' ',
     3             'F','L','O','A','T',5*' ','I','F','I','X',6*' ',
     5             'A','I','N','T',6*' ','I','N','T',7*' ',
     7             'I','D','I','N','T',5*' ','E','X','P',7*' ',
     9             'D','E','X','P',6*' ','A','L','O','G','1','0',4*' ',
     2             'D','L','O','G','1','0',4*' ','A','L','O','G',6*' ',
     4             'D','L','O','G',6*' ','S','Q','R','T',6*' ',
     6             'D','S','Q','R','T',5*' ','S','I','N',7*' ',
     8             'D','S','I','N',6*' ','C','O','S',7*' ',
     1             'D','C','O','S',6*' ','T','A','N','H',6*' ',
     2             'D','T','A','N','H',5*' ','A','T','A','N',6*' ',
     3             'D','A','T','A','N',5*' ',
     1             'A','S','I','N',6*' ','D','A','S','I','N',5*' ',
     2             'A','C','O','S',6*' ','D','A','C','O','S',5*' ',
     3             'T','A','N',' ',6*' ','D','T','A','N',106*' '/
	DATA EXCODE/112/
       DATA FUNVAL/3,31,4,31,4,32,5,33,4,34,4,35,3,36,5,36,3,37,4,37,
     1 6,39,6,39,4,38,4,38,4,40,5,40,3,41,4,41,3,42,4,42,4,43,5,43,
     2       4,44,5,44,4,45,5,45,4,46,5,46,3,47,4,47,20*0/
C
10	CONTINUE
	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 50
C
C  NO MORE ELEMENTS
	LASTOP=0
	RETCD=3
	RETURN
C
C
C  INITIALIZE VARIABLES
50	CONTINUE
	B10=0
	B16=0
	RETTYP=0
	RETPT=0
	REAL=0.D0
	RETCD=1
	DEFBAS=BASED
C	RVLF=0.0D0
C COMMENT OUT DO LOOP OVER 20 BYTES FOR SPEED.
C (INSTEAD JUST ZERO 8 BYTES WE WILL LIKELY USE)
	DO 60 I=1,8
C	DO 60 I=1,20
60	RETVAL(I)=0
C
70	CHAR1=LINE(IPT)
	NONBLK=IPT
C
C
C  SEE IF ALPHABETIC OR %
C SHORTCUT IF IT'S A CELL NAME .. GO JUST EVALUATE IT.
C ALSO WORKS FOR ENCODED FUNCT NAMES.
	IF(ICHAR(CHAR1).GE.255)GOTO 12000
C SEPARATE OUT FUNCTION CALLS FOR FASTER EXECUTION...SKIP TRYING FUNCT. NAME
C FIRST AS VARIABLE NAME (WHICH CAN TAKE LONG TIME TO CONVERT BEFORE WE DISCOVER
C IT ISN'T NEEDED...)
C
	IF(ICHAR(CHAR1).GE.230)GOTO 13201
C ADD COUPLE MORE SHORTCUTS... DON'T JUST LOOP TO SEE IF WE HAVE
C AN ALPHA CHARACTER...
	IF(CHAR1.NE.ALPHA(27))GOTO 78
	I=27
	GOTO 10000
78	CONTINUE
	IF(CHAR1.LT.'A'.OR.CHAR1.GT.'Z')GOTO 79
C TRY TO AVOID LOTS OF EXTRA FUNCTION CALLS...
C COMPARE CHARS AS CHARACTER VALUES... SHOULD STILL BE OK.
CCC	IF(ICHAR(CHAR1).LT.ICHAR(ALPHA(1))
CCC     1  .OR.ICHAR(CHAR1).GT.ICHAR(ALPHA(26)))GOTO 79
C USE FACT THAT ASCII CHARACTER CODES ARE IN A CONTINUOUS RANGE
CCC	I=ICHAR(CHAR1)-ICHAR(ALPHA(1))
	I=ICHAR(CHAR1)-65
C 65 IS ASCII VALUE FOR 'A' CHARACTER.
C (HARDCODE FOR SPEED...)
	GOTO 10000
79	CONTINUE
C DELETE 3 LINES FOLLOWING:
C	DO 80 I=1,27
C	IF (CHAR1.EQ.ALPHA(I)) GOTO 10000
C80	CONTINUE
C
C
C  NOT ALPHA SO SEE IF AN OPERATOR
	DO 100 I=1,9
	IF (CHAR1.EQ.OPER(I)) GOTO 20000
100	CONTINUE
C
C
C SEE IF AN OPERAND
C *** EVIDENTLY SHORT LOOP RUNS AS FAST AS A COUPLE DECISIONS AND SOME
C MATH; LEAVE IN.
140	DO 150 I=1,16
	IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
150	CONTINUE
C
C
C
	IF (CHAR1.EQ.DOT) GOTO 40000
C
C
C
	IF (CHAR1.EQ.ARROW) GOTO 300
C
C
C
	IF (CHAR1.EQ.QUOTE) GOTO 200
C
C
C  ADDITIONAL CONSTANT OPERATOR WOULD GO HERE
C
C
C *** ERROR *** ILLEGAL CHARACTER ENCOUNTERED
190	CALL ERRMSG (20)
	GOTO 99000
C
C
C
C
C **************************************
C ****** ASCII CONSTANT SPECIFIED ******
C **************************************
200	CONTINUE
	NONBLK=NONBLK+1
	RETVAL(1)=ICHAR(LINE(NONBLK))
	RETTYP=1
	GOTO 35100
C
C
C
C
C **************************************
C ****** IMMEDIATE BASE SPECIFIED ******
C **************************************
300	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 320
C
C
C *** ERROR *** ILLEGAL BASE SPECIFICATION
310	CALL ERRMSG(19)
	GOTO 99000
C
C
C  IMMEDIATE BASE SPECIFICATION
320	CHAR1=LINE(IPT)
	NONBLK=IPT
	IF (CHAR1.EQ.DIGITS(8,3)) GOTO 360
	IF (CHAR1.NE.DIGITS(1,3)) GOTO 310
C
C
C FIRST DIGIT IS 1 SO IMMEDIATE BASE MIGHT BE 10 OR 16
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.EQ.2) GOTO 310
	CHAR1=LINE(IPT)
	NONBLK=IPT
	IF (CHAR1.EQ.DIGITS(10,1)) GOTO 365
	IF (CHAR1.NE.DIGITS(6,1)) GOTO 310
C
C
C IMMEDIATE BASE IS 16
	DEFBAS=16
	GOTO 370
C
C
C IMMEDIATE BASE IS 8
360	DEFBAS=8
	GOTO 370
C
C
C IMMEDIATE BASE IS 10
365	DEFBAS=10
C
C
C
370	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.2) GOTO 310
	CHAR1=LINE(IPT)
	NONBLK=IPT
C
C
C GO FIND OUT WHAT NUMBER HAS THAT DEFAULT BASE
	GOTO 140
C
C
C
C
C ****************************************************
C ****** SEARCH TO SEE IF A UNARY FUNCTION NAME ******
C ****************************************************
10000	CONTINUE
	IALPHA=I
	IHOLD=NONBLK
C
C
C SCAN EACH OF THE FUNCTION NAMES.
	DO 10060 I=1,FCNT
C
C K HOLDS NUMBER OF NON-BLANK CHARACTERS IN THE FUNCTION NAME.
	K=FUNVAL(1,I)
	IPT2=IHOLD
	NONBLK=IHOLD
	IF (K.EQ.0) GOTO 10060
C
C
C SCAN EACH LETTER OF THE FUNCTION'S NAME
	DO 10050 J=1,K
	IF (LINE(IPT2).NE.FUNCT(J,I)) GOTO 10060
	IF (J.EQ.K) GOTO 10100
	CALL GETNNB (IPT2,RETCD2)
	IF (RETCD2.EQ.2) GOTO 10060
	NONBLK=IPT2
10050	CONTINUE
	STOP 10050
C
10060	CONTINUE
10070	NONBLK=IHOLD
	GOTO 12000
C
C
C  FUNCTION FOUND (LEAVES NONBLK POINTING AT LAST CHARACTER)
10100	CONTINUE
C
C
C
C
C **********************************
C ****** UNARY FUNCTION FOUND ******
C **********************************
	RETTYP=ICHAR(CHAR(FUNVAL(2,I)))
	LASTOP=RETTYP
	RETCD=2
	GOTO 99099
C
C
C
C
C
C ********************************
C ****** VARIABLE SPECIFIED ******
C ********************************
12000	CONTINUE
C
C
C  IALPHA HOLDS INDEX INTO ALPHA OF NAME
C ******&&&&&& REMOVE BLK OF CODE STARTING HERE...
C	CALL GETNNB (IPT,RETCD2)
C	IF (RETCD2.EQ.2) GOTO 12060
CC
CC
CC MAKE SURE NEXT CHARACTER IS NOT ALPHA
C	DO 12050 I=1,27
C	IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
C12050	CONTINUE
C *****&&&&& ...ENDING HERE
C ADD BELOW...
	LLB=IPT
	LRB=LEND
	CALL VARSCN(LINE,LLB,LRB,LSTCHR,ID1,ID2,IVALID)
C	IF(IVALID.EQ.0)GOTO 12200
C	IPT=LSTCHR
C leave the following "60" in place. It's only roughly right
C (probably should be more like 30) but will do since funct.
C names are 3 chars...
	IF(IVALID.NE.0.AND.ID2.LE.1.AND.ID1.GT.60)GOTO 13201
	IF(IVALID.NE.0)GOTO 12201
C NOT VALID VARIABLE. SEE IF A 2 + ARGUMENT FUNCTION...
C
C COME HERE DIRECT FOR FUNCTIONS ENCODED...
13201	CONTINUE
	I=IPT+9
	CALL FNAME(LINE(IPT),I,INDEXF)
	IF(INDEXF.EQ.6.OR.INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 12202
C NOW KNOW THERE IS A FUNCTION THERE, SO HANDLE IT.
	LLAST=LEND-IPT+1
	I=INDX(LINE(IPT),ICHAR(']'))
	IF(I.LE.0.OR.I.GT.LLAST)GOTO 12202
	LRB=I
	LLB=INDX(LINE(IPT),ICHAR('['))
	IF(LLB.LE.0.OR.LLB.GT.LLAST)GOTO 12202
	CALL DOMFCN(LINE(IPT),LLB,LRB,INDEXF,ACX)
	XAC=ACX
	TYPE(1,1)=2
	CALL TYPSET(1,27,TYPE(1,1))
C	TYPE(27,1)=2
	ID1=27
	ID2=1
	LSTCHR=LRB+IPT
C GO AND MERGE AS THOUGH WE JUST GOT A VARIABLE % AND HAD TO
C RETURN ITS VALUE.
	GOTO 12201
C IF NOT VALID FUNCTION REPORT AN ERROR.
12202	GOTO 12200
12201	IPT=LSTCHR
	IF(LSTCHR.LT.LEND)IPT=IPT-1
	NONBLK=IPT
C RESET NONBLK ALST SO WE RESET GETNNB TOO...
C WAS IPT=LSTCHR+1
C IPT POINTS AFTER VARIABLE NAME...
C ENSURE NON ALPHA AFTER VARIABLE NAME
	CALL GETNNB(IPT,RETCD2)
	IF(RETCD2.EQ.2) GOTO 12060
C
C IF THE NEXT CHARACTER IS AN = SIGN DON'T RETURN VALUE
C OF VARIABLE, JUST PUT INDEX INTO VBLS INTO LOWER BYTE
C OF RETVAL.
	IF (LINE(IPT).EQ.EQ) GOTO 12100
C
C
C ************************************************
C ****** RETURN VALUE OF VARIABLE SPECIFIED ******
C ************************************************
12060	CALL TYPGET(ID1,ID2,RETTYP)
C12060	RETTYP=TYPE(ID1,ID2)
C *****&&&&&
C MUST CLAMP TYPES SO EXTENDED VARIABLES CAN'T BE MULT PRCN VRBLS.
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12061
	IF (RETTYP.EQ.5)RETTYP=4
	IF (RETTYP.EQ.6)RETTYP=8
	IF (RETTYP.EQ.7)RETTYP=3
12061	CONTINUE
	IF(RETTYP.LE.0)GO TO 12080
	K=VLEN(RETTYP)
	DO 12070 I=1,K
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12068
C TRY AND CALL XVBLGT HERE TO GET VALUE ALL AT ONCE
C TO AVOID MULTIPLE ARBITRATION...
	IF(I.EQ.K)CALL XVBLGT(ID1,ID2,RETVAL)
C	CALL VBLGET(I,ID1,ID2,RETVAL(I))
C	RETVAL(I)=VBLS(I,ID1,ID2)
	GOTO 12070
12068	RETVAL(I)=AVBLS(I,ID1)
12070	CONTINUE
C
12080	LASTOP=RETTYP
	GOTO 99099
C
C
C
C *******************************************************
C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
C *******************************************************
12100	CONTINUE
C	RETVAL(1)=IALPHA
C	RETTYP=TYPE(IALPHA)
	CALL TYPGET(ID1,ID2,TYPE(1,1))
	CALL RVBOO(RETVAL,ID1,ID2)
C RVBOO JUST STUFFS ID1,ID2 INTO RETVAL ARRAY
C AS 2 INTEGERS.
	RETTYP=TYPE(1,1)
	GOTO 12080
C
C
C
C *** ERROR *** UNIDENTIFIED FUNCTION
12200	CALL ERRMSG(18)
	GOTO 99000
C
C
C
C
C
C **********************
C ****** OPERATOR ******
C **********************
C
C  I IS INDEX INTO OPER TO TELL WHAT OPERATOR IT IS
20000	CONTINUE
	RETCD=2
	IF(I.NE.4)GO TO 20050
C
C
C IF AN ASTERISK IS FOUND THE NEXT CHARACTER MUST BE EXAMINED
C TO SEE IF '**' WAS SPECIFIED FOR EXPONENTIATION.
	CALL GETNNB (IPT,RETCD2)
	IF(RETCD2.NE.1)GO TO 99000
	IF (LINE(IPT).NE.STAR) GOTO 20050
C
C
C '**' SPECIFIED (EXPONENTIATION)
	RETTYP=EXCODE
	NONBLK=IPT
	GO TO 12080
C
C
C
C  SET DEFAULT RETTYP FOR OPERATORS
20050	RETTYP=109+I
C
C
C  CHECK OUT POSSIBLE UNARY OPERATOR "-"
	IF (RETTYP.NE.111) GOTO 20080
C
C
C IF A MINUS IS ENCOUNTERED AND THERE WAS NO PREVIOUS ELEMENT OR
C IF PREVIOUS ELEMENT WAS AN OPERATOR OR = SIGN THEN OPERATOR
C IS UNARY.
	IF (LASTOP.EQ.0.OR.(LASTOP.GE.110.AND.LASTOP.LE.116).OR.
     ;      LASTOP.EQ.200) GOTO 20090
C
C
C  BINARY SUBTRACTION OPERATOR
	RETTYP=116
	GOTO 12080
C
C
C
C SEE IF A '+' SIGN
20080	IF(RETTYP.NE.115)GO TO 20085
C
C
C DETERMINE IF IT IS A UNARY PLUS
	IF(LASTOP.NE.0.AND.LASTOP.LE.100)GO TO 20085
C
C
C SEE IF LAST OPERATOR WAS ')'
	IF(LASTOP.EQ.117)GO TO 20085
C
C
C UNARY '+' FOUND.
	RETCD=1
	GO TO 10
C
C
C
C RESET LASTOP TO 0 IF LEFT PARENTHESIS IS FOUND (CODE 110)
C IF RETTYP IS FOR =, SET TO PROPER CODE
20085	IF(RETTYP.EQ.110)GO TO 20090
	IF(RETTYP.EQ.118)RETTYP=200
	GO TO 12080
C
C
C UNARY -
20090	CONTINUE
	GOTO 99097
C
C
C
C
C
C
C *************************
C ****** NON-DECIMAL ******
C *************************
C
30000	RETPT=RETPT+1
	IF (RETPT.LE.19) GOTO 30020
C
C
C *** ERROR *** MULTIPLE PRECISION IS LIMITED TO 19 DIGITS
C (ACTUALLY, NO LONGER PRESENT...)
	CALL ERRMSG(22)
	GOTO 99000
C
C
C  I HOLDS INDEX INTO DIGITS THAT WAS A MATCH.
C  SEE IF VALUE OF DIGIT IMPLIES A HIGHER BASE.
30020	IF (I.NE.16) GOTO 30030
	I=0
	GOTO 30050
30030	IF (I.EQ.8.OR.I.EQ.9) B10=1
	IF(I.GT.9) B16=1
30050	RETVAL(RETPT)=CHAR(I)
C
C
C GET NEXT CHARACTER
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.NE.1) GOTO 30100
	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 30070 I=1,16
	IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
30070	CONTINUE
	IF (CHAR1.EQ.DOT) GOTO 40000
	NONBLK=NONBLK-1
30100	CONTINUE
C
	IF (DEFBAS.EQ.16.OR.B16.EQ.1) GOTO 30200
	IF (DEFBAS.EQ.10.OR.B10.EQ.1) GOTO 30300
C
c add code here to check for non -calc mode and goto 40000 if so
c if defbas.ne.8 and if we're working on a floating number
C
C *****************************
C ****** BASE 8 CONSTANT ******
C *****************************
	BASE=8
C
C
C IF MORE THAN 10 DIGITS IT IS MULTIPLE PRECISION
	IF (RETPT.GT.10) GOTO 30170
	RETTYP=8
C
C
C  CONVERT TO OCTAL, HEX OR INTEGER
30110	INT=0
30130	DO 30132 L=1,7
	IF (ICHAR(RETVAL(L)).NE.0) GOTO 30140
30132	CONTINUE
30140	DO 30150 I=L,RETPT
	INT=INT*BASE+ICHAR(RETVAL(I))
	RETVAL(I)=0
30150	CONTINUE
	RETVAL(20)=0
30155	DO 30160 I=1,4
30160	RETVAL(I)=FOUR(I)
	GOTO 35100
C
C
C ************************************************
C ****** MULTIPLE PRECISION BASE 8 CONSTANT ******
C ************************************************
30170	RETTYP=6
30180	CALL FLIP (RETVAL,8,RETPT)
c was 20 above, not 8 but we shortened stack arrays so shorten this
	GOTO 35100
C
C
C
C *********************
C ****** BASE 16 ******
C *********************
30200	BASE=16
C
C
C IF MORE THAN 7 DIGITS IT IS MULTIPLE PRECISION.
	IF (RETPT.GT.7) GOTO 30270
C
C
C
C  HEXADECIMAL
	RETTYP=3
	GOTO 30110
C
C
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 16 ******
C ****************************************
30270	RETTYP=7
	GOTO 30180
C
C
C *********************
C ****** BASE 10 ******
C *********************
30300	BASE=10
C
C
C IF MORE THAN 9 DIGITS IT IS MULTIPLE PRECISION.
	IF (RETPT.GT.9) GOTO 30370
C
C
C  INTEGER
	RETTYP=4
	GOTO 30110
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 10 ******
C ****************************************
30370	RETTYP=5
	GOTO 30180
C
C
C
C
C
C SET LASTOP AND EXIT
35100	LASTOP=RETTYP
	GOTO 99099
C
C
C *****************************
C ****** REAL OR DECIMAL ******
C *****************************
40000	IF (B16.NE.1) GOTO 40020
C
C
C *** ERROR ***  '.' MAY ONLY BE USED WITH BASE 10
	CALL ERRMSG(21)
	GOTO 99000
C
C
C
40020	IF (RETPT.EQ.0) GOTO 40200
C
C
C IGNORE LEADING ZEROES
	DO 40022 L=1,19
	IF (ICHAR(RETVAL(L)).NE.0) GOTO 40030
40022	CONTINUE
C
C IF ALL ZEROES THE LAST ONE COUNTS!
	L=19
C
C
C CONVERT TO A REAL*8 NUMBER
40030	CONTINUE
	REAL=0.D0
	DO 40060 I=L,RETPT
	REAL=REAL*10.D0+ICHAR(RETVAL(I))
	RETVAL(I)=0
40060	CONTINUE
C
C
C  PICK UP FRACTIONAL PART OF REAL (DECIMAL)
40200	CONTINUE
	RB=1.0D0
	RETTYP=2
40205	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 40300
C
C IF NO MORE, YOU GOT IT ALL SO GO PLACE VALUE IN RETVAL.
	GOTO 40537
C
C
C
40300	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 40320 I=1,10
	IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40330
40320	CONTINUE
	GOTO 40350
40330	IF (I.EQ.10) I=0
	RB=0.1D0*RB
	REAL=REAL+DFLOAT(I)*RB
	GOTO 40205
C
C
C CHECK TO SEE IF E OR D EXPONENT SPECIFICATION IS USED.
40350	IF (CHAR1.EQ.DIGITS(13,3).OR.CHAR1.EQ.DIGITS(14,3)) GOTO 40360
	NONBLK=NONBLK-1
	GO TO 40537
C
C
C *********************************************
C ****** E AND D EXPONENT SPECIFICATIONS ******
C *********************************************
40360	CONTINUE
	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 40370
C
C
C *** ERROR *** ILLEGAL REAL EXPONENT FIELD SPECIFIED
40365	CALL ERRMSG (24)
	GOTO 99000
C
C
40370	CHAR1=LINE(IPT)
	IF (CHAR1.EQ.MINUS) GOTO 40380
	RB=10.D0
	IF (CHAR1.NE.PLUS) GOTO 40400
	GOTO 40390
40380	RB=0.1D0
C
C
C
40390	NONBLK=IPT
	CALL GETNNB (IPT,RETCD2)
40400	IF (RETCD2.GE.2) GOTO 40365
	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 40450 I=1,10
	IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40480
40450	CONTINUE
	GOTO 40365
40480	IF (I.EQ.10) I=0
C
C
C I1 HOLDS 1ST DIGIT OF EXPONENT SPECIFICATION
	I1=I
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.GE.2) GOTO 40550
	CHAR1=LINE(IPT)
	NONBLK=IPT
	DO 40500 I=1,10
	IF(CHAR1.EQ.DIGITS(I,1)) GO TO 40520
40500	CONTINUE
	NONBLK=NONBLK-1
	GOTO 40550
C
C
C I2 HOLDS SECOND DIGIT OF EXPONENT SPECIFICATION.
40520	IF (I.EQ.10) I=0
	I2=I
C
C
40530	RETTYP=9
	REAL=REAL*RB**(I1*10+I2)
C
C
C
C ***************************************************
C ****** COPY REAL*8 INTO RETURN VECTOR RETVAL ******
C ***************************************************
40537	DO 40540 I=1,8
40540	RETVAL(I)=EIGHT(I)
	GOTO 35100
C
C
C
40550	I2=I1
	I1=0
	GOTO 40530
C
C
C
C ********************************
C ******* ERROR PROCESSING *******
C ********************************
99000	CONTINUE
	IV=LEND-NONBLK+1
	CALL VWRT(LINE(NONBLK),IV)
C	WRITE (0,99010) (LINE(I),I=NONBLK,LEND)
C99010	FORMAT (1X,80(A1,\))
	RETCD=4
99097	LASTOP=0
99099	RETURN
	END
c -h- pget.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE PGET(CMDLIN,ICODE,IRTN)
	Include AParms.inc
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
        Integer*4 IDRO,IDCL
	CHARACTER*1 LET1,LET2,FORM2(128),FORM3(110),NMSH(80)
        Character*127 Form2c
        Equivalence(Form2(1),Form2c)
        REAL*8 R8S
	Integer*4 i4s
	equivalence(r8s,form3(1))
	equivalence(i4s,form3(1))
        INTEGER*4 IBIN
	COMMON/NMSH/NMSH
	REAL*8 XVBLS(1,1)
	INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	integer*4 idsptp,idol9,k3dfg,kcdelt,krdelt,kpag
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,idol9,
     3  k3dfg,kcdelt,krdelt,kpag
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IOLVL
	INTEGER*4 JVBLS(2,1,1)
CCC	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.
	DIMENSION FORM(128),FVLD(1,1)
	CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2

C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
	CHARACTER*1 LETA
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
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XAC,ZAC
	EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
	REAL*8 XXAC,XYAC
	EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
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	CHARACTER*1 ARGSTR(52,4)
CCC	COMMON/ARGSTR/ARGSTR
C	EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	INTEGER*4 IIRO,IICO,INUMEM
C NEED SOME BIG VARIABLES FOR SAVING THE MAPPINGS
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	COMMON/KLVL/KLVL
	CHARACTER*1 DEFVB(12)
	COMMON/DEFVBX/DEFVB
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
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).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	REAL*8 DVS(20,75)
	INTEGER*4 LDVS(2,20,75)
	EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
	CHARACTER*76 CFORM
	EQUIVALENCE(CFORM(1:1),FORM(1))
	COMMON /FVLDC/FVLD
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
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,MRows)
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 >>>***
	Character*1 Letr
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
C
C PUT NUMBERS OUT TO FILE
C USES RELATIVE FORMS TO CURRENT POS.
C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
C ONLY WRITES PHYSICALLY PRESENT DATA.
C P/D RRR,CCC,FORMULA,VALID,FORMAT
C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
	ICODE=1
	CLOSE(4)
7954	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
C ASK FOR FILE NAME
	CALL VWRT('Enter Filename:',15)
	III=IOLVL
C	IF(III.EQ.5)III=0
	if(iii.ne.11)READ(III,7953,END=510,ERR=510)FORM2
	if(iii.eq.11)call vget(form2,128)
c7952	FORMAT(' Enter filename>\')
7953	FORMAT(128A1)
	DO 6940 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
	FORM2(ILN)=0
6940	CONTINUE
6941	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=0
        IBIN=0
        IF(CMDLIN(2).EQ.'B'.OR.CMDLIN(2).EQ.'b')IBIN=1
	IF(IBIN.EQ.0)CALL WASSIG(4,FORM2)
C block=-1 is Absoft-specific Amiga hack to get record lengths encoded
C to allow variable length records to make sense.
        IF(IBIN.EQ.1)OPEN(UNIT=4,FILE=FORM2c,FORM='UNFORMATTED',
     1  ACCESS='SEQUENTIAL',STATUS='NEW',BLOCK=-1)
C NOW ENCODE COL WIDTHS AND ICREF/IRREF
C SO SAVE/RESTORE OF EXTENDED SHEETS DOESN'T GET
C MESSED UP.
	If(Ibin.eq.0)
     1  WRITE(CFORM(1:76),8850,ERR=8851)ICREF,IRREF,(CWIDS(III),
     1  III=1,20),DRWV,DCLV
8850	FORMAT(24I3)
	DO 8855 III=1,80
	II=ICHAR(NMSH(III))
	IF(II.LT.32)II=32
8855	NMSH(III)=CHAR(II)
8851	CONTINUE
	IF(IBIN.EQ.0)WRITE(4,6951)NMSH,(FORM(II),II=1,76)
        IF(IBIN.EQ.1)WRITE(4,err=448)NMSH,ICREF,IRREF,
     1  (CWIDS(III),III=1,20),DRWV,DCLV
6951	FORMAT(80A1,76A1)
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
        MDXM=12000
        LDXM=12000
        IF(IBIN.EQ.1)GOTO 448
	CALL VWRT('Enter max. displ down to save or 0 for all>',43)
	III=IOLVL
C	IF(III.EQ.5)III=0
	if(iii.ne.11)READ(III,7978,END=510,ERR=510)LDXM
	if(iii.ne.11)call vgeti(ldxm)
6950	FORMAT(80A1)
7978	FORMAT(I7)
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter max. displcmt right to save or 0 for all>',47)
	III=IOLVL
C	IF(III.EQ.5)III=0
	if(iii.ne.11)READ(III,7978,END=510,ERR=510)MDXM
	if(iii.ne.11)call vgeti(mdxm)
	IF(MDXM.LE.0)MDXM=12000
	IF(LDXM.LE.0)LDXM=12000
448     CONTINUE
C 12000 IS "AN ARBITRARILY LARGE NUMBER TO ASSURE THAT ALL VALID
C RANGES ARE SAVED". IT MUST BE SMALL ENOUGH TO ASSURE WE DON'T OVERFLOW AN
C INTEGER THOUGH.
	IF(CMDLIN(2).NE.'P'.and.CMDLIN(2).GT.' '.AND.IBIN.EQ.0)
     1   GOTO 7950
C TREAT "P" BY ITSELF AS A SAVE PP TYPE COMMAND (PUT PHYS)
C Could speed this by saving only what's been filled.
C RCLACT can be up to 301, RRWACT can be up to MCols
C since current cell may be outside this area, use scratch vbls
C to ensure all's well
	If(K3dfg.lt.0)Goto 8601
C write out special "flag" record to preserve 3D mapping
C information IF mapping is not disabled.
	Letr='F'
	if(ibin.eq.1)goto 8602
	WRITE(4,5403)LETR,k3dfg,KCDelt,KRDelt
	Goto 8603
8602	Continue
	i4s=KRDelt
	WRITE(4)LETR,K3Dfg,KCDelt,
     1  (form3(ivv),ivv=1,110)
8603	Continue
C fill in other rubbish as second part of record.
	Type(1,1)=2
	Form2(119)=-3
	If(Ibin.eq.0)
     1  WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1)
	If(Ibin.eq.1)
     1  WRITE(4)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1)
C
8601	Continue
	Irrw=max0(PCOL,RCLACT)
	Ircl=max0(PROW,RRWACT)
c	DO 7951 ICO=PCOL,301
c	DO 7951 IRO=PROW,60
	DO 7951 ICO=PCOL,Irrw
	DO 7951 IRO=PROW,Ircl
C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY.
C	IRX=(ICO-1)*60+IRO
	CALL REFLEC(ICO,IRO,IRX)
	IDRO=IRO-PROW+1
	IDCL=ICO-PCOL+1
	IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951
C FORM DISPLACEMENT LOCATORS
	CALL FVLDGT(IRO,ICO,FVLD(1,1))
	IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7951
	CALL WRKFIL(IRX,FORM,0)
	CALL CE2A(FORM,FORM2)
	IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
	IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
	CALL TYPGET(IRO,ICO,TYPE(1,1))
	IF(CMDLIN(3).NE.'N')GOTO 5402
	IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5402
C ALWAYS WRITE TEXT OUT EVEN IF SAVING NUMERICALLY
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
C INTERNAL PROC TO PRINT NUMERIC VALUES AT 6400
	LETR='P'
	ASSIGN 5405 TO INUMEM
C	GOTO 6400
6400	CONTINUE
C ASSUME LETR IS SET TO GOOD PREFIX LETTER ASCII VALUE
	CALL XVBLGT(IRO,ICO,XVBLS(1,1))
        IF(IBIN.EQ.1)GOTO 449
	IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5403)LETR,IDRO,IDCL,
     1  JVBLS(1,1,1)
5403	FORMAT(1A1,I5,',',I5,',',I15)
	IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5404)LETR,IDRO,IDCL,
     1  XVBLS(1,1)
        GOTO 450
449     CONTINUE
        R8S=XVBLS(1,1)
	WRITE(4,err=450)LETR,IDRO,IDCL,FORM3
450     CONTINUE
5404	FORMAT(1A1,I5,',',I5,',',D30.19)
	GOTO INUMEM,(5405,6406)
5402	CONTINUE
C FIND END OF TEXT IN ARRAY
	IVVV=110
        If(Ibin.eq.1)goto 4331
C skip this truncation for binary saves
	DO 4330 IV=2,110
	IVVV=113-IV
	IF(ICHAR(FORM2(IVVV)).GT.32)GOTO 4331
4330	CONTINUE
4331	CONTINUE
C SAVE ON PPX IN EFFICIENT FORM.
C DON'T WRITE OUT TRAILING NULLS.
C ENSURE FORMAT HAS NO NULLS IN IT.
	DO 358 IV=120,128
358	IF(ICHAR(FORM2(IV)).LT.32)FORM2(IV)=Char(32)
	IF(CMDLIN(3).EQ.'F')GOTO 6404
C PPF WILL SAVE FORMULAS ONLY
C PPA WILL SAVE FORMULAS AND VALUES (AS WILL PPc WHERE c IS
C ANY CHARACTER EXCEPT N.
	LETR='p'
C FLAG NUMERIC SAVE VIA LOWERCASE P HERE
	ASSIGN 6406 TO INUMEM
C GO WRITE FIRST LINE NUMERICALLY
	GOTO 6400
6406	CONTINUE
C NOW HAVE NUMERIC LINE WRITTEN. WRITE THE SECOND LINE OF THE
C GROUP TO, SO AS NOT TO CONFUSE GRAPHICS PROGRAMS AND THE
C LIKE.
	III=JCHAR(FORM2(119))
	IF(IBIN.EQ.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
     1   TYPE(1,1)
	IF(IBIN.EQ.1)WRITE(4,err=6404)III,(FORM2(IV),IV=120,128),
     1   TYPE(1,1)
6404	CONTINUE
C NOW WRITE OUT FORMULA RECORD.
	If(Ibin.eq.0)WRITE(4,7955)IDRO,IDCL,
     1   (FORM2(IV),IV=1,IVVV)
        Letr=char(80)
        If(Ibin.eq.1)Write(4,err=5405)Letr,idro,idcl,
     1   (form2(iv),iv=1,ivvv)
5405	CONTINUE
C DUMP TO SERIAL FILE IN OUR OWN FORMAT, BUT ALL IN ASCII.
7955	FORMAT('P',I5,',',I5,',',128A1)
C NOTE LONG RECORDS.
	III=JCHAR(FORM2(119))
	If(ibin.eq.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
     1  TYPE(1,1)
	If(Ibin.eq.1)WRITE(4,err=7951)III,(FORM2(IV),IV=120,128),
     1  TYPE(1,1)
7956	FORMAT(I3,',',9A1,',',I5)
7951	CONTINUE
2751	CONTINUE
C
C NOW SAVE NRDSP AND NCDSP MAPPINGS TOO
C ONLY SAVE MAPPINGS IF 4TH COMMAND CHARACTER IS "M".
C ... THEY TAKE A LOT OF ROOM.
	IF (CMDLIN(4).NE.'M') GOTO 6541
	DO 6540 IRO=DROW,20
	DO 6540 ICO=DCOL,75
	IIRO=64000
	IICO=IIRO
	IIRO=IIRO+IRO
	IICO=IICO+ICO
C NOTE WE MAKE THESE NUMBERS LARGE SO GRAPHING PROGRAMS WON'T TRY
C TO READ THEM.
6955	FORMAT('M',I5,',',I5,',',2I7)
        Letr='M'
        If(Ibin.eq.0)
     1   WRITE(4,6955,ERR=6541)IIRO,IICO,
     1   NRDSP(IRO,ICO),NCDSP(IRO,ICO)
        If(Ibin.eq.1)
     1   WRITE(4,ERR=6541)Letr,IIRO,IICO,
     1   NRDSP(IRO,ICO),NCDSP(IRO,ICO)
C WRITE A SPECIAL RECORD, FLAGGED BY 'M', TO SAVE A MAPPING CELL
C NEED A 2ND RECORD TOO; JUST SEND LAST ONE AGAIN.
	If(ibin.eq.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
     1  TYPE(1,1)
	If(Ibin.eq.1)WRITE(4,err=6541)III,(FORM2(IV),IV=120,128),
     1  TYPE(1,1)
6540	CONTINUE
6541	CONTINUE
	CLOSE(4)
	GOTO 9990
7950	IF(CMDLIN(2).NE.'D')GOTO 9990
	DO 7957 ICO=DCOL,75
	DO 7957 IRO=DROW,20
	IDRO=IRO-DROW+1
	IDCL=ICO-DCOL+1
	IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7957
	NR=NRDSP(IRO,ICO)
	NC=NCDSP(IRO,ICO)
C	IRX=(NC-1)*60+NR
	CALL REFLEC(NC,NR,IRX)
	CALL FVLDGT(NR,NC,FVLD(1,1))
	IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7957
	CALL WRKFIL(IRX,FORM,0)
	CALL CE2A(FORM,FORM2)
	IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
	IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
	IF(CMDLIN(3).NE.'N')GOTO 5412
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
	IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5412
C WRITE LABELS EVEN IF NUMERIC SAVE
	CALL TYPGET(NR,NC,TYPE(1,1))
	CALL XVBLGT(NR,NC,XVBLS(1,1))
	IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,1,1)
5413	FORMAT('P',I5,',',I5,',',I15)
	IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(1,1)
5414	FORMAT('P',I5,',',I5,',',D30.19)
	GOTO 5415
5412	CONTINUE
	WRITE(4,7958)IDRO,IDCL,(FORM2(IV),IV=1,110)
5415	CONTINUE
7958	FORMAT('D',I5,',',I5,',',128A1)
	DO 359 IV=120,128
359	IF(FORM2(IV).LT.' ')FORM2(IV)=Char(32)
	III=JCHAR(FORM2(119))
	WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
7957	CONTINUE
C ALLOW SAVE AS NEEDED OF MAPPING
	GOTO 2751
C	CLOSE(4)
9990	RETURN
510	CONTINUE
	IRTN=1
	CLOSE(IOLVL)
c	CLOSE(11)
c	OPEN(11,FILE='CON:0/0/100/100/Analy Command')
	RETURN
	END
c -h- pgget.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE PGGET(CMDLIN,ICODE,IRTN)
	Include AParms.inc
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
        Real*8 R8s
        Integer*4 I4s,I4t
        Equivalence(R8s,form2(1)),(I4s,form2(1))
        Equivalence (I4t,form2(3))
        Character*127 Form2c
        Equivalence(Form2(1),Form2c)
	COMMON/NMSH/NMSH
	REAL*8 XVBLS(1,1)
	INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 idsptp,idol9,k3dfg,kcdelt,krdelt,kpag
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,Idol9,
     3  K3dfg,kcdelt,krdelt,kpag
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IOLVL
	INTEGER*4 JVBLS(2,1,1)
	REAL*8 R8WK
CCC	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.
	DIMENSION FORM(128),FVLD(1,1)
	INTEGER*4 IRRW,ICCL
C USE BIG NUMBERS SO WE CAN SUBTRACT 64000 AND STILL NOT GET WRAPAROUND.
C (FOR SAVE/RESTORE OF MAP)
	CHARACTER*76 CFORM
	CHARACTER*35 CFORM2
	EQUIVALENCE(CFORM2(1:1),FORM2(1))
	EQUIVALENCE(CFORM(1:1),FORM(1))
	InTeGer*4 NDUM(24)
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,MRows)
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	COMMON/MIRROR/ICREF,IRREF
	CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
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
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	EXTERNAL INDX
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XAC,ZAC
	EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
	REAL*8 XXAC,XYAC
	EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
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	CHARACTER*1 ARGSTR(52,4)
CCC	COMMON/ARGSTR/ARGSTR
C	EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	COMMON/KLVL/KLVL
	CHARACTER*1 DEFVB(12)
	COMMON/DEFVBX/DEFVB
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
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).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	REAL*8 DVS(20,75)
	INTEGER*4 LDVS(2,20,75)
	EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
	COMMON /FVLDC/FVLD
CCC	InTeGer*4 NCEL,NXINI
CCC	COMMON/NCEL/NCEL,NXINI
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
C
c7952	FORMAT(' Enter filename>\')
7953	FORMAT(128A1)
6950	FORMAT(80A1)
7978	FORMAT(I7)
7956	FORMAT(I3,1X,9A1,1X,I5)
	CLOSE(4)
7960	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
C GET FILE NAME
	call Vwrt('Enter Filename:',15)
	III=IOLVL
C	IF(III.EQ.5)III=0
	if(iii.ne.11)READ(III,7953,END=510,ERR=510)FORM2
	if(iii.eq.11)call vget(form2,128)
	DO 6940 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
	FORM2(ILN)=Char(0)
6940	CONTINUE
6941	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(127,ILN)
	FORM2(ILN+1)=Char(0)
C SPECIAL "FAST READ" MODE TO SET UP DATA AREAS ON GETTING OLD SHEETS...
	NXINI=1
	LDXM=INDX(FORM2,ICHAR('/'))
C IF FILE IS FILENAME/M WE WON'T DO IT FAST...
	IF(LDXM.LE.0.OR.LDXM.GE.ILN)GOTO 8400
	FORM2(LDXM)=Char(0)
C TERMINATE AFTER THE / AND SET NXINI TO 0 AGAIN
	NXINI=0
8400	CONTINUE
        Ibin=0
        If(Cmdlin(2).eq.'B'.OR.cmdlin(2).eq.'b')Ibin=1
	If(Ibin.eq.0)CALL RASSIG(4,FORM2)
C BLOCK=-1 IS HACK TO READ ABSOFT UNFORMATTED BIN RECS AS VBL LEN
        If(Ibin.eq.1)Open(unit=4,file=form2c,form='Unformatted',
     1  access='SEQUENTIAL',status='OLD',BLOCK=-1)
        If(Ibin.eq.0)
     1  READ(4,6951,END=7964,ERR=7964)NMSH,FORM
        If(Ibin.eq.1)
     1  READ(4,END=7964,ERR=7107)NMSH,Ndum
7107    Continue
6951	FORMAT(80A1,76A1,56A1)
6952	FORMAT(24I3)
C TRY TO DECODE ICREF,IRREF, CWIDS, AND DRWV,DCLV
	If(Ibin.eq.0)READ(CFORM(1:76),6952,ERR=6953)NDUM
C IF HERE, THE READ WAS OK (APPARENTLY)
C FILL IN DEFAULTS IF NOTHING BUT ZEROES REALLY WAS SEEN
C (OR JUST ALL SPACES)
	ICREF=NDUM(1)
	IF(ICREF.LE.0.OR.ICREF.GT.MCols)ICREF=10
	IRREF=NDUM(2)
	IF(IRREF.LE.0.OR.IRREF.GT.(MRows-1))IRREF=50
C SET UP CWIDS BUT DEFAULT TO 10 IF NO REAL INFO THERE
	DO 6954 III=1,20
	IIVV=NDUM(III+2)
	IF(IIVV.LT.1.OR.IIVV.GT.100)IIVV=10
	CWIDS(III)=IIVV
6954	CONTINUE
C RESTORE NUMBER ROWS AND COLS BEING DISPLAYED
C NOTE WE DO NOT RESTORE THE COMPLETE DISPLAY
C MAPPING; JUST THE WIDTHS AND NUMBERS OF DISPLAY
C COLUMNS, AND WE RESTORE THE EXTENDED MAP SO THAT
C SAVED SHEETS WILL NORMALLY GET BACK THE SAME EXTENDED
C ADDRESSING THAT HAD BEEN SET UP.
	DRWV=NDUM(23)
	IF(DRWV.LT.1.OR.DRWV.GT.20)DRWV=7
	DCLV=NDUM(24)
	IF(DCLV.LT.1.OR.DCLV.GT.75)DCLV=20
6953	CONTINUE
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
        mdxm=12000
        ldxm=12000
        mmdxm=1
        lldxm=1
        If(ibin.eq.1)Goto 662
	CALL VWRT('Enter max. displc. down to restore or 0 for all>',48)
	III=IOLVL
C	IF(III.EQ.5)III=0
	if(iii.ne.11)READ(III,7978,END=510,ERR=510)MDXM
	if(iii.eq.11)call vgeti(mdxm)
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter max. displc. right to restore or 0 for all>',
     1  49)
	if(iii.ne.11)READ(III,7978,END=510,ERR=510)LDXM
	if(iii.eq.11)call vgeti(ldxm)
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter min. displ. down (1 or more)>',35)
	if(iii.ne.11)READ(III,7978,END=510,ERR=510)MMDXM
	if(iii.eq.11)call vgeti(mmdxm)
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter min displ. right (1 or more)>',35)
	if(iii.ne.11)READ(III,7978,END=510,ERR=510)LLDXM
	if(iii.eq.11)call vgeti(lldxm)
662     Continue
	IF(MDXM.LE.0)MDXM=12000
	LLDXM=MAX0(1,LLDXM)
	MMDXM=MAX0(1,MMDXM)
	IF(LDXM.LE.0)LDXM=12000
	IF(CMDLIN(4).EQ.'+'.OR.CMDLIN(4).EQ.'-')RCFGX=1
C ENTER RECALC MANUAL MODE IF ADDING NUMBERS OR SUBT.
C FROM SAVED SHEET
C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER.
7961	CONTINUE
        If(Ibin.eq.0)
     1  READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV),
     1  IV=1,110)
        If(Ibin.eq.1)
     1  READ(4,END=7964,ERR=7108)LET1,IRRW,ICCL,(FORM2(IV),
     1  IV=1,110)
7962	FORMAT(A1,I5,1X,I5,1X,128A1)
7108    Continue
        ivv=110
        If(Ibin.eq.1)Goto 4496
	DO 4497 IV=1,110
	IVV=111-IV
	IF(FORM2(IVV).GT.' ')GOTO 4496
	FORM2(IVV)=Char(0)
4497	CONTINUE
4496	CONTINUE
C ABOVE LOOP ENSURES THAT EXTRA PARTS OF BUFFER NOT IN SAVE FILE ARE
C ZEROED ON READIN.
        If(Ibin.eq.0)
     1  READ(4,7956,END=7964,ERR=7964)III,(FORM2(IV),IV=120,128),
     1  KKTYP
        If(Ibin.eq.1)
     1  READ(4,END=7964,ERR=7109)III,(FORM2(IV),IV=120,128),
     1  KKTYP
7109    Continue
	FORM2(119)=Char(III)
	If(k3dfg.lt.0)goto 8602
C Handle F records (flags)
	If(Let1.ne.'F')goto 8602
	if(ibin.ne.0)goto 8603
	Read(form2c(1:15),8604,err=7961)I4S
c	DECODE(15,8604,FORM2(1),ERR=7961)I4S
8604	FORMAT(I15)
8603	Continue
C set all values together so if decode error occurs things will
C remain consistent.
	krdelt=i4s
	k3dfg=irrw
	kcdelt=iccl
C No further processing of flag records.
	GoTo 7961
8602	Continue
	IF(LET1.EQ.'M')GOTO 6500
C M CODE MEANS WE'RE READING THE DISPLAY-TO-PHYSICAL MAP.
C GO HANDLE IT SPECIALLY, THEN RETURN. FLAGS RECORDS BY
C ADDING 64000 TO ROW AND COL NUMBERS TO AVOID GETTING
C GRAPHICS PROGRAMS MESSED UP.
C  NOTE THAT SAVING THE MAP WAS OPTIONAL AND IS NOT THE
C DO-NOTHING DEFAULT.
	IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
	IF(JCHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
	IF(IRRW.LE.0.OR.ICCL.LE.0)GOTO 9990
	IF(IRRW.GT.LDXM.OR.ICCL.GT.MDXM)GOTO 7961
	IF(IRRW.LT.LLDXM.OR.ICCL.LT.MMDXM) GOTO 7961
C PRODUCE NEW ADDRESSES IN PHYSICAL SHEET USING SAVED FILE'S ONES
C AND CURSOR LOCATION (SINCE WE SAVE/RESTORE RELATIVE TO CURSOR).
C THIS PROVIDES A SHEET PARTIAL SAVE / MERGE CAPABILITY.
	NR=IRRW+PROW-LLDXM
	NC=ICCL+PCOL-MMDXM
	IF(CMDLIN(2).NE.'D'.AND.LET1.NE.68)GOTO 7963
	IF(CMDLIN(2).EQ.'P'.or.ibin.eq.1)GOTO 7963
C GET DISPLAY VERSION...
	LRR=IRRW+DROW-LLDXM
	LCC=ICCL+DCOL-MMDXM
	LRR=MAX0(1,LRR)
	LCC=MAX0(1,LCC)
	IF(LRR.GT.DRWV.OR.LCC.GT.DCLV)GOTO 7961
	NR=NRDSP(LRR,LCC)
	NC=NCDSP(LRR,LCC)
7963	CONTINUE
C LET1='p'WILL COME HERE TOO. HANDLE IT SINCE IT'S NUMERIC STUFF.
C	IRX=(NC-1)*60+NR
	CALL REFLEC(NC,NR,IRX)
	IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961
	FORM2(118)=CHAR(15)
	DO 7113 IVV=1,128
7113	FORM(IVV)=FORM2(IVV)
	INRW=PROW
	INCL=PCOL
	JOUTR=1
	JOUTC=2
C A1 = OUT LOCATION FOR INPUT CELL NAMES
	JRTR=1
	JRTC=1
	IF(CMDLIN(3).EQ.'R')CALL RELVBL(FORM,FORM2,JOUTR,JOUTC,
     1  INRW,INCL,JRTR,JRTC)
C ALLOW RELOCATION ON LOADING SAVED SHEET IF DESIRED.
	CALL FVLDST(NR,NC,FORM2(119))
C	FVLD(NR,NC)=FORM2(119)
	CALL TYPSET(NR,NC,KKTYP)
C	TYPE(NR,NC)=KKTYP
	CALL CA2E(FORM2,FORM)
	IF(LET1.NE.'p')CALL WRKFIL(IRX,FORM,1)
C	WRITE(7'IRX)FORM2
	IF(LET1.NE.'p')GOTO 7961
C HAVE LOWERCASE 'p' NOW AS NUMERIC SAVE FLAG FOR THIS RECORD.
        if(Ibin.eq.1)xvbls(1,1)=r8s
        If(Ibin.eq.0)
     1  READ(CFORM2(1:35),6408,ERR=7961)XVBLS(1,1)
6408	FORMAT(BN,D30.19)
        If(Cmdlin(4).ne.'-'.And.Cmdlin(4).ne.'+')Goto 982
	CALL XVBLGT(NR,NC,R8WK)
	IF(CMDLIN(4).EQ.'+')XVBLS(1,1)=XVBLS(1,1)+R8WK
	IF(CMDLIN(4).EQ.'-')XVBLS(1,1)=R8WK-XVBLS(1,1)
C IMPLEMENT ADDING AND SUBTRACTING SAVED SHEETS FROM CURRENT.
C GOES TO RECALC MANUAL MODE SINCE RECALC WOULD MESS UP
C VALUES; FORMULAS GET UPDATED FROM LAST-READ SHEET NORMALLY.
	CALL XVBLST(NR,NC,XVBLS(1,1))
982     Continue
	GOTO 7961
6500	CONTINUE
C HERE READ MAPPINGS
	IRRW=IRRW-64000
	ICCL=ICCL-64000
C RESTORE OFFSETS TO NORMAL RANGE
        If(Ibin.eq.0)
     1  READ(CFORM2(1:35),6501,ERR=7961)II,III
        If(Ibin.eq.1)ii=i4s
        If(Ibin.eq.1)iii=i4t
6501	FORMAT(2I7)
	NRDSP(IRRW,ICCL)=II
	NCDSP(IRRW,ICCL)=III
C GO BACK FOR MORE. INEFFICIENT STORAGE OF MAP BUT IT'S COMPACT
C CODE...
	GOTO 7961
7964	CONTINUE
	CLOSE(4)
9990	NXINI=0
	RETURN
510	CONTINUE
	IRTN=1
	NXINI=0
	CLOSE(IOLVL)
c	CLOSE(11)
c	OPEN(5,FILE='CON:0/0/100/100/Analy Command')
	RETURN
	END
c -h- pmtx2.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE PMTX2(IRTCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	CHARACTER*1 LINE(80)
	CALL GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
     1  ID2B,RETCD)
C GET LOC OF MATRIX A (MUST BE SQUARE)
	IBGN=LSTCHR+1
	IF(RETCD.NE.0.OR.IMXX.LE.1)GOTO 1000
	IF(LINE(LSTCHR).NE.',')GOTO 300
	CALL GMTX(LINE,IBGN,LSTCHR,IDXA,IDXB,IDYA,
     1  IDYB,RETCD)
C GET LOC OF MATRIX X (RESULT).
	IBGN=LSTCHR+1
	IF(RETCD.NE.0.OR.IMXX.LE.2)GOTO 1000
	IF(LINE(LSTCHR).NE.',')GOTO 300
	CALL GMTX(LINE,IBGN,LSTCHR,IDBA,IDBB,IDCA,
     1  IDCB,RETCD)
	IBGN=LSTCHR+1
C GET LOC OF MATRIX B (AX=B), THE OTHER HALF OF OUR GIVENS
C IF WE FALL TO HERE, ALL LOOKS OK, SO LEAVE RETCD ALONE.
C HOWEVER IF ANY ERRS HAVE OCCURRED, RETCD IS ALREADY SET TO 3
C FOR ERROR...
1000	RETURN
300	CONTINUE
	RETCD=3
	RETURN
	END
c -h- postvl.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE POSTVL (RETCD)
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  POSTVL (RETCD)                *
C *                                                *
C **************************************************
C
C
C  CONVERTS POSTFIX EXPRESSIONS IN STACK 1 TO A VALUE
C
C
C	RETCD	MEANING
C
C	1	O.K.
C	2	ERROR
C
C POSTVL CALLS
C
C CALBIN    CALCULATES BINARY OPERATIONS
C CALUN     CALCULATES UNARY OPERATIONS
C ERRMSG    PRINTS OUT ERROR MESSAGES
C VAROUT    OUTPUTS THE VALUE OF A VARIABLE
C
C
C
C
C POSTVL IS CALLED BY CALC
C
C
C
C
C VARIABLE    USE
C _________ ___________________________
C
C    I,K     TEMPORARY VALUES
C
C    PT1     POINTS TO TOP ELEMENT IN STACK1
C
C    RETCD   RETURN CODE: 1=O.K., 2=ERROR
C
C    RETCD2  USED TO HOLD RETURN CODE WHEN CALLS TO
C            OTHER ROUTINES ARE MADE.
C
C    ST1PT   STACK 1 POINTER.
C
C    ST2PT   STACK 2 POINTER.
C
C    ST1TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 1
C
C    ST2TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 2
C
C    STACK1  HOLDS ORIGINAL POSTFIX EXPRESSION.
C
C    STACK2  USED TO EVALUATE EXPRESSION IN STACK1.
C
C    TYPE(27) HOLDS THE DATA TYPE FOR EACH OF THE VARIABLES.
C
C    AVBLS(100,27) HOLDS VALUES OF VARIABLES.
C    VBLS(8,60,301) HOLDS VALUE OF COMPLEXLY-NAMED VARIABLES. 1ST 27 ELEMENTS
C	ARE PLACE HOLDERS FOR AVBLS; ROUTINES THAT GENERATE DIMENSIONS ID1,ID2
C	FOR VBLS RETURN DIMENSIONS 1-27,1 FOR A-Z,%. THESE RESULT IN AVBLS
C	ARRAY BEING USED. VBLS ARRAY (MAX LENGTH 8 BYTES/VARIABLE) IS USED
C	FOR OTHER VARIABLES WHOSE NAMES ARE <ALPHA><ALPHA><NUM><NUM>
C	(WITH OPTION FOR ANY REASONABLE # OF ALPHAS AND NUMERICS BUT CLAMPED
C	AT 60,301 VALUES TO WORK CORRECTLY.)
C
C    VIEWSW   VIEW SWITCH:
C                0 = OFF
C                1 = DISPLAY COMMANDS
C                2 = DISPLAY VALUE OF EXPRESSIONS
C                3 = DISPLAY ALL
C
C
C
C	SUBROUTINE POSTVL (RETCD)
C
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 PT1
	InTeGer*4 VIEWSW,BASED
	InTeGer*4 RETCD,RETCD2,VLEN(9)
	InTeGer*4 TYPE(1,1)
	InTeGer*4 ST1TYP(40),ST2TYP(40)
	InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
	InTeGer*4 I,K
C
	CHARACTER*1 LINE(80)
	CHARACTER*1 STACK1(8,40), STACK2(8,40),AVBLS(20,27)
	CHARACTER*1 VBLS(8,1,1)
C
	COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;	       ST1LIM,ST2LIM
	COMMON /V/ TYPE,AVBLS,VBLS,VLEN
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C
C
	RETCD=1
C
C
C IF THERE IS ONE ELEMENT IN STACK1 AND IT IS NOT
C A NUMBER, THE EXPRESSION IS ILLEGAL (GO TO 95).
	IF(ST1PT.EQ.2.AND.ST1TYP(1).GT.30)GO TO 95
C
C
10	IF (ST1PT.GT.2) GOTO 40
	IF (ST1PT.EQ.1) GOTO 95
C
C
C ***************************************
C ****** ONLY 1 ELEMENT ON STACK 1 ******
C ***************************************
	K=VLEN(ST1TYP(ST1PT-1))
C
C
C COPY INTO VARIABLE %
	DO 20 I=1,K
20	AVBLS(I,27)=STACK1(I,1)
	CALL TYPSET(27,1,ST1TYP(1))
C	TYPE(27,1)=ST1TYP(1)
C
C
C OUTPUT VALUE OF %
	IF (VIEWSW.GT.1) CALL VAROUT(27,1)
	RETURN
C
C
C  MORE THAN ONE ELEMENT ON STACK1
40	CONTINUE
	IF (ST1TYP(ST1PT-1).LE.30) GOTO 90
	IF (ST2PT.LE.ST2LIM) GOTO 45
C
C
C *** ERROR *** STACK 2 OVERFLOW
	CALL ERRMSG(9)
43	RETCD=2
	RETURN
C
C
C
C
C ****************************************
C ****** OPERATOR SO PUT ON STACK 2 ******
C ****************************************
45	ST2TYP(ST2PT)=ST1TYP(ST1PT-1)
	ST2PT=ST2PT+1
	ST1PT=ST1PT-1
	IF(ST1PT.EQ.1)GO TO 95
	GOTO 40
C
C
C
C
C
C *********************
C ****** OPERAND ******
C *********************
C
C FIRST BE SURE THAT THERE IS AN OPERATOR INVOLVED ON STACK 2
C (IF ONLY ONE ELEMENT IN STACK 1 YOU SHOULD NOT BE HERE).
90	IF(ST2PT.NE.1)GO TO 110
C
C
C *** ERROR *** ILLLEGAL EXPRESSION
95	CALL ERRMSG(8)
	GO TO 43
C
C
C
C
C ENTER HERE AFTER APPLYING AN OPERATOR TO A NUMBER
100	IF (ST2PT.EQ.1) GOTO 10
110	K=ST2TYP(ST2PT-1)
C
C IF A UNARY OPERATOR, GO TO 190
	IF ((K.GT.30.AND.K.LE.47).OR.K.EQ.111) GOTO 190
C
C
C IF A BINARY OPERATOR, GO TO 170
	IF (K.GE.110.AND.K.LE.117) GOTO 170
	IF(K.EQ.200)GO TO 170
C
C IF ELEMENT ON STACK2 AT ST2PT-1 IS AN OPERAND, APPLY CALBIN AGAIN
	IF(K.LE.30) GO TO 180
	STOP 110
C
C
C
C
C ***************************************************************
C ****** CALBIN CALCULATES THE BINARY VALUE OF AN OPERATOR ******
C ***************************************************************
C  UPON ENTRANCE:
C	OPERAND 1 IS IN STACK 1
C	OPERAND 2 IS IN STACK 2
C	OPERATOR IS BELOW OPERAND 2
C  UPON EXIT RESULT IS ON STACK 1
C
C	RETURN CODE	MEANING
C
C	1		O.K.
C	2		OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C	3		ERROR ENCOUNTERED
C
C
170	CONTINUE
C
C
C FIRST PUT OPERAND 2 ONTO STACK 2
	PT1=ST1PT-1
	ST2TYP(ST2PT)=ST1TYP(PT1)
	K=VLEN(ST2TYP(ST2PT))
	DO 175 I=1,K
175	STACK2(I,ST2PT)=STACK1(I,PT1)
	ST1PT=ST1PT-1
	IF(ST1PT.EQ.1)GO TO 95
	ST2PT=ST2PT+1
C
C
C IF OPERAND 1 IS AN OPERATOR, PUT IT ON STACK 2 (GO TO 45)
	IF(ST1TYP(ST1PT-1).GT.30) GO TO 45
180	CALL CALBIN (RETCD2)
	GOTO (100,1000,43), RETCD2
	STOP 180
C
C
C
C
C
C ********************************************************************
C ****** CALL CALUN TO CALCULATE THE VALUE OF A UNARY OPERATION ******
C ********************************************************************
C	OPERATOR IS IN STACK 2
C	OPERAND IS IN STACK 1
C	UPON EXIT, OPERATOR IS POPPED OFF STACK 2
C
C	RETURN CODE	MEANING
C
C	1		O.K.
C	2		OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C	3		ERROR ENCOUNTERED
C
C
190	CALL CALUN (RETCD2)
	GOTO(100,43),RETCD2
	STOP 190
C
C
1000	RETURN
	END
c -h- prtcon.for	Tue Sep  2 10:58:55 1986	
C **********************************
C *                                *
C *    INTERNAL FUNCTION PRTCON    *
C *                                *
C **********************************
C CALLED BY MOUT ONLY
C CONVERTS 0 TO APPROPRIATE NUMBER FOR PRINTING WITH VECTOR DIGITS
	FUNCTION PRTCON(L1,IBASE)
	InTeGer*4 BASE(3)
	InTeGer*4 IBASE,K
	CHARACTER*1 L1,PRTCON,DIGITS(16,3)
	COMMON /DIGV/ DIGITS
	DATA BASE /10,8,16/
	PRTCON=L1
	IF(L1.EQ.0)PRTCON=CHAR(BASE(IBASE))
	K=ICHAR(PRTCON)
	PRTCON=DIGITS(K,IBASE)
	RETURN
	END
c -h- rassig.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RASSIG(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	InTeGer*4 IUNIT
C &&&& MS FTN 3.2
	LOGICAL LEXIST
C &&&&
	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	CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C	INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
	INQUIRE(FILE=WK(1:20),EXIST=LEXIST)
	IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
c	CALL UVT100(1,1,1)
c	CALL SWRT('File not found. Attempting to create.',37)
c	OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
c     1  FORM='FORMATTED')
c	CLOSE(IUNIT)
c
c On failure to open a file, create a window instead which
c can be its surrogate...
c
	Open(Iunit,file='CON:200/100/400/60/RdErr ' // wk,
     1  Access='Sequential',form='Formatted')
C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
C WILL GET EOF ON START, BUT THAT'S TOO BAD...
	Goto 77
100	CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
	OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
77	CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
	RETURN
	END
c -h- recalc.f40	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RECALC
C COPYRIGHT (C) 1983,1984,1985,1986 GLENN EVERHART
C ALL RIGHTS RESERVED
C RECALCULATE COMMAND
C RECOMPUTE ALL ELEMENTS OF SPREADSHEET WHERE VALID.
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	Include AParms.inc
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
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 >>>***
CCCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC     1  IRCE1,IRCE2
CCCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC     1  IRCE1,IRCE2
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	InTeGer*4 DLFG
CCC	COMMON/DLFG/DLFG
C DLFG=1 IF D## FORMS HAVE BEEN SEEN, ELSE 0
	DIMENSION FORM(128),FVLD(1,1)
	COMMON/FVLDC/FVLD
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=-2 OR -3 = DISPLAY FORMULA
C FVLD=3 NUMERIC, COMPUTE ONCE THEN SET FVLD TO 2
C FVLD=2 NUMERIC CONSTANT, ALREADY COMPUTED... DO NOT RECOMPUTE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
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
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
CCC	InTeGer*4 RRWACT,RCLACT
CCC	COMMON/RCLACT/RRWACT,RCLACT
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	InTeGer*4 PRS,PCS,DRS,DCS
	Character*6 cwrk6
	PRS=PROW
	PCS=PCOL
	DRS=DROW
	DCS=DCOL
	IF(RCMODE.EQ.2)GOTO 5500
C THE FOLLOWING 2 LOOPS DEFINE ORDER OF CALCULATION.
C HERE THIS IS: OUTER LOOP ON ROWS (ACROSS), INNER LOOP ON COLUMNS (DOWN).
C NOTE THAT N2 DEFINES THE SHEET. SINCE 1 IS THE ACCUMULATORS, JUST GO THRU
C FOR THE SHEET, NOT THE AC'S.
	DO 1 N2=2,RCLACT
	IF(IDOL8.EQ.0)GOTO 8220
C VIEW HACK HERE
C DISPLAY ROW NUMBER FOLLOWED BY BARE CR DURING RECALC
	KKKK=13
C 13 IS ASCII CARRIAGE RETURN
	write(cwrk6,8221)n2
	call uvt100(1,llcmd,60)
	call vwrt(cwrk6,5)
c	REWIND 11
c	WRITE(11,8221)N2,KKKK
c	REWIND 11
8221	FORMAT(I5,1A1)
8220	CONTINUE
	N1=1
220	CONTINUE
C	DO 2 N1=1,60
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
C 
CCCC COMMENT 2 LINES OUT WHEN FAST FVLDGT IS IN TO SPEED UP MORE...
CCCC EXTRA LOGIC IN FVPEEK DOESN'T USUALLY PAY FOR ITSELF...
CCC	CALL FVPEEK(N1,N2,NN1)
CCC	N1=NN1
	CALL FVLDGT(N1,N2,FVLD(1,1))
	IIFV=JCHAR(FVLD(1,1))
	IF (IIFV.LE.0) GOTO 2
	IRRX=(N2-1)*MCols+N1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
	IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 2
	KDRW=N1
	KDCL=N2
	PROW=N1
	PCOL=N2
C SEE IF THIS PHYS COL HAS A DISPLAY COL. AND IF SO SET THAT UP.
C ONLY SET TO DISPLAYED LOCS HERE TO MINIMIZE SEARCH TIME.
C NEED THIS TO HANDLE D## FORMS...
	IF (DLFG.EQ.0)GOTO 95
C IF NEVER HAD A D## FORM FORGET LOOKING FOR DISPLAY LOCS.
	DO 20 M2=1,DCLV
	DO 10 M1=1,DRWV
	M1X=M1
	M2X=M2
C LOOK FOR DISPLAY COORDS EVEN IF IN HYPERSPACE
C WE FIND ONE IF INDEX FROM REFLECT IS SAME AS WHAT
C WE'RE LOOKING FOR...
	IF(NRDSP(M1,M2).EQ.N1.AND.NCDSP(M1,M2).EQ.N2)GOTO 9
10	CONTINUE
20	CONTINUE
95	CONTINUE
C HERE IF CELL NOT DISPLAYED... SEE IF NEEDS DOING IN RI, RE MODES
	IF(RCMODE.LE.0)GOTO 9
	IF(PROW.NE.IRCE1.OR.PCOL.NE.IRCE2)GOTO 2
C SKIP UNLESS ENTER CELL.
9	CONTINUE
C IF NO DISPLAY ROW, LEAVE AT LOW RIGHT...
C USE SAVED VALUES SO WE DON'T RELY ON DO LOOP INDEX AFTER LOOP END.
	DROW=M1X
	DCOL=M2X
	CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
	LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
	DO 56 N=1,109
	LLST=111-N
	IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 57
	FORM(LLST)=Char(0)
56	CONTINUE
57	CONTINUE
	FORM(LLST)=Char(0)
	FORM(111)=Char(0)
C	IF(ICHAR(FORM(118)).NE.15)GOTO 2
c ****&&&& experimental...
c &&&&&**** replace llst by llst-1
c	llst=max0(1,llst-1)
	CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
C	CALL FVLDGT(N1,N2,FVLD(1,1))
	IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
2	CONTINUE
	N1=N1+1
	IF(N1.LE.RRWACT)GOTO 220
1	CONTINUE
	GOTO 5600
5500	CONTINUE
C RCMODE=2 AND NOT RM MODE
C (IN RM MODE, RECALC IS NOT CALLED...)
	DO 1701 M2=1,DCLV
	IF(IDOL8.EQ.0)GOTO 8222
C VIEW HACK HERE
C DISPLAY ROW NUMBER FOLLOWED BY BARE CR DURING RECALC
	KKKK=13
C 13 IS ASCII CARRIAGE RETURN
	write(cwrk6,8221)n2
	call uvt100(1,llcmd,60)
	call vwrt(cwrk6,5)
C 13 IS ASCII CARRIAGE RETURN
c	REWIND 11
c	WRITE(11,8221)M2,KKKK
c	REWIND 11
8222	CONTINUE
	KDRW=1
	KDCL=2
	DO 1702 M1=1,DRWV
C TO HANDLE DISPLAY WHEREVER IT MAY BE, FIND ID OF PHYS CELL AND
C CONVERT TO PHYS ROW, COL AGAIN REGARDLESS OF ALIAS...
C (NOTE CALC ORDER IS THEREFORE DISPLAY ORDER, NOT SHEET ORDER...)
	K=NRDSP(M1,M2)
	KK=NCDSP(M1,M2)
	CALL REFLECT(KK,K,IV1)
	NRC=IV1-1
	N1=MOD(NRC,MCols)+1
	N2=((NRC-N1+1)/MCols)+1
C COMPUTE PHYS ROW, COL FROM DISPLAY COORDINATES.
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
	If (N1.gt.RRWACT.or.N2.Gt.RCLACT) GOTO 1702
	CALL FVLDGT(N1,N2,FVLD(1,1))
	IIFV=JCHAR(FVLD(1,1))
	IF (IIFV.LE.0) GOTO 1702
C FORGET THIS CELL IF NOT A COMPUTABLE ONE...
	IRRX=IV1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
	IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 1702
	KDRW=N1
	KDCL=N2
	PROW=N1
	PCOL=N2
	DROW=M1
	DCOL=M2
	CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
	LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
C (ALSO GUARANTEE WE HAVE LOTS OF NULLS AT END TO TERMINATE INDEX ROUTINES)
	DO 756 N=1,109
	LLST=111-N
	IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 757
	FORM(LLST)=Char(0)
756	CONTINUE
757	CONTINUE
	FORM(LLST)=Char(0)
	FORM(111)=Char(0)
C CALL DOENTR TO DO THE ACTUAL COMPUTATION WORK...
	CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
	IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
1702	CONTINUE
1701	CONTINUE
C END OF COMPUTATION OVER DISPLAYS
C	GOTO 5600
5600	CONTINUE
	PROW=PRS
	PCOL=PCS
	DROW=DRS
	DCOL=DCOL
C FORCE FUNCTION WORKS ONCE ONLY.
	RCONE=0
	RCMODE=IABS(RCMODE)
C SET FOR TEMP. RECALC-ALL MODES TO RETURN TO NORMAL.
	IRCE1=0
	IRCE2=0
	RETURN
	END
c -h- reflect.f40	Tue Sep  2 10:58:55 1986	
	SUBROUTINE REFLEC(ID1,ID2,ID)
C FORM ID OUT OF ID1,ID2 BUT USING REFLECTED VALUES SO THAT
C RESULT ID IS ALWAYS IN PRIME AREA.
	Include AParms.inc
	InTeGer*4 ID,ID1,ID2,IDD1,IDD2
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,MRows)
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	COMMON/MIRROR/ICREF,IRREF
C IN RECALC WE MOVE OVER PRIME AREA ONLY AND SEARCH FOR CELLS IN
C DISPLAY AREA THERE. THIS IMPLIES THAT WE DON'T FIND DISPLAY
C COORDS OF CELLS IN EXTENDED AREAS THERE.  THEREFORE THE RI AND RE
C MODES FAIL COMPLETELY THERE. SINCE WE WANT THE SYSTEM TO WORK IN
C A PREDICTABLE WAY, FORCE RECALC MODE (I.E., R OR RM MODES) THERE TO
C ALLOW CELLS TO BE COMPUTED.
C NOTE THAT IF WE ARE IN THE PRIME AREA AND ISSUE AN RE OR RI COMMAND,
C THAT MODE SHOULD STAY SET SO LONG AS WE STAY THERE SINCE THE RE OR
C RI MODES WILL INHIBIT COMPUTING OUTSIDE THAT AREA (AS LONG AS NOTHING
C REFLECTS INTO IT) SO THERE WILL BE NO REASON FOR THIS TO BE CALLED
C TO REFLECT SOMETHING BACK TO PRIME AREA UNTIL A R COMMAND IS GIVEN
C OR THE DISPLAY MOVES OFF THE EDGE OF THE PRIME 60 BY 301 AREA.
C
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 FORMFG,RCFGX,PZAP,RCONE,RCMODE
CCC	InTeGer*4 IRCE1,IRCE2
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,IRCE2
	IDD1=MAX0(ID1,1)
	IDD2=ID2
C ACCEPT TRICK CALLS WITH ID1=0 AS FROM GMSUBS, MTXEQU,
C AND MDST
	IF(ID1.LT.1)GOTO 2000
4000	CONTINUE
	IF(IDD2.LE.MCols)GOTO 1000
	IDD2=IDD2-MCols
	IDD1=IDD1+IRREF
c	RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
	GOTO 4000
1000	CONTINUE
	IF(IDD1.LE.MRows)GOTO 2000
	IDD1=IDD1-MRows+1
	IDD2=IDD2+ICREF
c	RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
	GOTO 4000
2000	CONTINUE
	ID=(IDD1-1)*MCols+IDD2
	RETURN
	END
c -h- relvbl.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RELVBL(LNIN,LNOUT,INRW,INCL,JOUTR,JOUTC,JRTR,JRTC)
C RELOCATE VARIABLES BELOW/RIGHT OF JRTR,JRTC INTO LNOUT FROM LNIN
C	PARAMETER CUP=1,ED=11,EL=12
	Include AParms.inc
	CHARACTER*1 NAME(4),NUMBER(6)
	CHARACTER*1 LNIN,LNOUT
	CHARACTER*6 NUMBR6
	EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
	DIMENSION LNIN(128),LNOUT(128)
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
	Integer*4 K3dfg,kcdelt,krdelt,kpag,idol9,idsptp
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,Idsptp,Idol9,
     3  k3dfg,kcdelt,krdelt,kpag
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
C	LOGICAL*2 L63,L192,L255,L127,L128
	LOGICAL*4 L1,L2
C	InTeGer*4 I63,I192,I255,I127,I128
	InTeGer*4 I63,I192,I127
	InTeGer*4 I1,I2
C	EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
	EQUIVALENCE (I1,L1),(I2,L2)
C	EQUIVALENCE (L127,I127),(L128,I128)
C	DATA I63/63/,I192/192/,I255/255/,I127/127/,I128/128/
	DATA I63/63/,I192/192/,I127/127/
	LI=1
	LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100	CONTINUE
	KSheet=0
C	IF(LNIN(LI).LT.'A'.OR.LNIN(LI).GT.'Z')GOTO 200
	LCC=ICHAR(LNIN(LI))
C IF WE HAVE 255,CODE,CODE THEN RELOCATE IN BINARY...
	IF(LCC.EQ.255)GOTO 500
	IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
	IL1=LI
	LE=110
	LSTC=LE
	CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
C AVOID MESSING UP FUNCTION NAMES
	IF(ID2.EQ.1)IVLD=0
C	IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0
	IF(IVLD.EQ.0)GOTO 200
C FOUND VARIABLE. NOW GENERATE ASCII ANDSTUFF INTO OUTPUT.
C FIRST DON'T RELOCATE P## AND D## FORMS.
	IF(LNIN(LI+1).EQ.'#')GOTO 250
C RELOCATE NORMAL VARIABLE HERE.
C
C THE NEW VARIABLE IS TO BE DIFFERENT ONLY IF (ID1,ID2) HAS
C ID1.GT.JRTR AND ID2.GT.JRTC
	IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 210
	IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 210
C OK, KNOW NOW THAT WE HAVE TO RELOCATE ALL.
C THEREFORE ADD THE DIFFERENCE BETWEEN DEST AND SRC TO BOTH
C AND CLAMP TO VALID DIMENSIONS.
	IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
	IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
906	ID1=MAX0(ID1,1)
	ID2=MAX0(ID2,1)
C CAN UNPACK THIS STUFF ALL RIGHT IN EXTENDED WAYS.
	ID1=MIN0(MRC,ID1)
	ID2=MIN0(MRC,ID2)
210	CONTINUE
	KSHEET=0
	IF(K3DFG.LE.2)GOTO 2221
C RENAME CELLS BY 3D NAMES. (NOTE FLAG TO DO THIS; USE FOR DISPLAYS)
C ID1 GETS REDUCED BY COL. DELTA AND ID2 BY ROW DELTA
C UNTIL ONE OR BOTH ARE LESS THAN THE DELTAS. THEN THE %NNNN IS TACKED ON
C THE END. THIS PERMITS USERS TO DECIDE WHETHER THEY WANT THINGS TRANSLATED
C TO SHEET NUMBER FORMAT OR NOT.
	IF(KCDELT.LE.0.AND.KRDELT.LE.0)GOTO 2221
	KRR1=MRC
	KCC1=MRC
	IF(KCDELT.GT.0)KCC1=(ID1-1)/KCDELT
	IF(KRDELT.GT.0)KRR1=(ID2-2)/KRDELT
	KSH=MIN0(KRR1,KCC1)
	IF(KSH.GE.(MRC-100))GOTO 2221
C IF BOTH DELTAS ARE ZERO DON'T TOUCH ANYTHING.
	KSHEET=MAX0(KSH,0)
C KSHEET NONZERO FLAGS WE MAKE THE MOD
	IF(ID1.LT.KSHEET*KCDELT)GOTO 2220
	IF((ID2-1).LT.KSHEET*KRDELT)GOTO 2220
	ID1=ID1-KSHEET*KCDELT
	ID2=ID2-KSHEET*KRDELT
c222	CONTINUE
	GOTO 2221
2220	CONTINUE
	KSHEET=0
2221	CONTINUE
	CALL IN2AS(ID1,NAME)
C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
	IL2=ID2-1
	WRITE(NUMBR6(1:6),1000)IL2
C	ENCODE(6,1000,NUMBER)IL2
1000	FORMAT(I6)
C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
C THROW OUT SPACES AND COPY THE REST.
	LI=LSTC
	DO 202 N=1,4
	IF(Ichar(NAME(N)).LE.32)GOTO 202
	LNOUT(LO)=NAME(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
202	CONTINUE
	IF(IDOL1.GT.0)LNOUT(LO)=36
	IF(IDOL1.GT.0.AND.LO.LE.109)LO=LO+1
	DO 203 N=1,6
	IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
C IF 32 ISN'T SPACE, LOSE
	LNOUT(LO)=NUMBER(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
203	CONTINUE
	IF(IDOL2.EQ.0)GOTO 275
	LNOUT(LO)=Char(36)
	IF(LO.LE.109)LO=LO+1
275	Continue
	IF(KSHEET.EQ.0)GOTO 300
C ADD SHEET NUMBER CRUFT IF CALLED FOR.
	LNOUT(LO)=Char(37)
C 37 IS % SIGN
	IF(LO.LE.109)LO=LO+1
	NUMBR6(1:6)='      '
	WRITE(NUMBR6(1:6),1000)KSHEET
C	ENCODE(6,1000,NUMBER)KSHEET
	DO 1203 N=1,6
	IF(Ichar(NUMBER(N)).LE.32)GOTO 1203
C IF 32 ISN'T ASCII SPACE, LOSE.
	LNOUT(LO)=NUMBER(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
1203	CONTINUE
C NOW HAVE THE FULL VALUE ENCODED, INCLUDING SHEET NUMBER IF APPROPRIATE.
c	IF(LO.LE.109)LO=LO+1
	GOTO 300
250	CONTINUE
C JUST COPY DISPLAY FORMS.
	IL1=LSTC-1
	DO 251 N=LI,IL1
	LNOUT(LO)=LNIN(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
251	CONTINUE
	LI=LSTC
C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
	GOTO 300
200	LNOUT(LO)=LNIN(LI)
	LO=LO+1
	LI=LI+1
300	IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
	LO=MIN0(LO,110)
	DO 400 N=LO,110
400	LNOUT(N)=0
	DO 1 N=111,128
1	LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
	RETURN
500	CONTINUE
C DECODE BY HAND...
	LNOUT(LO)=LNIN(LI)
	I1=ICHAR(LNIN(LI+1))
	I2=IMASK(I1,I192)
C	L2=L1.AND.L192
	I1=IMASK(I1,I63)
C	L1=L1.AND.L63
C DO MASKING TO GET BINARY COORDS
	ID1=I1
	I1=ICHAR(LNIN(LI+2))
	I1=IMASK(I1,I127)
C	L1=L1.AND.L127
	ID2=I2*2+I1
C NOW RELOCATE AND PUT BACK
	IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 510
	IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 510
	IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
	IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
C CLAMP RESULT TO MAX RANGES
	ID1=MAX0(ID1,1)
	ID2=MAX0(ID2,1)
C DO GENERAL REPACK IF ID1 OR ID2 ARE EXTENDED RANGE.
	IF(ID1.GT.60.OR.ID2.GT.301)GOTO 905
C leave 60, 301 literals here since this controls repacking
C	ID1=MIN0(60,ID1)
C	ID2=MIN0(301,ID2)
510	CONTINUE
C RELOCATED, NOW REPACK AS NEW BINARY PATTERNS
	I1=ID1
C	L1=L1.AND.L63
	I1=IMASK(I1,I63)
	I2=ID2/2
	I2=IMASK(I2,I192)
C	L2=L2.AND.L192
C	L1=L1.OR.L2
	I1=I1+I2
	LNOUT(LO+1)=CHAR(I1)
	I2=ID2
	I2=IMASK(I2,I127)+128
C	L2=L2.AND.L127
C	L2=L2.OR.L128
C BE SURE AT LEAST 1 BIT IS SET
	LNOUT(LO+2)=CHAR(I2)
	LI=MIN0(109,LI+3)
	LO=MIN0(109,LO+3)	
C GO LOOK FOR MORE TO DECODE
	GOTO 300
905	CONTINUE
C HERE SET UP FOR REENTRY INTO "NORMAL" DECODE
	LSTC=MIN0(109,LI+3)
	GOTO 906
	END
c -h- rnd.for	Tue Sep  2 10:58:55 1986	
	FUNCTION RND(DUM)
C GENERATE RANDOM NUMBER BY LINEAR CONGRUENCE IN BIG
C INTEGERS.
	REAL*4 R
	INTEGER*4 DUM
	INTEGER*4 I,II
	LOGICAL*4 L,LMSK
	REAL*8 XX
	EQUIVALENCE(I,L),(II,LMSK)
	I=DUM
	XX=I
	XX=XX*214013.0D0+2531011.0D0
	IF(XX.LT.0.)XX=1.0D0-XX
	XX=DMOD(XX,16777216.0D0)
	I=IDINT(XX)
C	I=I*214013+2531011
C USE MASKING TO ZOT THIS INTO NORMAL RANGE
C JUST USE MODULO...
	IF(I.LT.0)I=1-I
	IF(I.LT.0)I=0
	I=MOD(I,16777215)
	DUM=I
C RETURN RANDOM BETWEEN 0 AND 1.0
C PERIOD OF 2**24 MAX
	XX=I
	XX=XX/16777216.0
	R=SNGL(XX)
	RND=R
	RETURN
	END
c -h- rvboo.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RVBOO(RETV,ID1,ID2)
C THIS ROUTINE ONLY COPIES ID1,ID2 INTO RETV ARRAY TO AVOID SOME
C BYTE-INTEGER CONVERSION PROBLEMS. THIS PACKING IS USED TO
C ACCESS VARIABLE LOCATION LATER.
	InTeGer*4 RETV,ID1,ID2
	DIMENSION RETV(2)
	RETV(1)=ID1
	RETV(2)=ID2
	RETURN
	END
c -h- scmp.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SCMP(LINA,LINB,LENM,ICODE)
	DIMENSION LINA(1),LINB(1)
	CHARACTER*1 LINA,LINB
	ICODE=1
	DO 1 N=1,LENM
	IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
C ALLOW _ TO BE A WILDCARD.
	IF(LINA(N).EQ.'_'.OR.LINB(N).EQ.'_')GOTO 1
	IF(LINA(N).NE.LINB(N))ICODE=0
	IF(ICODE.NE.1)GOTO 2
1	CONTINUE
2	CONTINUE
	RETURN
	END
c -h- sed.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SED(LCMD,LIN,LWRK,ARGSTR,XAC,LENGTH)
	CHARACTER*1 LIN(1),LWRK(1),ARGSTR(52,4)
	CHARACTER*1 LCMD(1),LSU(10)
	EXTERNAL INDX
	CHARACTER*10 LSU10
	EQUIVALENCE (LSU10(1:10),LSU(1))
	INTEGER*4 III
	REAL*8 XAC
C
C OPERATION:
C EDIT LIN TO LWRK, WITH LENGTH VARIABLE HOLDING INPUT
C LENGTH IN CHARACTERS. LCMD HOLDS COMMAND LINE, WHICH
C ULTIMATELY GETS EDITED STRING COPIED BACK INTO IT.
C
C EDITS:
C  CHARACTER AT IDELIM IS DELIMITER. REPLACE STRING IN 1ST
C INTERVAL BETWEEN DELIMITERS WITH SECOND.
C  HOWEVER:
C  &1 TO &4 GET CONTENTS (UP TO NULL) OF ARGSTR(X,1) TO (X,4)
C
C  &5 RETURNS XAC VALUE CONVERTED TO DECIMAL INTEGER AND
C  PRINTED.
C  &6 RETURNS XAC VALUE CONVERTED TO ASCII CODE (1 BYTE) AND
C  INSERTED.
C XAC ENTERS WITH CONTENTS OF ACCUMULATOR Z (TO AVOID TOO MUCH
C DIFFICULTY IN USING IT OWING TO THE UBIQUITY OF USE OF %).
C	WE ENTER JUST POINTING AT THE COMMAND LINE AFTER THE ENTER
C AND ITS SPACE. ASSUME 1ST CHARACTER IS OUR DELIMITER.
	DO 335 IV=1,80
335	LWRK(IV)=Char(0)
	IDELIM=ICHAR(LCMD(1))
	ID2=INDX(LCMD(2),IDELIM)
	IF(ID2.GE.LENGTH)GOTO 100
C NOW HAVE 1ST STRING, OF NONZERO LENGTH
C FIND SECOND STRING NOW. EITHER MAY BE OF 0 LENGTH BUT
C BOTH MUST BE DEFINED BY A DELIMITER.
	ID3=INDX(LCMD(2+ID2),IDELIM)
	IF(ID3.GE.LENGTH)GOTO 100
C WELL, WE GOT IT SOMEHOW. NOW TRY AND EDIT THE JUNK IN.
C (NOTE WE WANT TO FILL ALL OF LENGTH)
	INLIN=1
	INWRK=1
	IVV=ID3+ID2+2
	DO 336 IV=IVV,LENGTH
336	LCMD(IV)=Char(0)
	LSA=ID2-1
	LSB=ID3-1
	LSSB=2+ID2
	LZR=0
	DO 1 N=1,LENGTH
	IF(LSA.GT.0)GOTO 350
C ZERO LENGTH INITIAL STRING, SO ASSUME HE WANTS TO APPEND TO
C EXISTING STRING AT THE END.
C (HANDY FOR ADDING TO FORMULAE OR THE LIKE.)
	IF(Ichar(LIN(N)).EQ.0)GOTO 351
C JUST COPY THE INPUT FIRST AND GO OFF
	GOTO 2
351	CONTINUE
C HERE WE HAVE THE TERMINAL NULL
	LZR=LZR+1
C ALLOW US TO PRETEND FOR ONCE THAT WE GOT A MATCH
	IF(LZR.EQ.1)GOTO 222
	GOTO 1
350	CONTINUE
	IF(Ichar(LIN(INLIN)).EQ.0)GOTO 1
	CALL SSCMP(LIN(INLIN),LCMD(2),LSA,ICOD)
	IF(ICOD.EQ.0)GOTO 2
C HERE HAVE TO SUBSTITUTE
C PASS STRING TO SUBSTITUTE ON INPUT LINE FIRST.
222	CONTINUE
	INLIN=INLIN+LSA
C ALLOW ZERO LENGTH SUBSTITUTE CHARACTER
	IF(LSB.LE.0)GOTO 1
C	DO 6 M=1,LSB
	M=1
106	CONTINUE
	IF(LCMD(LSSB+M-1).EQ.'&')GOTO 7
8	CONTINUE
C JUST COPY ONE CHARACTER OF THE SUBSTITUTE STRING IN HERE.
	LWRK(INWRK)=LCMD(LSSB+M-1)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
	GOTO 6
7	CONTINUE
C HANDLE & FORMS
	IF(LCMD(LSSB+M).LT.'1'.OR.LCMD(LSSB+M).GT.'6')GOTO 8
C REQUIRE ALL FORMS TO BE &1 THRU &6 TO BE DEALT WITH HERE.
	M=M+1
	IF(LCMD(LSSB+M-1).GT.'4')GOTO 10
C HERE JUST HANDLE ARGSTR SUBSTITUTIONS.
	II=ICHAR(LCMD(LSSB+M-1))
	II=II-48
C II IS NOW THE INDEX.
	DO 11 MM=1,52
	LWRK(INWRK)=ARGSTR(MM,II)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
	IF(ARGSTR(MM,II).EQ.0)GOTO 12
11	CONTINUE
12	CONTINUE
	M=M+1
C PASS THE NUMBER OF THE &NUMBER FORM
	GOTO 6
10	CONTINUE
C HANDLE ZAC FORMS
	M=M+1
C PASS THE DIGIT
	IF(LCMD(LSSB+M-2).EQ.'5')GOTO 14
C FILL IN ZAC AS AN INTEGER
	II=32
	IF(XAC.GE.1.AND.XAC.LT.256.)II=XAC
C ONLY HANDLE CONVERSION IF LEGAL
	LWRK(INWRK)=CHAR(II)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
	GOTO 6
14	CONTINUE
C HANDLE NUMERIC CONVERSION HERE
	LSU(1)=0
	III=0
	IF(DABS(XAC).LT.9999999.)III=IDINT(XAC)
	WRITE(LSU10(1:10),15,ERR=22)III
C	ENCODE(10,15,LSU,ERR=22)III
15	FORMAT(I9)
22	DO 16 MK=1,10
	IF(Ichar(LSU(MK)).EQ.0)GOTO 6
	IF(LSU(MK).EQ.' ')GOTO 16
	LWRK(INWRK)=LSU(MK)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
16	CONTINUE
6	CONTINUE
	M=M+1
	IF(M.LE.LSB)GOTO 106
	GOTO 1
2	CONTINUE
C HERE JUST ANOTHER CHARACTER TO MOVE, DO THE MOVE.
	LWRK(INWRK)=LIN(INLIN)
	IF(INLIN.LT.LENGTH)INLIN=INLIN+1
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
1	CONTINUE
C COPY BACK OUT TO CMDLIN AFTER FIXUP
	IF(INWRK.GE.LENGTH)GOTO 3
	DO 4 N=INWRK,LENGTH
4	LWRK(N)=0
3	CONTINUE
C REPLACE COMMAND LINE WITH EDITED STRING FOR ENTRY NOW.
	DO 5 N=1,LENGTH
5	LCMD(N)=LWRK(N)
100	CONTINUE
	RETURN
	END
c -h- sign.for	Tue Sep  2 10:58:55 1986	
	REAL *8 FUNCTION SIGN(VAR)
	REAL*8 VAR
C ALWAYS RETURN 1. OR -1. FOR THIS PROGRAM ... NEVER 0.
	SIGN=1.
	IF(VAR.LT.0.)SIGN=-1.
	RETURN
	END
c -h- slend.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SLEND(RETCD)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY 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   SLEND(RETCD)              *
C *                                                *
C **************************************************
C
C
C
C SETS VALUE OF LEND, POINTER TO LAST NON-BLANK CHARACTER
C IN LINE(80)
C
C
C
C
C RETCD VALUE       MEANING
C
C    1            NORMAL RETURN
C    2            ALL BLANKS
C
C
C
C   SLEND IS CALLED BY CALC
C
C VARIABLE    USE
C
C  BLANK      ' '
C    I        INDEXES CHARACTERS IN LINE(80).
C  LEND       UPON EXIT, POINTS TO THE LAST NON-
C             BLANK IN LINE(80).
C  LINE(80)   HOLDS COMMAND LINE.
C  RETCD      RETURN CODE.  1=NORMAL, 2=ALL BLANKS
C
C
C
C	SUBROUTINE SLEND(RETCD)
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 VIEWSW,BASED,RETCD
C
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	CHARACTER*1 LINE(80)
C
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
C
C
C
	RETCD=1
	DO 100 I=1,80
	IF(LINE(81-I).NE.BLANK)GO TO 200
100	CONTINUE
	RETCD=2
	RETURN
200	LEND=81-I
	RETURN
	END
c -h- sscmp.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SSCMP(LINA,LINB,LENM,ICODE)
	DIMENSION LINA(1),LINB(1)
	CHARACTER*1 LINA,LINB
	ICODE=1
	DO 1 N=1,LENM
c	IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
	IF(ICHAR(LINA(N)).NE.ICHAR(LINB(N)))ICODE=0
	IF(ICODE.NE.1)GOTO 2
1	CONTINUE
2	CONTINUE
	RETURN
	END
c -h- sstr.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SSTR(CMDLIN,LA,N,LE,FORM)
	CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
	InTeGer*4 LA,N,LE
	InTeGer*4 VLEN(9),TYPE(1,1)
	CHARACTER*1 AVBLS(20,27)
	REAL*8 XVBLS(1,1),XX,VP,TMP
	COMMON/V/TYPE,AVBLS,XVBLS,VLEN
	NI=N
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
C MUST PASS _@ CHARS TO GET VARIABLE
	LAA=LA+2
	LEE=LE
	CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
	IF(IVLD.LE.0)GOTO 990
C	XX=XVBLS(I1,I2)
	CALL XVBLGT(I1,I2,XX)
	VP=128.D0**7
	DO 1 NN=1,8
	TMP=DINT(XX/VP)
	NBF(NN)=CHAR(IDINT(TMP))
	XX=XX-(VP*TMP)
	VP=DINT(VP/128.D0)
	IF(VP.EQ.0.0D0)VP=1.0D0
1	CONTINUE
C NOW NBF HAS 8 BYTES OF DATA CORRESPONDING TO DE-HASHED
C STRING. COPY TO FORM.
	NL=NI
	DO 2 NN=1,8
	FORM(NL)=NBF(NN)
	IF(ICHAR(NBF(NN)).GE.32)NL=NL+1
2	CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
	N=NL-1
	LA=LSTC-1
	CMDLIN(LA)=FORM(N)
C HOPE ALL'S WELL NOW...
	RETURN
990	FORM(N)=CMDLIN(N)
	RETURN
	END
c -h- strcmp.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
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 STRCMP(NAME,LENGTH,RETCD)         *
C *                                                *
C **************************************************
C
C
C  STRCMP LOOKS PAST BLANKS FOR THE NAME HELD BY NAME(1),...,NAME(LENGTH)
C  THE RETURN CODE RETCD INDICATES SUCCESS OR FAILURE:
C
C	1=MATCH
C	2=FAILURE
C
C  UPON EXIT, COMMON VARIABLE NONBLK
C         IF SUCCESSFUL, POINTS TO ONE BEYOND THE LAST CHARACTER SCANNED
C                 FOR MATCH
C         IF FAILURE, UNCHANGED
C
C
C
C  MODIFICATION CLASSES: M2
C
C
C
C  STRCMP CALLS GETNNB TO GET THE NEXT NON-BLANK FROM LINE(80)
C
C  STRCMP IS CALLED BY CMND
C
C
C
C
C VARIABLE       USE
C
C   I2        INDEXES NAME(LENGTH).
C   IS        HOLDS VALUE OF NONBLANK IN CASE AN ERROR OCCURS
C             AND IT IS NECESSARY TO RESTORE THE VALUE.
C   LENGTH    HOLDS THE LENGTH OF VECTOR NAME.
C   NONBLK    POINTER FOR COMMAND LINE HELD BY LINE(80).
C   RETCD     HOLDS RETURN CODE.  1=MATCH,  2=FAILURE
C
C
C
C
C	SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
	InTeGer*4 LENGTH
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4  RETCD,VIEWSW,BASED
C
	CHARACTER*1  LINE(80),NAME(LENGTH)
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C UPON ENTRANCE, NONBLK POINTS TO THE FIRST CHARACTER
C IN NAME, COMPARE LOOKS PAST THIS TO THE NEXT CHARACTER
C SINCE CMND HAS ALREADY IDENTIFIED THAT FIRST CHARACTER
C IN THE COMMAND NAME (AFTER THE ASTERISK).
	IS=NONBLK
	CALL GETNNB(IPT,RETCD)
	GO TO (10,999),RETCD
C ON EXIT NONBLK POINTS TO LAST CHARACTER IN NAME
C
C
10	DO 100 I2=1,LENGTH
	CALL GETNNB(IPT,RETCD)
	GO TO (20,999),RETCD
	STOP 20
20	NONBLK=IPT
	IF(NAME(I2).NE.LINE(NONBLK))GOTO 999
100	CONTINUE
	RETCD=1
	RETURN
C
C
C NO MATCH
999	RETCD=2
C IF ERROR, RESTORE VALUE OF NONBLK
	NONBLK=IS
	RETURN
	END
c -h- svbl.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SVBL(CMDLIN,LA,N,LE,FORM)
	Include Aparms.Inc
	InTeGer*4 VLEN(9),TYPE(1,1)
	CHARACTER*1 AVBLS(20,27)
	REAL*8 XVBLS(1,1),XX,XY,xmr,xmc
	COMMON/V/TYPE,AVBLS,XVBLS,VLEN
	CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
	CHARACTER*3 NBF3
	EQUIVALENCE(NBF3(1:1),NBF(5))
	InTeGer*4 LA,N,LE,I1,I2,J1,J2
	NI=N
	xmr=Mrows
	xmc=Mcols
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
	LAA=LA+2
C MUST PASS _# CHARS
	LEE=LE
	CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
	IF(IVLD.LE.0)GOTO 990
	LAA=LSTC+1
C ACCEPT ANY DELIMITER
	LEE=LE
	CALL VARSCN(CMDLIN,LAA,LEE,LSTC,J1,J2,IVLD)
	IF(IVLD.LE.0)GOTO 990
C	XX=XVBLS(I1,I2)
	CALL XVBLGT(I1,I2,XX)
C XX IS COL #
C	XY=XVBLS(J1,J2)-1.0
	CALL XVBLGT(J1,J2,XY)
	IF(XX.LE.(0.9D0).OR.XX.GT.XMR)GOTO 990
	IF(XY.LE.(0.9D0).OR.XY.GT.XMC)GOTO 990
	IC=XX
	CALL IN2AS(IC,NBF)
	IR=XY
	WRITE(NBF3(1:3),300)IR
C	ENCODE(3,300,NBF(5))IR
300	FORMAT(I3)
	NL=NI
C FILL IN DECODED VARIABLE NAME, ZOTTING OUT EXTRA SPACES.
	DO 400 NN=1,7
C 47 IS ASCII VALUE FOR 0 CHARACTER
C ALPHAS ARE ALSO ALL HIGHER.
	IF(ICHAR(NBF(NN)).LE.40)GOTO 400
	FORM(NL)=NBF(NN)
	NL=NL+1
400	CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER 2ND VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
	N=NL
	LE=LE-LSTC+NL
	LA=LSTC
C	DO 401 M=N,LE
C	CMDLIN(M)=CMDLIN(M+LSTC-NL)
C401	CONTINUE
C HOPE ALL'S WELL NOW...
	RETURN
990	CONTINUE
	FORM(N)=CMDLIN(N)
	RETURN
	END
c -h- swrt.for	Tue Sep  2 10:58:55 1986	
C
C SWRT - WRITE VARIABLE LENGTH STRING TO SCREEN WITHOUT
C RECORD TERMINATION.
C COPYRIGHT GLENN C EVERHART 1984
C ALL RIGHTS RESERVED
C *** Don't use for normal Amiga stuff, but have available in case
C *** it should be handy someplace...
C
C
ccc	SUBROUTINE SWRT(STRING,LENGTH)
ccc	CHARACTER*1 STRING(127)
ccc	INTEGER LENGTH
cccC DUMP OUT ALL WE CAN..
ccc	CHARACTER*9 SFM
ccc	CHARACTER*1 SFMX(9)
ccc	CHARACTER*3 SNM
ccc	EQUIVALENCE(SNM,SFMX(2))
ccc	EQUIVALENCE (SFMX(1),SFM)
cccC HERE ARE THE BUILT IN FORMATS. NOTE WE FILL IN THE
cccC REPEAT COUNT AT RUNTIME FOR THE TEXT TO BE WRITTEN.
cccC NOTE ALSO THAT THE 1ST CHAR IS A # SIGN TO SHOW UP PROBLEMS.
cccC FORMATS ARE (nnnA1,\)
cccC COMPRISING 13 CHARACTERS IN ALL.
ccc	DATA SFM/'(001A1,\)'/
cccC NOTE WE JUST FILL IN THE LENGTH AND WRITE TO SCREEN USING
cccC SFM AS A RUNTIME FORMAT.
cccC
ccc	IF(LENGTH.LE.0)RETURN
ccc	WRITE(SNM,1)LENGTH
ccc1	FORMAT(BZ,I3)
cccC WRITE ON UNIT 6 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
cccC (VIA EXPLICIT OPEN IN MAIN PROGRAM)
ccc	WRITE(11,SFM)(STRING(II),II=1,LENGTH)
ccc	RETURN
ccc	END
	subroutine vget(buf,len)
	character*1 buf(132),cbf(132)
	integer*4 len,ii,i
C Read buf up to len from console
	do 2 i=1,128
	cbf(i)=char(0)
2	continue
	call getttl(cbf)
c	call cmdmun(cbf)
	ii=min0(len,132)
	ii=max0(len,1)
C reads console into large buffer, returns n chars of it.
	do 1 i=1,ii
	buf(i)=cbf(i)
1	Continue
	return
	end
	subroutine vgeti(iii)
C get integer from command line
	integer*4 iii
	character*20 buf
	call vget(buf,20)
	read(buf,1000,err=999)iii
1000	format(i7)
	return
999	Continue
	iii=0
	return
	end
	SUBROUTINE VWRT(STRING,LENGTH)
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 IDSPTP,Idol9
	integer*4 k3dfg,kcdelt,krdelt,kpag
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
C ***<<< RDD COMMON END >>>***
C VWRT is like SWRT but writes to lun 11 window instead.
	CHARACTER*1 STRING(127)
	INTEGER LENGTH
C DUMP OUT ALL WE CAN..
	IF(LENGTH.LE.0)RETURN
C WRITE ON UNIT 11 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
C (VIA EXPLICIT OPEN IN MAIN PROGRAM)
c	REWIND 11
c	call uvt100(1,LLDSP,1)
	call swrt(string,length)
c	WRITE(11,777)(STRING(II),II=1,LENGTH)
c	REWIND 11
777	format(1X,127A1)
	RETURN
	END

C *************** AnalyO.Ftn ##########################################
c -h- acini1.fnw	Fri Aug 22 12:55:08 1986	
C PORTACALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN.
	SUBROUTINE INITA1(KMAP,KWID,ICODE)
C
	Include AParms.inc
	InTeGer*4 PRL(6)
        CHARACTER*1 NOWRAP ( 2 )
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	INTEGER IFCW
c	EXTERNAL LCWRQQ
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 IDSPTP,Idol9
	integer*4 k3dfg,kcdelt,krdelt,kpag
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 RRWACT,RCLACT
CCC	COMMON/RCLACT/RRWACT,RCLACT
CCC	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC	InTeGer*4 LLCMD,LLDSP
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
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 IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	CHARACTER*1 FORM2(4)
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
CCC	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 TYPE(1,1),VLEN(9)
CCC	InTeGer*4 KLVL
CCC	COMMON/KLVL/KLVL
CCC	InTeGer*4 IOLVL
CCC	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.
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XXV(1,1)
	EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
	CHARACTER*1 DVFMT(12),DEFFMT(10)
	CHARACTER*12 CDVFMT
	EQUIVALENCE(DVFMT(2),DEFFMT(1))
	EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
	COMMON/DEFVBX/DVFMT
	CHARACTER*1 NMSH(80)
	CHARACTER*80 NMSH80
	EQUIVALENCE(NMSH80(1:1),NMSH(1))
	COMMON/NMSH/NMSH
CCC	InTeGer*4 IPS1,IPS2,MODFLG
CCC	COMMON/ICPOS/IPS1,IPS2,MODFLG
CCC   	InTeGer*4 XTCFG,IPSET,XTNCNT
CCC   	CHARACTER*1 XTNCMD(80)
CCC   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
CCC	INTEGER KALKIT
CCC	COMMON/VARYIT/KALKIT
CCC	InTeGer*4 FORMFG,RCFGX,PZAP
CCC	InTeGer*4 RCONE,RCMODE,IRCE1,IRCE2
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCC     1  IRCE1,IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALC
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY.
	INTEGER*4 I4TMP
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,MRows)
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 SETS NUMBER OF COLS TO ADD ON ROW OVERFLOW, ROWS TO ADD ON COL OVERFLOW
C FOR CELL ALIASING.
	REAL*8 DVS(20,75)
	COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
	REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
	LOGICAL*4 LEXIST
	InTeGer*4 QCAC,QCENT(8),ACV(8)
	COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
	COMMON/DSPCMN/DVS,CWIDS
	CHARACTER*1 CHR
	character*20 fwt
	EQUIVALENCE(FWT(1:1),CHR)
C DISABLE FLOATING EXCEPTIONS
C	CALL LCWRQQ(IFCW)
C (MOVED LCWRQQ CALL TO MAIN)
	IDOL7=1
C ENABLE SCROLLING INITIALLY
C ZERO "SAVED DISPLAY VALUES" FIRST...
	DO 35 N=1,75
	DO 35 NN=1,20
35	DVS(NN,N)=0.
	MODFLG=1
C INITIALLY IN NON ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
C SETUP INITIAL DISPLAY LIMITS ACTUALLY USED.
	RRWACT=1
	K3DFG=0
	KCDELT=0
	KRDELT=0
	RCLACT=1
	IOLVL=11
c Set rather small sheet to allow for use on non-interlace screen
c initially
	DRWV=7
	DCLV=17
	LLCMD=20
	LLDSP=21
	If(Idsptp.ne.1)goto 4866
	DRWV=7
	DCLV=42
	LLCMD=45
	LLDSP=46
c Interlace dimensions for main window display
4866	Continue
	ICREF=10
	IRREF=50
C SET INCREMENTS TO 1/6 OF TOTAL FOR STARTERS.
	KLVL=1
	KALKIT=0
	IRCE1=0
	IRCE2=0
	RCMODE=2
	ICODE=0
	idol3=0
	idol4=0
	idol5=20000
	idol6=20000
	Idol8=1
	RCFGX=0
	FORMFG=0
C      CALL GETADR ( PRL, NOWRAP )
      PRL ( 2 ) = 2
c	OPEN(6,FILE='CON:',STATUS='NEW',FORM='FORMATTED')
	If(Idsptp.eq.1)goto 4867
c Non interlace (640 x 200) screen
c	OPEN(11,FILE='CON:20/169/550/30/Analy Command Inputs',
c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
	Goto 4868
4867	Continue
c Interlace
c	OPEN(11,FILE='CON:20/369/550/30/Analy Command Inputs',
c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
4868	Continue
c	OPEN(18,FILE='CON:20/210/450/30/Analy Cmd Prompts',
c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
C LOOK FOR 'ACINIT.PRM' INITIALIZER FILE. IF ONE FOUND, READ IT.
C IF NOT, ASK AT CONSOLE FOR SINGLE/DBL PRECISION AND INITIAL VIDEO MODE
	IVV=11
C SET UP AS THOUGH WE HAD AN @ACINIT.PRM AT STARTUP AND
C ALLOW IT TO GO THRU NORMALLY...
	INQUIRE(FILE='ACINIT.PRM',EXIST=LEXIST)
	IF(.NOT.LEXIST)GOTO 6003
	OPEN(3,FILE='ACINIT.PRM',STATUS='OLD',FORM='FORMATTED')
C	CALL RASSIG(3,'ACINIT.PRM')
	IVV=3
	IOLVL=3
	GOTO 6403
6003	CONTINUE
C	OPEN(5,FILE='CON:',STATUS='OLD',FORM='FORMATTED')
C OPEN EITHER CONSOLE OR INIT FILE AT FIRST...
6403	CONTINUE
6005	FORMAT(80A1)
C For AMIGA always use "BIOS MODE" so we can have special windowing
C code in place of the Fortran I/O. Fortran console I/O will be done
C using LUN 11 in a CON: window, but most normal spreadsheet
C operations will take place in a special window over which we will have
C finer grained control...
C
	CALL SWSET(1)
	MODFLG=1
6008	CONTINUE
C SETS UP FOR USING ROM BIOS DIRECTLY FOR EVERYTHING...
C COULD THEN USE E.G. NEWKEY TO DO KEYBOARD CMDS.
	GOTO 6002
6006	CONTINUE
C ERROR ON INPUT HERE... JUST FORGET IT.
	CLOSE(3)
	IOLVL=11
C MAKE SURE LUN 5 HAS A CONSOLE FILE OPEN.
c	CLOSE(11)
c	OPEN(11,FILE='CON:0/50/200/60/Analy Command',
c     1  STATUS='OLD',FORM='FORMATTED')
6002	CALL UVT100(18,0,0)
C PERFORM SYSTEM DEPENDENT INITIALIZATION for terminal. (none here really)
c may later read + write auxkpd.txt to set up escape seqs.
	CALL TTYINI
C
C SET UP THE SCREEN (ERASE, ETC.)
c erase screen first
	CALL UVT100(1,5,10)
	CALL UVT100(11,2,0)
c position cursor to r5c10
	CALL UVT100(1,5,10)
C ZERO THE VARIABLES TO START OFF WITH.
	DO 2070 KK=1,20
	DO 2070 KKK=1,27
2070	AVBLS(KK,KKK)=0
C SET UP WORK ARRAY BITMAP
	CALL WRKFIL(1,FORM,2)
c set reverse video title
	CALL UVT100(13,7,0)
	CALL SWRT('AnalytiCalc-68K',15)
	CALL UVT100(1,6,12)
	CALL SWRT('V25-03A',7)
	CALL UVT100(13,0,0)
	CALL UVT100(1,8,3)
	CALL SWRT(' ...The Analyst`s Tool',22)
	CALL UVT100(1,9,5)
C original name was VisiKluge, then ViziKluge, then PortaCalc, then 
C AnalyCalc, then AnalytiCalc.
	CALL SWRT('Copyright (C) 1982-1990 Glenn & Mary Everhart',45)
	CALL UVT100(1,10,1)
C ALLOW SPACE FOR ASKING FOR MONEY LATER VIA PATCH IF DESIRED.
	CALL SWRT('If you use this program please send $10.00 donation',
     1  51)
	CALL UVT100(1,11,1)
	CALL SWRT('to Glenn Everhart, 25 Sleigh Ride, Glen Mills PA. ',
     1  50)
	CALL UVT100(1,12,1)
	CALL SWRT('19342. May be copied for others',
     1  31)
C NOW GET ON WITH USEFUL WORK.
      PRL ( 2 ) = 1
      PRL ( 3 ) = 0
c set ansi mode...
      CALL UVT100 ( 18 ,0,0)
	Call uvt100(1,13,1)
	KWID=10
	KMAP=1
	RETURN
	END
c -h- acini2.for	Fri Aug 22 12:55:25 1986	
C PORTACALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	SUBROUTINE INITA2(KMAP,KWID,ICODE,IKONS)
C
	Include AParms.inc
	InTeGer*4 PRL(6)
        CHARACTER*1 NOWRAP ( 2 )
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	INTEGER IFCW
C	EXTERNAL LCWRQQ
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 RRWACT,RCLACT
CCC	COMMON/RCLACT/RRWACT,RCLACT
CCC	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
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
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
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,MRows)
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
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 IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	CHARACTER*1 FORM2(4)
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
CCC	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 TYPE(1,1),VLEN(9)
CCC	InTeGer*4 KLVL
CCC	COMMON/KLVL/KLVL
CCC	InTeGer*4 IOLVL
CCC	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.
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XXV(1,1)
	EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
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))
	CHARACTER*12 CDVFMT
	EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
	COMMON/DEFVBX/DVFMT
	CHARACTER*1 NMSH(80)
	CHARACTER*80 NMSH80
	EQUIVALENCE(NMSH80(1:1),NMSH(1))
	COMMON/NMSH/NMSH
CCC	InTeGer*4 IPS1,IPS2,MODFLG
CCC	COMMON/ICPOS/IPS1,IPS2,MODFLG
CCC   	InTeGer*4 XTCFG,IPSET,XTNCNT
CCC   	CHARACTER*1 XTNCMD(80)
CCC   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
CCC	INTEGER KALKIT
CCC	COMMON/VARYIT/KALKIT
CCC	InTeGer*4 FORMFG,RCFGX,PZAP
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP
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).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	INTEGER*4 I4TMP
	REAL*8 DVS(20,75)
	COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
	REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
	InTeGer*4 QCAC,QCENT(8),ACV(8)
	COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
C BITMAP
C	CHARACTER*1 IBITMP
C	DIMENSION IBITMP(2258)
C	COMMON/INITD/IBITMP
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
	character*35 fwt
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
	CHARACTER*1 EDNINI(4)
	DATA EDNINI/'E','D','I','T'/
C	DATA NOWRAP / "24,0 /
C
	DO 2900 III=1,16
2900	EDNAM(III)=' '
	DO 2901 III=1,4
2901	EDNAM(III)=EDNINI(III)
	IF(IKONS.EQ.0)GOTO 3000
3002	CONTINUE
	CALL UVT100(1,1,1)
	CALL VWRT('Alter Widths or Mapping Y/N:',28)
	ILL=IOLVL
C	IF(ILL.EQ.5)ILL=0
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
	if(ill.eq.11)call vget(form,4)
	IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3000
	CALL VWRT('Enter NEW Global Column Width 1-120:',36)
C ALTER MAPPING DESIRED
	if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)KWID
	if(ill.eq.11)call vgeti(kwid)
3004	FORMAT(I3)
	IF(KWID.LT.1.OR.KWID.GT.120)KWID=10
	CALL VWRT('Enter length of display in lines (nominally 24):',48)
	if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)III
	if(ill.eq.11)call vgeti(iii)
	IF(III.LE.4.OR.III.GT.999)III=24
C RESET DISPLAY SIZE IN S COMMAND QUESTIONS AS NEEDED.
	LLDSP=III
	LLCMD=III-1
	CALL VWRT('Change annotate editor from "EDIT" [Y/N]:',41)
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
	if(ill.eq.11)call vget(form,4)
	IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3031
	CALL VWRT('Give desired edit command:',26)
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)EDNAM
	if(ill.eq.11)call vget(ednam,16)
	EDNAM(16)=' '
C ENSURE THERE'S A SPACE AT END OF EDITOR NAME
3031	CONTINUE
	CALL VWRT('Modify Extended Area Remap Y/N: ',31)
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
	if(ill.eq.11)call vget(form,4)
	IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3502
	CALL VWRT('# cols to move over on row overflow:',36)
	if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)ICREF
	if(ill.eq.11)call vgeti(icref)
	IF(ICREF.GT.MCols)ICREF=10
	IF(ICREF.LT.0)ICREF=10
	CALL VWRT('# rows to move down on col overflow:',34)
	if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)IRREF
	if(ill.eq.11)call vgeti(irref)
	IF(IRREF.GT.(MRows-1))IRREF=50
	IF(IRREF.LT.0)IRREF=50
C FORCE THE RESULTS TO MAKE SENSE. 0 TO 60 ON COLS, 0-300 ON ROWS.
C IF USER BOTHERS TO READ MANUALS THIS WILL BE EXPLAINED.
3502	CONTINUE
	CALL VWRT('Reset Display to Upper Left of Sheet Y/N:',40)
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
	if(ill.eq.11)call vget(form,4)
	IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')KMAP=0
3006	FORMAT(80A1,50A1)
3000	CONTINUE
	RETURN
5600	CONTINUE
	IOLVL=11
	CLOSE(3)
c	Rewind 11
c	CLOSE(11)
c	OPEN(11,FILE='CON:0/0/100/100/Analy Command',
c     1  STATUS='OLD',FORM='FORMATTED')
	RETURN
	END
c -h- acini3.for	Fri Aug 22 12:55:39 1986	
C PORTACALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	SUBROUTINE INITB(KMAP,KWID,ICODE)
C
	Include AParms.inc
	InTeGer*4 PRL(6)
        CHARACTER*1 NOWRAP ( 2 )
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	INTEGER IFCW
C	EXTERNAL LCWRQQ
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 RRWACT,RCLACT
CCC	COMMON/RCLACT/RRWACT,RCLACT
CCC	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
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
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 IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	CHARACTER*1 FORM2(4)
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

CCC	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 TYPE(1,1),VLEN(9)
CCC	InTeGer*4 KLVL
CCC	COMMON/KLVL/KLVL
CCC	InTeGer*4 IOLVL
CCC	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.
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XXV(1,1)
	EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
	CHARACTER*1 DVFMT(12),DEFFMT(10)
	CHARACTER*12 CDVFMT
	EQUIVALENCE(DEFFMT(1),DVFMT(2))
	EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
	COMMON/DEFVBX/DVFMT
	CHARACTER*1 NMSH(80)
	CHARACTER*80 NMSH80
	EQUIVALENCE(NMSH80(1:1),FORM(1))
	COMMON/NMSH/NMSH
CCC	InTeGer*4 IPS1,IPS2,MODFLG
CCC	COMMON/ICPOS/IPS1,IPS2,MODFLG
CCC   	InTeGer*4 XTCFG,IPSET,XTNCNT
CCC   	CHARACTER*1 XTNCMD(80)
CCC   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
CCC	INTEGER KALKIT
CCC	COMMON/VARYIT/KALKIT
CCC	InTeGer*4 FORMFG,RCFGX,PZAP
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP
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).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	INTEGER*4 I4TMP
	REAL*8 DVS(20,75)
	COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
	REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
	InTeGer*4 QCAC,QCENT(8),ACV(8)
	COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
C BITMAP
C	CHARACTER*1 IBITMP
C	DIMENSION IBITMP(2258)
C	COMMON/INITD/IBITMP
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
	character*35 fwt
C	DATA NOWRAP / "24,0 /
C
	idol5=20000
	idol6=20000
C INITIALLY SET JRCL TO 301 = NO. OF ROWS TO BE IN WORK FILE
	JRCL=MRows
	PZAP=0
	XTCFG=0
	IPSET=0
C ZERO BITMAP
C	DO 36 N1=1,2258
C36	IBITMP(N1)=0
c	LINIZZ=0
	CALL UVT100(1,14,1)
	CALL VWRT('Enter NEW floating format default Y/N:',38)
	ILL=IOLVL
C	IF(ILL.EQ.5)ILL=0
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
	if(ill.eq.11)call vget(form,4)
	IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3589
C ENTER NEW DEFAULT.
6888	CALL UVT100(1,14,1)
	CALL UVT100(12,2,0)
C LINE NOW ERASED... GET NEW FORMAT
	CALL VWRT('Enter new format. Suggest F10.2>',32)
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
	if(ill.eq.11)call vget(form,16)
C NOW HAVE HIS DESIRED FORMAT. COPY INTO THE DEFAULT ARRAY.
C DEFFMT IS THAT.
	DO 3591 N1=1,10
	KKK=ICHAR(FORM(N1))
	KKK=MAX0(32,KKK)
C ASSUME NMSH COMPLETELY INIT'D
3591	DEFFMT(N1)=Char(KKK)
c	dvfmt(1)='('
c	dvfmt(12)=')'
C CHECK ITS LEGALITY BY TRYING TO USE IT ONCE.
	XX=3.14159
	WRITE(NMSH80(1:80),DVFMT,ERR=6888)XX
C	ENCODE(78,DVFMT,NMSH,ERR=6888)XX
C IF IT FAILS, PROGRAM WILL CRASH AND FILE WON'T GET CLOBBERED.
3589	CONTINUE
	CALL UVT100(1,15,1)
	CALL VWRT('Title for Spreadsheet:',22)
	ILL=IOLVL
C	IF(ILL.EQ.5)ILL=0
	if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
	if(ill.eq.11)call vget(form,120)
3006	FORMAT(80A1,50A1)
	IF(ICHAR(FORM(1)).LE.32.AND.ICHAR(FORM(2)).LE.32) GOTO 3008
C COPY TITLE UNLESS IT'S OLD
	DO 3007 KKK=1,80
3007	NMSH(KKK)=FORM(KKK)
C THAT WAY JUST C.R. LEAVES IN OLD TITLE.
3008	CONTINUE
C ****** IF S OPTION GIVEN THEN ICODE=-2
C THEREFORE, DON'T ASK DISK SIZE ETC, BUT ALLOW RESET OF TITLE
C AND DEFAULT FORMATS.
	IF(ICODE.EQ.-2) GOTO 7831
C ******
	CALL UVT100(1,16,1)
	CALL VWRT('Give Max Rows to be used:',25)
	if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)KR
	if(ill.eq.11)call vgeti(kr)
	IF(KR.LE.0)KR=MRows
	CALL UVT100(1,17,1)
	CALL VWRT('Give Max Cols to be used:',25)
	if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)KC
	if(ill.eq.11)call vgeti(kc)
	IF(KC.LE.0)KC=MCols
C	KKK=(KR-1)*60+KC
C ALLOW REPLIES IN ANY RANGE AND REFLECT BACK TO PRIME RANGE
C NOTE WE WANT A CELL ADDRESS HERE FOR THE END CELL...
	CALL REFLEC(KR,KC,KKK)
	XKKKK=KR*KC
	XKDF=XKKKK/64.
	XKDN=XKKKK/100.
C COMPUTED ABOVE THE MIN # OF K FOR DISK FILES
	CALL UVT100(1,18,1)
	write(fwt(1:12),2058)xkdn
2058	format(F9.0)
	CALL SWRT('Min=',4)
	call swrt(fwt(1:12),9)
	write(fwt,2058)xkdf
	call swrt(' K Value file ',14)
	CALL SWRT(fwt(1:12),9)
	CALL SWRT(' K Formula file',15)
c	WRITE(0,2058)XKDN,XKDF
c2058	FORMAT(' Mins=',F9.0' K Value file, ',F9.0,' K Formula file',\)
C KKK IS MAX INDEX TO BE USED HERE.
	CALL UVT100(1,21,1)
	CALL VWRT('Give Value File size, K:',24)
	if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)IPGMAX
	if(ill.eq.11)call vgeti(ipgmax)
7202	FORMAT(I6)
	IPGMOD=KKK
	IF(IPGMAX.LT.0)IPGMOD=0
	IPGMAX=IABS(IPGMAX)
	IF(IPGMAX.GT.2512)IPGMAX=1
	CALL UVT100(1,22,1)
	CALL VWRT('Give Formula File size, K:',26)
	if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)LPGMXF
	if(ill.eq.11)call vgeti(lpgmxf)
	LPGMOD=KKK
	IF(LPGMXF.LT.0)LPGMOD=0
	LPGMXF=IABS(LPGMXF)
C IF NUMBERS ARE ENTERED NEGATIVE, SET MODE TO "SLOW, FILE-SPACE
C CONSERVING" PACKING, SCATTERING PAGES ACROSS FILE.
	IF(LPGMXF.GT.4096)LPGMXF=(IPGMAX*3)/2
C NULL TERMINATE ALL FORMAT STRINGS.
C SET MAX WIDTH FOR PRINT TO DIMENSION OF THE BUFFER. NOTE THIS IS THE
C USUAL HARDWARE MAXIMUM SO WE DON'T WORRY TOO MUCH ABOUT IT. NOTE
C BILL TABOR'S PROGRAM TO PRINT PASTE-ABLE VERSIONS OF THE SHEET FROM
C SAVE FILES EXISTS, SO WE NEEDN'T WORRY TOO MUCH EITHER ABOUT USING
C DISPLAY FOR DOUBLE DUTY.
	MXL=132
C INITIALIZE WORK STORAGE FOR FORMULAS AND VARIABLES
	CALL WSSET
7831	CONTINUE
C SET DEFAULT WIDTHS OF COLUMNS TO 10. MAY BE ALTERED BELOW FOR DIFFERENT
C DEFAULT IF DESIRED.
	DO 16 N1=1,20
	CWIDS(N1)=KWID
16	CONTINUE
C
C NOW SET UP NRDSP, NCDSP
	IF(KMAP.EQ.0)GOTO 3009
C SET UP MAPPING NOW FOR INITIALLY UPPER LEFT CORNER OF PHYS SHEET IN DISPLAY SHT.
	DO 5 N1=1,20
	DO 5 N2=1,75
C INITIALLY WE DISPLAY THE UPPER LEFT PART OF THE SYSTEM.
C ESTABLISH ASSOCIATION INITIALLY THEREFORE OF DISPLAY TO UPPER
C LEFT OF PHYSICAL SHEET.
	NRDSP(N1,N2)=N1
	NCDSP(N1,N2)=N2+1
	DVS(N1,N2)=.00000031
5	CONTINUE
C FOR S OPTION USE SECRET -4 CODE TO RESET SHEET. STILL NEEDS WORK
C IN PORTACALC PC.
	IF(ICODE.EQ.-4)CALL WRKFIL(1,FORM,2)
3009	IF(ICODE.EQ.-4)GOTO 1
C43	CALL UVT100(1,21,1)
	KZPPD=0
	CMDLIN(1)=Char(0)
	IOLDFL=0
C3017	FORMAT(Q,80A1,80A1)
	MXL=1
	CMDLIN(MXL+1)=Char(0)
3572	FORMAT(I6)
	CALL UVT100(13,0,0)
C  SET UP RANDOM FILE AS NEEDED FOR SHEET
C EACH RECORD HAS:
C CHARS 1-110	FORMULAS
C CHARS 120-128	DISPLAY FORMAT (INITIALLY F9.2)
C CHAR 119	VALID FLAG (ALLOWS HANDLING READS.)
C    values: -3, -2: Numeric-only text (or special chars)
C	     -1    : Alphanumeric text
C	      0    : Uninitialized
C	      1    : Alphanumeric formula
C	     +2    : Number or pure numeric formula with value calculated
C	     +3    : Number or pure numeric formula, value not yet computed
C CHAR 118	MAGIC NUMBER 15 (CHECKS ALL WELL)
C READ A RECORD, IF ERROR, CREATE EMPTY FILE.
C	IF(IOLDFL.EQ.0)GOTO 1
CC IF IOLDFL NONZERO IT MEANS USER CLAIMS THERE EXISTS A FILE. IF 0 IT'S NEW.
CC HERE IT'S OLD SO LET'S BE SURE IT REALLY IS OK.
1	CONTINUE
C HIT EOF OR ERROR. MUST BE A NEW FILE. THEREFORE ZERO IT TO OUR NEEDS.
C AT THIS POINT WE ARE CREATING A NEW FILE AND NEED TO ZERO IT.
C
	DO 3 N=1,128
	FORM(N)=Char(0)
3	CONTINUE
	DO 3592 N=1,9
C SET UP DEFAULT FORMAT
3592	FORM(119+N)=DEFFMT(N)
	FORM(118)=CHAR(15)
	FORM(1)='0'
	FORM(2)='.'
C CREATE NULL FILE INITIALLY BY RESETTING ALL.
	JRRCL=MCols*JRCL
	KZPPD=1
C
2	CONTINUE
C COMMON POINT WITH FILE PREPARED.
	PCOL=2
	PROW=1
	DCOL=1
	DROW=1
	RETURN
5600	CONTINUE
C ERROR ON READ FROM IOLVL HANDLED HERE.
C	REWIND 5
	Rewind 11
c	CLOSE(11)
c	OPEN(11,FILE='CON:0/150/500/49/Analy Command',
c     1  STATUS='OLD',FORM='FORMATTED')
	CLOSE(3)
	IOLVL=11
	RETURN
	END
c -h- block.for	Fri Aug 22 12:58:14 1986	
	SUBROUTINE BLOCK
C	BLOCK DATA
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 18060 = 60*301
C 18033=18060-27
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
	Include AParms.Inc
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C   +                                                +
C   +            CALC    VERSION  X01-06             +
C   +                                                +
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C *******************************************************
C *                                                     *
C *            BLOCK  DATA  MODULE                      *
C *                                                     *
C *******************************************************
C
C
C COMMON AREAS ARE INITIALIZED BY THIS MODULE.
C FAKEUP FOR MICROSOFT WHICH HAS NO BLOCK DATA.
C DO IT ALL VIA LOOPS...
C
C
C MODIFIED 18-MAY-1981 P.B. SET % TO VERSION 6
C
C
C
C   VARIABLE      USE
C
C  ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC CHARACTERS
C               OR THE CHARACTER %.
C  BASED     HOLDS DEFAULT BASE.
C  BLANK        ' '
C  COMMA        ','
C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
C               SECOND SUBSCRIPT IS
C                     1 FOR DECIMAL
C                     2 FOR OCTAL
C                     3 FOR HEXADECIMAL
C  DTBL1(9,9,8) CONTROLS THE DECISION PROCESS WHEN EVALUATING A
C               BINARY OPERATION. SEE BELOW FOR DETAILS.
C  EQ           '='
C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
C               USED TO CONTROL ITERATION.
C  LINE(80)     COMMAND INPUT LINE
C  LPAR         '('
C  RPAR         ')'
C  ST1LIM       HOLDS THE SIZE OF STACK 1 (ALWAYS CONSTANT)
C  ST2LIM       HOLDS THE SIZE OF STACK 2 (ALWAYS CONSTANT)
C  ST1PT        POINTS TO THE TOP OF STACK 1 (CHANGES AS STACK IS USED)
C  ST2PT        POINTS TO THE TOP OF STACK 2 (CHANGES AS STACK IS USED)
C  ST1TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 1
C  ST2TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 2
C  STACK1(20,40)   UTILITY STACKS USED WHEN EVALUATING EXPRESSIONS. THE FIRST
C  STACK2(20,40)   SUBSCRIPT CONTROLS INDEXING ACROSS THE BYTES OF A SINGLE
C                   VARIABLE. THE SECOND SUBSCRIPT CONTROLS STACK ELEMENTS.
C  TYPE(27)         HOLDS THE DATA TYPES FOR EACH OF THE 27 VARIABLES. SEE
C                   CODES.FTN FOR THE POSSIBLE VALUES.
C  VIEWSW           VIEW SWITCH
C                    0 = OUTPUT ERROR MESSAGES
C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
C                        EVALUATED.
C                    3 = OUTPUT EVERYTHING
C  VLEN(9)      INDEXED BY DATA TYPE. GIVES THE NUMBER OF BYTES USED
C               BY THAT DATA TYPE.
C  AVBLS(20,27)      HOLDS THE VALUES OF THE 27 LEGAL VARIABLES.(ACCUMULATORS)
C  VBLS(8,60,301)    HOLDS VALUES OF ALL VARIABLES
C
C
C
C    CONSTANTS ARE STORED IN VBLS ACCORDING TO THEIR TYPE:
C
C
C
C <----------- MULTIPLE PRECISION (M10, M8, M16) ------------------------->
C !                        <------------- DECIMAL AND REAL --------------->
C !                        !                      <-- INTEGER HEX OCTAL -->
C !                                               !             ---> ASCII <---
C !                        !                      !                        !
C
C -------------     -------------------------------------------------------
C !     !     !     !     !     !     !     !     !     !     !     !     !
C ! 20  !  19 ! ... !  9  !  8  !  7  !  6  !  5  !  4  !  3  !  2  !  1  !
C !     !     !     !     !     !     !     !     !     !     !     !     !
C -------------     -------------------------------------------------------
C
C
C NOTE: BYTE 20 HOLDS THE SIGN FOR MULTIPLE PRECISION NUMBERS.
C       0 = POSITIVE, 1 = NEGATIVE
C
C
C
C
C
C	BLOCK DATA
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 LASTOP
	InTeGer*4 ST1TYP(40),ST2TYP(40)
	InTeGer*4 TYPE(1,1)
	InTeGer*4 VIEWSW,BASED,VLEN(9),BVLEN(9)
	InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
	InTeGer*4 ITCNTV(6)
C
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ,LINE(80)
	CHARACTER*1 BOMMA,BBLANK,BRPAR,BLPAR,BEQ
	CHARACTER*1 STACK1(8,40),STACK2(8,40)
	CHARACTER*1 AVBLS(20,27),BLPHA(27)
	CHARACTER*1 VBLS(8,1,1)
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
CCC	COMMON/ICPOS/IC1POS,IC2POS
	CHARACTER*1 DTBL1(9,9,8)
CC BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
C MOVED TABLE TO WRKFIL WHERE IT IS OVERLAIN BY A BUFFER DURING OPERATION
C AND JUST INITIALIZES DTBL1 AT STARTUP. THIS SHOULD ESSENTIALLY REMOVE DATA
C SPACE PENALTY FOR THIS HUGE ARRAY. NOTE IT'D BE SMALLER IF THERE WEREN'T
C SO MANY SUPPORTED DATA TYPES IN CALC.
C	InTeGer*4 BTBL(9,9,8)
C	InTeGer*4 BTBL1(9,9)
C	InTeGer*4 BTBL2(9,9),BTBL3(9,9),BTBL4(9,9),BTBL5(9,9)
C	InTeGer*4 BTBL6(9,9),BTBL7(9,9),BTBL8(9,9)
C	EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
C	EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
C	EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
C	EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
	CHARACTER*1 DIGITS(16,3),BIGITS(16,3)
C
C OARRY WILL BE USED TO HOLD OUTPUT VARIABLE IF OSWIT IS NONZERO
CCC	InTeGer*4 OSWIT
C OCNTR MAY HOLD BYTES VALID IN OARRY (UP TO 100, NO MORE...)
CCC	InTeGer*4 OCNTR
CCC	CHARACTER*1 OARRY(100)
C
C ILINE IS PROGRAMMABLE LINE INPUT (I.E., NOT FROM CONSOLE)
	CHARACTER*1 ILINE(106)
	InTeGer*4 ILNFG
	InTeGer*4 ILNCT
	COMMON /ILN/ILNFG,ILNCT,ILINE
C ILINE IS PRESENT IF ILNFG <> 0 AND ILNCT HAS # BYTES IN IT.
CCC	COMMON /OAR/OSWIT,OCNTR,OARRY
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;         ST1LIM,ST2LIM
	COMMON /V/ TYPE,AVBLS,VBLS,VLEN
	COMMON /DECIDE/ DTBL1
	COMMON /DIGV/ DIGITS
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
c	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 /ERROR/ LASTOP
	COMMON/ITERA/ ITCNTV
	CHARACTER*1 DVFMT(12),BVFMT(12)
	COMMON/DEFVBX/DVFMT
C SUPPORT VVARY OVERLAY WITH INITIAL VARY DATA:
	REAL*8 QAC(26),QDERIV(8),QDEL(8),QOLDVV
	InTeGer*4 QCAC,QCENT(8),ACV(8)
	COMMON/VRYDAT/QAC,QDERIV,QDEL,QCAC,QCENT,QOLDVV,ACV
C INITIAL DEFAULT FORMAT FOR NUMERICS
	DATA BVFMT/'(','F','9','.','2',' ',
     1  ' ',' ',' ',' ',' ',')'/
C
C	DATA BIEWSW/2/
C	DATA ITCNTV/6*0/
	DATA BLPHA/'A','B','C','D','E','F','G','H','I','J','K','L','M',
     ;       'N','O','P','Q','R','S','T','U','V','W','X','Y','Z','%'/
	DATA BIGITS/'1','2','3','4','5','6','7','8','9',
     1  '0','0','0','0','0','0','0',
     ;       '1','2','3','4','5','6','7',
     1  '0','0','0','0','0','0','0','0','0',
     ;  '1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','0'/
	DATA BOMMA/','/,BBLANK/' '/,BRPAR/')'/,BLPAR/'('/,BEQ/'='/
C
C
C DEFAULT BASE IS 10
C	DATA BASED/10/
C
C
C STACKS ARE CURRENTLY SET AT 40 ELEMENTS DEEP
C	DATA ST1LIM/40/, ST2LIM/40/
C
C
C
C	DEFAULT TYPES
C	A,B,C,D,E,F,G,H  =  DECIMAL
C	I,J,K,L,M,N      =  INTEGER (BASE10)
C	O,P,Q,R,S,T,U,V,W,X,Y,Z  =  DECIMAL
C
C  % AS INTEGER TO HOLD CALC VERSION NUMBER
C
C	DATA TYPE/8*2,6*4,12*2,4,1*2/
c modify type array so ac's i-n are reals
C	DATA TYPE/8*2,6*2,12*2,2,1*2/
C
C
C GIVE VERSION # BY VALUE IN %
C
c don't bother with this; by the time user gets into calc,
c % already is clobbered most times, so no need for it.
c	DATA AVBLS(1,27)/6/
c	DATA AVBLS(2,27)/0/,AVBLS(3,27)/0/,AVBLS(4,27)/0/
C
C
C
C
C SPECIFY THE LENGTH USED BY EACH DATA TYPE
	DATA BVLEN/1,8,4,4,8,8,8,4,8/
C
C NOTE ALL LENGTHS 8 OR LESS SINCE MULTIPLE PRECISION THINGS SNIPPED OUT
C
C  DECISION TABLE FOR PERFORMING BINARY OPERATIONS
C
C  DTBL1(OPERAND2,OPERAND1,INDEX)
C
C  WHERE:					OPERATOR:
C  INDEX=1	MODIFY CODE FOR OPERAND 1	*/+-
C	 2	MODIFY CODE FOR OPERAND 2	*/+-
C	 3	FUNCTION VALUE TYPE		*/+-
C	 4	OPERATOR CLASS			*/+-
C
C	 5	MODIFY CODE FOR OPERAND 1	**
C	 6	MODIFY CODE FOR OPERAND 2	**
C	 7	FUNCTION VALUE TYPE		**
C	 8	OPERATOR CLASS			**
C
C
C  WHERE TYPE CODES (MODIFY CODES) ARE:
C	0	NO CHANGE
C	1	CONVERT TO ASCII
C	2	CONVERT TO DECIMAL
C	3	CONVERT TO HEXADECIMAL
C	4	CONVERT TO INTEGER
C	5	CONVERT TO M10
C	6	CONVERT TO M8
C	7	CONVERT TO M16
C	8	CONVERT TO OCTAL
C	9	CONVERT TO REAL
C
C  FOR */+- FUNCTION VALUE TYPES AND OPERATOR CLASS ARE PRESENTLY
C  IDENTICAL
C
C  FOR **  OPERATOR CLASSES FOLLOW:
C
C 	CODE	OPERATOR CLASS
C	1	REAL**REAL
C	2	REAL**INTEGER
C	3	INTEGER**REAL
C	4	INTEGER**REAL
C	5	M8**INTEGER
C	6	M10**INTEGER
C	7	M16**INTEGER
C
C
C
C	DATA BTBL1 /4,2,3,4,5,6,7,8,9,
C     1  9*0,0,2,0,0,3*7,0,9,0,2,0,0,5,5,7,0,9,0,2,7,0,0,0,7,0,9,
C     2  0,2,7,5,5,0,7,0,9,0,2,6*0,9,0,2,3,0,5,6,7,0,9,0,2,7*0/
C	DATA BTBL2/
C     3  4,8*0,2,0,6*2,0,3,3*0,7,7,3*0,4,4*0,5,3*0,5,0,7,5,0,5,0,5,0,
C     4  6,0,7,5,3*0,6,0,7,2,4*7,0,7,0,8,8*0,9,0,6*9,0/
C	DATA BTBL3/4,2,3,4,5,6,7,8,9,
C     5  9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,5,2,7,3*5,7,5,9,
C     6  6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,9,2,7*9/
C	DATA BTBL4/
C     7  4,2,3,4,5,6,7,8,9,9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,
C     8  5,2,7,5,5,5,7,5,9,6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,
C     9  9,2,7*9/
C	DATA BTBL5/4,2,3,6*4,9*0,9*0,9*0,0,9,6*0,9,0,9,6*0,9,0,9,6*0,9,
C     1  9*0,9*0/
C	DATA BTBL6/4,3*0,3*9,4,0,4,3*0,3*9,0,0,4,3*0,3*9,2*0,4,3*0,3*9,
C     2  2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*9,2*0,
C     3  4,3*0,3*9,2*0/
C        DATA BTBL7/4,2,3,6*4,9*2,9*3,9*4,5,9,6*5,9,6,9,6,6,5,6,7,6,9,
C     4  7,9,6*7,9,9*8,9*9/
C	DATA BTBL8/4,1,4,4,3,3,3,4,3,2,1,2,2,3*1,2,1,4,3,4,4,3*3,
C     5  4,3,4,3,4,4,3*3,4,3,6,1,6*6,1,5,1,6*5,1,7,1,6*7,1,4,3,4,4,3*3,
C     6  4,3,2,1,2,2,3*1,2,1/
C
C HERE COPY LOCAL DATA INTO THE COMMONS.
C SINCE MOST ARRAYS AND THINGS ARE SMALL, WE JUST DO IT WITH REGULAR FORTRAN.
C THE BTBL ARRAY IS HANDLED IN WRKFIL WHERE THERE'S A BIG ENOUGH ARRAY FOR
C SCRATCH SPACE TO HOLD THE INITIAL DATA; WRKFIL IS CALLED BY WSSET WITH
C "SECRET CODE" TO INIT DTBL1 FROM THE ARRAY AND DOES SO ONCE ONLY.
	VIEWSW=0
	LEVEL=1
	LASTOP=0
	BASED=10
	COMMA=BOMMA
	BLANK=BBLANK
	RPAR=BRPAR
	LPAR=BLPAR
	EQ=BEQ
	DO 1 N=1,6
	ITCNTV(N)=0
1	CONTINUE
	DO 2 N=1,27
	DO 12 NN=1,20
12	AVBLS(NN,N)=Char(0)
2	ALPHA(N)=BLPHA(N)
	ST1LIM=40
	ST2LIM=40
C THIS IS DONE IN WRKFIL SINCE THERE'S A BIG LOCAL ARRAY THERE
C WE CAN KEEP EQUIVALENCED TO THIS ONE...
C	DO 3 N2=1,9
C	DO 3 N1=1,9
C	DTBL1(N1,N2,2)=BTBL2(N1,N2)
C	DTBL1(N1,N2,3)=BTBL3(N1,N2)
C	DTBL1(N1,N2,4)=BTBL4(N1,N2)
C	DTBL1(N1,N2,5)=BTBL5(N1,N2)
C	DTBL1(N1,N2,6)=BTBL6(N1,N2)
C	DTBL1(N1,N2,7)=BTBL7(N1,N2)
C	DTBL1(N1,N2,8)=BTBL8(N1,N2)
C3	DTBL1(N1,N2,1)=BTBL1(N1,N2)
	DO 4 N=1,9
	VLEN(N)=BVLEN(N)
4	CONTINUE
	DO 5 N2=1,3
	DO 5 N1=1,16
	DIGITS(N1,N2)=BIGITS(N1,N2)
5	CONTINUE
C SET UP DEFAULT DISPLAY FORMAT (INCLUDES "(" AND ")" CHARS WHICH
C ***MUST*** BE THERE FOR MAIN PGM TO WORK).
	DO 17 N=1,12
	DVFMT(N)=BVFMT(N)
17	Continue
	DO 15 N=1,26
	QAC(N)=0.
15	CONTINUE
	DO 18 N=1,8
	QDERIV(N)=1.
	ACV(N)=0
	QDEL(N)=0.
	QCENT(N)=0
18	CONTINUE
	QOLDVV=1.
	QCAC=1
	OSWIT=0
	OCNTR=0
	ILNFG=0
	ILNCT=0
	IC1POS=0
	IC2POS=0
	RETURN
	END
c -h- dtrcmd.for	Fri Aug 22 13:04:33 1986	
C DATATRIEVE INTERFACE FUNCTIONS
C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
C
C THIS IS THE NON-DTR VERSION with dummy entry points for
C the DTR functions BUT supplying the new non-DTR functions
c completely.
	SUBROUTINE DTRCMD(LINE)
	CHARACTER*1 LINE(80)
	CHARACTER*62 LINEC
C	EQUIVALENCE(LINEC(1:1),LINE(1))
C	INCLUDE 'VKLUGPRM.FTN'
C COPYRIGHT (C) 1983 GLENN EVERHART
	INTEGER RETCD
C
C DEFINE FILE AREAS FOR MAPPING FILES...
C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE
C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND
C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE
C INPUT - ONLY OR READ/WRITE.
C
C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
C
C MFIOPN =	0	IF NOT OPEN
C		1	IF OPEN FOR READ ONLY, SEQUENTIAL
C		2	IF OPEN READ ONLY, RANDOM
C		3	IF OPEN READ/WRITE, RANDOM.
C
C MFOOPN =	0	IF NOT OPEN
C		1	IF OPEN WRITE SEQUENTIAL
C		2	IF OPEN WRITE RANDOM
C
C OTHER OPTIONS DON'T MAKE SENSE.
C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
C MFILUN,MFOLUN ARE LOGICAL UNITS.
	InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
	InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH

	InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
	COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
     1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
C
C
	CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XAC,XVBLS(1,1)
	REAL*8 TAC,UAC,VAC,WAC,YAC
	REAL*8 TMP
	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)
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
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
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	InTeGer*4 DTRENA
CCC	COMMON/DTRCMN/DTRENA
	CHARACTER *1 LINECL(82)
C	CHARACTER*70 LINEC
	EQUIVALENCE(LINEC(1:1),LINECL(1))
C	CHARACTER*80 SCRBUF
	CHARACTER*1 LBUF(128)
	CHARACTER*1 MBUF(128)
	CHARACTER*110 CLBUF,CMBUF
	CHARACTER*50 CCLBUF,CCMBUF
	CHARACTER*11 C11LBF
C	EQUIVALENCE(C11LBF(1:1),CLBUF(1:1))
	EQUIVALENCE(CLBUF(1:1),CCLBUF(1:1),LBUF(1),C11LBF(1:1)),
     1  (CMBUF(1:1),CCMBUF(1:1),MBUF(1))
C	EQUIVALENCE(CLBUF,LBUF(1)),(CMBUF,MBUF(1))
C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
	CHARACTER*9 FMTB
	EQUIVALENCE (FMTB(1:1),LBUF(120))
	CHARACTER*11 FMTBF
	CHARACTER*1 IFVLD
C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
ccc	DO 3332 N=1,80
ccc	NN=81-N
ccc	IF(ICHAR(LINE(NN)).GT.32)GOTO 3333
ccc	LINE(NN)=CHAR(0)
ccc3332	CONTINUE
ccc3333	CONTINUE
C SPACE FILL ENTIRE ARRAY
	DO 3334 N=1,82
3334	LINECL(N)=CHAR(32)
	RETCD=1
C HANDLE DTRCMD FUNCTIONS. LINE ARRAY PASSED IN HERE
C STARTS AFTER THE "DTR" SO WE CAN DECODE IT.
C EXECUTE DTR COMMAND
C  DTRCMD (COMMAND) GIVES DTR COMMAND FACILITY AT COMMAND
C LEVEL.
C ALLOW DTRIMM COMMAND TO USE DTR IMMEDIATE TERMINAL
C INTERFACE. THE REST CAN USE SAME COMMAND NAMES AS AFTER
C THE "DB" IN *U DBXXXX COMMANDS.
500	CONTINUE
C ENABLE/DISABLE FOR DTR FUNCTIONS
C SETTING DTRENA TO -1 IMPLIES DISABLE FUNCTIONS
	CALL SCMP(LINE,'ENA',3,ICODE)
	IF(ICODE.NE.1)GOTO 600
	DTRENA=1
	GOTO 9999
600	CONTINUE
	CALL SCMP(LINE,'DIS',3,ICODE)
	IF(ICODE.NE.1)GOTO 700
	DTRENA=-1
	GOTO 9999
700	CONTINUE
	CALL SCMP(LINE,'OPINS',5,ICODE)
C OPEN INPUT SEQUENTIAL
	IF(ICODE.NE.1)GOTO 3800
C DTROPINS RANGE FILENAME
	IBGN=6
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
	LINE(LSTCH+25)=CHAR(0)
	OPEN(UNIT=MFILUN,FILE=LINE(LSTCH),ACCESS='SEQUENTIAL',
     1  STATUS='OLD',IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFIOPN=1
	GOTO 9999
3800	CONTINUE
	CALL SCMP(LINE,'OPINRR',6,ICODE)
C OPEN IN RANDOM READ
	IF(ICODE.NE.1)GOTO 3900
	KK=2
	GOTO 3910
3900	CONTINUE
	CALL SCMP(LINE,'OPINRU',6,ICODE)
C OPEN IN RANDOM UPDATE
	IF(ICODE.NE.1)GOTO 3950
	KK=3
3910	CONTINUE
C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C *******
C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
	DO 5601 NN=1,50
5601	MBUF(NN)=' '
	DO 5602 NN=1,25
5602	MBUF(NN)=LINE(LSTCH+NN-1)
C	LINE(LSTCH+25)=0
C	NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
C	OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='BINARY',
C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='OLD',
C     1  RECL=128,BLOCKSIZE=128,ERR=9990)
	OPEN(UNIT=MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
     1  STATUS='OLD',FORM='UNFORMATTED',RECL=128,
     1  IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFIOPN=KK
	GOTO 9999
3950	CONTINUE
	CALL SCMP(LINE,'OPOUTS',6,ICODE)
C OPEN OUTPUT SEQUENTIAL
	IF(ICODE.NE.1)GOTO 4000
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C *******
C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
C	LINE(LSTCH+25)=0
	DO 5603 NN=1,50
5603	MBUF(NN)=' '
	DO 5604 NN=1,25
5604	MBUF(NN)=LINE(LSTCH+NN-1)
	OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='SEQUENTIAL',
     1  STATUS='NEW',IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFOOPN=1
	GOTO 9999
4000	CONTINUE
	CALL SCMP(LINE,'OPOUTR',6,ICODE)
C OPEN OUTPUT RANDOM
	IF(ICODE.NE.1)GOTO 4100
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C	NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
C *******
C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
	DO 5605 NN=1,50
5605	MBUF(NN)=' '
	DO 5606 NN=1,25
5606	MBUF(NN)=LINE(LSTCH+NN-1)
C	LINE(LSTCH+25)=0
C	OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='NEW',
C     1  RECL=32,BLOCKSIZE=128,ERR=9990)
	OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='DIRECT',
     1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
     2  IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFOOPN=2
	GOTO 9999
4100	CONTINUE
	CALL SCMP(LINE,'CLSOUT',6,ICODE)
C CLOSE OUTPUT 
	IF(ICODE.NE.1)GOTO 4200
	CLOSE(UNIT=MFOLUN)
	MFOOPN=0
	GOTO 9999
4200	CONTINUE
	CALL SCMP(LINE,'CLSINP',6,ICODE)
C CLOSE INPUT 
	IF(ICODE.NE.1)GOTO 4300
	CLOSE(UNIT=MFILUN)
	MFIOPN=0
	GOTO 9999
4300	CONTINUE
	CALL SCMP(LINE,'ENAOUT',6,ICODE)
C ENABLE OUTPUT 
	IF(ICODE.NE.1)GOTO 4400
	MFOFLG=1
	GOTO 9999
4400	CONTINUE
	CALL SCMP(LINE,'ENAINP',6,ICODE)
C ENABLE INPUT 
	IF(ICODE.NE.1)GOTO 4500
	MFIFLG=1
	GOTO 9999
4500	CONTINUE
	CALL SCMP(LINE,'DISINP',6,ICODE)
C DISABLE INPUT 
	IF(ICODE.NE.1)GOTO 4510
	MFIFLG=0
	GOTO 9999
4510	CONTINUE
	CALL SCMP(LINE,'DISOUT',6,ICODE)
C DISABLE OUTPUT
	IF(ICODE.NE.1)GOTO 4520
	MFOFLG=0
	GOTO 9999
4520	CONTINUE
	CALL SCMP(LINE,'EDTINP',6,ICODE)
C ENABLE INPUT FORCE
C COMMAND
C DTREDTINP RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
	IF(ICODE.NE.1)GOTO 4600
C FORCE ENABLE OF READIN DURING THIS
	MFIFLG=1
	MFOFLG=1
C ENABLE OUTPUT TOO.
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
	DO 4550 N1=IXRL,IXRH
	DO 4550 N2=IXCL,IXCH
	CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
	CALL FVLDST(N1,N2,Char(255))
	CALL WRKFIL(IRX,LBUF,0)
	CALL WRKFIL(IRX,LBUF,1)
4550	CONTINUE
	MFIFLG=0
	MFOFLG=0
	GOTO 9999
4600	CONTINUE
	CALL SCMP(LINE,'FMTOUT',6,ICODE)
C FORMAT/WRITE OUTPUT
C COMMAND
C DTRFMTOUT RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
	IF(ICODE.NE.1)GOTO 4630
	IVLFG=1
	GOTO 4740
4630	CONTINUE
	CALL SCMP(LINE,'VALOUT',6,ICODE)
	IF(ICODE.NE.1)GOTO 4700
C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
	IVFLG=2
C	GOTO 4740
4740	CONTINUE
C FORCE ENABLE OF READIN DURING THIS
	MFIFLG=1
	MFOFLG=1
C ENABLE OUTPUT TOO.
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
	DO 4650 N1=IXRL,IXRH
	DO 4650 N2=IXCL,IXCH
C FIND INDEX FOR WRKFIL
	CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
	CALL XVBLGT(N1,N2,TMP)
C TMP IS REAL*8 SCRATCH
	CALL FVLDST(N1,N2,Char(255))
	CALL WRKFIL(IRX,LBUF,0)
C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
C NOW GRAB THE VALUE AND SAVE IT...
C FIRST MOVE THE FORMAT DOWN
C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
	DO 4651 N=1,9
	LBUF(N+1)=LBUF(N+119)
4651	CONTINUE
	LBUF(1)='('
	LBUF(11)=')'
c	LBUF(12)=CHAR(0)
C CHANGE TO USE CHAR VERSION OF LBUF
C *******
C FORMAT NOW LIVES IN LOW PART OF LBUF
C D25.17 FORMAT WOULD DO FOR WRITE
c	IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF(1:11),ERR=4652)TMP
	IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF,ERR=4652)TMP
	IF(IVLFG.EQ.2)WRITE(LINEC(1:70),4658,ERR=4652)TMP
4658	FORMAT(D25.17)
C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
C USE DISPLAY FORMAT.
4652	CONTINUE
	KK=1
	DO 4653 N=1,110
4653	LBUF(N)=CHAR(0)
	DO 4654 N=1,60
C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
	KKK=JCHAR(LINECL(N))
	IF(KKK.LE.32)GOTO 4654
	LBUF(KK)=LINECL(N)
	KK=KK+1
4654	CONTINUE
	CALL WRKFIL(IRX,LBUF,1)
4650	CONTINUE
	MFIFLG=0
	MFOFLG=0
	GOTO 9999
4700	CONTINUE
	CALL SCMP(LINE,'CMPFRM',6,ICODE)
	IF(ICODE.NE.1)GOTO 4800
C DBCMPFRM V1:V2
C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
	IBGN=7
	IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
	CALL REFLEC(IXCL,IXRL,IRXL)
	CALL REFLEC(IXCH,IXRH,IRXH)
	IF(LINE(LSTCH).NE.',')GOTO 4780
	IBGN=LSTCH+1
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
	IF(IVLD.EQ.3)GOTO 4780
C GET THE LENGTHS NOW
	CALL XVBLGT(IYRL,IYCL,TMP)
	IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
	LBUFL=TMP
	CALL XVBLGT(IYRH,IYCH,TMP)
	IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
	MBUFL=TMP
C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
C COMPARISONS BASED ON THAT.
	GOTO 4770
4780	CONTINUE
C GET INDEX OF EACH ELEMENT...
	CALL WRKFIL(IRXL,LBUF,0)
	CALL WRKFIL(IRXH,MBUF,0)
C LOAD THE 2 FORMULAS.
C NOW FIND THE ENDS...
	DO 4750 N=1,110
	NN=111-N
	IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
4750	CONTINUE
4751	LBUFL=NN
	DO 4760 N=1,110
	NN=111-N
	IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
4760	CONTINUE
4761	MBUFL=NN
4770	CONTINUE
c find index pos'n by hand...
	KK=LBUFL-MBUFL+1
	DO 4776 NN=1,KK
	IF(LBUF(NN).NE.MBUF(1))GOTO 4776
	NNN=MBUFL-1
	DO 4777 N=1,NNN
	IVVV=NN+N
	IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
4777	CONTINUE
C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
C SINCE NN IS WHAT WE NEED, GO USE IT.
	GOTO 4779
4778	CONTINUE
4776	CONTINUE
C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
C
	NN=0
4779	CONTINUE
C NN IS LOCATION OF SUBSTRING NOW
C	NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
C NN IS LOCATION OF SUBSTRING NOW
	XAC=NN
C RETURN RESULT IN % ACCUMULATOR.
	WAC=0.
	IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
	IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
	GOTO 9999
4800	CONTINUE
	CALL SCMP(LINE,'LENFRM',6,ICODE)
	IF(ICODE.NE.1)GOTO 4900
C DBLENFRM V1:V2
C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
	IBGN=7
	IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
	CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
	CALL WRKFIL(IRXL,LBUF,0)
C LOAD THE FORMULA.
C NOW FIND THE END...
	DO 4850 N=1,110
	NN=111-N
	IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
4850	CONTINUE
4851	LBUFL=NN
	TMP=LBUFL
	XAC=TMP
C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
	NN=0
C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
	CALL FVLDGT(IXRH,IXCH,NN)
	IF(NN.EQ.0)GOTO 9999
	CALL XVBLST(IXRH,IXCH,TMP)
	GOTO 9999
4900	CONTINUE
	CALL SCMP(LINE,'TRMFRM',6,ICODE)
	IF(ICODE.NE.1)GOTO 5000
C TRIM FORMULA
C DTRTRMFRM INCELL:OUTCELL,START:END
C RETURNS TRIMMED FORMULA TO CELL.
	IBGN=7
	IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
	CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
	CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
	CALL REFLEC(IXCH,IXRH,IRXH)
	CALL WRKFIL(IRXL,LBUF,0)
	LO=LSTCHR+1
	LHI=LSTCHR+21
	LSTCHR=LHI
	CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
	IF(IVLD.EQ.0)GOTO 9990
	CALL XVBLGT(JD1,JD2,TMP)
	LOCHR=1
	IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
C LOCHR = START CHAR
	LO=LSTCHR+1
	LHI=LSTCHR+21
	LSTCHR=LHI
	CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
	IF(IVLD.EQ.0)GOTO 9990
	CALL XVBLGT(JD1,JD2,TMP)
	LHICHR=110
	IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
C LHICHR IS END CHARACTER
C NOW ALL ARGS ARE COLLECTED.
C (IGNORE WHAT WAS DELIMITER...)
C COPY DESIRED STUFF TO MBUF
	N=1
	DO 4910 NN=1,110
	MBUF(NN)=CHAR(0)
	IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
	MBUF(N)=LBUF(NN)
	N=N+1
C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
4910	CONTINUE
	DO 4911 NN=111,128
4911	MBUF(NN)=LBUF(NN)
	CALL WRKFIL(IRXH,MBUF,1)
C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
	GOTO 9999
5000	CONTINUE
	GOTO 9999
9990	RETCD=3
C ERROR RETURN
9999	RETURN
	END
c -h- dtrfct.for	Fri Aug 22 13:05:02 1986	
C DATATRIEVE INTERFACE FUNCTIONS
C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
C COPYRIGHT 1986 GCE
	SUBROUTINE DTRFCT(LINE,RETCD)
	InTeGer*4 RETCD
	CHARACTER*1 LINE(80)
	CHARACTER *1 LINECL(82)
	CHARACTER*62 LINEC
	EQUIVALENCE(LINEC(1:1),LINECL(1))
C
C
C DEFINE FILE AREAS FOR MAPPING FILES...
C
C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
C
C MFIOPN =	0	IF NOT OPEN
C		1	IF OPEN FOR READ ONLY, SEQUENTIAL
C		2	IF OPEN READ ONLY, RANDOM
C		3	IF OPEN READ/WRITE, RANDOM.
C
C MFOOPN =	0	IF NOT OPEN
C		1	IF OPEN WRITE SEQUENTIAL
C		2	IF OPEN WRITE RANDOM
C
C OTHER OPTIONS DON'T MAKE SENSE.
C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
C MFILUN,MFOLUN ARE LOGICAL UNITS.
	InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
	InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
	InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
	COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
     1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
C
C
C	INCLUDE 'VKLUGPRM.FTN'
C COPYRIGHT (C) 1983 GLENN EVERHART
C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
	CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XAC,XVBLS(1,1)
	REAL*8 TAC,UAC,VAC,WAC,YAC
	REAL*8 TMP
	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
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 XTNCNT,XTCFG,IPSET
CCC	CHARACTER*1 XTNCMD(80)
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
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)
	INTEGER IVVV
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
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	InTeGer*4 DTRENA
CCC	COMMON/DTRCMN/DTRENA
C	CHARACTER*70 LINEC
	CHARACTER*1 LBUF(128)
	CHARACTER*1 MBUF(128)
	CHARACTER*110 CLBUF,CMBUF
C	EQUIVALENCE(CLBUF(1:1),LBUF(1)),(CMBUF(1:1),MBUF(1))
	CHARACTER*50 CCMBUF
	CHARACTER*11 C11LBF
	EQUIVALENCE(CCMBUF(1:1),CMBUF(1:1),MBUF(1)),
     1  (C11LBF(1:1),CLBUF(1:1),LBUF(1))
C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
c	CHARACTER*1 IFVLD
	RETCD=1
	IF(DTRENA.LT.0)GOTO 9999
C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
ccc	DO 3332 N=1,76
ccc	NN=77-N
ccc	IF(JCHAR(LINE(NN)).GT.32)GOTO 3333
ccc	LINE(NN)=CHAR(0)
ccc3332	CONTINUE
ccc3333	CONTINUE
C SPACE FILL ENTIRE ARRAY
	DO 3334 N=1,82
3334	LINECL(N)=CHAR(32)
	RETCD=1
C HANDLE *U DBXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
C STARTS AFTER THE "DB" SO WE CAN DECODE IT.
C *U DBCMD (COMMAND) PASSES COMMAND TO DTR FOR ACTION
C  HOWEVER THIS DOES NOT RETURN A VALUE. USE FOR
C  SETUP PURPOSES ONLY.
C
C NO NEED TO INCLUDE ABILITY TO STORE COMMANDS IN CELLS
C FOR EDITING SINCE {CELL CONSTRUCT PROVIDES THIS ALREADY.
C (AND AT COMMAND LEVEL THE __{CELL CONSTRUCT DOES ALSO.)
500	CONTINUE
	CALL SCMP(LINE,'OPINS',5,ICODE)
C OPEN INPUT SEQUENTIAL
	IF(ICODE.NE.1)GOTO 3800
C DTROPINS RANGE FILENAME
	IBGN=6
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C	LINE(LSTCH+25)=CHAR(0)
	DO 5601 NN=1,50
5601	MBUF(NN)=' '
	DO 5602 NN=1,25
5602	MBUF(NN)=LINE(LSTCH+NN-1)
	OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
     1  STATUS='OLD',IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFIOPN=1
	GOTO 9999
3800	CONTINUE
	CALL SCMP(LINE,'OPINRR',6,ICODE)
C OPEN IN RANDOM READ
	IF(ICODE.NE.1)GOTO 3900
	KK=2
	GOTO 3910
3900	CONTINUE
	CALL SCMP(LINE,'OPINRU',6,ICODE)
C OPEN IN RANDOM UPDATE
	IF(ICODE.NE.1)GOTO 3950
	KK=3
3910	CONTINUE
C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W

	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C	LINE(LSTCH+25)=0
	DO 5603 NN=1,50
5603	MBUF(NN)=' '
	DO 5604 NN=1,25
5604	MBUF(NN)=LINE(LSTCH+NN-1)
C	NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
	OPEN(MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
     1  FORM='UNFORMATTED',RECL=128,STATUS='OLD',IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFIOPN=KK
	GOTO 9999
3950	CONTINUE
	CALL SCMP(LINE,'OPOUTS',6,ICODE)
C OPEN OUTPUT SEQUENTIAL
	IF(ICODE.NE.1)GOTO 4000
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
	DO 5605 NN=1,50
5605	MBUF(NN)=' '
	DO 5606 NN=1,25
5606	MBUF(NN)=LINE(LSTCH+NN-1)
	OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
     1  STATUS='NEW',IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFOOPN=1
	GOTO 9999
4000	CONTINUE
	CALL SCMP(LINE,'OPOUTR',6,ICODE)
C OPEN OUTPUT RANDOM
	IF(ICODE.NE.1)GOTO 4100
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C	NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
C	LINE(LSTCH+25)=0
	DO 5607 NN=1,50
5607	MBUF(NN)=' '
	DO 5608 NN=1,25
5608	MBUF(NN)=LINE(LSTCH+NN-1)
	OPEN(MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
     1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
     2  IOSTAT=IVVV)
	IF(IVVV.NE.0)GOTO 9990
	MFOOPN=2
	GOTO 9999
4100	CONTINUE
	CALL SCMP(LINE,'CLSOUT',6,ICODE)
C CLOSE OUTPUT 
	IF(ICODE.NE.1)GOTO 4200
	CLOSE(UNIT=MFOLUN)
	MFOOPN=0
	GOTO 9999
4200	CONTINUE
	CALL SCMP(LINE,'CLSINP',6,ICODE)
C CLOSE INPUT 
	IF(ICODE.NE.1)GOTO 4300
	CLOSE(UNIT=MFILUN)
	MFIOPN=0
	GOTO 9999
4300	CONTINUE
	CALL SCMP(LINE,'ENAOUT',6,ICODE)
C ENABLE OUTPUT 
	IF(ICODE.NE.1)GOTO 4400
	MFOFLG=1
	GOTO 9999
4400	CONTINUE
	CALL SCMP(LINE,'ENAINP',6,ICODE)
C ENABLE INPUT 
	IF(ICODE.NE.1)GOTO 4500
	MFIFLG=1
	GOTO 9999
4500	CONTINUE
	CALL SCMP(LINE,'DISINP',6,ICODE)
C DISABLE INPUT 
	IF(ICODE.NE.1)GOTO 4510
	MFIFLG=0
	GOTO 9999
4510	CONTINUE
	CALL SCMP(LINE,'DISOUT',6,ICODE)
C DISABLE OUTPUT
	IF(ICODE.NE.1)GOTO 4520
	MFOFLG=0
	GOTO 9999
4520	CONTINUE
	CALL SCMP(LINE,'EDTINP',6,ICODE)
C ENABLE INPUT FORCE
C COMMAND
C DTREDTINP RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
	IF(ICODE.NE.1)GOTO 4600
C FORCE ENABLE OF READIN DURING THIS
	MFIFLG=1
	MFOFLG=1
C ENABLE OUTPUT TOO.
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
	DO 4550 N1=IXRL,IXRH
	DO 4550 N2=IXCL,IXCH
	CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
	CALL FVLDST(N1,N2,Char(255))
	CALL WRKFIL(IRX,LBUF,0)
	CALL WRKFIL(IRX,LBUF,1)
4550	CONTINUE
	MFIFLG=0
	MFOFLG=0
	GOTO 9999
4600	CONTINUE
	CALL SCMP(LINE,'FMTOUT',6,ICODE)
C FORMAT/WRITE OUTPUT
C COMMAND
C DTRFMTOUT RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
	IF(ICODE.NE.1)GOTO 4630
	IVLFG=1
	GOTO 4740
4630	CONTINUE
	CALL SCMP(LINE,'VALOUT',6,ICODE)
	IF(ICODE.NE.1)GOTO 4700
C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
	IVFLG=2
C	GOTO 4740
4740	CONTINUE
C FORCE ENABLE OF READIN DURING THIS
	MFIFLG=1
	MFOFLG=1
C ENABLE OUTPUT TOO.
	IBGN=7
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
	DO 4650 N1=IXRL,IXRH
	DO 4650 N2=IXCL,IXCH
C FIND INDEX FOR WRKFIL
	CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
	CALL XVBLGT(N1,N2,TMP)
C TMP IS REAL*8 SCRATCH
	CALL FVLDST(N1,N2,Char(255))
	CALL WRKFIL(IRX,LBUF,0)
C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
C NOW GRAB THE VALUE AND SAVE IT...
C FIRST MOVE THE FORMAT DOWN
C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
	DO 4651 N=1,9
	LBUF(N+1)=LBUF(N+119)
4651	CONTINUE
	LBUF(1)='('
	LBUF(11)=')'
c	LBUF(12)=0
C FORMAT NOW LIVES IN LOW PART OF LBUF
C D25.17 FORMAT WOULD DO FOR WRITE
C NEED CHAR VBL FOR FORMAT EQUIV'D TO LOW 12 CHARS OF LBUF
c	IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF(1:11),ERR=4652)TMP
	IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF,ERR=4652)TMP
	IF(IVLFG.EQ.2)WRITE(LINEC(1:62),4658,ERR=4652)TMP
4658	FORMAT(D25.17)
C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
C USE DISPLAY FORMAT.
4652	CONTINUE
	KK=1
	DO 4653 N=1,110
4653	LBUF(N)=CHAR(0)
	DO 4654 N=1,60
C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
	KKK=JCHAR(LINECL(N))
	IF(KKK.LE.32)GOTO 4654
	LBUF(KK)=LINECL(N)
	KK=KK+1
4654	CONTINUE
	CALL WRKFIL(IRX,LBUF,1)
4650	CONTINUE
	MFIFLG=0
	MFOFLG=0
	GOTO 9999
4700	CONTINUE
	CALL SCMP(LINE,'CMPFRM',6,ICODE)
	IF(ICODE.NE.1)GOTO 4800
C DBCMPFRM V1:V2
C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
	IBGN=7
	IVLD=0
	LSTCH=78
C USE GMTX TO GET CELL ADDRESSES.
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
	CALL REFLEC(IXCL,IXRL,IRXL)
	CALL REFLEC(IXCH,IXRH,IRXH)
	IF(LINE(LSTCH).NE.',')GOTO 4780
	IBGN=LSTCH+1
	IVLD=0
	CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
	IF(IVLD.EQ.3)GOTO 4780
C GET THE LENGTHS NOW
	CALL XVBLGT(IYRL,IYCL,TMP)
	IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
	LBUFL=TMP
	CALL XVBLGT(IYRH,IYCH,TMP)
	IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
	MBUFL=TMP
C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
C COMPARISONS BASED ON THAT.
	GOTO 4770
4780	CONTINUE
C GET INDEX OF EACH ELEMENT...
	CALL WRKFIL(IRXL,LBUF,0)
	CALL WRKFIL(IRXH,MBUF,0)
C LOAD THE 2 FORMULAS.
C NOW FIND THE ENDS...
	DO 4750 N=1,110
	NN=111-N
	IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
4750	CONTINUE
4751	LBUFL=NN
	DO 4760 N=1,110
	NN=111-N
	IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
4760	CONTINUE
4761	MBUFL=NN
4770	CONTINUE
c find index pos'n by hand...
	KK=LBUFL-MBUFL+1
	DO 4776 NN=1,KK
	IF(LBUF(NN).NE.MBUF(1))GOTO 4776
	NNN=MBUFL-1
	DO 4777 N=1,NNN
	IVVV=NN+N
	IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
4777	CONTINUE
C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
C SINCE NN IS WHAT WE NEED, GO USE IT.
	GOTO 4779
4778	CONTINUE
4776	CONTINUE
C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
C
	NN=0
4779	CONTINUE
C NN IS LOCATION OF SUBSTRING NOW
C	NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
	XAC=NN
C RETURN RESULT IN % ACCUMULATOR.
	WAC=0.
	IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
	IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
	GOTO 9999
4800	CONTINUE
	CALL SCMP(LINE,'LENFRM',6,ICODE)
	IF(ICODE.NE.1)GOTO 4900
C DBLENFRM V1:V2
C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
	IBGN=7
	IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
	CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
	CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
	CALL WRKFIL(IRXL,LBUF,0)
C LOAD THE FORMULA.
C NOW FIND THE END...
	DO 4850 N=1,110
	NN=111-N
	IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
4850	CONTINUE
4851	LBUFL=NN
	TMP=LBUFL
	XAC=TMP
C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
	NN=0
C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
	CALL FVLDGT(IXRH,IXCH,NN)
	IF(NN.EQ.0)GOTO 9999
	CALL XVBLST(IXRH,IXCH,TMP)
	GOTO 9999
4900	CONTINUE
	CALL SCMP(LINE,'TRMFRM',6,ICODE)
	IF(ICODE.NE.1)GOTO 5000
C TRIM FORMULA
C DTRTRMFRM INCELL:OUTCELL,START:END
C RETURNS TRIMMED FORMULA TO CELL.
	IBGN=7
	IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
	CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
	IF(IVLD.EQ.3)GOTO 9990
C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
	CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
	CALL REFLEC(IXCH,IXRH,IRXH)
	CALL WRKFIL(IRXL,LBUF,0)
	LO=LSTCHR+1
	LHI=LSTCHR+21
	LSTCHR=LHI
	CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
	IF(IVLD.EQ.0)GOTO 9990
	CALL XVBLGT(JD1,JD2,TMP)
	LOCHR=1
	IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
C LOCHR = START CHAR
	LO=LSTCHR+1
	LHI=LSTCHR+21
	LSTCHR=LHI
	CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
	IF(IVLD.EQ.0)GOTO 9990
	CALL XVBLGT(JD1,JD2,TMP)
	LHICHR=110
	IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
C LHICHR IS END CHARACTER
C NOW ALL ARGS ARE COLLECTED.
C (IGNORE WHAT WAS DELIMITER...)
C COPY DESIRED STUFF TO MBUF
	N=1
	DO 4910 NN=1,110
	MBUF(NN)=CHAR(0)
	IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
	MBUF(N)=LBUF(NN)
	N=N+1
C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
4910	CONTINUE
	DO 4911 NN=111,128
4911	MBUF(NN)=LBUF(NN)
	CALL WRKFIL(IRXH,MBUF,1)
C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
	GOTO 9999
5000	CONTINUE
	GOTO 9999
9990	RETCD=3
C ERROR RETURN
9999	RETURN
	END
c -h- fft.ftn	Fri Aug 22 13:08:56 1986	
C  
C-----------------------------------------------------------------------
C SUBROUTINE: FOUREA
C PERFORMS COOLEY-TUKEY FAST FOURIER TRANSFORM
C-----------------------------------------------------------------------
C  
      SUBROUTINE FOUREA(ID1,ID2,IC,IR,IVN,ISI)
C ID1,ID2 = COORDS OF FIRST CELL. IC AND IR ARE 0, OR 1
C ONLY ONE OF IC, IR MAY BE NONZERO. (FLAGS HORIZ/VERTICAL
C DATA AREA)
C  
C THE COOLEY-TUKEY FAST FOURIER TRANSFORM IN ANSI FORTRAN
C  
C DATA IS A ONE-DIMENSIONAL COMPLEX ARRAY WHOSE LENGTH, N, IS A
C POWER OF TWO.  ISI IS +1 FOR AN INVERSE TRANSFORM AND -1 FOR A
C FORWARD TRANSFORM.  TRANSFORM VALUES ARE RETURNED IN THE INPUT
C ARRAY, REPLACING THE INPUT.
C TRANSFORM(J)=SUM(DATA(I)*W**((I-1)*(J-1))), WHERE I AND J RUN
C FROM 1 TO N AND W = EXP (ISI*2*PI*SQRT(-1)/N).  PROGRAM ALSO
C COMPUTES INVERSE TRANSFORM, FOR WHICH THE DEFINING EXPRESSION
C IS INVTR(J)=(1/N)*SUM(DATA(I)*W**((I-1)*(J-1))).
C RUNNING TIME IS PROPORTIONAL TO N*LOG2(N), RATHER THAN TO THE
C CLASSICAL N**2.
C AFTER PROGRAM BY BRENNER, JUNE 1967. THIS IS A VERY SHORT VERSION
C OF THE FFT AND IS INTENDED MAINLY FOR DEMONSTRATION. PROGRAMS
C ARE AVAILABLE IN THIS COLLECTION WHICH RUN FASTER AND ARE NOT
C RESTRICTED TO POWERS OF 2 OR TO ONE-DIMENSIONAL ARRAYS.
C SEE -- IEEE TRANS AUDIO (JUNE 1967), SPECIAL ISSUE ON FFT.
C  
C ASSUMES THAT FIRST N/2 ELEMENTS ARE REAL, SECOND COMPLEX...
C STORES DATA THAT WAY ALSO...
C
C      COMPLEX DATA(1)
C      COMPLEX TEMP, W
C MAKE THIS A REAL FFT, NOT COMPLEX...
	REAL*8 DATA(1),TEMP,W,TEMP2,TEMPI,WI
	InTeGer*4 ID1,ID2,IC,IR,IRX,IRXX,IVN,N
C SET UP STMT FUNCTIONS...
	ID1F(K)=ID1+IC*(K-1)
	ID2F(K)=ID2+IR*(K-1)
	N=IVN
C  
C CHECK FOR POWER OF TWO UP TO 14
C  
C INITIALLY SAY ALL OK
      NN = 1
      DO 10 I=1,14
        M = I
        NN = NN*2
        IF (NN.EQ.N) GO TO 20
	IF(NN.GT.N)GOTO 11
  10  CONTINUE
11	CONTINUE
	N=NN/2
C USE NEXT SMALLER POWER OF 2 ARRAY...
C	RETURN
C HERE BEGINNETH ACTUAL WORK.
C SET UP DATA COORDS ON THE FLY. NORMALLY I,J RUN IN RANGE 1 TO N
C SO WHERE K=(I OR J) (I.E., ONE OF THE TWO) WE USE A RELATION
C ID1V=ID1+IC*(K-1) AND ID2V=ID2+IR*(K-1). WE USE STMT FUNCTIONS
C ID1F AND ID2F FOR THIS.
  20  CONTINUE
	NOV2=N/2
C  
C      PI = 4.*ATAN(1.)
	PI=3.14159265358979323846264
      FN = NOV2
C  
C THIS SECTION PUTS DATA IN BIT-REVERSED ORDER
C  
      J = 1
      DO 80 I=1,NOV2
C  
C AT THIS POINT, I AND J ARE A BIT REVERSED PAIR (EXCEPT FOR THE
C DISPLACEMENT OF +1)
C  
	IF(I.GE.J)GOTO 40
C  
C EXCHANGE DATA(I) WITH DATA(J) IF I.LT.J.
C  
 30	CONTINUE
C EXCHANGE DATA(J), DATA(I)
	CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
	CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
	CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
	CALL XVBLST(ID1F(I),ID2F(I),TEMP)
C FLIP BOTH REAL AND COMPLEX PARTS OF DATA
	CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMP)
	CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
	CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
	CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP)
C  30    TEMP = DATA(J)
C        DATA(J) = DATA(I)
C        DATA(I) = TEMP
C  
C IMPLEMENT J=J+1, BIT-REVERSED COUNTER
C  
  40    M = NOV2/2
  50    IF (J.LE.M) GOTO 70
  60    J = J - M
        M = (M+1)/2
        GO TO 50
  70    J = J + M
  80  CONTINUE
C  
C NOW COMPUTE THE BUTTERFLIES
C  
      MMAX = 1
  90  IF (MMAX.GE.NOV2)GOTO 130
 100  ISTEP = 2*MMAX
      DO 120 M=1,MMAX
        THETA = PI*FLOAT(ISI*(M-1))/FLOAT(MMAX)
	 W = COS(THETA)
        WI = SIN(THETA)
C        W = CMPLX(COS(THETA),SIN(THETA))
        DO 110 I=M,NOV2,ISTEP
          J = I + MMAX
C GET REAL AND IMAG HALVES OF NUMBER...
	  CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
	  CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMPI)
C DO COMPLEX MULTIPLICATION BY HAND TO AVOID LARGE RUNTIME SYSTEM
C ROUTINE INCLUSION.
	  TEMP2=W*TEMP-WI*TEMPI
	  TEMPI=WI*TEMP+W*TEMPI
	TEMP=TEMP2
C          TEMP = W*DATA(J)
C          DATA(J) = DATA(I) - TEMP
C          DATA(I) = DATA(I) + TEMP
	   CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
	   TEMP2=DATA(1)+TEMP
	   DATA(1)=DATA(1) - TEMP
	   CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
	   CALL XVBLST(ID1F(I),ID2F(I),TEMP2)
C COMPLEX PART
	   CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
	   TEMP2=DATA(1)+TEMPI
	   DATA(1)=DATA(1) - TEMPI
	   CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
	   CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP2)
 110    CONTINUE
 120  CONTINUE
      MMAX = ISTEP
      GO TO 90
  130  IF (ISI.LT.0) GOTO 160
C  
C FOR INV TRANS -- ISI=1 -- MULTIPLY OUTPUT BY 1/N
C  
 140  DO 150 I=1,N
C        DATA(I) = DATA(I)/FN
	CALL XVBLGT(ID1F(I),ID2F(I),TEMP)
	TEMP=TEMP/FN
	CALL XVBLST(ID1F(I),ID2F(I),TEMP)
 150  CONTINUE
 160  RETURN
      END
c -h- help.for	Fri Aug 22 13:20:10 1986	
	SUBROUTINE HELP(LVL)
C PRINT HELP INFO ON SCREEN USING FIRST 22 LINES. ASSUME XQTCMD INVALIDATES
C THE DISPLAY.
C COPYRIGHT (C) 1983 GLENN AND MARY EVERHART
	CHARACTER*1 FORM(128)
	CALL UVT100(18,0,0)
	CALL UVT100(11,2,0)
	CALL UVT100(1,1,1)
C COPYRIGHT (C) 1983 GLENN and MARY EVERHART
C All Rights Reserved
C
C NEW PC HELP FILE
C DESIGNED TO BE SMALLER THAN OLD VERSION. READS FILES OFF DISK
C BY SKIPPING N*24 LINES AND DISPLAYING 24 LINES, WHERE N=LVL
C ASSUME HELP FILE ON DISK LOGGED CURRENTLY
	CLOSE(3)
c for now, assume help file lives on same disk as our default.
	IXXX=0
	OPEN(3,FILE='PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
     1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
C try on dk: if we can't find it in default.
	If(IXXX.LE.0)goto 2772
	Close(3)
	OPEN(3,FILE='DK:PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
     1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
	IF(IXXX.GT.0)RETURN
2772	Continue
C RETURN IF HELP FILE IS MISSING...
C USE A FIXED HELP FILE FOR MULTISCREEN HELP. LOWER OVERHEAD,...
	NSKP=LVL*24
C NOW READ IN THE DATA, WRITE TO SCREEN.
	KKL=NSKP+1
	KKH=NSKP+23
C JUST GO DIRECTLY TO THE DESIRED SCREENFUL OF INFO.
	DO 7640 KKK=KKL,KKH
	READ(3,REC=KKK,END=7642,ERR=7642)FORM
c use fortran writes here normally since we want the crlf stuff they imply
c always write 24 lines to scroll all else off...
	IVVV=78
C FIND END OF LINE AND ONLY EMIT CHARACTERS TO THAT; DON'T WASTE
C TIME DRAWING SPACES ON THE SCREEN.
	DO 772 IV=1,78
	IVVV=79-IV
	IF(ICHAR(FORM(IVVV)).GT.32)GOTO 773
772	CONTINUE
773	CONTINUE
	FORM(IVVV+1)=Char(13)
	FORM(IVVV+2)=Char(10)
	IVVV=IVVV+2
	CALL SWRT(FORM,IVVV)
C	WRITE(11,7643)(FORM(IV),IV=1,IVVV)
C NOTE WE HAVE LUN 6 OPENED AS CON: IN THE MAIN PROGRAM TO GIVE AN
C INDEPENDENT TERMINAL OUTPUT CHANNEL. HOPEFULLY THIS PREVENTS SOME
C SCREWUPS DUE TO USING LUN 0 FOR BOTH CONSOLE INPUT AND OUTPUT; END OF
C RECORDS OUGHT TO BE INDEPENDENT THIS WAY (I HOPE).
C7643	FORMAT(1X,82A1,4A1)
7640	CONTINUE
7642	CONTINUE
	CLOSE(3)
	FORM(1)=13
	CALL SWRT(FORM,1)
	RETURN
	END
c -h- linfit.for	Fri Aug 22 13:23:55 1986	
C LINE FITTING SUBROUTINE WITH ERROR MEASURE RETURN ALSO.
	SUBROUTINE LINFIT(ID1X,ID2X,IRCOL,ID1,ID2,N,A,B,DEL,RR)
	InTeGer*4 ID1X,ID2X,IRCOL,ID1,ID2,N
	REAL*8 A,B,DEL,XY,SX2,SX,SY,RR
	InTeGer*4 IC,IR,KK,KKK,I
	REAL*8 XI,YI,SY2,EN,WRK
C FIT LINE TO EQUALLY SPACED POINTS...
C Y=BX+A
	SY2=0.
	EN=N
	XY=0.
	SX2=0.
	SX=0.
	SY=0.
	IC=IRCOL
	IR=1-IRCOL
C IRCOL IS 0 OR 1 FOR ACROSS OR DOWN
	DO 10 I=1,N
C IF ID1X < 0 THEN FORM IT HERE AS ID1+I-1
	IF (ID1X.GT.0)GOTO 20
C FORM XI
	XI=I
	GOTO 30
20	CONTINUE
C INPUT XI
	KK=ID1X+IC*(I-1)
	KKK=ID2X+IR*(I-1)
	CALL XVBLGT(KK,KKK,XI)
30	CONTINUE
C GET YI IN ANY CASE...
	KK=ID1+IC*(I-1)
	KKK=ID2+IR*(I-1)
	CALL XVBLGT(KK,KKK,YI)
	XY=XY+XI*YI
C FORM SUMS NEEDED TO FIT LINE...
	SX2=SX2+XI*XI
	SX=SX+XI
	SY=SY+YI
	SY2=SY2+YI*YI
10	CONTINUE
C NOW GET SLOPE
	WRK=((XY-(SX*SY)/EN)/(SX2-(SX*SX)/EN))
	B=WRK
C THEN INTERCEPT
	WRK=(SY/EN)-B*(SX/EN)
	A=WRK
	WRK=DSQRT((SY2-(A*SY+B*XY))/EN)
	DEL=WRK
C DEL = ERROR OF FIT
	RR=(EN*XY-SX*SY)/DSQRT((EN*SX2-SX*SX)*(EN*SY2-SY*SY))
C RR IS CORRELATION COEFFICIENT
	RETURN
	END
c -h- list.for	Fri Aug 22 13:24:14 1986	
	SUBROUTINE LIST
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  LIST                  *
C *                                                *
C **************************************************
C
C
C LISTS THE LEGAL CALC COMMANDS AND GIVES A BRIEF
C DESCRIPTION OF THEIR FUNCTION.
C
C LIST IS CALLED BY CALC
C
C	SUBROUTINE LIST
C
C
C NOTE WE USE FORTRAN WRITE HERE SINCE IT SHOULD ONLY HAPPEN IN CALC MODE.
c	rewind 11
c	WRITE (11,20)
c	WRITE (11,30)
c	rewind 11
	Call vwrt(char(13)//char(10),2)
	Call vwrt(
     1  'Cmds= @file-do file;*C-Comment;*E-exit;*R-Read con',50)
	Call vwrt(char(13)//char(10),2)
	Call Vwrt(
     1  '*S-stop;*V n(bet.0,3)-View Ctl - Higher=see more',48)
	RETURN
c20	FORMAT (' CMDS= @FILE-DO FILE;*C-COMMENT;*E-EXIT;*R-READ CON')
c30	FORMAT (' *S-STOP;*V n(bet.0,3)-VIEW CTL- HIGHER=SEE MORE')
	END
c -h- wsset.f40	Fri Aug 22 13:43:11 1986	
        SUBROUTINE WSSET
C WORK SHEET MANAGMENT ROUTINES
C HANDLE SPREADSHEET "IN MEMORY" STORAGE
C COPYRIGHT (C) GLENN AND MARY EVERHART 1983,1984
C
C ALL RIGHTS RESERVED
C
C WSSET - INITIALIZE STORAGE TO START CONDITIONS
C EXPECT IMPLEMENTATION TO USE A COMMON BITMAP AND PROVIDE A VARIABLE
C NCEL TO TELL HOW MANY CELLS ARE IN USE
C NEXT BITMAPS IMPLEMENT FVLD
	Include AParms.Inc
        CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
	CHARACTER*1 FVXX(IMPS3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(IMP2S))
	EQUIVALENCE (FV4(1),FVXX(IMP3S))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
        CHARACTER*1 ITYP(IMP1S)
        InTeGer*4 IATYP(27),LINTGR
        COMMON/TYP/IATYP,ITYP,LINTGR
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC        InTeGer*4 IPGMAX,LPGMXF
CCC        COMMON/FILEMX/IPGMAX,LPGMXF
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C USE LUN 7 FOR FORMULAS, 9 FOR VALUES FILE IF NEEDED...
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 DVF(12),DFMT(10)
        EQUIVALENCE(DVF(2),DFMT(1))
        COMMON/DEFVBX/DVF
CCC	InTeGer*4 DLFG
CCC	COMMON/DLFG/DLFG
C DLFG IS NONZERO IF ANY D## FORMS HAVE BEEN SEEN
        InTeGer*4 MPAG(2),MPMOD
        InTeGer*2 LVALBF(5,MVal)
	DIMENSION MPMOD(2)
        COMMON/VB/MPAG,LVALBF,MPMOD
	InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
	COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
CCC	InTeGer*4 MFID(2)
C        InTeGer*4 MFID,IFID(8,MFrm)
C        CHARACTER*1 LFID(16,MFrm)
C        EQUIVALENCE(IFID(1,1),LFID(1,1))
CCC        COMMON/FRM/MFID,MFMOD
C        COMMON/FRM/MFID,IFID
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,MRows)
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        COMMON /NCEL/NCEL,NXINI
	LINTGR=0
	MPMOD(1)=0
	MPMOD(2)=0
	MFMOD(1)=0
	MFMOD(2)=0
	DLFG=0
        IBP=1
C INITIALIZE ADDRESSES FOR FVLDSG/FVLDGT
C	CALL FVGO(FV1,LBITS)
        DO 2 N=1,9
2       FMTDAT(N,1)=DFMT(N)
        DO 3 N=2,76
        DO 3 NN=1,9
3       FMTDAT(NN,N)=CHAR(0)
        DO 1 N=1,8
	NN=128/IBP
        LBITS(N)=CHAR(NN)
1       IBP=IBP+IBP
        DO 4 N=1,IMP1S
C CLEAR BITMAPS NOW
        FV1(N)=CHAR(0)
        FV2(N)=CHAR(0)
        FV4(N)=CHAR(0)
4       ITYP(N)=CHAR(0)
C OPEN THE WORK FILES SO WE DON'T NEED TO LATER...
C LUN 7 IS FORMULAS; LUN 9 IS VALUES
C HOWEVER, IF IPGMAX IS LESS THAN 800/205 (INDICATING ENTIRE FILE
C FITS IN MEMORY) DON'T OPEN LUN 9 AND IF LPGMXF IS < 2048/64, LIKEWISE
C FOR LUN 7.
C INITIALLY CLOSE FILES IN CASE THEY WERE OPEN...
        CLOSE(7,STATUS='DELETE')
        CLOSE(13,STATUS='DELETE')
C NOW OPEN THEM AS RANDOM ACCESS FILES.
        NBK=IPGMAX*2
C KEEP VALUE PAGES IN 500 BYTE UNITS, NOT 512 BYTE UNITS, TO COME
C OUT EVEN...
        IF(IPGMAX.GT.(MVal/100))OPEN(13,
     1  ACCESS='DIRECT',FORM='UNFORMATTED',
     3  RECL=500,STATUS='NEW')
        NBK=LPGMXF*2
        IF(LPGMXF.GT.(MFro64))OPEN(7,
     1  ACCESS='DIRECT',FORM='UNFORMATTED',
     3  RECL=512,STATUS='NEW')
C SET NOTHING IN MEMORY YET
        MFID(1)=0
	MFID(2)=0
        MPAG(1)=0
	MPAG(2)=0
C MARK BUFFER 1 AS IN MEMORY AND AS LAST-ACCESSED (SO WE FIRST ATTEMPT TO
C OVERWRITE BUFFER 2 TO GET STARTED.)
	MFLAST=1
	MFBASE=0
	MVLAST=1
	MVBASE=0
C ZERO MEMORY BUFFER AND FILES
C ACTUALLY MARK WITH -1 SO THAT WE CAN TELL WHEN WE HIT A VIRGIN
C AREA.
        DO 9 N=1,MVal
        DO 9 M=1,5
	KKKKK=-1
9       LVALBF(M,N)=KKKKK
        NPG=(IPGMAX*2)
        IF(IPGMAX.LE.(MVal/100))GOTO 11
        DO 10 N=1,NPG
10      WRITE(13,REC=N,ERR=11)((LVALBF(K,KKK),K=1,5),KKK=1,50)
11      CONTINUE
	CALL WRKFIL(0,0,50)
C        DO 12 N=1,2048
C        DO 12 M=1,8
C12      IFID(M,N)=0
C 	NPG=LPGMXF*2
C        IF(LPGMXF.LE.(2048/64))GOTO 14
C        DO 13 N=1,NPG
C13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
14      CONTINUE
C SET ALL AC'S TO TYPE FLOATING...
        DO 8 N=1,27
8       IATYP(N)=2
C TYPE 2 IS REALS (DEFAULT)
        NCEL=0
	NXINI=0
        RETURN
        END
c -h- wtbini.f40	Fri Aug 22 13:43:29 1986	
C WORK FORMULA TABLE INITIALIZE FOR DTBL1 COMMON
C COPYRIGHT (C) GLENN AND MARY EVERHART 1985
C ALL RIGHTS RESERVED
	SUBROUTINE WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,
     1  BTBL6,BTBL7,BTBL8)
	Include Aparms.inc
	CHARACTER*1 DTBL1(9,9,8)
C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
	Integer*4 LPGMXF
C	InTeGer*2 BTBL(6,6,8)
C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
C NO NEED TO WASTE IT.
	InTeGer*2 IFID(8,MFrm)
C	CHARACTER*1 LFID(16,MFrm)
C	EQUIVALENCE(LFID(1,1),IFID(1,1))
C	EQUIVALENCE(IFID(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)
C	EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
C	EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
C	EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
C	EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
	COMMON /DECIDE/ DTBL1
C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
C TYPES (WHICH ARE NOT SUPPORTED HERE)
	do 135 n3=1,8
	do 135 n2=1,9
	do 135 n1=1,9
135	dtbl1(n1,n2,n3)=CHAR(0)
	DO 35 NN2=1,6
	N2=NN2
	IF(NN2.GT.4)N2=NN2+3
	DO 235 N1=1,4
	DTBL1(N1,N2,1)=CHAR(BTBL1(N1,NN2))
	DTBL1(N1,N2,2)=CHAR(BTBL2(N1,NN2))
	DTBL1(N1,N2,3)=CHAR(BTBL3(N1,NN2))
	DTBL1(N1,N2,4)=CHAR(BTBL4(N1,NN2))
	DTBL1(N1,N2,5)=CHAR(BTBL5(N1,NN2))
	DTBL1(N1,N2,6)=CHAR(BTBL6(N1,NN2))
	DTBL1(N1,N2,7)=CHAR(BTBL7(N1,NN2))
235	DTBL1(N1,N2,8)=CHAR(BTBL8(N1,NN2))
	do 335 n1=5,6
	DTBL1(N1+3,N2,1)=CHAR(BTBL1(N1,NN2))
	DTBL1(N1+3,N2,2)=CHAR(BTBL2(N1,NN2))
	DTBL1(N1+3,N2,3)=CHAR(BTBL3(N1,NN2))
	DTBL1(N1+3,N2,4)=CHAR(BTBL4(N1,NN2))
	DTBL1(N1+3,N2,5)=CHAR(BTBL5(N1,NN2))
	DTBL1(N1+3,N2,6)=CHAR(BTBL6(N1,NN2))
	DTBL1(N1+3,N2,7)=CHAR(BTBL7(N1,NN2))
	DTBL1(N1+3,N2,8)=CHAR(BTBL8(N1,NN2))
335	continue
35	CONTINUE
C NOW CLEAR THE BUFFER OUT, HAVING SET UP DTBL1 FROM IT.
C SET INITIAL -1 SO WE CAN RECOGNIZE WHEN TO STOP LOOKING
C INITIALLY...
	DO 36 NN=1,MFrm
	DO 36 N=1,8
	KKKKK=-1
36	IFID(N,NN)=KKKKK
C ZERO THE FILE NOW
	NPG=LPGMXF*2
        IF(LPGMXF.LE.(MFro64))GOTO 14
        DO 13 N=1,NPG
13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
14      CONTINUE
	RETURN
	END
c -h- wkdy.for	Fri Aug 22 13:44:33 1986	
	SUBROUTINE WKDY(JULLO,JULHI,NDAYS)
C GIVEN START AND END JULIAN DATE, FIGURE OUT HOW MANY WEEK DAYS
C THERE ARE BETWEEN THEM.
	JL=JULLO
	JH=JULHI
	IF(JL.LE.JH)GOTO 10
	JL=JULHI
	JH=JULLO
10	CONTINUE
	IDL=(JH-JL)/7
C GET NUMBER OF WEEKS BETWEEN DAYS, 5 WORKDAYS PER WHOLE WEEK.
	IWDY=IDL*5
C ADD 3 SO THAT MODULO OF SUNDAY IS 0, NOT WED.
	IDOR=JH-JL-7*(IDL)
	IF(IDOR.NE.0)IDOR=5
C IDOR IS ORIGINAL # DAYS DIFFERENCE, CORRECTED FOR WHOLE
C WEEKS ALREADY ALLOWED.
	LD=JL+3
	LD=MOD(LD,7)
	LH=JH+3
	LH=MOD(LH,7)
C NOW HAVE DAY OF WEEK START,END. FIND WORK DAYS THAT WEEK (M-F ONLY)
	IKLU=0
	IK2=1
	IF(LD.LT.1)IK2=0
	IF(LD.LT.1)LD=1
	IF(LD.GT.5)LD=5
C FOR HIGH END OF RANGE IF THE END DATE IS SUNDAY SUBTRACT ONE DAY
C FROM THE DAYS SO WE OMIT THE MONDAY FROM THE RANGE...
	IF(LH.LT.1)IKLU=IK2
	IF(LH.LT.1)LH=1
	IF(LH.GT.5)LH=5
C LH = DAY ENDED ON, LD=START DAY, FORCED INTO WORK WEEK.
	IF (LH.GT.LD)IWDY=IWDY+LH-LD-IKLU
	IF (LH.LE.LD)IWDY=IWDY+IDOR-(LD-LH)-IKLU
C GIVES DAYS BETWEEN 2 DATES JUST LIKE JULIAN DATE SUBTRACTION FOR
C CALENDAR DATES.
	NDAYS=IWDY
	RETURN
	END
c -h- wrkint.for	Fri Aug 22 13:44:46 1986	
	SUBROUTINE WRKINT(JULLO,NWDY,JULHI)
C GETS JULLO = START DATE AND NWDY = NO. WORKDAYS (M-F) TO ADD AND
C FINDS JULHI = END JULIAN DATE, CONSTRAINED TO BE IN MONDAY TO
C FRIDAY RANGE.
C MUST ADD 3 BECAUSE THAT'S THE BIAS OF OUR JULIAN DATE BASE.
	IDJL=MOD(JULLO+3,7)
C IDJL = DAY CODE OF START DATE
	NWWK=NWDY/5
	JL=JULLO
	IF(IDJL.LT.1)JL=JL+1
	IF(IDJL.GT.5)JL=JL+2
C BUMP START INTERVAL...
	NWDD=NWDY-5*NWWK
	JL=JL+NWWK*7+NWDD
	IDJL=MOD(JL+3,7)
	IF(IDJL.LT.1)JL=JL+1
	IF(IDJL.GT.5)JL=JL+2
C FORCE OUTPUT DATE TO BE WITHIN WORKWEEK
	JULHI=JL
	RETURN
	END
C ****************** AnalyTZ.Ftn ########################################3
c -h- test.for	Fri Aug 22 13:35:58 1986	
	SUBROUTINE TEST(LOGTYP,FLAG,V1,V2)
	InTeGer*4 FLAG
	REAL*8 V1,V2
	FLAG=0
	IF(LOGTYP.EQ.1.AND.V1.GT.V2)FLAG=1
	IF(LOGTYP.EQ.2.AND.V1.LT.V2)FLAG=1
	IF(LOGTYP.EQ.3.AND.V1.EQ.V2)FLAG=1
	IF(LOGTYP.EQ.4.AND.V1.NE.V2)FLAG=1
	IF(LOGTYP.EQ.5.AND.V1.GE.V2)FLAG=1
	IF(LOGTYP.EQ.6.AND.V1.LE.V2)FLAG=1
C TEST LOGICAL RELATIONS FOR IF STATEMENT, FLAG=1 IF TRUE, 0 ELSE.
	RETURN
	END
c -h- ttydei.for	Fri Aug 22 13:35:58 1986	
	SUBROUTINE TTYDEI
	INCLUDE DOS.INC
	INTEGER *4 MODE
	Integer*4 Amiga
	External Amiga
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	COMMON/CONSFH/FH
	If (FH.ne.0)Call Amiga(Close,FH)
	RETURN
	END
c -h- ttyini.for	Fri Aug 22 13:35:58 1986	
	SUBROUTINE TTYINI
C PERFORM INITS ON UNIT 5. NORMALLY EITHER DO NOTHING OR
C REPLACE WITH SOMETHING THAT WORKS FOR YOUR SYSTEM. TYPICAL
C ACTIONS:
C  SET THE TERMINAL NOT TO WRAP AROUND
C  ATTACH TERMINAL SO TYPE-AHEAD WORKS
C  SET UP TERMINAL TO MUNGE AROUND THE ESCAPE SEQUENCES TO ALLOW
C  SPECIAL FUNCTION AND/OR ARROW KEYS TO WORK.
C ULTIMATELY USE WRITE OF UNIT 0 TO DUMP OUT SOME USEFUL ESCAPE SEQS.
C TO DEFINE FUNCTION KEYS A LA VT100 (SORT OF).
	INCLUDE DOS.INC
	CHARACTER*40 NAME
	INTEGER *4 MODE
	Integer*4 Amiga
	External Amiga
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	Integer*4 IDSPTP,Idol9
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9
C ***<<< RDD COMMON END >>>***
CCC	COMMON/CONSFH/FH
c Resize initial windows so all fit on NON interlace screen
	If(IDSPTP.NE.1)NAME=
     1  "RAW:0/0/639/199/AnalytiCalc-AMIGA" // CHAR(0)
	IF(IDSPTP.EQ.1)NAME=
     1  "RAW:0/0/639/399/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)
	Include AParms.Inc
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(IMP1S),FV2(IMP1S),FV4(IMP1S)
	CHARACTER*1 FVXX(IMPs3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
	EQUIVALENCE (FV4(1),FVXX(Imp3s))
        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(IMP1S)
        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,MRows)
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
	Include AParms.inc
        CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
	CHARACTER*1 FVXX(Imps3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
	EQUIVALENCE (FV4(1),FVXX(Imp3s))
        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(IMP1S)
        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,MRows)
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
	Include AParms.Inc
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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)
	call vget(ijunk,2)
c	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)
	call vget(ijunk,2)
c	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)
	Include AParms.inc
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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)*MCols+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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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
	Character*127 cwrk
	Character*2 crlf
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
	crlf=char(13)//char(10)
	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
c	Rewind 11
	call vwrt(star1,1)
c	WRITE (11,103) STAR1
c	Rewind 11
103	FORMAT (1X,A1)
	RETURN
110	STAR1=CHAR(ICHAR(STAR1)+32)
c	Rewind 11
	Call vwrt('^' // star1,2)
c	WRITE (11,112) STAR1
c	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
c	Rewind 11
	write(cwrk,dform,err=10000)real
	call vwrt(crlf,2)
	call vwrt(cwrk,len(cwrk))
c	WRITE (11,DFORM,ERR=10000) REAL
c	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
c	Rewind 11
	write(cwrk,310,err=10000)sign(isv),eight
	call vwrt(crlf,2)
	Call vwrt(cwrk,len(cwrk))
c	WRITE (11,310,ERR=10000) SIGN(ISV), EIGHT
c	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
c	Rewind 11
	Write(cwrk,410,err=10000)int
	call vwrt(crlf,2)
	call vwrt(cwrk,len(cwrk))
c	WRITE (11,410,ERR=10000) INT
c	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
c	Rewind 11
	write(cwrk,820,err=10000)sign(isv),levin
	call vwrt(crlf,2)
	call vwrt(cwrk,len(cwrk))
c	WRITE (11,820,ERR=10000) SIGN(ISV), LEVIN
c	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
c	Rewind 11
	write(cwrk,910,err=10000)real
	call vwrt(crlf,2)
	call vwrt(cwrk,len(cwrk))
c	WRITE (11,910,ERR=10000) REAL
c	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
	Include Aparms.Inc
	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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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,MRows)
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,MFrm)
	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,MFrm)
	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=(MFrm+31)/64
C	LLL=(LPGMXF)/IBF
C	LLL=LPGMXF
C IPM IS NO. PAGES MAX IN FILS
C 1024 bytes holds 64 entries at 16 bytes each
C (user specifies file in K)
C handle in 1024 units since we have 2 buffers
	IPM=LPGMXF*64/(MFrmo2)
C EACH BUFFER HAS 16KB (if mfrm=2048) 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,(MFrm-1))
	JHASH=MOD(IHASH,(MFrmo2))
C	JHASH=IMASK(IHASH,1023)
C	JHASH=MOD(IHASH,2048)
	IF(LPGMOD.NE.0)GOTO 5305
C	IPAG=(IHASH/2048)+1
	IPAG=(IHASH/(MFrmo2))+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=(MFrmo2)
C BASE IS HASFWAY ALONG FILE...
	GOTO 1400
854	CONTINUE
C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
C MFLAST will be either 1 or 2; following logic swaps them.
	MFLAST=3-MFLAST
	MFBASE=(MFrmo2)-MFBASE
C SIMILAR LOGIC SAYS MFBAS4E IS EITHER 0 OR MFrmo2. 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.(MFro64))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+(MFro64)-1
	WRITE(7,REC=N,ERR=1170)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+(MFro64)
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+(MFro64)-1
	READ(7,REC=N,ERR=1171)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+(MFro64)
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,(MFrmo2)
c	N=MOD((NN+JHASH-1),(MFrmo2))
	N=MOD((NN+JHASH),(MFrmo2))
	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))
C for the moment leave this in. LAter remove and change to 10
C bytes formula, 4 bytes cell ID.
	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,MCols)+1
	ICUSED=((NRC-IRUSED+1)/MCols)+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=(MFro64)
C	IBF=(2048+31)/32/2
C	LLL=(LPGMXF*2)/IBF
C	IPM=LLL
	IPM=LPGMXF*64/MFrmo2
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,(MFrmo2))
	IF(LPGMOD.NE.0)GOTO 5307
	IPAG=(IHASH/(MFrmo2))+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=(MFrmo2)
C BASE IS HASFWAY ALONG FILE...
	GOTO 2400
954	CONTINUE
C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
	MFLAST=3-MFLAST
	MFBASE=(MFrmo2)-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.(MFro64))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+(MFro64)-1
	WRITE(7,REC=N,ERR=2170)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+(MFro64)
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+(MFro64)-1
	READ(7,REC=N,ERR=2171)((IFID(K,KK),K=1,8),KK=L,LL)
	L=L+(MFro64)
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,(MFrmo2)
	N=MOD((NN+JHASH),(MFrmo2))+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,(MFrmo2)
	N=MOD((NN+JHASH),(MFrmo2))+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)
	Include AParms.Inc
        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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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(IMP1S),FV2(Imp1s),FV4(Imp1s)
	CHARACTER*1 FVXX(Imps3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
	EQUIVALENCE (FV4(1),FVXX(Imp3s))
        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(Imp1s),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,MRows)
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,MVal)
        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=(MVal/100)
C ibf = blk factor
C	IBF=(800+49)/50/2
C	IF(IBF.LT.1)IBF=1
C
	LLL=(IPGMAX*2)/IBF
	IPM=LLL
	IF(IPM.LE.2)IPM=2
	IHASH=ID
        JHASH=MOD(IHASH,(MVlov2))+1
	IF(IPGMOD.NE.0)GOTO 3402
        IPAG=(IHASH/(MVlov2))+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=(MVlov2)
	GOTO 1000
852	CONTINUE
	MVLAST=1
	MVBASE=0
	GOTO 1000
853	CONTINUE
C SWITCH BUFFER USED LEAST RECENTLY
	MVLAST=3-MVLAST
	MVBASE=MVlov2-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.(MVal/100))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+(MVlo16)-1
        WRITE(13,REC=N,ERR=500)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
        L=L+(MVlo16)
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+(MVlo16)-1
        READ(13,REC=N,END=501,ERR=501)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
        L=L+(MVlo16)
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,(MVlov2)
	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.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
	Include AParms.Inc
        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,IDSPTP,IDOL9,
     3  k3dfg,kcdelt,krdelt,kpag
c	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
c     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(Imp1s),FV2(Imp1s),FV4(Imp1s)
	CHARACTER*1 FVXX(IMPS3)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
	EQUIVALENCE (FV4(1),FVXX(Imp3s))
        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(Imp1s)
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,MRows)
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,MVal)
        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=(MVal+99)/100
C	IBF=(800+49)/50/2
C	IF(IBF.LT.1)IBF=1
	LLL=IPGMAX*2/ibf
C 4000 BYTES PER BUFFER (400 CELLS AT 10 PER CELL)
C	LLL=(IPGMAX*2)/IBF
	IPM=LLL
	IF(IPM.LE.2)IPM=2
	IHASH=ID
        JHASH=MOD(IHASH,(MVlov2))+1
	IF(IPGMOD.NE.0)GOTO 3400
C SPACE-OPTIMIZING PACKING
        IPAG=(IHASH/(MVlov2))+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=(MVlov2)
	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=MVlov2-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.
c
	IF(IPGMAX.LE.IBF)GOTO 1000
c
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+(MVlo16)-1
        WRITE(13,REC=N,ERR=500)((LVALBF(KK,K),KK=1,5),K=L,LLL)
        L=L+(MVlo16)
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+(MVlo16)-1
        READ(13,REC=N,END=501,ERR=501)((LVALBF(KK,K),KK=1,5),K=L,LLL)
        L=L+(MVlo16)
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,(MVlov2)
	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.0D0)RETURN
        IH1=JHASH-1
        DO 2 MMN=JHASH,(MVlov2)
	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)=Char(0)
C ZERO OUT ACCUMULATORS
	DO 1 I=1,27
	DO 1 J=1,20
1	AVBLS(J,I)=Char(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.Char(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.0D0)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
