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

Text File | 1987-11-08 | 115KB | 4,419 lines

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