c -h- declr.for	Fri Aug 22 13:02:54 1986	
	SUBROUTINE DECLR(ITYP,RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *       SUBROUTINE  DECLR (ITYP,RETCD)           *
C *                                                *
C **************************************************
C
C
C ANALYZES VECTOR LINE TO DETERMINE WHAT VARIABLES GET THEIR
C TYPES CHANGED. THE NEW TYPE IS SPECIFIED AS AN ARGUMENT IN
C THE CALL:
C
C
C  TYPE CODE
C	1  ASCII
C	2  DECIMAL (REAL BUT DECIMAL POINT FOR OUTPUT)
C	3  HEXADECIMAL
C	4  INTEGER
C	5  MULTIPLE PRECISION (BASE 10)
C	6  MULTIPLE PRECISION (BASE 8)
C	7  MULTIPLE PRECISION (BASE 16)
C	8  OCTAL
C	9  REAL
C
C  IF NEGATIVE, TYPE IS DEFINED BUT VARIABLE HAS
C  NOT BEEN ASSIGNED A VALUE
C
C
C  RETCD     MEANING
C  1    =    O.K.
C  2    =    ERROR
C
C  NOTE:  AS IN FORTRAN, VARIABLES IN DECLARATIONS MUST BE SEPARATED
C         BY COMMAS
C
C
C  MODIFICATION CLASSES: M1, M2
C
C
C
C
C DECLR CALLS:
C
C  ERRMSG   PRINTS ERROR MESSAGES
C
C
C
C DECLR IS CALLED BY CMND, THE ROUTINE THAT DECODES COMMANDS.
C
C
C
C
C       VARIABLE        USE
C
C    ALPHA           LIST OF LEGAL VARIABLE NAMES. THE FIRST 26 ARE
C                    ALPHABETIC, THE 27TH IS THE CHARACTER '%'.
C    BLANK           ' '
C    I,I2,I3         TEMPORARY VALUES.
C    ITYP            CODE THAT GIVES THE TYPE OF VARIABLE FOR A
C                    PARTICULAR CALL TO THIS ROUTINE. VARIABLES ARE
C                    EITHER DECLARED TO BE OF THIS TYPE OR, IF NO
C                    VARIABLES ARE SPECIFIED, A LIST OF ALL THE
C                    VARIABLES OF THAT TYPE ARE GIVEN.
C    LEND            LAST NON-BLANK IN VECTOR LINE(80).
C    LINE(80)        HOLDS INPUT COMMAND LINE. IF DECLARATION HAS
C                    NO ARGUMENT, THIS VECTOR IS THEN USED TO OUTPUT
C                    A LIST OF VARIABLES OF THE TYPE SPECIFIED.
C    NONBLK          START SCAN OF VARIABLE LIST.
C    TYPE            HOLDS THE TYPE CODE FOR EACH VARIABLE.
C
C
C
C
C
C
C
C	SUBROUTINE DECLR(ITYP,RETCD)
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4  RETCD,VIEWSW,BASED,VLEN(9)
	InTeGer*4 TYPE(1,1)
	InTeGer*4 I,I2,I3,ITYP
C
	CHARACTER*1  LINE(80),AVBLS(20,27),VBLS(8,1,1)
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
	COMMON  /V/TYPE,AVBLS,VBLS,VLEN
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C
	IF(NONBLK.EQ.LEND)GO TO 500
C
C
C **************************************************
C ****** DECLARE VARIABLES TO BE OF TYPE ITYP ******
C **************************************************
	I2=NONBLK+1
10	CONTINUE
C10	IF (LINE(I2).EQ.BLANK) GOTO 60
C	DO 20 I3=1,26
C	IF (LINE(I2).EQ.ALPHA(I3)) GOTO 30
C20	CONTINUE
C *****&&&&& ADD VARIABLE SIZE SUPPORT - GCE
	CALL VARSCN(LINE,I2,LEND,LSTCHR,ID1,ID2,IVALID)
C VARSCN SEARCHES FOR VALID VARIABLE NAME STRINGS INCLUDING C$+EXPR
C AND R$+EXPR FOR LOC-RELATIVE NAMES IN ABSOLUTE AND C@+N, R@+N FOR RELATIVE
C NAMES IN DISPLAY SYSTEM. IT RETURNS THE ID1, ID2 INDICES FOR
C THE VARIABLES IN VBLS ARRAY AND TYPE ARRAY. FOR SINGLE ALPHAS
C A-Z, ID1 RETURNS 1-26 AND ID2=1. % RETURNS ID1=27, ID2=1.
	IF(IVALID.EQ.0) GOTO 22
C VALID FLAG IS NONZERO IF VARIABLE NAME IS VALID, ELSE 0.
	I2=LSTCHR
C LSTCHR RETURNS LAST CHARACTER OF NAME
	GOTO 30
C
C  ILLEGAL CHARACTER IN DECLARATION'S VARIABLE LIST
22	I=4
C
C
C
C ******* ERROR RETURN *******
25	RETCD=2
	CALL ERRMSG(I)
	RETURN
C
C
C
C
30	CONTINUE
C IF OLD VARIABLE WAS UNDEFINED, MAKE NEW TYPE LESS THAN 0 ALSO.
C THIS ALLOWS ONE TO EXAMINE INTERNAL VALUES FOR DIFFERENT DATA
C TYPES. IF THIS IS NOT NEEDED, IT WOULD BE CLEANER TO ALWAYS MAKE
C VARIABLES UNDEFINED WHEN THEIR DATA TYPE IS CHANGED. TO DO THIS
C JUST USE THE STATEMENT
C	I=-ITYP
	I=ITYP
C ****&&&&&& NOTE TYPE NOW 2-DIM
	CALL TYPGET(ID1,ID2,TYPE(1,1))
	IF(TYPE(1,1).LE.0)I=-I
	CALL TYPSET(ID1,ID2,I)
C	TYPE(ID1,ID2)=I
	I3=I2+1
	IF (I3.GT.LEND) GOTO 1000
	DO 40 I2=I3,LEND
	IF (LINE(I2).EQ.BLANK) GOTO 40
	IF (LINE(I2).EQ.COMMA) GOTO 45
C
C VARIABLES NOT SEPARATED BY COMMAS
	I=5
	GO TO 25
40	CONTINUE
	GOTO 1000
45	IF (I2.EQ.LEND) GOTO 22
60	I2=I2+1
	IF (I2.LE.LEND) GOTO 10
	GO TO 1000
C
C
C
C
C
C
C **********************************************************************
C ** NO ARGUMENTS SO SHOW WHAT VARIABLES HAVE BEEN DECLARED THAT TYPE **
C **********************************************************************
500	CONTINUE
	IF(VIEWSW.EQ.0) GO TO 1000
C PERHAPS THE ABOVE LINE SHOULD BE REMOVED (???)
C
C
C BLANK OUT OUTPUT LINE.
	DO 510 I=1,80
510	LINE(I)=BLANK
C
C
C SEARCH FOR VARIABLES OF TYPE ITYP. PUT THEM IN LINE(I2) WHEN FOUND FOR
C LATER PRINTING.
	I2=0
	DO 550 I=1,27
C FAKE UP DISPLAY
C ****&&&&&
	CALL TYPGET(I,1,TYPE(1,1))
	IF(IABS(TYPE(1,1)).NE.ITYP)GO TO 550
	I2=I2+1
	LINE(I2)=ALPHA(I)
550	CONTINUE
C
C
C GO TO SECTION APPROPRIATE FOR PRINTING EITHER THE LIST OF VARIABLES OR
C A MESSAGE INDICATING THAT NO VARIABLES ARE OF THAT TYPE.
	IF(I2.EQ.0) GO TO 600
C
C
C OUTPUT A LIST OF VARIABLES OF TYPE ITYP
	WRITE(11,560) (LINE(I),I=1,I2)
560	FORMAT(' VARIABLES SO DECLARED = ',30A1)
	GO TO 1000
C
C
C
C
C NO VARIABLES OF THAT TYPE
600	WRITE(11,610)
610	FORMAT(' NO VARIABLES OF THAT TYPE')
C
C
C
C **** NORMAL RETURN ****
1000	RETCD=1
	RETURN
	END
c -h- doentr.for	Fri Aug 22 13:03:06 1986	
	SUBROUTINE DOENTR(FORM,LOW,LHIGH)
C +++++++++++++++++++++++++++++++++++
C PARAMETER 18060=60*301
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
	EXTERNAL INDX
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 ACY
	EQUIVALENCE(ACY,AVBLS(1,27))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	COMMON/FVLDC/FVLD
C +++++++++++++++++++++++++++++++++++
C ENABLE { FORMS TO HANDLE ALL POSSIBLE EQUATIONS.
	CALL FRMEDT(FORM,LLST)
	IITR=0
5050	IITR=IITR+1
	FORM(111)=0
	LCURR=LOW
C DO AN ENTRY. MUST SCAN FOR MULTIPLE STATEMENTS PER LINE AND ALSO
C RECOGNIZE FUNCTION NAMES.
1000	CONTINUE
	KKK=ICHAR('\')
	LSL=INDX(FORM(LCURR),KKK)
	IF(LSL.EQ.0)LSL=LHIGH
C CLAMP AT 80 CHARS LONG INPUT.
	IF(LSL.LE.79)GOTO 1200
C STMT HAS NO MULTIPLES. SQUASH IT TO USE ONLY 1ST PART...
	LSL=79
	LCURR=LHIGH
	FORM(80)=0
1200	CONTINUE
	IF(FORM(LCURR).NE.'<')GOTO 5052
	IF(ACY.GT.0. .AND.
     2  IITR.LT.100)GOTO 5050
C ALLOW IN-FORMULA LOOPING PROVIDED % IS POSITIVE AND
C WITH LIMITED RETRIES...
C AVOID CALLING DOSTMT WITH BOGUS < CHARACTER AS "FORMULA" SO
C WE AVOID ERROR MESSAGES.
	GOTO 5051
5052	CONTINUE
	CALL DOSTMT(FORM(LCURR),LSL)
5051	IF (LCURR.GE.LHIGH)RETURN
	LCURR=LCURR+LSL
	If(Lcurr.lt.Lhigh)GOTO 1000
	Return
	END
c -h- doif.for	Fri Aug 22 13:03:17 1986	
	SUBROUTINE DOIF(LINE,LLB,LRB,LLAST)
C	PARAMETER 1=1,12=12
	EXTERNAL INDX
	CHARACTER*1 LINE(110)
	REAL*8 V1,V2
	V1=0.
	V2=0.
	LS=LRB-LLB+1
	CALL GETLOG(LINE(LLB),LS,LOGTYP,LASST)
	LOV1=LLB
	LHIV1=LASST+LLB-1
	IF(LOV1.GE.LHIV1)GOTO 100
C USE SUM FUNCTION HERE AS TYPE OF FCN
	LT=4
	CALL DOMFCN(LINE,LOV1,LHIV1,LT,V1)
100	CONTINUE
	IF(LOGTYP.EQ.0)GOTO 1000
	LOV2=LASST+2+LLB
	LHIV2=LRB
	IF(LOV2.GE.LHIV2)GOTO 200
	LT=4
	CALL DOMFCN(LINE,LOV2,LHIV2,LT,V2)
200	CONTINUE
	CALL TEST(LOGTYP,LFLAG,V1,V2)
	IF(LFLAG.EQ.0)GOTO 700
C HERE HAVE "TRUE" ALTERNATIVE OF IF STMT
	KKK=ICHAR('|')
	LBAR=INDX(LINE,KKK)
	LBAR=MIN0(LBAR,LLAST)
	LSTM=LRB+1
C LSTM TO LBAR IS NOW THE STMT TO EVALUATE. SINCE WE ALREADY HAVE A
C ROUTINE TO EVALUATE A STMT, DO SO. NOTE PARTIAL RECURSION, SO
C NO NESTED IFS ALLOWED, AND CALL MUST PERMIT RECURSION ON YOUR
C MACHINE OR FORGET IT. (OK ON PDP11, VAX).
	LSZ=LBAR-LSTM
	IF(LSZ.LT.1)GOTO 1000
	LSZ=LSZ+1
	CALL DOSTMI(LINE(LSTM),LSZ)
	GOTO 1000
700	CONTINUE
C HERE HAVE "FALSE" ALTERNATIVE OF IF STMT
	KKK=ICHAR('|')
	LBAR=INDX(LINE,KKK)+1
	LBAR=MIN0(LBAR,LLAST)
	LSZ=LLAST-LBAR
	IF(LSZ.LT.1)GOTO 1000
	LSZ=LSZ+1
	CALL DOSTMI(LINE(LBAR),LSZ)
1000	CONTINUE
C THAT'S ALL.
	RETURN
	END
c -h- domath.fms	Fri Aug 22 13:03:28 1986	
	SUBROUTINE DOMATH(INDEXF,VAR,AC,SS,CTR,ACX)
C COPYRIGHT (C) 1985, 1986 GLENN C.EVERHART
C ALL RIGHTS RESERVED
C	EXTERNAL INDX
	REAL*8 AC,SS,CTR,ACX,RWRK1,RWRK2
	DIMENSION EP(20)
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
CCC	REAL*8 EP,PV,FV
CCC	COMMON/ERNPER/EP,PV,FV,KIRR
	REAL*8 VAR,TE
	INTEGER*4 IWRK1,IWRK2,IDUM
	LOGICAL*4 LWRK1,LWRK2,LWRK3
	INTEGER*4 IWRK3
	EQUIVALENCE(IWRK1,LWRK1),(IWRK2,LWRK2),(IWRK3,LWRK3)
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,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
CCC	REAL*8 AACP,AACQ
CCC	InTeGer*4 KLKC,KLKR
CCC	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	IF(INDEXF.NE.1)GOTO 100
C MIN
	IF(VAR.GE.AC)GOTO 105
	AC=VAR
	AACP=KLKC
	AACQ=KLKR
105	CONTINUE
	ACX=AC
	RETURN
100	IF(INDEXF.NE.2)GOTO 200
C MAX
	IF(VAR.LE.AC)GOTO 107
	AC=VAR
	AACP=KLKC
	AACQ=KLKR
107	CONTINUE
C	IF(VAR.GT.AC)AC=VAR
	ACX=AC
	RETURN
200	IF(INDEXF.NE.3)GOTO 300
C AVG
	AC=AC+VAR
	CTR=CTR+1.
	ACX=AC/CTR
	RETURN
300	IF(INDEXF.NE.4)GOTO 400
C SUM
	AC=AC+VAR
	ACX=AC
	RETURN
400	IF(INDEXF.NE.5)GOTO 500
C STD (STANDARD DEVIATION SQUARED)
	AC=AC+VAR
	SS=SS+(VAR*VAR)
	CTR=CTR+1.
	ACX=(SS-((AC*AC)/CTR))/CTR
	RETURN
500	CONTINUE
	IF(INDEXF.NE.7)GOTO 600
C AND
	IF(SS.NE.0.)IWRK1=AC
	IF(SS.EQ.0.)IWRK1=VAR
	SS=1.
	IWRK2=VAR
	LWRK1=LWRK1.AND.LWRK2
	AC=IWRK1
	ACX=AC
	RETURN
600	IF(INDEXF.NE.8)GOTO 700
C INCLUSIVE OR
	IWRK1=AC
	IWRK2=VAR
	LWRK1=LWRK1.OR.LWRK2
	AC=IWRK1
	ACX=AC
	RETURN
700	IF (INDEXF.NE.9)GOTO 800
C NOT
	IWRK1=VAR
	LWRK1=.NOT.LWRK1
	AC=IWRK1
	ACX=AC
	RETURN
800	IF(INDEXF.NE.10)GOTO 1000
C CNT
C COUNT NONZERO ENTRIES
	IF(VAR.NE.0.)AC=AC+1.
	ACX=AC
	RETURN
1000	CONTINUE
	IF(INDEXF.NE.11)GOTO 1100
C NPV
	IF(SS.EQ.0.)GOTO 1050
	CTR=CTR+1.
C	AC=AC+VAR*CTR/SS
	AC=AC+VAR/(SS**(CTR-1))
	ACX=AC
	RETURN
C	GOTO 1200
1050	CONTINUE
	SS=VAR+1.
	ACX=0.
	RETURN
1100	if(indexf.ne.12) GOTO 1200
C LKP
	IF(SS.NE.0.)GOTO 1150
	SS=1.
	AC=VAR
	ACX=-1.
	RETURN
C	GOTO 1200
1150	CONTINUE
C	IF(VAR.GE.AC.AND.ACX.LT.0.)ACX=CTR
	IF(VAR.LT.AC.OR.ACX.GE.0.)GOTO 1155
	ACX=CTR
	AACP=KLKC
	AACQ=KLKR
1155	CONTINUE
	CTR=CTR+1.
	RETURN
1200	CONTINUE
	IF(INDEXF.NE.13)GOTO 1300
C LKN
	IF(SS.NE.0.)GOTO 1250
	SS=1.
	AC=VAR
	ACX=-1.
	GOTO 1300
1250	CONTINUE
C	IF(VAR.LE.AC.AND.ACX.LT.0.)ACX=CTR
	IF(VAR.GT.AC.OR.ACX.GT.0.)GOTO 1256
	ACX=CTR
	AACP=KLKC
	AACQ=KLKR
1256	CONTINUE
	CTR=CTR+1.
	RETURN
1300	CONTINUE
	IF(INDEXF.NE.14)GOTO 1400
C LKE
	IF(SS.NE.0.)GOTO 1350
	SS=1.
	AC=VAR
	ACX=-1.
	GOTO 1400
1350	CONTINUE
C	IF(VAR.EQ.AC.AND.ACX.LT.0.)ACX=CTR
	IF(VAR.NE.AC.OR.ACX.GE.0.)GOTO 1355
	ACX=CTR
	AACP=KLKC
	AACQ=KLKR
1355	CONTINUE
	CTR=CTR+1.
	RETURN
1400	CONTINUE
	IF(INDEXF.NE.15)GOTO 1500
C XOR
	IF(SS.NE.0)IWRK1=AC
	IF(SS.EQ.0)IWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1405
	IWRK2=VAR
	LWRK3=LWRK1.OR.LWRK2
	LWRK1=LWRK1.AND.LWRK2
	IWRK1=IWRK3-IWRK1
1405	AC=IWRK1
	ACX=AC
	RETURN
1500	CONTINUE
	IF(INDEXF.NE.16)GOTO 1600
C EQV
C NOTE THE EQUIVALENCE FUNCTION IS JUST THE COMPLEMENT OF
C THE XOR FUNCTION. DO THE COMPLEMENT VIA THE .NOT. OPERATOR.
	IF(SS.NE.0)IWRK1=AC
	IF(SS.EQ.0)IWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1505
	IWRK2=VAR
	LWRK3=LWRK1.OR.LWRK2
	LWRK1=LWRK1.AND.LWRK2
	IWRK1=IWRK3-IWRK1
	LWRK1=.NOT.LWRK1
1505	AC=IWRK1
	ACX=AC
	RETURN
1600	CONTINUE
	IF(INDEXF.NE.17)GOTO 1700
C MOD
C MODULO (V1 MOD V2)
	IF(SS.NE.0)RWRK1=AC
	IF(SS.EQ.0)RWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1605
	RWRK2=VAR
	RWRK1=DMOD(RWRK1,RWRK2)
1605	AC=RWRK1
	ACX=AC
	RETURN
1700	CONTINUE
	IF(INDEXF.NE.18)GOTO 1800
C REMAINDER -- INTEGER MODULO
	IF(SS.NE.0)IWRK1=AC
	IF(SS.EQ.0)IWRK1=VAR
	SS=SS+1.
	IF(SS.EQ.1.)GOTO 1705
	IWRK2=VAR
	IWRK1=JMOD(IWRK1,IWRK2)
1705	AC=IWRK1
	ACX=AC
	RETURN
1800	CONTINUE
	IF(INDEXF.NE.19)GOTO 1900
C SGN
C RETURN 1.0 * SIGN OF ARGUMENT.
	AC=DSIGN(1.0D0,VAR)
	ACX=AC
	RETURN
1900	CONTINUE
	IF(INDEXF.NE.20)GOTO 2000
C IRR - INTERNAL RATE OF RETURN
	AC=0.
	ACX=0.
	IF(KIRR.LT.20)KIRR=KIRR+1
	IF(KIRR.EQ.1)PV=VAR
	IF(KIRR.EQ.2)FV=VAR
	IF(KIRR.LT.3)RETURN
C IRRPV,FV,RETURNS...
	IWRK1=KIRR-2
	EP(IWRK1)=VAR
	RWRK1=.15
	RWRK2=.25
C ITERATIVELY SOLVE FOR INTERNAL RATE OF RETURN.
1903	TE=0.
	SS=FV/((1.D0+RWRK1)**(IWRK1))
	DO 1905 IWRK2=1,IWRK1
	AC=EP(IWRK2)/((1.D0+RWRK1)**IWRK2)
	SS=SS+AC
1905	CONTINUE
	RWRK2=RWRK1*(SS+TE)/PV
	IF(DABS(RWRK1-RWRK2).LT..00001)GOTO 1910
	RWRK1=RWRK2
	GOTO 1903
1910	CONTINUE
	AC=RWRK2
	ACX=AC
	RETURN
2000	CONTINUE
	IF(INDEXF.NE.21)GOTO 2100
C RND[] - RANDOM NUMBER RETURN
	AC=RND(IDUM)
	ACX=AC
	RETURN
2100	CONTINUE
   	IF(INDEXF.NE.22)GOTO 2200
C PMT FUNCTION
C PMT[PRINCIPAL, INTEREST, NPERIODS] ARE ARGS
C PAYMENT (MORTGAGE PAYMENT PER PERIOD
C COMPUTED AS PAYMENT=PRINCIPAL*(INTEREST/(1-(1+INTEREST)**NPERIODS))
C (CORRECT EVEN IF INTEREST=0
C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
	AC=0.
	ACX=0.
	KIRR=KIRR+1
	EP(KIRR)=VAR
	IF(KIRR.LT.3)RETURN
C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
	AC=EP(1)*(EP(2)/(1.-((1.+EP(2))**(-EP(3)))))
	ACX=AC
	RETURN
2200	CONTINUE
	IF(INDEXF.NE.23)GOTO 2300
C PVL FUNCTION
C PVL[PAYMENT,INTEREST,NPERIODS] ARE ARGS
C PRESENT VALUE COMPUTED AS
C PV=PAYMENT*(1.-(1.+INTEREST)**-NPERIODS)/INTEREST
C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
	AC=0.
	ACX=0.
	KIRR=KIRR+1
	EP(KIRR)=VAR
	IF(KIRR.LT.3)RETURN
C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
	AC=EP(1)*EP(3)
	IF(EP(3).EQ.0..OR.EP(2).EQ.0.)GOTO 2205
	AC=EP(1)*((1.-(1.+EP(2))**(-EP(3)))/EP(2))
2205	ACX=AC
	RETURN
2300	CONTINUE
	IF(INDEXF.NE.24)GOTO 2400
C AVE AVERAGE EXCLUDING ZERO CELLS
	IF(VAR.EQ.0.)GOTO 2305
	AC=AC+VAR
	CTR=CTR+1.
2305	ACX=AC/DMAX1(CTR,1.0D0)
	RETURN
2400	CONTINUE
	IF(INDEXF.NE.25)GOTO 2500
C CHS
C CHOOSE FROM ARGS USING 1ST ARG AS COUNT INTO RANGE...
C (SIMILAR TO CLASSICAL "CHOOSE" FUNCTION...)
C RETURNS 0.0 OR VALUE OF NTH ARG WHERE N IS INDEX OF ARG...
C	IF(KIRR.EQ.0)ACX=0.
	KIRR=KIRR+1
	IF(KIRR.EQ.1)IWRK1=VAR+1.
	IF(KIRR.NE.IWRK1)GOTO 2450
C SAVE LOCATION ALSO OF CELLS.
C THIS ALLOWS US TO FIND ADDRESSES OF SELECTED CELLS IN CHOOSE FOR ADDRESS MATH.
	AACP=KLKC
	AACQ=KLKR
	SS=VAR
2450	CONTINUE
	ACX=SS
	AC=ACX
	RETURN
2500	CONTINUE
	IF(INDEXF.NE.26)GOTO 2600
C ATM ARCTAN OF 2 ARGS
	IF(SS.NE.0.)RWRK1=AC
	IF(SS.EQ.0.)RWRK1=VAR
	SS=SS+1.
	IF(SS.LE.1.1)GOTO 2505
	RWRK2=VAR
C GET 4 QUADRANT ARCTAN
	RWRK1=DATAN2(RWRK1,RWRK2)
2505	AC=RWRK1
	ACX=AC
	RETURN
2600	CONTINUE
	RETURN
	END
c -h- domfcn.for	Fri Aug 22 13:03:40 1986	
	SUBROUTINE DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
C LLB = LOC OF
C LRB = LOC OF
C INDEXF IS AS ABOVE. GUARANTEED IN RANGE 1-5.
	CHARACTER*1 LINE(110)
C +++++++++++++++++++++++++++++++++++
C PARAMETER 18060=60*301
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	EXTERNAL INDX
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
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
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	REAL*8 XXX
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	REAL*8 ACX,ACY
	REAL*8 AC,SS,CTR
	EQUIVALENCE(ACY,AVBLS(1,27))
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	CHARACTER*1 ILINE(106)
	InTeGer*4 ILNFG,ILNCT
	COMMON/ILN/ILNFG,ILNCT,ILINE
	COMMON/FVLDC/FVLD
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,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
CCC	InTeGer*4 KLKC,KLKR
	REAL*8 ACP,ACQ
CCC	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	EQUIVALENCE(ACP,AVBLS(1,16)),(ACQ,AVBLS(1,17))
C +++++++++++++++++++++++++++++++++++
C
C FIRST GET A VARIABLE NAME. ALL MATH FUNCTIONS REQUIRE VARIABLE
C NAMES SINCE THEIR VARIABLES ARE THEIR ONLY VALID ARGS.
	CALL MTHINI(INDEXF,AC,SS,CTR,ACX)
C SET UP PROPER INITS
C KV2=1 IF A 2ND VBL EXISTS
	LCR=LLB+1
	AACP=ACP
	AACQ=ACQ
C INIT SAVED P, Q AC'S HERE IN CASE DOMATH MODIFIES...
C THIS ALLOWS SELECTION FUNCTIONS TO SET COL, ROW IN P AND Q AC.
100	CONTINUE
	KV2=0
	LB=LCR
	LE=LRB-1
	IF(LB.GE.LE)RETURN
	CALL VARSCN(LINE,LB,LE,LASST,ID1,ID2,IVALID)
	IF(IVALID.EQ.0)RETURN
	IF(LINE(LASST).NE.':')GOTO 110
	LB=LASST+1
	LE=LRB-1
	CALL VARSCN(LINE,LB,LE,LASST,ID1B,ID2B,IVALID)
	IF(IVALID.NE.0)KV2=1
110	CONTINUE
	CALL XVBLGT(ID1,ID2,XVBLS(1,1))
	XXX=XVBLS(1,1)
C	XXX=XVBLS(ID1,ID2)
	CALL TYPGET(ID1,ID2,TYPE(1,1))
C USE EQUIVALENCE OF JVBLS AND XVBLS
	IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
	KLKC=ID1
	KLKR=ID2-1
	CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
	IF(KV2.EQ.0)GOTO 200
	IF(ID1.NE.ID1B) GOTO 120
	IF(ID2.GT.ID2B)GOTO 200
	M=ID2+1
	DO 121 MM=M,ID2B
	CALL XVBLGT(ID1,MM,XVBLS(1,1))
	XXX=XVBLS(1,1)
	CALL TYPGET(ID1,MM,TYPE(1,1))
C	XXX=XVBLS(ID1,MM)
	IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
	KLKC=ID1
	KLKR=MM-1
	CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
121	CONTINUE
	GOTO 200
120	CONTINUE
	IF(ID2.NE.ID2B)GOTO 130
	IF(ID1.GT.ID1B)GOTO 200
	M=ID1+1
	DO 131 MM=M,ID1B
	CALL XVBLGT(MM,ID2,XVBLS(1,1))
	XXX=XVBLS(1,1)
C	XXX=XVBLS(MM,ID2)
	CALL TYPGET(MM,ID2,TYPE(1,1))
	IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
	KLKC=MM
	KLKR=ID2-1
	CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
131	CONTINUE
130	CONTINUE
200	CONTINUE
C IF NEXT CHAR IS A COMMA, SKIP IT AND KEEP UP SCAN UNLESS DONE
	IF(LINE(LASST).EQ.',')GOTO 300
	ACP=AACP
	ACQ=AACQ
C USE P, Q ACCUMULATORS FOR SELECTED COL, ROW COORDS FROM DOMATH
	RETURN
300	LCR=LASST+1
	GOTO 100
	END
c -h- dostmi.for	Fri Aug 22 13:03:55 1986	
	SUBROUTINE DOSTMI(LINE,LLAST)
C COPY OF DOSTMT FOR IF FUNCTION.
C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
	CHARACTER*1 LINE(110)
C +++++++++++++++++++++++++++++++++++
C PARAMETER 18060=60*301
	EXTERNAL INDX
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
	COMMON/FVLDC/FVLD
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.

	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	REAL*8 ACX,ACY,AACY
	INTEGER*4 IACY,IIJACY
	EQUIVALENCE(IIJACY,AACY)
	EQUIVALENCE(IACY,AVBLS(1,27))
	EQUIVALENCE(ACY,AVBLS(1,27))
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	CHARACTER*1 ILINE(106)
	InTeGer*4 ILNFG,ILNCT
	COMMON/ILN/ILNFG,ILNCT,ILINE
C +++++++++++++++++++++++++++++++++++
	CALL FNAME(LINE,LLAST,INDEXF)
C ABOVE GETS FUNCTION NAMES.
C	NAME	INDEXF
C	MIN	1
C	MAX	2
C	AVG	3
C	SUM	4
C	STD	5	(STD DEVIATION)
C	IF	6	(IF STMT)
C	AND	7
C	OR	8
C	NOT	9
C	CNT	10 (COUNTS NONZERO ENTRIES)
C	NPV	11 NET PRESENT VALUE
C	LKP	12 LOOKUP IN LIST, GIVE OFFSET 0 BASED
C	LKN	13	LOOKUP NEGATIVE (INVERSE OF LKP)
C	LKE	14	LOOKUP EQUAL
C	XOR	15	EXCLUSIVE OR
C	EQV	16	EQUIVALENCE (TRUE IF BITS EQUAL)
C	MOD	17	V1 MODULO V2
C	REM	18	REMAINDER OF V1/V2
C	SGN	19	SIGN OF V1 (-1.,0., OR +1.)
C	IRR	20	INTERNAL RATE OF RETURN
C USE  AND  TO DELIMIT FUNCTION ARGS.
C *****************************************************************************
C **** NOTE: MAX 20 IS KEPT AS A LITERAL IN NEXTEL ALSO AS FLAG THAT FUNCTION
C **** FAILED TO FIND VALID LITERAL. CHANGE THERE TOO IF YOU ADD MORE FUNCTIONS.
	IF(INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 1000
C HERE IF A FUNCTION OR AN IF STMT (FORMAT= IF varRELvarstmt|else-stmt)
C
C ALLOW CALC TO HANDLE ALL BUT IF STMTS
	IF(INDEXF.NE.6)GOTO 1000
C
C **** FIXUP '' NEXT. 2 LINES. REPLACE HERE... ***
	KKK=ICHAR('[')
	LLB=INDX(LINE,KKK)
	KKK=ICHAR(']')
	LRB=INDX(LINE,KKK)
C *** ERROR WITH FORMAT -- NO  SEEN IN TIME. JUST IGNORE IT.
	IF(LLB.GT.LLAST)RETURN
	IF(LRB.GT.LLAST)LRB=LLAST
C ** COMMENT OUT NEVER-USED CODE NEXT AREA...
C
C	IF(INDEXF.EQ.6)GOTO 2000
CC ISOLATE MATH FUNCTIONS
C	CALL DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
CC GET % ABOVE
C	CALL TYPGET(KDRW,KDCL,TYPE(1,1))
C	IF(IABS(TYPE(1,1)).NE.2)GOTO 1760
C	CALL XVBLST(KDRW,KDCL,ACX)
CC	XVBLS(KDRW,KDCL)=ACX
CC LEAVE RESULT IN % TOO.
C	ACY=ACX
C	CALL TYPSET(27,1,TYPE(1,1))
CC	TYPE(27,1)=TYPE(KDRW,KDCL)
C	RETURN
C1760	JVBLS(1,1,1)=ACX
C	CALL JVBLST(1,KDRW,KDCL,JVBLS(1,1,1))
CC	JVBLS(1,KDRW,KDCL)=ACX
C	RETURN
2000	CONTINUE
C HANDLE AN "IF" STATEMENT
C ILLEGAL HERE INSIDE AN IF, SO JUST IGNORE IT.
C	CALL DOIF(LINE,LLB,LRB,LLAST)
C PASS LLAST TO DOIF SINCE WE DON'T EXPECT ] AS LAST CHAR OF STMT.
C NO DIRECT SET OF VRBL HERE...
	RETURN
1000	CONTINUE
C HERE JUST HAVE SOMETHING TO PASS TO CALC. DO SO.
	ILNFG=1
	LMX=LLAST-1
	DO 1001 N1=1,LMX
1001	ILINE(N1)=LINE(N1)
	ILNCT=LMX
C PROTECT CALC FROM ANY PART OF A LINE LONGER THAN 80 CHARS (ITS MAX)
	IF(ILNCT.GT.80)ILNCT=80
	CALL CALC
C STORE EXPRESSION RESULT.
C CONVERT BETWEEN TYPES FIRST IF NEED BE
	CALL TYPGET(KDRW,KDCL,LMX)
	CALL TYPGET(27,1,N1)
	LMX=IABS(LMX)
	N1=IABS(N1)
	IF(N1.EQ.1.OR.(N1.GE.3.AND.N1.LE.8))GOTO 8739
	N1=2
	GOTO 8740
8739	CONTINUE
	N1=4
8740	CONTINUE
C ONLY CONCERN HERE IS REAL TYPES (CODE=2) AND INT TYPES (CODE=4)
	AACY=ACY
	IF(N1.EQ.LMX)GOTO 2670
	IF(N1.EQ.2)IIJACY=ACY
	IF(N1.EQ.4)AACY=IACY
C DO WHICHEVER CONVERSION IS NEEDED IF ONE IS NEEDED AT ALL.
2670	CONTINUE
	CALL XVBLST(KDRW,KDCL,AACY)
C	XVBLS(KDRW,KDCL)=ACY
	RETURN
	END
c -h- dostmt.for	Fri Aug 22 13:03:55 1986	
	SUBROUTINE DOSTMT(LINE,LLAST)
C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
	CHARACTER*1 LINE(110)
C +++++++++++++++++++++++++++++++++++
C PARAMETER 18060=60*301
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	EXTERNAL INDX
	INTEGER*4 VNLT
	DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
	COMMON/FVLDC/FVLD
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	REAL*8 XVBLS(1,1)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	INTEGER*4 JVBLS(2,1,1)
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	REAL*8 ACX,ACY,AACY
	INTEGER*4 IACY,IIJACY
	EQUIVALENCE(IACY,AVBLS(1,27))
	EQUIVALENCE(ACY,AVBLS(1,27))
	EQUIVALENCE(IIJACY,AACY)
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	CHARACTER*1 ILINE(106)
	InTeGer*4 ILNFG,ILNCT
	COMMON/ILN/ILNFG,ILNCT,ILINE

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

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

c of symbol table
	IF(INLIN(I1+1).NE.'*')GOTO 5600
	IF(NAMMAX.LE.0)GOTO 5600
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
C ERASE LINE
	CALL VWRT('Output File:',12)
	read(11,5602,end=5419,err=5419)(wrk1(II),II=1,80)
5602	format(80a1)
	DO 5603 N=1,79
	NN=80-N
	IF(JCHAR(WRK1(NN)).GT.32)GOTO 5604
	WRK1(NN)=Char(0)
5603	CONTINUE
5604	CONTINUE
	close(8)
	CALL WASSIG(8,WRK1)
C OPEN OUTPUT FOR WRITE
C THEN DUMP SYMBOLS THERE
C SYMBOL TABLE DUMP CAN BE SAVED ANYWHERE AND REENTERED AS
C ASSIGNMENT STMTS.
	WRK1(1)='{'
	DO 5607 N=2,110
5607	WRK1(N)=0
	WRK1(18)='='
	DO 5605 N=1,NAMMAX
	IF(NAMNUM(9,N)+NAMNUM(10,N).LE.0)GOTO 5605
	DO 5608 NN=1,16
5608	WRK1(NN+1)=NAMARY(NN,N)
	CALL IN2AS(KK,WRK1(19))
	NAMNUM(9,N)=KK
	WRITE(WRK13(1:3),5606,ERR=5419)NAMNUM(10,N)-1
C	ENCODE(3,5606,WRK1(23))NAMNUM(10,N)-1
5606	FORMAT(I3)
	K=3
	WRK2(1)='T'
	WRK2(2)='E'
	WRK2(3)=' '
	DO 5609 KK=1,106
	I4=JCHAR(WRK1(KK))
	IF(I4.LE.32)GOTO 5609
	K=K+1
	WRK2(K)=CHAR(I4)
5609	CONTINUE
C WRITE OUT DEFINITIONS AS IF THEY WERE ASSIGMNENT STMTS.
	WRITE(8,5610)(WRK2(KK),KK=1,K)
5610	FORMAT(110A1)
5605	CONTINUE
	CLOSE(8)
	GOTO 5419
5600	CONTINUE
	LO=I2+1
	IHI=LO+25
	CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
C IF IVLD=0 ASSUME WE'RE UNDEFINING THE SYMBOL
	IF(IVLD.GT.0)GOTO 5402
C INVALID SYMBOL. UNDEFINE THE STRING.
	DO 5403 I4=1,NAMMAX
	DO 5404 I5=1,I3
C REQUIRE WHOLE STRING FOR SEARCH.
	IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5403
5404	CONTINUE
C GOT IT IF WE FALL THRU
	NAMNUM(9,I4)=0
	NAMNUM(10,I4)=0
C ZERO THE ELEMENT DEFINITION AND FORGET IT...
	DO 5432 I5=1,16
5432	NAMARY(I5,I4)=Char(0)
5403	CONTINUE
	GOTO 5419
5402	CONTINUE
C VALID ARRAY ELEMENT, DEFINE IT.
	IF(NAMMAX.LE.0)GOTO 5406
	DO 5405 I4=1,NAMMAX
	IF(NAMNUM(9,I4)+NAMNUM(10,I4).EQ.0)GOTO 5410
5405	CONTINUE
	GOTO 5406
5410	CONTINUE
C GOT IT IF WE FALL THRU
	NAMNUM(9,I4)=ID1
	NAMNUM(10,I4)=ID2
C ZERO THE ELEMENT DEFINITION AND FORGET IT...
	GOTO 5407
5406	CONTINUE
	IF(NAMMAX.LT.0)NAMMAX=0
	NAMMAX=MIN0(NAMMAX+1,301)
	NAMNUM(9,NAMMAX)=ID1
	NAMNUM(10,NAMMAX)=ID2
C NOW SAVE THE SYMBOL NAME
	I4=NAMMAX
5407	CONTINUE
	DO 5409 I5=1,16
5409	NAMARY(I5,I4)=0
	DO 5408 I5=1,I3
	NAMARY(I5,I4)=INLIN(I1+I5)
5408	CONTINUE
C NO FURTHER PROCESSING IF WE DID ANY DEFINITION... JUST EXIT
5419	CONTINUE
	INLIN(1)='%'
C IF A DEFINITION, JUST PUT SOMETHING INNOCUOUS INTO LINE FOR
C LATER PROCESSING.
	DO 5421 I5=2,110
5421	INLIN(I5)=0
	RETURN
5400	CONTINUE
C NOW THAT DEFINITIONS ARE TAKEN CARE OF (IF ANY)
C HANDLE SYMBOLIC SEARCHES
	if(nammax.le.0)goto 5505
	LSTCHR=I1+1
	DO 5501 I4=1,NAMMAX
	DO 5502 I5=1,16
	IF(JCHAR(NAMARY(I5,I4)).LE.47)GOTO 5502
	IF(JCHAR(INLIN(I1+I5)).LE.47)GOTO 5502
	LSTCHR=I1+I5+1
	IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5501
CC SKIP OUT IF WE HAVE A TERMINATING CHARACTER IN DEF
CC AND HAD AT LEAST 1 NONTERMINATING CHAR IN DEFINITION.
C	IF(JCHAR(NAMARY(1,I4)).GT.47.AND.
C     1     JCHAR(NAMARY(I5,I4)).LE.47) GOTO 5560
5502	CONTINUE
5560	CONTINUE
C IF WE FALL THRU WE HAVE A MATCH
	ID1=NAMNUM(9,I4)
	ID2=NAMNUM(10,I4)
C LAST CHECK: BE SURE WE AREN'T GIVING A DELETED SYMBOL.
	IF((ID1+ID2).GT.0)GOTO 5500
5501	CONTINUE
5505	continue
	LO=I1+1
	IHI=LO+25
	CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
	IF(IVLD.LE.0)RETURN
5500	CONTINUE
	DO 11 N1=1,120
11	WRK1(N1)=0
C HERE HAVE A VALID CONSTRUCT SO REPLACE IT
C (ONLY ONE PER LINE THIS TIME ROUND)
C	IRX=(ID2-1)*60+ID1
	CALL REFLEC(ID2,ID1,IRX)
C COPY FIRST PART OF FORMULA TO WORK ARRAY
	LO=I1-1
	IHI=0
	IF(LO.LE.0)GOTO 10
	DO 1 N1=1,LO
	IHI=N1
	WRK1(IHI)=INLIN(N1)
1	CONTINUE
10	CONTINUE
	IHI=IHI+1
	CALL WRKFIL(IRX,WRK2,0)
C WRKFIL READS THE FORMULA INTO WRK2. NEXT FIND END OF TEXT
	DO 2 N1=1,110
	LO=111-N1
	IF(ICHAR(WRK2(LO)).GT.32)GOTO 3
2	CONTINUE
3	CONTINUE
C LO NOW IS LENGTH OF FORMULA
	DO 4 N1=1,LO
	WRK1(IHI)=WRK2(N1)
	IF(IHI.LT.110)IHI=IHI+1
4	CONTINUE
C TACK ON ANY MORE TEXT
C RELY ON INLIN BEING 110 CHARS LONG
	DO 5 N1=LSTCHR,110
	WRK1(IHI)=INLIN(N1)
	IF(IHI.LT.110)IHI=IHI+1
5	CONTINUE
C NOW COPY 110 CHARS BACK TO INLIN
	DO 6 N1=1,110
6	INLIN(N1)=WRK1(N1)
	DO 7 N1=1,110
	LO=111-N1
	IF(ICHAR(INLIN(LO)).GT.32)GOTO 8
C	INLIN(LO)=CHAR(32)
7	CONTINUE
8	LEND=LO
	LCNT=LCNT+1
	GOTO 1000
C KEEP LOOKING & RECURSING BUT IMPOSE LIMIT
C	RETURN
	END
c -h- fvldgt.for	Fri Aug 22 13:10:38 1986	
        SUBROUTINE FVLDGT(ID1,ID2,IVAL)
C
C FVLDGT - RETURN FVLD BYTE GIVEN 2 DIMS OF ITS "LOCATION"
        InTeGer*4 ID1,ID2
        CHARACTER*1 IVAL
C NEXT BITMAPS IMPLEMENT FVLD
	EXTERNAL INDX
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
        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
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
        CHARACTER*1 ITYP(2264)
        InTeGer*4 IATYP(27)
        COMMON/TYP/IATYP,ITYP
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,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
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
C
C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
C AREAS WITH DATA.
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
CCC        CHARACTER*1 FMTDAT(9,76)
CCC        COMMON/FMTBFR/FMTDAT
        CHARACTER*1 I1,I2,I4
	CHARACTER*1 IT1,IT2,IT4,IT8
	LOGICAL*4 LT1,LT2,LT4,LT8
	InTeGer*4 KT1,KT2,KT4,KT8
	CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
       EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
     1(LT8,IT82(1))
       EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
     1 (KT8,IT82(1))
C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
C ORDER BYTE WITH EQUIVALENCES
	EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
     1 (IT82(2),IT8)
	IF(ID2.GT.0)GOTO 2000
C TRICK ENTRY USING ID IN FIRST ARG, 0 IN 2ND ARG...
C TELL XVBLST/XVBLGT ABOUT FV4 STATE (SET BY CALL WITH -4 BYTE ON FVLDST)
	ID=ID1
        IBT=((ID-1)/8)+1
	KT1=ID-1
	KT2=7
	KT1=IMASK(KT1,KT2)
C	LT1=LT1.AND.LT2
	IBIT=KT1+1
C        IBIT=((ID-1).AND.7)+1
C        I1=FV1(IBT).AND.LBITS(IBIT)
C        I2=FV2(IBT).AND.LBITS(IBIT)
C        I4=FV4(IBT).AND.LBITS(IBIT)
	KT1=ICHAR(FV1(IBT))
	KT2=ICHAR(FV2(IBT))
	KT4=ICHAR(FV4(IBT))
	KT8=ICHAR(LBITS(IBIT))
	KT1=IMASK(KT1,KT8)
C	LT1=LT1.AND.LT8
	KT2=IMASK(KT2,KT8)
C	LT2=LT2.AND.LT8
	KT4=IMASK(KT4,KT8)
C	LT4=LT4.AND.LT8
	I1=CHAR(KT1)
	I2=CHAR(KT2)
	I4=CHAR(KT4)
	IVAL=0
C RETURN NONZERO IF ANY BITS ARE SET.
	IF((KT1+KT2+KT4).NE.0)IVAL=1
C	IF((I1+I2+I4).NE.0)IVAL=1
	RETURN
2000	CONTINUE
C REFLECT ALL BACK TO PRIME STORAGE REGION
C        ID=(ID2-1)*60+ID1
	IF(ID2.EQ.1.AND.ID1.LE.18060)GOTO 7806
	CALL REFLEC(ID2,ID1,ID)
	GOTO 7807
7806	CONTINUE
	ID=ID1
7807    IBT=((ID-1)/8)+1
	KT1=ID-1
	KT2=7
	KT1=IMASK(KT1,KT2)
C	LT1=LT1.AND.LT2
	IBIT=KT1+1
C        IBIT=((ID-1).AND.7)+1
C        I1=FV1(IBT).AND.LBITS(IBIT)
C        I2=FV2(IBT).AND.LBITS(IBIT)
C        I4=FV4(IBT).AND.LBITS(IBIT)
	KT1=ICHAR(FV1(IBT))
	KT2=ICHAR(FV2(IBT))
	KT4=ICHAR(FV4(IBT))
	KT8=ICHAR(LBITS(IBIT))
C	LT1=LT1.AND.LT8
C	LT2=LT2.AND.LT8
C	LT4=LT4.AND.LT8
	KT1=IMASK(KT1,KT8)
	KT2=IMASK(KT2,KT8)
	KT4=IMASK(KT4,KT8)
C	I1=CHAR(KT1)
C	I2=CHAR(KT2)
C	I4=CHAR(KT4)
        IVL=0
        IF(KT1.NE.0)IVL=1
        IF(KT2.NE.0)IVL=IVL+2
        IF(KT4.NE.0)IVL=-IVL
        IVAL=CHAR(IVL)
C READS OFF FVLD BYTE FROM 3 BITS, HIGH ONE IS SIGN. TREAT AS SIGN-
C MAGNITUDE NUMBER IN RANGE -3 TO +3,
        RETURN
        END
c -h- fvldst.for	Fri Aug 22 13:10:51 1986	
        SUBROUTINE FVLDST(ID1,ID2,IVAL)
C
C FVLDST - SET THE BYTE IN FVLD ARRAY
C NEXT BITMAPS IMPLEMENT FVLD
        CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
	CHARACTER*1 FVXX(6792)
	EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
	EQUIVALENCE (FV4(1),FVXX(4529))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
        CHARACTER*1 IVAL
        CHARACTER*1 LBITS(8)
	EXTERNAL INDX
        COMMON/BITS/LBITS
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
        CHARACTER*1 ITYP(2264)
        InTeGer*4 IATYP(27)
        COMMON/TYP/IATYP,ITYP
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,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
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
C
C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
C AREAS WITH DATA.
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
CCC        CHARACTER*1 FMTDAT(9,76)
	InTeGer*4 IVV,I1,I2,I3,ITA
	LOGICAL*4 L2,L1,LVV,LTA
	EQUIVALENCE(L2,I2),(L1,I1),(LVV,IVV)
	EQUIVALENCE(LTA,ITA)
CCC        COMMON/FMTBFR/FMTDAT
	CHARACTER*1 IT1,IT2,IT4,IT8
	LOGICAL*4 LT1,LT2,LT4,LT8
	InTeGer*4 KT1,KT2,KT4,KT8,KW1,KW2
	CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
	EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
     1  (LT8,IT82(1))
	EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
     1  (KT8,IT82(1))
C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
C ORDER BYTE WITH EQUIVALENCES
C	EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
C     1  (IT82(2),IT8)
C        CHARACTER*1 I4
	IF(ID2.EQ.1.AND.ID1.LE.18060)GOTO 7806
C ALLOW DELIBERATE CALL WITH EFFECTIVELY ONE ARG.
7807	CALL REFLEC(ID2,ID1,ID)
	GOTO 7808
7806	CONTINUE
C        ID=(ID2-1)*60+ID1
	ID=ID1
7808    IBT=((ID-1)/8)+1
	KT1=ID-1
	KT2=7
	KT1=IMASK(KT1,KT2)
C	LT1=LT1.AND.LT2
	IBIT=KT1+1
C        IBIT=((ID-1).AND.7)+1
C ZERO ALL 3 FVLD BITS FIRST
C        FV1(IBT)=FV1(IBT).AND..NOT.LBITS(IBIT)
C        FV2(IBT)=FV2(IBT).AND..NOT.LBITS(IBIT)
C        FV4(IBT)=FV4(IBT).AND..NOT.LBITS(IBIT)
	KT1=ICHAR(FV1(IBT))
	KT2=ICHAR(FV2(IBT))
	KT4=ICHAR(FV4(IBT))
	KT8=ICHAR(LBITS(IBIT))
	ITA=-KT8-1
C ITA IS NOW THE COMPLEMENT OF KT8
C THUS, THE SELECTED BIT IS OFF IN IT, ALL OTHERS ON.
C	LT1=LT1.AND.LTA
C	LT2=LT2.AND.LTA
C	LT4=LT4.AND.LTA
	KT1=IMASK(KT1,ITA)
	KT2=IMASK(KT2,ITA)
	KT4=IMASK(KT4,ITA)
C FILL IN ALL 3 BITMAPS WITH THEIR PREVIOUS CONTENTS EXCEPT THE
C CHOSEN BITS.
	FV1(IBT)=CHAR(KT1)
	FV2(IBT)=CHAR(KT2)
	FV4(IBT)=CHAR(KT4)
	IVVV=JCHAR(IVAL)
        IVV=IABS(IVVV)
        I3=0
        IF(IVVV.LT.0)I3=1
C	I1=1
C	I2=2
	KW2=2
	KW1=1
	I2=IMASK(IVV,KW2)
	I1=IMASK(IVV,KW1)
C        L2=LVV.AND.L2
C        L1=LVV.AND.L1
C NOTE WE ASSUME HEAVILY THAT LOGICAL OPERATIONS WORK BY BINARY
C ANDS AND ORS IN DATA.
C ** NOTE WE DON'T NEED TO RELOAD THE KT1 THRU KT4 INTEGERS... ALL ALREADY
C ARE LOADED... DITTO KT8
C	KT1=ICHAR(FV1(IBT))
C	KT2=ICHAR(FV2(IBT))
C	KT4=ICHAR(FV4(IBT))
C	KT8=ICHAR(LBITS(IBIT))
	LT1=LT1.OR.LT8
	LT2=LT2.OR.LT8
	LT4=LT4.OR.LT8
C        IF(I1.NE.0)FV1(IBT)=FV1(IBT).OR.LBITS(IBIT)
C        IF(I2.NE.0)FV2(IBT)=FV2(IBT).OR.LBITS(IBIT)
C        IF(I3.NE.0)FV4(IBT)=FV4(IBT).OR.LBITS(IBIT)
        IF(I1.NE.0)FV1(IBT)=CHAR(KT1)
        IF(I2.NE.0)FV2(IBT)=CHAR(KT2)
        IF(I3.NE.0)FV4(IBT)=CHAR(KT4)
        RETURN
        END
c -h- fvpeek.fms	Fri Aug 22 13:11:27 1986	
C DUMMY FVPEEK
	SUBROUTINE FVPEEK(ID1,ID2,IGO)
	InTeGer*4 ID1,ID2,IGO
	IGO=ID1
	RETURN
	END
c -h- getfnl.for	Fri Aug 22 13:12:09 1986	
	SUBROUTINE GETFNL(LINE,LSKP,LLEN)
C PARSE OUT FILENAME AND GET LSKP, LLEN NUMBERS
	EXTERNAL INDX
	CHARACTER*1 LINE(80)
	InTeGer*4 LSKP,LLEN,LO,HI
	LSKP=0
	LLEN=32000
C SET INITIAL NUMBERS TO READ WHOLE FILE
	KKK=ICHAR(',')
	N=INDX(LINE,KKK)
	IF(N.LE.0.OR.N.GT.78)RETURN
C IF CANNOT FIND COMMA, JUST SKIP OUT & TRY TO CATCH ERRORS ON OPEN.
	LINE(N)=0
C NULL TERMINATE FILENAME
	LO=N+1
	HI=LO+20
	CALL GN(LO,HI,LSKP,LINE)
	LO=N+1
	KKK=ICHAR(',')
	N=INDX(LINE(LO),KKK)
	IF(N.LE.0.OR.N.GT.30)RETURN
	LO=LO+N
	HI=LO+20
	CALL GN(LO,HI,LLEN,LINE)
C SHOULD HAVE NUMBERS NOW
	RETURN
	END
c -h- getlog.for	Fri Aug 22 13:12:16 1986	
	SUBROUTINE GETLOG(LINE,LMX,LOGTYP,LASST)
	CHARACTER*1 LINE(110)
	EXTERNAL INDX
	CHARACTER*1 LFN(4,6)
	CHARACTER*4 XLF(6)
	INTEGER*4 LF(6)
	EQUIVALENCE(XLF(1)(1:1),LF(1),LFN(1,1))
C	EQUIVALENCE(LF(1),LFN(1,1))
	DATA XLF/'.GT.','.LT.','.EQ.','.NE.','.GE.','.LE.'/
C LOGTYP RELATIONSHIP TO RELATIONSHIPS OF 2 VARIABLES
C IS DEFINED IN ABOVE DATA STMT.
C IF LINE CONTAINS STRING IN NAME, RETURN TYPE AND END LOC.
	LMX4=LMX-3
	DO 100 LL=1,6
	LOGTYP=LL
	DO 1 N1=1,LMX4
	IF(LINE(N1  ).NE.LFN(1,LL))GOTO 2
	IF(LINE(N1+1).NE.LFN(2,LL))GOTO 2
	IF(LINE(N1+2).NE.LFN(3,LL))GOTO 2
	IF(LINE(N1+3).NE.LFN(4,LL))GOTO 2
C HERE HAVE A MATCH
	LASST=N1
C RETURN LOC OF NEXT CHAR AFTER RELATION.
	GOTO 200
2	CONTINUE
1	CONTINUE
100	CONTINUE
	LOGTYP=0
200	CONTINUE
	RETURN
	END
c -h- getnnb.for	Fri Aug 22 13:13:44 1986	
	SUBROUTINE GETNNB(IPT,RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************

C *                                                *
C *         SUBROUTINE GETNNB(IPT,RETCD)           *
C *                                                *
C **************************************************
C
C
C  GET NEXT NON-BLANK ELEMENT FROM LINE STARTING AT NONBLK+1
C
C  RETCD =  1   O.K.
C	    2   NO NON-BLANK FOUND
C
C  IPT POINTS TO POSITION IN LINE WHERE NEXT NON-BLANK IS FOUND.
C  IT IS UP TO CALLING PROGRAM TO RESET NONBLK FOR NEXT SCAN.
C
C
C
C GETNNB IS CALLED BY
C
C AT
C BASCNG
C CMND
C NEXTEL
C STRCMP
C
C
C   VARIABLE    USE
C
C    BLANK      ' '
C    IPT        RETURNS POSITION OF NEXT NON-BLANK.
C    K          HOLDS TEMPORARY VALUES.
C    LEND       LAST NON-BLANK IN LINE(80).
C    NONBLK     HOLDS CHARACTER TO LEFT OF THE START OF THE SCAN.
C    RETCD      HOLDS THE RETURN CODE. 1=O.K.  2=THE REST IS BLANKS.
C
C
C	SUBROUTINE GETNNB(IPT,RETCD)
C
C
	InTeGer*4 IPT
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 VIEWSW,BASED,BASE,RETCD
	InTeGer*4 K
C
	CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
	RETCD=1
	IF (NONBLK.GE.LEND) GOTO 999
C
C AT LEAST 1 NON-BLANK EXISTS.
	K=NONBLK+1
	DO 10 IPT=K,LEND
	IF (LINE(IPT).NE.BLANK) GOTO 1000
10	CONTINUE
C
C
C ACTUALLY, SHOULD NEVER FALL THROUGH IF 'LEND' IS SET CORRECTLY.
C
C
C THE REST ARE BLANKS
999	RETCD=2
1000	RETURN
	END
c -h- getttl.for	Fri Aug 22 13:14:41 1986	
	SUBROUTINE GETTTL(LINE)
	CHARACTER*1 LINE(132)
	CHARACTER*3 FNAME
	CHARACTER*1 FN(3)
	EQUIVALENCE (FN(1),FNAME(1:1))
	InTeGer*4 IBBX
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,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
CCC	COMMON/MODPUB/MODPUB,LIMODE
C MODPUB = MODE USED IN CMD MODE GTMODE ROUTINE
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
CCC	InTeGer*4 LLCMD,LLDSP
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C LIMODE IS WHAT GETS SET UP IN /# CMND
	IBBX=0
C
C
C
C
C CODE FOR FORTRAN READ...
C  **** HERE IS THE SECTION OF CODE YOU NEED FOR NON-VMS-SPECIFIC VERSION
C NOTE READS UNIT 0 TO GET CONSOLE.
C CHECK THAT WE'RE READING CONSOLE. IF LUN 5 IS OFF CONSOLE, THEN
C READ USING DIRECT DOS CALLS.
C  IF (STILL) IN AN INITIALIZER FILE, READ USING REGULAR FORTRAN READS
C AND ACT NORMALLY.
C  DISCOVER CONSOLE BECAUSE FILENAME IS 'CON:' OR 'CON'.
CC	INQUIRE(UNIT=5,NAME=FNAME)
CC	IF (FN(1).NE.'C'.OR.FN(2).NE.'O'.OR.FN(3).NE.'N')
CC     1 GOTO 5000
C CALL ASSEMBLER ROUTINE TO GET CHARACTERS.
	DO 5001 N=1,132
5001	LINE(N)=CHAR(0)
C FIX IT UP SO A NULL LINE LOOKS HARMLESS...
	LINE(1)=' '
C NULL THE LINE FIRST IN FORTRAN; MAKES IT EASIER TO DO ASSEMBLER STUFF.
	CALL TTYIN(MODPUB,LINE)
	IF(LINE(1).NE.'/')GOTO 5540
C DISPLAY HELP MSG AT BOTTOM
	IF(MODPUB.EQ.0)GOTO 5540
C ONLY DISPLAY IF IN "AUTOENTER" MODE
c	CALL UVT100(1,LLDSP,1)
c	CALL SWRT('Add,Cpy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set',46)
c	CALL SWRT(',Tst,View,Wrt,Xit,Zap,/,Help',28)
c	CALL UVT100(1,LLCMD,11)
C CALL TTYIN NEXT WITH 0 SO / ISN'T TERMINATOR.
c	N=0
C	CALL TTYIN(N,LINE(2))
5540	CONTINUE
	IF(ICHAR(LINE(1)).EQ.26)
     1  GOTO 2000
C Add,Copy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set,Test,View,Wrt,Xit,Zap,Help,/
C READ IN AFTER CLOSE AND RE-OPEN IF WE GET EOF ON INPUT SIGNALLED
C BY CONTROL Z.
C ASSUME WE'LL USE DOS FUNCTION 1 FOR READIN AND ECHO
C AND THEN END THE READIN AFTER FIRST CONTROL SEQUENCE.
C	GOTO 6000
C5000	CONTINUE
C	READ(5,1000,END=2000,ERR=2000)LINE
1000	FORMAT(132A1)
6000	CONTINUE
CC	IF(ICHAR(LINE(1)).NE.0)RETURN
CCC IF WE GET 0 MAYBE IT'S AN EXTENDED CODE. TRY RETURNING A HASHED
CCC VALUE HERE. USE __{CELL WHERE CELL IS A FOLLOWED BY (B+CODE) WHERE
CC CODE IS THE VALUE RETURNED...
CC	LINE(5)=CHAR(ICHAR(LINE(2))+66-59)
CC EXTENDED CODES WE CARE ABOUT START AT 59.
CC MAP INTO EXTENDED AC'S STARTING AT AB SINCE AA IS THE SAME AS % ACCUMULATOR
CC WHICH CAN'T BE REASSIGNED THIS WAY.
C	LINE(5)=CHAR(ICHAR(LINE(2))+7)
C	LINE(1)='_'
C	LINE(2)='_'
C	LINE(3)='{'
C	LINE(4)='A'
C
C WE SHOULD "KNOW" COORDS HERE DESIRED...
C THEY RUN FROM B TO Z...IMPLYING ID1=28 THRU 53
CC	II=ICHAR(LINE(5))-66+28
C	II=ICHAR(LINE(5))-38
C SCREEN OUT EXTRA JUNK THAT WOULD COME FROM HIGH FUNCT CODES...
C (DON'T BOTHER MAPPING A<Z+1> TO BA AND SO ON... ONLY 6
C KEYS IN USABLE RANGE ANYHOW...
C	IF(II.GT.52)GOTO 1200
C	III=1
C	CALL FVLDGT(II,III,IBBX)
C	IF(IBBX.EQ.0)GOTO 1200
C SKIP OVER CELLS THAT ARE EMPTY.
C
C NULL OUT REMAINDER OF THE LINE TO AVOID CONFUSION HERE.
C NOTE WE ONLY DO THIS WHERE WE SAW AN INITIAL NULL INDICATING AN
C EXTENDED FUNCTION INPUT.
C	IBBX=6
C	GOTO 1201
C1200	IBBX=1
C1201	CONTINUE
C	DO 1100 N=IBBX,132
C1100	LINE(N)=CHAR(0)
	RETURN
2000	CONTINUE
c	CLOSE(18)
	IOLVL=11
c	OPEN(18,FILE='CON:20/40/150/150/Analy Command Input')
	CLOSE(3)
CC RETRY A READ AFTER EOF...
Cc try a write to 5 to see if that'll reset the file
	Rewind 11
	write(11,4002)
4002	format(' *eof*')
	Rewind 11
	READ(11,1000,END=4000,ERR=4000)LINE
	rewind 11
	RETURN
4000	CONTINUE
CC IF WE KEEP GETTING ERRORS, JUST QUIT.
CC AT LEAST STAY AROUND. USER CAN DO @\DEV\CON
CC TO PARTLY RECOVER...
C	STOP
C TRY TO RESET TTY EOF
C *********
	RETURN
	END
c -h- gmadd.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMADD(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
C MODIFIED FOR PCCPC
C      SUBROUTINE GMADD(A,B,R,N,M)
       REAL*8 A,B,R
       DIMENSION A(1),B(1),R(1)
C      NM=N*M
	IAB=(IA2-1)*60+IA1-1
	IBB=(IB2-1)*60+IB1-1
	IRB=(IR2-1)*60+IR1-1
      DO 10 I=1,N
      DO 10 J=1,M
	IJ=(I-1)*60+J
	CALL XVBLGT(IJ+IAB,0,A)
	CALL XVBLGT(IJ+IBB,0,B)
	R(1)=A(1)+B(1)
	CALL XVBLST(IJ+IRB,0,R)
10	CONTINUE
C   10 R(IJ)=A(IJ)+B(IJ)
      RETURN
      END
c -h- gmprd.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMPRD(IA1,IA2,IB1,IB2,IR1,IR2,N,M,L)
C      SUBROUTINE GMPRD(A,B,R,N,M,L)
	REAL*8 A,B,R
        DIMENSION A(1),B(1),R(1)
C SPECIAL MATRIX MULTIPLY WITHIN SPREADSHEET MATRIX
	IAB=(IA2-1)*60+IA1-1
	IBB=(IB2-1)*60+IB1-1
	IRB=(IR2-1)*60+IR1-1
	DO 10 K=1,L
	DO 10 J=1,M
	NL=(J-1)*60+K
	R(1)=0.
	CALL XVBLST(IRB+NL,0,R)
	DO 10 I=1,N
	NM=(J-1)*60+I
	ML=(I-1)*60+K
	CALL XVBLGT(IAB+NM,0,A)
	CALL XVBLGT(IBB+ML,0,B)
	A(1)=A(1)*B(1)
	CALL XVBLGT(IRB+NL,0,R)
	R(1)=R(1)+A(1)
10	CALL XVBLST(IRB+NL,0,R)
C	R(NL)=R(NL)+A(NM)*B(ML)
C10	CONTINUE
      RETURN
      END
c -h- gmsub.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMSUB(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
C      SUBROUTINE GMSUB(A,B,R,N,M)
	REAL*8 A,B,R
	IAB=(IA2-1)*60+IA1-1
	IBB=(IB2-1)*60+IB1-1
	IRB=(IR2-1)*60+IR1-1
C      NM=N*M
      DO 10 I=1,N
      DO 10 J=1,M
      IJ=(I-1)*60+J
	CALL XVBLGT(IAB+IJ,0,A)
	CALL XVBLGT(IBB+IJ,0,B)
	A=A-B
	CALL XVBLST(IRB+IJ,0,A)
10	CONTINUE
C   10 R(IJ)=A(IJ)-B(IJ)
      RETURN
      END
c -h- gmtx.for	Fri Aug 22 13:16:31 1986	
	SUBROUTINE GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
     1  ID2B,RETCD)

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

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

C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
C       DO 80 J=1,M
C       IJ=(I-1)*M+J
C       KJ=(K-1)*N+J
C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
C90       CONTINUE
CC       SUBSTITUTE BACK
CC       NN=(N-1)*N+N
C       NN=N*N
C       DO 110 J=1,M
C       NJ=(N-1)*M+J
C       B(NJ)=B(NJ)/A(NN)
C       I1MAX=N-1
C       IF(I1MAX)110,110,95
C95       DO 111 I1=1,I1MAX
C       I=N-I1
C       IJ=(I-1)*M+J
C       II=(I-1)*N+I
C       I2=I+1
C       DO 100 L=I2,N
C       IL=(I-1)*N+L
C       LJ=(L-1)*M+J
C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
C       B(IJ)=B(IJ)/A(II)
C111       CONTINUE
C110       CONTINUE
C       RETURN
C       END
	INTEGER A1,A2,B1,B2
C       DIMENSION A(1),B(1)
C ALTER DECLARATIONS FOR USE WITH SPREAD SHEET
C NOTE THAT OUR COLUMN DIMENSION IS 60, NOT N OR M HERE
C SUBSCRIPTS ARE (ROW-1)*COL-DIMENSION + COL
C  THEREFORE, CHANGE *N OR *M IN SUBSCRIPT COMPUTATIONS TO
C  *60
	REAL*8 A,B,AW1,AW2,BW1,BW2,AW3,AW4,AMAX
	INTEGER ABASE,BBASE
	ABASE=(A2-1)*60+A1-1
	BBASE=(B2-1)*60+B1-1
	D=1.
       KMAX=N-1
       DO 90 K=1,KMAX
       AMAX=0.
       J2=K
       DO 20 J1=K,N
       IK=(J1-1)*60+K
	CALL XVBLGT(IK+ABASE,0,A)
       IF(DABS(AMAX)-DABS(A))10,20,20
10       AMAX=A
       J2=J1
20       CONTINUE
C       EXCHANGE ROW K,J2 IF NECESSARY
       IF(J2-K)30,60,30
30       DO 40 J=K,N
       J3=(K-1)*60+J
       J4=(J2-1)*60+J
	CALL XVBLGT(J3+ABASE,0,SAVE)
C       SAVE=A(J3)
	CALL XVBLGT(J4+ABASE,0,AW1)
	CALL XVBLST(J3+ABASE,0,AW1)
	CALL XVBLST(J4+ABASE,0,SAVE)
C       A(J3)=A(J4)
C       A(J4)=SAVE
40       CONTINUE
       DO 50 J=1,M
       J3=(K-1)*60+J
       J4=(J2-1)*60+J
C       SAVE=B(J3)
C       B(J3)=B(J4)
C50       B(J4)=SAVE
	CALL XVBLGT(J3+BBASE,0,SAVE)
	CALL XVBLGT(J4+BBASE,0,BW1)
	CALL XVBLST(J3+BBASE,0,BW1)
	CALL XVBLST(J4+BBASE,0,SAVE)
50	CONTINUE
C       REDUCTION
60       K1=K+1
       KK=(K-1)*60+K
	CALL XVBLGT(KK+ABASE,0,A)
	IF(A.EQ.0)GOTO 999
C	IF(A(KK).EQ.0.)GOTO 999
       DO 80 I=K1,N
       IK=(I-1)*60+K
       DO 70 J=K1,N
       IJ=(I-1)*60+J
       KJ=(K-1)*60+J
C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
	CALL XVBLGT(IJ+ABASE,0,AW1)
	CALL XVBLGT(KJ+ABASE,0,AW2)
	CALL XVBLGT(IK+ABASE,0,AW3)
	CALL XVBLGT(KK+ABASE,0,AW4)
	AW1=AW1-AW2*AW3/AW4
	CALL XVBLST(IJ+ABASE,0,AW1)
70	CONTINUE
       DO 80 J=1,M
       IJ=(I-1)*60+J
       KJ=(K-1)*60+J
C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
	CALL XVBLGT(IJ+BBASE,0,BW1)
	CALL XVBLGT(KJ+BBASE,0,BW2)
	BW1=BW1-BW2*AW3/AW4
	CALL XVBLST(IJ+BBASE,0,BW1)
80	CONTINUE
90       CONTINUE
C       SUBSTITUTE BACK
       NN=(N-1)*60+N
C       NN=N*N
	CALL XVBLGT(NN+ABASE,0,AW1)
	IF(AW1.EQ.0.)GOTO 999
       DO 110 J=1,M
       NJ=(N-1)*60+J
C       B(NJ)=B(NJ)/A(NN)
	CALL XVBLGT(NJ+BBASE,0,BW1)
	BW1=BW1/AW1
	CALL XVBLST(NJ+BBASE,0,BW1)
       I1MAX=N-1
       IF(I1MAX)110,110,95
95       DO 111 I1=1,I1MAX
       I=N-I1
       IJ=(I-1)*60+J
       II=(I-1)*60+I
       I2=I+1
	CALL XVBLGT(II+ABASE,0,AW1)
       DO 100 L=I2,N
       IL=(I-1)*60+L
       LJ=(L-1)*60+J
C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
	CALL XVBLGT(IJ+BBASE,0,BW1)
	CALL XVBLGT(IL+ABASE,0,AW2)
	CALL XVBLGT(LJ+BBASE,0,BW2)
	BW1=BW1-AW2*BW2
	CALL XVBLST(IJ+BBASE,0,BW1)
100	CONTINUE
C       B(IJ)=B(IJ)/A(II)
	BW1=BW1/AW1
	CALL XVBLST(IJ+BBASE,0,BW1)
111       CONTINUE
110       CONTINUE
       RETURN
999	CONTINUE
	D=0.
	RETURN
       END
