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 >
Text File  |  1988-04-11  |  101KB  |  4,002 lines
  1. c -h- analy.for    Fri Aug 22 12:54:45 1986    
  2.        PROGRAM ANALY(INPUT=15,OUTPUT=16,TAPE=17,ERR=1)
  3. C PORTACALC MAIN PROGRAM
  4. C SPREAD SHEET DRIVER PROGRAM
  5. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  6. C ALL RIGHTS RESERVED
  7. C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
  8. C PARAMETER 18060=60*301
  9. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  10. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  11. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  12. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  13. C FROM THE DISK BASED FILE HERE.
  14. C
  15.     InTeGer*4 PRL(6)
  16.         CHARACTER*1 NOWRAP ( 2 )
  17.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  18.     INTEGER*4 VNLT
  19.     INTEGER IFCW
  20. C    EXTERNAL LCWRQQ
  21.     DIMENSION FORM(128),FVLD(1,1)
  22. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  23. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  24. C SO INITIALLY IGNORE.
  25. C
  26. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  27. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  28. C
  29. C ***<<<< RDD COMMON START >>>***
  30.     InTeGer*4 RRWACT,RCLACT
  31. C    COMMON/RCLACT/RRWACT,RCLACT
  32.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  33.      1  IDOL7,IDOL8
  34. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  35. C     1  IDOL7,IDOL8
  36.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  37. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  38.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  39. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  40. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  41. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  42.     InTeGer*4 KLVL
  43. C    COMMON/KLVL/KLVL
  44.     InTeGer*4 IOLVL,IGOLD
  45. C    COMMON/IOLVL/IOLVL
  46. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  47. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  48.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  49.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  50.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  51. C ***<<< RDD COMMON END >>>***
  52.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  53.     COMMON/D2R/NRDSP,NCDSP
  54.     InTeGer*4 TYPE(1,1),VLEN(9)
  55.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  56.     REAL*8 XXV(1,1)
  57.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  58.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  59. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  60.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  61.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  62.     CHARACTER*12 CDVFMT
  63.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  64.     COMMON/DEFVBX/DVFMT
  65.     CHARACTER*1 NMSH(80)
  66.     CHARACTER*80 NMSH80
  67.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  68.     COMMON/NMSH/NMSH
  69.     CHARACTER*1 FORM2(4)
  70. C ***<<< XVXTCD COMMON START >>>***
  71.     CHARACTER*1 OARRY(100)
  72.     InTeGer*4 OSWIT,OCNTR
  73. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  74. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  75.     InTeGer*4 IPS1,IPS2,MODFLG
  76. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  77.        InTeGer*4 XTCFG,IPSET,XTNCNT
  78.        CHARACTER*1 XTNCMD(80)
  79. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  80. C VARY FLAG ITERATION COUNT
  81.     INTEGER KALKIT
  82. C    COMMON/VARYIT/KALKIT
  83.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  84.     InTeGer*4 RCMODE,IRCE1,IRCE2
  85. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  86. C     1  IRCE2
  87. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  88. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  89. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  90. C RCFGX ON.
  91. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  92. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  93. C  AND VM INHIBITS. (SETS TO 1).
  94.     INTEGER*4 FH
  95. C FILE HANDLE FOR CONSOLE I/O (RAW)
  96. C    COMMON/CONSFH/FH
  97.     CHARACTER*1 ARGSTR(52,4)
  98. C    COMMON/ARGSTR/ARGSTR
  99.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  100.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  101.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  102.      3  IRCE2,FH,ARGSTR
  103. C ***<<< XVXTCD COMMON END >>>***
  104. C
  105. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  106. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  107. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  108. C DISPLAY ACTUALLY USED FOR SCREEN.
  109.     InTeGer*4 CWIDS(20)
  110. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  111. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  112. C AS 20 NOT 75.
  113.     INTEGER*4 I4TMP
  114.     REAL*8 DVS(20,75)
  115.     COMMON /FVLDC/FVLD
  116. C FOLLOWING SUPPORT VVARY OVERLAY:
  117.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  118.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  119.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  120. C BITMAP
  121. C    CHARACTER*1 IBITMP
  122. C    DIMENSION IBITMP(2258)
  123. C    COMMON/INITD/IBITMP
  124. C    CHARACTER*1 DFMTS(10,20,75)
  125. C 10 CHARACTERS PER ENTRY.
  126.     COMMON/DSPCMN/DVS,CWIDS
  127. C    character*35 fwt
  128. C COMMONS FROM OTHER MISC. ROUTINES, ADDED TO ALLOW AMIGA FORTRAN TO
  129. C ALLOCATE COMMONS ON STACK...
  130.     CHARACTER*1 LBITS(8)
  131.     COMMON/BITS/LBITS
  132.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  133.     COMMON/CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  134.     CHARACTER*1 DTBL1(9,9,8)
  135.     COMMON/DECIDE/DTBL1
  136.     CHARACTER*1 DIGITS(16,3)
  137.     COMMON/DIGV/DIGITS
  138. C ***<<< KLSTO COMMON START >>>***
  139.     InTeGer*4 DLFG
  140. C    COMMON/DLFG/DLFG
  141.     InTeGer*4 KDRW,KDCL
  142. C    COMMON/DOT/KDRW,KDCL
  143.     InTeGer*4 DTRENA
  144. C    COMMON/DTRCMN/DTRENA
  145.     REAL*8 EP,PV,FV
  146.     DIMENSION EP(20)
  147.     INTEGER*4 KIRR
  148. C    COMMON/ERNPER/EP,PV,FV,KIRR
  149.     InTeGer*4 LASTOP
  150. C    COMMON/ERROR/LASTOP
  151.     CHARACTER*1 FMTDAT(9,76)
  152. C    COMMON/FMTBFR/FMTDAT
  153.     CHARACTER*1 EDNAM(16)
  154. C    COMMON/EDNAM/EDNAM
  155.     InTeGer*4 MFID(2),MFMOD(2)
  156. C    COMMON/FRM/MFID,MFMOD
  157.     InTeGer*4 JMVFG,JMVOLD
  158. C    COMMON/FUBAR/JMVFG,JMVOLD
  159.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  160.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  161. C ***<<< KLSTO COMMON END >>>***
  162. C
  163. C
  164.         CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
  165.     CHARACTER*1 FVXX(6792)
  166.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
  167.     EQUIVALENCE (FV4(1),FVXX(4529))
  168.         Common/FVLDM/FVXX
  169. c        COMMON/FVLDM/FV1,FV2,FV4
  170.     InTeGer*2 IFID(8,2048)
  171.     COMMON/IFIDC/IFID
  172.     InTeGer*4 ILNFG,ILNCT
  173.     CHARACTER*1 ILINE(106)
  174.     COMMON/ILN/ILNFG,ILNCT,ILINE
  175.     InTeGer*4 ITCNTV(6)
  176.     COMMON/ITERA/ITCNTV
  177.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  178.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  179.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  180.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  181.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  182. C ***<<< NULETC COMMON START >>>***
  183.     InTeGer*4 ICREF,IRREF
  184. C    COMMON/MIRROR/ICREF,IRREF
  185.     InTeGer*4 MODPUB,LIMODE
  186. C    COMMON/MODPUB/MODPUB,LIMODE
  187.     InTeGer*4 KLKC,KLKR
  188.     REAL*8 AACP,AACQ
  189. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  190.     InTeGer*4 NCEL,NXINI
  191. C    COMMON/NCEL/NCEL,NXINI
  192.     CHARACTER*1 NAMARY(20,301)
  193. C    COMMON/NMNMNM/NAMARY
  194.     InTeGer*4 NULAST,LFVD
  195. C    COMMON/NULXXX/NULAST,LFVD
  196.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  197.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  198. C ***<<< NULETC COMMON END >>>***
  199.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  200.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  201.     COMMON/STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  202.      1  ST1LIM,ST2LIM
  203.     InTeGer*4 IATYP(27),LINTGR
  204.     CHARACTER*1 ITYP(2264)
  205.     COMMON/TYP/IATYP,ITYP,LINTGR
  206.     InTeGer*4 MPAG(2),MPMOD(2)
  207.     InTeGer*2 LVALBF(5,800)
  208.     COMMON/VB/MPAG,LVALBF,MPMOD
  209.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  210.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  211.     InTeGer*4 LEVEL,NONBLK,LEND,VIEWSW,BASED
  212.     CHARACTER*1 LINE(80)
  213.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  214. C *** END COMMONS FROM OTHER PLACES.
  215.     FH=0
  216. c    IFCW=4927
  217. C DISABLE FLOATING EXCEPTIONS
  218. c    CALL LCWRQQ(IFCW)
  219. C INITIAL DEFAULT FORMAT FOR NUMERICS is set at runtime
  220. C INIT COMMON DATA FIRST OF ALL.
  221.     IDOL7=1
  222. C INITIALLY IN ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
  223. C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
  224.     CALL BLOCK
  225.     IKONS=0
  226.     write(*,6402)
  227. 6402    Format(' Compiled by Absoft Fortran 2.3.')
  228.     Write(*,6403)
  229. 6403    Format(' Requires 640 by 400 Workbench screen (interlace)')
  230.     CALL INITA1(KMAP,KWID,ICODE)
  231. 3002    CONTINUE
  232.     CALL INITA2(KMAP,KWID,ICODE,IKONS)
  233.     IKONS=1
  234. 3000    CONTINUE
  235.     CALL INITB(KMAP,KWID,ICODE)
  236.     LINIZZ=0
  237. C    IF(IOLDFL.GT.1)GOTO 2000
  238. 2000    CONTINUE
  239. C DRAW OUR LABELS AND OTHERWISE INITIALIZE DISPLAY SHEET
  240.     KZPPD=0
  241.     IF(IPSET.NE.0)GOTO 1000
  242.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  243.     CALL UVT100(1,1,1)
  244.     OSWIT=20
  245.     IPRSS=PROW
  246.     IPCSS=PCOL
  247.     IDRW=DROW
  248.     IDCL=DCOL
  249.     IF(LINIZZ.LE.1)CALL RECALC
  250.     IF(PZAP.EQ.0)CALL DSPSHT(2)
  251.     DCOL=IDCL
  252.     DROW=IDRW
  253.     PROW=IPRSS
  254.     PCOL=IPCSS
  255. 3006    FORMAT(80A1)
  256. C
  257. 1000    CONTINUE
  258.     IPSET=0
  259.     LINIZZ=LINIZZ+1
  260.     OSWIT=20
  261. C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
  262.     ICODE=0
  263.     CALL XQTCMD(ICODE)
  264.     IF(ICODE.LT.30)GOTO 1843
  265. C HELP COMMAND AND SIMILAR...
  266.     IF(ICODE.NE.400)GOTO 1847
  267.     CALL DSPSHT(10)
  268.     ICODE=1
  269. C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
  270.     GOTO 1843
  271. 1847    CONTINUE
  272.     IF(ICODE.NE.420)GOTO 1849
  273. C CLOSE UNIT 1 JUST IN CASE...
  274.     CLOSE(1)
  275.     KLVL=1
  276.     IPRSSS=PROW
  277.     IPCSSS=PCOL
  278.     CALL CALC
  279.     PROW=IPRSSS
  280.     PCOL=IPCSSS
  281. C CLOSE CONSOLE LUN USED BY CALC.
  282.     CLOSE(1)
  283. C CLOSE ANY OTHER LUNS CALC MAY HAVE USED...
  284.     CLOSE(2)
  285.     CLOSE(3)
  286. C SET UP FOR REDRAW WHEN BACK...
  287.     ICODE=-1
  288.     GOTO 1843
  289. 1849    CONTINUE
  290.     IF(ICODE.NE.430)GOTO 1845
  291. C TEST FUNCTION, TESTING EXPRESSION.
  292. C INHIBIT RECALCULATION...
  293. C COMMAND IS IN "XTNCMD" STRING.
  294.     LLST=MIN0(80,XTNCNT)
  295.     LFST=1
  296.     CALL DOENTR(XTNCMD,LFST,LLST)
  297. C THIS SETS % VARIABLE AND WILL DO A CALC DIRECTLY. THEREFORE
  298. C WE MUST INHIBIT AUTO RECALCULATION.
  299. C NOTE WE HAVE TO CALL THIS FROM THE ROOT SINCE THE RECALC OVERLAY
  300. C TREE OVERWRITES THE XQTCMD ONE.
  301.     ICODE=1
  302.     GOTO 1843
  303. 1845    CONTINUE
  304.     IVVV=ICODE-30
  305. 9308    CALL HELP(IVVV)
  306.     IVVV=0
  307.     CALL VWRT('Type return to continue, Hn for other Help pages:',
  308.      1  49)
  309.     ILL=IOLVL
  310. C    IF(ILL.EQ.5)ILL=0
  311.     READ(ILL,3006,END=5600,ERR=5600)(FORM2(K),K=1,4)
  312.     IVVVV=ichar(FORM2(2))
  313.     IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
  314.     IF(FORM2(1).EQ.'H'.OR.FORM2(1).EQ.'h')GOTO 9308
  315. C NOW CLEAR SCREEN AND TRY MORE COMMANDS AS BEFORE...
  316.     ICODE=6
  317. C
  318. 1843    CONTINUE
  319.     OSWIT=20
  320.     IPRSS=PROW
  321.     IPCSS=PCOL
  322.     IDRW=DROW
  323.     IDCL=DCOL
  324.     IF(LINIZZ.LE.1)CALL RECALC
  325.     IF(IPSET.NE.0)GOTO 4110
  326.     DCOL=IDCL
  327.     DROW=IDRW
  328.     PROW=IPRSS
  329.     PCOL=IPCSS
  330. 4110    CONTINUE
  331.     IPSET=0
  332.     IF(ICODE.EQ.-1)GOTO 2000
  333. C IN PORTACALC-VM, S COMMAND ALLOWS DEFAULT FORMAT CHANGE AND
  334. C TITLE CHANGE, BUT DOES NOT ALTER SHEET IN MEMORY... DON'T ALLOW
  335. C SCRATCH FILE SAVE STUFF...
  336. C    IF(ICODE.EQ.-2)CALL WRKFIL(1,FORM,3)
  337. C    IF (ICODE.EQ.-2)CALL CLOSE(7)
  338.     IF(ICODE.LE.-2)GOTO 3002
  339. C
  340. C RECALCULATE SHEET NOW AUTOMAGICALLY
  341. C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
  342. C THE ENTIRE SHEET.
  343. C LIMIT NUMBER OF ITERATIONS AT ANY ONE TIME TO 20 HOWEVER
  344.     KKMAX=20
  345. 3670    CONTINUE
  346.     IF(ICODE.EQ.5.OR.ICODE.EQ.1
  347.      1  .OR.ICODE.EQ.6.OR.RCFGX.EQ.1)GOTO 3671
  348.     CALL RECALC
  349.     IPSET=0
  350.     KKMAX=KKMAX-1
  351. C IMPLEMENT VARY LOOP...
  352. C ASSUME USRFCT MUSTR CONTOL KALKIT VARIABLE THEN TO GET LOOP TO
  353. C TERMINATE SOMETIME.
  354.     KKMAX=MIN0(KKMAX,KALKIT)
  355.     IF(KKMAX.GT.0)GOTO 3670
  356. 3671    CONTINUE
  357. C    IF(ICODE.NE.1.AND.RCFGX.NE.1)CALL RECALC
  358. C
  359. C DISPLAY SHEET NOW. ONLY ALTERS ENTRIES INVALIDATED BY COMMAND.
  360.     IF(ICODE.NE.2.AND.ICODE.NE.6)GOTO 21
  361. C ICODE=2 = REFRESH DISPLAY. ZERO ALL NUMBERS AND CAUSE TOTAL REDISPLAY.
  362.     DO 22 N1=1,20
  363.     DO 22 N2=1,75
  364. C SET NUMBER DISPLAYED TO WEIRD VALUE.
  365. 22    DVS(N1,N2)=DVS(N1,N2)+.000000000034
  366.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  367.     CALL UVT100(1,1,1)
  368. 21    CONTINUE
  369.     IF(ICODE.EQ.6)ICODE=2
  370.     IF(ICODE.NE.5.AND.PZAP.EQ.0)CALL DSPSHT(ICODE)
  371.     DCOL=IDCL
  372.     DROW=IDRW
  373.     PROW=IPRSS
  374.     PCOL=IPCSS
  375.     GOTO 1000
  376. 5600    CONTINUE
  377. C ERROR ON READ FROM IOLVL HANDLED HERE.
  378. c    REWIND 5
  379.     CLOSE(11)
  380.     OPEN(11,FILE='CON:50/150/300/40/Analy Command',STATUS='OLD',
  381.      1  FORM='FORMATTED')
  382.     CLOSE(3)
  383.     IOLVL=11
  384.     GOTO 1000
  385.     END
  386. c -h- assign.for    Fri Aug 22 12:56:01 1986    
  387.     SUBROUTINE ASSIGN(IUNIT,NAME)
  388. C
  389. C
  390.     CHARACTER*1 NAME(50)
  391.     InTeGer*4 IUNIT
  392. C &&&& MS FTN 3.2
  393.     LOGICAL LEXIST
  394. C &&&&
  395.     CHARACTER*20 WK
  396.     CHARACTER*1 WK1(20)
  397.     EQUIVALENCE(WK(1:1),WK1(1))
  398. C JUST TRY AND NULL FILL A NAME TO USE.
  399.     DO 1 N=1,20
  400.     WK1(N)=' '
  401. 1    CONTINUE
  402.     DO 2 N=1,20
  403.     II=ICHAR(NAME(N))
  404.     IF(II.LT.32)GOTO 3
  405.     WK1(N)=CHAR(II)
  406. C1    CONTINUE
  407. 2    CONTINUE
  408. 3    CONTINUE
  409. C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
  410. C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
  411. C AVOID CRASHES IF THE FILE ISN'T THERE...
  412. C MSDOS FORTRAN 3.2 AND LATER FEATURE...
  413. C &&&&
  414. C
  415. C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
  416. C
  417.     INQUIRE(FILE=WK,EXIST=LEXIST)
  418.     IF(LEXIST)GOTO 100
  419. C FILE DOES NOT EXIST, SO CREATE IT HERE.
  420. C IF CREATE FAILS WE LOSE TOO...
  421.     CALL UVT100(1,1,1)
  422.     CALL SWRT('File not found. Using window instead.',37)
  423.     Open(IUNIT,'CON:200/100/300/80/Nonexistent file')
  424. C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
  425. C WILL GET EOF ON START, BUT THAT'S TOO BAD...
  426.     Return
  427. 100    CONTINUE
  428. C &&&&
  429. C IF JUST CALL ASSIGN, ASSUME FOR READ.
  430.     OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
  431.      1  FORM='FORMATTED')
  432. 77    CONTINUE
  433. C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
  434. C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
  435.     RETURN
  436.     END
  437. c -h- at.for    Fri Aug 22 12:56:23 1986    
  438.     SUBROUTINE AT (RETCD)
  439. C COPYRIGHT (C) 1983 GLENN EVERHART
  440. C ALL RIGHTS RESERVED
  441. C 60=MAX REAL ROWS
  442. C 301=MAX REAL COLS
  443. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  444. C VBLS AND TYPE DIMENSIONED 60,301
  445. C *******************************************************
  446. C *                                                     *
  447. C *           SUBROUTINE  AT                            *
  448. C *                                                     *
  449. C *******************************************************
  450. C SUBROUTINE AT IS CALLED WHEN THE  *@  CALC COMMAND IS ENCOUNTERED.
  451. C IT CHANGES  THE  VALUE  OF LEVEL  WHICH  HOLDS THE  NUMBER OF THE
  452. C LOGICAL  I/O  UNIT WHERE INPUT COMMAND LINES ARE TO BE OBTAINED.
  453. C THE FILE ASSOCIATED WITH THAT I/O UNIT IS OPENED UNDER THE PROPER
  454. C CONDITIONS.
  455. C
  456. C MODIFICATION CLASSES: M1,M2,M9
  457. C
  458. C      MODIFIED 3-OCT-77 P.B.
  459. C      MODIFIED 10-JAN-78 P.B.  TO PUT SY: BEFORE FILENAMES
  460. C         WITH NO DEVICE SPECIFIED SO THAT DEFAULT IS USER'S SY:
  461. C         AND NOT THE SYSTEM SY:
  462. C
  463. C
  464. C    AT CALLS
  465. C
  466. C  ASSIGN  (TO ASSOCIATE A FILE NAME WITH A LOGICAL I/O UNIT)
  467. C  ERRMSG  (TO PRINT ERROR MESSAGES)
  468. C  GETNNB  (TO GET NEXT NON-BLANK FROM THE INPUT LINE)
  469. C  ZNEG    (TO TEST IF A VARIABLE IS POSITIVE)
  470. C
  471. C
  472. C
  473. C   AT IS CALLED BY ROUTINE CMND WHICH IS THE MODULE THAT DETERMINES
  474. C   WHAT CALC COMMAND WAS REQUESTED.
  475. C
  476. C
  477. C
  478. C         VARIABLE          USE
  479. C
  480. C   ALPHA(27)         HOLDS LEGAL VARIABLE NAMES.
  481. C   I,J               HOLD TEMPORARY VALUES.
  482. C   IPT               POINTS TO NEXT NON-BLANK CHARACTER IN LINE(80).
  483. C   ITCNTV(6)         INDEXED BY LEVEL. HOLDS 0 IF NO ITERATION ON THAT
  484. C                     LEVEL, OTHERWISE INDEX INTO VBLS FOR THE VARIABLE
  485. C                     THAT CONTROLS ITERATION.
  486. C   LEVEL             HOLDS NUMBER OF LOGICAL I/O UNIT WHERE NEXT INPUT
  487. C                     LINE IS EXPECTED.
  488. C   LINE(80)          HOLDS COMMAND INPUT LINE.
  489. C   NBLINE(78)        HOLDS THE INPUT FILE NAME WITHOUT BLANKS.
  490. C   NONBLK            POINTS TO THE LAST NON-BLANK CHARACTER IN LINE(80).
  491. C   RETCD             RETURN CODE: 1=O.K.  2=ERROR.
  492. C   SY                "SY:" USED TO OPEN FILES WITH A DEFAULT OF
  493. C                     USER'S SY: (OTHERWISE SYSTEM SY: IS USED) P.B.
  494. C                     10-JAN-78
  495. C
  496. C
  497. C
  498. C    SUBROUTINE AT (RETCD)
  499. C
  500.     InTeGer*4 IPT,J,I
  501.     InTeGer*4 LEVEL,NONBLK,LEND
  502.     InTeGer*4 RETCD,VIEWSW,BASED
  503.     InTeGer*4 ITCNTV(6),ZNEG
  504. C
  505.     CHARACTER*1  LINE(80),NBLINE(78)
  506.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  507. C    CHARACTER*1 SY(3)
  508. C
  509. C
  510.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  511.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  512.     COMMON/ITERA/ITCNTV
  513. C
  514. C    DATA SY/'S','Y',':'/
  515. C
  516. C
  517. C
  518. C UPON ENTRANCE, NONBLK POINTS TO THE CHARACTER @
  519. C
  520. C  MODIFICATION CLASSES:  M1,M2,M9
  521. C
  522. C PICK UP FIRST NON-BLANK AFTER THE @
  523.     CALL GETNNB(IPT,RETCD)
  524.     GO TO (10,1050),RETCD
  525.     STOP 10
  526. C
  527. C
  528. C START BUILDING FILE NAME AS A COMPRESSED VERSION (BLANKS REMOVED)
  529. C OF THE REST OF LINE(80)
  530. 10    J=0
  531. 15    NONBLK=IPT
  532.     J=J+1
  533.     NBLINE(J)=LINE(NONBLK)
  534.     CALL GETNNB(IPT,RETCD)
  535.     GO TO (15,50),RETCD
  536.     STOP 50
  537. C
  538. C
  539. C SET RETURN CODE AND INDICATE THAT WE WILL BE AT A NEW LEVEL.
  540. C J HOLDS THE COUNT OF THE NUMBER OF CHARACTERS IN NBLINE.
  541. C IF J=1 THEN NO ITERATION IS POSSIBLE BECAUSE FILENAME IS THE
  542. C SINGLE CHARACTER.
  543. 50    RETCD=1
  544.     LEVEL=LEVEL+1
  545.     IF (LEVEL.GT.6) GOTO 1000
  546. C
  547.     IF(J.EQ.1) GO TO 200
  548. C
  549. C NBLINE HOLDS THE COMPRESSED FILENAME. NOW WE CHECK TO SEE IF AN
  550. C ITERATION VARIABLE WAS SPECIFIED. THIS IS INDICATED BY A LEGAL
  551. C VARIABLE NAME PRECEEDED BY A BLANK (IN LINE(80))
  552. C NOTE THAT ONLY ONE OF THE ACCUMULATORS A-Z MAY BE USED FOR THIS.
  553.     DO 60 I=1,27
  554. C A-Z OR % LEGAL
  555.     IF(ALPHA(I).EQ.LINE(NONBLK))GO TO 100
  556. 60    CONTINUE
  557.     GO TO 200
  558. 100    IF(LINE(NONBLK-1).NE.BLANK)GO TO 200
  559. C
  560. C
  561. C ITERATION INDICATOR IS PRESENT
  562. C (ALPHABETIC CHARACTER OR % PRECEEDED BY A BLANK)
  563. C IF THE VALUE OF THE VARIABLE IS NOT POSITIVE, THE FILE IS IGNORED.
  564.     IF(ZNEG(I).EQ.1)GO TO 150
  565. C
  566. C
  567. C RETAIN INDEX INTO VBLS AND DECREASE J SO THAT THE FILENAME
  568. C DOES NOT INCLUDE THE ITERATION SPECIFICATION.
  569.     ITCNTV(LEVEL)=I
  570.     J=J-1
  571.     GO TO 300
  572. C
  573. C
  574. C FILE NOT ENTERED, ITERATION VARIABLE IS ZERO, NEGATIVE, OR UNDEFINED
  575. 150    LEVEL=LEVEL-1
  576.     GO TO 350
  577. C
  578. C
  579. C IF NO ITERATION, SET ITCNTV TO ZERO BECAUSE NOT ZEROED BY EXIT
  580. C ROUTINES
  581. 200    ITCNTV(LEVEL)=0
  582. 300    CONTINUE
  583.     NBLINE(J+1)=0
  584. C    OPEN(UNIT=LEVEL,NAME=NBLINE)
  585. C    CALL RASSIG (LEVEL,NBLINE,J)
  586.     CALL RASSIG (LEVEL,NBLINE)
  587. 350    RETURN
  588. C
  589. C *** ERROR PROCESSING ***
  590. C
  591. C  TOO MANY LEVELS
  592. 1000    I=2
  593. 1010    CALL ERRMSG(I)
  594. 1020    RETCD=2
  595.     RETURN
  596. C
  597. C
  598. C UNIDENTIFIED COMMAND (ARGUMENT)
  599. 1050    I=3
  600.     GO TO 1010
  601.     END
  602. c -h- bascng.for    Fri Aug 22 12:57:23 1986    
  603.     SUBROUTINE BASCNG(RETCD)
  604. C COPYRIGHT (C) 1983 GLENN EVERHART
  605. C ALL RIGHTS RESERVED
  606. C 60=MAX REAL ROWS
  607. C 301=MAX REAL COLS
  608. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  609. C VBLS AND TYPE DIMENSIONED 60,301
  610. C
  611. C SUBROUTINE BASCNG IS CALLED WHEN THE *B CALC COMMAND IS
  612. C ENCOUNTERED. THIS COMMAND INDICATES THAT THE DEFAULT BASE
  613. C FOR CONSTANTS IS TO BE CHANGED. THE ROUTINE READS IN ONE
  614. C OR TWO DIGITS AND CHANGES THE DEFAULT BASE SPECIFICATION
  615. C AS IS APPROPRIATE.
  616. C
  617. C MODIFICATION CLASS M2
  618. C
  619. C   BASCNG CALLS
  620. C
  621. C  ERRMSG  (PRINTS ERROR MESSAGES)
  622. C  GETNNB  (GETS THE NEXT NON-BLANK IN INPUT LINE LINE(80))
  623. C
  624. C
  625. C  BASCNG IS CALLED BY ROUTINE CMND WHICH IDENTIFIES THE COMMAND THAT
  626. C  THE USER WANTS TO EXECUTE.
  627. C
  628. C
  629. C    VARIABLE       USE
  630. C
  631. C    BASED       HOLDS THE DEFAULT BASE.
  632. C    IPT         POINTS TO THE NEXT NON-BLANK IN LINE(80).
  633. C    I1          BINARY VALUE OF FIRST DIGIT, VALUE OF NEW BASE.
  634. C    I2          BINARY VALUE OF SECOND DIGIT.
  635. C    NONBLK      POINTS TO THE LAST NON-BLANK IN LINE(80)
  636. C    RETCD       RETURN CODE: 1=O.K.  2=ERROR.
  637. C    RETCD2      HOLDS RETURN CODE FROM CALL TO GETNNB
  638. C
  639. C
  640. C
  641. C
  642. C    SUBROUTINE BASCNG(RETCD)
  643. C
  644. C
  645. C UPON ENTRANCE, NONBLK POINTS TO THE 'B' IN '*B' IN LINE
  646. C
  647.     InTeGer*4 IPT,I1,I2
  648.     InTeGer*4 LEVEL,NONBLK,LEND
  649.     InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
  650. C
  651.     CHARACTER*1 DIGITS(16,3),LINE(80)
  652. C
  653.     COMMON /DIGV/ DIGITS
  654.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  655. C
  656. C
  657. C IF NO ARGUMENT, RETURN WITH NORMAL RETURN CODE. THIS ALLOWS THE
  658. C USER TO SEE WHAT THE PRESENT DEFAULT BASE IS.
  659.     RETCD=1
  660.     CALL GETNNB(IPT,RETCD2)
  661.     IF(RETCD2.GT.1)GO TO 1000
  662. C
  663. C
  664. C CHECK OUT FIRST DIGIT
  665.     DO 300 I1=1,10
  666.     IF(DIGITS(I1,1).EQ.LINE(IPT)) GO TO 400
  667. 300    CONTINUE
  668.     GO TO 999
  669. C
  670. C
  671. C SEE IF THERE IS A SECOND DIGIT
  672. 400    NONBLK=IPT
  673.     IF(I1.EQ.10)I1=0
  674.     CALL GETNNB(IPT,RETCD2)
  675.     IF(RETCD2.EQ.1)GO TO 500
  676. C
  677. C
  678. C IF NOT, CONVERT TO A TWO DIGIT NUMBER WITH A LEADING ZERO.
  679.     I2=I1
  680.     I1=0
  681.     GO TO 700
  682. C
  683. C A SECOND CHARACTER WAS FOUND; FIGURE OUT WHAT THE BINARY
  684. C VALUE IS (IF IT IS A DIGIT AT ALL).
  685. 500    DO 600 I2=1,10
  686.     IF(DIGITS(I2,1).EQ.LINE(IPT))GO TO 700
  687. 600    CONTINUE
  688.     GO TO 999
  689. C
  690. C CONVERT DIGITS TO A NUMBER IF IT IS LEGAL
  691. 700    IF(I2.EQ.10)I2=0
  692.     I1=I1*10+I2
  693.     IF(I1.NE.8.AND.I1.NE.10.AND.I1.NE.16) GO TO 999
  694.     BASED=I1
  695.     GO TO 1000
  696. C
  697. C
  698. C ILLEGAL BASE SPECIFICATION
  699. 999    RETCD=2
  700.     WRITE(11,998)
  701. 998    FORMAT(' Illegal Base. (Only 8,10,and 16 OK). Ignored.')
  702. C    CALL ERRMSG(19)
  703. C
  704. C RETURN
  705. 1000    RETURN
  706.     END
  707. c -h- blkdat.for    Fri Aug 22 12:57:49 1986    
  708.     BLOCK DATA
  709. C COPYRIGHT 1983 GLENN C.EVERHART
  710. C ALL RIGHTS RESERVED
  711. C    InTeGer*4 MFID(2),MFMOD(2)
  712.     InTeGer*2 IFID(8,2048)
  713.     COMMON/IFIDC/IFID
  714.     CHARACTER*1 LFID(16,2048)
  715.     EQUIVALENCE(IFID(1,1),LFID(1,1))
  716. C    COMMON/FRM/MFID,MFMOD
  717.     CHARACTER*1 DTBL1(9,9,8)
  718. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  719.     InTeGer*2 BTBL(6,6,8)
  720. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  721. C NO NEED TO WASTE IT.
  722. c    INTEGER DTBLIN
  723. C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
  724.     EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
  725.     InTeGer*2 BTBL1(6,6)
  726.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  727.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  728.     EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  729.     EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  730.     EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  731.     EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  732.     COMMON /DECIDE/ DTBL1
  733. cc    DATA DTBLIN/0/
  734.     DATA BTBL1 /4,2,3,4,8,9,
  735.      1  6*0,0,2,0,0,0,9,0,2,0,0,0,9,
  736.      2  0,2,3,0,0,9,0,2,4*0/
  737.     DATA BTBL2/
  738.      3  4,5*0,2,0,3*2,0,3,3*0,2*0,4,3*0,2*0,
  739.      4  8,5*0,9,0,3*9,0/
  740.     DATA BTBL3/4,2,3,4,8,9,
  741.      5  6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  742.      6  8,2,3,4,8,9,9,2,4*9/
  743.     DATA BTBL4/
  744.      7  4,2,3,4,8,9,6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  745.      8  8,2,3,4,8,9,
  746.      9  9,2,4*9/
  747.     DATA BTBL5/4,2,3,3*4,6*0,6*0,6*0,
  748.      1  6*0,6*0/
  749.     DATA BTBL6/4,3*0,4,0,4,3*0,0,0,4,3*0,2*0,4,3*0,2*0,
  750.      2  4,3*0,2*0,
  751.      3  4,3*0,2*0/
  752.         DATA BTBL7/4,2,3,3*4,6*2,6*3,6*4,
  753.      4  6*8,6*9/
  754.     DATA BTBL8/4,1,4,4,4,3,2,1,2,2,2,1,4,3,4,4,
  755.      5  4,3,4,3,4,4,4,3,4,3,4,4,
  756.      6  4,3,2,1,2,2,2,1/
  757.     END
  758. c -h- ca2e.for    Fri Aug 22 13:00:17 1986    
  759.     SUBROUTINE CA2E(LNIN,LNOUT)
  760. C CONVERT NORMAL ASCII FORM TO ENCODED
  761.     CHARACTER*1 NAME(4),NUMBER(6)
  762.     CHARACTER*1 LNIN,LNOUT
  763.     CHARACTER*6 NUMBR6
  764.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  765.     DIMENSION LNIN(128),LNOUT(128)
  766.     InTeGer*4 RRWACT,RCLACT
  767. C    COMMON/RCLACT/RRWACT,RCLACT
  768.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  769.      1  IDOL7,IDOL8
  770. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  771. C     1  IDOL7,IDOL8
  772.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  773. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  774.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  775. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  776. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  777. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  778.     InTeGer*4 KLVL
  779. C    COMMON/KLVL/KLVL
  780.     InTeGer*4 IOLVL,IGOLD
  781. C    COMMON/IOLVL/IOLVL
  782. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  783. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  784.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  785.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  786.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  787. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  788. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  789. C    LOGICAL*2 L63,L192,L255,L128
  790.     LOGICAL*4 L1,L2
  791. C    InTeGer*4 I63,I192,I255,I128
  792.     InTeGer*4 I63,I192,I127
  793.     InTeGer*4 I1,I2
  794. C    EQUIVALENCE(L128,I128)
  795. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  796.     EQUIVALENCE (I1,L1),(I2,L2)
  797. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  798.     DATA I63/63/,I192/192/,I127/127/
  799.     LI=1
  800.     LO=1
  801. C LI = INPUT LOCATION
  802. C LO=OUTPUT LOCATION
  803. 100    CONTINUE
  804.     LCC=ICHAR(LNIN(LI))
  805.     IF(LCC.EQ.255)GOTO 500
  806. C IF BINARY FORM, COPY 3 BYTES TO AVOID ERRORS.
  807.     IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
  808. C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
  809.     IL1=LI
  810.     LE=110
  811.     LSTC=LE
  812.     CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
  813. C AVOID MESSING UP FUNCTION NAMES
  814.     IF(ID2.EQ.1)IVLD=0
  815.     IF(IDOL1.NE.0.OR.IDOL2.NE.0)IVLD=0
  816. C ONLY REPACK NORMAL FORM NAMES
  817. C NOTE THAT SINCE THESE HAVE $ AFTER THE FIELDS, NO PARTIAL NAME
  818. C WILL EVER GET RECOGNIZED WITHOUT IDOL1 OR IDOL2 GETTING SET.
  819.     IF(IVLD.EQ.0)GOTO 200
  820. C ALIASED NAMES MIGHT GET SCANNED WITHIN PRIME AREA IF THE FIRST
  821. C ONE OR TWO CHARS GET STRIPPED OFF, SO TREAT LIKE P## OR D## FORMS
  822. C AND COPY THE WHOLE NAME HERE.
  823.     IF(ID1.GT.60.OR.ID2.GT.301)GOTO 250
  824. C ALSO DON'T PACK ALIASED NAMES; THEY WON'T FIT IN CODED VALUES.
  825. C FOUND VARIABLE.
  826. C FIRST DON'T PACK P## AND D## FORMS.
  827.     IF(LNIN(LI+1).EQ.'#')GOTO 250
  828. C REPACK NORMAL VARIABLE HERE.
  829.     LI=LSTC
  830.     LNOUT(LO)=CHAR(255)
  831.     I1=IMASK(ID1,I63)
  832. C    I1=ID1
  833. C    L1=L1.AND.L63
  834.     I2=ID2/2
  835.     I2=IMASK(I2,I192)
  836. C    L2=L2.AND.L192
  837. C    L1=L1.OR.L2
  838.     I1=I1+I2
  839.     LNOUT(LO+1)=CHAR(I1)
  840. C    I2=ID2
  841.     I2=IMASK(ID2,I127)+128
  842. C    L2=L2.AND.L255
  843. C    L2=L2.OR.L128
  844.     LNOUT(LO+2)=CHAR(I2)
  845.     LO=MIN0(109,LO+3)    
  846.     GOTO 300
  847. 250    CONTINUE
  848. C JUST COPY DISPLAY FORMS.
  849.     IL1=LSTC-1
  850.     DO 251 N=LI,IL1
  851.     LNOUT(LO)=LNIN(N)
  852.     LO=LO+1
  853.     IF(LO.GT.110)GOTO 300
  854. 251    CONTINUE
  855.     LI=LSTC
  856. C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
  857.     GOTO 300
  858. 200    CONTINUE
  859. C HERE CHECK FOR FORMULA...
  860. C NOTE THAT SOME NAMES (E.G. "AVG" COULD CONFLICT WITH VERY LARGE COLUMN
  861. C NAMES. HOWEVER, IGNORE THAT POSSIBILITY. THAT'S AWFULLY FAR OUT.
  862.     CALL FNAME(LNIN(LI),II,INDX)
  863.     IF(INDX.LE.0.OR.INDX.GT.25)GOTO 220
  864. C Ensure that functions with indices too large to encode are
  865. C just treated literally. 229+25=254, the largest index we can have
  866. C before colliding with the 255 used to encode variable names.
  867. C thus all function names past the 25th must just be literally
  868. C entered. This is not really a problem as logic to find them
  869. C will work in either encoded or unencoded cases.
  870. C BE SURE A [ CHAR FOLLOWS NAME FOR THIS TO BE ACCEPTED...
  871.     IF(LNIN(LI+3).NE.'[')GOTO 220
  872. C FOUND MULTI-INPUT FUNCT NAME
  873.     LNOUT(LO)=CHAR(229+INDX)
  874. C SIMPLE 1-BYTE ENCODE OF NEEDED FUNCT NAME. NOT IN ANY CRITICAL RANGES...
  875.     LO=LO+1
  876.     LI=LI+3
  877.     GOTO 300
  878. 220    CONTINUE
  879.     LNOUT(LO)=LNIN(LI)
  880. C JUST COPY MISC. CHARACTER.
  881.     LO=LO+1
  882.     LI=LI+1
  883. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  884. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  885.     LO=MIN0(LO,110)
  886.     DO 400 N=LO,110
  887. 400    LNOUT(N)=0
  888. C COPY REST OF 128 BYTE ARRAY
  889.     DO 1 N=111,128
  890. 1    LNOUT(N)=LNIN(N)
  891. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  892.     RETURN
  893. 500    CONTINUE
  894. C SPECIAL COPY OF 3 BYTE PACKED FORMS FOR SPEED
  895.     LNOUT(LO)=LNIN(LI)
  896.     LNOUT(LO+1)=LNIN(LI+1)
  897.     LNOUT(LO+2)=LNIN(LI+2)
  898.     LO=LO+3
  899.     LI=LI+3
  900.     GOTO 300
  901.     END
  902. c -h- calbin.for    Fri Aug 22 13:00:17 1986    
  903.     SUBROUTINE CALBIN(RETCD)
  904. C COPYRIGHT (C) 1983,1984 GLENN EVERHART
  905. C ALL RIGHTS RESERVED
  906. C 60=MAX REAL ROWS
  907. C 301=MAX REAL COLS
  908. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  909. C VBLS AND TYPE DIMENSIONED 60,301
  910. C
  911. C *******************************************************
  912. C *                                                     *
  913. C *             SUBROUTINE  CALBIN                      *
  914. C *                                                     *
  915. C *******************************************************
  916. C
  917. C  SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
  918. C
  919. C special version with multiple precision diked out - gce (to save space
  920. C on 256K PC)
  921. C  UPON ENTRANCE TO ROUTINE:
  922. C    OPERAND1 IS IN STACK1  (ST1PT-1)
  923. C    OPERAND2 IS ON TOP OF STACK2  (ST2PT-1)
  924. C    OPERATOR IS BELOW OPERAND2  (ST2PT-2)
  925. C  UPON EXIT:
  926. C    RESULT IS IN STACK1
  927. C    STACK2 HAS BEEN CLEANED UP
  928. C
  929. C  RETURN CODE    MEANING
  930. C    1    NORMAL RETURN
  931. C    2    OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  932. C    3    ERROR RETURN
  933. C
  934. C
  935. C
  936. C  MODIFICATION CLASSES: M3, M4, AND M8
  937. C
  938. C
  939. C
  940. C  CALBIN CALLS
  941. C
  942. C  CONTYP   CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
  943. C  ERRMSG   PRINTS OUT ERROR MESSAGES
  944. C  MULADD   PERFORMS MULTIPLE PRECISION ADDITION
  945. C  MULDIV   PERFORMS MULTIPLE PRECISION DIVISION
  946. C  MULMUL   PERFORMS MULTIPLE PRECISION MULTIPLICATION
  947. C
  948. C
  949. C
  950. C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
  951. C
  952. C
  953. C
  954. C
  955. C   VARIABLE     USE
  956. C
  957. C  EIGHT(8)      PICKS OUT A REAL CONSTANT FROM STACK.
  958. C  FOUR(4)       PICKS OUT AN INTEGER CONSTANT FROM STACK.
  959. C  I,J           HOLD TEMPORARY VALUES.
  960. C  IA            FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
  961. C                VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
  962. C  ID            USED TO CONVERT DECISION TABLE CHARACTER*1 VALUE TO
  963. C                AN InTeGer*4 VALUE THAT CAN BE USED AS AN ARGUMENT
  964. C                IN A CALL TO CONTYP.
  965. C  INT,IHOLD     HOLD INTEGER*4 VALUES.
  966. C  IOP           HOLDS THE BINARY OPERATOR.
  967. C  IOP2          USED TO INDEX A COMPUTED GO.
  968. C  ISW           HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
  969. C  MINUS         VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  970. C                NUMBER THAT IS USED TO INDICATE A NEGATIVE.
  971. C  OP1TYP        TYPE OF OPERAND 1.
  972. C  OP2TYP        TYPE OF OPERAND 2.
  973. C  PLUS          VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  974. C                NUMBER THAT IS USED TO INDICATE POSITIVE.
  975. C  PT1,PT2       POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
  976. C  REAL,RHOLD    HOLD TEMPORARY REAL*8 VALUES.
  977. C  RETCD         ERROR RETURN:  1 = O.K.   2 = RESULT WAS OUTPUT
  978. C                3 = ERROR
  979. C
  980. C
  981. C    SUBROUTINE CALBIN(RETCD)
  982.     REAL*8 REAL,RHOLD,DFLOAT
  983. C
  984.     INTEGER*4 INT,IHOLD
  985. C
  986.     InTeGer*4 LEVEL,NONBLK,LEND
  987.     InTeGer*4 VLEN(9)
  988.     InTeGer*4 IOP,IA,ID,IOP2,ISW
  989.     InTeGer*4 PLUS,MINUS
  990.     InTeGer*4 OLDTYP,VIEWSW,BASED
  991.     InTeGer*4 TYPE(1,1)
  992.     InTeGer*4 RETCD,RETCD2
  993.     InTeGer*4 OP1TYP,OP2TYP
  994.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  995.     InTeGer*4 PT1,PT2
  996. C
  997.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  998.     InTeGer*4 STK12(2,40)
  999.     REAL*8 XVBLK
  1000.     EQUIVALENCE(STK12(1,1),STACK1(1,1))
  1001.     CHARACTER*1 AVBLS(20,27), DTBL1(9,9,8)
  1002.     CHARACTER*1 VBLS(8,1,1)
  1003.     EQUIVALENCE (XVBLK,VBLS(1,1,1))
  1004.     CHARACTER*1 EIGHT(8),FOUR(4)
  1005.     CHARACTER*1 LINE(80)
  1006. C
  1007.     EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
  1008. C
  1009.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1010.     COMMON/V/ TYPE,AVBLS,VBLS,VLEN
  1011.     COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  1012.      ;         ST1LIM,ST2LIM
  1013.     COMMON /DECIDE/DTBL1
  1014. C
  1015. C
  1016.     DATA PLUS/0/,MINUS/1/
  1017. C
  1018. C
  1019.     RETCD=1
  1020.     PT1=ST1PT-1
  1021.     PT2=ST2PT-1
  1022. C
  1023.     IOP=ST2TYP(ST2PT-2)
  1024.     OP1TYP=ST1TYP(PT1)
  1025.     OP2TYP=ST2TYP(PT2)
  1026. C NOTE THAT IA IS UNUSED HERE... SAVE BIG DIMENSIONS
  1027.     IA=ICHAR(STACK1(1,PT1))
  1028.     ID1=STK12(1,PT1)
  1029.     ID2=STK12(2,PT1)
  1030. C    CALL GETDM(STACK1(1,PT1),ID1,ID2)
  1031. C ****&&&& ABOVE GETS LOCS IN 2 DIM ARRAY OF VARIABLES
  1032.     IF (IOP.NE.200) GOTO 100
  1033. C
  1034. C
  1035. C
  1036. C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
  1037.     IF(OP1TYP.GE.0) GO TO 5
  1038. C
  1039. C
  1040. C
  1041. C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
  1042.     OP1TYP=-OP1TYP
  1043.     ST1TYP(PT1)=OP1TYP
  1044. C
  1045. C
  1046. C
  1047. C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
  1048. C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE  I=J=2
  1049. 5    J=VLEN(OP2TYP)
  1050. C    TYPE(IA)=OP1TYP
  1051.     CALL TYPSET(ID1,ID2,OP1TYP)
  1052. C    TYPE(ID1,ID2)=OP1TYP
  1053. C *&*****&&&&& NOTE TYPE ARRAY AND VBLS ARRAY NOW ARE HUGE
  1054. C  NOTE FURTHER THAT AVBLS IS OLD VBLS ARRAY. SWITCHED ON IF
  1055. C ID1 =< 27 AND ID2=1.
  1056.     DO 10 I=1,J
  1057. 10    STACK1(I,PT1)=STACK2(I,PT2)
  1058.     CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
  1059.     GOTO (20,9999), RETCD2
  1060.     STOP 20
  1061. C
  1062. C
  1063. C THE SPECIFIED VARIABLE GETS NEW VALUE.
  1064. C ***&&&& HERE'S WHERE WE STORE A VALUE INTO A VARIABLE...
  1065. 20    J=VLEN(OP1TYP)
  1066.     DO 30 I=1,J
  1067. C    VBLS(I,IA)=STACK1(I,PT1)
  1068.     IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 22
  1069. C REPLACE VBLSET CALL WITH XVBLST CALL ON LAST PASS TO AVOID
  1070. C MULTIPLE REPLACEMENT OF STORAGE FOR EVERY PASS.
  1071.     VBLS(I,1,1)=STACK1(I,PT1)
  1072.     IF(I.EQ.J)CALL XVBLST(ID1,ID2,XVBLK)
  1073. C    CALL VBLSET(I,ID1,ID2,STACK1(I,PT1))
  1074. C    VBLS(I,ID1,ID2)=STACK1(I,PT1)
  1075.     GOTO 30
  1076. 22    AVBLS(I,ID1)=STACK1(I,PT1)
  1077. C *****&&&&&
  1078. 30    CONTINUE
  1079.     GOTO 10000
  1080. C
  1081. C
  1082. C  IOP2 VALUES 1="**"  2="*"   3="/"   4="+"   5="-"
  1083. 100    IOP2=IOP-111
  1084.     GOTO (1000,2000,2000,2000,2000),IOP2
  1085. C
  1086. C
  1087. C    ********************************************
  1088. C    ***********  EXPONENTIATION  ***************
  1089. C    ********************************************
  1090. C
  1091. C
  1092. C  FIRST CONVERT TO PROPER TYPE
  1093. 1000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,5))
  1094.     CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
  1095.     IF (RETCD2.EQ.2) GOTO 9999
  1096.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,6))
  1097.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1098.     IF (RETCD2.EQ.2) GOTO 9999
  1099. C
  1100. C
  1101. C  GOTO APPROPRIATE PLACE TO PERFORM OPERATION
  1102.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,8))
  1103.     GOTO (1100,1200,1300,1400,1500,1600,1700),ID
  1104.     STOP 1000
  1105. C
  1106. C
  1107. C  REAL**REAL
  1108. 1100    DO 1104 I=1,8
  1109. 1104    EIGHT(I)=STACK1(I,PT1)
  1110.     RHOLD=REAL
  1111.     DO 1108 I=1,8
  1112. 1108    EIGHT(I)=STACK2(I,PT2)
  1113.     REAL=RHOLD**REAL
  1114. C
  1115. C
  1116. C  USED BY REAL**I
  1117. 1109    DO 1110 I=1,8
  1118. 1110    STACK1(I,PT1)=EIGHT(I)
  1119. C
  1120. C
  1121. C  USED BY I**REAL,I**I
  1122. 1114    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,7))
  1123.     GOTO 10000
  1124. C
  1125. C
  1126. C
  1127. C  REAL**I
  1128. 1200    DO 1204 I=1,8
  1129. 1204    EIGHT(I)=STACK1(I,PT1)
  1130.     DO 1208 I=1,4
  1131. 1208    FOUR(I)=STACK2(I,PT2)
  1132.     REAL=REAL**INT
  1133.     GOTO 1109
  1134. C
  1135. C
  1136. C
  1137. C  I**REAL (PARTS USED BY I**I)
  1138. 1300    DO 1304 I=1,4
  1139. 1304    FOUR(I)=STACK1(I,PT1)
  1140.     DO 1308 I=1,8
  1141. 1308    EIGHT(I)=STACK2(I,PT2)
  1142. C
  1143. C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
  1144. C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
  1145. C
  1146.     INT=DFLOAT(INT)**REAL
  1147. 1310    DO 1314 I=1,4
  1148. 1314    STACK1(I,PT1)=FOUR(I)
  1149.     GOTO 1114
  1150. C
  1151. C
  1152. C
  1153. C  I**I
  1154. 1400    DO 1404 I=1,4
  1155. 1404    FOUR(I)=STACK1(I,PT1)
  1156.     IHOLD=INT
  1157.     DO 1408 I=1,4
  1158. 1408    FOUR(I)=STACK2(I,PT2)
  1159.     INT=IHOLD**INT
  1160.     GOTO 1310
  1161. C
  1162. C
  1163. C
  1164. C  M8**I    (PARTS USED BY M10**I, M16**I)
  1165. 1500    ISW=8
  1166. 1501    IF(ST2PT.LE.ST2LIM)GO TO 1502
  1167. C
  1168. C
  1169. C STACK OVERFLOW
  1170.     CALL ERRMSG(9)
  1171.     GO TO 9999
  1172. C
  1173. C
  1174. C GET EXPONENT AS AN INTEGER
  1175. 1502    DO 1504 I=1,4
  1176. 1504    FOUR(I)=STACK2(I,PT2)
  1177.     IF (INT.GE.0) GOTO 1520
  1178. C
  1179. C
  1180. C EXPONENT NOT POSITIVE OR 0
  1181.     CALL ERRMSG (15)
  1182.     GOTO 9999
  1183. 1520    IF (INT.GT.0) GOTO 1530
  1184. C
  1185. C
  1186. C I**0 = 1
  1187.     STACK1(8,PT1)=PLUS
  1188.     DO 1522 I=2,7
  1189. 1522    STACK1(I,PT1)=0
  1190. C LEAVE AS INTEGER SETS HERE RATHER THAN EXPLICIT CHAR() CALLS
  1191.     STACK1(1,PT1)=1
  1192.     GOTO 10000
  1193. C
  1194. C
  1195. C EXPONENT IS > 0
  1196. 1530    INT=INT-1
  1197. C
  1198. C
  1199. C IF EXPONENT = 1 WE ARE DONE
  1200.     IF(INT.EQ.0)GO TO 10000
  1201. C
  1202. C
  1203. C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
  1204. C FACTOR.
  1205.     DO 1534 I=1,8
  1206. 1534    STACK2(I,ST2PT)=STACK1(I,PT1)
  1207.     ST2TYP(ST2PT)=ST1TYP(PT1)
  1208. C
  1209. C
  1210. C
  1211. C
  1212. 1549    continue
  1213. c1549    DO 1550 I=1,INT
  1214. c    CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
  1215. c    IF(RETCD2.GE.2)GO TO 9999
  1216. c1550    CONTINUE
  1217.     GOTO 10000
  1218. C
  1219. C  M10**I
  1220. 1600    ISW=10
  1221.     GOTO 1501
  1222. C
  1223. C
  1224. C
  1225. C  M16**I
  1226. 1700    ISW=16
  1227.     GOTO 1501
  1228. C
  1229. C
  1230. C  *****************************************
  1231. C  * MAKE CONVERSIONS APPROPRIATE FOR */+- *
  1232. C  *****************************************
  1233. 2000    CONTINUE
  1234.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,1))
  1235.     CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
  1236.     IF (RETCD2.EQ.2) GOTO 9999
  1237.     IF(ID.EQ.0)GO TO 2010
  1238.     ST1TYP(PT1)=ID
  1239.     OP1TYP=ID
  1240. 2010    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,2))
  1241.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1242.     IF (RETCD2.EQ.2) GOTO 9999
  1243.     IF(ID.EQ.0)GOTO 2020
  1244.     ST2TYP(PT2)=ID
  1245.     OP2TYP=ID
  1246. C
  1247. 2020    CONTINUE
  1248. C
  1249. C
  1250. C  GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
  1251.     GOTO (2100,3000,4000,5000,6000),IOP2
  1252. 2100    STOP 2100
  1253. C
  1254. C
  1255. C
  1256. C
  1257. C
  1258. C
  1259. C  **********************************************
  1260. C  ***********  MULTIPLICATION  *****************
  1261. C  **********************************************
  1262. 3000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1263.     GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
  1264.     STOP 3000
  1265. C
  1266. C
  1267. C  ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
  1268. 3100    CALL ERRMSG (12)
  1269.     GOTO 9999
  1270. C
  1271. C
  1272. C  DECIMAL, REAL
  1273. 3200    DO 3204 I=1,8
  1274. 3204    EIGHT(I)=STACK1(I,PT1)
  1275.     RHOLD=REAL
  1276.     DO 3208 I=1,8
  1277. 3208    EIGHT(I)=STACK2(I,PT2)
  1278.     REAL=RHOLD*REAL
  1279. 3209    DO 3210 I=1,8
  1280. 3210    STACK1(I,PT1)=EIGHT(I)
  1281. C
  1282. C
  1283. C  FOLLOWING USED BY OTHER SECTIONS
  1284. 3220    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,3))
  1285.     GOTO 10000
  1286. C
  1287. C
  1288. C
  1289. C  HEX,INTEGER,OCTAL
  1290. 3300    DO 3304 I=1,4
  1291. 3304    FOUR(I)=STACK1(I,PT1)
  1292.     IHOLD=INT
  1293.     DO 3308 I=1,4
  1294. 3308    FOUR(I)=STACK2(I,PT2)
  1295.     INT=IHOLD*INT
  1296. 3309    DO 3310 I=1,4
  1297. 3310    STACK1(I,PT1)=FOUR(I)
  1298.     GOTO 3220
  1299. C
  1300. C
  1301. C
  1302. C  M10
  1303. 3500    continue
  1304. c3500    CALL MULMUL (PT1,PT2,RETCD2,10)
  1305. C
  1306. C
  1307. C  FOLLOWING USED BY OTHER SECTIONS
  1308. 3510    IF (RETCD2.EQ.2) GOTO 9999
  1309.     GOTO 3220
  1310. C
  1311. C
  1312. C
  1313. C  M8
  1314. 3600    continue
  1315. c3600    CALL MULMUL (PT1,PT2,RETCD2,8)
  1316.     GOTO 3510
  1317. C
  1318. C
  1319. C
  1320. C  M16
  1321. 3700    continue
  1322. c3700    CALL MULMUL (PT1,PT2,RETCD2,16)
  1323.     GOTO 3510
  1324. C
  1325. C
  1326. C  **************************************************
  1327. C  ******************  DIVISION  ********************
  1328. C  **************************************************
  1329. 4000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1330.     GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
  1331.     STOP 4000
  1332. C
  1333. C
  1334. C  DECIMAL,REAL
  1335. 4200    DO 4204 I=1,8
  1336. 4204    EIGHT(I)=STACK1(I,PT1)
  1337.     RHOLD=REAL
  1338.     DO 4208 I=1,8
  1339. 4208    EIGHT(I)=STACK2(I,PT2)
  1340.     IF(REAL.NE.0.D0)GO TO 4210
  1341.     CALL ERRMSG(23)
  1342.     GO TO 9999
  1343. 4210    REAL=RHOLD/REAL
  1344.     GOTO 3209
  1345. C
  1346. C
  1347. C  HEX,INTEGER,OCTAL
  1348. 4300    DO 4304 I=1,4
  1349. 4304    FOUR(I)=STACK1(I,PT1)
  1350.     IHOLD=INT
  1351.     DO 4308 I=1,4
  1352. 4308    FOUR(I)=STACK2(I,PT2)
  1353.     IF(INT.NE.0)GO TO 4310
  1354.     CALL ERRMSG(23)
  1355.     GO TO 9999
  1356. 4310    INT=IHOLD/INT
  1357.     GOTO 3309
  1358. C
  1359. C
  1360. C  M10
  1361. 4500    continue
  1362. c4500    CALL MULDIV (PT1,PT2,RETCD2,10)
  1363.     GOTO 3510
  1364. C
  1365. C
  1366. C  M8
  1367. 4600    continue
  1368. c4600    CALL MULDIV (PT1,PT2,RETCD2,8)
  1369.     GOTO 3510
  1370. C
  1371. C
  1372. C  M16
  1373. 4700    continue
  1374. c4700    CALL MULDIV (PT1,PT2,RETCD2,16)
  1375.     GOTO 3510
  1376. C
  1377. C
  1378. C
  1379. C
  1380. C
  1381. C **************************************************
  1382. C *****************  ADDITION  *********************
  1383. C **************************************************
  1384. C
  1385. 5000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1386.     GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
  1387.     STOP 5000
  1388. C
  1389. C
  1390. C  DECIMAL, REAL
  1391. 5200    DO 5204 I=1,8
  1392. 5204    EIGHT(I)=STACK1(I,PT1)
  1393.     RHOLD=REAL
  1394.     DO 5208 I=1,8
  1395. 5208    EIGHT(I)=STACK2(I,PT2)
  1396.     REAL=RHOLD+REAL
  1397.     GOTO 3209
  1398. C
  1399. C
  1400. C  HEX,INTEGER,OCTAL
  1401. 5300    DO 5304 I=1,4
  1402. 5304    FOUR(I)=STACK1(I,PT1)
  1403.     IHOLD=INT
  1404.     DO 5308 I=1,4
  1405. 5308    FOUR(I)=STACK2(I,PT2)
  1406.     INT=IHOLD+INT
  1407.     GOTO 3309
  1408. C
  1409. C
  1410. C  M10
  1411. 5500    continue
  1412. c5500    CALL MULADD (PT1,PT2,RETCD2,1)
  1413.     GOTO 3510
  1414. C
  1415. C
  1416. C  M8
  1417. 5600    continue
  1418. c5600    CALL MULADD (PT1,PT2,RETCD2,2)
  1419.     GOTO 3510
  1420. C
  1421. C
  1422. C  M16
  1423. 5700    continue
  1424. c5700    CALL MULADD(PT1,PT2,RETCD2,3)
  1425.     GOTO 3510
  1426. C
  1427. C
  1428. C
  1429. C
  1430. C
  1431. C
  1432. C  ***************************************************
  1433. C  ******************  SUBTRACTION  ******************
  1434. C  ***************************************************
  1435. C
  1436. 6000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1437.     GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
  1438.     STOP 6000
  1439. C
  1440. C
  1441. C  DECIMAL,REAL
  1442. 6200    DO 6204 I=1,8
  1443. 6204    EIGHT(I)=STACK1(I,PT1)
  1444.     RHOLD=REAL
  1445.     DO 6208 I=1,8
  1446. 6208    EIGHT(I)=STACK2(I,PT2)
  1447.     REAL=RHOLD-REAL
  1448.     GOTO 3209
  1449. C
  1450. C
  1451. C  HEX,INTEGER,OCTAL
  1452. 6300    DO 6304 I=1,4
  1453. 6304    FOUR(I)=STACK1(I,PT1)
  1454.     IHOLD=INT
  1455.     DO 6308 I=1,4
  1456. 6308    FOUR(I)=STACK2(I,PT2)
  1457.     INT=IHOLD-INT
  1458.     GOTO 3309
  1459. C
  1460. C
  1461. C  M10
  1462. 6500    continue
  1463. c6500    CALL MULADD (PT1,PT2,RETCD2,4)
  1464.     GOTO 3510
  1465. C
  1466. C
  1467. C  M8
  1468. 6600    continue
  1469. c6600    CALL MULADD (PT1,PT2,RETCD2,5)
  1470.     GOTO 3510
  1471. C
  1472. C
  1473. C  M16
  1474. 6700    continue
  1475. c6700    CALL MULADD (PT1,PT2,RETCD2,6)
  1476.     GOTO 3510
  1477. C
  1478. C
  1479. C
  1480. C
  1481. C
  1482. C    EXIT
  1483. 9999    RETCD=3
  1484. C
  1485. C
  1486. C
  1487. 10000    ST2PT=ST2PT-2
  1488.     RETURN
  1489.     END
  1490. c -h- calc.for    Fri Aug 22 13:00:17 1986    
  1491.     SUBROUTINE CALC
  1492. C COPYRIGHT (C) 1983 GLENN EVERHART
  1493. C ALL RIGHTS RESERVED
  1494. C 60=MAX REAL ROWS
  1495. C 301=MAX REAL COLS
  1496. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1497. C VBLS AND TYPE DIMENSIONED 60,301
  1498. C ***               CALC   MAINLINE                   ***
  1499. C
  1500. C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
  1501. C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
  1502. C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
  1503. C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN
  1504. C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
  1505. C POSSIBLE COMMANDS.
  1506. C
  1507. C    CALC CALLS
  1508. C
  1509. C  ASSIGN    OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
  1510. C  CLOSE     CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
  1511. C  CMND      DETERMINES WHAT CALC COMMAND IS REQUIRED.
  1512. C  ERRCX     CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
  1513. C  ERRMSG    PRINTS OUT ERROR MESSAGES.
  1514. C  EXIT      RETURNS TO OPERATING SYSTEM.
  1515. C  GETMCR    GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
  1516. C            IS PRESENT, CALC EXITS AFTER THAT ONE COMMAND IS EXECUTED.
  1517. C  INPOST    CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
  1518. C  LIST      LISTS THE LEGAL CALC COMMANDS.
  1519. C  POSTVL    CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
  1520. C            A VALUE.
  1521. C  SLEND     FINDS THE LAST NON-BLANK IN LINE(80).
  1522. C  VAROUT    PRINTS OUT THE VALUE OF A VARIABLE.
  1523. C  ZNEG      DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
  1524. C
  1525. C
  1526. C
  1527. C   VARIABLE      USE
  1528. C
  1529. C  BASED        DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
  1530. C  BLANK        ' '
  1531. C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
  1532. C               SECOND SUBSCRIPT IS
  1533. C                     1 FOR DECIMAL
  1534. C                     2 FOR OCTAL
  1535. C                     3 FOR HEXADECIMAL
  1536. C  I,J          HOLD TEMPORARY VALUES.
  1537. C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
  1538. C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
  1539. C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
  1540. C               USED TO CONTROL ITERATION.
  1541. C        THIS VARIABLE IS GUARANTEED TO BE 1-27.
  1542. C  LEND         POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
  1543. C  LEVEL        HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
  1544. C               LINES COME FROM.
  1545. C  LINE(80)     COMMAND INPUT LINE.
  1546. C  NONBLK       POINTS TO LAST NON-BLANK FOUND IN LINE(80).
  1547. C  ONCE         HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
  1548. C               0 OTHERWISE.
  1549. C  STAR         '*'
  1550. C  VIEWSW           VIEW SWITCH
  1551. C                    0 = OUTPUT ERROR MESSAGES
  1552. C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
  1553. C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
  1554. C                        EVALUATED.
  1555. C                    3 = OUTPUT EVERYTHING
  1556. C  WHAT         '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
  1557. C               SHOULD BE OUTPUT.
  1558. C
  1559. C    MODIFIED    REASON
  1560. C
  1561. C    18-MAY-1981    DELETED LINE THAT CAUSED DEFAULT BASE TO BE RESET
  1562. C            WHEN AN ERROR OCCURS (PB)
  1563. C
  1564. C    18-MAY-1981    ADDED CODE AT LINES 106 TO 108 TO CONVERT FROM LOWER
  1565. C            TO UPPER CASE  (PB)
  1566. C
  1567. C CHANGED TO SUBROUTINE GCE TO ALLOW EXTERNAL CONTROL OF CALCULATOR.
  1568. C
  1569.     InTeGer*4 LEVEL,NONBLK,LEND
  1570.     InTeGer*4 RETCD,VIEWSW,BASED
  1571.     InTeGer*4 ONCE
  1572.     InTeGer*4 ZNEG,ITCNTV(6)
  1573. C
  1574.     CHARACTER*1  LINE(80),WHAT,STAR,QUOTE
  1575.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  1576.     CHARACTER*1 DIGITS(16,3)
  1577.     CHARACTER*1 OARRY(100)
  1578.     InTeGer*4 OSWIT,OCNTR
  1579. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1580. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1581.     InTeGer*4 IPS1,IPS2,MODFLG
  1582. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1583.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1584.        CHARACTER*1 XTNCMD(80)
  1585. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1586. C VARY FLAG ITERATION COUNT
  1587.     INTEGER KALKIT
  1588. C    COMMON/VARYIT/KALKIT
  1589.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1590.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1591. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1592. C     1  IRCE2
  1593. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1594. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1595. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1596. C RCFGX ON.
  1597. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1598. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1599. C  AND VM INHIBITS. (SETS TO 1).
  1600.     INTEGER*4 FH
  1601. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1602. C    COMMON/CONSFH/FH
  1603.     CHARACTER*1 ARGSTR(52,4)
  1604. C    COMMON/ARGSTR/ARGSTR
  1605.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  1606.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1607.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1608.      3  IRCE2,FH,ARGSTR
  1609.     InTeGer*4 ILNFG,ILNCT
  1610.     CHARACTER*1 ILINE(106)
  1611.     COMMON/ILN/ILNFG,ILNCT,ILINE
  1612. C
  1613.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1614.     InTeGer*4 RRWACT,RCLACT
  1615. C    COMMON/RCLACT/RRWACT,RCLACT
  1616.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  1617.      1  IDOL7,IDOL8
  1618. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  1619. C     1  IDOL7,IDOL8
  1620.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  1621. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1622.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1623. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1624. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  1625. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  1626.     InTeGer*4 KLVL
  1627. C    COMMON/KLVL/KLVL
  1628.     InTeGer*4 IOLVL,IGOLD
  1629. C    COMMON/IOLVL/IOLVL
  1630. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  1631. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  1632.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1633.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1634.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  1635. C    COMMON/KLVL/KLVL
  1636.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  1637.     COMMON /DIGV/ DIGITS
  1638.     COMMON/ITERA/ITCNTV
  1639. C
  1640.     DATA  WHAT/'?'/, STAR/'*'/, QUOTE/''''/
  1641.     DATA ONCE/0/
  1642. C
  1643. C
  1644. C
  1645. C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
  1646. C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
  1647. C THE MODULES PROPERLY, PUT IN A
  1648.     IF(KLVL.EQ.1)LEVEL=KLVL
  1649.     ONCE=0
  1650. C    IF(ILNFG.NE.0) GOTO 6000
  1651. C    CALL ASSIGN (1,'TT:')
  1652. 6000    CONTINUE
  1653. C CHANGE TI: TO TT: FOR VMS.
  1654. C
  1655.     IF(ILNFG.EQ.0)GOTO 6010
  1656.     IF(ILNCT.GT.0)GOTO 6010
  1657. C INVALID INPUTS...NO LINE TO DO BUT FLAGGED TO DO. CLEAN UP.
  1658.     ILNFG=0
  1659.     RETURN
  1660. 6010    CONTINUE
  1661.     IF(ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6001
  1662. C ++++++
  1663. C FOR DEC FORTRAN:
  1664. C    CALL GETMCR(LINE,LEND)
  1665. C    IF(LEND)20,20,5
  1666. C FOR NON-DEC FORTRAN: (OR VAX VERSIONS)
  1667.     GOTO 20
  1668. C ++++++  END OF CHOICES...
  1669. 5    CONTINUE
  1670.     GOTO 6003
  1671. 6001    CONTINUE
  1672.     DO 6007 LENDX=1,80
  1673. 6007    LINE(LENDX)=CHAR(32)
  1674.     IF(ILNFG.EQ.1)ONCE=1
  1675.     I255X=0
  1676.     DO 6002 LENDX=1,ILNCT
  1677.     LINE(LENDX)=ILINE(LENDX)
  1678.     IF(ICHAR(LINE(LENDX)).EQ.255)I255X=3
  1679.     IF(I255X.LE.0)GOTO 4602
  1680.     I255X=I255X-1
  1681.     GOTO 6002
  1682. C SKIP ENTIRE 3-CHR PACKED CODES
  1683. 4602    CONTINUE
  1684.     IF(ICHAR(LINE(LENDX)).GT.0.AND.ICHAR(LINE(LENDX)).LT.32)
  1685.      1  LINE(LENDX)=CHAR(32)
  1686. C LEAVE ANY EXISTING NULLS IN.
  1687. 6002    CONTINUE
  1688.     LEND=ILNCT
  1689. CD    CALL FRMEDT(LINE,LEND)
  1690. C FRMEDT IMPLEMENTS EDITS OF {VAR INTO THAT VARIABLE'S FORMULA
  1691. CC NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1692. C    ICCC=MIN0(80,(LEND+1))
  1693. C    LINE(ICCC)=0
  1694.     GOTO 103
  1695. 6003    CONTINUE
  1696.     DO 6 NONBLK=1,7
  1697.     IF(LINE(NONBLK).EQ.BLANK)GO TO 7
  1698.     IF(ICHAR(LINE(NONBLK)).EQ.13)GO TO 20
  1699. 6    CONTINUE
  1700.     STOP 6
  1701. 7    NONBLK=NONBLK+1
  1702.     ONCE=1
  1703.     GO TO 106
  1704. C
  1705. C  ERROR RESET
  1706.  
  1707. 10    IF(LEVEL.LE.1) GO TO 12
  1708.     CLOSE(LEVEL)
  1709.     LEVEL=LEVEL-1
  1710.     GO TO 10
  1711. 12    CONTINUE
  1712.     VIEWSW=3
  1713. C
  1714. C
  1715. C  GET NEXT INPUT LINE
  1716. 20    CONTINUE
  1717.     LINE(1)=0
  1718.     LINE(2)=0
  1719.     IF(ONCE.EQ.1.AND.LEVEL.LE.1) RETURN
  1720. C20    IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL EXIT
  1721. C    IF (ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6004
  1722.     IF (LEVEL.LE.1.AND.ILNFG.NE.0.AND.ILNCT.GT.0)RETURN
  1723.     IF(LEVEL.LT.1)RETURN
  1724.     IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)WRITE(11,22)
  1725. 22    FORMAT(' CALC>')
  1726. C
  1727. C
  1728.     LLLV=LEVEL
  1729.     IF(LLLV.EQ.1)LLLV=11
  1730.     rewind 11
  1731.     READ (LLLV,24,END=900,ERR=1000) LINE
  1732.     rewind 11
  1733. 24    FORMAT (80A1)
  1734. C    GOTO 6005
  1735. C SECTION BELOW COMMENTED OUT BECAUSE IT SHOULD NEVER BE CALLED (GCE).
  1736. C6004    CONTINUE
  1737. C    DO 6006 LENDX=1,80
  1738. C6006    LINE(LENDX)=CHAR(32)
  1739. CC ABOVE BLANKS OUT LINE ARRAY
  1740. C    DO 6007 LENDX=1,ILNCT
  1741. C6007    LINE(LENDX)=ILINE(LENDX)
  1742. CC ABOVE COPIES INPUT FROM OUR CALLER...
  1743. C6005    CONTINUE
  1744. C
  1745. C
  1746. C
  1747. C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
  1748. CD    CALL FRMEDT(LINE,LEND)
  1749.     CALL SLEND(RETCD)
  1750.     GO TO(30,20),RETCD
  1751.     STOP 30
  1752. 30    CONTINUE
  1753. C
  1754. C
  1755.     IF(ILNFG.EQ.0.AND.ILNCT.GT.0)GOTO 103
  1756. C SHOW WHAT WAS READ FROM FILE
  1757.     rewind 11
  1758.     IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
  1759.      1 WRITE(11,40)LEVEL,(LINE(I),I=1,LEND)
  1760.     rewind 11
  1761. 40    FORMAT (' CALC<',I1,'>',80A1)
  1762. 103    CONTINUE
  1763. C NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1764.     ICCC=MIN0(80,(LEND+1))
  1765.     LINE(ICCC)=0
  1766. C
  1767. C  IDENTIFY FIRST NON-BLANK
  1768.     DO 104 NONBLK=1,LEND
  1769.     IF (LINE(NONBLK).NE.BLANK) GOTO 106
  1770. 104    CONTINUE
  1771.     RETURN
  1772. C    STOP 104
  1773. C
  1774. C CONVERT LOWER CASE TO UPPER CASE
  1775. 106    CONTINUE
  1776.     I255X=0
  1777.     DO 108 I=NONBLK,LEND
  1778.     J=ICHAR(LINE(I))
  1779.     IF(J.EQ.255)I255X=3
  1780.     IF(I255X.LE.0)GOTO 3107
  1781. C SKIP ENCODED VARIABLE NAMES
  1782.     I255X=I255X-1
  1783.     GOTO 107
  1784. 3107    CONTINUE
  1785.     IF (I.EQ.NONBLK) GOTO 107
  1786.     IF (LINE(I-1).EQ.QUOTE) GOTO 108
  1787.     IF(J.GE.97.AND.J.LE.122) LINE(I)=CHAR(J-32)
  1788. 107    CONTINUE
  1789. 108    CONTINUE
  1790. C
  1791. C  SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
  1792.     IF (LINE(NONBLK).NE.WHAT) GOTO 110
  1793.     CALL LIST
  1794.     GOTO 20
  1795. C
  1796. C  SEE IF IT IS A COMMAND
  1797. 110    IF (LINE(NONBLK).NE.STAR) GOTO 120
  1798.     CALL CMND (RETCD)
  1799.     GOTO (20,115,10,6120), RETCD
  1800. 6120    RETURN
  1801. C    STOP 110
  1802. C
  1803. C
  1804. C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
  1805. 115    CALL SLEND(RETCD)
  1806.     GO TO (103,20),RETCD
  1807.     RETURN
  1808. C    STOP 115
  1809. C
  1810. C  SEE IF ONLY ONE ALPHA CHARACTER
  1811. 120    J=NONBLK+1
  1812.     IF (LEND.NE.NONBLK) GOTO 130
  1813.     DO 124 I=1,27
  1814.     IF (LINE(NONBLK).EQ.ALPHA(I)) GOTO 126
  1815. 124    CONTINUE
  1816. C
  1817. C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
  1818.     DO 125 I=1,10
  1819.     IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
  1820. 125    CONTINUE
  1821. C
  1822. C
  1823. C ALLOW FOR ENTERING THE ASCII BLANK
  1824.     IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
  1825.     I=1
  1826.     GOTO 1001
  1827. C
  1828. C  OUTPUT VALUE OF SINGLE VARIABLE
  1829. 126    CALL VAROUT(I,1)
  1830.     GOTO 20
  1831. C
  1832. C
  1833. C CHECK INPUT FOR SYNTAX ERRORS
  1834. 130    CALL ERRCX (RETCD)
  1835.     GOTO (140,10),RETCD
  1836.     RETURN
  1837. C    STOP 130
  1838. C
  1839. C  CHANGE FROM INFIX TO POSTFIX NOTATION
  1840. 140    CALL INPOST (RETCD)
  1841.     GOTO (150,10), RETCD
  1842. C
  1843. C
  1844. C EVALUATE EXPRESSION
  1845. 150    CONTINUE
  1846.     CALL POSTVL(RETCD)
  1847.     GOTO(20,10),RETCD
  1848.     RETURN
  1849. C    STOP 150
  1850. C
  1851. C
  1852. C  EXIT
  1853. 900    CONTINUE
  1854.     IF (LEVEL.EQ.1) RETURN
  1855. C    IF (LEVEL.EQ.1) CALL EXIT
  1856.     IF(ITCNTV(LEVEL).EQ.0)GOTO 910
  1857.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
  1858. C
  1859. C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
  1860. C AND EXECUTE AGAIN.
  1861.     REWIND LEVEL
  1862.     GO TO 20
  1863. C
  1864. C
  1865. C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
  1866. C OF LEVEL BY ONE.
  1867. 910    CLOSE(LEVEL)
  1868.     LEVEL=LEVEL-1
  1869.     GOTO 20
  1870. C
  1871. C
  1872. C
  1873. C *** ERROR PROCESSING ***
  1874. 1000    I=27
  1875. 1001    CALL ERRMSG(I)
  1876.     GO TO 10
  1877.     END
  1878. c -h- calun.for    Fri Aug 22 13:00:17 1986    
  1879.     SUBROUTINE CALUN(RETCD)
  1880. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  1881. C ALL RIGHTS RESERVED
  1882. C 60=MAX REAL ROWS
  1883. C 301=MAX REAL COLS
  1884. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1885.  
  1886. C VBLS AND TYPE DIMENSIONED 60,301
  1887. C  *****************************************************
  1888. C  *             SUBROUTINE   CALUN                    *
  1889. C  *****************************************************
  1890. C
  1891. C  SUBROUTINE CALUN PERFORMS A UNARY OPERATION.
  1892. C
  1893. C  UPON ENTRANCE:
  1894. C    OPERATOR IS ON STACK 2
  1895. C    OPERAND IS ON STACK 1
  1896. C  UPON EXIT:
  1897. C    OPERATOR HAS BEEN POPPED OFF STACK 2
  1898. C    RESULT IS ON STACK 1
  1899. C
  1900. C    RETCD    MEANING
  1901. C
  1902. C    1    O.K.
  1903. C    2    ERROR
  1904. C
  1905. C   MODIFICATION CLASSES: M3, M4, AND M8
  1906. C
  1907. C  CALUN CALLS
  1908. C
  1909. C  CONTYP   CONVERTS DATA TYPES
  1910. C  ERRMSG   PRINTS ERROR MESSAGES
  1911. C  $DATAN   ARC TANGENT
  1912. C  $DCOS    COSINE
  1913. C  $DEXP    E**X
  1914. C  $DLOG    NATURAL LOG
  1915. C  $DLOG10  LOG BASE 10
  1916. C  $DSIN    SINE
  1917. C  $DSQRT   SQUARE ROOT
  1918. C  $DTANH   HYPERBOLIC TANGENT
  1919. C
  1920. C  CALUN IS CALLED BY POSTVL WHICH CONVERTS FROM INFIX TO POSTFIX
  1921. C
  1922. C     VARIABLE    USE
  1923. C
  1924. C  RETCD      RETURN CODE:  1 = O.K.   2 = ERROR
  1925. C  J,K,K2,I   HOLD TEMPORARY VALUES
  1926. C  MINUS      VALUE IN LAST MULTIPLE PRECISION BYTE.
  1927. C             USED TO INDICATE A NEGATIVE NUMBER.
  1928. C  PLUS       VALUE IN LAST MULTIPLE PRCISION BYTE.
  1929. C             USED TO INDICATE A POSITIVE NUMBER.
  1930. C  REAL       TEMPORARY DOUBLE PRECISION VALUES.
  1931. C  INT        TEMPORARY INTEGER*4 VALUES.
  1932. C  ST1TYP(40) TYPE FOR EACH ELEMENT ON STACK 1
  1933. C  ST2TYP(40) TYPE FOR EACH ELEMENT OF STACK 2
  1934. C  ST1PT      POINTS TO TOP OF STACK 1
  1935. C  ST2PT      POINTS TO TOP OF STACK 2
  1936. C  STACK1     HOLDS OPERAND
  1937. C  STACK2     HOLDS UNARY OPERATOR
  1938. C
  1939. C    SUBROUTINE CALUN(RETCD)
  1940.     REAL*8 REAL
  1941.     REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
  1942.     REAL*8 DASIN,DACOS,DTAN
  1943.     REAL*8 DTANH,DATAN
  1944. C
  1945.     REAL*4 FLOAT
  1946. C
  1947.     INTEGER*4 INT
  1948. C
  1949.     InTeGer*4 RETCD,RETCD2
  1950.     InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT,ST1LIM,ST2LIM
  1951.     InTeGer*4 K,K2
  1952. C
  1953.     CHARACTER*1 STACK1(8,40),STACK2(8,40),FOUR(4),EIGHT(8)
  1954.     CHARACTER*1 PLUS,MINUS
  1955. C
  1956.     EQUIVALENCE (FOUR,INT),(EIGHT,REAL)
  1957. C
  1958.     COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,
  1959.      ;          ST1TYP,ST2TYP,ST1LIM,ST2LIM
  1960. C
  1961. C    DATA PLUS/0/,MINUS/1/
  1962. C
  1963.     PLUS=0
  1964.     MINUS=1
  1965.     RETCD=1
  1966.     K=ST2TYP(ST2PT-1)
  1967.     K2=ST1TYP(ST1PT-1)
  1968. C
  1969. C
  1970. C MAKE SURE VARIABLE IS DEFINED
  1971.     IF(K2.GT.0)GOTO 50
  1972. C IF NOT, PRINT MESSAGE AND RETURN
  1973.     CALL ERRMSG(16)
  1974.     GOTO 89999
  1975. C
  1976. 50    J=K
  1977. C
  1978. C
  1979. C SEE IF IT IS A UNARY MINUS
  1980.     IF (J.EQ.111) GOTO 100
  1981. C
  1982. C
  1983. C  FUNCTIONS START AT 31
  1984.     K=K-30
  1985.     GOTO (100,100,300,400,500,400,10000),K
  1986.     GOTO 10000
  1987. C
  1988. C
  1989. C  ***************************************
  1990. C  *** ABS (=DABS), IABS, AND UNARY -  ***
  1991. C  ***************************************
  1992. 100    CONTINUE
  1993.     IF(K2.GT.0)GO TO 105
  1994.     CALL ERRMSG(16)
  1995.     GO TO 89999
  1996. 105    GOTO (110,120,130,130,140,140,140,130,120),K2
  1997.     STOP 100
  1998. C
  1999. C
  2000. C  ASCII
  2001. 110    CALL ERRMSG (12)
  2002.     GOTO 89999
  2003. C
  2004. C
  2005. C  DECIMAL AND REAL
  2006. 120    DO 121 I=1,8
  2007. 121    EIGHT(I)=STACK1(I,ST1PT-1)
  2008.     IF (K.NE.111) GOTO 123
  2009. C
  2010. C
  2011. C  UNARY -
  2012.     REAL=-REAL
  2013.     GOTO 124
  2014. 123    REAL=DABS(REAL)
  2015. 124    DO 125 I=1,8
  2016. 125    STACK1(I,ST1PT-1)=EIGHT(I)
  2017.     GOTO 90000
  2018. C
  2019. C
  2020. C  INTEGER, HEXADECIMAL, AND OCTAL
  2021. 130    DO 131 I=1,4
  2022. 131    FOUR(I)=STACK1(I,ST1PT-1)
  2023.     IF (K.NE.111) GOTO 133
  2024.     INT=-INT
  2025.     GO TO 134
  2026. 133    IF(INT.LT.0)INT=-INT
  2027. 134    DO 135 I=1,4
  2028. 135    STACK1(I,ST1PT-1)=FOUR(I)
  2029.     GOTO 90000
  2030. C
  2031. C
  2032. C  MULTIPLE PRECISION
  2033. 140    IF (K.NE.111) GOTO 150
  2034.     IF (STACK1(8,ST1PT-1).EQ.PLUS)GOTO 160
  2035. 150    STACK1(8,ST1PT-1)=PLUS
  2036.     GOTO 90000
  2037. 160    STACK1(8,ST1PT-1)=MINUS
  2038.     GOTO 90000
  2039. C
  2040. C
  2041. C  ***************************************
  2042. C  ************  FLOAT  ******************
  2043. C  ***************************************
  2044. 300    CONTINUE
  2045.     GOTO (310,320,330,330,340,340,340,330,320),K2
  2046. C
  2047. C
  2048. C  ASCII
  2049. 310    CALL ERRMSG(12)
  2050.     GOTO 89999
  2051. C
  2052. C
  2053. C  REAL (=DECIMAL)
  2054. 320    CALL ERRMSG (13)
  2055.     GOTO 89999
  2056. C
  2057. C
  2058. C  INTEGER=HEXADECIMAL=OCTAL
  2059. 330    DO 333 I=1,4
  2060. 333    FOUR(I)=STACK1(I,ST1PT-1)
  2061.     REAL=FLOAT(INT)
  2062.     DO 335 I=1,8
  2063. 335    STACK1(I,ST1PT-1)=EIGHT(I)
  2064.     ST1TYP(ST1PT-1)=2
  2065.     GOTO 90000
  2066. C
  2067. C
  2068. C  MULTIPLE PRECISION
  2069. 340    CALL ERRMSG (11)
  2070.     GOTO 89999
  2071. C
  2072. C
  2073. C
  2074. C  ***************************************
  2075. C  *******  IFIX AND INT (=IDINT)  *******
  2076. C  ***************************************
  2077. 400    CONTINUE
  2078.     GOTO (410,420,430,430,440,440,440,430,420),K2
  2079.     STOP 400
  2080. C
  2081. C
  2082. C  ASCII
  2083. 410    CALL ERRMSG (12)
  2084.     GOTO 89999
  2085. C
  2086. C
  2087. C  REAL AND DECIMAL
  2088. 420    DO 421 I=1,8
  2089. 421    EIGHT(I)=STACK1(I,ST1PT-1)
  2090.     INT=IDINT(REAL)
  2091.     DO 424 I=1,4
  2092. 424    STACK1(I,ST1PT-1)=FOUR(I)
  2093.     ST1TYP(ST1PT-1)=4
  2094.     GOTO 90000
  2095. C
  2096. C
  2097. C  INTEGER, HEXADECIMAL, AND OCTAL
  2098. 430    CALL ERRMSG (10)
  2099.     GOTO 89999
  2100. C
  2101. C
  2102. C  MULTIPLE PRECISION
  2103. 440    CALL ERRMSG (11)
  2104.     GOTO 89999
  2105. C
  2106. C
  2107. C
  2108. C  ***************************************
  2109. C  ***************  AINT  ****************
  2110. C  ***************************************
  2111. C
  2112. C  REAL TO REAL TRUNCATION
  2113. 500    CONTINUE
  2114.     GOTO (510,520,530,530,540,540,540,530,520),K2
  2115. C
  2116. C
  2117. C  ASCII
  2118. 510    CALL ERRMSG (12)
  2119.     GOTO 89999
  2120. C
  2121. C
  2122. C  REAL AND DECIMAL
  2123. 520    DO 522 I=1,8
  2124. 522    EIGHT(I)=STACK1(I,ST1PT-1)
  2125. C
  2126. C DON'T USE AINT(SNGL(REAL)) BECAUSE THEN
  2127. C 2.9999999 RESULTS IN 3.0
  2128.     REAL=DINT(REAL)
  2129.     DO 524 I=1,8
  2130. 524    STACK1(I,ST1PT-1)=EIGHT(I)
  2131.     GOTO 90000
  2132. C
  2133. C
  2134. C  INTEGER, HEXADECIMAL, AND OCTAL
  2135. 530    CALL ERRMSG (10)
  2136.     GOTO 89999
  2137. C
  2138. C
  2139. C  MULTIPLE PRECISION
  2140. 540    CALL ERRMSG(11)
  2141.     GOTO 89999
  2142. C
  2143. C
  2144. C
  2145. C
  2146. C  ****************************************
  2147. C  ****************************************
  2148. C  ********                        ********
  2149. C  ******** REAL TO REAL FUNCTIONS ********
  2150. C  ********                        ********
  2151. C  ********  EXP      (=DEXP)      ********
  2152. C  ********  ALOG     (=DLOG)      ********
  2153. C  ********  ALOG10   (=DLOG10)    ********
  2154. C  ********  SQRT     (=DSQRT)     ********
  2155. C  ********  SIN      (=DSIN)      ********
  2156. C  ********  COS      (=DCOS)      ********
  2157. C  ********  TANH     (DTANH)      ********
  2158. C  ********  ATAN     (=DATAN)     ********
  2159. C  ********                        ********
  2160. C  ****************************************
  2161. C  ****************************************
  2162. C
  2163. C
  2164. C
  2165. 10000    CONTINUE
  2166.     GOTO (11000,12000,15000,15000,15000,15000,15000,15000,12000),K2
  2167.     STOP 10000
  2168. C
  2169. C
  2170. C  ASCII
  2171. 11000    CALL ERRMSG (12)
  2172.     GOTO 89999
  2173. C
  2174. C
  2175. C  REAL AND DECIMAL
  2176. 12000    DO 12010 I=1,8
  2177. 12010    EIGHT(I)=STACK1(I,ST1PT-1)
  2178.     K=K-6
  2179.     GOTO (12100,12200,12300,12400,12500,12600,12700,12800,
  2180.      1  12840,12860,12880),K
  2181. C
  2182. C
  2183. C  EXP
  2184. 12100    REAL=DEXP(REAL)
  2185.     GOTO 14000
  2186. C
  2187. C
  2188. C  ALOG
  2189. 12200    REAL=DLOG(REAL)
  2190.     GOTO 14000
  2191. C
  2192. C
  2193. C  DLOG10
  2194. 12300    REAL=DLOG10(REAL)
  2195.     GOTO 14000
  2196. C
  2197. C
  2198. C  DSQRT
  2199. 12400    IF (REAL.GE.0.D0) GOTO 12410
  2200. 12405    CALL ERRMSG (14)
  2201.     GOTO 89999
  2202. 12410    REAL=DSQRT (REAL)
  2203.     GOTO 14000
  2204. C
  2205. C
  2206. C  DSIN
  2207. 12500    REAL=DSIN(REAL)
  2208.     GOTO 14000
  2209. C
  2210. C
  2211. C  DCOS
  2212. 12600    REAL=DCOS(REAL)
  2213.     GOTO 14000
  2214. C
  2215. C
  2216. C  DTANH
  2217. 12700    REAL=DTANH(REAL)
  2218.     GOTO 14000
  2219. C
  2220. C
  2221. C  DATAN
  2222. 12800    REAL=DATAN(REAL)
  2223.     GOTO 14000
  2224. C
  2225. C ASIN
  2226. 12840    CONTINUE
  2227.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2228.     REAL=DASIN(REAL)
  2229.     GOTO 14000
  2230. C
  2231. C ACOS
  2232. 12860    CONTINUE
  2233.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2234.     REAL=DACOS(REAL)
  2235.     GOTO 14000
  2236. C
  2237. C TAN
  2238. 12880    CONTINUE
  2239.     IF(REAL.GT.1.570795)REAL=1.570795
  2240.     IF(REAL.LT. -1.570795) REAL = -1.570795
  2241. C CLAMP TO AVOID OVERFLOW
  2242.     REAL=DTAN(REAL)
  2243. C    GOTO 14000
  2244. C (GOTO NOT NEEDED IF THIS IS THE LAST FUNCTION)
  2245. 14000    DO 14010 I=1,8
  2246. 14010    STACK1(I,ST1PT-1)=EIGHT(I)
  2247.     GOTO 90000
  2248. C
  2249. C
  2250. C  INTEGER, HEXADECIMAL, OCTAL, AND MULTIPLE PRECISION
  2251. 15000    CONTINUE
  2252.     CALL CONTYP(STACK1,ST1PT-1,K2,2,RETCD2)
  2253.     GO TO(15010,89999),RETCD2
  2254.     STOP 15000
  2255. 15010    ST1TYP(ST1PT-1)=2
  2256.     GO TO 12000
  2257. C
  2258. C
  2259. C  EXIT
  2260. 89999    RETCD=2
  2261. 90000    ST2PT=ST2PT-1
  2262.     RETURN
  2263.     END
  2264. c -h- ce2a.fms    Fri Aug 22 13:00:17 1986    
  2265.     SUBROUTINE CE2A(LNIN,LNOUT)
  2266. C CONVERT ENCODED FORMULAS TO NORMAL ASCII
  2267. C NOTE: ONLY HAS TO HANDLE STANDARD NAMES AS A$5$ TYPE FORMS AND P# AND D# FORMS
  2268. C ARE NOT TRANSLATED TO PACKED ONES.
  2269.     CHARACTER*1 NAME(4),NUMBER(6)
  2270.     CHARACTER*1 LNIN,LNOUT
  2271.     CHARACTER*6 NUMBR6
  2272.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  2273.     DIMENSION LNIN(128),LNOUT(128)
  2274. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2275. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2276.     InTeGer*4 RRWACT,RCLACT
  2277. C    COMMON/RCLACT/RRWACT,RCLACT
  2278.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2279.      1  IDOL7,IDOL8
  2280. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2281. C     1  IDOL7,IDOL8
  2282.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2283. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2284.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2285. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2286. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2287. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2288.     InTeGer*4 KLVL
  2289. C    COMMON/KLVL/KLVL
  2290.     InTeGer*4 IOLVL,IGOLD
  2291. C    COMMON/IOLVL/IOLVL
  2292. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2293. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2294.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2295.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2296.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2297. C    LOGICAL*2 L63,L192,L255,L127
  2298.     LOGICAL*4 L1,L2
  2299. C    InTeGer*4 I63,I192,I255,I127
  2300.     InTeGer*4 I63,I192,I127
  2301.     InTeGer*4 I1,I2
  2302. C    EQUIVALENCE(L127,I127)
  2303. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  2304.     EQUIVALENCE (I1,L1),(I2,L2)
  2305.     INTEGER*4 FNAM(25)
  2306.     character*4 fnmx(25)
  2307.     CHARACTER*1 FCHNM(4,25)
  2308.     equivalence(fnmx(1)(1:1),fnam(1),fchnm(1,1))
  2309. c    EQUIVALENCE(FNAM(1),FCHNM(1,1))
  2310.     DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
  2311.      1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
  2312.      2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
  2313.      3  'RND ','PMT','PVL','AVE','CHS'/
  2314. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  2315.     DATA I63/63/,I192/192/,I127/127/
  2316.     LI=1
  2317.     LO=1
  2318. C LI = INPUT LOCATION
  2319. C LO=OUTPUT LOCATION
  2320. 100    CONTINUE
  2321.     LCC=ICHAR(LNIN(LI))
  2322.     IF(LCC.NE.255)GOTO 200
  2323. C FIND BINARY PATTERNS TO USE
  2324.     I1=ICHAR(LNIN(LI+1))
  2325.     I2=IMASK(I1,I192)
  2326. C    L2=L1.AND.L192
  2327.     I1=IMASK(I1,I63)
  2328. C    L1=L1.AND.L63
  2329.     ID1=I1
  2330.     I1=ICHAR(LNIN(LI+2))
  2331.     I1=IMASK(I1,I127)
  2332. C    L1=L1.AND.L127
  2333.     ID2=I2*2+I1
  2334.     LI=MIN0(LI+3,109)
  2335. C DO MASKING TO GET BINARY COORDS
  2336.     CALL IN2AS(ID1,NAME)
  2337. C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
  2338.     IL2=ID2-1
  2339.     WRITE(NUMBR6(1:6),1000)IL2
  2340. C    ENCODE(6,1000,NUMBER)IL2
  2341. 1000    FORMAT(I6)
  2342. C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
  2343. C THROW OUT SPACES AND COPY THE REST.
  2344.     DO 202 N=1,4
  2345.     IF(ICHAR(NAME(N)).LE.32)GOTO 202
  2346.     LNOUT(LO)=NAME(N)
  2347.     LO=LO+1
  2348.     IF(LO.GT.110)GOTO 300
  2349. 202    CONTINUE
  2350.     DO 203 N=1,6
  2351.     IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
  2352. C IF 32 ISN'T SPACE, LOSE
  2353.     LNOUT(LO)=NUMBER(N)
  2354.     LO=LO+1
  2355.     IF(LO.GT.110)GOTO 300
  2356. 203    CONTINUE
  2357.     GOTO 300
  2358. C COPY MISC. CHARACTER
  2359. 200    CONTINUE
  2360.     II=ICHAR(LNIN(LI))
  2361.     IF(II.LT.230.OR.II.GT.254)GOTO 220
  2362. C FUNCTION NAME...
  2363.     II=II-229
  2364.     LNOUT(LO)=FCHNM(1,II)
  2365.     LNOUT(LO+1)=FCHNM(2,II)
  2366.     LNOUT(LO+2)=FCHNM(3,II)
  2367.     LI=LI+1
  2368.     LO=LO+3
  2369. C FILL IN ASCII FORM OF FUNCTION HERE...
  2370.     GOTO 300
  2371. 220    CONTINUE
  2372.     LNOUT(LO)=LNIN(LI)
  2373.     LO=LO+1
  2374.     LI=LI+1
  2375. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  2376. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  2377.     LO=MIN0(LO,110)
  2378.     DO 400 N=LO,110
  2379. 400    LNOUT(N)=0
  2380.     DO 1 N=111,128
  2381. 1    LNOUT(N)=LNIN(N)
  2382. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  2383.     RETURN
  2384.     END
  2385. c -h- cmdmun.for    Fri Aug 22 13:00:17 1986    
  2386.     SUBROUTINE CMDMUN(LINE)
  2387. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  2388. C ALL RIGHTS RESERVED
  2389. ccc
  2390. ccc junk VT100 escape sequence parsing except for arrow keys and
  2391. ccc PF2 since it's mostly not useful in MSDOS anyway.
  2392. ccc
  2393.     CHARACTER*1 LINE(120),LC,LINBUF(120),CW(120)
  2394. C    InTeGer*4 IOLVL,IGOLD
  2395.     EXTERNAL INDX
  2396. C    COMMON/IOLVL/IOLVL,IGOLD
  2397.     InTeGer*4 RRWACT,RCLACT
  2398. C    COMMON/RCLACT/RRWACT,RCLACT
  2399.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2400.      1  IDOL7,IDOL8
  2401. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2402. C     1  IDOL7,IDOL8
  2403.     Logical LEXIST
  2404.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2405. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2406.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2407. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2408. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2409. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2410.     InTeGer*4 KLVL
  2411. C    COMMON/KLVL/KLVL
  2412.     InTeGer*4 IOLVL,IGOLD
  2413. C    COMMON/IOLVL/IOLVL
  2414. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2415. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2416.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2417.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2418.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2419. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2420. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2421.     Integer*4 FH
  2422.     Common/CONSFH/FH
  2423.     Integer Initd,UseDK,UseDF
  2424.     Data Initd/0/
  2425. c Assume compilation with -h so this stays around
  2426.     If(Initd.ne.0)Goto 2408
  2427.     Initd=1
  2428.     UseDF=0
  2429.     UseDK=0
  2430. c Before inserting the DK: part, check that dk:AKA.CMD can be found.
  2431.     Inquire(File='DK:AKA.CMD',EXIST=LEXIST)
  2432.     If(Lexist)UseDF=1
  2433.     IF(Lexist)UseDK=1
  2434.     Inquire(File='AKA.CMD',Exist=Lexist)
  2435.     If(Lexist)UseDF=1
  2436. c Usedk = 1 if stuff is seen in dk:
  2437. c usedf = 1 if stuff found in default OR dk:
  2438. 2408    Continue
  2439.     ITERX=0
  2440. C ALLOW RESCAN OF READ-IN COMMANDS UP TO 10 TIMES.
  2441. 6501    CONTINUE
  2442.     ITERX=ITERX+1
  2443.     IF(ITERX.GT.10)RETURN
  2444.     LI=1
  2445. C ALLOW ARROWS OR OTHER SIMILAR KEYS TO BE RECOGNIZED
  2446.     LL=ICHAR(LINE(LI))
  2447. C ALLOW ! OR ESCAPE TO BE LEADIN FOR ESCAPE SEQUENCES
  2448.     IF(LL.EQ.155.OR.LL.EQ.33.OR.LL.EQ.27)GOTO 1000
  2449. C ALLOW % SPECIAL TREATMENT
  2450.     IF(ICHAR(LINE(1)).EQ.37)GOTO 7000
  2451.     IF(LINE(1).EQ.'^')IGOLD=IGOLD+1
  2452.     IF(LINE(1).EQ.'^')GOTO 7223
  2453. C IF WE SEE , COULB BE THAT ESC GOT EATEN BY VMS...
  2454.     IF(LINE(LI).EQ.'[')GOTO 1000
  2455. C CONVERT LOWER TO UPPER CASE
  2456.     NMX=120
  2457.     DO 41 N=1,120
  2458. C CHECK FOR DOUBLE QUOTE (34 DECIMAL). LEAVE L.C. IF SO
  2459.     NNN=ICHAR(LINE(N))
  2460.     IF(NNN.EQ.34)NMX=2
  2461. C IF WE SEE " CHARACTER THEN ONLY CONVERT 1ST 2 CHARACTERS TO U.C.
  2462. 41    CONTINUE
  2463.     JFED=0
  2464.     DO 1 N=1,NMX
  2465.     LL=ICHAR(LINE(N))
  2466.     IF(LL.GT.96.AND.LL.LT.123)LL=LL-32
  2467.     LINE(N)=CHAR(LL)
  2468.     IF(LINE(N).EQ.'_'.AND.LINE(N+1).EQ.'_')JFED=N
  2469. 1    CONTINUE
  2470.     IF(JFED.LE.0)GOTO 520
  2471. C IF __ SEEN (2 UNDERSCORES IN A ROW), CALL FRMEDT AFTER REMOVING THE __ FROM
  2472. C THE COMMAND LINE.
  2473.     DO 521 KKK=JFED,118
  2474.     LINE(KKK)=LINE(KKK+2)
  2475. 521    CONTINUE
  2476.     LINE(119)=Char(0)
  2477.     LINE(120)=Char(0)
  2478.     KKK=110
  2479.     CALL FRMEDT(LINE,KKK)
  2480. 520    CONTINUE
  2481.     IF(LINE(1).NE.'M')GOTO 2000
  2482. C    IF(LINE(1).NE.'M')RETURN
  2483.     LI=2
  2484.     GOTO 1000
  2485. 1000    CONTINUE
  2486. C HANDLE ESCAPE SEQUENCES
  2487. C ENCODE VT100 SEQUENCES HERE. MUST MODIFY FOR OTHERS.
  2488. C IF VMS PASSES 2 ESCS, PASS 1ST, TEST SECOND.
  2489. C NOTE CURSOR UP,DOWN, RIGHT, LEFT ARE CODED AS ESC A,B,C, OR D
  2490. C WITH POSSIBLE CRUFT BETW ESC AND THE LETTER.
  2491.     LL=ICHAR(LINE(LI+1))
  2492.     IF(LL.EQ.155.OR.LL.EQ.27)LI=LI+1
  2493.     LC=ICHAR(LINE(LI+1))
  2494.     IF(LC.EQ.'['.OR.LC.EQ.'O')LC=ICHAR(LINE(LI+2))
  2495.     IF(LC.NE.'?'.AND.LC.NE.'Q')GOTO 10
  2496. C MAKE PF2 MEAN HELP, JUST LIKE EDT
  2497. C FIX UP AMIGA HELP KEY ALSO TO MEAN HELP...
  2498.     LINE(LI)=CHAR(72)
  2499. C 72 = ASCII FOR 'H'
  2500.     LGGG=IGOLD+8
  2501.     IF(IGOLD.LE.0)GOTO 488
  2502.     LINE(LI+1)=CHAR((LGGG/10)+48)
  2503.     LINE(LI+2)=CHAR(MOD(LGGG,10)+48)
  2504. 488    CONTINUE
  2505. C    RETURN
  2506.     GOTO 2000
  2507. 10    CONTINUE
  2508. C HANDLE AUX KEYPAD KEYS AS INDIRECTS (FOR NOW)
  2509. C MAP ENTER KEY INTO AUX KEYPAD RANGE
  2510.     IF(LC.EQ.'M')LC='o'
  2511.     IF(LC.GE.'l'.AND.LC.LE.'y')GOTO 2650
  2512.     IF(LC.GE.'P'.AND.LC.LE.'S')GOTO 2100
  2513. C HANDLE INDIRECT CALLS AT 2100 FOR PF1 THRU PF4 IF AANY
  2514.     LL=ICHAR(LC)
  2515.     IF(LL.GE.48.AND.LL.LE.63)GOTO 2640
  2516.     LL=LL-65
  2517. C SUBTRACT ASCII A
  2518.     IF (LL.LT.0.OR.LL.GT.3)GOTO 2000
  2519. C ARROW KEYS HERE. ADJUST AND PASS THEM TO REST OF PROGRAM
  2520.     LK=LL
  2521.     IF(LL.EQ.3)LK=2
  2522.     IF(LL.EQ.2)LK=3
  2523.     LK=LK+49
  2524. C ADJUST FOR ASCII VALUE
  2525.     LINE(LI)=CHAR(LK)
  2526. C STASH NEW CELL IN.
  2527. C DON'T DISTURB GOLD STATUS ON MOTION OR ON HELP. ONLY ON INDIRECT
  2528. C COMMAND FILES.
  2529.     RETURN
  2530. C    GOTO 2000
  2531. 2640    CONTINUE
  2532. C AMIGA FUNCTION KEYS
  2533.     LL=LL-48+ICHAR('l')
  2534.     LC=CHAR(LL)
  2535. c Fix up as though VT100 function chars and go on
  2536. 2650    CONTINUE
  2537.     LL=ICHAR(LC)
  2538.     LL=LL-ICHAR('l')+ICHAR('A')
  2539. C MAPPING IS:
  2540. C  KEY    CHAR    AKx.CMD  x=
  2541. C  0    p    E
  2542. c  1    q    F
  2543. C  2    r    G
  2544. c  3    s    H
  2545. c  4    t       I
  2546. c  5    u    J
  2547. c  6    v    K
  2548. c  7    w    L
  2549. c  8    x    M
  2550. c  9    y    N
  2551. c  ,    l    A
  2552. c  -    m    B
  2553. c  .    n    C
  2554. c ENTER o    D
  2555.     LC=CHAR(LL)
  2556.     LINE(1)=CHAR(64)
  2557. C 64 IS ASCII @ CHARACTER
  2558.     IVL=0
  2559. C INCLUDE "DK:" IN STRING
  2560. c
  2561.     If(UseDF.eq.0) Goto 7223
  2562.     If(UseDK.eq.0) Goto 2099
  2563.     LINE(2)='D'
  2564.     LINE(3)='K'
  2565.     LINE(4)=':'
  2566.     IVL=3
  2567. 2099    Continue
  2568.     LINE(2+IVL)='A'
  2569.     LINE(3+IVL)='K'
  2570.     GOTO 2600
  2571. 2100    CONTINUE
  2572. C GENERATE INDIRECT FILE CALLS FROM PF1, PF3, PF4 KEYS IF ANY
  2573. C (THESE GIVE LETTERS P, R, OR S)
  2574.     LINE(1)=CHAR(64)
  2575.     IVL=0
  2576.     If(UseDF.eq.0) Goto 7223
  2577.     If(UseDK.eq.0) Goto 2098
  2578.     LINE(2)='D'
  2579.     LINE(3)='K'
  2580.     LINE(4)=':'
  2581.     IVL=3
  2582. 2098    Continue
  2583.     LINE(2+IVL)='K'
  2584.     LINE(3+IVL)='Y'
  2585. 2600    CONTINUE
  2586.     LINE(4+IVL)=LC
  2587.     IF(IGOLD.LE.0)GOTO 7202
  2588. C GOLD ADDS EXTRA A,B,C,D,E,... ETC. AFTER FILENAME
  2589.     LINE(5+IVL)=CHAR(64+IGOLD)
  2590.     IVL=IVL+1
  2591. C ADD EXTRA LETTER FOR GOLDED COMMANDS
  2592. 7202    CONTINUE
  2593.     LINE(5+IVL)='.'
  2594.     LINE(6+IVL)='C'
  2595.     LINE(7+IVL)='M'
  2596.     LINE(8+IVL)='D'
  2597.     LINE(9+IVL)=0
  2598. C GENERATE @KYP, @KYR, OR @KYS COMMAND ON PF1, PF3, PF4
  2599. 2000    CONTINUE
  2600.     IGOLD=0
  2601.     RETURN
  2602. 7000    CONTINUE
  2603. C PROCESS %%% FORMS
  2604.     I1=INDX(LINE(2),37)
  2605. C IF I1 IS 1, THEN WE JUST HAVE %% AND THERE'S NOTHING TO DUMP TO
  2606. C THE SCREEN. OTHERWISE DUMP IT OUT HERE..
  2607.     I1=I1+1
  2608.     IF(I1.LE.2.OR.I1.GT.80)GOTO 7002
  2609.     II1=I1-1
  2610.     IV=II1-1
  2611.     CALL SWRT(LINE(2),IV)
  2612. 7301    FORMAT(80A1,60A1)
  2613. 7002    CONTINUE
  2614.     IF(I1.GT.80)RETURN
  2615. C COPY WHATEVER NEEDS TO BE COPIED TO LINBUF
  2616.     DO 7003 II=1,80
  2617. 7003    LINBUF(II)=0
  2618.     I2=INDX(LINE(I1+1),37)
  2619.     IF(I2.GT.80)RETURN
  2620.     I2=I2+I1
  2621.     I1=I1+1
  2622.     II2=I2-1
  2623.     II=0
  2624.     IF(II2.LT.I1)GOTO 7540
  2625.     DO 7004 LL=I1,II2
  2626.     II=II+1
  2627. 7004    LINBUF(II)=LINE(LL)
  2628. 7540    CONTINUE
  2629.     IF(I2.GT.80)RETURN
  2630. C IF LINE(I2+1) HAS & THEN CLOSE FILE RIGHT HERE AND BUG OFF
  2631.     IF(LINE(I2+1).NE.'&')GOTO 8005
  2632.     CLOSE (IOLVL)
  2633.     IOLVL=11
  2634.     LINE(I2+1)='\'
  2635. 8005    CONTINUE
  2636. C SEE IF LINE(I2+1) CONTAINS A ?
  2637.     IF(LINE(I2+1).NE.'?'.AND.LINE(I2+1).NE.'\')GOTO 7005
  2638. C HAVE TO READ IN USER'S LINE HERE... READ OFF UNIT 5 ALWAYS...
  2639.     LX=II+1
  2640.     rewind 11
  2641. c    If(FH.NE.0)goto 9201
  2642. c    READ(11,7301,END=7035,ERR=7035)(LINBUF(II),II=LX,120)
  2643. c    rewind 11
  2644. c    Goto 9202
  2645. c9201    Continue
  2646. c read in main window
  2647.     Call Getttl(CW)
  2648.     If(ichar(cw(1)).eq.26.or.
  2649.      1  ichar(cw(1)).eq.28)goto 7035
  2650. c filter so funny chars are treated as eof... ctl Z or ctl \ are eof.
  2651.     KK=1
  2652. c copy to Linbuf array (as much as fits, anyway
  2653.     Do 9203 II=LX,120
  2654.     Linbuf(II)=CW(KK)
  2655.     KK=KK+1
  2656. 9203    Continue
  2657. c9202    Continue
  2658. c For AMIGA we use lun 11 for console, both input and output,
  2659. c for all commands except normal sheet operation (e.g. help etc.)
  2660. C NOW SEE IF LINBUF(LX) IS EITHER A \ CHAR OR ANY CONTROL CHARACTER
  2661.     LC=LINBUF(LX)
  2662.     IF(LINE(I2+1).EQ.'\'.OR.LINE(I2+1).EQ.'!')GOTO 7005
  2663.     IF(IOLVL.EQ.11)GOTO 7005
  2664. C IF WE SEE ANYTHING EXCEPT A CONTROL CHAR OR \, REWIND THE FILE...
  2665. C THIS ALLOWS US TO HAVE A SORT OF "ENTER MODE" AND A "COMMAND MODE"
  2666. C A LA SUPERCALC ETC.
  2667.     IF(LC.NE.'\'.AND.LC.GT.CHAR(32))REWIND IOLVL
  2668. C COMMENT OUT ANY TERMINAL COMMAND
  2669.     IF(LC.EQ.'\'.OR.LC.EQ.'!'.OR.LC.LE.CHAR(32))LINBUF(1)='*'
  2670.     GOTO 7005
  2671. 7035    CONTINUE
  2672. C RECOVER AFTER CTL-Z ON EXPECTED INPUT.
  2673. C    REWIND 5
  2674.     LINBUF(1)='*'
  2675.     CLOSE (IOLVL)
  2676.     IF(IOLVL.EQ.11)OPEN(11,FILE='CON:40/150/300/40/Analy Command')
  2677.     IOLVL=11
  2678. 7005    CONTINUE
  2679.     DO 7006 II=1,120
  2680. 7006    LINE(II)=LINBUF(II)
  2681.     GOTO 6501
  2682. C ALLOW RESCAN OF COMMAND LINE AFTER READ-IN.
  2683. C    RETURN
  2684. C RETURN AFTER BUMPING IGOLD. COMMENT OUT CMD
  2685. 7223    CONTINUE
  2686.     LINE(1)='*'
  2687.     RETURN
  2688.     END
  2689. c -h- cmnd.f40    Fri Aug 22 13:00:17 1986    
  2690.     SUBROUTINE CMND(RETCD)
  2691. C COPYRIGHT (C) 1983 GLENN EVERHART
  2692. C ALL RIGHTS RESERVED
  2693. C 60=MAX REAL ROWS
  2694. C 301=MAX REAL COLS
  2695. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  2696. C VBLS AND TYPE DIMENSIONED 60,301
  2697. C   ***************************************************
  2698. C   *                                                 *
  2699. C   *         SUBROUTINE  CMND                        *
  2700. C   *                                                 *
  2701. C   ***************************************************
  2702. C
  2703. C
  2704. C  UPON ENTRANCE, NONBLK POINT TO THE "*" IN LINE
  2705. C  INDICATING A COMMAND.  THIS ROUTINE DETERMINES WHICH COMMAND
  2706. C  IS DESIRED AND CALLS THE APPROPRIATE SUBROUTINE.
  2707. C
  2708. C  RETCD:
  2709. C  1=NORMAL
  2710. C  2=BYPASS NEXT READ BECAUSE READ COMMAND HAS BEEN EXECUTED
  2711. C     TO CHANGE LINE(80)
  2712. C  3=ERROR, SO GO TO 1000 TO SET LEVEL=1
  2713. C
  2714. C
  2715. C MODIFY CLASSES: M1
  2716. C
  2717.  
  2718. C
  2719. C   CMND CALLS
  2720. C
  2721. C  AT      TO PROCESS A FILE OF CALC COMMANDS
  2722. C  BASCNG  TO CHANGE THE DEFAULT BASE FOR CONSTANTS
  2723. C  CLOSE   CLOSE FILE OF CALC COMMANDS
  2724. C  DECLR   DECLARE VAIABLES TO BE A CERTAIN DATA TYPE
  2725. C  ERRMSG  PRINTS ERROR MESSAGES
  2726. C  EXIT    RETURN TO OPERATING SYSTEM
  2727. C  GETNNB  GETS NEXT NON-BLANK FROM LINE(80)
  2728. C  STRCMP  LOOKS FOR A SPECIFIED STRING IN LINE(80)
  2729. C  ZERO    ZEROES ALL VARIABLES
  2730. C  ZNEG    TO SEE IF A VARIABLE HAS POSITIVE VALUE
  2731. C
  2732. C
  2733. C
  2734. C  CMND IS CALLED BY CALC WHO HAS IDENTIFIED THE '*'
  2735. C  INDICATING A COMMAND IS DESIRED.
  2736. C
  2737. C
  2738. C
  2739. C
  2740. C   VARIABLE      USE
  2741. C
  2742. C
  2743. C  CCHAR      TEMPORARILY HOLDS A SINGLE CHARACTER.
  2744. C  DIGITS    HOLDS ASCII REPRESENTATION OF DIGITS.
  2745. C  I         TEMPORARY INDEX.
  2746. C  ID        ARGUMENT FOR SUBROUTINE DECLR. INDICATES
  2747. C            A PARTICULAR DATA TYPE.
  2748. C  IPT       POINTER FOR LINE(80).
  2749. C  ITCNTV    0 IF NO ITERATION. IF POSITIVE, INDEX
  2750. C            OF VARIABLE USED TO CONTROL ITERATION ON THAT LEVEL.
  2751. C  KIND(15)  HOLDS FIRST LETTER OF ALL LEGAL COMMANDS.
  2752. C  LEVEL     HOLDS LOGICAL I/O UNIT WHERE NEXT COMMAND COMES FROM.
  2753. C  LINE(80)  HOLDS COMMAND LINE.
  2754. C  NONBLK    POINTER FOR LINE(80).
  2755. C  RETCD     HOLDS RETURN CODE.
  2756. C  RETCD2    HOLDS RETURN CODE.
  2757. C  VIEWSW    VIEW SWITCH:
  2758. C            0 = OFF
  2759. C            1 = DISPLAY COMMAND LINES
  2760. C            2 = DISPLAY VALUE OF EXPRESSIONS
  2761. C            3 = DISPLAY ALL
  2762. C
  2763. C
  2764. C
  2765. C    SUBROUTINE CMND(RETCD)
  2766. C
  2767. C
  2768. C    EXTERNAL INDX
  2769.     InTeGer*4 LEVEL,NONBLK,LEND
  2770.     InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
  2771. C    InTeGer*4 IOLVL
  2772. C    COMMON/IOLVL/IOLVL
  2773.     InTeGer*4 ZNEG,ITCNTV(6)
  2774. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2775. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2776.     InTeGer*4 RRWACT,RCLACT
  2777. C    COMMON/RCLACT/RRWACT,RCLACT
  2778.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2779.      1  IDOL7,IDOL8
  2780. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2781. C     1  IDOL7,IDOL8
  2782.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2783. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2784.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2785. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2786. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2787. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2788.     InTeGer*4 KLVL
  2789. C    COMMON/KLVL/KLVL
  2790.     InTeGer*4 IOLVL,IGOLD
  2791. C    COMMON/IOLVL/IOLVL
  2792. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2793. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2794.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2795.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2796.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2797.     Character*1 WRK(130)
  2798.     CHARACTER*1 WRKX(130),WRK2X(130)
  2799.     CHARACTER*1 WRK2(128)
  2800.     CHARACTER*35 CWRK,CWRKX,CWRK2
  2801.     CHARACTER*11 CWRK2B
  2802.     Character*1 wrk2b(11)
  2803.     EQUIVALENCE(CWRK2B(1:1),WRK2(1),wrk2b(1))
  2804.     EQUIVALENCE(CWRK2(1:1),WRK2(1))
  2805.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  2806. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  2807. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  2808. c    EQUIVALENCE(WRK(1),WRKX(1))
  2809.     EQUIVALENCE(WRK2(1),WRK2X(1))
  2810.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  2811.     InTeGer*4 TYPE(1,1),VLEN(9)
  2812.     REAL*8 XAC,XVBLS(1,1)
  2813.     INTEGER*4 JVBLS(2,1,1)
  2814.     EQUIVALENCE(XAC,AVBLS(1,27))
  2815.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  2816.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  2817.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  2818.     CHARACTER*1 FVLD(1,1)
  2819.     COMMON/FVLDC/FVLD
  2820. C
  2821.     CHARACTER*1  LINE(80),KIND(23),ASCII(4),DEC(6),HEX(2),INT(6),
  2822.      ;  M10(2),M8(1),M16(2),OCTAL(4),REAL(3),CCHAR
  2823.     CHARACTER*1 DIGITS(16,3)
  2824. C
  2825.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  2826.     COMMON /ITERA/ITCNTV
  2827.     COMMON /DIGV/ DIGITS
  2828. C
  2829.     DATA KIND
  2830.      1/'@','A','B','C','D','E','H','I','M','N','O','R','S','V','Z'
  2831.      2,'P','W','G','Q','F','J','X','U'/
  2832. C NOTE PWGQFJX ADDED BY GCE FOR PORTACALC INTERFACE.
  2833. C  FREE: K,U,Y, + SPECIAL CHARACTERS (LIKE .,;'"#$%^, ETC.)
  2834.     DATA  ASCII/'S','C','I','I'/,  DEC/'E','C','I','M','A','L'/
  2835.     DATA  HEX/'E','X'/, INT/'N','T','E','G','E','R'/
  2836.     DATA  M10/'1','0'/,  M8/'8'/
  2837.     DATA  M16/'1','6'/
  2838.     DATA  OCTAL/'C','T','A','L'/
  2839.     DATA  REAL/'E','A','L'/
  2840. C    DATA WRKX/130*0/,WRK2X/130*0/
  2841. C
  2842. C
  2843. C
  2844. C PICK UP NON-BLANK CHARACTER AFTER '*'
  2845.     RETCD=1
  2846.     CALL GETNNB(IPT,RETCD2)
  2847.     GOTO(2,4),RETCD2
  2848.     STOP 2
  2849. 2    NONBLK=IPT
  2850. C NONBLK POINTS TO 1ST NONBLANK CHARACTER AFTER *
  2851. C
  2852.     DO 3 I=1,23
  2853.     IF (LINE(NONBLK).EQ.KIND(I)) GOTO 6
  2854. 3    CONTINUE
  2855. C
  2856. C
  2857. C UNIDENTIFIED COMMAND
  2858. 4    GOTO 995
  2859. C
  2860. C
  2861. C
  2862. C GO TO DIFFERENT SECTIONS ON THE BASIS OF THE FIRST CHARACTER
  2863. C OF THE COMMAND.
  2864. 6    GOTO (10,20,30,1000,40,50,60,70,80,90,100,110,50,
  2865.      1  130,140,210,220,250,290,330,360,480,780),I
  2866.     STOP 6
  2867. C
  2868. C
  2869. C
  2870. C
  2871. C **************************************************
  2872. C *****    *@  INDIRECT COMMAND PROCESSING    ******
  2873. C **************************************************
  2874. 10    CALL AT(RETCD)
  2875.     GOTO (1000,999),RETCD
  2876.     STOP 10
  2877. C
  2878. C
  2879. C
  2880. C
  2881. C **************************************************
  2882. C ******      *A     DECLARE TYPE ASCII       ******
  2883. C **************************************************
  2884. 20    CALL STRCMP (ASCII,4,RETCD2)
  2885.     ID=1
  2886.     GOTO (200,995),RETCD2
  2887.     STOP 20
  2888. C
  2889. C
  2890. C
  2891. C
  2892. C **************************************************
  2893. C ******       *B      BASE DEFAULT          *******
  2894. C **************************************************
  2895. 30    CONTINUE
  2896.     CALL BASCNG(RETCD2)
  2897.     IF(VIEWSW.NE.0)WRITE(11,34) BASED
  2898. 34    FORMAT(' DEFAULT BASE IS ',I2)
  2899.     GO TO (1000,999),RETCD2
  2900.     STOP 30
  2901. C
  2902. C
  2903. C
  2904. C
  2905. C ********************************************************
  2906. C **   *C   COMMENT, JUST RETURN (VIA STATEMENT 1000)   **
  2907. C ********************************************************
  2908. C
  2909. C
  2910. C
  2911. C **************************************************
  2912. C *******     *D     DECLARE TYPE DECIMAL    *******
  2913. C **************************************************
  2914. 40    CALL STRCMP(DEC,6,RETCD2)
  2915.     ID=2
  2916.     GOTO (200,995),RETCD2
  2917.     STOP 40
  2918. C
  2919. C
  2920. C **************************************************
  2921. C **********          *E   EXIT             ********
  2922. C **************************************************
  2923. 50    CONTINUE
  2924. C SET RETCD=4 ON EXIT IF EXIT COMMAND, SO CALC RETURNS TO ITS CALLER.
  2925.     IF (LEVEL.EQ.1) RETCD=4
  2926.     IF (LEVEL.EQ.1) RETURN
  2927. C    IF (LEVEL.EQ.1) CALL EXIT
  2928.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  2929.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  2930. C ITERATION VARIABLE IS POSITIVE SO EXECUTE FILE AGAIN
  2931.     REWIND LEVEL
  2932.     GO TO 1000
  2933. C
  2934. C NOTE THAT WHEN EXITING A LEVEL THAT WAS ITERATED, ITCNTV
  2935. C IS NOT SET TO ZERO. THIS REQUIRES THAT WHEN ENTERED AT
  2936. C SUBROUTINE 'AT' AND ITERATION IS NOT DESIRED, THAT ITCNTV
  2937. C MUST BE SET TO ZERO THERE
  2938.  
  2939. 55    CLOSE(LEVEL)
  2940.     LEVEL=LEVEL-1
  2941. 59    GOTO 1000
  2942. C
  2943. C
  2944. C
  2945. C
  2946. C
  2947. C **************************************************
  2948. C * *H DECLARE VARIABLES TO BE OF TYPE HEXADECIMAL *
  2949. C **************************************************
  2950. 60    CALL STRCMP (HEX,2,RETCD2)
  2951.     ID=3
  2952.     GOTO (200,995),RETCD2
  2953.     STOP 60
  2954. C
  2955. C
  2956. C
  2957. C
  2958. C **************************************************
  2959. C * *I DECLARE VARIABLE TO BE OF TYPE INTEGER (*4) *
  2960. C **************************************************
  2961. 70    CALL STRCMP (INT,6,RETCD2)
  2962.     ID=4
  2963.     GOTO (200,995),RETCD2
  2964.     STOP 70
  2965. C
  2966. C
  2967. C **************************************************
  2968. C *  *M  DECLARE VARIABLE TO BE MULTIPLE PRECISION *
  2969. C **************************************************
  2970. 80    CALL STRCMP (M10,2,RETCD2)
  2971.     ID=5
  2972.     GOTO (200,84),RETCD2
  2973.     STOP 80
  2974. C
  2975. C
  2976. C  SEE IF MULTIPLE PRECISION IS OCTAL
  2977. 84    CALL STRCMP (M8,1,RETCD2)
  2978.     ID=6
  2979.     GOTO (200,88),RETCD2
  2980.     STOP 84
  2981. C
  2982. C
  2983. C  SEE IF MULTIPLE PRECISION HEXADECIMAL
  2984. 88    CALL STRCMP (M16,2,RETCD2)
  2985.     ID=7
  2986.     GOTO (200,995),RETCD2
  2987.     STOP 88
  2988. C
  2989. C
  2990. C
  2991. C
  2992. C ************************************************************
  2993. C **  *N SUPPRESS PRINTING OF VARIABLES WHEN VALUES CHANGE  **
  2994. C ************************************************************
  2995. 90    VIEWSW=1
  2996.     GOTO 1000
  2997. C
  2998. C
  2999. C
  3000. C
  3001. C **************************************************
  3002. C ***  *O  DECLARE VARIABLE TO BE OF TYPE OCTAL  ***
  3003. C **************************************************
  3004. 100    CALL STRCMP (OCTAL,4,RETCD2)
  3005.     ID=8
  3006.     GOTO (200,995),RETCD2
  3007.     STOP 100
  3008. C
  3009. C
  3010. C
  3011. C
  3012. C
  3013. C **************************************************
  3014. C ***********     *R ENCOUNTERED       *************
  3015. C **************************************************
  3016. C
  3017. C  *R    SEE IF A REAL DECLARATION
  3018. 110    CALL STRCMP (REAL,3,RETCD2)
  3019.     ID=9
  3020.     GOTO (200,114),RETCD2
  3021.     STOP 110
  3022. C
  3023. C
  3024. C  OTHERWISE ASSUME A READ IS REQUIRED
  3025. 114    IF (LEVEL.NE.1) GOTO 117
  3026.     Rewind 11
  3027.     WRITE(11,116)
  3028.     Rewind 11
  3029.     GOTO 118
  3030. 116    FORMAT(' CALR>',$)
  3031. 117    Continue
  3032.     Rewind 11
  3033.     WRITE (11,119) LEVEL
  3034.     Rewind 11
  3035. 119    FORMAT (' CALC<',I1,'>',$)
  3036. 118    Continue
  3037. c    Rewind 11
  3038.     READ (11,115,END=1000,ERR=990) LINE
  3039.     Rewind 11
  3040. 115    FORMAT (80A1)
  3041. C
  3042. C  NOTE THAT IF <CR> IS HIT AS THE ONLY INPUT, RETURN IS NORMAL
  3043. C  AND PROCESSING CONTINUES ON LEVEL (RETCD=2)
  3044.     RETCD=2
  3045.     GOTO 1000
  3046. C
  3047. C
  3048. C
  3049. C
  3050. C
  3051. C ************************************************************
  3052. C ***  *V ACTIVATE PRINTING OF VARIABLE WHEN VALUES CHANGE ***
  3053. C ************************************************************
  3054. 129    NONBLK=IPT
  3055. 130    CALL GETNNB(IPT,RETCD2)
  3056.     GO TO (129,132),RETCD2
  3057.     STOP  130
  3058. 132    CCHAR=LINE(NONBLK)
  3059.     IF(CCHAR.NE.DIGITS(10,1))GO TO 134
  3060. C
  3061. C  *VIEW 0 ENCOUNTERED
  3062.     VIEWSW=0
  3063.     GO TO 1000
  3064. 134    IF(CCHAR.NE.DIGITS(1,1))GO TO 136
  3065. C
  3066. C *VIEW 1 ENCOUNTERED
  3067.     VIEWSW=1
  3068.     GO TO 1000
  3069. 136    IF(CCHAR.NE.DIGITS(2,1))GO TO 138
  3070.     VIEWSW=2
  3071.     GO TO 1000
  3072. 138    VIEWSW=3
  3073.     GOTO 1000
  3074. C
  3075. C
  3076. C
  3077. C
  3078. C **************************************************
  3079. C **********   *Z   ZERO OUT ALL VARIABLES  ********
  3080. C **************************************************
  3081. 140    CALL ZERO
  3082.     GOTO 1000
  3083. C
  3084. C
  3085. C
  3086. C
  3087. C
  3088. C MAKE DECLARATIONS
  3089. 200    CALL DECLR(ID,RETCD2)
  3090.     GO TO(1000,999),RETCD2
  3091.     STOP 200
  3092. C
  3093. C
  3094. C
  3095. C
  3096. C
  3097. C **** ERROR PROCESSING ****
  3098. C
  3099. 990    I=27
  3100.     REWIND LEVEL
  3101.     GO TO 998
  3102. 995    I=3
  3103. 998    CALL ERRMSG(I)
  3104. 999    RETCD=3
  3105. 1000    CONTINUE
  3106.     RETURN
  3107. C
  3108. C P COMMAND - SET PLACEMENT OF PHYSICAL POSN IN SHEET
  3109. C *P WILL PROMPT FOR INPUTS OF LOCATIONS.
  3110. C
  3111. 210    CONTINUE
  3112. C
  3113.     RETCD=1
  3114.     CALL CMND2(RETCD,1)
  3115.     RETURN
  3116. C W COMMAND - WRITE % TO CURRENT PHYSICAL LOC IN SHEET. USE E32.25
  3117. C FORMAT.
  3118. C  DOES NOT PROMPT. THEREFORE, IF USED INSIDE SPREADSHEET, HAS THE
  3119. C  EFFECT OF CONVERTING CURRENT CELL'S FORMULA TO A LITERAL NUMBER
  3120. C  AND FREEZING IT THAT WAY. THEREFORE A FORMULA CONTAINING *W WILL
  3121. C  NORMALLY ONLY EXECUTE THE *W ONCE (AFTERWARDS BEING OVERWRITTEN).
  3122. C
  3123. 220    CONTINUE
  3124.     RETCD=1
  3125.     CALL CMND2(RETCD,2)
  3126. C
  3127.     RETURN
  3128. C
  3129. C *G SEEN.
  3130. C THE SYNTAX OF *G IS *G V1,V2 WHICH WILL GET VALUE OF VBLS(G1,G2)
  3131. C  AND LOAD IT INTO %. THE DIMENSIONS ARE CLAMPED TO LEGAL BOUNDS
  3132. C  AND TYPE=4 MEANS USE INTEGER, TYPE=2 CONVERTS VARIABLES TO
  3133. C  INTEGER. CALLS VARSCN TO DO THIS STUFF.
  3134. C  THIS GIVES A MEASURE OF INDIRECTION.
  3135. 250    CONTINUE
  3136.     RETCD=1
  3137. C SAY ALL'S WELL.
  3138.     CALL CMND2(RETCD,3)
  3139. C
  3140.     RETURN
  3141. C
  3142. C *Q QUERY DATABASE COMMAND
  3143. C
  3144. C
  3145. 290    CONTINUE
  3146.     RETCD=1
  3147.     CALL CMND2(RETCD,4)
  3148. C
  3149.     RETURN
  3150. C
  3151. C *F LABEL  GOTO LABEL COMMAND (CONDITIONAL)
  3152. C
  3153. C
  3154. C THE SYNTAX OF THE *F COMMAND IS :
  3155. C  *F LABEL
  3156. C  WITH THE OPERATION OF LOCATING A LINE BEGINNING WITH THE
  3157. C  STRING "*CLABEL" (SO IT IS PASSED OVER BY NORMAL CALC
  3158. C  PROCESSING). THE INPUT FILE ON IOLVL IS REWOUND AND
  3159. C  SCANNING GOES TO THE EOF OR UNTIL THE STRING IS FOUND.
  3160. C  RETCD=2 IF NO SUCH LABEL IS FOUND.
  3161. C
  3162. C  AS A FURTHER AID, IF THE % VARIABLE IS 0 OR NEGATIVE, THE
  3163. C  COMMAND IS IGNORED.
  3164. 330    CONTINUE
  3165.     RETCD=1
  3166.     CALL CMND2(RETCD,5)
  3167. C
  3168.     RETURN
  3169. C
  3170. C *J LABEL - JUST LIKE *F LABEL BUT ON CALC'S COMMAND FILES.
  3171. C I.E., FINDS A LINE STARTING WITH *CLABEL
  3172. C (NOTE IT STARTS FROM START OF FILE AND DOES THIS ONLY IF % IS POSITIVE).
  3173. C ITERATION OF COMMAND FILES REMAINS UNDER NORMAL CONTROL.
  3174. 360    CONTINUE
  3175.     RETCD=1
  3176.     CALL CMND2(RETCD,6)
  3177.     RETURN
  3178. C *X COMMAND
  3179. C  XC FILESPEC CELLNAME
  3180. C    READS FILESPEC AS A SAVED SPEADSHEET (NUMERIC OR FORMULA)
  3181. C  AND LOADS ITS VALUE INTO CURRENT CELL AND % ACCUMULATOR. DOES
  3182. C  NOT LOAD FORMULA UNLESS F SEEN. THUS 2 VARIANTS:
  3183. C   *XF FILESPEC CELLNAME    LOAD FORMULA AND VALUE
  3184. C   *XV FILESPEC CELLNAME    LOAD VALUE
  3185. C NOTE ANY CHARACTER AFTER *X THAT ISN'T "F" IS EQUIVALENT TO V FOR EASY USE.
  3186. 480    CONTINUE
  3187.     RETCD=1
  3188.     CALL CMND2(RETCD,7)
  3189.     RETURN
  3190. C *U FUNCTION ARGS
  3191. C HANDLE USER FUNCTION CALL...
  3192. 780    CONTINUE
  3193.     RETCD=1
  3194. C PASS LINE AND ARGS TO SUBROUTINE TO PARSE (EXTERNALIZE THE WORK)
  3195. C COMMON /V/ HAS DATA NEEDED FOR ARGUMENTS...
  3196.     CALL USRFCT(LINE,RETCD,WRK2)
  3197. C IF RETCD CHANGES IN USRFCT THIS ALLOWS ERROR CODES BACK.
  3198.     RETURN
  3199.     END
  3200. c -h- cmnd2.f40    Fri Aug 22 13:00:17 1986    
  3201.     SUBROUTINE CMND2(RETCD,I)
  3202. C COPYRIGHT (C) 1983 GLENN EVERHART
  3203. C ALL RIGHTS RESERVED
  3204. C
  3205. C EXTRA ROUTINES MOVED HERE FROM INSIDE CMND SO THAT THEY CAN BE OVERLAIN IN
  3206. C 256K VERSION TO GAIN A GREAT DEAL OF SPACE.
  3207.     EXTERNAL INDX
  3208.     InTeGer*4 LEVEL,NONBLK,LEND
  3209.     InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
  3210. C    InTeGer*4 IOLVL
  3211. C    COMMON/IOLVL/IOLVL
  3212.     InTeGer*4 ZNEG,ITCNTV(6)
  3213. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3214. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3215.     InTeGer*4 RRWACT,RCLACT
  3216. C    COMMON/RCLACT/RRWACT,RCLACT
  3217.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  3218.      1  IDOL7,IDOL8
  3219. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  3220. C     1  IDOL7,IDOL8
  3221.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  3222. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3223.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3224. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3225. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  3226. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  3227.     InTeGer*4 KLVL
  3228. C    COMMON/KLVL/KLVL
  3229.     InTeGer*4 IOLVL,IGOLD
  3230. C    COMMON/IOLVL/IOLVL
  3231. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  3232. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  3233.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  3234.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  3235.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  3236.     CHARACTER*1 WRK2(128),LETA
  3237.     CHARACTER*35 CWRK,CWRKX,CWRK2
  3238.     CHARACTER*50 CWRK50
  3239.     EQUIVALENCE (CWRK50(1:1),CWRK(1:1))
  3240.     CHARACTER*11 CWRK2B
  3241.     Character*1 wrk2b(11)
  3242.     CHARACTER*1 WRKX(130),WRK2X(130)
  3243.     Character*1 WRK(128)
  3244.     EQUIVALENCE(CWRK2B,WRK2(1),Wrk2b(1),Cwrk2)
  3245. c    EQUIVALENCE(CWRK2,WRK2(1))
  3246.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  3247. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  3248. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  3249. c    EQUIVALENCE(WRK(1),WRKX(1))
  3250.     EQUIVALENCE(WRK2(1),WRK2X(1))
  3251.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  3252.     InTeGer*4 TYPE(1,1),VLEN(9)
  3253.     REAL*8 XAC,XVBLS(1,1)
  3254.     INTEGER*4 JVBLS(2,1,1)
  3255.     EQUIVALENCE(XAC,AVBLS(1,27))
  3256.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  3257.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  3258.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  3259.     CHARACTER*1 FVLD(1,1)
  3260.     COMMON/FVLDC/FVLD
  3261. C
  3262.     CHARACTER*1  LINE(80),CCHAR
  3263.     CHARACTER*1 DIGITS(16,3)
  3264. C
  3265.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  3266.     COMMON /ITERA/ITCNTV
  3267.     COMMON /DIGV/ DIGITS
  3268. C I ARGUMENT SELECTS COMMAND.
  3269. C 1 = *P
  3270. C 2 = *W
  3271. C 3 = *G 
  3272. C 4 = *Q
  3273. C 5 = *F
  3274. C 6 = *G
  3275. C 7 = *X
  3276.     IF(I.NE.1)GOTO 7000
  3277. C *P COMMANDS
  3278. C IF THE COMMAND IS *P VAR THEN SET TO VARIABLE LOCATION.
  3279.     KK1=3
  3280.     KK2=20
  3281.     IF(LINE(3).EQ.'@')GOTO 217
  3282. C ONLY LOOK IN COLS 3-20. COLUMNS 1,2 ARE THE *W COMMAND.
  3283.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3284.     IF(IVLD.NE.0)GOTO 216
  3285.     GOTO 218
  3286. 217    CONTINUE
  3287. C ALLOW *W@V1,V2 TO GOTO LOCATION OF V1,V2 (COL,ROW)
  3288. C  THIS ALLOWS PROGRAMMED ACCESS TO VARIABLES.
  3289.     L1=4
  3290.     L2=60
  3291.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3292.     IF(IVLD1.EQ.0)GOTO 1000
  3293.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3294.     IF(TYPE(1,1).EQ.2)GOTO 219
  3295.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3296.     LCL=JVBLS(1,1,1)
  3297.     GOTO 2200
  3298. 219    CONTINUE
  3299.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3300.     LCL=XVBLS(1,1)
  3301. 2200    CONTINUE
  3302. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3303.     L1=LSTCH+1
  3304.     L2=60
  3305. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3306.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3307.     IF(IVLD2.EQ.0)GOTO 1000
  3308. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3309.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3310.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3311.     LRW=JVBLS(1,1,1)
  3312.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3313.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3314. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3315.     LRW=LRW+1
  3316. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3317. C CLAMPING TO MAX VALUES.
  3318.     LCL=MAX0(1,LCL)
  3319.     LRW=MAX0(1,LRW)
  3320.     LCL=MIN0(LCL,60)
  3321.     LRW=MIN0(LRW,301)
  3322.     KK=LCL
  3323.     KKK=LRW
  3324.     GOTO 216
  3325. 218    CONTINUE
  3326.     rewind 11
  3327.     IF(LEVEL.EQ.1)WRITE(11,211)
  3328. 211    FORMAT(' SET PHYS LOC. COLUMN=')
  3329.     rewind 11
  3330.     LLLV=LEVEL
  3331.     IF(LEVEL.EQ.1)LLLV=11
  3332.     READ(LLLV,212,END=700,ERR=700)KK
  3333. 212    FORMAT(I7)
  3334.     rewind 11
  3335.     IF(LEVEL.EQ.1)WRITE(11,213)
  3336. 213    FORMAT(' SET PHYS LOC. ROW =')
  3337.     rewind 11
  3338.     READ(LLLV,212,END=700,ERR=700)KKK
  3339.     rewind 11
  3340.     KKK=KKK+1
  3341. 216    KK=MAX0(1,KK)
  3342.     KKK=MAX0(1,KKK)
  3343.     KK=MIN0(60,KK)
  3344.     KKK=MIN0(301,KKK)
  3345. C CLAMP TO LEGAL SIZE
  3346.     PROW=KK
  3347.     PCOL=KKK
  3348. C
  3349.     RETURN
  3350. C TERMINAL READ ERROR AND END PROCESSING
  3351. 700    CONTINUE
  3352.     IF(LEVEL.EQ.1)CLOSE(11)
  3353.     IF(LEVEL.EQ.1)OPEN(11,FILE='CON:20/100/300/40/Analy Command')
  3354.     IF(LEVEL.NE.1)REWIND LEVEL
  3355.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  3356.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  3357.     RETURN
  3358. 7000    CONTINUE
  3359.     IF(I.NE.2)GOTO 7200
  3360. C *W COMMANDS
  3361. C    IRX=(PCOL-1)*60+PROW
  3362.     CALL REFLEC(PCOL,PROW,IRX)
  3363.     CALL WRKFIL(IRX,WRK,0)
  3364. C    READ(7'IRX)WRK
  3365. C GET RECORD INTO MEMORY
  3366.     IF(LINE(3).EQ.'F')GOTO 224
  3367.     WRITE(CWRK(1:35),221)XAC
  3368. C    ENCODE(35,221,WRK)XAC
  3369. C PUT VARIABLE VALUE AS STRING INTO FILE BUFFER
  3370. 221    FORMAT(D32.25)
  3371.     GOTO 225
  3372. 224    CONTINUE
  3373. C WRITE AND USE LOCAL FORMAT
  3374.     WRK2(1)='('
  3375.     DO 226 K=1,9
  3376.     WRK2(1+K)=WRK(119+K)
  3377. 226    CONTINUE
  3378.     WRK2(11)=')'
  3379.     WRITE(CWRK(1:35),WRK2B)XAC
  3380. 225    CONTINUE
  3381.     DO 222 K=36,110
  3382. 222    WRK(K)=CHAR(32)
  3383.     CALL WRKFIL(IRX,WRK,1)
  3384. C    WRITE(7'IRX)WRK
  3385.     RETURN
  3386. 7200    CONTINUE
  3387.     IF(I.NE.3)GOTO 7400
  3388. C *G COMMANDS
  3389.     L1=3
  3390.     L2=60
  3391.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3392.     IF(IVLD1.EQ.0)GOTO 1000
  3393.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3394.     IF(TYPE(1,1).EQ.2)GOTO 251
  3395.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3396.     LCL=JVBLS(1,1,1)
  3397.     GOTO 252
  3398. 251    CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3399.     LCL=XVBLS(1,1)
  3400. 252    CONTINUE
  3401. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3402.     L1=LSTCH+1
  3403.     L2=60
  3404. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3405.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3406.     IF(IVLD2.EQ.0)GOTO 1000
  3407. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3408.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3409.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3410.     LRW=JVBLS(1,1,1)
  3411.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3412.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3413. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3414.     LRW=LRW+1
  3415. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3416. C CLAMPING TO MAX VALUES.
  3417.     LCL=MAX0(1,LCL)
  3418.     LRW=MAX0(1,LRW)
  3419.     LCL=MIN0(LCL,60)
  3420.     LRW=MIN0(LRW,301)
  3421. C RETURN VALUE.
  3422.     CALL TYPGET(LCL,LRW,TYPE(1,1))
  3423.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(LCL,LRW,XAC)
  3424.     IF(TYPE(1,1).NE.2)CALL JVBLGT(1,LCL,LRW,JVBLS(1,1,1))
  3425.     IF(TYPE(1,1).NE.2)XAC=JVBLS(1,1,1)
  3426. C USE IMPLICIT CONVERSION FROM FORTRAN HERE. NOTE WE RETURN WITH
  3427. C THE LOOKED UP VALUE IN XAC.
  3428.     RETURN
  3429. 7400    CONTINUE
  3430.     IF(I.NE.4)GOTO 7600
  3431. C *Q COMMANDS
  3432. C *Q QUERY DATABASE COMMAND
  3433. C
  3434. C
  3435. C THIS COMMAND IS DESIGNED TO PERMIT CALC TO ACCESS SEQUENTIAL (FOR NOW)
  3436. C FILES AND PULL IN VALUES. ARRAY WRK IS USED TO HOLD THE RECORDS AND
  3437. C MAY DISPLAY WHATEVER IS DESIRED.
  3438. C
  3439. C OPERATION IS AS FOLLOWS:
  3440. C
  3441. C *QW/F filespec ?KEYSTRING? <cc>
  3442. C WHERE THE W/F FLAG MEANS WRITE TO FORMULA AT CURRENT LOC (MAYBE MODIFIED
  3443. C EARLIER BY THE *P COMMAND) AND F FLAG MEANS RETURN % AS VALUE OBTAINED BY
  3444. C ATTEMPTING A DECODE ON THE FILE LINE BETWEEN DELIMITER CHARACTERS
  3445. C cc GIVEN INSIDE  CHARACTERS. FILE IS ASSUMED TO START WITH
  3446. C "KEYSTRING" WHERE ANY CHARACTER IS A MATCH EXACTLY EXCEPT THAT
  3447. C THE _ CHARACTER INDICATES A WILDCARD.
  3448. C SPECIAL CASES:
  3449. C  IF ` IS 1ST CHAR OF KEYSTRING, RECORDS MUST HAVE KEYSTRING STARTING
  3450. C AT COL 1 (EXCLUDING THE `)
  3451. C  IF <CC> STRING HAS ` AS 1ST CHARACTER, THEN IT IS OF FORM
  3452. C <`NM> WHERE N=ASCII CODE FOR COLUMN WANTED + 32 AND M = ASCII CODE
  3453. C   FOR LENGTH DESIRED + 32
  3454. C  THIS ALLOWS POSITIONAL RETRIEVAL (THOUGH PAINFULLY)
  3455. C
  3456. C A SECOND KEYSTRING MAY BE ENTERED INSIDE A SECOND PAIR OF ? CHARACTERS TOO.
  3457. C  THE SEARCH WILL SEEK THE KEYS ANYWHERE IN THE RECORDS READ, UP TO 128
  3458. C  CHARACTERS LONG EACH.
  3459. C SECOND KEYSTRING MAY NOT BE ANCHORED TO START OF LINE.
  3460. C  AS AN ADDED ATTRACTION:
  3461. C   *QFK  OR *QFN  WON'T CLOSE LUN 4 AT END. IN ADDITION *QFN WON'T
  3462. C  CLOSE IT AT START EITHER ALLOWING SEQUENTIAL RETRIEVALS OUT OF
  3463. C  DATA FILES. DITTO *QW VARIANTS.
  3464. C    IRX=(PCOL-1)*60+PROW
  3465.     CALL REFLEC(PCOL,PROW,IRX)
  3466. C    IF(LINE(3).EQ.'W')READ(7'IRX)WRK
  3467.     IF(LINE(3).EQ.'W')CALL WRKFIL(IRX,WRK,0)
  3468.     IF(LINE(3).NE.'W'.AND.LINE(3).NE.'F')RETURN
  3469.     IL=INDX(LINE,32)
  3470.     IF(IL.GT.40)GOTO 299
  3471.     IL2=INDX(LINE(IL+1),32)
  3472.     IF(IL2.GT.38)GOTO 299
  3473. C ENSURE LUN 4 AVAILABLE
  3474.     IF(LINE(4).NE.'C'.AND.LINE(4).NE.'N')CLOSE(4)
  3475.     LINE(IL2+IL)=CHAR(0)
  3476.     IF(LINE(4).NE.'N'.AND.LINE(4).NE.'C')
  3477.      1   CALL RASSIG(4,LINE(IL+1))
  3478. C THIS MAKES LUN 4 BE THE ONE WE WANT
  3479.     LINE(IL2+IL)=CHAR(32)
  3480.     KKK=ICHAR('?')
  3481.     IQ1=INDX(LINE,KKK)
  3482. C LOCATE THE KEY
  3483.     IF(IQ1.GE.70)GOTO 299
  3484.     KKK=ICHAR('?')
  3485.     IQ2=INDX(LINE(IQ1+1),KKK)
  3486.     IF(IQ2.GE.72)GOTO 299
  3487. C NOW KNOW KEY IS IQ2-1 LONG, STARTS AT IQ1+1
  3488. C
  3489. C ALLOW DOUBLE KEYS IF ANOTHER ?? PAIR IS SEEN.
  3490.     KEYS2=0
  3491.     KKK=ICHAR('?')
  3492.     IQ3=INDX(LINE(IQ1+IQ2+1),KKK)
  3493.     IF(IQ3.GT.3)GOTO 297
  3494. C WELL, THERE'S A 2ND STRING THERE MAYBE.
  3495.     IQ4=INDX(LINE(IQ3+IQ1+IQ2+1),KKK)
  3496.     IF(IQ4.GT.30)GOTO 297
  3497.     IF(IQ4.EQ.1)GOTO 297
  3498.     KEYS2=1
  3499. C FLAG WE HAVE A SECOND KEY. SOMETHING'S THERE.
  3500.     LCL=IQ3+IQ2+IQ1+1
  3501.     LRW=LCL+IQ4-1
  3502. 297    READ(4,332,END=299,ERR=299)WRK2
  3503.     IQQ=IQ2-1
  3504.     IXX=128-IQ2
  3505. C COMPARE THE ENTIRE RECORD FOR THE KEY, MATCH ANYWHERE.
  3506.     IF(LINE(IQ1+1).NE.'`')GOTO 376
  3507. C IF 1ST CHAR OF KEY IS ` THEN SEARCH BEGINS AT LINE START ONLY. KEY IS
  3508. C 1 LESS.
  3509.     IQ1=1+IQ1
  3510.     IXX=1
  3511.     IQQ=IQQ-1
  3512. C ADJUST SO SEARCH IS 1 CHAR LESS.
  3513. 376    CONTINUE
  3514.     DO 350 KKK=1,IXX
  3515.     CALL SCMP(LINE(IQ1+1),WRK2(KKK),IQQ,ICOD)
  3516.     IF(ICOD.NE.0)GOTO 351
  3517. 350    CONTINUE
  3518. C DON'T JUST FALL THRU
  3519.     GOTO 353
  3520. 351    CONTINUE
  3521.     IF(KEYS2.EQ.0)GOTO 353
  3522. C CHECK SECOND KEY STRING IN RECORD IF ANY WAS ASKED FOR.
  3523. C (THAT'S ALL YOU GET. 2 KEYS MAX.)
  3524. C LINE(LCL) TO LINE(LRW) CONTAINS KEY.
  3525.     IXY=128-IQ4+1
  3526.     ICC=IQ4-1
  3527.     DO 354 KKK=1,IXY
  3528.     CALL SCMP(LINE(LCL),WRK2(KKK),ICC,ICOD)
  3529.     IF(ICOD.NE.0)GOTO 355
  3530. 354    CONTINUE
  3531. 355    CONTINUE
  3532. 353    IF(ICOD.EQ.0)GOTO 297
  3533. C HERE FOUND THE KEYED RECORD. NOW EXAMINE COMMAND LINE FOR
  3534. C SPECIAL CHARACTERS. IF NONE, JUST COPY THE FIRST CHARACTERS
  3535. C IN THE TEXT INTO EITHER THE BUFFER OR ENCODE THEM.
  3536.     KKK=ICHAR('<')
  3537.     IQ1=INDX(LINE,KKK)
  3538.     IF(IQ1.LE.0.OR.IQ1.GT.75)GOTO 296
  3539.     KKK=ICHAR('>')
  3540.     IQ2=INDX(LINE(IQ1+1),KKK)
  3541.     IF(IQ2.LE.0.OR.IQ2.GT.8)GOTO 296
  3542.     KKQ=ICHAR(LINE(IQ1+1))
  3543.     KK=INDX(WRK2,KKQ)
  3544. C MUNGE THE SEARCH SO THAT IF THE SPECIAL CHAR IS ` THEN THE NEXT 2
  3545. C CHARACTERS HAVE START AND LENGTH ENCODED AS ASCII CODE -32 DECIMAL
  3546. C WHICH ALLOWS FIELDS TO BE PLACED ANYWHERE (THOUGH SOMEWHAT PAINFULLY)
  3547.     IF(LINE(IQ1+1).EQ.'`')KK=ICHAR(LINE(IQ1+2))-32
  3548.     IF(KK.GT.125)GOTO 299
  3549. C NOTE THAT THE KEY FORM WOULD THEN GIVE
  3550. C  <`!@> FOR START COLUMN=1 AND LENGTH =32 (ASCII 64 = @ AND ASCII 33 = !)
  3551. C THIS MEANS USER HAS TO KNOW ASCII ORDER BUT AT LEAST IT'S IN MANUAL.
  3552.     IF(LINE(IQ1+1).EQ.'`')KKK=ICHAR(LINE(IQ1+3))-32
  3553.     KKQ=ICHAR(LINE(IQ1+2))
  3554.     IF(LINE(IQ1+1).NE.'`')KKK=INDX(WRK2(KK+1),KKQ)+KK
  3555.     GOTO 295
  3556. 296    CONTINUE
  3557. C DEFAULT, NO SPECIAL CHARS.
  3558.     KK=0
  3559.     KKK=110
  3560. 295    CONTINUE
  3561.     KL=KKK-KK-1
  3562.     KK=KK+1
  3563.     IF(LINE(3).NE.'W')GOTO 294
  3564.     KL=MIN0(KL,109)
  3565.     DO 293 N=1,KL
  3566.     WRK(N)=WRK2(KK)
  3567. 293    KK=KK+1
  3568.     WRK(KL+1)=0
  3569. C WRITE OUT THE RECORD'S KEY PART INTO SHEET FILE
  3570.     CALL WRKFIL(IRX,WRK,1)
  3571. C    WRITE(7'IRX)WRK
  3572.     XAC=1.
  3573.     GOTO 298
  3574. 294    CONTINUE
  3575. C FLOAT THE VALUE, RETURN IN XAC
  3576.     DO 750 N=1,35
  3577.     WRK(N)=CHAR(32)
  3578.     IF(N.LE.KL)WRK(N)=WRK2(KK-1+N)
  3579. 750    CONTINUE
  3580.     READ(CWRK(1:35),221,ERR=299)XAC
  3581. C    DECODE(KL,221,WRK2(KK),ERR=299)XAC
  3582. 298    CONTINUE
  3583. C IF IT'S A KEEP OR NEXT TYPE OPERATION, LEAVE LUN 4 OPEN.
  3584. C FIRST ONE MUST BE A KEEP (TO OPEN FILE IN THE FIRST PLACE)
  3585. C AND SUBSEQUENT OPERATIONS MAY BE A N OPERATIONS, WHICH
  3586. C WILL JUST CONTINUE SEQUENTIAL READIN OF DATA. USER HAS TO
  3587. C KEEP TRACK. NOTE RETURN VALUE IS -999999. (6 9'S) IF WE
  3588. C FAIL AND HAVE TO CLOSE FILE.
  3589.     IF(LINE(4).EQ.'K'.OR.LINE(4).EQ.'N')RETURN
  3590.     CLOSE(4)
  3591.     RETURN
  3592. 299    CONTINUE
  3593. C RETURN -999999 IF WE FAIL IN FINDING FILE.
  3594.     XAC=-999999.
  3595.     CLOSE(4)
  3596. C    COME HERE FOR NON-RECOVERABLE ERRORS IN FORMAT TOO.
  3597. C
  3598.     RETURN
  3599. 7600    CONTINUE
  3600.     IF(I.NE.5)GOTO 7800
  3601. C *F COMMANDS
  3602.     IF(XAC.LE.0)RETURN
  3603.     REWIND IOLVL
  3604.     IF(IOLVL.EQ.11)RETURN
  3605. 333    READ(IOLVL,332,END=331,ERR=331)WRK
  3606. 332    FORMAT(128A1)
  3607.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 333
  3608.     ISSL=2
  3609.     ISSS=2
  3610.     IF(LINE(3).EQ.' ')ISSL=3
  3611.     IF(WRK(3).EQ.' ')ISSS=3
  3612.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3613.     IF(ICODE.EQ.0)GOTO 333
  3614.     RETURN
  3615. C ERROR ENTRY WHERE WE SEE WE FAILED TO FIND LABEL.
  3616. 331    CONTINUE
  3617.     IF(IOLVL.NE.11)CLOSE(IOLVL)
  3618.     IOLVL=11
  3619.     RETCD=2
  3620. C
  3621.     RETURN
  3622. 7800    CONTINUE
  3623.     IF(I.NE.6)GOTO 8000
  3624. C *G
  3625.     IF(LEVEL.EQ.1.OR.XAC.LE.0)RETURN
  3626.     REWIND LEVEL
  3627. 363    READ(LEVEL,362,END=55,ERR=55)WRK
  3628. 362    FORMAT(128A1)
  3629.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 363
  3630.     ISSL=2
  3631.     ISSS=2
  3632.     IF(LINE(3).EQ.' ')ISSL=3
  3633.     IF(WRK(3).EQ.' ')ISSS=3
  3634.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3635.     IF(ICODE.EQ.0)GOTO 363
  3636. C
  3637.     RETURN
  3638. 8000    CONTINUE
  3639.     IF(I.NE.7)GOTO 8200
  3640. C *X COMMANDS
  3641. C NOW GET THE ARGS
  3642.     JFFG=0
  3643.     IF(LINE(3).EQ.'F')JFFG=1
  3644. C NOW HAVE FORMULA FLAG.
  3645.     IQ3=4
  3646. C ALLOW 1 SPACE OPTIONALLY
  3647.     IF(LINE(IQ3).EQ.' ')IQ3=5
  3648.     IQ1=INDX(LINE(IQ3),32)
  3649.     IQ1=IQ1+IQ3-1
  3650. C NULL TERMINATE FILENAME WHILE PARSING IT (DON'T LET ASSIGN SEE VBL NAME)
  3651.     LINE(IQ1)=0
  3652.     CLOSE(4)
  3653. 9770    CALL RASSIG(4,LINE(IQ3))
  3654. C REPLACE THE SPACE FOR VARSCN'S SIGHT
  3655.     LINE(IQ1)=CHAR(32)
  3656. C IQ1 NOW HAS START INDEX FOR VARSCN DESIRED... GO GET VRBL NAME.
  3657.     KK1=IQ1
  3658.     KK2=IQ1+20
  3659.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3660.     IF(IVLD.LE.0)GOTO 481
  3661. C GOT VALID VARIABLE NAME. KK,KKK ARE ROW,COL
  3662. C NOW WE KNOW HOW TO RETRIEVE THE DATA OFF FILE IN UNIT 4
  3663. C READ INTO WRK ARRAY TILL WE GET IT.
  3664.     IQ3=KK
  3665.     IQ4=KKK-1
  3666. 483    READ(4,332,END=488,ERR=488)WRK
  3667. C IGNORE TITLE
  3668. 486    CONTINUE
  3669. C NOTE WE READ IN THE NUMBER IN NUMERIC FORMAT. EASIER THAT WAY.
  3670. c    IF(JFFG.EQ.0)READ(4,484,END=488,ERR=488)IRRW,ICCL,XYVAL
  3671. c    IF(JFFG.NE.0)READ(4,489,END=488,ERR=488)IRRW,ICCL,
  3672. c     1  (WRK(IV),IV=1,110)
  3673. c484    FORMAT(1X,I5,1X,I5,1X,E50.35)
  3674. c489    FORMAT(1X,I5,1X,I5,1X,110A1)
  3675.     READ(4,484,END=488,ERR=488)LETA,IRRW,ICCL,
  3676.      1  (WRK(IV),IV=1,110)
  3677. C ALWAYS READ TEXT AS ALPHA
  3678.     READ(CWRK50(1:50),6486,ERR=5486)XYVAL
  3679. C DECODE AND STORE IN XYVAL IF POSSIBLE
  3680. 6486    FORMAT(BN,D50.35)
  3681. 5486    CONTINUE
  3682. C HACK OUT TRAILING BLANKS
  3683.     DO 5322 IV=1,110
  3684.     IVV=111-IV
  3685.     IF(ICHAR(WRK(IVV)).GT.32)GOTO 5323
  3686.     WRK(IVV)=CHAR(0)
  3687. 5322    CONTINUE
  3688. 5323    CONTINUE
  3689. C &&&&
  3690. 484    FORMAT(1A1,I5,1X,I5,1X,110A1,50A1)
  3691.     READ(4,485,END=488,ERR=488)LFVLD,(WRK(IV),IV=120,128),KKTYP
  3692. C ALLOW FLAG OF 3 FOR NUMERIC,RECALCULATE... 2 FOR NUMERIC, NO RECALC.
  3693. C 1 CONTINUES TO MEAN ALWAYS RECALCULATE.
  3694.     IF(LFVLD.LT.-1)LFVLD=-3
  3695.     IF(LFVLD.GT.1)LFVLD=3
  3696. C
  3697. 485    FORMAT(I3,1X,9A1,1X,I5)
  3698. C READS IN AN ENTRY OF SAVED SHEET. TEST IF IN OUR RANGE.
  3699.     IF(IRRW.EQ.IQ3.AND.ICCL.EQ.IQ4)GOTO 487
  3700.     GOTO 486
  3701. 487    CONTINUE
  3702. C SUCCESS. NOW FILL IN VALUE OR FORMULA.
  3703.     IF(JFFG.EQ.0)GOTO 6487
  3704. C IF READING IN FORMULA, TRY AND GET VALUE OUT OF VALUE
  3705. C RECORD
  3706.     IF(LETA.NE.'p')GOTO 6487
  3707. C OK, THIS IS A VALUE RECORD WHICH SHOULD BE IMMEDIATELY FOLLOWED
  3708. C BY A FORMULA RECORD.
  3709. C   JUST DECODE THE VALUE AND RECORD IT.
  3710. C  ... ACTUALLY IT'S ALREADY DECODED SO JUST RECORD IT.
  3711.     CALL XVBLST(PROW,PCOL,XYVAL)
  3712.     XAC=XYVAL
  3713. C GO BACK AND GET FORMULA
  3714.     GOTO 486
  3715. 6487    CONTINUE
  3716. C    IRX=(PCOL-1)*60+PROW
  3717.     CALL REFLEC(PCOL,PROW,IRX)
  3718.     WRK(118)=CHAR(15)
  3719.     WRK(119)=CHAR(LFVLD)
  3720.     CALL FVLDST(PROW,PCOL,LFVLD)
  3721. C    FVLD(PROW,PCOL)=LFVLD
  3722. C SET UP TO SAVE FORMULA.
  3723. C SAVE EITHER FORMULA OR VALUE.
  3724.     IF(JFFG.EQ.0)GOTO 4890
  3725.     CALL CA2E(WRK,WRK2)
  3726.     CALL WRKFIL(IRX,WRK2,1)
  3727.     GOTO 488
  3728. 4890    CONTINUE
  3729. C SET UP NUMBER IF HERE.
  3730.     CALL TYPSET(PROW,PCOL,KKTYP)
  3731. C    TYPE(PROW,PCOL)=KKTYP
  3732.     CALL FVLDST(PROW,PCOL,LFVLD)
  3733. C    FVLD(PROW,PCOL)=LFVLD
  3734.     CALL XVBLST(PROW,PCOL,XYVAL)
  3735. C    XVBLS(PROW,PCOL)=XYVAL
  3736.     XAC=XYVAL
  3737. 488    CONTINUE
  3738.     CLOSE(4)
  3739.     RETURN
  3740. 481    CONTINUE
  3741.     CLOSE(4)
  3742.     RETCD=2
  3743. C
  3744.     RETURN
  3745. 8200    CONTINUE
  3746. 55    CLOSE(LEVEL)
  3747.     LEVEL=LEVEL-1
  3748. 1000    CONTINUE
  3749.     RETURN
  3750.     END
  3751. c -h- contyp.for    Fri Aug 22 13:00:17 1986    
  3752.     SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  3753. C COPYRIGHT (C) 1983 GLENN EVERHART
  3754. C ALL RIGHTS RESERVED
  3755. C 60=MAX REAL ROWS
  3756. C 301=MAX REAL COLS
  3757. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  3758. C VBLS AND TYPE DIMENSIONED 60,301
  3759. C *                                                *
  3760. C *            SUBROUTINE CONTYP                   *
  3761. C
  3762. C
  3763. C  CONVERTS CONSTANT IN STACK(I,INDXX) FROM OLDTYP TO NEWTYP
  3764. C  IF OLDTYP.EQ.NEWTYP A RETURN IS MADE IMMEDIATELY.
  3765. C  NOTE THAT TYPE(INDXX) IS NOT CHANGED BY THIS ROUTINE
  3766. C  TYPE CODES:
  3767. C
  3768. C    0    NO CHANGE
  3769. C    1    ASCII
  3770. C    2    DECIMAL
  3771. C    3    HEXADECIMAL
  3772. C    4    INTEGER
  3773. c note: multiple precision conversions diked out
  3774. C    5    M10
  3775. C    6    M8
  3776. C    7    M16
  3777. C    8    OCTAL
  3778. C    9    REAL
  3779. C
  3780. C  RETCD    MEANING
  3781. C
  3782. C    1    O.K.
  3783. C    2    ERROR
  3784. C
  3785. C
  3786. C   MODIFY CLASSES:  M3,M4,M8
  3787. C
  3788. C  CONTYP CALLS:
  3789. C
  3790. C   ERRMSG   PRINTS OUT ERROR MESSAGES
  3791. C   MULCON   CONVERTS MULTIPLE PRECISION TO MULTIPLE PRECISION
  3792. C            OF A DIFFERENT BASE
  3793. C
  3794. C
  3795. C
  3796. C  CONTYP IS CALLED BY
  3797. C
  3798. C   CALUN    CALCULATES UNARY OPERATIONS
  3799. C   CALBIN   CALCULATES BINARY OPERATIONS
  3800. C   VARIABLE     USE
  3801. C
  3802. C  BASE        HOLDS BASE OR POWERS OF THAT BASE (INTEGER*4).
  3803. C  BASVEC      HOLDS LEGAL BASES: 8,10, AND 16
  3804. C  EIGHT(8)    CHARACTER*1 ARRAY TO PICK OFF REAL*8 VALUES.
  3805. C  FOUR(4)     CHARACTER*1 ARRAY TO PICK OFF INTEGER*4 VALUES.
  3806. C  I,J,M       TEMPORARY VALUES.
  3807. C  IBASE       HOLDS BASE OF A NUMBER WHEN BASE HOLDS THE POWERS
  3808. C              OF THAT BASE.
  3809. C  IEND        HOLDS THE NUMBER OF MULTIPLE PRECISION DIGITS THAT
  3810. C              WILL BE PICKED UP WHEN CONVERTING TO INTEGER*4.
  3811. C  INDXX       POINTER TO VARIABLE BEING CONVERTED.
  3812. C  INT         HOLDS INTEGER*4 VALUES EQUIVALENCED TO VECTOR FOUR.
  3813. C  IS          TEMPORARILY HOLDS MULTIPLE PRECISION BASE 8 OR BASE
  3814. C              16 DIGITS.
  3815. C  IS2         TEMPORARILY HOLDS A DIGIT VALUE WHEN CHECKING MULTIPLE
  3816. C              PRECISION BASE 8 AND BASE 16 NUMBERS TO SEE IF THEY
  3817. C              ARE TOO LARGE TO FIT IN INTEGER*4.
  3818. C  ISGN        USED WHEN DETERMINING THE MAXIMUM NUMBER THAT CAN BE
  3819. C              HELD BY INTEGER*4. 1=POSITIVE, 2= NEGATIVE. ALSO HOLDS
  3820. C              0 OR 7 FOR BASE 8 MAXIMUM NUMBER CHECK. HOLDS 0 OR 15
  3821. C              FOR BASE 16 MAXIMUM NUMBER CHECK.
  3822.  
  3823. C  K           TEMPORARILY HOLDS INTEGER*4 VALUES.
  3824. C  NEWTYP      NEW DATA TYPE REQUESTED.
  3825. C  OLDTYP      DATA TYPE OF THE VARIABLE TO BE CONVERTED.
  3826. C  RBASE       BASE WHEN CONVERTING FROM MULTIPLE PRECISION TO REAL*8.
  3827. C  REAL        HOLDS REAL*8 VALUES. EQUIVALENCED TO ARRAY EIGHT.
  3828. C  RETCD       RETURN CODE. 1=O.K.  2=ERROR.
  3829. C  RPOWER      HOLDS POWERS OF RBASE WHEN CONVERTING FROM MULTIPLE
  3830. C              PRECISION TO REAL*8.
  3831. C  STACK(I,INDXX)  HOLDS VARIABLE TO BE CONVERTED.
  3832. C
  3833. C
  3834. C    SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  3835. C
  3836.     REAL*8 REAL,RBASE,RPOWER,DFLOAT
  3837. C
  3838.     INTEGER*4 K,INT,BASE
  3839. C
  3840.     InTeGer*4 OLDTYP,NEWTYP,RETCD,BASVEC(3),INDXX
  3841.     InTeGer*4 MAX10(10,2)
  3842.     InTeGer*4 I,M,J
  3843.     InTeGer*4 ISGN,IS,IS2
  3844. C
  3845.     CHARACTER*1 EIGHT(8),FOUR(4)
  3846.     CHARACTER*1 STACK(8,40)
  3847. C
  3848.     EQUIVALENCE (FOUR,INT),(REAL,EIGHT)
  3849. C
  3850.     DATA BASVEC/10,8,16/
  3851.     DATA MAX10/2,1,4,7,4,8,3,6,4,7,2,1,4,7,4,8,3,6,4,8/
  3852. C
  3853. C
  3854. C  SET DEFAULT RETURN CODE
  3855.     RETCD=1
  3856.     IF(OLDTYP.GT.0)GO TO 910
  3857. C
  3858. C VARIABLE UNDEFINED
  3859.     CALL ERRMSG(16)
  3860.     RETCD=2
  3861.     RETURN
  3862. C
  3863. C
  3864. C
  3865. 910    IF(NEWTYP.EQ.0) RETURN
  3866.     IF (OLDTYP.EQ.NEWTYP) RETURN
  3867.     GOTO (1000,2000,3000,3000,4000,5000,6000,3000,2000), OLDTYP
  3868.     STOP 1000
  3869. C
  3870. C
  3871. C
  3872. C **************************************************
  3873. C **************  OLDTYP = ASCII  ******************
  3874. C **************************************************
  3875. C
  3876. C  START BY CONVERTING TO INTEGER*4
  3877. 1000    CONTINUE
  3878. C
  3879. C
  3880. C  IF INTEGER, HEXADECIMAL OR OCTAL, ALMOST DONE
  3881.     DO 1002 I=2,8
  3882. 1002    STACK(I,INDXX)=0
  3883.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  3884. C
  3885. C
  3886. C
  3887.     DO 1008 I=1,4
  3888. 1008    FOUR(I)=STACK(I,INDXX)
  3889.     IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) GOTO 1200
  3890. C
  3891. C
  3892. C  MULTIPLE PRECISION
  3893. 1010    continue
  3894.     RETURN
  3895. C
  3896. C
  3897. C  DECIMAL OR REAL
  3898. 1200    REAL=DFLOAT(INT)
  3899.     DO 1210 I=1,8
  3900. 1210    STACK(I,INDXX)=EIGHT(I)
  3901.     RETURN
  3902. C
  3903. C
  3904. C
  3905. C **************************************************
  3906. C *********  OLDTYP = DECIMAL OR REAL  *************
  3907. C **************************************************
  3908. C
  3909. 2000    IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) RETURN
  3910. C
  3911. C
  3912.     DO 2002 I=1,8
  3913. 2002    EIGHT(I)=STACK(I,INDXX)
  3914. C
  3915. C
  3916. C  ZERO STACK(I,INDXX)
  3917.     DO 2004 I=1,8
  3918. 2004    STACK(I,INDXX)=CHAR(0)
  3919. C
  3920. C
  3921. C  CONVERT TO INTEGER
  3922. C  MAKE SURE CONVERSION DOESN'T BLOW UP
  3923.     IF(REAL.LT.-2147483648.D0.OR.REAL.GT.2147483647.D0)
  3924.      1 GOTO 6050
  3925. C
  3926. C
  3927. C
  3928. 2007    INT=REAL
  3929. C
  3930. C SEE IF NEWTYP IS MULTIPLE PRECISION
  3931.     IF (NEWTYP.GE.5.AND.NEWTYP.LE.7) GOTO 1010
  3932.     DO 2008 I=1,4
  3933. 2008    STACK(I,INDXX)=FOUR(I)
  3934. C
  3935. C RETURN IF TYPE IS INTEGER, HEX, OR OCTAL
  3936.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  3937. C
  3938. C ASCII SO CLEAR OUT BYES 2,3, AND 4
  3939. 2009    DO 2010 I=2,4
  3940. 2010    STACK(I,INDXX)=CHAR(0)
  3941.     RETURN
  3942. C
  3943. C
  3944. C
  3945. C
  3946. C
  3947. C
  3948. C **************************************************
  3949. C *******  OLDTYP = INTEGER, HEX, OR OCTAL  ********
  3950. C **************************************************
  3951. C
  3952. 3000    IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  3953.     DO 3002 I=1,4
  3954. 3002    FOUR(I)=STACK(I,INDXX)
  3955. C
  3956. C SEE IF NEWTYP IS ASCII
  3957.     IF (NEWTYP.EQ.1) GOTO 2009
  3958. C
  3959. C IF NOT REAL*8 THEN IT IS MULTIPLE PRECISION (PROCESS AT 1010)
  3960.     IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 1010
  3961. C
  3962. C PROCESS AS REAL*8
  3963.     GOTO 1200
  3964. C
  3965. C *************  OLDTYP = M10  *********************
  3966. C
  3967. 4000    CONTINUE
  3968.     RETURN
  3969. 4040    continue
  3970.     RETURN
  3971. C
  3972. C **************  OLDTYP = M8  *********************
  3973. C
  3974. 5000    CONTINUE
  3975. C ***************  OLDTYP = M16  *******************
  3976. C
  3977. 6000    CONTINUE
  3978.     RETURN
  3979. C
  3980. C ***** ERROR RETURN ******
  3981. 6050    RETCD=2
  3982. C ILLEGAL CONVERSION ATTEMPTED.
  3983.     CALL ERRMSG(26)
  3984.     RETURN
  3985. C
  3986.     END
  3987. c -h- imask.for    Fri Aug 22 12:54:45 1986    
  3988.     INTEGER FUNCTION IMASK(I1,I2)
  3989.     InTeGer*4 I1,I2
  3990.     InTeGer*4 IXX
  3991.     IXX=I1.AND.I2
  3992.     IMASK=IXX
  3993.     RETURN
  3994.     END
  3995.     REAL*8 FUNCTION DFLOAT(IN)
  3996.     INTEGER IN
  3997.     REAL*8 XX
  3998.     XX=IN
  3999.     DFLOAT=XX
  4000.     RETURN
  4001.     END
  4002.