home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d1xx
/
d144
/
analyticalc.lha
/
AnalytiCalc
/
AnalySources.Arc
/
AnalyAC.Ftn
< prev
next >
Wrap
Text File
|
1988-04-11
|
101KB
|
4,002 lines
c -h- analy.for Fri Aug 22 12:54:45 1986
PROGRAM ANALY(INPUT=15,OUTPUT=16,TAPE=17,ERR=1)
C PORTACALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
C PARAMETER 18060=60*301
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
C
InTeGer*4 PRL(6)
CHARACTER*1 NOWRAP ( 2 )
CHARACTER*1 FORM,FVLD,CMDLIN(132)
INTEGER*4 VNLT
INTEGER IFCW
C EXTERNAL LCWRQQ
DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C
C ***<<<< RDD COMMON START >>>***
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
DIMENSION NRDSP(20,75),NCDSP(20,75)
COMMON/D2R/NRDSP,NCDSP
InTeGer*4 TYPE(1,1),VLEN(9)
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
REAL*8 XXV(1,1)
EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
CHARACTER*1 DVFMT(12),DEFFMT(10)
EQUIVALENCE(DVFMT(2),DEFFMT(1))
CHARACTER*12 CDVFMT
EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
COMMON/DEFVBX/DVFMT
CHARACTER*1 NMSH(80)
CHARACTER*80 NMSH80
EQUIVALENCE(NMSH80(1:1),NMSH(1))
COMMON/NMSH/NMSH
CHARACTER*1 FORM2(4)
C ***<<< XVXTCD COMMON START >>>***
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
InTeGer*4 IPS1,IPS2,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
INTEGER*4 I4TMP
REAL*8 DVS(20,75)
COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
InTeGer*4 QCAC,QCENT(8),ACV(8)
COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
C BITMAP
C CHARACTER*1 IBITMP
C DIMENSION IBITMP(2258)
C COMMON/INITD/IBITMP
C CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
COMMON/DSPCMN/DVS,CWIDS
C character*35 fwt
C COMMONS FROM OTHER MISC. ROUTINES, ADDED TO ALLOW AMIGA FORTRAN TO
C ALLOCATE COMMONS ON STACK...
CHARACTER*1 LBITS(8)
COMMON/BITS/LBITS
CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
COMMON/CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
CHARACTER*1 DTBL1(9,9,8)
COMMON/DECIDE/DTBL1
CHARACTER*1 DIGITS(16,3)
COMMON/DIGV/DIGITS
C ***<<< KLSTO COMMON START >>>***
InTeGer*4 DLFG
C COMMON/DLFG/DLFG
InTeGer*4 KDRW,KDCL
C COMMON/DOT/KDRW,KDCL
InTeGer*4 DTRENA
C COMMON/DTRCMN/DTRENA
REAL*8 EP,PV,FV
DIMENSION EP(20)
INTEGER*4 KIRR
C COMMON/ERNPER/EP,PV,FV,KIRR
InTeGer*4 LASTOP
C COMMON/ERROR/LASTOP
CHARACTER*1 FMTDAT(9,76)
C COMMON/FMTBFR/FMTDAT
CHARACTER*1 EDNAM(16)
C COMMON/EDNAM/EDNAM
InTeGer*4 MFID(2),MFMOD(2)
C COMMON/FRM/MFID,MFMOD
InTeGer*4 JMVFG,JMVOLD
C COMMON/FUBAR/JMVFG,JMVOLD
COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
1 LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
C
C
CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
CHARACTER*1 FVXX(6792)
EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
EQUIVALENCE (FV4(1),FVXX(4529))
Common/FVLDM/FVXX
c COMMON/FVLDM/FV1,FV2,FV4
InTeGer*2 IFID(8,2048)
COMMON/IFIDC/IFID
InTeGer*4 ILNFG,ILNCT
CHARACTER*1 ILINE(106)
COMMON/ILN/ILNFG,ILNCT,ILINE
InTeGer*4 ITCNTV(6)
COMMON/ITERA/ITCNTV
InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
1 MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
C ***<<< NULETC COMMON START >>>***
InTeGer*4 ICREF,IRREF
C COMMON/MIRROR/ICREF,IRREF
InTeGer*4 MODPUB,LIMODE
C COMMON/MODPUB/MODPUB,LIMODE
InTeGer*4 KLKC,KLKR
REAL*8 AACP,AACQ
C COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
InTeGer*4 NCEL,NXINI
C COMMON/NCEL/NCEL,NXINI
CHARACTER*1 NAMARY(20,301)
C COMMON/NMNMNM/NAMARY
InTeGer*4 NULAST,LFVD
C COMMON/NULXXX/NULAST,LFVD
COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
1 KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CHARACTER*1 STACK1(8,40),STACK2(8,40)
InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
COMMON/STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
1 ST1LIM,ST2LIM
InTeGer*4 IATYP(27),LINTGR
CHARACTER*1 ITYP(2264)
COMMON/TYP/IATYP,ITYP,LINTGR
InTeGer*4 MPAG(2),MPMOD(2)
InTeGer*2 LVALBF(5,800)
COMMON/VB/MPAG,LVALBF,MPMOD
InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
InTeGer*4 LEVEL,NONBLK,LEND,VIEWSW,BASED
CHARACTER*1 LINE(80)
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C *** END COMMONS FROM OTHER PLACES.
FH=0
c IFCW=4927
C DISABLE FLOATING EXCEPTIONS
c CALL LCWRQQ(IFCW)
C INITIAL DEFAULT FORMAT FOR NUMERICS is set at runtime
C INIT COMMON DATA FIRST OF ALL.
IDOL7=1
C INITIALLY IN ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
CALL BLOCK
IKONS=0
write(*,6402)
6402 Format(' Compiled by Absoft Fortran 2.3.')
Write(*,6403)
6403 Format(' Requires 640 by 400 Workbench screen (interlace)')
CALL INITA1(KMAP,KWID,ICODE)
3002 CONTINUE
CALL INITA2(KMAP,KWID,ICODE,IKONS)
IKONS=1
3000 CONTINUE
CALL INITB(KMAP,KWID,ICODE)
LINIZZ=0
C IF(IOLDFL.GT.1)GOTO 2000
2000 CONTINUE
C DRAW OUR LABELS AND OTHERWISE INITIALIZE DISPLAY SHEET
KZPPD=0
IF(IPSET.NE.0)GOTO 1000
IF(PZAP.EQ.0)CALL UVT100(11,2,0)
CALL UVT100(1,1,1)
OSWIT=20
IPRSS=PROW
IPCSS=PCOL
IDRW=DROW
IDCL=DCOL
IF(LINIZZ.LE.1)CALL RECALC
IF(PZAP.EQ.0)CALL DSPSHT(2)
DCOL=IDCL
DROW=IDRW
PROW=IPRSS
PCOL=IPCSS
3006 FORMAT(80A1)
C
1000 CONTINUE
IPSET=0
LINIZZ=LINIZZ+1
OSWIT=20
C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
ICODE=0
CALL XQTCMD(ICODE)
IF(ICODE.LT.30)GOTO 1843
C HELP COMMAND AND SIMILAR...
IF(ICODE.NE.400)GOTO 1847
CALL DSPSHT(10)
ICODE=1
C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
GOTO 1843
1847 CONTINUE
IF(ICODE.NE.420)GOTO 1849
C CLOSE UNIT 1 JUST IN CASE...
CLOSE(1)
KLVL=1
IPRSSS=PROW
IPCSSS=PCOL
CALL CALC
PROW=IPRSSS
PCOL=IPCSSS
C CLOSE CONSOLE LUN USED BY CALC.
CLOSE(1)
C CLOSE ANY OTHER LUNS CALC MAY HAVE USED...
CLOSE(2)
CLOSE(3)
C SET UP FOR REDRAW WHEN BACK...
ICODE=-1
GOTO 1843
1849 CONTINUE
IF(ICODE.NE.430)GOTO 1845
C TEST FUNCTION, TESTING EXPRESSION.
C INHIBIT RECALCULATION...
C COMMAND IS IN "XTNCMD" STRING.
LLST=MIN0(80,XTNCNT)
LFST=1
CALL DOENTR(XTNCMD,LFST,LLST)
C THIS SETS % VARIABLE AND WILL DO A CALC DIRECTLY. THEREFORE
C WE MUST INHIBIT AUTO RECALCULATION.
C NOTE WE HAVE TO CALL THIS FROM THE ROOT SINCE THE RECALC OVERLAY
C TREE OVERWRITES THE XQTCMD ONE.
ICODE=1
GOTO 1843
1845 CONTINUE
IVVV=ICODE-30
9308 CALL HELP(IVVV)
IVVV=0
CALL VWRT('Type return to continue, Hn for other Help pages:',
1 49)
ILL=IOLVL
C IF(ILL.EQ.5)ILL=0
READ(ILL,3006,END=5600,ERR=5600)(FORM2(K),K=1,4)
IVVVV=ichar(FORM2(2))
IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
IF(FORM2(1).EQ.'H'.OR.FORM2(1).EQ.'h')GOTO 9308
C NOW CLEAR SCREEN AND TRY MORE COMMANDS AS BEFORE...
ICODE=6
C
1843 CONTINUE
OSWIT=20
IPRSS=PROW
IPCSS=PCOL
IDRW=DROW
IDCL=DCOL
IF(LINIZZ.LE.1)CALL RECALC
IF(IPSET.NE.0)GOTO 4110
DCOL=IDCL
DROW=IDRW
PROW=IPRSS
PCOL=IPCSS
4110 CONTINUE
IPSET=0
IF(ICODE.EQ.-1)GOTO 2000
C IN PORTACALC-VM, S COMMAND ALLOWS DEFAULT FORMAT CHANGE AND
C TITLE CHANGE, BUT DOES NOT ALTER SHEET IN MEMORY... DON'T ALLOW
C SCRATCH FILE SAVE STUFF...
C IF(ICODE.EQ.-2)CALL WRKFIL(1,FORM,3)
C IF (ICODE.EQ.-2)CALL CLOSE(7)
IF(ICODE.LE.-2)GOTO 3002
C
C RECALCULATE SHEET NOW AUTOMAGICALLY
C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
C THE ENTIRE SHEET.
C LIMIT NUMBER OF ITERATIONS AT ANY ONE TIME TO 20 HOWEVER
KKMAX=20
3670 CONTINUE
IF(ICODE.EQ.5.OR.ICODE.EQ.1
1 .OR.ICODE.EQ.6.OR.RCFGX.EQ.1)GOTO 3671
CALL RECALC
IPSET=0
KKMAX=KKMAX-1
C IMPLEMENT VARY LOOP...
C ASSUME USRFCT MUSTR CONTOL KALKIT VARIABLE THEN TO GET LOOP TO
C TERMINATE SOMETIME.
KKMAX=MIN0(KKMAX,KALKIT)
IF(KKMAX.GT.0)GOTO 3670
3671 CONTINUE
C IF(ICODE.NE.1.AND.RCFGX.NE.1)CALL RECALC
C
C DISPLAY SHEET NOW. ONLY ALTERS ENTRIES INVALIDATED BY COMMAND.
IF(ICODE.NE.2.AND.ICODE.NE.6)GOTO 21
C ICODE=2 = REFRESH DISPLAY. ZERO ALL NUMBERS AND CAUSE TOTAL REDISPLAY.
DO 22 N1=1,20
DO 22 N2=1,75
C SET NUMBER DISPLAYED TO WEIRD VALUE.
22 DVS(N1,N2)=DVS(N1,N2)+.000000000034
IF(PZAP.EQ.0)CALL UVT100(11,2,0)
CALL UVT100(1,1,1)
21 CONTINUE
IF(ICODE.EQ.6)ICODE=2
IF(ICODE.NE.5.AND.PZAP.EQ.0)CALL DSPSHT(ICODE)
DCOL=IDCL
DROW=IDRW
PROW=IPRSS
PCOL=IPCSS
GOTO 1000
5600 CONTINUE
C ERROR ON READ FROM IOLVL HANDLED HERE.
c REWIND 5
CLOSE(11)
OPEN(11,FILE='CON:50/150/300/40/Analy Command',STATUS='OLD',
1 FORM='FORMATTED')
CLOSE(3)
IOLVL=11
GOTO 1000
END
c -h- assign.for Fri Aug 22 12:56:01 1986
SUBROUTINE ASSIGN(IUNIT,NAME)
C
C
CHARACTER*1 NAME(50)
InTeGer*4 IUNIT
C &&&& MS FTN 3.2
LOGICAL LEXIST
C &&&&
CHARACTER*20 WK
CHARACTER*1 WK1(20)
EQUIVALENCE(WK(1:1),WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
DO 1 N=1,20
WK1(N)=' '
1 CONTINUE
DO 2 N=1,20
II=ICHAR(NAME(N))
IF(II.LT.32)GOTO 3
WK1(N)=CHAR(II)
C1 CONTINUE
2 CONTINUE
3 CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
INQUIRE(FILE=WK,EXIST=LEXIST)
IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
CALL UVT100(1,1,1)
CALL SWRT('File not found. Using window instead.',37)
Open(IUNIT,'CON:200/100/300/80/Nonexistent file')
C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
C WILL GET EOF ON START, BUT THAT'S TOO BAD...
Return
100 CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
1 FORM='FORMATTED')
77 CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
RETURN
END
c -h- at.for Fri Aug 22 12:56:23 1986
SUBROUTINE AT (RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C *******************************************************
C * *
C * SUBROUTINE AT *
C * *
C *******************************************************
C SUBROUTINE AT IS CALLED WHEN THE *@ CALC COMMAND IS ENCOUNTERED.
C IT CHANGES THE VALUE OF LEVEL WHICH HOLDS THE NUMBER OF THE
C LOGICAL I/O UNIT WHERE INPUT COMMAND LINES ARE TO BE OBTAINED.
C THE FILE ASSOCIATED WITH THAT I/O UNIT IS OPENED UNDER THE PROPER
C CONDITIONS.
C
C MODIFICATION CLASSES: M1,M2,M9
C
C MODIFIED 3-OCT-77 P.B.
C MODIFIED 10-JAN-78 P.B. TO PUT SY: BEFORE FILENAMES
C WITH NO DEVICE SPECIFIED SO THAT DEFAULT IS USER'S SY:
C AND NOT THE SYSTEM SY:
C
C
C AT CALLS
C
C ASSIGN (TO ASSOCIATE A FILE NAME WITH A LOGICAL I/O UNIT)
C ERRMSG (TO PRINT ERROR MESSAGES)
C GETNNB (TO GET NEXT NON-BLANK FROM THE INPUT LINE)
C ZNEG (TO TEST IF A VARIABLE IS POSITIVE)
C
C
C
C AT IS CALLED BY ROUTINE CMND WHICH IS THE MODULE THAT DETERMINES
C WHAT CALC COMMAND WAS REQUESTED.
C
C
C
C VARIABLE USE
C
C ALPHA(27) HOLDS LEGAL VARIABLE NAMES.
C I,J HOLD TEMPORARY VALUES.
C IPT POINTS TO NEXT NON-BLANK CHARACTER IN LINE(80).
C ITCNTV(6) INDEXED BY LEVEL. HOLDS 0 IF NO ITERATION ON THAT
C LEVEL, OTHERWISE INDEX INTO VBLS FOR THE VARIABLE
C THAT CONTROLS ITERATION.
C LEVEL HOLDS NUMBER OF LOGICAL I/O UNIT WHERE NEXT INPUT
C LINE IS EXPECTED.
C LINE(80) HOLDS COMMAND INPUT LINE.
C NBLINE(78) HOLDS THE INPUT FILE NAME WITHOUT BLANKS.
C NONBLK POINTS TO THE LAST NON-BLANK CHARACTER IN LINE(80).
C RETCD RETURN CODE: 1=O.K. 2=ERROR.
C SY "SY:" USED TO OPEN FILES WITH A DEFAULT OF
C USER'S SY: (OTHERWISE SYSTEM SY: IS USED) P.B.
C 10-JAN-78
C
C
C
C SUBROUTINE AT (RETCD)
C
InTeGer*4 IPT,J,I
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 RETCD,VIEWSW,BASED
InTeGer*4 ITCNTV(6),ZNEG
C
CHARACTER*1 LINE(80),NBLINE(78)
CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C CHARACTER*1 SY(3)
C
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
COMMON/ITERA/ITCNTV
C
C DATA SY/'S','Y',':'/
C
C
C
C UPON ENTRANCE, NONBLK POINTS TO THE CHARACTER @
C
C MODIFICATION CLASSES: M1,M2,M9
C
C PICK UP FIRST NON-BLANK AFTER THE @
CALL GETNNB(IPT,RETCD)
GO TO (10,1050),RETCD
STOP 10
C
C
C START BUILDING FILE NAME AS A COMPRESSED VERSION (BLANKS REMOVED)
C OF THE REST OF LINE(80)
10 J=0
15 NONBLK=IPT
J=J+1
NBLINE(J)=LINE(NONBLK)
CALL GETNNB(IPT,RETCD)
GO TO (15,50),RETCD
STOP 50
C
C
C SET RETURN CODE AND INDICATE THAT WE WILL BE AT A NEW LEVEL.
C J HOLDS THE COUNT OF THE NUMBER OF CHARACTERS IN NBLINE.
C IF J=1 THEN NO ITERATION IS POSSIBLE BECAUSE FILENAME IS THE
C SINGLE CHARACTER.
50 RETCD=1
LEVEL=LEVEL+1
IF (LEVEL.GT.6) GOTO 1000
C
IF(J.EQ.1) GO TO 200
C
C NBLINE HOLDS THE COMPRESSED FILENAME. NOW WE CHECK TO SEE IF AN
C ITERATION VARIABLE WAS SPECIFIED. THIS IS INDICATED BY A LEGAL
C VARIABLE NAME PRECEEDED BY A BLANK (IN LINE(80))
C NOTE THAT ONLY ONE OF THE ACCUMULATORS A-Z MAY BE USED FOR THIS.
DO 60 I=1,27
C A-Z OR % LEGAL
IF(ALPHA(I).EQ.LINE(NONBLK))GO TO 100
60 CONTINUE
GO TO 200
100 IF(LINE(NONBLK-1).NE.BLANK)GO TO 200
C
C
C ITERATION INDICATOR IS PRESENT
C (ALPHABETIC CHARACTER OR % PRECEEDED BY A BLANK)
C IF THE VALUE OF THE VARIABLE IS NOT POSITIVE, THE FILE IS IGNORED.
IF(ZNEG(I).EQ.1)GO TO 150
C
C
C RETAIN INDEX INTO VBLS AND DECREASE J SO THAT THE FILENAME
C DOES NOT INCLUDE THE ITERATION SPECIFICATION.
ITCNTV(LEVEL)=I
J=J-1
GO TO 300
C
C
C FILE NOT ENTERED, ITERATION VARIABLE IS ZERO, NEGATIVE, OR UNDEFINED
150 LEVEL=LEVEL-1
GO TO 350
C
C
C IF NO ITERATION, SET ITCNTV TO ZERO BECAUSE NOT ZEROED BY EXIT
C ROUTINES
200 ITCNTV(LEVEL)=0
300 CONTINUE
NBLINE(J+1)=0
C OPEN(UNIT=LEVEL,NAME=NBLINE)
C CALL RASSIG (LEVEL,NBLINE,J)
CALL RASSIG (LEVEL,NBLINE)
350 RETURN
C
C *** ERROR PROCESSING ***
C
C TOO MANY LEVELS
1000 I=2
1010 CALL ERRMSG(I)
1020 RETCD=2
RETURN
C
C
C UNIDENTIFIED COMMAND (ARGUMENT)
1050 I=3
GO TO 1010
END
c -h- bascng.for Fri Aug 22 12:57:23 1986
SUBROUTINE BASCNG(RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C
C SUBROUTINE BASCNG IS CALLED WHEN THE *B CALC COMMAND IS
C ENCOUNTERED. THIS COMMAND INDICATES THAT THE DEFAULT BASE
C FOR CONSTANTS IS TO BE CHANGED. THE ROUTINE READS IN ONE
C OR TWO DIGITS AND CHANGES THE DEFAULT BASE SPECIFICATION
C AS IS APPROPRIATE.
C
C MODIFICATION CLASS M2
C
C BASCNG CALLS
C
C ERRMSG (PRINTS ERROR MESSAGES)
C GETNNB (GETS THE NEXT NON-BLANK IN INPUT LINE LINE(80))
C
C
C BASCNG IS CALLED BY ROUTINE CMND WHICH IDENTIFIES THE COMMAND THAT
C THE USER WANTS TO EXECUTE.
C
C
C VARIABLE USE
C
C BASED HOLDS THE DEFAULT BASE.
C IPT POINTS TO THE NEXT NON-BLANK IN LINE(80).
C I1 BINARY VALUE OF FIRST DIGIT, VALUE OF NEW BASE.
C I2 BINARY VALUE OF SECOND DIGIT.
C NONBLK POINTS TO THE LAST NON-BLANK IN LINE(80)
C RETCD RETURN CODE: 1=O.K. 2=ERROR.
C RETCD2 HOLDS RETURN CODE FROM CALL TO GETNNB
C
C
C
C
C SUBROUTINE BASCNG(RETCD)
C
C
C UPON ENTRANCE, NONBLK POINTS TO THE 'B' IN '*B' IN LINE
C
InTeGer*4 IPT,I1,I2
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
C
CHARACTER*1 DIGITS(16,3),LINE(80)
C
COMMON /DIGV/ DIGITS
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C IF NO ARGUMENT, RETURN WITH NORMAL RETURN CODE. THIS ALLOWS THE
C USER TO SEE WHAT THE PRESENT DEFAULT BASE IS.
RETCD=1
CALL GETNNB(IPT,RETCD2)
IF(RETCD2.GT.1)GO TO 1000
C
C
C CHECK OUT FIRST DIGIT
DO 300 I1=1,10
IF(DIGITS(I1,1).EQ.LINE(IPT)) GO TO 400
300 CONTINUE
GO TO 999
C
C
C SEE IF THERE IS A SECOND DIGIT
400 NONBLK=IPT
IF(I1.EQ.10)I1=0
CALL GETNNB(IPT,RETCD2)
IF(RETCD2.EQ.1)GO TO 500
C
C
C IF NOT, CONVERT TO A TWO DIGIT NUMBER WITH A LEADING ZERO.
I2=I1
I1=0
GO TO 700
C
C A SECOND CHARACTER WAS FOUND; FIGURE OUT WHAT THE BINARY
C VALUE IS (IF IT IS A DIGIT AT ALL).
500 DO 600 I2=1,10
IF(DIGITS(I2,1).EQ.LINE(IPT))GO TO 700
600 CONTINUE
GO TO 999
C
C CONVERT DIGITS TO A NUMBER IF IT IS LEGAL
700 IF(I2.EQ.10)I2=0
I1=I1*10+I2
IF(I1.NE.8.AND.I1.NE.10.AND.I1.NE.16) GO TO 999
BASED=I1
GO TO 1000
C
C
C ILLEGAL BASE SPECIFICATION
999 RETCD=2
WRITE(11,998)
998 FORMAT(' Illegal Base. (Only 8,10,and 16 OK). Ignored.')
C CALL ERRMSG(19)
C
C RETURN
1000 RETURN
END
c -h- blkdat.for Fri Aug 22 12:57:49 1986
BLOCK DATA
C COPYRIGHT 1983 GLENN C.EVERHART
C ALL RIGHTS RESERVED
C InTeGer*4 MFID(2),MFMOD(2)
InTeGer*2 IFID(8,2048)
COMMON/IFIDC/IFID
CHARACTER*1 LFID(16,2048)
EQUIVALENCE(IFID(1,1),LFID(1,1))
C COMMON/FRM/MFID,MFMOD
CHARACTER*1 DTBL1(9,9,8)
C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
InTeGer*2 BTBL(6,6,8)
C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
C NO NEED TO WASTE IT.
c INTEGER DTBLIN
C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
InTeGer*2 BTBL1(6,6)
InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
COMMON /DECIDE/ DTBL1
cc DATA DTBLIN/0/
DATA BTBL1 /4,2,3,4,8,9,
1 6*0,0,2,0,0,0,9,0,2,0,0,0,9,
2 0,2,3,0,0,9,0,2,4*0/
DATA BTBL2/
3 4,5*0,2,0,3*2,0,3,3*0,2*0,4,3*0,2*0,
4 8,5*0,9,0,3*9,0/
DATA BTBL3/4,2,3,4,8,9,
5 6*2,3,2,3,3,3,9,4,2,3,4,4,9,
6 8,2,3,4,8,9,9,2,4*9/
DATA BTBL4/
7 4,2,3,4,8,9,6*2,3,2,3,3,3,9,4,2,3,4,4,9,
8 8,2,3,4,8,9,
9 9,2,4*9/
DATA BTBL5/4,2,3,3*4,6*0,6*0,6*0,
1 6*0,6*0/
DATA BTBL6/4,3*0,4,0,4,3*0,0,0,4,3*0,2*0,4,3*0,2*0,
2 4,3*0,2*0,
3 4,3*0,2*0/
DATA BTBL7/4,2,3,3*4,6*2,6*3,6*4,
4 6*8,6*9/
DATA BTBL8/4,1,4,4,4,3,2,1,2,2,2,1,4,3,4,4,
5 4,3,4,3,4,4,4,3,4,3,4,4,
6 4,3,2,1,2,2,2,1/
END
c -h- ca2e.for Fri Aug 22 13:00:17 1986
SUBROUTINE CA2E(LNIN,LNOUT)
C CONVERT NORMAL ASCII FORM TO ENCODED
CHARACTER*1 NAME(4),NUMBER(6)
CHARACTER*1 LNIN,LNOUT
CHARACTER*6 NUMBR6
EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
DIMENSION LNIN(128),LNOUT(128)
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
CCC InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
C LOGICAL*2 L63,L192,L255,L128
LOGICAL*4 L1,L2
C InTeGer*4 I63,I192,I255,I128
InTeGer*4 I63,I192,I127
InTeGer*4 I1,I2
C EQUIVALENCE(L128,I128)
C EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
EQUIVALENCE (I1,L1),(I2,L2)
C DATA I63/63/,I192/192/,I255/255/,I128/128/
DATA I63/63/,I192/192/,I127/127/
LI=1
LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100 CONTINUE
LCC=ICHAR(LNIN(LI))
IF(LCC.EQ.255)GOTO 500
C IF BINARY FORM, COPY 3 BYTES TO AVOID ERRORS.
IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
IL1=LI
LE=110
LSTC=LE
CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
C AVOID MESSING UP FUNCTION NAMES
IF(ID2.EQ.1)IVLD=0
IF(IDOL1.NE.0.OR.IDOL2.NE.0)IVLD=0
C ONLY REPACK NORMAL FORM NAMES
C NOTE THAT SINCE THESE HAVE $ AFTER THE FIELDS, NO PARTIAL NAME
C WILL EVER GET RECOGNIZED WITHOUT IDOL1 OR IDOL2 GETTING SET.
IF(IVLD.EQ.0)GOTO 200
C ALIASED NAMES MIGHT GET SCANNED WITHIN PRIME AREA IF THE FIRST
C ONE OR TWO CHARS GET STRIPPED OFF, SO TREAT LIKE P## OR D## FORMS
C AND COPY THE WHOLE NAME HERE.
IF(ID1.GT.60.OR.ID2.GT.301)GOTO 250
C ALSO DON'T PACK ALIASED NAMES; THEY WON'T FIT IN CODED VALUES.
C FOUND VARIABLE.
C FIRST DON'T PACK P## AND D## FORMS.
IF(LNIN(LI+1).EQ.'#')GOTO 250
C REPACK NORMAL VARIABLE HERE.
LI=LSTC
LNOUT(LO)=CHAR(255)
I1=IMASK(ID1,I63)
C I1=ID1
C L1=L1.AND.L63
I2=ID2/2
I2=IMASK(I2,I192)
C L2=L2.AND.L192
C L1=L1.OR.L2
I1=I1+I2
LNOUT(LO+1)=CHAR(I1)
C I2=ID2
I2=IMASK(ID2,I127)+128
C L2=L2.AND.L255
C L2=L2.OR.L128
LNOUT(LO+2)=CHAR(I2)
LO=MIN0(109,LO+3)
GOTO 300
250 CONTINUE
C JUST COPY DISPLAY FORMS.
IL1=LSTC-1
DO 251 N=LI,IL1
LNOUT(LO)=LNIN(N)
LO=LO+1
IF(LO.GT.110)GOTO 300
251 CONTINUE
LI=LSTC
C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
GOTO 300
200 CONTINUE
C HERE CHECK FOR FORMULA...
C NOTE THAT SOME NAMES (E.G. "AVG" COULD CONFLICT WITH VERY LARGE COLUMN
C NAMES. HOWEVER, IGNORE THAT POSSIBILITY. THAT'S AWFULLY FAR OUT.
CALL FNAME(LNIN(LI),II,INDX)
IF(INDX.LE.0.OR.INDX.GT.25)GOTO 220
C Ensure that functions with indices too large to encode are
C just treated literally. 229+25=254, the largest index we can have
C before colliding with the 255 used to encode variable names.
C thus all function names past the 25th must just be literally
C entered. This is not really a problem as logic to find them
C will work in either encoded or unencoded cases.
C BE SURE A [ CHAR FOLLOWS NAME FOR THIS TO BE ACCEPTED...
IF(LNIN(LI+3).NE.'[')GOTO 220
C FOUND MULTI-INPUT FUNCT NAME
LNOUT(LO)=CHAR(229+INDX)
C SIMPLE 1-BYTE ENCODE OF NEEDED FUNCT NAME. NOT IN ANY CRITICAL RANGES...
LO=LO+1
LI=LI+3
GOTO 300
220 CONTINUE
LNOUT(LO)=LNIN(LI)
C JUST COPY MISC. CHARACTER.
LO=LO+1
LI=LI+1
300 IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
LO=MIN0(LO,110)
DO 400 N=LO,110
400 LNOUT(N)=0
C COPY REST OF 128 BYTE ARRAY
DO 1 N=111,128
1 LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
RETURN
500 CONTINUE
C SPECIAL COPY OF 3 BYTE PACKED FORMS FOR SPEED
LNOUT(LO)=LNIN(LI)
LNOUT(LO+1)=LNIN(LI+1)
LNOUT(LO+2)=LNIN(LI+2)
LO=LO+3
LI=LI+3
GOTO 300
END
c -h- calbin.for Fri Aug 22 13:00:17 1986
SUBROUTINE CALBIN(RETCD)
C COPYRIGHT (C) 1983,1984 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C
C *******************************************************
C * *
C * SUBROUTINE CALBIN *
C * *
C *******************************************************
C
C SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
C
C special version with multiple precision diked out - gce (to save space
C on 256K PC)
C UPON ENTRANCE TO ROUTINE:
C OPERAND1 IS IN STACK1 (ST1PT-1)
C OPERAND2 IS ON TOP OF STACK2 (ST2PT-1)
C OPERATOR IS BELOW OPERAND2 (ST2PT-2)
C UPON EXIT:
C RESULT IS IN STACK1
C STACK2 HAS BEEN CLEANED UP
C
C RETURN CODE MEANING
C 1 NORMAL RETURN
C 2 OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C 3 ERROR RETURN
C
C
C
C MODIFICATION CLASSES: M3, M4, AND M8
C
C
C
C CALBIN CALLS
C
C CONTYP CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
C ERRMSG PRINTS OUT ERROR MESSAGES
C MULADD PERFORMS MULTIPLE PRECISION ADDITION
C MULDIV PERFORMS MULTIPLE PRECISION DIVISION
C MULMUL PERFORMS MULTIPLE PRECISION MULTIPLICATION
C
C
C
C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
C
C
C
C
C VARIABLE USE
C
C EIGHT(8) PICKS OUT A REAL CONSTANT FROM STACK.
C FOUR(4) PICKS OUT AN INTEGER CONSTANT FROM STACK.
C I,J HOLD TEMPORARY VALUES.
C IA FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
C VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
C ID USED TO CONVERT DECISION TABLE CHARACTER*1 VALUE TO
C AN InTeGer*4 VALUE THAT CAN BE USED AS AN ARGUMENT
C IN A CALL TO CONTYP.
C INT,IHOLD HOLD INTEGER*4 VALUES.
C IOP HOLDS THE BINARY OPERATOR.
C IOP2 USED TO INDEX A COMPUTED GO.
C ISW HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
C MINUS VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C NUMBER THAT IS USED TO INDICATE A NEGATIVE.
C OP1TYP TYPE OF OPERAND 1.
C OP2TYP TYPE OF OPERAND 2.
C PLUS VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C NUMBER THAT IS USED TO INDICATE POSITIVE.
C PT1,PT2 POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
C REAL,RHOLD HOLD TEMPORARY REAL*8 VALUES.
C RETCD ERROR RETURN: 1 = O.K. 2 = RESULT WAS OUTPUT
C 3 = ERROR
C
C
C SUBROUTINE CALBIN(RETCD)
REAL*8 REAL,RHOLD,DFLOAT
C
INTEGER*4 INT,IHOLD
C
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 VLEN(9)
InTeGer*4 IOP,IA,ID,IOP2,ISW
InTeGer*4 PLUS,MINUS
InTeGer*4 OLDTYP,VIEWSW,BASED
InTeGer*4 TYPE(1,1)
InTeGer*4 RETCD,RETCD2
InTeGer*4 OP1TYP,OP2TYP
InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
InTeGer*4 PT1,PT2
C
CHARACTER*1 STACK1(8,40),STACK2(8,40)
InTeGer*4 STK12(2,40)
REAL*8 XVBLK
EQUIVALENCE(STK12(1,1),STACK1(1,1))
CHARACTER*1 AVBLS(20,27), DTBL1(9,9,8)
CHARACTER*1 VBLS(8,1,1)
EQUIVALENCE (XVBLK,VBLS(1,1,1))
CHARACTER*1 EIGHT(8),FOUR(4)
CHARACTER*1 LINE(80)
C
EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON/V/ TYPE,AVBLS,VBLS,VLEN
COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
; ST1LIM,ST2LIM
COMMON /DECIDE/DTBL1
C
C
DATA PLUS/0/,MINUS/1/
C
C
RETCD=1
PT1=ST1PT-1
PT2=ST2PT-1
C
IOP=ST2TYP(ST2PT-2)
OP1TYP=ST1TYP(PT1)
OP2TYP=ST2TYP(PT2)
C NOTE THAT IA IS UNUSED HERE... SAVE BIG DIMENSIONS
IA=ICHAR(STACK1(1,PT1))
ID1=STK12(1,PT1)
ID2=STK12(2,PT1)
C CALL GETDM(STACK1(1,PT1),ID1,ID2)
C ****&&&& ABOVE GETS LOCS IN 2 DIM ARRAY OF VARIABLES
IF (IOP.NE.200) GOTO 100
C
C
C
C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
IF(OP1TYP.GE.0) GO TO 5
C
C
C
C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
OP1TYP=-OP1TYP
ST1TYP(PT1)=OP1TYP
C
C
C
C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE I=J=2
5 J=VLEN(OP2TYP)
C TYPE(IA)=OP1TYP
CALL TYPSET(ID1,ID2,OP1TYP)
C TYPE(ID1,ID2)=OP1TYP
C *&*****&&&&& NOTE TYPE ARRAY AND VBLS ARRAY NOW ARE HUGE
C NOTE FURTHER THAT AVBLS IS OLD VBLS ARRAY. SWITCHED ON IF
C ID1 =< 27 AND ID2=1.
DO 10 I=1,J
10 STACK1(I,PT1)=STACK2(I,PT2)
CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
GOTO (20,9999), RETCD2
STOP 20
C
C
C THE SPECIFIED VARIABLE GETS NEW VALUE.
C ***&&&& HERE'S WHERE WE STORE A VALUE INTO A VARIABLE...
20 J=VLEN(OP1TYP)
DO 30 I=1,J
C VBLS(I,IA)=STACK1(I,PT1)
IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 22
C REPLACE VBLSET CALL WITH XVBLST CALL ON LAST PASS TO AVOID
C MULTIPLE REPLACEMENT OF STORAGE FOR EVERY PASS.
VBLS(I,1,1)=STACK1(I,PT1)
IF(I.EQ.J)CALL XVBLST(ID1,ID2,XVBLK)
C CALL VBLSET(I,ID1,ID2,STACK1(I,PT1))
C VBLS(I,ID1,ID2)=STACK1(I,PT1)
GOTO 30
22 AVBLS(I,ID1)=STACK1(I,PT1)
C *****&&&&&
30 CONTINUE
GOTO 10000
C
C
C IOP2 VALUES 1="**" 2="*" 3="/" 4="+" 5="-"
100 IOP2=IOP-111
GOTO (1000,2000,2000,2000,2000),IOP2
C
C
C ********************************************
C *********** EXPONENTIATION ***************
C ********************************************
C
C
C FIRST CONVERT TO PROPER TYPE
1000 ID=ICHAR(DTBL1(OP2TYP,OP1TYP,5))
CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
ID=ICHAR(DTBL1(OP2TYP,OP1TYP,6))
CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
C
C
C GOTO APPROPRIATE PLACE TO PERFORM OPERATION
ID=ICHAR(DTBL1(OP2TYP,OP1TYP,8))
GOTO (1100,1200,1300,1400,1500,1600,1700),ID
STOP 1000
C
C
C REAL**REAL
1100 DO 1104 I=1,8
1104 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 1108 I=1,8
1108 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD**REAL
C
C
C USED BY REAL**I
1109 DO 1110 I=1,8
1110 STACK1(I,PT1)=EIGHT(I)
C
C
C USED BY I**REAL,I**I
1114 ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,7))
GOTO 10000
C
C
C
C REAL**I
1200 DO 1204 I=1,8
1204 EIGHT(I)=STACK1(I,PT1)
DO 1208 I=1,4
1208 FOUR(I)=STACK2(I,PT2)
REAL=REAL**INT
GOTO 1109
C
C
C
C I**REAL (PARTS USED BY I**I)
1300 DO 1304 I=1,4
1304 FOUR(I)=STACK1(I,PT1)
DO 1308 I=1,8
1308 EIGHT(I)=STACK2(I,PT2)
C
C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
C
INT=DFLOAT(INT)**REAL
1310 DO 1314 I=1,4
1314 STACK1(I,PT1)=FOUR(I)
GOTO 1114
C
C
C
C I**I
1400 DO 1404 I=1,4
1404 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 1408 I=1,4
1408 FOUR(I)=STACK2(I,PT2)
INT=IHOLD**INT
GOTO 1310
C
C
C
C M8**I (PARTS USED BY M10**I, M16**I)
1500 ISW=8
1501 IF(ST2PT.LE.ST2LIM)GO TO 1502
C
C
C STACK OVERFLOW
CALL ERRMSG(9)
GO TO 9999
C
C
C GET EXPONENT AS AN INTEGER
1502 DO 1504 I=1,4
1504 FOUR(I)=STACK2(I,PT2)
IF (INT.GE.0) GOTO 1520
C
C
C EXPONENT NOT POSITIVE OR 0
CALL ERRMSG (15)
GOTO 9999
1520 IF (INT.GT.0) GOTO 1530
C
C
C I**0 = 1
STACK1(8,PT1)=PLUS
DO 1522 I=2,7
1522 STACK1(I,PT1)=0
C LEAVE AS INTEGER SETS HERE RATHER THAN EXPLICIT CHAR() CALLS
STACK1(1,PT1)=1
GOTO 10000
C
C
C EXPONENT IS > 0
1530 INT=INT-1
C
C
C IF EXPONENT = 1 WE ARE DONE
IF(INT.EQ.0)GO TO 10000
C
C
C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
C FACTOR.
DO 1534 I=1,8
1534 STACK2(I,ST2PT)=STACK1(I,PT1)
ST2TYP(ST2PT)=ST1TYP(PT1)
C
C
C
C
1549 continue
c1549 DO 1550 I=1,INT
c CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
c IF(RETCD2.GE.2)GO TO 9999
c1550 CONTINUE
GOTO 10000
C
C M10**I
1600 ISW=10
GOTO 1501
C
C
C
C M16**I
1700 ISW=16
GOTO 1501
C
C
C *****************************************
C * MAKE CONVERSIONS APPROPRIATE FOR */+- *
C *****************************************
2000 CONTINUE
ID=ICHAR(DTBL1(OP2TYP,OP1TYP,1))
CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
IF(ID.EQ.0)GO TO 2010
ST1TYP(PT1)=ID
OP1TYP=ID
2010 ID=ICHAR(DTBL1(OP2TYP,OP1TYP,2))
CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
IF(ID.EQ.0)GOTO 2020
ST2TYP(PT2)=ID
OP2TYP=ID
C
2020 CONTINUE
C
C
C GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
GOTO (2100,3000,4000,5000,6000),IOP2
2100 STOP 2100
C
C
C
C
C
C
C **********************************************
C *********** MULTIPLICATION *****************
C **********************************************
3000 ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
STOP 3000
C
C
C ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
3100 CALL ERRMSG (12)
GOTO 9999
C
C
C DECIMAL, REAL
3200 DO 3204 I=1,8
3204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 3208 I=1,8
3208 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD*REAL
3209 DO 3210 I=1,8
3210 STACK1(I,PT1)=EIGHT(I)
C
C
C FOLLOWING USED BY OTHER SECTIONS
3220 ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,3))
GOTO 10000
C
C
C
C HEX,INTEGER,OCTAL
3300 DO 3304 I=1,4
3304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 3308 I=1,4
3308 FOUR(I)=STACK2(I,PT2)
INT=IHOLD*INT
3309 DO 3310 I=1,4
3310 STACK1(I,PT1)=FOUR(I)
GOTO 3220
C
C
C
C M10
3500 continue
c3500 CALL MULMUL (PT1,PT2,RETCD2,10)
C
C
C FOLLOWING USED BY OTHER SECTIONS
3510 IF (RETCD2.EQ.2) GOTO 9999
GOTO 3220
C
C
C
C M8
3600 continue
c3600 CALL MULMUL (PT1,PT2,RETCD2,8)
GOTO 3510
C
C
C
C M16
3700 continue
c3700 CALL MULMUL (PT1,PT2,RETCD2,16)
GOTO 3510
C
C
C **************************************************
C ****************** DIVISION ********************
C **************************************************
4000 ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
STOP 4000
C
C
C DECIMAL,REAL
4200 DO 4204 I=1,8
4204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 4208 I=1,8
4208 EIGHT(I)=STACK2(I,PT2)
IF(REAL.NE.0.D0)GO TO 4210
CALL ERRMSG(23)
GO TO 9999
4210 REAL=RHOLD/REAL
GOTO 3209
C
C
C HEX,INTEGER,OCTAL
4300 DO 4304 I=1,4
4304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 4308 I=1,4
4308 FOUR(I)=STACK2(I,PT2)
IF(INT.NE.0)GO TO 4310
CALL ERRMSG(23)
GO TO 9999
4310 INT=IHOLD/INT
GOTO 3309
C
C
C M10
4500 continue
c4500 CALL MULDIV (PT1,PT2,RETCD2,10)
GOTO 3510
C
C
C M8
4600 continue
c4600 CALL MULDIV (PT1,PT2,RETCD2,8)
GOTO 3510
C
C
C M16
4700 continue
c4700 CALL MULDIV (PT1,PT2,RETCD2,16)
GOTO 3510
C
C
C
C
C
C **************************************************
C ***************** ADDITION *********************
C **************************************************
C
5000 ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
STOP 5000
C
C
C DECIMAL, REAL
5200 DO 5204 I=1,8
5204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 5208 I=1,8
5208 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD+REAL
GOTO 3209
C
C
C HEX,INTEGER,OCTAL
5300 DO 5304 I=1,4
5304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 5308 I=1,4
5308 FOUR(I)=STACK2(I,PT2)
INT=IHOLD+INT
GOTO 3309
C
C
C M10
5500 continue
c5500 CALL MULADD (PT1,PT2,RETCD2,1)
GOTO 3510
C
C
C M8
5600 continue
c5600 CALL MULADD (PT1,PT2,RETCD2,2)
GOTO 3510
C
C
C M16
5700 continue
c5700 CALL MULADD(PT1,PT2,RETCD2,3)
GOTO 3510
C
C
C
C
C
C
C ***************************************************
C ****************** SUBTRACTION ******************
C ***************************************************
C
6000 ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
STOP 6000
C
C
C DECIMAL,REAL
6200 DO 6204 I=1,8
6204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 6208 I=1,8
6208 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD-REAL
GOTO 3209
C
C
C HEX,INTEGER,OCTAL
6300 DO 6304 I=1,4
6304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 6308 I=1,4
6308 FOUR(I)=STACK2(I,PT2)
INT=IHOLD-INT
GOTO 3309
C
C
C M10
6500 continue
c6500 CALL MULADD (PT1,PT2,RETCD2,4)
GOTO 3510
C
C
C M8
6600 continue
c6600 CALL MULADD (PT1,PT2,RETCD2,5)
GOTO 3510
C
C
C M16
6700 continue
c6700 CALL MULADD (PT1,PT2,RETCD2,6)
GOTO 3510
C
C
C
C
C
C EXIT
9999 RETCD=3
C
C
C
10000 ST2PT=ST2PT-2
RETURN
END
c -h- calc.for Fri Aug 22 13:00:17 1986
SUBROUTINE CALC
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C *** CALC MAINLINE ***
C
C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN
C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
C POSSIBLE COMMANDS.
C
C CALC CALLS
C
C ASSIGN OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
C CLOSE CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
C CMND DETERMINES WHAT CALC COMMAND IS REQUIRED.
C ERRCX CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
C ERRMSG PRINTS OUT ERROR MESSAGES.
C EXIT RETURNS TO OPERATING SYSTEM.
C GETMCR GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
C IS PRESENT, CALC EXITS AFTER THAT ONE COMMAND IS EXECUTED.
C INPOST CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
C LIST LISTS THE LEGAL CALC COMMANDS.
C POSTVL CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
C A VALUE.
C SLEND FINDS THE LAST NON-BLANK IN LINE(80).
C VAROUT PRINTS OUT THE VALUE OF A VARIABLE.
C ZNEG DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
C
C
C
C VARIABLE USE
C
C BASED DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
C BLANK ' '
C DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
C SECOND SUBSCRIPT IS
C 1 FOR DECIMAL
C 2 FOR OCTAL
C 3 FOR HEXADECIMAL
C I,J HOLD TEMPORARY VALUES.
C ITCNTV(6) INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
C INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
C HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
C USED TO CONTROL ITERATION.
C THIS VARIABLE IS GUARANTEED TO BE 1-27.
C LEND POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
C LEVEL HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
C LINES COME FROM.
C LINE(80) COMMAND INPUT LINE.
C NONBLK POINTS TO LAST NON-BLANK FOUND IN LINE(80).
C ONCE HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
C 0 OTHERWISE.
C STAR '*'
C VIEWSW VIEW SWITCH
C 0 = OUTPUT ERROR MESSAGES
C 1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
C 2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
C EVALUATED.
C 3 = OUTPUT EVERYTHING
C WHAT '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
C SHOULD BE OUTPUT.
C
C MODIFIED REASON
C
C 18-MAY-1981 DELETED LINE THAT CAUSED DEFAULT BASE TO BE RESET
C WHEN AN ERROR OCCURS (PB)
C
C 18-MAY-1981 ADDED CODE AT LINES 106 TO 108 TO CONVERT FROM LOWER
C TO UPPER CASE (PB)
C
C CHANGED TO SUBROUTINE GCE TO ALLOW EXTERNAL CONTROL OF CALCULATOR.
C
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 RETCD,VIEWSW,BASED
InTeGer*4 ONCE
InTeGer*4 ZNEG,ITCNTV(6)
C
CHARACTER*1 LINE(80),WHAT,STAR,QUOTE
CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
CHARACTER*1 DIGITS(16,3)
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
InTeGer*4 IPS1,IPS2,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
InTeGer*4 ILNFG,ILNCT
CHARACTER*1 ILINE(106)
COMMON/ILN/ILNFG,ILNCT,ILINE
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C COMMON/KLVL/KLVL
COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
COMMON /DIGV/ DIGITS
COMMON/ITERA/ITCNTV
C
DATA WHAT/'?'/, STAR/'*'/, QUOTE/''''/
DATA ONCE/0/
C
C
C
C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
C THE MODULES PROPERLY, PUT IN A
IF(KLVL.EQ.1)LEVEL=KLVL
ONCE=0
C IF(ILNFG.NE.0) GOTO 6000
C CALL ASSIGN (1,'TT:')
6000 CONTINUE
C CHANGE TI: TO TT: FOR VMS.
C
IF(ILNFG.EQ.0)GOTO 6010
IF(ILNCT.GT.0)GOTO 6010
C INVALID INPUTS...NO LINE TO DO BUT FLAGGED TO DO. CLEAN UP.
ILNFG=0
RETURN
6010 CONTINUE
IF(ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6001
C ++++++
C FOR DEC FORTRAN:
C CALL GETMCR(LINE,LEND)
C IF(LEND)20,20,5
C FOR NON-DEC FORTRAN: (OR VAX VERSIONS)
GOTO 20
C ++++++ END OF CHOICES...
5 CONTINUE
GOTO 6003
6001 CONTINUE
DO 6007 LENDX=1,80
6007 LINE(LENDX)=CHAR(32)
IF(ILNFG.EQ.1)ONCE=1
I255X=0
DO 6002 LENDX=1,ILNCT
LINE(LENDX)=ILINE(LENDX)
IF(ICHAR(LINE(LENDX)).EQ.255)I255X=3
IF(I255X.LE.0)GOTO 4602
I255X=I255X-1
GOTO 6002
C SKIP ENTIRE 3-CHR PACKED CODES
4602 CONTINUE
IF(ICHAR(LINE(LENDX)).GT.0.AND.ICHAR(LINE(LENDX)).LT.32)
1 LINE(LENDX)=CHAR(32)
C LEAVE ANY EXISTING NULLS IN.
6002 CONTINUE
LEND=ILNCT
CD CALL FRMEDT(LINE,LEND)
C FRMEDT IMPLEMENTS EDITS OF {VAR INTO THAT VARIABLE'S FORMULA
CC NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
C ICCC=MIN0(80,(LEND+1))
C LINE(ICCC)=0
GOTO 103
6003 CONTINUE
DO 6 NONBLK=1,7
IF(LINE(NONBLK).EQ.BLANK)GO TO 7
IF(ICHAR(LINE(NONBLK)).EQ.13)GO TO 20
6 CONTINUE
STOP 6
7 NONBLK=NONBLK+1
ONCE=1
GO TO 106
C
C ERROR RESET
10 IF(LEVEL.LE.1) GO TO 12
CLOSE(LEVEL)
LEVEL=LEVEL-1
GO TO 10
12 CONTINUE
VIEWSW=3
C
C
C GET NEXT INPUT LINE
20 CONTINUE
LINE(1)=0
LINE(2)=0
IF(ONCE.EQ.1.AND.LEVEL.LE.1) RETURN
C20 IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL EXIT
C IF (ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6004
IF (LEVEL.LE.1.AND.ILNFG.NE.0.AND.ILNCT.GT.0)RETURN
IF(LEVEL.LT.1)RETURN
IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)WRITE(11,22)
22 FORMAT(' CALC>')
C
C
LLLV=LEVEL
IF(LLLV.EQ.1)LLLV=11
rewind 11
READ (LLLV,24,END=900,ERR=1000) LINE
rewind 11
24 FORMAT (80A1)
C GOTO 6005
C SECTION BELOW COMMENTED OUT BECAUSE IT SHOULD NEVER BE CALLED (GCE).
C6004 CONTINUE
C DO 6006 LENDX=1,80
C6006 LINE(LENDX)=CHAR(32)
CC ABOVE BLANKS OUT LINE ARRAY
C DO 6007 LENDX=1,ILNCT
C6007 LINE(LENDX)=ILINE(LENDX)
CC ABOVE COPIES INPUT FROM OUR CALLER...
C6005 CONTINUE
C
C
C
C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
CD CALL FRMEDT(LINE,LEND)
CALL SLEND(RETCD)
GO TO(30,20),RETCD
STOP 30
30 CONTINUE
C
C
IF(ILNFG.EQ.0.AND.ILNCT.GT.0)GOTO 103
C SHOW WHAT WAS READ FROM FILE
rewind 11
IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
1 WRITE(11,40)LEVEL,(LINE(I),I=1,LEND)
rewind 11
40 FORMAT (' CALC<',I1,'>',80A1)
103 CONTINUE
C NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
ICCC=MIN0(80,(LEND+1))
LINE(ICCC)=0
C
C IDENTIFY FIRST NON-BLANK
DO 104 NONBLK=1,LEND
IF (LINE(NONBLK).NE.BLANK) GOTO 106
104 CONTINUE
RETURN
C STOP 104
C
C CONVERT LOWER CASE TO UPPER CASE
106 CONTINUE
I255X=0
DO 108 I=NONBLK,LEND
J=ICHAR(LINE(I))
IF(J.EQ.255)I255X=3
IF(I255X.LE.0)GOTO 3107
C SKIP ENCODED VARIABLE NAMES
I255X=I255X-1
GOTO 107
3107 CONTINUE
IF (I.EQ.NONBLK) GOTO 107
IF (LINE(I-1).EQ.QUOTE) GOTO 108
IF(J.GE.97.AND.J.LE.122) LINE(I)=CHAR(J-32)
107 CONTINUE
108 CONTINUE
C
C SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
IF (LINE(NONBLK).NE.WHAT) GOTO 110
CALL LIST
GOTO 20
C
C SEE IF IT IS A COMMAND
110 IF (LINE(NONBLK).NE.STAR) GOTO 120
CALL CMND (RETCD)
GOTO (20,115,10,6120), RETCD
6120 RETURN
C STOP 110
C
C
C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
115 CALL SLEND(RETCD)
GO TO (103,20),RETCD
RETURN
C STOP 115
C
C SEE IF ONLY ONE ALPHA CHARACTER
120 J=NONBLK+1
IF (LEND.NE.NONBLK) GOTO 130
DO 124 I=1,27
IF (LINE(NONBLK).EQ.ALPHA(I)) GOTO 126
124 CONTINUE
C
C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
DO 125 I=1,10
IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
125 CONTINUE
C
C
C ALLOW FOR ENTERING THE ASCII BLANK
IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
I=1
GOTO 1001
C
C OUTPUT VALUE OF SINGLE VARIABLE
126 CALL VAROUT(I,1)
GOTO 20
C
C
C CHECK INPUT FOR SYNTAX ERRORS
130 CALL ERRCX (RETCD)
GOTO (140,10),RETCD
RETURN
C STOP 130
C
C CHANGE FROM INFIX TO POSTFIX NOTATION
140 CALL INPOST (RETCD)
GOTO (150,10), RETCD
C
C
C EVALUATE EXPRESSION
150 CONTINUE
CALL POSTVL(RETCD)
GOTO(20,10),RETCD
RETURN
C STOP 150
C
C
C EXIT
900 CONTINUE
IF (LEVEL.EQ.1) RETURN
C IF (LEVEL.EQ.1) CALL EXIT
IF(ITCNTV(LEVEL).EQ.0)GOTO 910
IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
C
C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
C AND EXECUTE AGAIN.
REWIND LEVEL
GO TO 20
C
C
C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
C OF LEVEL BY ONE.
910 CLOSE(LEVEL)
LEVEL=LEVEL-1
GOTO 20
C
C
C
C *** ERROR PROCESSING ***
1000 I=27
1001 CALL ERRMSG(I)
GO TO 10
END
c -h- calun.for Fri Aug 22 13:00:17 1986
SUBROUTINE CALUN(RETCD)
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C *****************************************************
C * SUBROUTINE CALUN *
C *****************************************************
C
C SUBROUTINE CALUN PERFORMS A UNARY OPERATION.
C
C UPON ENTRANCE:
C OPERATOR IS ON STACK 2
C OPERAND IS ON STACK 1
C UPON EXIT:
C OPERATOR HAS BEEN POPPED OFF STACK 2
C RESULT IS ON STACK 1
C
C RETCD MEANING
C
C 1 O.K.
C 2 ERROR
C
C MODIFICATION CLASSES: M3, M4, AND M8
C
C CALUN CALLS
C
C CONTYP CONVERTS DATA TYPES
C ERRMSG PRINTS ERROR MESSAGES
C $DATAN ARC TANGENT
C $DCOS COSINE
C $DEXP E**X
C $DLOG NATURAL LOG
C $DLOG10 LOG BASE 10
C $DSIN SINE
C $DSQRT SQUARE ROOT
C $DTANH HYPERBOLIC TANGENT
C
C CALUN IS CALLED BY POSTVL WHICH CONVERTS FROM INFIX TO POSTFIX
C
C VARIABLE USE
C
C RETCD RETURN CODE: 1 = O.K. 2 = ERROR
C J,K,K2,I HOLD TEMPORARY VALUES
C MINUS VALUE IN LAST MULTIPLE PRECISION BYTE.
C USED TO INDICATE A NEGATIVE NUMBER.
C PLUS VALUE IN LAST MULTIPLE PRCISION BYTE.
C USED TO INDICATE A POSITIVE NUMBER.
C REAL TEMPORARY DOUBLE PRECISION VALUES.
C INT TEMPORARY INTEGER*4 VALUES.
C ST1TYP(40) TYPE FOR EACH ELEMENT ON STACK 1
C ST2TYP(40) TYPE FOR EACH ELEMENT OF STACK 2
C ST1PT POINTS TO TOP OF STACK 1
C ST2PT POINTS TO TOP OF STACK 2
C STACK1 HOLDS OPERAND
C STACK2 HOLDS UNARY OPERATOR
C
C SUBROUTINE CALUN(RETCD)
REAL*8 REAL
REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
REAL*8 DASIN,DACOS,DTAN
REAL*8 DTANH,DATAN
C
REAL*4 FLOAT
C
INTEGER*4 INT
C
InTeGer*4 RETCD,RETCD2
InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT,ST1LIM,ST2LIM
InTeGer*4 K,K2
C
CHARACTER*1 STACK1(8,40),STACK2(8,40),FOUR(4),EIGHT(8)
CHARACTER*1 PLUS,MINUS
C
EQUIVALENCE (FOUR,INT),(EIGHT,REAL)
C
COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,
; ST1TYP,ST2TYP,ST1LIM,ST2LIM
C
C DATA PLUS/0/,MINUS/1/
C
PLUS=0
MINUS=1
RETCD=1
K=ST2TYP(ST2PT-1)
K2=ST1TYP(ST1PT-1)
C
C
C MAKE SURE VARIABLE IS DEFINED
IF(K2.GT.0)GOTO 50
C IF NOT, PRINT MESSAGE AND RETURN
CALL ERRMSG(16)
GOTO 89999
C
50 J=K
C
C
C SEE IF IT IS A UNARY MINUS
IF (J.EQ.111) GOTO 100
C
C
C FUNCTIONS START AT 31
K=K-30
GOTO (100,100,300,400,500,400,10000),K
GOTO 10000
C
C
C ***************************************
C *** ABS (=DABS), IABS, AND UNARY - ***
C ***************************************
100 CONTINUE
IF(K2.GT.0)GO TO 105
CALL ERRMSG(16)
GO TO 89999
105 GOTO (110,120,130,130,140,140,140,130,120),K2
STOP 100
C
C
C ASCII
110 CALL ERRMSG (12)
GOTO 89999
C
C
C DECIMAL AND REAL
120 DO 121 I=1,8
121 EIGHT(I)=STACK1(I,ST1PT-1)
IF (K.NE.111) GOTO 123
C
C
C UNARY -
REAL=-REAL
GOTO 124
123 REAL=DABS(REAL)
124 DO 125 I=1,8
125 STACK1(I,ST1PT-1)=EIGHT(I)
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, AND OCTAL
130 DO 131 I=1,4
131 FOUR(I)=STACK1(I,ST1PT-1)
IF (K.NE.111) GOTO 133
INT=-INT
GO TO 134
133 IF(INT.LT.0)INT=-INT
134 DO 135 I=1,4
135 STACK1(I,ST1PT-1)=FOUR(I)
GOTO 90000
C
C
C MULTIPLE PRECISION
140 IF (K.NE.111) GOTO 150
IF (STACK1(8,ST1PT-1).EQ.PLUS)GOTO 160
150 STACK1(8,ST1PT-1)=PLUS
GOTO 90000
160 STACK1(8,ST1PT-1)=MINUS
GOTO 90000
C
C
C ***************************************
C ************ FLOAT ******************
C ***************************************
300 CONTINUE
GOTO (310,320,330,330,340,340,340,330,320),K2
C
C
C ASCII
310 CALL ERRMSG(12)
GOTO 89999
C
C
C REAL (=DECIMAL)
320 CALL ERRMSG (13)
GOTO 89999
C
C
C INTEGER=HEXADECIMAL=OCTAL
330 DO 333 I=1,4
333 FOUR(I)=STACK1(I,ST1PT-1)
REAL=FLOAT(INT)
DO 335 I=1,8
335 STACK1(I,ST1PT-1)=EIGHT(I)
ST1TYP(ST1PT-1)=2
GOTO 90000
C
C
C MULTIPLE PRECISION
340 CALL ERRMSG (11)
GOTO 89999
C
C
C
C ***************************************
C ******* IFIX AND INT (=IDINT) *******
C ***************************************
400 CONTINUE
GOTO (410,420,430,430,440,440,440,430,420),K2
STOP 400
C
C
C ASCII
410 CALL ERRMSG (12)
GOTO 89999
C
C
C REAL AND DECIMAL
420 DO 421 I=1,8
421 EIGHT(I)=STACK1(I,ST1PT-1)
INT=IDINT(REAL)
DO 424 I=1,4
424 STACK1(I,ST1PT-1)=FOUR(I)
ST1TYP(ST1PT-1)=4
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, AND OCTAL
430 CALL ERRMSG (10)
GOTO 89999
C
C
C MULTIPLE PRECISION
440 CALL ERRMSG (11)
GOTO 89999
C
C
C
C ***************************************
C *************** AINT ****************
C ***************************************
C
C REAL TO REAL TRUNCATION
500 CONTINUE
GOTO (510,520,530,530,540,540,540,530,520),K2
C
C
C ASCII
510 CALL ERRMSG (12)
GOTO 89999
C
C
C REAL AND DECIMAL
520 DO 522 I=1,8
522 EIGHT(I)=STACK1(I,ST1PT-1)
C
C DON'T USE AINT(SNGL(REAL)) BECAUSE THEN
C 2.9999999 RESULTS IN 3.0
REAL=DINT(REAL)
DO 524 I=1,8
524 STACK1(I,ST1PT-1)=EIGHT(I)
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, AND OCTAL
530 CALL ERRMSG (10)
GOTO 89999
C
C
C MULTIPLE PRECISION
540 CALL ERRMSG(11)
GOTO 89999
C
C
C
C
C ****************************************
C ****************************************
C ******** ********
C ******** REAL TO REAL FUNCTIONS ********
C ******** ********
C ******** EXP (=DEXP) ********
C ******** ALOG (=DLOG) ********
C ******** ALOG10 (=DLOG10) ********
C ******** SQRT (=DSQRT) ********
C ******** SIN (=DSIN) ********
C ******** COS (=DCOS) ********
C ******** TANH (DTANH) ********
C ******** ATAN (=DATAN) ********
C ******** ********
C ****************************************
C ****************************************
C
C
C
10000 CONTINUE
GOTO (11000,12000,15000,15000,15000,15000,15000,15000,12000),K2
STOP 10000
C
C
C ASCII
11000 CALL ERRMSG (12)
GOTO 89999
C
C
C REAL AND DECIMAL
12000 DO 12010 I=1,8
12010 EIGHT(I)=STACK1(I,ST1PT-1)
K=K-6
GOTO (12100,12200,12300,12400,12500,12600,12700,12800,
1 12840,12860,12880),K
C
C
C EXP
12100 REAL=DEXP(REAL)
GOTO 14000
C
C
C ALOG
12200 REAL=DLOG(REAL)
GOTO 14000
C
C
C DLOG10
12300 REAL=DLOG10(REAL)
GOTO 14000
C
C
C DSQRT
12400 IF (REAL.GE.0.D0) GOTO 12410
12405 CALL ERRMSG (14)
GOTO 89999
12410 REAL=DSQRT (REAL)
GOTO 14000
C
C
C DSIN
12500 REAL=DSIN(REAL)
GOTO 14000
C
C
C DCOS
12600 REAL=DCOS(REAL)
GOTO 14000
C
C
C DTANH
12700 REAL=DTANH(REAL)
GOTO 14000
C
C
C DATAN
12800 REAL=DATAN(REAL)
GOTO 14000
C
C ASIN
12840 CONTINUE
IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
REAL=DASIN(REAL)
GOTO 14000
C
C ACOS
12860 CONTINUE
IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
REAL=DACOS(REAL)
GOTO 14000
C
C TAN
12880 CONTINUE
IF(REAL.GT.1.570795)REAL=1.570795
IF(REAL.LT. -1.570795) REAL = -1.570795
C CLAMP TO AVOID OVERFLOW
REAL=DTAN(REAL)
C GOTO 14000
C (GOTO NOT NEEDED IF THIS IS THE LAST FUNCTION)
14000 DO 14010 I=1,8
14010 STACK1(I,ST1PT-1)=EIGHT(I)
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, OCTAL, AND MULTIPLE PRECISION
15000 CONTINUE
CALL CONTYP(STACK1,ST1PT-1,K2,2,RETCD2)
GO TO(15010,89999),RETCD2
STOP 15000
15010 ST1TYP(ST1PT-1)=2
GO TO 12000
C
C
C EXIT
89999 RETCD=2
90000 ST2PT=ST2PT-1
RETURN
END
c -h- ce2a.fms Fri Aug 22 13:00:17 1986
SUBROUTINE CE2A(LNIN,LNOUT)
C CONVERT ENCODED FORMULAS TO NORMAL ASCII
C NOTE: ONLY HAS TO HANDLE STANDARD NAMES AS A$5$ TYPE FORMS AND P# AND D# FORMS
C ARE NOT TRANSLATED TO PACKED ONES.
CHARACTER*1 NAME(4),NUMBER(6)
CHARACTER*1 LNIN,LNOUT
CHARACTER*6 NUMBR6
EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
DIMENSION LNIN(128),LNOUT(128)
CCC InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C LOGICAL*2 L63,L192,L255,L127
LOGICAL*4 L1,L2
C InTeGer*4 I63,I192,I255,I127
InTeGer*4 I63,I192,I127
InTeGer*4 I1,I2
C EQUIVALENCE(L127,I127)
C EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
EQUIVALENCE (I1,L1),(I2,L2)
INTEGER*4 FNAM(25)
character*4 fnmx(25)
CHARACTER*1 FCHNM(4,25)
equivalence(fnmx(1)(1:1),fnam(1),fchnm(1,1))
c EQUIVALENCE(FNAM(1),FCHNM(1,1))
DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF ',
1 'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
2 'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
3 'RND ','PMT','PVL','AVE','CHS'/
C DATA I63/63/,I192/192/,I255/255/,I128/128/
DATA I63/63/,I192/192/,I127/127/
LI=1
LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100 CONTINUE
LCC=ICHAR(LNIN(LI))
IF(LCC.NE.255)GOTO 200
C FIND BINARY PATTERNS TO USE
I1=ICHAR(LNIN(LI+1))
I2=IMASK(I1,I192)
C L2=L1.AND.L192
I1=IMASK(I1,I63)
C L1=L1.AND.L63
ID1=I1
I1=ICHAR(LNIN(LI+2))
I1=IMASK(I1,I127)
C L1=L1.AND.L127
ID2=I2*2+I1
LI=MIN0(LI+3,109)
C DO MASKING TO GET BINARY COORDS
CALL IN2AS(ID1,NAME)
C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
IL2=ID2-1
WRITE(NUMBR6(1:6),1000)IL2
C ENCODE(6,1000,NUMBER)IL2
1000 FORMAT(I6)
C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
C THROW OUT SPACES AND COPY THE REST.
DO 202 N=1,4
IF(ICHAR(NAME(N)).LE.32)GOTO 202
LNOUT(LO)=NAME(N)
LO=LO+1
IF(LO.GT.110)GOTO 300
202 CONTINUE
DO 203 N=1,6
IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
C IF 32 ISN'T SPACE, LOSE
LNOUT(LO)=NUMBER(N)
LO=LO+1
IF(LO.GT.110)GOTO 300
203 CONTINUE
GOTO 300
C COPY MISC. CHARACTER
200 CONTINUE
II=ICHAR(LNIN(LI))
IF(II.LT.230.OR.II.GT.254)GOTO 220
C FUNCTION NAME...
II=II-229
LNOUT(LO)=FCHNM(1,II)
LNOUT(LO+1)=FCHNM(2,II)
LNOUT(LO+2)=FCHNM(3,II)
LI=LI+1
LO=LO+3
C FILL IN ASCII FORM OF FUNCTION HERE...
GOTO 300
220 CONTINUE
LNOUT(LO)=LNIN(LI)
LO=LO+1
LI=LI+1
300 IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
LO=MIN0(LO,110)
DO 400 N=LO,110
400 LNOUT(N)=0
DO 1 N=111,128
1 LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
RETURN
END
c -h- cmdmun.for Fri Aug 22 13:00:17 1986
SUBROUTINE CMDMUN(LINE)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
ccc
ccc junk VT100 escape sequence parsing except for arrow keys and
ccc PF2 since it's mostly not useful in MSDOS anyway.
ccc
CHARACTER*1 LINE(120),LC,LINBUF(120),CW(120)
C InTeGer*4 IOLVL,IGOLD
EXTERNAL INDX
C COMMON/IOLVL/IOLVL,IGOLD
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
Logical LEXIST
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
Integer*4 FH
Common/CONSFH/FH
Integer Initd,UseDK,UseDF
Data Initd/0/
c Assume compilation with -h so this stays around
If(Initd.ne.0)Goto 2408
Initd=1
UseDF=0
UseDK=0
c Before inserting the DK: part, check that dk:AKA.CMD can be found.
Inquire(File='DK:AKA.CMD',EXIST=LEXIST)
If(Lexist)UseDF=1
IF(Lexist)UseDK=1
Inquire(File='AKA.CMD',Exist=Lexist)
If(Lexist)UseDF=1
c Usedk = 1 if stuff is seen in dk:
c usedf = 1 if stuff found in default OR dk:
2408 Continue
ITERX=0
C ALLOW RESCAN OF READ-IN COMMANDS UP TO 10 TIMES.
6501 CONTINUE
ITERX=ITERX+1
IF(ITERX.GT.10)RETURN
LI=1
C ALLOW ARROWS OR OTHER SIMILAR KEYS TO BE RECOGNIZED
LL=ICHAR(LINE(LI))
C ALLOW ! OR ESCAPE TO BE LEADIN FOR ESCAPE SEQUENCES
IF(LL.EQ.155.OR.LL.EQ.33.OR.LL.EQ.27)GOTO 1000
C ALLOW % SPECIAL TREATMENT
IF(ICHAR(LINE(1)).EQ.37)GOTO 7000
IF(LINE(1).EQ.'^')IGOLD=IGOLD+1
IF(LINE(1).EQ.'^')GOTO 7223
C IF WE SEE , COULB BE THAT ESC GOT EATEN BY VMS...
IF(LINE(LI).EQ.'[')GOTO 1000
C CONVERT LOWER TO UPPER CASE
NMX=120
DO 41 N=1,120
C CHECK FOR DOUBLE QUOTE (34 DECIMAL). LEAVE L.C. IF SO
NNN=ICHAR(LINE(N))
IF(NNN.EQ.34)NMX=2
C IF WE SEE " CHARACTER THEN ONLY CONVERT 1ST 2 CHARACTERS TO U.C.
41 CONTINUE
JFED=0
DO 1 N=1,NMX
LL=ICHAR(LINE(N))
IF(LL.GT.96.AND.LL.LT.123)LL=LL-32
LINE(N)=CHAR(LL)
IF(LINE(N).EQ.'_'.AND.LINE(N+1).EQ.'_')JFED=N
1 CONTINUE
IF(JFED.LE.0)GOTO 520
C IF __ SEEN (2 UNDERSCORES IN A ROW), CALL FRMEDT AFTER REMOVING THE __ FROM
C THE COMMAND LINE.
DO 521 KKK=JFED,118
LINE(KKK)=LINE(KKK+2)
521 CONTINUE
LINE(119)=Char(0)
LINE(120)=Char(0)
KKK=110
CALL FRMEDT(LINE,KKK)
520 CONTINUE
IF(LINE(1).NE.'M')GOTO 2000
C IF(LINE(1).NE.'M')RETURN
LI=2
GOTO 1000
1000 CONTINUE
C HANDLE ESCAPE SEQUENCES
C ENCODE VT100 SEQUENCES HERE. MUST MODIFY FOR OTHERS.
C IF VMS PASSES 2 ESCS, PASS 1ST, TEST SECOND.
C NOTE CURSOR UP,DOWN, RIGHT, LEFT ARE CODED AS ESC A,B,C, OR D
C WITH POSSIBLE CRUFT BETW ESC AND THE LETTER.
LL=ICHAR(LINE(LI+1))
IF(LL.EQ.155.OR.LL.EQ.27)LI=LI+1
LC=ICHAR(LINE(LI+1))
IF(LC.EQ.'['.OR.LC.EQ.'O')LC=ICHAR(LINE(LI+2))
IF(LC.NE.'?'.AND.LC.NE.'Q')GOTO 10
C MAKE PF2 MEAN HELP, JUST LIKE EDT
C FIX UP AMIGA HELP KEY ALSO TO MEAN HELP...
LINE(LI)=CHAR(72)
C 72 = ASCII FOR 'H'
LGGG=IGOLD+8
IF(IGOLD.LE.0)GOTO 488
LINE(LI+1)=CHAR((LGGG/10)+48)
LINE(LI+2)=CHAR(MOD(LGGG,10)+48)
488 CONTINUE
C RETURN
GOTO 2000
10 CONTINUE
C HANDLE AUX KEYPAD KEYS AS INDIRECTS (FOR NOW)
C MAP ENTER KEY INTO AUX KEYPAD RANGE
IF(LC.EQ.'M')LC='o'
IF(LC.GE.'l'.AND.LC.LE.'y')GOTO 2650
IF(LC.GE.'P'.AND.LC.LE.'S')GOTO 2100
C HANDLE INDIRECT CALLS AT 2100 FOR PF1 THRU PF4 IF AANY
LL=ICHAR(LC)
IF(LL.GE.48.AND.LL.LE.63)GOTO 2640
LL=LL-65
C SUBTRACT ASCII A
IF (LL.LT.0.OR.LL.GT.3)GOTO 2000
C ARROW KEYS HERE. ADJUST AND PASS THEM TO REST OF PROGRAM
LK=LL
IF(LL.EQ.3)LK=2
IF(LL.EQ.2)LK=3
LK=LK+49
C ADJUST FOR ASCII VALUE
LINE(LI)=CHAR(LK)
C STASH NEW CELL IN.
C DON'T DISTURB GOLD STATUS ON MOTION OR ON HELP. ONLY ON INDIRECT
C COMMAND FILES.
RETURN
C GOTO 2000
2640 CONTINUE
C AMIGA FUNCTION KEYS
LL=LL-48+ICHAR('l')
LC=CHAR(LL)
c Fix up as though VT100 function chars and go on
2650 CONTINUE
LL=ICHAR(LC)
LL=LL-ICHAR('l')+ICHAR('A')
C MAPPING IS:
C KEY CHAR AKx.CMD x=
C 0 p E
c 1 q F
C 2 r G
c 3 s H
c 4 t I
c 5 u J
c 6 v K
c 7 w L
c 8 x M
c 9 y N
c , l A
c - m B
c . n C
c ENTER o D
LC=CHAR(LL)
LINE(1)=CHAR(64)
C 64 IS ASCII @ CHARACTER
IVL=0
C INCLUDE "DK:" IN STRING
c
If(UseDF.eq.0) Goto 7223
If(UseDK.eq.0) Goto 2099
LINE(2)='D'
LINE(3)='K'
LINE(4)=':'
IVL=3
2099 Continue
LINE(2+IVL)='A'
LINE(3+IVL)='K'
GOTO 2600
2100 CONTINUE
C GENERATE INDIRECT FILE CALLS FROM PF1, PF3, PF4 KEYS IF ANY
C (THESE GIVE LETTERS P, R, OR S)
LINE(1)=CHAR(64)
IVL=0
If(UseDF.eq.0) Goto 7223
If(UseDK.eq.0) Goto 2098
LINE(2)='D'
LINE(3)='K'
LINE(4)=':'
IVL=3
2098 Continue
LINE(2+IVL)='K'
LINE(3+IVL)='Y'
2600 CONTINUE
LINE(4+IVL)=LC
IF(IGOLD.LE.0)GOTO 7202
C GOLD ADDS EXTRA A,B,C,D,E,... ETC. AFTER FILENAME
LINE(5+IVL)=CHAR(64+IGOLD)
IVL=IVL+1
C ADD EXTRA LETTER FOR GOLDED COMMANDS
7202 CONTINUE
LINE(5+IVL)='.'
LINE(6+IVL)='C'
LINE(7+IVL)='M'
LINE(8+IVL)='D'
LINE(9+IVL)=0
C GENERATE @KYP, @KYR, OR @KYS COMMAND ON PF1, PF3, PF4
2000 CONTINUE
IGOLD=0
RETURN
7000 CONTINUE
C PROCESS %%% FORMS
I1=INDX(LINE(2),37)
C IF I1 IS 1, THEN WE JUST HAVE %% AND THERE'S NOTHING TO DUMP TO
C THE SCREEN. OTHERWISE DUMP IT OUT HERE..
I1=I1+1
IF(I1.LE.2.OR.I1.GT.80)GOTO 7002
II1=I1-1
IV=II1-1
CALL SWRT(LINE(2),IV)
7301 FORMAT(80A1,60A1)
7002 CONTINUE
IF(I1.GT.80)RETURN
C COPY WHATEVER NEEDS TO BE COPIED TO LINBUF
DO 7003 II=1,80
7003 LINBUF(II)=0
I2=INDX(LINE(I1+1),37)
IF(I2.GT.80)RETURN
I2=I2+I1
I1=I1+1
II2=I2-1
II=0
IF(II2.LT.I1)GOTO 7540
DO 7004 LL=I1,II2
II=II+1
7004 LINBUF(II)=LINE(LL)
7540 CONTINUE
IF(I2.GT.80)RETURN
C IF LINE(I2+1) HAS & THEN CLOSE FILE RIGHT HERE AND BUG OFF
IF(LINE(I2+1).NE.'&')GOTO 8005
CLOSE (IOLVL)
IOLVL=11
LINE(I2+1)='\'
8005 CONTINUE
C SEE IF LINE(I2+1) CONTAINS A ?
IF(LINE(I2+1).NE.'?'.AND.LINE(I2+1).NE.'\')GOTO 7005
C HAVE TO READ IN USER'S LINE HERE... READ OFF UNIT 5 ALWAYS...
LX=II+1
rewind 11
c If(FH.NE.0)goto 9201
c READ(11,7301,END=7035,ERR=7035)(LINBUF(II),II=LX,120)
c rewind 11
c Goto 9202
c9201 Continue
c read in main window
Call Getttl(CW)
If(ichar(cw(1)).eq.26.or.
1 ichar(cw(1)).eq.28)goto 7035
c filter so funny chars are treated as eof... ctl Z or ctl \ are eof.
KK=1
c copy to Linbuf array (as much as fits, anyway
Do 9203 II=LX,120
Linbuf(II)=CW(KK)
KK=KK+1
9203 Continue
c9202 Continue
c For AMIGA we use lun 11 for console, both input and output,
c for all commands except normal sheet operation (e.g. help etc.)
C NOW SEE IF LINBUF(LX) IS EITHER A \ CHAR OR ANY CONTROL CHARACTER
LC=LINBUF(LX)
IF(LINE(I2+1).EQ.'\'.OR.LINE(I2+1).EQ.'!')GOTO 7005
IF(IOLVL.EQ.11)GOTO 7005
C IF WE SEE ANYTHING EXCEPT A CONTROL CHAR OR \, REWIND THE FILE...
C THIS ALLOWS US TO HAVE A SORT OF "ENTER MODE" AND A "COMMAND MODE"
C A LA SUPERCALC ETC.
IF(LC.NE.'\'.AND.LC.GT.CHAR(32))REWIND IOLVL
C COMMENT OUT ANY TERMINAL COMMAND
IF(LC.EQ.'\'.OR.LC.EQ.'!'.OR.LC.LE.CHAR(32))LINBUF(1)='*'
GOTO 7005
7035 CONTINUE
C RECOVER AFTER CTL-Z ON EXPECTED INPUT.
C REWIND 5
LINBUF(1)='*'
CLOSE (IOLVL)
IF(IOLVL.EQ.11)OPEN(11,FILE='CON:40/150/300/40/Analy Command')
IOLVL=11
7005 CONTINUE
DO 7006 II=1,120
7006 LINE(II)=LINBUF(II)
GOTO 6501
C ALLOW RESCAN OF COMMAND LINE AFTER READ-IN.
C RETURN
C RETURN AFTER BUMPING IGOLD. COMMENT OUT CMD
7223 CONTINUE
LINE(1)='*'
RETURN
END
c -h- cmnd.f40 Fri Aug 22 13:00:17 1986
SUBROUTINE CMND(RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C ***************************************************
C * *
C * SUBROUTINE CMND *
C * *
C ***************************************************
C
C
C UPON ENTRANCE, NONBLK POINT TO THE "*" IN LINE
C INDICATING A COMMAND. THIS ROUTINE DETERMINES WHICH COMMAND
C IS DESIRED AND CALLS THE APPROPRIATE SUBROUTINE.
C
C RETCD:
C 1=NORMAL
C 2=BYPASS NEXT READ BECAUSE READ COMMAND HAS BEEN EXECUTED
C TO CHANGE LINE(80)
C 3=ERROR, SO GO TO 1000 TO SET LEVEL=1
C
C
C MODIFY CLASSES: M1
C
C
C CMND CALLS
C
C AT TO PROCESS A FILE OF CALC COMMANDS
C BASCNG TO CHANGE THE DEFAULT BASE FOR CONSTANTS
C CLOSE CLOSE FILE OF CALC COMMANDS
C DECLR DECLARE VAIABLES TO BE A CERTAIN DATA TYPE
C ERRMSG PRINTS ERROR MESSAGES
C EXIT RETURN TO OPERATING SYSTEM
C GETNNB GETS NEXT NON-BLANK FROM LINE(80)
C STRCMP LOOKS FOR A SPECIFIED STRING IN LINE(80)
C ZERO ZEROES ALL VARIABLES
C ZNEG TO SEE IF A VARIABLE HAS POSITIVE VALUE
C
C
C
C CMND IS CALLED BY CALC WHO HAS IDENTIFIED THE '*'
C INDICATING A COMMAND IS DESIRED.
C
C
C
C
C VARIABLE USE
C
C
C CCHAR TEMPORARILY HOLDS A SINGLE CHARACTER.
C DIGITS HOLDS ASCII REPRESENTATION OF DIGITS.
C I TEMPORARY INDEX.
C ID ARGUMENT FOR SUBROUTINE DECLR. INDICATES
C A PARTICULAR DATA TYPE.
C IPT POINTER FOR LINE(80).
C ITCNTV 0 IF NO ITERATION. IF POSITIVE, INDEX
C OF VARIABLE USED TO CONTROL ITERATION ON THAT LEVEL.
C KIND(15) HOLDS FIRST LETTER OF ALL LEGAL COMMANDS.
C LEVEL HOLDS LOGICAL I/O UNIT WHERE NEXT COMMAND COMES FROM.
C LINE(80) HOLDS COMMAND LINE.
C NONBLK POINTER FOR LINE(80).
C RETCD HOLDS RETURN CODE.
C RETCD2 HOLDS RETURN CODE.
C VIEWSW VIEW SWITCH:
C 0 = OFF
C 1 = DISPLAY COMMAND LINES
C 2 = DISPLAY VALUE OF EXPRESSIONS
C 3 = DISPLAY ALL
C
C
C
C SUBROUTINE CMND(RETCD)
C
C
C EXTERNAL INDX
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
C InTeGer*4 IOLVL
C COMMON/IOLVL/IOLVL
InTeGer*4 ZNEG,ITCNTV(6)
C InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
Character*1 WRK(130)
CHARACTER*1 WRKX(130),WRK2X(130)
CHARACTER*1 WRK2(128)
CHARACTER*35 CWRK,CWRKX,CWRK2
CHARACTER*11 CWRK2B
Character*1 wrk2b(11)
EQUIVALENCE(CWRK2B(1:1),WRK2(1),wrk2b(1))
EQUIVALENCE(CWRK2(1:1),WRK2(1))
EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
C EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
c EQUIVALENCE(WRK(1),WRKX(1))
EQUIVALENCE(WRK2(1),WRK2X(1))
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
InTeGer*4 TYPE(1,1),VLEN(9)
REAL*8 XAC,XVBLS(1,1)
INTEGER*4 JVBLS(2,1,1)
EQUIVALENCE(XAC,AVBLS(1,27))
EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
CHARACTER*1 FVLD(1,1)
COMMON/FVLDC/FVLD
C
CHARACTER*1 LINE(80),KIND(23),ASCII(4),DEC(6),HEX(2),INT(6),
; M10(2),M8(1),M16(2),OCTAL(4),REAL(3),CCHAR
CHARACTER*1 DIGITS(16,3)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /ITERA/ITCNTV
COMMON /DIGV/ DIGITS
C
DATA KIND
1/'@','A','B','C','D','E','H','I','M','N','O','R','S','V','Z'
2,'P','W','G','Q','F','J','X','U'/
C NOTE PWGQFJX ADDED BY GCE FOR PORTACALC INTERFACE.
C FREE: K,U,Y, + SPECIAL CHARACTERS (LIKE .,;'"#$%^, ETC.)
DATA ASCII/'S','C','I','I'/, DEC/'E','C','I','M','A','L'/
DATA HEX/'E','X'/, INT/'N','T','E','G','E','R'/
DATA M10/'1','0'/, M8/'8'/
DATA M16/'1','6'/
DATA OCTAL/'C','T','A','L'/
DATA REAL/'E','A','L'/
C DATA WRKX/130*0/,WRK2X/130*0/
C
C
C
C PICK UP NON-BLANK CHARACTER AFTER '*'
RETCD=1
CALL GETNNB(IPT,RETCD2)
GOTO(2,4),RETCD2
STOP 2
2 NONBLK=IPT
C NONBLK POINTS TO 1ST NONBLANK CHARACTER AFTER *
C
DO 3 I=1,23
IF (LINE(NONBLK).EQ.KIND(I)) GOTO 6
3 CONTINUE
C
C
C UNIDENTIFIED COMMAND
4 GOTO 995
C
C
C
C GO TO DIFFERENT SECTIONS ON THE BASIS OF THE FIRST CHARACTER
C OF THE COMMAND.
6 GOTO (10,20,30,1000,40,50,60,70,80,90,100,110,50,
1 130,140,210,220,250,290,330,360,480,780),I
STOP 6
C
C
C
C
C **************************************************
C ***** *@ INDIRECT COMMAND PROCESSING ******
C **************************************************
10 CALL AT(RETCD)
GOTO (1000,999),RETCD
STOP 10
C
C
C
C
C **************************************************
C ****** *A DECLARE TYPE ASCII ******
C **************************************************
20 CALL STRCMP (ASCII,4,RETCD2)
ID=1
GOTO (200,995),RETCD2
STOP 20
C
C
C
C
C **************************************************
C ****** *B BASE DEFAULT *******
C **************************************************
30 CONTINUE
CALL BASCNG(RETCD2)
IF(VIEWSW.NE.0)WRITE(11,34) BASED
34 FORMAT(' DEFAULT BASE IS ',I2)
GO TO (1000,999),RETCD2
STOP 30
C
C
C
C
C ********************************************************
C ** *C COMMENT, JUST RETURN (VIA STATEMENT 1000) **
C ********************************************************
C
C
C
C **************************************************
C ******* *D DECLARE TYPE DECIMAL *******
C **************************************************
40 CALL STRCMP(DEC,6,RETCD2)
ID=2
GOTO (200,995),RETCD2
STOP 40
C
C
C **************************************************
C ********** *E EXIT ********
C **************************************************
50 CONTINUE
C SET RETCD=4 ON EXIT IF EXIT COMMAND, SO CALC RETURNS TO ITS CALLER.
IF (LEVEL.EQ.1) RETCD=4
IF (LEVEL.EQ.1) RETURN
C IF (LEVEL.EQ.1) CALL EXIT
IF(ITCNTV(LEVEL).EQ.0)GOTO 55
IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
C ITERATION VARIABLE IS POSITIVE SO EXECUTE FILE AGAIN
REWIND LEVEL
GO TO 1000
C
C NOTE THAT WHEN EXITING A LEVEL THAT WAS ITERATED, ITCNTV
C IS NOT SET TO ZERO. THIS REQUIRES THAT WHEN ENTERED AT
C SUBROUTINE 'AT' AND ITERATION IS NOT DESIRED, THAT ITCNTV
C MUST BE SET TO ZERO THERE
55 CLOSE(LEVEL)
LEVEL=LEVEL-1
59 GOTO 1000
C
C
C
C
C
C **************************************************
C * *H DECLARE VARIABLES TO BE OF TYPE HEXADECIMAL *
C **************************************************
60 CALL STRCMP (HEX,2,RETCD2)
ID=3
GOTO (200,995),RETCD2
STOP 60
C
C
C
C
C **************************************************
C * *I DECLARE VARIABLE TO BE OF TYPE INTEGER (*4) *
C **************************************************
70 CALL STRCMP (INT,6,RETCD2)
ID=4
GOTO (200,995),RETCD2
STOP 70
C
C
C **************************************************
C * *M DECLARE VARIABLE TO BE MULTIPLE PRECISION *
C **************************************************
80 CALL STRCMP (M10,2,RETCD2)
ID=5
GOTO (200,84),RETCD2
STOP 80
C
C
C SEE IF MULTIPLE PRECISION IS OCTAL
84 CALL STRCMP (M8,1,RETCD2)
ID=6
GOTO (200,88),RETCD2
STOP 84
C
C
C SEE IF MULTIPLE PRECISION HEXADECIMAL
88 CALL STRCMP (M16,2,RETCD2)
ID=7
GOTO (200,995),RETCD2
STOP 88
C
C
C
C
C ************************************************************
C ** *N SUPPRESS PRINTING OF VARIABLES WHEN VALUES CHANGE **
C ************************************************************
90 VIEWSW=1
GOTO 1000
C
C
C
C
C **************************************************
C *** *O DECLARE VARIABLE TO BE OF TYPE OCTAL ***
C **************************************************
100 CALL STRCMP (OCTAL,4,RETCD2)
ID=8
GOTO (200,995),RETCD2
STOP 100
C
C
C
C
C
C **************************************************
C *********** *R ENCOUNTERED *************
C **************************************************
C
C *R SEE IF A REAL DECLARATION
110 CALL STRCMP (REAL,3,RETCD2)
ID=9
GOTO (200,114),RETCD2
STOP 110
C
C
C OTHERWISE ASSUME A READ IS REQUIRED
114 IF (LEVEL.NE.1) GOTO 117
Rewind 11
WRITE(11,116)
Rewind 11
GOTO 118
116 FORMAT(' CALR>',$)
117 Continue
Rewind 11
WRITE (11,119) LEVEL
Rewind 11
119 FORMAT (' CALC<',I1,'>',$)
118 Continue
c Rewind 11
READ (11,115,END=1000,ERR=990) LINE
Rewind 11
115 FORMAT (80A1)
C
C NOTE THAT IF <CR> IS HIT AS THE ONLY INPUT, RETURN IS NORMAL
C AND PROCESSING CONTINUES ON LEVEL (RETCD=2)
RETCD=2
GOTO 1000
C
C
C
C
C
C ************************************************************
C *** *V ACTIVATE PRINTING OF VARIABLE WHEN VALUES CHANGE ***
C ************************************************************
129 NONBLK=IPT
130 CALL GETNNB(IPT,RETCD2)
GO TO (129,132),RETCD2
STOP 130
132 CCHAR=LINE(NONBLK)
IF(CCHAR.NE.DIGITS(10,1))GO TO 134
C
C *VIEW 0 ENCOUNTERED
VIEWSW=0
GO TO 1000
134 IF(CCHAR.NE.DIGITS(1,1))GO TO 136
C
C *VIEW 1 ENCOUNTERED
VIEWSW=1
GO TO 1000
136 IF(CCHAR.NE.DIGITS(2,1))GO TO 138
VIEWSW=2
GO TO 1000
138 VIEWSW=3
GOTO 1000
C
C
C
C
C **************************************************
C ********** *Z ZERO OUT ALL VARIABLES ********
C **************************************************
140 CALL ZERO
GOTO 1000
C
C
C
C
C
C MAKE DECLARATIONS
200 CALL DECLR(ID,RETCD2)
GO TO(1000,999),RETCD2
STOP 200
C
C
C
C
C
C **** ERROR PROCESSING ****
C
990 I=27
REWIND LEVEL
GO TO 998
995 I=3
998 CALL ERRMSG(I)
999 RETCD=3
1000 CONTINUE
RETURN
C
C P COMMAND - SET PLACEMENT OF PHYSICAL POSN IN SHEET
C *P WILL PROMPT FOR INPUTS OF LOCATIONS.
C
210 CONTINUE
C
RETCD=1
CALL CMND2(RETCD,1)
RETURN
C W COMMAND - WRITE % TO CURRENT PHYSICAL LOC IN SHEET. USE E32.25
C FORMAT.
C DOES NOT PROMPT. THEREFORE, IF USED INSIDE SPREADSHEET, HAS THE
C EFFECT OF CONVERTING CURRENT CELL'S FORMULA TO A LITERAL NUMBER
C AND FREEZING IT THAT WAY. THEREFORE A FORMULA CONTAINING *W WILL
C NORMALLY ONLY EXECUTE THE *W ONCE (AFTERWARDS BEING OVERWRITTEN).
C
220 CONTINUE
RETCD=1
CALL CMND2(RETCD,2)
C
RETURN
C
C *G SEEN.
C THE SYNTAX OF *G IS *G V1,V2 WHICH WILL GET VALUE OF VBLS(G1,G2)
C AND LOAD IT INTO %. THE DIMENSIONS ARE CLAMPED TO LEGAL BOUNDS
C AND TYPE=4 MEANS USE INTEGER, TYPE=2 CONVERTS VARIABLES TO
C INTEGER. CALLS VARSCN TO DO THIS STUFF.
C THIS GIVES A MEASURE OF INDIRECTION.
250 CONTINUE
RETCD=1
C SAY ALL'S WELL.
CALL CMND2(RETCD,3)
C
RETURN
C
C *Q QUERY DATABASE COMMAND
C
C
290 CONTINUE
RETCD=1
CALL CMND2(RETCD,4)
C
RETURN
C
C *F LABEL GOTO LABEL COMMAND (CONDITIONAL)
C
C
C THE SYNTAX OF THE *F COMMAND IS :
C *F LABEL
C WITH THE OPERATION OF LOCATING A LINE BEGINNING WITH THE
C STRING "*CLABEL" (SO IT IS PASSED OVER BY NORMAL CALC
C PROCESSING). THE INPUT FILE ON IOLVL IS REWOUND AND
C SCANNING GOES TO THE EOF OR UNTIL THE STRING IS FOUND.
C RETCD=2 IF NO SUCH LABEL IS FOUND.
C
C AS A FURTHER AID, IF THE % VARIABLE IS 0 OR NEGATIVE, THE
C COMMAND IS IGNORED.
330 CONTINUE
RETCD=1
CALL CMND2(RETCD,5)
C
RETURN
C
C *J LABEL - JUST LIKE *F LABEL BUT ON CALC'S COMMAND FILES.
C I.E., FINDS A LINE STARTING WITH *CLABEL
C (NOTE IT STARTS FROM START OF FILE AND DOES THIS ONLY IF % IS POSITIVE).
C ITERATION OF COMMAND FILES REMAINS UNDER NORMAL CONTROL.
360 CONTINUE
RETCD=1
CALL CMND2(RETCD,6)
RETURN
C *X COMMAND
C XC FILESPEC CELLNAME
C READS FILESPEC AS A SAVED SPEADSHEET (NUMERIC OR FORMULA)
C AND LOADS ITS VALUE INTO CURRENT CELL AND % ACCUMULATOR. DOES
C NOT LOAD FORMULA UNLESS F SEEN. THUS 2 VARIANTS:
C *XF FILESPEC CELLNAME LOAD FORMULA AND VALUE
C *XV FILESPEC CELLNAME LOAD VALUE
C NOTE ANY CHARACTER AFTER *X THAT ISN'T "F" IS EQUIVALENT TO V FOR EASY USE.
480 CONTINUE
RETCD=1
CALL CMND2(RETCD,7)
RETURN
C *U FUNCTION ARGS
C HANDLE USER FUNCTION CALL...
780 CONTINUE
RETCD=1
C PASS LINE AND ARGS TO SUBROUTINE TO PARSE (EXTERNALIZE THE WORK)
C COMMON /V/ HAS DATA NEEDED FOR ARGUMENTS...
CALL USRFCT(LINE,RETCD,WRK2)
C IF RETCD CHANGES IN USRFCT THIS ALLOWS ERROR CODES BACK.
RETURN
END
c -h- cmnd2.f40 Fri Aug 22 13:00:17 1986
SUBROUTINE CMND2(RETCD,I)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C
C EXTRA ROUTINES MOVED HERE FROM INSIDE CMND SO THAT THEY CAN BE OVERLAIN IN
C 256K VERSION TO GAIN A GREAT DEAL OF SPACE.
EXTERNAL INDX
InTeGer*4 LEVEL,NONBLK,LEND
InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
C InTeGer*4 IOLVL
C COMMON/IOLVL/IOLVL
InTeGer*4 ZNEG,ITCNTV(6)
C InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
CHARACTER*1 WRK2(128),LETA
CHARACTER*35 CWRK,CWRKX,CWRK2
CHARACTER*50 CWRK50
EQUIVALENCE (CWRK50(1:1),CWRK(1:1))
CHARACTER*11 CWRK2B
Character*1 wrk2b(11)
CHARACTER*1 WRKX(130),WRK2X(130)
Character*1 WRK(128)
EQUIVALENCE(CWRK2B,WRK2(1),Wrk2b(1),Cwrk2)
c EQUIVALENCE(CWRK2,WRK2(1))
EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
C EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
c EQUIVALENCE(WRK(1),WRKX(1))
EQUIVALENCE(WRK2(1),WRK2X(1))
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
InTeGer*4 TYPE(1,1),VLEN(9)
REAL*8 XAC,XVBLS(1,1)
INTEGER*4 JVBLS(2,1,1)
EQUIVALENCE(XAC,AVBLS(1,27))
EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
CHARACTER*1 FVLD(1,1)
COMMON/FVLDC/FVLD
C
CHARACTER*1 LINE(80),CCHAR
CHARACTER*1 DIGITS(16,3)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /ITERA/ITCNTV
COMMON /DIGV/ DIGITS
C I ARGUMENT SELECTS COMMAND.
C 1 = *P
C 2 = *W
C 3 = *G
C 4 = *Q
C 5 = *F
C 6 = *G
C 7 = *X
IF(I.NE.1)GOTO 7000
C *P COMMANDS
C IF THE COMMAND IS *P VAR THEN SET TO VARIABLE LOCATION.
KK1=3
KK2=20
IF(LINE(3).EQ.'@')GOTO 217
C ONLY LOOK IN COLS 3-20. COLUMNS 1,2 ARE THE *W COMMAND.
CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
IF(IVLD.NE.0)GOTO 216
GOTO 218
217 CONTINUE
C ALLOW *W@V1,V2 TO GOTO LOCATION OF V1,V2 (COL,ROW)
C THIS ALLOWS PROGRAMMED ACCESS TO VARIABLES.
L1=4
L2=60
CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
IF(IVLD1.EQ.0)GOTO 1000
CALL TYPGET(ID1A,ID2A,TYPE(1,1))
IF(TYPE(1,1).EQ.2)GOTO 219
CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
LCL=JVBLS(1,1,1)
GOTO 2200
219 CONTINUE
CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
LCL=XVBLS(1,1)
2200 CONTINUE
C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
L1=LSTCH+1
L2=60
C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
IF(IVLD2.EQ.0)GOTO 1000
C SEEMS LIKE OK VARIABLE... GO AHEAD
CALL TYPGET(ID1B,ID2B,TYPE(1,1))
CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
LRW=JVBLS(1,1,1)
IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
LRW=LRW+1
C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
C CLAMPING TO MAX VALUES.
LCL=MAX0(1,LCL)
LRW=MAX0(1,LRW)
LCL=MIN0(LCL,60)
LRW=MIN0(LRW,301)
KK=LCL
KKK=LRW
GOTO 216
218 CONTINUE
rewind 11
IF(LEVEL.EQ.1)WRITE(11,211)
211 FORMAT(' SET PHYS LOC. COLUMN=')
rewind 11
LLLV=LEVEL
IF(LEVEL.EQ.1)LLLV=11
READ(LLLV,212,END=700,ERR=700)KK
212 FORMAT(I7)
rewind 11
IF(LEVEL.EQ.1)WRITE(11,213)
213 FORMAT(' SET PHYS LOC. ROW =')
rewind 11
READ(LLLV,212,END=700,ERR=700)KKK
rewind 11
KKK=KKK+1
216 KK=MAX0(1,KK)
KKK=MAX0(1,KKK)
KK=MIN0(60,KK)
KKK=MIN0(301,KKK)
C CLAMP TO LEGAL SIZE
PROW=KK
PCOL=KKK
C
RETURN
C TERMINAL READ ERROR AND END PROCESSING
700 CONTINUE
IF(LEVEL.EQ.1)CLOSE(11)
IF(LEVEL.EQ.1)OPEN(11,FILE='CON:20/100/300/40/Analy Command')
IF(LEVEL.NE.1)REWIND LEVEL
IF(ITCNTV(LEVEL).EQ.0)GOTO 55
IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
RETURN
7000 CONTINUE
IF(I.NE.2)GOTO 7200
C *W COMMANDS
C IRX=(PCOL-1)*60+PROW
CALL REFLEC(PCOL,PROW,IRX)
CALL WRKFIL(IRX,WRK,0)
C READ(7'IRX)WRK
C GET RECORD INTO MEMORY
IF(LINE(3).EQ.'F')GOTO 224
WRITE(CWRK(1:35),221)XAC
C ENCODE(35,221,WRK)XAC
C PUT VARIABLE VALUE AS STRING INTO FILE BUFFER
221 FORMAT(D32.25)
GOTO 225
224 CONTINUE
C WRITE AND USE LOCAL FORMAT
WRK2(1)='('
DO 226 K=1,9
WRK2(1+K)=WRK(119+K)
226 CONTINUE
WRK2(11)=')'
WRITE(CWRK(1:35),WRK2B)XAC
225 CONTINUE
DO 222 K=36,110
222 WRK(K)=CHAR(32)
CALL WRKFIL(IRX,WRK,1)
C WRITE(7'IRX)WRK
RETURN
7200 CONTINUE
IF(I.NE.3)GOTO 7400
C *G COMMANDS
L1=3
L2=60
CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
IF(IVLD1.EQ.0)GOTO 1000
CALL TYPGET(ID1A,ID2A,TYPE(1,1))
IF(TYPE(1,1).EQ.2)GOTO 251
CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
LCL=JVBLS(1,1,1)
GOTO 252
251 CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
LCL=XVBLS(1,1)
252 CONTINUE
C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
L1=LSTCH+1
L2=60
C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
IF(IVLD2.EQ.0)GOTO 1000
C SEEMS LIKE OK VARIABLE... GO AHEAD
CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
CALL TYPGET(ID1B,ID2B,TYPE(1,1))
LRW=JVBLS(1,1,1)
IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
LRW=LRW+1
C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
C CLAMPING TO MAX VALUES.
LCL=MAX0(1,LCL)
LRW=MAX0(1,LRW)
LCL=MIN0(LCL,60)
LRW=MIN0(LRW,301)
C RETURN VALUE.
CALL TYPGET(LCL,LRW,TYPE(1,1))
IF(TYPE(1,1).EQ.2)CALL XVBLGT(LCL,LRW,XAC)
IF(TYPE(1,1).NE.2)CALL JVBLGT(1,LCL,LRW,JVBLS(1,1,1))
IF(TYPE(1,1).NE.2)XAC=JVBLS(1,1,1)
C USE IMPLICIT CONVERSION FROM FORTRAN HERE. NOTE WE RETURN WITH
C THE LOOKED UP VALUE IN XAC.
RETURN
7400 CONTINUE
IF(I.NE.4)GOTO 7600
C *Q COMMANDS
C *Q QUERY DATABASE COMMAND
C
C
C THIS COMMAND IS DESIGNED TO PERMIT CALC TO ACCESS SEQUENTIAL (FOR NOW)
C FILES AND PULL IN VALUES. ARRAY WRK IS USED TO HOLD THE RECORDS AND
C MAY DISPLAY WHATEVER IS DESIRED.
C
C OPERATION IS AS FOLLOWS:
C
C *QW/F filespec ?KEYSTRING? <cc>
C WHERE THE W/F FLAG MEANS WRITE TO FORMULA AT CURRENT LOC (MAYBE MODIFIED
C EARLIER BY THE *P COMMAND) AND F FLAG MEANS RETURN % AS VALUE OBTAINED BY
C ATTEMPTING A DECODE ON THE FILE LINE BETWEEN DELIMITER CHARACTERS
C cc GIVEN INSIDE CHARACTERS. FILE IS ASSUMED TO START WITH
C "KEYSTRING" WHERE ANY CHARACTER IS A MATCH EXACTLY EXCEPT THAT
C THE _ CHARACTER INDICATES A WILDCARD.
C SPECIAL CASES:
C IF ` IS 1ST CHAR OF KEYSTRING, RECORDS MUST HAVE KEYSTRING STARTING
C AT COL 1 (EXCLUDING THE `)
C IF <CC> STRING HAS ` AS 1ST CHARACTER, THEN IT IS OF FORM
C <`NM> WHERE N=ASCII CODE FOR COLUMN WANTED + 32 AND M = ASCII CODE
C FOR LENGTH DESIRED + 32
C THIS ALLOWS POSITIONAL RETRIEVAL (THOUGH PAINFULLY)
C
C A SECOND KEYSTRING MAY BE ENTERED INSIDE A SECOND PAIR OF ? CHARACTERS TOO.
C THE SEARCH WILL SEEK THE KEYS ANYWHERE IN THE RECORDS READ, UP TO 128
C CHARACTERS LONG EACH.
C SECOND KEYSTRING MAY NOT BE ANCHORED TO START OF LINE.
C AS AN ADDED ATTRACTION:
C *QFK OR *QFN WON'T CLOSE LUN 4 AT END. IN ADDITION *QFN WON'T
C CLOSE IT AT START EITHER ALLOWING SEQUENTIAL RETRIEVALS OUT OF
C DATA FILES. DITTO *QW VARIANTS.
C IRX=(PCOL-1)*60+PROW
CALL REFLEC(PCOL,PROW,IRX)
C IF(LINE(3).EQ.'W')READ(7'IRX)WRK
IF(LINE(3).EQ.'W')CALL WRKFIL(IRX,WRK,0)
IF(LINE(3).NE.'W'.AND.LINE(3).NE.'F')RETURN
IL=INDX(LINE,32)
IF(IL.GT.40)GOTO 299
IL2=INDX(LINE(IL+1),32)
IF(IL2.GT.38)GOTO 299
C ENSURE LUN 4 AVAILABLE
IF(LINE(4).NE.'C'.AND.LINE(4).NE.'N')CLOSE(4)
LINE(IL2+IL)=CHAR(0)
IF(LINE(4).NE.'N'.AND.LINE(4).NE.'C')
1 CALL RASSIG(4,LINE(IL+1))
C THIS MAKES LUN 4 BE THE ONE WE WANT
LINE(IL2+IL)=CHAR(32)
KKK=ICHAR('?')
IQ1=INDX(LINE,KKK)
C LOCATE THE KEY
IF(IQ1.GE.70)GOTO 299
KKK=ICHAR('?')
IQ2=INDX(LINE(IQ1+1),KKK)
IF(IQ2.GE.72)GOTO 299
C NOW KNOW KEY IS IQ2-1 LONG, STARTS AT IQ1+1
C
C ALLOW DOUBLE KEYS IF ANOTHER ?? PAIR IS SEEN.
KEYS2=0
KKK=ICHAR('?')
IQ3=INDX(LINE(IQ1+IQ2+1),KKK)
IF(IQ3.GT.3)GOTO 297
C WELL, THERE'S A 2ND STRING THERE MAYBE.
IQ4=INDX(LINE(IQ3+IQ1+IQ2+1),KKK)
IF(IQ4.GT.30)GOTO 297
IF(IQ4.EQ.1)GOTO 297
KEYS2=1
C FLAG WE HAVE A SECOND KEY. SOMETHING'S THERE.
LCL=IQ3+IQ2+IQ1+1
LRW=LCL+IQ4-1
297 READ(4,332,END=299,ERR=299)WRK2
IQQ=IQ2-1
IXX=128-IQ2
C COMPARE THE ENTIRE RECORD FOR THE KEY, MATCH ANYWHERE.
IF(LINE(IQ1+1).NE.'`')GOTO 376
C IF 1ST CHAR OF KEY IS ` THEN SEARCH BEGINS AT LINE START ONLY. KEY IS
C 1 LESS.
IQ1=1+IQ1
IXX=1
IQQ=IQQ-1
C ADJUST SO SEARCH IS 1 CHAR LESS.
376 CONTINUE
DO 350 KKK=1,IXX
CALL SCMP(LINE(IQ1+1),WRK2(KKK),IQQ,ICOD)
IF(ICOD.NE.0)GOTO 351
350 CONTINUE
C DON'T JUST FALL THRU
GOTO 353
351 CONTINUE
IF(KEYS2.EQ.0)GOTO 353
C CHECK SECOND KEY STRING IN RECORD IF ANY WAS ASKED FOR.
C (THAT'S ALL YOU GET. 2 KEYS MAX.)
C LINE(LCL) TO LINE(LRW) CONTAINS KEY.
IXY=128-IQ4+1
ICC=IQ4-1
DO 354 KKK=1,IXY
CALL SCMP(LINE(LCL),WRK2(KKK),ICC,ICOD)
IF(ICOD.NE.0)GOTO 355
354 CONTINUE
355 CONTINUE
353 IF(ICOD.EQ.0)GOTO 297
C HERE FOUND THE KEYED RECORD. NOW EXAMINE COMMAND LINE FOR
C SPECIAL CHARACTERS. IF NONE, JUST COPY THE FIRST CHARACTERS
C IN THE TEXT INTO EITHER THE BUFFER OR ENCODE THEM.
KKK=ICHAR('<')
IQ1=INDX(LINE,KKK)
IF(IQ1.LE.0.OR.IQ1.GT.75)GOTO 296
KKK=ICHAR('>')
IQ2=INDX(LINE(IQ1+1),KKK)
IF(IQ2.LE.0.OR.IQ2.GT.8)GOTO 296
KKQ=ICHAR(LINE(IQ1+1))
KK=INDX(WRK2,KKQ)
C MUNGE THE SEARCH SO THAT IF THE SPECIAL CHAR IS ` THEN THE NEXT 2
C CHARACTERS HAVE START AND LENGTH ENCODED AS ASCII CODE -32 DECIMAL
C WHICH ALLOWS FIELDS TO BE PLACED ANYWHERE (THOUGH SOMEWHAT PAINFULLY)
IF(LINE(IQ1+1).EQ.'`')KK=ICHAR(LINE(IQ1+2))-32
IF(KK.GT.125)GOTO 299
C NOTE THAT THE KEY FORM WOULD THEN GIVE
C <`!@> FOR START COLUMN=1 AND LENGTH =32 (ASCII 64 = @ AND ASCII 33 = !)
C THIS MEANS USER HAS TO KNOW ASCII ORDER BUT AT LEAST IT'S IN MANUAL.
IF(LINE(IQ1+1).EQ.'`')KKK=ICHAR(LINE(IQ1+3))-32
KKQ=ICHAR(LINE(IQ1+2))
IF(LINE(IQ1+1).NE.'`')KKK=INDX(WRK2(KK+1),KKQ)+KK
GOTO 295
296 CONTINUE
C DEFAULT, NO SPECIAL CHARS.
KK=0
KKK=110
295 CONTINUE
KL=KKK-KK-1
KK=KK+1
IF(LINE(3).NE.'W')GOTO 294
KL=MIN0(KL,109)
DO 293 N=1,KL
WRK(N)=WRK2(KK)
293 KK=KK+1
WRK(KL+1)=0
C WRITE OUT THE RECORD'S KEY PART INTO SHEET FILE
CALL WRKFIL(IRX,WRK,1)
C WRITE(7'IRX)WRK
XAC=1.
GOTO 298
294 CONTINUE
C FLOAT THE VALUE, RETURN IN XAC
DO 750 N=1,35
WRK(N)=CHAR(32)
IF(N.LE.KL)WRK(N)=WRK2(KK-1+N)
750 CONTINUE
READ(CWRK(1:35),221,ERR=299)XAC
C DECODE(KL,221,WRK2(KK),ERR=299)XAC
298 CONTINUE
C IF IT'S A KEEP OR NEXT TYPE OPERATION, LEAVE LUN 4 OPEN.
C FIRST ONE MUST BE A KEEP (TO OPEN FILE IN THE FIRST PLACE)
C AND SUBSEQUENT OPERATIONS MAY BE A N OPERATIONS, WHICH
C WILL JUST CONTINUE SEQUENTIAL READIN OF DATA. USER HAS TO
C KEEP TRACK. NOTE RETURN VALUE IS -999999. (6 9'S) IF WE
C FAIL AND HAVE TO CLOSE FILE.
IF(LINE(4).EQ.'K'.OR.LINE(4).EQ.'N')RETURN
CLOSE(4)
RETURN
299 CONTINUE
C RETURN -999999 IF WE FAIL IN FINDING FILE.
XAC=-999999.
CLOSE(4)
C COME HERE FOR NON-RECOVERABLE ERRORS IN FORMAT TOO.
C
RETURN
7600 CONTINUE
IF(I.NE.5)GOTO 7800
C *F COMMANDS
IF(XAC.LE.0)RETURN
REWIND IOLVL
IF(IOLVL.EQ.11)RETURN
333 READ(IOLVL,332,END=331,ERR=331)WRK
332 FORMAT(128A1)
IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 333
ISSL=2
ISSS=2
IF(LINE(3).EQ.' ')ISSL=3
IF(WRK(3).EQ.' ')ISSS=3
CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
IF(ICODE.EQ.0)GOTO 333
RETURN
C ERROR ENTRY WHERE WE SEE WE FAILED TO FIND LABEL.
331 CONTINUE
IF(IOLVL.NE.11)CLOSE(IOLVL)
IOLVL=11
RETCD=2
C
RETURN
7800 CONTINUE
IF(I.NE.6)GOTO 8000
C *G
IF(LEVEL.EQ.1.OR.XAC.LE.0)RETURN
REWIND LEVEL
363 READ(LEVEL,362,END=55,ERR=55)WRK
362 FORMAT(128A1)
IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 363
ISSL=2
ISSS=2
IF(LINE(3).EQ.' ')ISSL=3
IF(WRK(3).EQ.' ')ISSS=3
CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
IF(ICODE.EQ.0)GOTO 363
C
RETURN
8000 CONTINUE
IF(I.NE.7)GOTO 8200
C *X COMMANDS
C NOW GET THE ARGS
JFFG=0
IF(LINE(3).EQ.'F')JFFG=1
C NOW HAVE FORMULA FLAG.
IQ3=4
C ALLOW 1 SPACE OPTIONALLY
IF(LINE(IQ3).EQ.' ')IQ3=5
IQ1=INDX(LINE(IQ3),32)
IQ1=IQ1+IQ3-1
C NULL TERMINATE FILENAME WHILE PARSING IT (DON'T LET ASSIGN SEE VBL NAME)
LINE(IQ1)=0
CLOSE(4)
9770 CALL RASSIG(4,LINE(IQ3))
C REPLACE THE SPACE FOR VARSCN'S SIGHT
LINE(IQ1)=CHAR(32)
C IQ1 NOW HAS START INDEX FOR VARSCN DESIRED... GO GET VRBL NAME.
KK1=IQ1
KK2=IQ1+20
CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
IF(IVLD.LE.0)GOTO 481
C GOT VALID VARIABLE NAME. KK,KKK ARE ROW,COL
C NOW WE KNOW HOW TO RETRIEVE THE DATA OFF FILE IN UNIT 4
C READ INTO WRK ARRAY TILL WE GET IT.
IQ3=KK
IQ4=KKK-1
483 READ(4,332,END=488,ERR=488)WRK
C IGNORE TITLE
486 CONTINUE
C NOTE WE READ IN THE NUMBER IN NUMERIC FORMAT. EASIER THAT WAY.
c IF(JFFG.EQ.0)READ(4,484,END=488,ERR=488)IRRW,ICCL,XYVAL
c IF(JFFG.NE.0)READ(4,489,END=488,ERR=488)IRRW,ICCL,
c 1 (WRK(IV),IV=1,110)
c484 FORMAT(1X,I5,1X,I5,1X,E50.35)
c489 FORMAT(1X,I5,1X,I5,1X,110A1)
READ(4,484,END=488,ERR=488)LETA,IRRW,ICCL,
1 (WRK(IV),IV=1,110)
C ALWAYS READ TEXT AS ALPHA
READ(CWRK50(1:50),6486,ERR=5486)XYVAL
C DECODE AND STORE IN XYVAL IF POSSIBLE
6486 FORMAT(BN,D50.35)
5486 CONTINUE
C HACK OUT TRAILING BLANKS
DO 5322 IV=1,110
IVV=111-IV
IF(ICHAR(WRK(IVV)).GT.32)GOTO 5323
WRK(IVV)=CHAR(0)
5322 CONTINUE
5323 CONTINUE
C &&&&
484 FORMAT(1A1,I5,1X,I5,1X,110A1,50A1)
READ(4,485,END=488,ERR=488)LFVLD,(WRK(IV),IV=120,128),KKTYP
C ALLOW FLAG OF 3 FOR NUMERIC,RECALCULATE... 2 FOR NUMERIC, NO RECALC.
C 1 CONTINUES TO MEAN ALWAYS RECALCULATE.
IF(LFVLD.LT.-1)LFVLD=-3
IF(LFVLD.GT.1)LFVLD=3
C
485 FORMAT(I3,1X,9A1,1X,I5)
C READS IN AN ENTRY OF SAVED SHEET. TEST IF IN OUR RANGE.
IF(IRRW.EQ.IQ3.AND.ICCL.EQ.IQ4)GOTO 487
GOTO 486
487 CONTINUE
C SUCCESS. NOW FILL IN VALUE OR FORMULA.
IF(JFFG.EQ.0)GOTO 6487
C IF READING IN FORMULA, TRY AND GET VALUE OUT OF VALUE
C RECORD
IF(LETA.NE.'p')GOTO 6487
C OK, THIS IS A VALUE RECORD WHICH SHOULD BE IMMEDIATELY FOLLOWED
C BY A FORMULA RECORD.
C JUST DECODE THE VALUE AND RECORD IT.
C ... ACTUALLY IT'S ALREADY DECODED SO JUST RECORD IT.
CALL XVBLST(PROW,PCOL,XYVAL)
XAC=XYVAL
C GO BACK AND GET FORMULA
GOTO 486
6487 CONTINUE
C IRX=(PCOL-1)*60+PROW
CALL REFLEC(PCOL,PROW,IRX)
WRK(118)=CHAR(15)
WRK(119)=CHAR(LFVLD)
CALL FVLDST(PROW,PCOL,LFVLD)
C FVLD(PROW,PCOL)=LFVLD
C SET UP TO SAVE FORMULA.
C SAVE EITHER FORMULA OR VALUE.
IF(JFFG.EQ.0)GOTO 4890
CALL CA2E(WRK,WRK2)
CALL WRKFIL(IRX,WRK2,1)
GOTO 488
4890 CONTINUE
C SET UP NUMBER IF HERE.
CALL TYPSET(PROW,PCOL,KKTYP)
C TYPE(PROW,PCOL)=KKTYP
CALL FVLDST(PROW,PCOL,LFVLD)
C FVLD(PROW,PCOL)=LFVLD
CALL XVBLST(PROW,PCOL,XYVAL)
C XVBLS(PROW,PCOL)=XYVAL
XAC=XYVAL
488 CONTINUE
CLOSE(4)
RETURN
481 CONTINUE
CLOSE(4)
RETCD=2
C
RETURN
8200 CONTINUE
55 CLOSE(LEVEL)
LEVEL=LEVEL-1
1000 CONTINUE
RETURN
END
c -h- contyp.for Fri Aug 22 13:00:17 1986
SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C * *
C * SUBROUTINE CONTYP *
C
C
C CONVERTS CONSTANT IN STACK(I,INDXX) FROM OLDTYP TO NEWTYP
C IF OLDTYP.EQ.NEWTYP A RETURN IS MADE IMMEDIATELY.
C NOTE THAT TYPE(INDXX) IS NOT CHANGED BY THIS ROUTINE
C TYPE CODES:
C
C 0 NO CHANGE
C 1 ASCII
C 2 DECIMAL
C 3 HEXADECIMAL
C 4 INTEGER
c note: multiple precision conversions diked out
C 5 M10
C 6 M8
C 7 M16
C 8 OCTAL
C 9 REAL
C
C RETCD MEANING
C
C 1 O.K.
C 2 ERROR
C
C
C MODIFY CLASSES: M3,M4,M8
C
C CONTYP CALLS:
C
C ERRMSG PRINTS OUT ERROR MESSAGES
C MULCON CONVERTS MULTIPLE PRECISION TO MULTIPLE PRECISION
C OF A DIFFERENT BASE
C
C
C
C CONTYP IS CALLED BY
C
C CALUN CALCULATES UNARY OPERATIONS
C CALBIN CALCULATES BINARY OPERATIONS
C VARIABLE USE
C
C BASE HOLDS BASE OR POWERS OF THAT BASE (INTEGER*4).
C BASVEC HOLDS LEGAL BASES: 8,10, AND 16
C EIGHT(8) CHARACTER*1 ARRAY TO PICK OFF REAL*8 VALUES.
C FOUR(4) CHARACTER*1 ARRAY TO PICK OFF INTEGER*4 VALUES.
C I,J,M TEMPORARY VALUES.
C IBASE HOLDS BASE OF A NUMBER WHEN BASE HOLDS THE POWERS
C OF THAT BASE.
C IEND HOLDS THE NUMBER OF MULTIPLE PRECISION DIGITS THAT
C WILL BE PICKED UP WHEN CONVERTING TO INTEGER*4.
C INDXX POINTER TO VARIABLE BEING CONVERTED.
C INT HOLDS INTEGER*4 VALUES EQUIVALENCED TO VECTOR FOUR.
C IS TEMPORARILY HOLDS MULTIPLE PRECISION BASE 8 OR BASE
C 16 DIGITS.
C IS2 TEMPORARILY HOLDS A DIGIT VALUE WHEN CHECKING MULTIPLE
C PRECISION BASE 8 AND BASE 16 NUMBERS TO SEE IF THEY
C ARE TOO LARGE TO FIT IN INTEGER*4.
C ISGN USED WHEN DETERMINING THE MAXIMUM NUMBER THAT CAN BE
C HELD BY INTEGER*4. 1=POSITIVE, 2= NEGATIVE. ALSO HOLDS
C 0 OR 7 FOR BASE 8 MAXIMUM NUMBER CHECK. HOLDS 0 OR 15
C FOR BASE 16 MAXIMUM NUMBER CHECK.
C K TEMPORARILY HOLDS INTEGER*4 VALUES.
C NEWTYP NEW DATA TYPE REQUESTED.
C OLDTYP DATA TYPE OF THE VARIABLE TO BE CONVERTED.
C RBASE BASE WHEN CONVERTING FROM MULTIPLE PRECISION TO REAL*8.
C REAL HOLDS REAL*8 VALUES. EQUIVALENCED TO ARRAY EIGHT.
C RETCD RETURN CODE. 1=O.K. 2=ERROR.
C RPOWER HOLDS POWERS OF RBASE WHEN CONVERTING FROM MULTIPLE
C PRECISION TO REAL*8.
C STACK(I,INDXX) HOLDS VARIABLE TO BE CONVERTED.
C
C
C SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
C
REAL*8 REAL,RBASE,RPOWER,DFLOAT
C
INTEGER*4 K,INT,BASE
C
InTeGer*4 OLDTYP,NEWTYP,RETCD,BASVEC(3),INDXX
InTeGer*4 MAX10(10,2)
InTeGer*4 I,M,J
InTeGer*4 ISGN,IS,IS2
C
CHARACTER*1 EIGHT(8),FOUR(4)
CHARACTER*1 STACK(8,40)
C
EQUIVALENCE (FOUR,INT),(REAL,EIGHT)
C
DATA BASVEC/10,8,16/
DATA MAX10/2,1,4,7,4,8,3,6,4,7,2,1,4,7,4,8,3,6,4,8/
C
C
C SET DEFAULT RETURN CODE
RETCD=1
IF(OLDTYP.GT.0)GO TO 910
C
C VARIABLE UNDEFINED
CALL ERRMSG(16)
RETCD=2
RETURN
C
C
C
910 IF(NEWTYP.EQ.0) RETURN
IF (OLDTYP.EQ.NEWTYP) RETURN
GOTO (1000,2000,3000,3000,4000,5000,6000,3000,2000), OLDTYP
STOP 1000
C
C
C
C **************************************************
C ************** OLDTYP = ASCII ******************
C **************************************************
C
C START BY CONVERTING TO INTEGER*4
1000 CONTINUE
C
C
C IF INTEGER, HEXADECIMAL OR OCTAL, ALMOST DONE
DO 1002 I=2,8
1002 STACK(I,INDXX)=0
IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
C
C
C
DO 1008 I=1,4
1008 FOUR(I)=STACK(I,INDXX)
IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) GOTO 1200
C
C
C MULTIPLE PRECISION
1010 continue
RETURN
C
C
C DECIMAL OR REAL
1200 REAL=DFLOAT(INT)
DO 1210 I=1,8
1210 STACK(I,INDXX)=EIGHT(I)
RETURN
C
C
C
C **************************************************
C ********* OLDTYP = DECIMAL OR REAL *************
C **************************************************
C
2000 IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) RETURN
C
C
DO 2002 I=1,8
2002 EIGHT(I)=STACK(I,INDXX)
C
C
C ZERO STACK(I,INDXX)
DO 2004 I=1,8
2004 STACK(I,INDXX)=CHAR(0)
C
C
C CONVERT TO INTEGER
C MAKE SURE CONVERSION DOESN'T BLOW UP
IF(REAL.LT.-2147483648.D0.OR.REAL.GT.2147483647.D0)
1 GOTO 6050
C
C
C
2007 INT=REAL
C
C SEE IF NEWTYP IS MULTIPLE PRECISION
IF (NEWTYP.GE.5.AND.NEWTYP.LE.7) GOTO 1010
DO 2008 I=1,4
2008 STACK(I,INDXX)=FOUR(I)
C
C RETURN IF TYPE IS INTEGER, HEX, OR OCTAL
IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
C
C ASCII SO CLEAR OUT BYES 2,3, AND 4
2009 DO 2010 I=2,4
2010 STACK(I,INDXX)=CHAR(0)
RETURN
C
C
C
C
C
C
C **************************************************
C ******* OLDTYP = INTEGER, HEX, OR OCTAL ********
C **************************************************
C
3000 IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
DO 3002 I=1,4
3002 FOUR(I)=STACK(I,INDXX)
C
C SEE IF NEWTYP IS ASCII
IF (NEWTYP.EQ.1) GOTO 2009
C
C IF NOT REAL*8 THEN IT IS MULTIPLE PRECISION (PROCESS AT 1010)
IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 1010
C
C PROCESS AS REAL*8
GOTO 1200
C
C ************* OLDTYP = M10 *********************
C
4000 CONTINUE
RETURN
4040 continue
RETURN
C
C ************** OLDTYP = M8 *********************
C
5000 CONTINUE
C *************** OLDTYP = M16 *******************
C
6000 CONTINUE
RETURN
C
C ***** ERROR RETURN ******
6050 RETCD=2
C ILLEGAL CONVERSION ATTEMPTED.
CALL ERRMSG(26)
RETURN
C
END
c -h- imask.for Fri Aug 22 12:54:45 1986
INTEGER FUNCTION IMASK(I1,I2)
InTeGer*4 I1,I2
InTeGer*4 IXX
IXX=I1.AND.I2
IMASK=IXX
RETURN
END
REAL*8 FUNCTION DFLOAT(IN)
INTEGER IN
REAL*8 XX
XX=IN
DFLOAT=XX
RETURN
END