c -h- analy.for	Fri Aug 22 12:54:45 1986	
       PROGRAM ANALY(INPUT=15,OUTPUT=16,TAPE=17,ERR=1)
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 PARAMETER 18060=60*301
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
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
	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(2264),FV2(2264),FV4(2264)
	CHARACTER*1 FVXX(6792)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
	EQUIVALENCE (FV4(1),FVXX(4529))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
	InTeGer*2 IFID(8,2048)
	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,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 >>>***
	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(2264)
	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.
	FH=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.')
	Write(*,6403)
6403	Format(' Requires 640 by 400 Workbench screen (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)
	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
	READ(ILL,3006,END=5600,ERR=5600)(FORM2(K),K=1,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
	CLOSE(11)
	OPEN(11,FILE='CON:50/150/300/40/Analy Command',STATUS='OLD',
     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
	WRITE(11,998)
998	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
C	InTeGer*4 MFID(2),MFMOD(2)
	InTeGer*2 IFID(8,2048)
	COMMON/IFIDC/IFID
	CHARACTER*1 LFID(16,2048)
	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
	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
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.
	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.
	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
C	COMMON/KLVL/KLVL
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON /DIGV/ DIGITS
	COMMON/ITERA/ITCNTV
C
	DATA  WHAT/'?'/, STAR/'*'/, QUOTE/''''/
	DATA ONCE/0/
C
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)WRITE(11,22)
22	FORMAT(' CALC>')
C
C
	LLLV=LEVEL
	IF(LLLV.EQ.1)LLLV=11
	rewind 11
	READ (LLLV,24,END=900,ERR=1000) LINE
	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
	rewind 11
	IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
     1 WRITE(11,40)LEVEL,(LINE(I),I=1,LEND)
	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
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
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='DK:AKA.CMD',EXIST=LEXIST)
	If(Lexist)UseDF=1
	IF(Lexist)UseDK=1
	Inquire(File='AKA.CMD',Exist=Lexist)
	If(Lexist)UseDF=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
	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)
	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
	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
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)
	IF(VIEWSW.NE.0)WRITE(11,34) BASED
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
	Rewind 11
	WRITE(11,116)
	Rewind 11
	GOTO 118
116	FORMAT(' CALR>',$)
117	Continue
	Rewind 11
	WRITE (11,119) LEVEL
	Rewind 11
119	FORMAT (' CALC<',I1,'>',$)
118	Continue
c	Rewind 11
	READ (11,115,END=1000,ERR=990) LINE
	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.
	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
	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,60)
	LRW=MIN0(LRW,301)
	KK=LCL
	KKK=LRW
	GOTO 216
218	CONTINUE
	rewind 11
	IF(LEVEL.EQ.1)WRITE(11,211)
211	FORMAT(' SET PHYS LOC. COLUMN=')
	rewind 11
	LLLV=LEVEL
	IF(LEVEL.EQ.1)LLLV=11
	READ(LLLV,212,END=700,ERR=700)KK
212	FORMAT(I7)
	rewind 11
	IF(LEVEL.EQ.1)WRITE(11,213)
213	FORMAT(' SET PHYS LOC. ROW =')
	rewind 11
	READ(LLLV,212,END=700,ERR=700)KKK
	rewind 11
	KKK=KKK+1
216	KK=MAX0(1,KK)
	KKK=MAX0(1,KKK)
	KK=MIN0(60,KK)
	KKK=MIN0(301,KKK)
C CLAMP TO LEGAL SIZE
	PROW=KK
	PCOL=KKK
C
	RETURN
C TERMINAL READ ERROR AND END PROCESSING
700	CONTINUE
	IF(LEVEL.EQ.1)CLOSE(11)
	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,60)
	LRW=MIN0(LRW,301)
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
