home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d594 / analyrimsrc.lha / AnalyRimSrc / AnaRimSrcDoc.Zoo / analyrimp1.for < prev    next >
Text File  |  1991-10-18  |  678KB  |  24,243 lines
  1. C ********** ANALYAC.FTN ##########################################
  2. C This version of AnalytiCalc uses the include file aparms.inc to
  3. C contain parameters. These specify the "prime area" of the
  4. C spreadsheet, and also the size of in-memory buffers that
  5. C are used for in-memory storage of spreadsheet data. Larger
  6. C spreadsheets may of course be stored using the software
  7. C paging built in, but at much reduced speed.
  8. C  Glenn Everhart 9/20/1989
  9. C This version of AnalytiCalc has RIM integrated and is descended
  10. C from the original via the following ports:
  11. C pdp11/RSX -> VAX/VMS ->VAX/VMS -> MSDOS/IBMPC ->Amiga ->Unix (Sun) ->VAX/VMS
  12. C and now VAX/VMS -> Amiga.
  13. C Much of the crockishness of less than the original set of PARAMETERS
  14. C derived from the MSDOS port; MS Fortran 3.2 did not support parameters
  15. C (or,I believe, block data, though that got introduced later). The
  16. C parameters were reinserted (partially anyway) for the Amiga version.
  17. C Glenn Everhart 1991
  18. C
  19. C parameter relationships implicit below:
  20. C mval, nominal 800, multiple of 100
  21. C mfrm, nominal 2048, multiple of 128
  22. C Mvlov2=mval/2
  23. C mfrmo2=mfrm/2
  24. C MVal/16=mvlo16
  25. C mfrm/64=mfro64
  26. c -h- analy.for    Fri Aug 22 12:54:45 1986    
  27.         PROGRAM ANALY
  28. C ANALYTICALC MAIN PROGRAM
  29. C SPREAD SHEET DRIVER PROGRAM
  30.     Include aparms.inc
  31. C COPYRIGHT (C) 1983-1990 GLENN AND MARY EVERHART
  32. C ALL RIGHTS RESERVED
  33. C MAX SHEET DIMS ARE MCOLS BY mrows-1 (MROWS SINCE ACCUMULATORS ARE A PSEUDO ROW)
  34. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  35. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  36. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  37. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  38. C FROM THE DISK BASED FILE HERE.
  39. C
  40. c    InTeGer*4 PRL(6)
  41. c        CHARACTER*1 NOWRAP ( 2 )
  42.     character*1 fvld
  43. c    CHARACTER*1 FORM,FVLD,CMDLIN(132)
  44. c    INTEGER*4 VNLT
  45. c    INTEGER IFCW
  46. C    EXTERNAL LCWRQQ
  47.     DIMENSION FVLD(1,1)
  48. c    DIMENSION FORM(128),FVLD(1,1)
  49. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  50. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  51. C SO INITIALLY IGNORE.
  52. C
  53. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  54. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  55. C
  56.     character*132 inmsg
  57.     integer inmsgf
  58.     common/rinmsg/inmsgf,inmsg
  59. C ***<<<< RDD COMMON START >>>***
  60.     InTeGer*4 RRWACT,RCLACT
  61. C    COMMON/RCLACT/RRWACT,RCLACT
  62.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  63.      1  IDOL7,IDOL8
  64. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  65. C     1  IDOL7,IDOL8
  66.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  67. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  68.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  69. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  70. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  71. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  72.     InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kpag
  73. C    COMMON/KLVL/KLVL
  74.     InTeGer*4 IOLVL,igold
  75. C    COMMON/IOLVL/IOLVL
  76. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  77. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  78.     Integer*4 Idsptp,Idol9
  79.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  80.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  81.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  82.      3  k3dfg,kcdelt,krdelt,kpag
  83. C ***<<< RDD COMMON END >>>***
  84.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  85.     COMMON/D2R/NRDSP,NCDSP
  86.     InTeGer*4 TYPE(1,2),VLEN(9)
  87.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  88.     Real*8 VAVBLS(3,27)
  89.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  90.     REAL*8 XXV(1,1)
  91.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  92.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  93. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  94.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  95.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  96.     CHARACTER*12 CDVFMT
  97.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  98.     COMMON/DEFVBX/DVFMT
  99.     CHARACTER*1 NMSH(80)
  100.     CHARACTER*80 NMSH80
  101.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  102.     COMMON/NMSH/NMSH
  103.     CHARACTER*1 FORM2(4)
  104. cc    integer*4 curszx,curszy,kbdin
  105. cc    common/curspr/curszx,curszy,kbdin
  106. C ***<<< XVXTCD COMMON START >>>***
  107.     CHARACTER*1 OARRY(100)
  108.     InTeGer*4 OSWIT,OCNTR
  109. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  110. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  111.     InTeGer*4 IPS1,IPS2,MODFLG
  112. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  113.        InTeGer*4 XTCFG,IPSET,XTNCNT
  114.        CHARACTER*1 XTNCMD(80)
  115. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  116. C VARY FLAG ITERATION COUNT
  117.     INTEGER KALKIT
  118. C    COMMON/VARYIT/KALKIT
  119.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  120.     InTeGer*4 RCMODE,IRCE1,IRCE2
  121. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  122. C     1  IRCE2
  123. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  124. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  125. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  126. C RCFGX ON.
  127. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  128. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  129. C  AND VM INHIBITS. (SETS TO 1).
  130.     INTEGER*4 FH
  131. C FILE HANDLE FOR CONSOLE I/O (RAW)
  132. C    COMMON/CONSFH/FH
  133.     CHARACTER*1 ARGSTR(52,4)
  134. C    COMMON/ARGSTR/ARGSTR
  135.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  136.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  137.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  138.      3  IRCE2,FH,ARGSTR
  139. C ***<<< XVXTCD COMMON END >>>***
  140. C
  141. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  142. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  143. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  144. C DISPLAY ACTUALLY USED FOR SCREEN.
  145.     Integer*4 CWids(JIDcl)
  146. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  147. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  148. C AS 20 NOT 75.
  149. c    INTEGER*4 I4TMP
  150.     REAL*8 DVS(JIDcl,JIDrw)
  151.     COMMON /FVLDC/FVLD
  152. C FOLLOWING SUPPORT VVARY OVERLAY:
  153.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  154.     InTeGer*4 QCAC(2),QCENT(8),ACV(8)
  155.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  156. C BITMAP
  157. C    CHARACTER*1 IBITMP
  158. C    DIMENSION IBITMP(2258)
  159. C    COMMON/INITD/IBITMP
  160. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  161. C 10 CHARACTERS PER ENTRY.
  162.     COMMON/DSPCMN/DVS,CWIDS
  163. C    character*35 fwt
  164. C COMMONS FROM OTHER MISC. ROUTINES, ADDED TO ALLOW AMIGA FORTRAN TO
  165. C ALLOCATE COMMONS ON STACK...
  166.     CHARACTER*1 LBITS(8)
  167.     COMMON/BITS/LBITS
  168.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  169.     COMMON/CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  170.     CHARACTER*1 DTBL1(9,9,8)
  171.     COMMON/DECIDE/DTBL1
  172.     CHARACTER*1 DIGITS(16,3)
  173.     COMMON/DIGV/DIGITS
  174. C ***<<< KLSTO COMMON START >>>***
  175.     InTeGer*4 DLFG
  176. C    COMMON/DLFG/DLFG
  177.     InTeGer*4 KDRW,KDCL
  178. C    COMMON/DOT/KDRW,KDCL
  179.     InTeGer*4 DTRENA
  180. C    COMMON/DTRCMN/DTRENA
  181.     REAL*8 EP,PV,FV
  182.     DIMENSION EP(20)
  183.     INTEGER*4 KIRR
  184. C    COMMON/ERNPER/EP,PV,FV,KIRR
  185.     InTeGer*4 LASTOP
  186. C    COMMON/ERROR/LASTOP
  187.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  188. C    COMMON/FMTBFR/FMTDAT
  189.     CHARACTER*1 EDNAM(16)
  190. C    COMMON/EDNAM/EDNAM
  191.     InTeGer*4 MFID(2),MFMOD(2)
  192. C    COMMON/FRM/MFID,MFMOD
  193.     InTeGer*4 JMVFG,JMVOLD
  194. C    COMMON/FUBAR/JMVFG,JMVOLD
  195.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  196.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  197. C ***<<< KLSTO COMMON END >>>***
  198. C
  199. C
  200.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  201.     CHARACTER*1 FVXX(Imps3)
  202.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  203.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  204.         Common/FVLDM/FVXX
  205. c        COMMON/FVLDM/FV1,FV2,FV4
  206.     InTeGer*2 IFID(8,MFrm)
  207.     COMMON/IFIDC/IFID
  208.     InTeGer*4 ILNFG,ILNCT
  209.     CHARACTER*1 ILINE(106)
  210.     COMMON/ILN/ILNFG,ILNCT,ILINE
  211.     InTeGer*4 ITCNTV(6)
  212.     COMMON/ITERA/ITCNTV
  213.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  214.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  215.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  216.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  217.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  218. C ***<<< NULETC COMMON START >>>***
  219.     InTeGer*4 ICREF,IRREF
  220. C    COMMON/MIRROR/ICREF,IRREF
  221.     InTeGer*4 MODPUB,LIMODE
  222. C    COMMON/MODPUB/MODPUB,LIMODE
  223.     InTeGer*4 KLKC,KLKR
  224.     REAL*8 AACP,AACQ
  225. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  226.     InTeGer*4 NCEL,NXINI
  227. C    COMMON/NCEL/NCEL,NXINI
  228.     CHARACTER*1 NAMARY(20,MROWS)
  229. C    COMMON/NMNMNM/NAMARY
  230.     InTeGer*4 NULAST,LFVD
  231. C    COMMON/NULXXX/NULAST,LFVD
  232.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  233.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  234. C ***<<< NULETC COMMON END >>>***
  235.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  236.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  237.     COMMON/STACKx/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  238.      1  ST1LIM,ST2LIM
  239.     InTeGer*4 IATYP(27),LINTGR
  240.     CHARACTER*1 ITYP(Imp1s)
  241.     COMMON/TYP/IATYP,ITYP,LINTGR
  242.     InTeGer*4 MPAG(2),MPMOD(2)
  243.     InTeGer*2 LVALBF(5,Mval)
  244.     COMMON/VB/MPAG,LVALBF,MPMOD
  245.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  246.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  247.     InTeGer*4 LEVEL,NONBLK,LEND,VIEWSW,BASED
  248.     CHARACTER*1 LINE(80)
  249.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  250.     integer*4 isvl1,isvl2,isvh1,isvh2,isvfg,jsv1,jsv2
  251.     common/isv/isvl1,isvl2,isvh1,isvh2,isvfg,jsv1,jsv2
  252. C *** END COMMONS FROM OTHER PLACES.
  253.     Character*1 IYN
  254.     integer*4 ixxxx,ixxxy
  255.     FH=0
  256.     isvfg=0
  257.     NCEL=0
  258.     inmsg=" "
  259.     inmsgf=0
  260. c    IFCW=4927
  261. C DISABLE FLOATING EXCEPTIONS
  262. c    call lcwrqq(ifcw)
  263. C system-specific: disable exceptions`
  264. c    ixxxx=ieee_flags("clear","exception","all",ixxxy)
  265. c    ixxxx=ieee_handler("set","all",SIGFPE_IGNORE)
  266. C don't slow down for underflows etc...
  267. c    call nonstandard_arithmetic
  268. C INITIAL DEFAULT FORMAT FOR NUMERICS is set at runtime
  269. C INIT COMMON DATA FIRST OF ALL.
  270.     IDOL7=1
  271. C INITIALLY IN ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
  272. C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
  273.     CALL BLOCK
  274.     call block2
  275.     IKONS=0
  276.     write(*,6402)
  277. 6402    Format(' Amiga vers. compiled by Absoft Fortran 2.3')
  278.         IYN=char(27)
  279.         Write(*,6398)iyn,iyn
  280. 6398    Format(A,'[H',A,'[J')
  281.     Write(*,6403)
  282. 6403    Format(' Is workbench screen 640 by 400 or over? [Y/N]:')
  283.     IDSPTP=0
  284.     Read(*,6406)IYN
  285. 6406    Format(1A1)
  286.     If(IYN.eq.'Y'.or.IYN.eq.'y')IDSPTP=1
  287. c IDSPTP now is 0 for non interlace, 1 for interlace.
  288.     CALL INITA1(KMAP,KWID,ICODE)
  289. 3002    CONTINUE
  290.     CALL INITA2(KMAP,KWID,ICODE,IKONS)
  291.     IKONS=1
  292. 3000    CONTINUE
  293.     CALL INITB(KMAP,KWID,ICODE)
  294.     LINIZZ=0
  295. C    IF(IOLDFL.GT.1)GOTO 2000
  296. 2000    CONTINUE
  297. C DRAW OUR LABELS AND OTHERWISE INITIALIZE DISPLAY SHEET
  298.     KZPPD=0
  299.     IF(IPSET.NE.0)GOTO 1000
  300.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  301.     CALL UVT100(1,1,1)
  302.     OSWIT=20
  303.     IPRSS=PROW
  304.     IPCSS=PCOL
  305.     IDRW=DROW
  306.     IDCL=DCOL
  307.     IF(LINIZZ.LE.1)CALL RECALC
  308.     IF(PZAP.EQ.0)CALL DSPSHT(2)
  309.     DCOL=IDCL
  310.     DROW=IDRW
  311.     PROW=IPRSS
  312.     PCOL=IPCSS
  313. 3006    FORMAT(80A1)
  314. C
  315. 1000    CONTINUE
  316.     IPSET=0
  317.     LINIZZ=LINIZZ+1
  318.     OSWIT=20
  319. C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
  320.     ICODE=0
  321.     CALL XQTCMD(ICODE)
  322.     IF(ICODE.LT.30)GOTO 1843
  323. C HELP COMMAND AND SIMILAR...
  324.     IF(ICODE.NE.400)GOTO 1847
  325.     CALL DSPSHT(10)
  326.     ICODE=1
  327. C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
  328.     GOTO 1843
  329. 1847    CONTINUE
  330.     IF(ICODE.NE.420)GOTO 1849
  331. C CLOSE UNIT 1 JUST IN CASE...
  332.     CLOSE(1)
  333.     KLVL=1
  334.     IPRSSS=PROW
  335.     IPCSSS=PCOL
  336.     CALL CALC
  337.     PROW=IPRSSS
  338.     PCOL=IPCSSS
  339. C CLOSE CONSOLE LUN USED BY CALC.
  340.     CLOSE(1)
  341. C CLOSE ANY OTHER LUNS CALC MAY HAVE USED...
  342.     CLOSE(2)
  343.     CLOSE(3)
  344. C SET UP FOR REDRAW WHEN BACK...
  345.     ICODE=-1
  346.     GOTO 1843
  347. 1849    CONTINUE
  348.     IF(ICODE.NE.430)GOTO 1845
  349. C TEST FUNCTION, TESTING EXPRESSION.
  350. C INHIBIT RECALCULATION...
  351. C COMMAND IS IN "XTNCMD" STRING.
  352.     LLST=MIN0(80,XTNCNT+1)
  353.     LFST=1
  354.     CALL DOENTR(XTNCMD,LFST,LLST)
  355. C THIS SETS % VARIABLE AND WILL DO A CALC DIRECTLY. THEREFORE
  356. C WE MUST INHIBIT AUTO RECALCULATION.
  357. C NOTE WE HAVE TO CALL THIS FROM THE ROOT SINCE THE RECALC OVERLAY
  358. C TREE OVERWRITES THE XQTCMD ONE.
  359.     ICODE=1
  360.     GOTO 1843
  361. 1845    CONTINUE
  362.     IVVV=ICODE-30
  363. 9308    CALL HELP(IVVV)
  364.     IVVV=0
  365.     CALL VWRT('Type return to continue, Hn for other Help pages:',
  366.      1  49)
  367.     ILL=IOLVL
  368. C    IF(ILL.EQ.5)ILL=0
  369.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)(FORM2(K),K=1,4)
  370.     if(ill.eq.11)call vget(form2,4)
  371.     IVVVV=ichar(FORM2(2))
  372.     IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
  373.     IF(FORM2(1).EQ.'H'.OR.FORM2(1).EQ.'h')GOTO 9308
  374. C NOW CLEAR SCREEN AND TRY MORE COMMANDS AS BEFORE...
  375.     ICODE=6
  376. C
  377. 1843    CONTINUE
  378.     OSWIT=20
  379.     IPRSS=PROW
  380.     IPCSS=PCOL
  381.     IDRW=DROW
  382.     IDCL=DCOL
  383.     IF(LINIZZ.LE.1)CALL RECALC
  384.     IF(IPSET.NE.0)GOTO 4110
  385.     DCOL=IDCL
  386.     DROW=IDRW
  387.     PROW=IPRSS
  388.     PCOL=IPCSS
  389. 4110    CONTINUE
  390.     IPSET=0
  391.     IF(ICODE.EQ.-1)GOTO 2000
  392. C IN PORTACALC-VM, S COMMAND ALLOWS DEFAULT FORMAT CHANGE AND
  393. C TITLE CHANGE, BUT DOES NOT ALTER SHEET IN MEMORY... DON'T ALLOW
  394. C SCRATCH FILE SAVE STUFF...
  395. C    IF(ICODE.EQ.-2)CALL WRKFIL(1,FORM,3)
  396. C    IF (ICODE.EQ.-2)CALL CLOSE(7)
  397.     IF(ICODE.LE.-2)GOTO 3002
  398. C
  399. C RECALCULATE SHEET NOW AUTOMAGICALLY
  400. C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
  401. C THE ENTIRE SHEET.
  402. C LIMIT NUMBER OF ITERATIONS AT ANY ONE TIME TO 20 HOWEVER
  403.     KKMAX=20
  404. 3670    CONTINUE
  405.     IF(ICODE.EQ.5.OR.ICODE.EQ.1
  406.      1  .OR.ICODE.EQ.6.OR.RCFGX.EQ.1)GOTO 3671
  407.     CALL RECALC
  408.     IPSET=0
  409.     KKMAX=KKMAX-1
  410. C IMPLEMENT VARY LOOP...
  411. C ASSUME USRFCT MUSTR CONTOL KALKIT VARIABLE THEN TO GET LOOP TO
  412. C TERMINATE SOMETIME.
  413.     KKMAX=MIN0(KKMAX,KALKIT)
  414.     IF(KKMAX.GT.0)GOTO 3670
  415. 3671    CONTINUE
  416. C    IF(ICODE.NE.1.AND.RCFGX.NE.1)CALL RECALC
  417. C
  418. C DISPLAY SHEET NOW. ONLY ALTERS ENTRIES INVALIDATED BY COMMAND.
  419.     IF(ICODE.NE.2.AND.ICODE.NE.6)GOTO 21
  420. C ICODE=2 = REFRESH DISPLAY. ZERO ALL NUMBERS AND CAUSE TOTAL REDISPLAY.
  421.     DO 22 N1=1,JIDcl
  422.     DO 22 N2=1,JIDrw
  423. C SET NUMBER DISPLAYED TO WEIRD VALUE.
  424. 22    DVS(N1,N2)=DVS(N1,N2)+.000000000034
  425.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  426.     CALL UVT100(1,1,1)
  427. 21    CONTINUE
  428.     IF(ICODE.EQ.6)ICODE=2
  429.     IF(ICODE.NE.5.AND.PZAP.EQ.0)CALL DSPSHT(ICODE)
  430.     DCOL=IDCL
  431.     DROW=IDRW
  432.     PROW=IPRSS
  433.     PCOL=IPCSS
  434.     GOTO 1000
  435. 5600    CONTINUE
  436. C ERROR ON READ FROM IOLVL HANDLED HERE.
  437. c    REWIND 5
  438. c    CLOSE(11)
  439. c    OPEN(11,FILE='CON:50/150/300/40/Analy Command',STATUS='OLD',
  440. c     1  FORM='FORMATTED')
  441.     CLOSE(3)
  442.     IOLVL=11
  443.     GOTO 1000
  444.     END
  445. c -h- assign.for    Fri Aug 22 12:56:01 1986    
  446.     SUBROUTINE ASSIGN(IUNIT,NAME)
  447. C
  448. C
  449.     CHARACTER*1 NAME(50)
  450.     InTeGer*4 IUNIT
  451. C &&&& MS FTN 3.2
  452.     LOGICAL LEXIST
  453. C &&&&
  454.     CHARACTER*20 WK
  455.     CHARACTER*1 WK1(20)
  456.     EQUIVALENCE(WK(1:1),WK1(1))
  457. C JUST TRY AND NULL FILL A NAME TO USE.
  458.     DO 1 N=1,20
  459.     WK1(N)=' '
  460. 1    CONTINUE
  461.     DO 2 N=1,20
  462.     II=ICHAR(NAME(N))
  463.     IF(II.LT.32)GOTO 3
  464.     WK1(N)=CHAR(II)
  465. C1    CONTINUE
  466. 2    CONTINUE
  467. 3    CONTINUE
  468. C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
  469. C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
  470. C AVOID CRASHES IF THE FILE ISN'T THERE...
  471. C MSDOS FORTRAN 3.2 AND LATER FEATURE...
  472. C &&&&
  473. C
  474. C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
  475. C
  476.     INQUIRE(FILE=WK,EXIST=LEXIST)
  477.     IF(LEXIST)GOTO 100
  478. C FILE DOES NOT EXIST, SO CREATE IT HERE.
  479. C IF CREATE FAILS WE LOSE TOO...
  480.     CALL UVT100(1,1,1)
  481.     CALL SWRT('File not found. Using window instead.',37)
  482. c    Open(IUNIT,file='tt:',status='unknown')
  483.     open(IUNIT,'con:200/100/300/80/Nonexistent file')
  484. C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
  485. C WILL GET EOF ON START, BUT THAT'S TOO BAD...
  486.     Return
  487. 100    CONTINUE
  488. C &&&&
  489. C IF JUST CALL ASSIGN, ASSUME FOR READ.
  490.     OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
  491.      1  FORM='FORMATTED',recl=512)
  492. 77    CONTINUE
  493. C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
  494. C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
  495.     RETURN
  496.     END
  497. c -h- at.for    Fri Aug 22 12:56:23 1986    
  498.     SUBROUTINE AT (RETCD)
  499. C COPYRIGHT (C) 1983 GLENN EVERHART
  500. C ALL RIGHTS RESERVED
  501. C 60=MAX REAL ROWS
  502. C 301=MAX REAL COLS
  503. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  504. C VBLS AND TYPE DIMENSIONED 60,301
  505. C *******************************************************
  506. C *                                                     *
  507. C *           SUBROUTINE  AT                            *
  508. C *                                                     *
  509. C *******************************************************
  510. C SUBROUTINE AT IS CALLED WHEN THE  *@  CALC COMMAND IS ENCOUNTERED.
  511. C IT CHANGES  THE  VALUE  OF LEVEL  WHICH  HOLDS THE  NUMBER OF THE
  512. C LOGICAL  I/O  UNIT WHERE INPUT COMMAND LINES ARE TO BE OBTAINED.
  513. C THE FILE ASSOCIATED WITH THAT I/O UNIT IS OPENED UNDER THE PROPER
  514. C CONDITIONS.
  515. C
  516. C MODIFICATION CLASSES: M1,M2,M9
  517. C
  518. C      MODIFIED 3-OCT-77 P.B.
  519. C      MODIFIED 10-JAN-78 P.B.  TO PUT SY: BEFORE FILENAMES
  520. C         WITH NO DEVICE SPECIFIED SO THAT DEFAULT IS USER'S SY:
  521. C         AND NOT THE SYSTEM SY:
  522. C
  523. C
  524. C    AT CALLS
  525. C
  526. C  ASSIGN  (TO ASSOCIATE A FILE NAME WITH A LOGICAL I/O UNIT)
  527. C  ERRMSG  (TO PRINT ERROR MESSAGES)
  528. C  GETNNB  (TO GET NEXT NON-BLANK FROM THE INPUT LINE)
  529. C  ZNEG    (TO TEST IF A VARIABLE IS POSITIVE)
  530. C
  531. C
  532. C
  533. C   AT IS CALLED BY ROUTINE CMND WHICH IS THE MODULE THAT DETERMINES
  534. C   WHAT CALC COMMAND WAS REQUESTED.
  535. C
  536. C
  537. C
  538. C         VARIABLE          USE
  539. C
  540. C   ALPHA(27)         HOLDS LEGAL VARIABLE NAMES.
  541. C   I,J               HOLD TEMPORARY VALUES.
  542. C   IPT               POINTS TO NEXT NON-BLANK CHARACTER IN LINE(80).
  543. C   ITCNTV(6)         INDEXED BY LEVEL. HOLDS 0 IF NO ITERATION ON THAT
  544. C                     LEVEL, OTHERWISE INDEX INTO VBLS FOR THE VARIABLE
  545. C                     THAT CONTROLS ITERATION.
  546. C   LEVEL             HOLDS NUMBER OF LOGICAL I/O UNIT WHERE NEXT INPUT
  547. C                     LINE IS EXPECTED.
  548. C   LINE(80)          HOLDS COMMAND INPUT LINE.
  549. C   NBLINE(78)        HOLDS THE INPUT FILE NAME WITHOUT BLANKS.
  550. C   NONBLK            POINTS TO THE LAST NON-BLANK CHARACTER IN LINE(80).
  551. C   RETCD             RETURN CODE: 1=O.K.  2=ERROR.
  552. C   SY                "SY:" USED TO OPEN FILES WITH A DEFAULT OF
  553. C                     USER'S SY: (OTHERWISE SYSTEM SY: IS USED) P.B.
  554. C                     10-JAN-78
  555. C
  556. C
  557. C
  558. C    SUBROUTINE AT (RETCD)
  559. C
  560.     InTeGer*4 IPT,J,I
  561.     InTeGer*4 LEVEL,NONBLK,LEND
  562.     InTeGer*4 RETCD,VIEWSW,BASED
  563.     InTeGer*4 ITCNTV(6),ZNEG
  564. C
  565.     CHARACTER*1  LINE(80),NBLINE(78)
  566.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  567. C    CHARACTER*1 SY(3)
  568. C
  569. C
  570.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  571.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  572.     COMMON/ITERA/ITCNTV
  573. C
  574. C    DATA SY/'S','Y',':'/
  575. C
  576. C
  577. C
  578. C UPON ENTRANCE, NONBLK POINTS TO THE CHARACTER @
  579. C
  580. C  MODIFICATION CLASSES:  M1,M2,M9
  581. C
  582. C PICK UP FIRST NON-BLANK AFTER THE @
  583.     CALL GETNNB(IPT,RETCD)
  584.     GO TO (10,1050),RETCD
  585.     STOP 10
  586. C
  587. C
  588. C START BUILDING FILE NAME AS A COMPRESSED VERSION (BLANKS REMOVED)
  589. C OF THE REST OF LINE(80)
  590. 10    J=0
  591. 15    NONBLK=IPT
  592.     J=J+1
  593.     NBLINE(J)=LINE(NONBLK)
  594.     CALL GETNNB(IPT,RETCD)
  595.     GO TO (15,50),RETCD
  596.     STOP 50
  597. C
  598. C
  599. C SET RETURN CODE AND INDICATE THAT WE WILL BE AT A NEW LEVEL.
  600. C J HOLDS THE COUNT OF THE NUMBER OF CHARACTERS IN NBLINE.
  601. C IF J=1 THEN NO ITERATION IS POSSIBLE BECAUSE FILENAME IS THE
  602. C SINGLE CHARACTER.
  603. 50    RETCD=1
  604.     LEVEL=LEVEL+1
  605.     IF (LEVEL.GT.6) GOTO 1000
  606. C
  607.     IF(J.EQ.1) GO TO 200
  608. C
  609. C NBLINE HOLDS THE COMPRESSED FILENAME. NOW WE CHECK TO SEE IF AN
  610. C ITERATION VARIABLE WAS SPECIFIED. THIS IS INDICATED BY A LEGAL
  611. C VARIABLE NAME PRECEEDED BY A BLANK (IN LINE(80))
  612. C NOTE THAT ONLY ONE OF THE ACCUMULATORS A-Z MAY BE USED FOR THIS.
  613.     DO 60 I=1,27
  614. C A-Z OR % LEGAL
  615.     IF(ALPHA(I).EQ.LINE(NONBLK))GO TO 100
  616. 60    CONTINUE
  617.     GO TO 200
  618. 100    IF(LINE(NONBLK-1).NE.BLANK)GO TO 200
  619. C
  620. C
  621. C ITERATION INDICATOR IS PRESENT
  622. C (ALPHABETIC CHARACTER OR % PRECEEDED BY A BLANK)
  623. C IF THE VALUE OF THE VARIABLE IS NOT POSITIVE, THE FILE IS IGNORED.
  624.     IF(ZNEG(I).EQ.1)GO TO 150
  625. C
  626. C
  627. C RETAIN INDEX INTO VBLS AND DECREASE J SO THAT THE FILENAME
  628. C DOES NOT INCLUDE THE ITERATION SPECIFICATION.
  629.     ITCNTV(LEVEL)=I
  630.     J=J-1
  631.     GO TO 300
  632. C
  633. C
  634. C FILE NOT ENTERED, ITERATION VARIABLE IS ZERO, NEGATIVE, OR UNDEFINED
  635. 150    LEVEL=LEVEL-1
  636.     GO TO 350
  637. C
  638. C
  639. C IF NO ITERATION, SET ITCNTV TO ZERO BECAUSE NOT ZEROED BY EXIT
  640. C ROUTINES
  641. 200    ITCNTV(LEVEL)=0
  642. 300    CONTINUE
  643.     NBLINE(J+1)=char(0)
  644. C    OPEN(UNIT=LEVEL,NAME=NBLINE)
  645. C    CALL RASSIG (LEVEL,NBLINE,J)
  646.     CALL RASSIG (LEVEL,NBLINE,I)
  647.     if(i.ne.0)goto 1000
  648. 350    RETURN
  649. C
  650. C *** ERROR PROCESSING ***
  651. C
  652. C  TOO MANY LEVELS
  653. 1000    I=2
  654. 1010    CALL ERRMSG(I)
  655. 1020    RETCD=2
  656.     RETURN
  657. C
  658. C
  659. C UNIDENTIFIED COMMAND (ARGUMENT)
  660. 1050    I=3
  661.     GO TO 1010
  662.     END
  663. c -h- bascng.for    Fri Aug 22 12:57:23 1986    
  664.     SUBROUTINE BASCNG(RETCD)
  665. C COPYRIGHT (C) 1983 GLENN EVERHART
  666. C ALL RIGHTS RESERVED
  667. C 60=MAX REAL ROWS
  668. C 301=MAX REAL COLS
  669. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  670. C VBLS AND TYPE DIMENSIONED 60,301
  671. C
  672. C SUBROUTINE BASCNG IS CALLED WHEN THE *B CALC COMMAND IS
  673. C ENCOUNTERED. THIS COMMAND INDICATES THAT THE DEFAULT BASE
  674. C FOR CONSTANTS IS TO BE CHANGED. THE ROUTINE READS IN ONE
  675. C OR TWO DIGITS AND CHANGES THE DEFAULT BASE SPECIFICATION
  676. C AS IS APPROPRIATE.
  677. C
  678. C MODIFICATION CLASS M2
  679. C
  680. C   BASCNG CALLS
  681. C
  682. C  ERRMSG  (PRINTS ERROR MESSAGES)
  683. C  GETNNB  (GETS THE NEXT NON-BLANK IN INPUT LINE LINE(80))
  684. C
  685. C
  686. C  BASCNG IS CALLED BY ROUTINE CMND WHICH IDENTIFIES THE COMMAND THAT
  687. C  THE USER WANTS TO EXECUTE.
  688. C
  689. C
  690. C    VARIABLE       USE
  691. C
  692. C    BASED       HOLDS THE DEFAULT BASE.
  693. C    IPT         POINTS TO THE NEXT NON-BLANK IN LINE(80).
  694. C    I1          BINARY VALUE OF FIRST DIGIT, VALUE OF NEW BASE.
  695. C    I2          BINARY VALUE OF SECOND DIGIT.
  696. C    NONBLK      POINTS TO THE LAST NON-BLANK IN LINE(80)
  697. C    RETCD       RETURN CODE: 1=O.K.  2=ERROR.
  698. C    RETCD2      HOLDS RETURN CODE FROM CALL TO GETNNB
  699. C
  700. C
  701. C
  702. C
  703. C    SUBROUTINE BASCNG(RETCD)
  704. C
  705. C
  706. C UPON ENTRANCE, NONBLK POINTS TO THE 'B' IN '*B' IN LINE
  707. C
  708.     InTeGer*4 IPT,I1,I2
  709.     InTeGer*4 LEVEL,NONBLK,LEND
  710.     InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
  711. C
  712.     CHARACTER*1 DIGITS(16,3),LINE(80)
  713. C
  714.     COMMON /DIGV/ DIGITS
  715.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  716. C
  717. C
  718. C IF NO ARGUMENT, RETURN WITH NORMAL RETURN CODE. THIS ALLOWS THE
  719. C USER TO SEE WHAT THE PRESENT DEFAULT BASE IS.
  720.     RETCD=1
  721.     CALL GETNNB(IPT,RETCD2)
  722.     IF(RETCD2.GT.1)GO TO 1000
  723. C
  724. C
  725. C CHECK OUT FIRST DIGIT
  726.     DO 300 I1=1,10
  727.     IF(DIGITS(I1,1).EQ.LINE(IPT)) GO TO 400
  728. 300    CONTINUE
  729.     GO TO 999
  730. C
  731. C
  732. C SEE IF THERE IS A SECOND DIGIT
  733. 400    NONBLK=IPT
  734.     IF(I1.EQ.10)I1=0
  735.     CALL GETNNB(IPT,RETCD2)
  736.     IF(RETCD2.EQ.1)GO TO 500
  737. C
  738. C
  739. C IF NOT, CONVERT TO A TWO DIGIT NUMBER WITH A LEADING ZERO.
  740.     I2=I1
  741.     I1=0
  742.     GO TO 700
  743. C
  744. C A SECOND CHARACTER WAS FOUND; FIGURE OUT WHAT THE BINARY
  745. C VALUE IS (IF IT IS A DIGIT AT ALL).
  746. 500    DO 600 I2=1,10
  747.     IF(DIGITS(I2,1).EQ.LINE(IPT))GO TO 700
  748. 600    CONTINUE
  749.     GO TO 999
  750. C
  751. C CONVERT DIGITS TO A NUMBER IF IT IS LEGAL
  752. 700    IF(I2.EQ.10)I2=0
  753.     I1=I1*10+I2
  754.     IF(I1.NE.8.AND.I1.NE.10.AND.I1.NE.16) GO TO 999
  755.     BASED=I1
  756.     GO TO 1000
  757. C
  758. C
  759. C ILLEGAL BASE SPECIFICATION
  760. 999    RETCD=2
  761.     call vwrt(' Illegal Base. (Only 8,10, and 16 OK). Ignored.',
  762.      1  48)
  763. c    WRITE(11,998)
  764. c998    FORMAT(' Illegal Base. (Only 8,10,and 16 OK). Ignored.')
  765. C    CALL ERRMSG(19)
  766. C
  767. C RETURN
  768. 1000    RETURN
  769.     END
  770. c -h- blkdat.for    Fri Aug 22 12:57:49 1986    
  771.     subroutine BLOCK2
  772. C COPYRIGHT 1983 GLENN C.EVERHART
  773. C ALL RIGHTS RESERVED
  774.     Include aparms.inc
  775. C    InTeGer*4 MFID(2),MFMOD(2)
  776.     InTeGer*2 IFID(8,MFrm)
  777.     COMMON/IFIDC/IFID
  778.     CHARACTER*1 LFID(16,MFrm)
  779.     EQUIVALENCE(IFID(1,1),LFID(1,1))
  780. C    COMMON/FRM/MFID,MFMOD
  781.     CHARACTER*1 DTBL1(9,9,8)
  782. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  783.     InTeGer*2 BTBL(6,6,8)
  784. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  785. C NO NEED TO WASTE IT.
  786. c    INTEGER DTBLIN
  787. C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
  788. c    EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
  789.     InTeGer*2 BTBL1(6,6)
  790.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  791.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  792.     EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  793.     EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  794.     EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  795.     EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  796.     COMMON /DECIDE/ DTBL1
  797. cc    DATA DTBLIN/0/
  798.     DATA BTBL1 /4,2,3,4,8,9,
  799.      1  6*0,0,2,0,0,0,9,0,2,0,0,0,9,
  800.      2  0,2,3,0,0,9,0,2,4*0/
  801.     DATA BTBL2/
  802.      3  4,5*0,2,0,3*2,0,3,3*0,2*0,4,3*0,2*0,
  803.      4  8,5*0,9,0,3*9,0/
  804.     DATA BTBL3/4,2,3,4,8,9,
  805.      5  6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  806.      6  8,2,3,4,8,9,9,2,4*9/
  807.     DATA BTBL4/
  808.      7  4,2,3,4,8,9,6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  809.      8  8,2,3,4,8,9,
  810.      9  9,2,4*9/
  811.     DATA BTBL5/4,2,3,3*4,6*0,6*0,6*0,
  812.      1  6*0,6*0/
  813.     DATA BTBL6/4,3*0,4,0,4,3*0,0,0,4,3*0,2*0,4,3*0,2*0,
  814.      2  4,3*0,2*0,
  815.      3  4,3*0,2*0/
  816.         DATA BTBL7/4,2,3,3*4,6*2,6*3,6*4,
  817.      4  6*8,6*9/
  818.     DATA BTBL8/4,1,4,4,4,3,2,1,2,2,2,1,4,3,4,4,
  819.      5  4,3,4,3,4,4,4,3,4,3,4,4,
  820.      6  4,3,2,1,2,2,2,1/
  821. C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
  822. C TYPES (WHICH ARE NOT SUPPORTED HERE)
  823.     do 135 n3=1,8
  824.     do 135 n2=1,9
  825.     do 135 n1=1,9
  826. 135    dtbl1(n1,n2,n3)=CHAR(0)
  827.     DO 35 NN2=1,6
  828.     N2=NN2
  829.     IF(NN2.GT.4)N2=NN2+3
  830.     DO 235 N1=1,4
  831.     DTBL1(N1,N2,1)=CHAR(BTBL1(N1,NN2))
  832.     DTBL1(N1,N2,2)=CHAR(BTBL2(N1,NN2))
  833.     DTBL1(N1,N2,3)=CHAR(BTBL3(N1,NN2))
  834.     DTBL1(N1,N2,4)=CHAR(BTBL4(N1,NN2))
  835.     DTBL1(N1,N2,5)=CHAR(BTBL5(N1,NN2))
  836.     DTBL1(N1,N2,6)=CHAR(BTBL6(N1,NN2))
  837.     DTBL1(N1,N2,7)=CHAR(BTBL7(N1,NN2))
  838. 235    DTBL1(N1,N2,8)=CHAR(BTBL8(N1,NN2))
  839.     do 335 n1=5,6
  840.     DTBL1(N1+3,N2,1)=CHAR(BTBL1(N1,NN2))
  841.     DTBL1(N1+3,N2,2)=CHAR(BTBL2(N1,NN2))
  842.     DTBL1(N1+3,N2,3)=CHAR(BTBL3(N1,NN2))
  843.     DTBL1(N1+3,N2,4)=CHAR(BTBL4(N1,NN2))
  844.     DTBL1(N1+3,N2,5)=CHAR(BTBL5(N1,NN2))
  845.     DTBL1(N1+3,N2,6)=CHAR(BTBL6(N1,NN2))
  846.     DTBL1(N1+3,N2,7)=CHAR(BTBL7(N1,NN2))
  847.     DTBL1(N1+3,N2,8)=CHAR(BTBL8(N1,NN2))
  848. 335    continue
  849. 35    CONTINUE
  850. C NOW CLEAR THE BUFFER OUT, HAVING SET UP DTBL1 FROM IT.
  851. C SET INITIAL -1 SO WE CAN RECOGNIZE WHEN TO STOP LOOKING
  852. C INITIALLY...
  853.     DO 36 NN=1,MFrm
  854.     DO 36 N=1,8
  855.     KKKKK=-1
  856. 36    IFID(N,NN)=KKKKK
  857.     return
  858.     END
  859. c -h- ca2e.for    Fri Aug 22 13:00:17 1986    
  860.     SUBROUTINE CA2E(LNIN,LNOUT)
  861. C CONVERT NORMAL ASCII FORM TO ENCODED
  862.     INCLUDE aparms.inc
  863.     character*1 number(6)
  864. c    CHARACTER*1 NAME(4),NUMBER(6)
  865.     CHARACTER*1 LNIN,LNOUT
  866.     CHARACTER*6 NUMBR6
  867.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  868.     DIMENSION LNIN(128),LNOUT(128)
  869.     InTeGer*4 RRWACT,RCLACT
  870. C    COMMON/RCLACT/RRWACT,RCLACT
  871.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  872.      1  IDOL7,IDOL8
  873. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  874. C     1  IDOL7,IDOL8
  875.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  876. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  877.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  878. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  879. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  880. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  881.     InTeGer*4 KLVL
  882. C    COMMON/KLVL/KLVL
  883.     InTeGer*4 IOLVL,IGOLD
  884. C    COMMON/IOLVL/IOLVL
  885. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  886. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  887.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  888.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  889.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  890.      3  k3dfg,kcdelt,krdelt,kpag
  891. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  892. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  893. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  894. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  895. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  896. C    LOGICAL*2 L63,L192,L255,L128
  897.     LOGICAL*4 L1,L2
  898. C    InTeGer*4 I63,I192,I255,I128
  899.     InTeGer*4 I63,I192,I127
  900.     InTeGer*4 I1,I2
  901. C    EQUIVALENCE(L128,I128)
  902. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  903.     EQUIVALENCE (I1,L1),(I2,L2)
  904. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  905.     save i63,i192,i127
  906.     DATA I63/63/,I192/192/,I127/127/
  907.     LI=1
  908.     LO=1
  909. C LI = INPUT LOCATION
  910. C LO=OUTPUT LOCATION
  911. 100    CONTINUE
  912.     LCC=ICHAR(LNIN(LI))
  913.     IF(LCC.EQ.255)GOTO 500
  914. C IF BINARY FORM, COPY 3 BYTES TO AVOID ERRORS.
  915. cD    If(K3dfg.gt.0)goto 200
  916.     IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
  917. C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
  918.     IL1=LI
  919.     LE=110
  920.     LSTC=LE
  921.     CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
  922. C AVOID MESSING UP FUNCTION NAMES
  923.     IF(ID2.EQ.1)IVLD=0
  924.     IF(IDOL1.NE.0.OR.IDOL2.NE.0)IVLD=0
  925. C ONLY REPACK NORMAL FORM NAMES
  926. C NOTE THAT SINCE THESE HAVE $ AFTER THE FIELDS, NO PARTIAL NAME
  927. C WILL EVER GET RECOGNIZED WITHOUT IDOL1 OR IDOL2 GETTING SET.
  928.     IF(IVLD.EQ.0)GOTO 200
  929. C ALIASED NAMES MIGHT GET SCANNED WITHIN PRIME AREA IF THE FIRST
  930. C ONE OR TWO CHARS GET STRIPPED OFF, SO TREAT LIKE P## OR D## FORMS
  931. C AND COPY THE WHOLE NAME HERE.
  932. C NOTE: WE LEAVE THE LIMITS HERE AT 60 AND 301 EVEN IF THE
  933. C SHEET DIMENSIONS CHANGE. THE ENCODING SCHEME BREAKS
  934. C DOWN OVER 63 BY 255 ANYWAY, SO JUST LEAVE LARGER NAMES
  935. C ALONE.
  936.     If(Kpag.gt.0)goto 250
  937.     If(K3DFG.GT.0)GOTO 250
  938. C Don't encode variables if using 3D addressing since this
  939. C could force the 3D addressing information to be lost.
  940.     IF(ID1.GT.60.OR.ID2.GT.301)GOTO 250
  941. C ALSO DON'T PACK ALIASED NAMES; THEY WON'T FIT IN CODED VALUES.
  942. C FOUND VARIABLE.
  943. C FIRST DON'T PACK P## AND D## FORMS.
  944.     IF(LNIN(LI+1).EQ.'#')GOTO 250
  945. C REPACK NORMAL VARIABLE HERE.
  946.     LI=LSTC
  947.     LNOUT(LO)=CHAR(255)
  948.     I1=IMASK(ID1,I63)
  949. C    I1=ID1
  950. C    L1=L1.AND.L63
  951.     I2=ID2/2
  952.     I2=IMASK(I2,I192)
  953. C    L2=L2.AND.L192
  954. C    L1=L1.OR.L2
  955.     I1=I1+I2
  956.     LNOUT(LO+1)=CHAR(I1)
  957. C    I2=ID2
  958.     I2=IMASK(ID2,I127)+128
  959. C    L2=L2.AND.L255
  960. C    L2=L2.OR.L128
  961.     LNOUT(LO+2)=CHAR(I2)
  962.     LO=MIN0(109,LO+3)    
  963.     GOTO 300
  964. 250    CONTINUE
  965. C JUST COPY DISPLAY FORMS.
  966.     IL1=LSTC-1
  967.     DO 251 N=LI,IL1
  968.     LNOUT(LO)=LNIN(N)
  969.     LO=LO+1
  970.     IF(LO.GT.110)GOTO 300
  971. 251    CONTINUE
  972.     LI=LSTC
  973. C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
  974.     GOTO 300
  975. 200    CONTINUE
  976. C HERE CHECK FOR FORMULA...
  977. C NOTE THAT SOME NAMES (E.G. "AVG" COULD CONFLICT WITH VERY LARGE COLUMN
  978. C NAMES. HOWEVER, IGNORE THAT POSSIBILITY. THAT'S AWFULLY FAR OUT.
  979.     CALL FNAME(LNIN(LI),II,INDX)
  980.     IF(INDX.LE.0.OR.INDX.GT.25)GOTO 220
  981. C Ensure that functions with indices too large to encode are
  982. C just treated literally. 229+25=254, the largest index we can have
  983. C before colliding with the 255 used to encode variable names.
  984. C thus all function names past the 25th must just be literally
  985. C entered. This is not really a problem as logic to find them
  986. C will work in either encoded or unencoded cases.
  987. C BE SURE A [ CHAR FOLLOWS NAME FOR THIS TO BE ACCEPTED...
  988.     IF(LNIN(LI+3).NE.'[')GOTO 220
  989. C FOUND MULTI-INPUT FUNCT NAME
  990.     LNOUT(LO)=CHAR(229+INDX)
  991. C SIMPLE 1-BYTE ENCODE OF NEEDED FUNCT NAME. NOT IN ANY CRITICAL RANGES...
  992.     LO=LO+1
  993.     LI=LI+3
  994.     GOTO 300
  995. 220    CONTINUE
  996.     LNOUT(LO)=LNIN(LI)
  997. C JUST COPY MISC. CHARACTER.
  998.     LO=LO+1
  999.     LI=LI+1
  1000. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  1001. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  1002.     LO=MIN0(LO,110)
  1003.     DO 400 N=LO,110
  1004. 400    LNOUT(N)=char(0)
  1005. C COPY REST OF 128 BYTE ARRAY
  1006.     DO 1 N=111,128
  1007. 1    LNOUT(N)=LNIN(N)
  1008. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  1009.     RETURN
  1010. 500    CONTINUE
  1011. C SPECIAL COPY OF 3 BYTE PACKED FORMS FOR SPEED
  1012.     LNOUT(LO)=LNIN(LI)
  1013.     LNOUT(LO+1)=LNIN(LI+1)
  1014.     LNOUT(LO+2)=LNIN(LI+2)
  1015.     LO=LO+3
  1016.     LI=LI+3
  1017.     GOTO 300
  1018.     END
  1019. c -h- calbin.for    Fri Aug 22 13:00:17 1986    
  1020.     SUBROUTINE CALBIN(RETCD)
  1021. C COPYRIGHT (C) 1983,1984 GLENN EVERHART
  1022. C ALL RIGHTS RESERVED
  1023. C 60=MAX REAL ROWS
  1024. C 301=MAX REAL COLS
  1025. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1026. C VBLS AND TYPE DIMENSIONED 60,301
  1027. C
  1028. C *******************************************************
  1029. C *                                                     *
  1030. C *             SUBROUTINE  CALBIN                      *
  1031. C *                                                     *
  1032. C *******************************************************
  1033. C
  1034. C  SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
  1035. C
  1036. C special version with multiple precision diked out - gce (to save space
  1037. C on 256K PC)
  1038. C  UPON ENTRANCE TO ROUTINE:
  1039. C    OPERAND1 IS IN STACK1  (ST1PT-1)
  1040. C    OPERAND2 IS ON TOP OF STACK2  (ST2PT-1)
  1041. C    OPERATOR IS BELOW OPERAND2  (ST2PT-2)
  1042. C  UPON EXIT:
  1043. C    RESULT IS IN STACK1
  1044. C    STACK2 HAS BEEN CLEANED UP
  1045. C
  1046. C  RETURN CODE    MEANING
  1047. C    1    NORMAL RETURN
  1048. C    2    OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  1049. C    3    ERROR RETURN
  1050. C
  1051. C
  1052. C
  1053. C  MODIFICATION CLASSES: M3, M4, AND M8
  1054. C
  1055. C
  1056. C
  1057. C  CALBIN CALLS
  1058. C
  1059. C  CONTYP   CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
  1060. C  ERRMSG   PRINTS OUT ERROR MESSAGES
  1061. C  MULADD   PERFORMS MULTIPLE PRECISION ADDITION
  1062. C  MULDIV   PERFORMS MULTIPLE PRECISION DIVISION
  1063. C  MULMUL   PERFORMS MULTIPLE PRECISION MULTIPLICATION
  1064. C
  1065. C
  1066. C
  1067. C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
  1068. C
  1069. C
  1070. C
  1071. C
  1072. C   VARIABLE     USE
  1073. C
  1074. C  EIGHT(8)      PICKS OUT A REAL CONSTANT FROM STACK.
  1075. C  FOUR(4)       PICKS OUT AN INTEGER CONSTANT FROM STACK.
  1076. C  I,J           HOLD TEMPORARY VALUES.
  1077. C  IA            FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
  1078. C                VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
  1079. C  ID            USED TO CONVERT DECISION TABLE CHARACTER*1 VALUE TO
  1080. C                AN InTeGer*4 VALUE THAT CAN BE USED AS AN ARGUMENT
  1081. C                IN A CALL TO CONTYP.
  1082. C  INT,IHOLD     HOLD INTEGER*4 VALUES.
  1083. C  IOP           HOLDS THE BINARY OPERATOR.
  1084. C  IOP2          USED TO INDEX A COMPUTED GO.
  1085. C  ISW           HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
  1086. C  MINUS         VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  1087. C                NUMBER THAT IS USED TO INDICATE A NEGATIVE.
  1088. C  OP1TYP        TYPE OF OPERAND 1.
  1089. C  OP2TYP        TYPE OF OPERAND 2.
  1090. C  PLUS          VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  1091. C                NUMBER THAT IS USED TO INDICATE POSITIVE.
  1092. C  PT1,PT2       POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
  1093. C  REAL,RHOLD    HOLD TEMPORARY REAL*8 VALUES.
  1094. C  RETCD         ERROR RETURN:  1 = O.K.   2 = RESULT WAS OUTPUT
  1095. C                3 = ERROR
  1096. C
  1097. C
  1098. C    SUBROUTINE CALBIN(RETCD)
  1099.     REAL*8 REAL,RHOLD,DFLOAT
  1100. C
  1101.     INTEGER*4 INT,IHOLD
  1102. C
  1103.     InTeGer*4 LEVEL,NONBLK,LEND
  1104.     InTeGer*4 VLEN(9)
  1105.     InTeGer*4 IOP,IA,ID,IOP2,ISW
  1106.     InTeGer*4 PLUS,MINUS
  1107.     InTeGer*4 VIEWSW,BASED
  1108. c    InTeGer*4 OLDTYP,VIEWSW,BASED
  1109.     InTeGer*4 TYPE(1,2)
  1110.     InTeGer*4 RETCD,RETCD2
  1111.     InTeGer*4 OP1TYP,OP2TYP
  1112.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  1113.     InTeGer*4 PT1,PT2
  1114. C
  1115.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  1116.     InTeGer*4 STK12(2,40)
  1117.     REAL*8 XVBLK
  1118.     EQUIVALENCE(STK12(1,1),STACK1(1,1))
  1119.     CHARACTER*1 AVBLS(24,27), DTBL1(9,9,8)
  1120.     Real*8 VAVBLS(3,27)
  1121.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  1122.     CHARACTER*1 VBLS(8,1,1)
  1123.     EQUIVALENCE (XVBLK,VBLS(1,1,1))
  1124.     CHARACTER*1 EIGHT(8),FOUR(4)
  1125.     CHARACTER*1 LINE(80)
  1126. C
  1127.     EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
  1128. C
  1129.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1130.     COMMON/V/ TYPE,AVBLS,VBLS,VLEN
  1131.     COMMON /STACKx/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  1132.      ;         ST1LIM,ST2LIM
  1133.     COMMON /DECIDE/DTBL1
  1134. C
  1135. C
  1136.     save plus,minus
  1137.     DATA PLUS/0/,MINUS/1/
  1138. C
  1139. C
  1140.     RETCD=1
  1141.     PT1=ST1PT-1
  1142.     PT2=ST2PT-1
  1143. C
  1144.     IOP=ST2TYP(ST2PT-2)
  1145.     OP1TYP=ST1TYP(PT1)
  1146.     OP2TYP=ST2TYP(PT2)
  1147. C NOTE THAT IA IS UNUSED HERE... SAVE BIG DIMENSIONS
  1148.     IA=ICHAR(STACK1(1,PT1))
  1149.     ID1=STK12(1,PT1)
  1150.     ID2=STK12(2,PT1)
  1151. C    CALL GETDM(STACK1(1,PT1),ID1,ID2)
  1152. C ****&&&& ABOVE GETS LOCS IN 2 DIM ARRAY OF VARIABLES
  1153.     IF (IOP.NE.200) GOTO 100
  1154. C
  1155. C
  1156. C
  1157. C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
  1158.     IF(OP1TYP.GE.0) GO TO 5
  1159. C
  1160. C
  1161. C
  1162. C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
  1163.     OP1TYP=-OP1TYP
  1164.     ST1TYP(PT1)=OP1TYP
  1165. C
  1166. C
  1167. C
  1168. C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
  1169. C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE  I=J=2
  1170. 5    J=VLEN(OP2TYP)
  1171. C    TYPE(IA)=OP1TYP
  1172.     CALL TYPSET(ID1,ID2,OP1TYP)
  1173. C    TYPE(ID1,ID2)=OP1TYP
  1174. C *&*****&&&&& NOTE TYPE ARRAY AND VBLS ARRAY NOW ARE HUGE
  1175. C  NOTE FURTHER THAT AVBLS IS OLD VBLS ARRAY. SWITCHED ON IF
  1176. C ID1 =< 27 AND ID2=1.
  1177.     DO 10 I=1,J
  1178. 10    STACK1(I,PT1)=STACK2(I,PT2)
  1179.     CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
  1180.     GOTO (20,9999), RETCD2
  1181.     STOP 20
  1182. C
  1183. C
  1184. C THE SPECIFIED VARIABLE GETS NEW VALUE.
  1185. C ***&&&& HERE'S WHERE WE STORE A VALUE INTO A VARIABLE...
  1186. 20    J=VLEN(OP1TYP)
  1187.     DO 30 I=1,J
  1188. C    VBLS(I,IA)=STACK1(I,PT1)
  1189.     IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 22
  1190. C REPLACE VBLSET CALL WITH XVBLST CALL ON LAST PASS TO AVOID
  1191. C MULTIPLE REPLACEMENT OF STORAGE FOR EVERY PASS.
  1192.     VBLS(I,1,1)=STACK1(I,PT1)
  1193.     IF(I.EQ.J)CALL XVBLST(ID1,ID2,XVBLK)
  1194. C    CALL VBLSET(I,ID1,ID2,STACK1(I,PT1))
  1195. C    VBLS(I,ID1,ID2)=STACK1(I,PT1)
  1196.     GOTO 30
  1197. 22    AVBLS(I,ID1)=STACK1(I,PT1)
  1198. C *****&&&&&
  1199. 30    CONTINUE
  1200.     GOTO 10000
  1201. C
  1202. C
  1203. C  IOP2 VALUES 1="**"  2="*"   3="/"   4="+"   5="-"
  1204. 100    IOP2=IOP-111
  1205.     GOTO (1000,2000,2000,2000,2000),IOP2
  1206. C
  1207. C
  1208. C    ********************************************
  1209. C    ***********  EXPONENTIATION  ***************
  1210. C    ********************************************
  1211. C
  1212. C
  1213. C  FIRST CONVERT TO PROPER TYPE
  1214. 1000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,5))
  1215.     CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
  1216.     IF (RETCD2.EQ.2) GOTO 9999
  1217.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,6))
  1218.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1219.     IF (RETCD2.EQ.2) GOTO 9999
  1220. C
  1221. C
  1222. C  GOTO APPROPRIATE PLACE TO PERFORM OPERATION
  1223.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,8))
  1224.     GOTO (1100,1200,1300,1400,1500,1600,1700),ID
  1225.     STOP 1000
  1226. C
  1227. C
  1228. C  REAL**REAL
  1229. 1100    DO 1104 I=1,8
  1230. 1104    EIGHT(I)=STACK1(I,PT1)
  1231.     RHOLD=REAL
  1232.     DO 1108 I=1,8
  1233. 1108    EIGHT(I)=STACK2(I,PT2)
  1234.     REAL=RHOLD**REAL
  1235. C
  1236. C
  1237. C  USED BY REAL**I
  1238. 1109    DO 1110 I=1,8
  1239. 1110    STACK1(I,PT1)=EIGHT(I)
  1240. C
  1241. C
  1242. C  USED BY I**REAL,I**I
  1243. 1114    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,7))
  1244.     GOTO 10000
  1245. C
  1246. C
  1247. C
  1248. C  REAL**I
  1249. 1200    DO 1204 I=1,8
  1250. 1204    EIGHT(I)=STACK1(I,PT1)
  1251.     DO 1208 I=1,4
  1252. 1208    FOUR(I)=STACK2(I,PT2)
  1253.     REAL=REAL**INT
  1254.     GOTO 1109
  1255. C
  1256. C
  1257. C
  1258. C  I**REAL (PARTS USED BY I**I)
  1259. 1300    DO 1304 I=1,4
  1260. 1304    FOUR(I)=STACK1(I,PT1)
  1261.     DO 1308 I=1,8
  1262. 1308    EIGHT(I)=STACK2(I,PT2)
  1263. C
  1264. C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
  1265. C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
  1266. C
  1267.     INT=DFLOAT(INT)**REAL
  1268. 1310    DO 1314 I=1,4
  1269. 1314    STACK1(I,PT1)=FOUR(I)
  1270.     GOTO 1114
  1271. C
  1272. C
  1273. C
  1274. C  I**I
  1275. 1400    DO 1404 I=1,4
  1276. 1404    FOUR(I)=STACK1(I,PT1)
  1277.     IHOLD=INT
  1278.     DO 1408 I=1,4
  1279. 1408    FOUR(I)=STACK2(I,PT2)
  1280.     INT=IHOLD**INT
  1281.     GOTO 1310
  1282. C
  1283. C
  1284. C
  1285. C  M8**I    (PARTS USED BY M10**I, M16**I)
  1286. 1500    ISW=8
  1287. 1501    IF(ST2PT.LE.ST2LIM)GO TO 1502
  1288. C
  1289. C
  1290. C STACK OVERFLOW
  1291.     CALL ERRMSG(9)
  1292.     GO TO 9999
  1293. C
  1294. C
  1295. C GET EXPONENT AS AN INTEGER
  1296. 1502    DO 1504 I=1,4
  1297. 1504    FOUR(I)=STACK2(I,PT2)
  1298.     IF (INT.GE.0) GOTO 1520
  1299. C
  1300. C
  1301. C EXPONENT NOT POSITIVE OR 0
  1302.     CALL ERRMSG (15)
  1303.     GOTO 9999
  1304. 1520    IF (INT.GT.0) GOTO 1530
  1305. C
  1306. C
  1307. C I**0 = 1
  1308.     STACK1(8,PT1)=char(PLUS)
  1309.     DO 1522 I=2,7
  1310. 1522    STACK1(I,PT1)=char(0)
  1311. C LEAVE AS INTEGER SETS HERE RATHER THAN EXPLICIT CHAR() CALLS
  1312.     STACK1(1,PT1)=char(1)
  1313.     GOTO 10000
  1314. C
  1315. C
  1316. C EXPONENT IS > 0
  1317. 1530    INT=INT-1
  1318. C
  1319. C
  1320. C IF EXPONENT = 1 WE ARE DONE
  1321.     IF(INT.EQ.0)GO TO 10000
  1322. C
  1323. C
  1324. C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
  1325. C FACTOR.
  1326.     DO 1534 I=1,8
  1327. 1534    STACK2(I,ST2PT)=STACK1(I,PT1)
  1328.     ST2TYP(ST2PT)=ST1TYP(PT1)
  1329. C
  1330. C
  1331. C
  1332. C
  1333. 1549    continue
  1334. c1549    DO 1550 I=1,INT
  1335. c    CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
  1336. c    IF(RETCD2.GE.2)GO TO 9999
  1337. c1550    CONTINUE
  1338.     GOTO 10000
  1339. C
  1340. C  M10**I
  1341. 1600    ISW=10
  1342.     GOTO 1501
  1343. C
  1344. C
  1345. C
  1346. C  M16**I
  1347. 1700    ISW=16
  1348.     GOTO 1501
  1349. C
  1350. C
  1351. C  *****************************************
  1352. C  * MAKE CONVERSIONS APPROPRIATE FOR */+- *
  1353. C  *****************************************
  1354. 2000    CONTINUE
  1355.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,1))
  1356.     CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
  1357.     IF (RETCD2.EQ.2) GOTO 9999
  1358.     IF(ID.EQ.0)GO TO 2010
  1359.     ST1TYP(PT1)=ID
  1360.     OP1TYP=ID
  1361. 2010    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,2))
  1362.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1363.     IF (RETCD2.EQ.2) GOTO 9999
  1364.     IF(ID.EQ.0)GOTO 2020
  1365.     ST2TYP(PT2)=ID
  1366.     OP2TYP=ID
  1367. C
  1368. 2020    CONTINUE
  1369. C
  1370. C
  1371. C  GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
  1372.     GOTO (2100,3000,4000,5000,6000),IOP2
  1373. 2100    STOP 2100
  1374. C
  1375. C
  1376. C
  1377. C
  1378. C
  1379. C
  1380. C  **********************************************
  1381. C  ***********  MULTIPLICATION  *****************
  1382. C  **********************************************
  1383. 3000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1384.     GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
  1385.     STOP 3000
  1386. C
  1387. C
  1388. C  ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
  1389. 3100    CALL ERRMSG (12)
  1390.     GOTO 9999
  1391. C
  1392. C
  1393. C  DECIMAL, REAL
  1394. 3200    DO 3204 I=1,8
  1395. 3204    EIGHT(I)=STACK1(I,PT1)
  1396.     RHOLD=REAL
  1397.     DO 3208 I=1,8
  1398. 3208    EIGHT(I)=STACK2(I,PT2)
  1399.     REAL=RHOLD*REAL
  1400. 3209    DO 3210 I=1,8
  1401. 3210    STACK1(I,PT1)=EIGHT(I)
  1402. C
  1403. C
  1404. C  FOLLOWING USED BY OTHER SECTIONS
  1405. 3220    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,3))
  1406.     GOTO 10000
  1407. C
  1408. C
  1409. C
  1410. C  HEX,INTEGER,OCTAL
  1411. 3300    DO 3304 I=1,4
  1412. 3304    FOUR(I)=STACK1(I,PT1)
  1413.     IHOLD=INT
  1414.     DO 3308 I=1,4
  1415. 3308    FOUR(I)=STACK2(I,PT2)
  1416.     INT=IHOLD*INT
  1417. 3309    DO 3310 I=1,4
  1418. 3310    STACK1(I,PT1)=FOUR(I)
  1419.     GOTO 3220
  1420. C
  1421. C
  1422. C
  1423. C  M10
  1424. 3500    continue
  1425. c3500    CALL MULMUL (PT1,PT2,RETCD2,10)
  1426. C
  1427. C
  1428. C  FOLLOWING USED BY OTHER SECTIONS
  1429. 3510    IF (RETCD2.EQ.2) GOTO 9999
  1430.     GOTO 3220
  1431. C
  1432. C
  1433. C
  1434. C  M8
  1435. 3600    continue
  1436. c3600    CALL MULMUL (PT1,PT2,RETCD2,8)
  1437.     GOTO 3510
  1438. C
  1439. C
  1440. C
  1441. C  M16
  1442. 3700    continue
  1443. c3700    CALL MULMUL (PT1,PT2,RETCD2,16)
  1444.     GOTO 3510
  1445. C
  1446. C
  1447. C  **************************************************
  1448. C  ******************  DIVISION  ********************
  1449. C  **************************************************
  1450. 4000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1451.     GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
  1452.     STOP 4000
  1453. C
  1454. C
  1455. C  DECIMAL,REAL
  1456. 4200    DO 4204 I=1,8
  1457. 4204    EIGHT(I)=STACK1(I,PT1)
  1458.     RHOLD=REAL
  1459.     DO 4208 I=1,8
  1460. 4208    EIGHT(I)=STACK2(I,PT2)
  1461.     IF(REAL.NE.0.D0)GO TO 4210
  1462.     CALL ERRMSG(23)
  1463.     GO TO 9999
  1464. 4210    REAL=RHOLD/REAL
  1465.     GOTO 3209
  1466. C
  1467. C
  1468. C  HEX,INTEGER,OCTAL
  1469. 4300    DO 4304 I=1,4
  1470. 4304    FOUR(I)=STACK1(I,PT1)
  1471.     IHOLD=INT
  1472.     DO 4308 I=1,4
  1473. 4308    FOUR(I)=STACK2(I,PT2)
  1474.     IF(INT.NE.0)GO TO 4310
  1475.     CALL ERRMSG(23)
  1476.     GO TO 9999
  1477. 4310    INT=IHOLD/INT
  1478.     GOTO 3309
  1479. C
  1480. C
  1481. C  M10
  1482. 4500    continue
  1483. c4500    CALL MULDIV (PT1,PT2,RETCD2,10)
  1484.     GOTO 3510
  1485. C
  1486. C
  1487. C  M8
  1488. 4600    continue
  1489. c4600    CALL MULDIV (PT1,PT2,RETCD2,8)
  1490.     GOTO 3510
  1491. C
  1492. C
  1493. C  M16
  1494. 4700    continue
  1495. c4700    CALL MULDIV (PT1,PT2,RETCD2,16)
  1496.     GOTO 3510
  1497. C
  1498. C
  1499. C
  1500. C
  1501. C
  1502. C **************************************************
  1503. C *****************  ADDITION  *********************
  1504. C **************************************************
  1505. C
  1506. 5000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1507.     GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
  1508.     STOP 5000
  1509. C
  1510. C
  1511. C  DECIMAL, REAL
  1512. 5200    DO 5204 I=1,8
  1513. 5204    EIGHT(I)=STACK1(I,PT1)
  1514.     RHOLD=REAL
  1515.     DO 5208 I=1,8
  1516. 5208    EIGHT(I)=STACK2(I,PT2)
  1517.     REAL=RHOLD+REAL
  1518.     GOTO 3209
  1519. C
  1520. C
  1521. C  HEX,INTEGER,OCTAL
  1522. 5300    DO 5304 I=1,4
  1523. 5304    FOUR(I)=STACK1(I,PT1)
  1524.     IHOLD=INT
  1525.     DO 5308 I=1,4
  1526. 5308    FOUR(I)=STACK2(I,PT2)
  1527.     INT=IHOLD+INT
  1528.     GOTO 3309
  1529. C
  1530. C
  1531. C  M10
  1532. 5500    continue
  1533. c5500    CALL MULADD (PT1,PT2,RETCD2,1)
  1534.     GOTO 3510
  1535. C
  1536. C
  1537. C  M8
  1538. 5600    continue
  1539. c5600    CALL MULADD (PT1,PT2,RETCD2,2)
  1540.     GOTO 3510
  1541. C
  1542. C
  1543. C  M16
  1544. 5700    continue
  1545. c5700    CALL MULADD(PT1,PT2,RETCD2,3)
  1546.     GOTO 3510
  1547. C
  1548. C
  1549. C
  1550. C
  1551. C
  1552. C
  1553. C  ***************************************************
  1554. C  ******************  SUBTRACTION  ******************
  1555. C  ***************************************************
  1556. C
  1557. 6000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1558.     GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
  1559.     STOP 6000
  1560. C
  1561. C
  1562. C  DECIMAL,REAL
  1563. 6200    DO 6204 I=1,8
  1564. 6204    EIGHT(I)=STACK1(I,PT1)
  1565.     RHOLD=REAL
  1566.     DO 6208 I=1,8
  1567. 6208    EIGHT(I)=STACK2(I,PT2)
  1568.     REAL=RHOLD-REAL
  1569.     GOTO 3209
  1570. C
  1571. C
  1572. C  HEX,INTEGER,OCTAL
  1573. 6300    DO 6304 I=1,4
  1574. 6304    FOUR(I)=STACK1(I,PT1)
  1575.     IHOLD=INT
  1576.     DO 6308 I=1,4
  1577. 6308    FOUR(I)=STACK2(I,PT2)
  1578.     INT=IHOLD-INT
  1579.     GOTO 3309
  1580. C
  1581. C
  1582. C  M10
  1583. 6500    continue
  1584. c6500    CALL MULADD (PT1,PT2,RETCD2,4)
  1585.     GOTO 3510
  1586. C
  1587. C
  1588. C  M8
  1589. 6600    continue
  1590. c6600    CALL MULADD (PT1,PT2,RETCD2,5)
  1591.     GOTO 3510
  1592. C
  1593. C
  1594. C  M16
  1595. 6700    continue
  1596. c6700    CALL MULADD (PT1,PT2,RETCD2,6)
  1597.     GOTO 3510
  1598. C
  1599. C
  1600. C
  1601. C
  1602. C
  1603. C    EXIT
  1604. 9999    RETCD=3
  1605. C
  1606. C
  1607. C
  1608. 10000    ST2PT=ST2PT-2
  1609.     RETURN
  1610.     END
  1611. c -h- calc.for    Fri Aug 22 13:00:17 1986    
  1612.     SUBROUTINE CALC
  1613. C COPYRIGHT (C) 1983 GLENN EVERHART
  1614. C ALL RIGHTS RESERVED
  1615. C 60=MAX REAL ROWS
  1616. C 301=MAX REAL COLS
  1617. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1618. C VBLS AND TYPE DIMENSIONED 60,301
  1619. C ***               CALC   MAINLINE                   ***
  1620. C
  1621. C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
  1622. C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
  1623. C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
  1624. C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN
  1625. C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
  1626. C POSSIBLE COMMANDS.
  1627. C
  1628. C    CALC CALLS
  1629. C
  1630. C  ASSIGN    OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
  1631. C  CLOSE     CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
  1632. C  CMND      DETERMINES WHAT CALC COMMAND IS REQUIRED.
  1633. C  ERRCX     CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
  1634. C  ERRMSG    PRINTS OUT ERROR MESSAGES.
  1635. C  EXIT      RETURNS TO OPERATING SYSTEM.
  1636. C  GETMCR    GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
  1637. C            IS PRESENT, CALC EXITS AFTER THAT ONE COMMAND IS EXECUTED.
  1638. C  INPOST    CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
  1639. C  LIST      LISTS THE LEGAL CALC COMMANDS.
  1640. C  POSTVL    CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
  1641. C            A VALUE.
  1642. C  SLEND     FINDS THE LAST NON-BLANK IN LINE(80).
  1643. C  VAROUT    PRINTS OUT THE VALUE OF A VARIABLE.
  1644. C  ZNEG      DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
  1645. C
  1646. C
  1647. C
  1648. C   VARIABLE      USE
  1649. C
  1650. C  BASED        DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
  1651. C  BLANK        ' '
  1652. C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
  1653. C               SECOND SUBSCRIPT IS
  1654. C                     1 FOR DECIMAL
  1655. C                     2 FOR OCTAL
  1656. C                     3 FOR HEXADECIMAL
  1657. C  I,J          HOLD TEMPORARY VALUES.
  1658. C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
  1659. C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
  1660. C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
  1661. C               USED TO CONTROL ITERATION.
  1662. C        THIS VARIABLE IS GUARANTEED TO BE 1-27.
  1663. C  LEND         POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
  1664. C  LEVEL        HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
  1665. C               LINES COME FROM.
  1666. C  LINE(80)     COMMAND INPUT LINE.
  1667. C  NONBLK       POINTS TO LAST NON-BLANK FOUND IN LINE(80).
  1668. C  ONCE         HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
  1669. C               0 OTHERWISE.
  1670. C  STAR         '*'
  1671. C  VIEWSW           VIEW SWITCH
  1672. C                    0 = OUTPUT ERROR MESSAGES
  1673. C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
  1674. C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
  1675. C                        EVALUATED.
  1676. C                    3 = OUTPUT EVERYTHING
  1677. C  WHAT         '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
  1678. C               SHOULD BE OUTPUT.
  1679. C
  1680. C    MODIFIED    REASON
  1681. C
  1682. C    18-MAY-1981    DELETED LINE THAT CAUSED DEFAULT BASE TO BE RESET
  1683. C            WHEN AN ERROR OCCURS (PB)
  1684. C
  1685. C    18-MAY-1981    ADDED CODE AT LINES 106 TO 108 TO CONVERT FROM LOWER
  1686. C            TO UPPER CASE  (PB)
  1687. C
  1688. C CHANGED TO SUBROUTINE GCE TO ALLOW EXTERNAL CONTROL OF CALCULATOR.
  1689. C
  1690.     InTeGer*4 LEVEL,NONBLK,LEND
  1691.     InTeGer*4 RETCD,VIEWSW,BASED
  1692.     InTeGer*4 ONCE
  1693.     InTeGer*4 ZNEG,ITCNTV(6)
  1694. C
  1695.     CHARACTER*1  LINE(80),WHAT,STAR,QUOTE
  1696.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  1697.     CHARACTER*1 DIGITS(16,3)
  1698.     CHARACTER*1 OARRY(100)
  1699.     InTeGer*4 OSWIT,OCNTR
  1700. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1701. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1702.     InTeGer*4 IPS1,IPS2,MODFLG
  1703. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1704.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1705.        CHARACTER*1 XTNCMD(80)
  1706. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1707. C VARY FLAG ITERATION COUNT
  1708.     INTEGER KALKIT
  1709. C    COMMON/VARYIT/KALKIT
  1710.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1711.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1712. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1713. C     1  IRCE2
  1714. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1715. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1716. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1717. C RCFGX ON.
  1718. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1719. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1720. C  AND VM INHIBITS. (SETS TO 1).
  1721.     INTEGER*4 FH
  1722. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1723. C    COMMON/CONSFH/FH
  1724.     CHARACTER*1 ARGSTR(52,4)
  1725. C    COMMON/ARGSTR/ARGSTR
  1726.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  1727.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1728.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1729.      3  IRCE2,FH,ARGSTR
  1730.     InTeGer*4 ILNFG,ILNCT
  1731.     CHARACTER*1 ILINE(106)
  1732.     COMMON/ILN/ILNFG,ILNCT,ILINE
  1733. C
  1734.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1735.     InTeGer*4 RRWACT,RCLACT
  1736. C    COMMON/RCLACT/RRWACT,RCLACT
  1737.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  1738.      1  IDOL7,IDOL8
  1739. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  1740. C     1  IDOL7,IDOL8
  1741.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  1742. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1743.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1744. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1745. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  1746. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  1747.     InTeGer*4 KLVL
  1748. C    COMMON/KLVL/KLVL
  1749.     InTeGer*4 IOLVL,IGOLD
  1750. C    COMMON/IOLVL/IOLVL
  1751. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  1752. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  1753.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1754.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1755.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  1756.      3  k3dfg,kcdelt,krdelt,kpag
  1757. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1758. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1759. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  1760. C    COMMON/KLVL/KLVL
  1761.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  1762.     COMMON /DIGV/ DIGITS
  1763.     COMMON/ITERA/ITCNTV
  1764.     Character*2 crlf
  1765.     character*127 cwrk
  1766. C
  1767.     save what,star,quote,once
  1768.     DATA  WHAT/'?'/, STAR/'*'/, QUOTE/''''/
  1769.     DATA ONCE/0/
  1770. C
  1771.     crlf(1:1)=char(13)
  1772.     crlf(2:2)=char(10)
  1773. C
  1774. C
  1775. C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
  1776. C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
  1777. C THE MODULES PROPERLY, PUT IN A
  1778.     IF(KLVL.EQ.1)LEVEL=KLVL
  1779.     ONCE=0
  1780. C    IF(ILNFG.NE.0) GOTO 6000
  1781. C    CALL ASSIGN (1,'TT:')
  1782. 6000    CONTINUE
  1783. C CHANGE TI: TO TT: FOR VMS.
  1784. C
  1785.     IF(ILNFG.EQ.0)GOTO 6010
  1786.     IF(ILNCT.GT.0)GOTO 6010
  1787. C INVALID INPUTS...NO LINE TO DO BUT FLAGGED TO DO. CLEAN UP.
  1788.     ILNFG=0
  1789.     RETURN
  1790. 6010    CONTINUE
  1791.     IF(ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6001
  1792. C ++++++
  1793. C FOR DEC FORTRAN:
  1794. C    CALL GETMCR(LINE,LEND)
  1795. C    IF(LEND)20,20,5
  1796. C FOR NON-DEC FORTRAN: (OR VAX VERSIONS)
  1797.     GOTO 20
  1798. C ++++++  END OF CHOICES...
  1799. 5    CONTINUE
  1800.     GOTO 6003
  1801. 6001    CONTINUE
  1802.     DO 6007 LENDX=1,80
  1803. 6007    LINE(LENDX)=CHAR(32)
  1804.     IF(ILNFG.EQ.1)ONCE=1
  1805.     I255X=0
  1806.     DO 6002 LENDX=1,ILNCT
  1807.     LINE(LENDX)=ILINE(LENDX)
  1808.     IF(ICHAR(LINE(LENDX)).EQ.255)I255X=3
  1809.     IF(I255X.LE.0)GOTO 4602
  1810.     I255X=I255X-1
  1811.     GOTO 6002
  1812. C SKIP ENTIRE 3-CHR PACKED CODES
  1813. 4602    CONTINUE
  1814.     IF(ICHAR(LINE(LENDX)).GT.0.AND.ICHAR(LINE(LENDX)).LT.32)
  1815.      1  LINE(LENDX)=CHAR(32)
  1816. C LEAVE ANY EXISTING NULLS IN.
  1817. 6002    CONTINUE
  1818.     LEND=ILNCT
  1819. CD    CALL FRMEDT(LINE,LEND)
  1820. C FRMEDT IMPLEMENTS EDITS OF {VAR INTO THAT VARIABLE'S FORMULA
  1821. CC NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1822. C    ICCC=MIN0(80,(LEND+1))
  1823. C    LINE(ICCC)=0
  1824.     GOTO 103
  1825. 6003    CONTINUE
  1826.     DO 6 NONBLK=1,7
  1827.     IF(LINE(NONBLK).EQ.BLANK)GO TO 7
  1828.     IF(ICHAR(LINE(NONBLK)).EQ.13)GO TO 20
  1829. 6    CONTINUE
  1830.     STOP 6
  1831. 7    NONBLK=NONBLK+1
  1832.     ONCE=1
  1833.     GO TO 106
  1834. C
  1835. C  ERROR RESET
  1836.  
  1837. 10    IF(LEVEL.LE.1) GO TO 12
  1838.     CLOSE(LEVEL)
  1839.     LEVEL=LEVEL-1
  1840.     GO TO 10
  1841. 12    CONTINUE
  1842.     VIEWSW=3
  1843. C
  1844. C
  1845. C  GET NEXT INPUT LINE
  1846. 20    CONTINUE
  1847.     LINE(1)=char(0)
  1848.     LINE(2)=char(0)
  1849.     IF(ONCE.EQ.1.AND.LEVEL.LE.1) RETURN
  1850. C20    IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL EXIT
  1851. C    IF (ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6004
  1852.     IF (LEVEL.LE.1.AND.ILNFG.NE.0.AND.ILNCT.GT.0)RETURN
  1853.     IF(LEVEL.LT.1)RETURN
  1854.     IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)call vwrt(crlf,2)
  1855.     IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)call vwrt('Calc>',5)
  1856. c22    FORMAT(' CALC>')
  1857. C
  1858. C
  1859.     LLLV=LEVEL
  1860.     IF(LLLV.EQ.1)LLLV=11
  1861. c    rewind 11
  1862.     if(lllv.ne.11)goto 6008
  1863.     call vget(line,80)
  1864.     do 6009 iii=1,80
  1865. C Force chars read in to spaces like Fortran system would.
  1866. C This includes controls like crlf.
  1867.     if(ichar(line(iii)).le.31)line(iii)=' '
  1868. 6009    Continue
  1869. 6008    Continue
  1870. c    if(lllv.eq.11)call vget(line,80)
  1871.     if(lllv.ne.11)READ (LLLV,24,END=900,ERR=1000) LINE
  1872. c    rewind 11
  1873. 24    FORMAT (80A1)
  1874. C    GOTO 6005
  1875. C SECTION BELOW COMMENTED OUT BECAUSE IT SHOULD NEVER BE CALLED (GCE).
  1876. C6004    CONTINUE
  1877. C    DO 6006 LENDX=1,80
  1878. C6006    LINE(LENDX)=CHAR(32)
  1879. CC ABOVE BLANKS OUT LINE ARRAY
  1880. C    DO 6007 LENDX=1,ILNCT
  1881. C6007    LINE(LENDX)=ILINE(LENDX)
  1882. CC ABOVE COPIES INPUT FROM OUR CALLER...
  1883. C6005    CONTINUE
  1884. C
  1885. C
  1886. C
  1887. C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
  1888. CD    CALL FRMEDT(LINE,LEND)
  1889.     CALL SLEND(RETCD)
  1890.     GO TO(30,20),RETCD
  1891.     STOP 30
  1892. 30    CONTINUE
  1893. C
  1894. C
  1895.     IF(ILNFG.EQ.0.AND.ILNCT.GT.0)GOTO 103
  1896. C SHOW WHAT WAS READ FROM FILE
  1897. c    rewind 11
  1898.     cwrk=' '
  1899.     IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
  1900.      1  write(cwrk,40)level,(line(i),i=1,lend)
  1901.     cwrk= crlf // cwrk
  1902.     iii=lend+10
  1903.     IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
  1904.      1  call vwrt(cwrk,iii)
  1905. c     1 WRITE(11,40)LEVEL,(LINE(I),I=1,LEND)
  1906. c    rewind 11
  1907. 40    FORMAT (' CALC<',I1,'>',80A1)
  1908. 103    CONTINUE
  1909. C NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1910.     ICCC=MIN0(80,(LEND+1))
  1911.     LINE(ICCC)=char(0)
  1912. C
  1913. C  IDENTIFY FIRST NON-BLANK
  1914.     DO 104 NONBLK=1,LEND
  1915.     IF (LINE(NONBLK).NE.BLANK) GOTO 106
  1916. 104    CONTINUE
  1917.     RETURN
  1918. C    STOP 104
  1919. C
  1920. C CONVERT LOWER CASE TO UPPER CASE
  1921. 106    CONTINUE
  1922.     I255X=0
  1923.     DO 108 I=NONBLK,LEND
  1924.     J=ICHAR(LINE(I))
  1925.     IF(J.EQ.255)I255X=3
  1926.     IF(I255X.LE.0)GOTO 3107
  1927. C SKIP ENCODED VARIABLE NAMES
  1928.     I255X=I255X-1
  1929.     GOTO 107
  1930. 3107    CONTINUE
  1931.     IF (I.EQ.NONBLK) GOTO 107
  1932.     IF (LINE(I-1).EQ.QUOTE) GOTO 108
  1933.     IF(J.GE.97.AND.J.LE.122) LINE(I)=CHAR(J-32)
  1934. 107    CONTINUE
  1935. 108    CONTINUE
  1936. C
  1937. C  SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
  1938.     IF (LINE(NONBLK).NE.WHAT) GOTO 110
  1939.     CALL LIST
  1940.     GOTO 20
  1941. C
  1942. C  SEE IF IT IS A COMMAND
  1943. 110    IF (LINE(NONBLK).NE.STAR) GOTO 120
  1944.     CALL CMND (RETCD)
  1945.     GOTO (20,115,10,6120), RETCD
  1946. 6120    RETURN
  1947. C    STOP 110
  1948. C
  1949. C
  1950. C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
  1951. 115    CALL SLEND(RETCD)
  1952.     GO TO (103,20),RETCD
  1953.     RETURN
  1954. C    STOP 115
  1955. C
  1956. C  SEE IF ONLY ONE ALPHA CHARACTER
  1957. 120    J=NONBLK+1
  1958.     IF (LEND.NE.NONBLK) GOTO 130
  1959.     DO 124 I=1,27
  1960.     IF (LINE(NONBLK).EQ.ALPHA(I)) GOTO 126
  1961. 124    CONTINUE
  1962. C
  1963. C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
  1964.     DO 125 I=1,10
  1965.     IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
  1966. 125    CONTINUE
  1967. C
  1968. C
  1969. C ALLOW FOR ENTERING THE ASCII BLANK
  1970.     IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
  1971.     I=1
  1972.     GOTO 1001
  1973. C
  1974. C  OUTPUT VALUE OF SINGLE VARIABLE
  1975. 126    CALL VAROUT(I,1)
  1976.     GOTO 20
  1977. C
  1978. C
  1979. C CHECK INPUT FOR SYNTAX ERRORS
  1980. 130    CALL ERRCX (RETCD)
  1981.     GOTO (140,10),RETCD
  1982.     RETURN
  1983. C    STOP 130
  1984. C
  1985. C  CHANGE FROM INFIX TO POSTFIX NOTATION
  1986. 140    CALL INPOST (RETCD)
  1987.     GOTO (150,10), RETCD
  1988. C
  1989. C
  1990. C EVALUATE EXPRESSION
  1991. 150    CONTINUE
  1992.     CALL POSTVL(RETCD)
  1993.     GOTO(20,10),RETCD
  1994.     RETURN
  1995. C    STOP 150
  1996. C
  1997. C
  1998. C  EXIT
  1999. 900    CONTINUE
  2000.     IF (LEVEL.EQ.1) RETURN
  2001. C    IF (LEVEL.EQ.1) CALL EXIT
  2002.     IF(ITCNTV(LEVEL).EQ.0)GOTO 910
  2003.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
  2004. C
  2005. C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
  2006. C AND EXECUTE AGAIN.
  2007.     REWIND LEVEL
  2008.     GO TO 20
  2009. C
  2010. C
  2011. C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
  2012. C OF LEVEL BY ONE.
  2013. 910    CLOSE(LEVEL)
  2014.     LEVEL=LEVEL-1
  2015.     GOTO 20
  2016. C
  2017. C
  2018. C
  2019. C *** ERROR PROCESSING ***
  2020. 1000    I=27
  2021. 1001    CALL ERRMSG(I)
  2022.     GO TO 10
  2023.     END
  2024. c -h- calun.for    Fri Aug 22 13:00:17 1986    
  2025.     SUBROUTINE CALUN(RETCD)
  2026. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  2027. C ALL RIGHTS RESERVED
  2028. C 60=MAX REAL ROWS
  2029. C 301=MAX REAL COLS
  2030. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  2031.  
  2032. C VBLS AND TYPE DIMENSIONED 60,301
  2033. C  *****************************************************
  2034. C  *             SUBROUTINE   CALUN                    *
  2035. C  *****************************************************
  2036. C
  2037. C  SUBROUTINE CALUN PERFORMS A UNARY OPERATION.
  2038. C
  2039. C  UPON ENTRANCE:
  2040. C    OPERATOR IS ON STACK 2
  2041. C    OPERAND IS ON STACK 1
  2042. C  UPON EXIT:
  2043. C    OPERATOR HAS BEEN POPPED OFF STACK 2
  2044. C    RESULT IS ON STACK 1
  2045. C
  2046. C    RETCD    MEANING
  2047. C
  2048. C    1    O.K.
  2049. C    2    ERROR
  2050. C
  2051. C   MODIFICATION CLASSES: M3, M4, AND M8
  2052. C
  2053. C  CALUN CALLS
  2054. C
  2055. C  CONTYP   CONVERTS DATA TYPES
  2056. C  ERRMSG   PRINTS ERROR MESSAGES
  2057. C  $DATAN   ARC TANGENT
  2058. C  $DCOS    COSINE
  2059. C  $DEXP    E**X
  2060. C  $DLOG    NATURAL LOG
  2061. C  $DLOG10  LOG BASE 10
  2062. C  $DSIN    SINE
  2063. C  $DSQRT   SQUARE ROOT
  2064. C  $DTANH   HYPERBOLIC TANGENT
  2065. C
  2066. C  CALUN IS CALLED BY POSTVL WHICH CONVERTS FROM INFIX TO POSTFIX
  2067. C
  2068. C     VARIABLE    USE
  2069. C
  2070. C  RETCD      RETURN CODE:  1 = O.K.   2 = ERROR
  2071. C  J,K,K2,I   HOLD TEMPORARY VALUES
  2072. C  MINUS      VALUE IN LAST MULTIPLE PRECISION BYTE.
  2073. C             USED TO INDICATE A NEGATIVE NUMBER.
  2074. C  PLUS       VALUE IN LAST MULTIPLE PRCISION BYTE.
  2075. C             USED TO INDICATE A POSITIVE NUMBER.
  2076. C  REAL       TEMPORARY DOUBLE PRECISION VALUES.
  2077. C  INT        TEMPORARY INTEGER*4 VALUES.
  2078. C  ST1TYP(40) TYPE FOR EACH ELEMENT ON STACK 1
  2079. C  ST2TYP(40) TYPE FOR EACH ELEMENT OF STACK 2
  2080. C  ST1PT      POINTS TO TOP OF STACK 1
  2081. C  ST2PT      POINTS TO TOP OF STACK 2
  2082. C  STACK1     HOLDS OPERAND
  2083. C  STACK2     HOLDS UNARY OPERATOR
  2084. C
  2085. C    SUBROUTINE CALUN(RETCD)
  2086.     REAL*8 REAL
  2087.     REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
  2088.     REAL*8 DASIN,DACOS,DTAN
  2089.     REAL*8 DTANH,DATAN
  2090. C
  2091.     REAL*4 FLOAT
  2092. C
  2093.     INTEGER*4 INT
  2094. C
  2095.     InTeGer*4 RETCD,RETCD2
  2096.     InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT,ST1LIM,ST2LIM
  2097.     InTeGer*4 K,K2
  2098. C
  2099.     CHARACTER*1 STACK1(8,40),STACK2(8,40),FOUR(4),EIGHT(8)
  2100.     CHARACTER*1 PLUS,MINUS
  2101. C
  2102.     EQUIVALENCE (FOUR,INT),(EIGHT,REAL)
  2103. C
  2104.     COMMON /STACKx/STACK1,STACK2,ST1PT,ST2PT,
  2105.      ;          ST1TYP,ST2TYP,ST1LIM,ST2LIM
  2106. C
  2107. C    DATA PLUS/0/,MINUS/1/
  2108. C
  2109.     PLUS=char(0)
  2110.     MINUS=char(1)
  2111.     RETCD=(1)
  2112.     K=ST2TYP(ST2PT-1)
  2113.     K2=ST1TYP(ST1PT-1)
  2114. C
  2115. C
  2116. C MAKE SURE VARIABLE IS DEFINED
  2117.     IF(K2.GT.0)GOTO 50
  2118. C IF NOT, PRINT MESSAGE AND RETURN
  2119.     CALL ERRMSG(16)
  2120.     GOTO 89999
  2121. C
  2122. 50    J=K
  2123. C
  2124. C
  2125. C SEE IF IT IS A UNARY MINUS
  2126.     IF (J.EQ.111) GOTO 100
  2127. C
  2128. C
  2129. C  FUNCTIONS START AT 31
  2130.     K=K-30
  2131.     GOTO (100,100,300,400,500,400,10000),K
  2132.     GOTO 10000
  2133. C
  2134. C
  2135. C  ***************************************
  2136. C  *** ABS (=DABS), IABS, AND UNARY -  ***
  2137. C  ***************************************
  2138. 100    CONTINUE
  2139.     IF(K2.GT.0)GO TO 105
  2140.     CALL ERRMSG(16)
  2141.     GO TO 89999
  2142. 105    GOTO (110,120,130,130,140,140,140,130,120),K2
  2143.     STOP 100
  2144. C
  2145. C
  2146. C  ASCII
  2147. 110    CALL ERRMSG (12)
  2148.     GOTO 89999
  2149. C
  2150. C
  2151. C  DECIMAL AND REAL
  2152. 120    DO 121 I=1,8
  2153. 121    EIGHT(I)=STACK1(I,ST1PT-1)
  2154.     IF (K.NE.111) GOTO 123
  2155. C
  2156. C
  2157. C  UNARY -
  2158.     REAL=-REAL
  2159.     GOTO 124
  2160. 123    REAL=DABS(REAL)
  2161. 124    DO 125 I=1,8
  2162. 125    STACK1(I,ST1PT-1)=EIGHT(I)
  2163.     GOTO 90000
  2164. C
  2165. C
  2166. C  INTEGER, HEXADECIMAL, AND OCTAL
  2167. 130    DO 131 I=1,4
  2168. 131    FOUR(I)=STACK1(I,ST1PT-1)
  2169.     IF (K.NE.111) GOTO 133
  2170.     INT=-INT
  2171.     GO TO 134
  2172. 133    IF(INT.LT.0)INT=-INT
  2173. 134    DO 135 I=1,4
  2174. 135    STACK1(I,ST1PT-1)=FOUR(I)
  2175.     GOTO 90000
  2176. C
  2177. C
  2178. C  MULTIPLE PRECISION
  2179. 140    IF (K.NE.111) GOTO 150
  2180.     IF (STACK1(8,ST1PT-1).EQ.PLUS)GOTO 160
  2181. 150    STACK1(8,ST1PT-1)=PLUS
  2182.     GOTO 90000
  2183. 160    STACK1(8,ST1PT-1)=MINUS
  2184.     GOTO 90000
  2185. C
  2186. C
  2187. C  ***************************************
  2188. C  ************  FLOAT  ******************
  2189. C  ***************************************
  2190. 300    CONTINUE
  2191.     GOTO (310,320,330,330,340,340,340,330,320),K2
  2192. C
  2193. C
  2194. C  ASCII
  2195. 310    CALL ERRMSG(12)
  2196.     GOTO 89999
  2197. C
  2198. C
  2199. C  REAL (=DECIMAL)
  2200. 320    CALL ERRMSG (13)
  2201.     GOTO 89999
  2202. C
  2203. C
  2204. C  INTEGER=HEXADECIMAL=OCTAL
  2205. 330    DO 333 I=1,4
  2206. 333    FOUR(I)=STACK1(I,ST1PT-1)
  2207.     REAL=FLOAT(INT)
  2208.     DO 335 I=1,8
  2209. 335    STACK1(I,ST1PT-1)=EIGHT(I)
  2210.     ST1TYP(ST1PT-1)=2
  2211.     GOTO 90000
  2212. C
  2213. C
  2214. C  MULTIPLE PRECISION
  2215. 340    CALL ERRMSG (11)
  2216.     GOTO 89999
  2217. C
  2218. C
  2219. C
  2220. C  ***************************************
  2221. C  *******  IFIX AND INT (=IDINT)  *******
  2222. C  ***************************************
  2223. 400    CONTINUE
  2224.     GOTO (410,420,430,430,440,440,440,430,420),K2
  2225.     STOP 400
  2226. C
  2227. C
  2228. C  ASCII
  2229. 410    CALL ERRMSG (12)
  2230.     GOTO 89999
  2231. C
  2232. C
  2233. C  REAL AND DECIMAL
  2234. 420    DO 421 I=1,8
  2235. 421    EIGHT(I)=STACK1(I,ST1PT-1)
  2236.     INT=IDINT(REAL)
  2237.     DO 424 I=1,4
  2238. 424    STACK1(I,ST1PT-1)=FOUR(I)
  2239.     ST1TYP(ST1PT-1)=4
  2240.     GOTO 90000
  2241. C
  2242. C
  2243. C  INTEGER, HEXADECIMAL, AND OCTAL
  2244. 430    CALL ERRMSG (10)
  2245.     GOTO 89999
  2246. C
  2247. C
  2248. C  MULTIPLE PRECISION
  2249. 440    CALL ERRMSG (11)
  2250.     GOTO 89999
  2251. C
  2252. C
  2253. C
  2254. C  ***************************************
  2255. C  ***************  AINT  ****************
  2256. C  ***************************************
  2257. C
  2258. C  REAL TO REAL TRUNCATION
  2259. 500    CONTINUE
  2260.     GOTO (510,520,530,530,540,540,540,530,520),K2
  2261. C
  2262. C
  2263. C  ASCII
  2264. 510    CALL ERRMSG (12)
  2265.     GOTO 89999
  2266. C
  2267. C
  2268. C  REAL AND DECIMAL
  2269. 520    DO 522 I=1,8
  2270. 522    EIGHT(I)=STACK1(I,ST1PT-1)
  2271. C
  2272. C DON'T USE AINT(SNGL(REAL)) BECAUSE THEN
  2273. C 2.9999999 RESULTS IN 3.0
  2274.     REAL=DINT(REAL)
  2275.     DO 524 I=1,8
  2276. 524    STACK1(I,ST1PT-1)=EIGHT(I)
  2277.     GOTO 90000
  2278. C
  2279. C
  2280. C  INTEGER, HEXADECIMAL, AND OCTAL
  2281. 530    CALL ERRMSG (10)
  2282.     GOTO 89999
  2283. C
  2284. C
  2285. C  MULTIPLE PRECISION
  2286. 540    CALL ERRMSG(11)
  2287.     GOTO 89999
  2288. C
  2289. C
  2290. C
  2291. C
  2292. C  ****************************************
  2293. C  ****************************************
  2294. C  ********                        ********
  2295. C  ******** REAL TO REAL FUNCTIONS ********
  2296. C  ********                        ********
  2297. C  ********  EXP      (=DEXP)      ********
  2298. C  ********  ALOG     (=DLOG)      ********
  2299. C  ********  ALOG10   (=DLOG10)    ********
  2300. C  ********  SQRT     (=DSQRT)     ********
  2301. C  ********  SIN      (=DSIN)      ********
  2302. C  ********  COS      (=DCOS)      ********
  2303. C  ********  TANH     (DTANH)      ********
  2304. C  ********  ATAN     (=DATAN)     ********
  2305. C  ********                        ********
  2306. C  ****************************************
  2307. C  ****************************************
  2308. C
  2309. C
  2310. C
  2311. 10000    CONTINUE
  2312.     GOTO (11000,12000,15000,15000,15000,15000,15000,15000,12000),K2
  2313.     STOP 10000
  2314. C
  2315. C
  2316. C  ASCII
  2317. 11000    CALL ERRMSG (12)
  2318.     GOTO 89999
  2319. C
  2320. C
  2321. C  REAL AND DECIMAL
  2322. 12000    DO 12010 I=1,8
  2323. 12010    EIGHT(I)=STACK1(I,ST1PT-1)
  2324.     K=K-6
  2325.     GOTO (12100,12200,12300,12400,12500,12600,12700,12800,
  2326.      1  12840,12860,12880),K
  2327. C
  2328. C
  2329. C  EXP
  2330. 12100    REAL=DEXP(REAL)
  2331.     GOTO 14000
  2332. C
  2333. C
  2334. C  ALOG
  2335. 12200    REAL=DLOG(REAL)
  2336.     GOTO 14000
  2337. C
  2338. C
  2339. C  DLOG10
  2340. 12300    REAL=DLOG10(REAL)
  2341.     GOTO 14000
  2342. C
  2343. C
  2344. C  DSQRT
  2345. 12400    IF (REAL.GE.0.D0) GOTO 12410
  2346. 12405    CALL ERRMSG (14)
  2347.     GOTO 89999
  2348. 12410    REAL=DSQRT (REAL)
  2349.     GOTO 14000
  2350. C
  2351. C
  2352. C  DSIN
  2353. 12500    REAL=DSIN(REAL)
  2354.     GOTO 14000
  2355. C
  2356. C
  2357. C  DCOS
  2358. 12600    REAL=DCOS(REAL)
  2359.     GOTO 14000
  2360. C
  2361. C
  2362. C  DTANH
  2363. 12700    REAL=DTANH(REAL)
  2364.     GOTO 14000
  2365. C
  2366. C
  2367. C  DATAN
  2368. 12800    REAL=DATAN(REAL)
  2369.     GOTO 14000
  2370. C
  2371. C ASIN
  2372. 12840    CONTINUE
  2373.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2374.     REAL=DASIN(REAL)
  2375.     GOTO 14000
  2376. C
  2377. C ACOS
  2378. 12860    CONTINUE
  2379.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2380.     REAL=DACOS(REAL)
  2381.     GOTO 14000
  2382. C
  2383. C TAN
  2384. 12880    CONTINUE
  2385.     IF(REAL.GT.1.570795)REAL=1.570795
  2386.     IF(REAL.LT. -1.570795) REAL = -1.570795
  2387. C CLAMP TO AVOID OVERFLOW
  2388.     REAL=DTAN(REAL)
  2389. C    GOTO 14000
  2390. C (GOTO NOT NEEDED IF THIS IS THE LAST FUNCTION)
  2391. 14000    DO 14010 I=1,8
  2392. 14010    STACK1(I,ST1PT-1)=EIGHT(I)
  2393.     GOTO 90000
  2394. C
  2395. C
  2396. C  INTEGER, HEXADECIMAL, OCTAL, AND MULTIPLE PRECISION
  2397. 15000    CONTINUE
  2398.     CALL CONTYP(STACK1,ST1PT-1,K2,2,RETCD2)
  2399.     GO TO(15010,89999),RETCD2
  2400.     STOP 15000
  2401. 15010    ST1TYP(ST1PT-1)=2
  2402.     GO TO 12000
  2403. C
  2404. C
  2405. C  EXIT
  2406. 89999    RETCD=2
  2407. 90000    ST2PT=ST2PT-1
  2408.     RETURN
  2409.     END
  2410. c -h- ce2a.fms    Fri Aug 22 13:00:17 1986    
  2411.     SUBROUTINE CE2A(LNIN,LNOUT)
  2412. C CONVERT ENCODED FORMULAS TO NORMAL ASCII
  2413. C NOTE: ONLY HAS TO HANDLE STANDARD NAMES AS A$5$ TYPE FORMS AND P# AND D# FORMS
  2414. C ARE NOT TRANSLATED TO PACKED ONES.
  2415.     CHARACTER*1 NAME(4),NUMBER(6)
  2416.     CHARACTER*1 LNIN,LNOUT
  2417.     CHARACTER*6 NUMBR6
  2418.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  2419.     DIMENSION LNIN(128),LNOUT(128)
  2420. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2421. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2422.     InTeGer*4 RRWACT,RCLACT
  2423. C    COMMON/RCLACT/RRWACT,RCLACT
  2424.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2425.      1  IDOL7,IDOL8
  2426. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2427. C     1  IDOL7,IDOL8
  2428.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2429. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2430.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2431. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2432. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2433. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2434.     InTeGer*4 KLVL
  2435. C    COMMON/KLVL/KLVL
  2436.     InTeGer*4 IOLVL,IGOLD
  2437. C    COMMON/IOLVL/IOLVL
  2438. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2439. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2440.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2441.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2442.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  2443.      3  k3dfg,kcdelt,krdelt,kpag
  2444. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2445. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2446. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2447. C    LOGICAL*2 L63,L192,L255,L127
  2448.     LOGICAL*4 L1,L2
  2449. C    InTeGer*4 I63,I192,I255,I127
  2450.     InTeGer*4 I63,I192,I127
  2451.     InTeGer*4 I1,I2
  2452. C    EQUIVALENCE(L127,I127)
  2453. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  2454.     EQUIVALENCE (I1,L1),(I2,L2)
  2455.     INTEGER*4 FNAM(25)
  2456.     character*4 fnmx(25)
  2457.     CHARACTER*1 FCHNM(4,25)
  2458.     equivalence(fnmx(1)(1:1),fnam(1),fchnm(1,1))
  2459. c    EQUIVALENCE(FNAM(1),FCHNM(1,1))
  2460.     save fnmx,i63,i192,i127
  2461.     DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
  2462.      1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
  2463.      2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
  2464.      3  'RND ','PMT','PVL','AVE','CHS'/
  2465. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  2466.     DATA I63/63/,I192/192/,I127/127/
  2467.     LI=1
  2468.     LO=1
  2469. C LI = INPUT LOCATION
  2470. C LO=OUTPUT LOCATION
  2471. 100    CONTINUE
  2472.     LCC=ICHAR(LNIN(LI))
  2473.     IF(LCC.NE.255)GOTO 200
  2474. C FIND BINARY PATTERNS TO USE
  2475.     I1=ICHAR(LNIN(LI+1))
  2476.     I2=IMASK(I1,I192)
  2477. C    L2=L1.AND.L192
  2478.     I1=IMASK(I1,I63)
  2479. C    L1=L1.AND.L63
  2480.     ID1=I1
  2481.     I1=ICHAR(LNIN(LI+2))
  2482.     I1=IMASK(I1,I127)
  2483. C    L1=L1.AND.L127
  2484.     ID2=I2*2+I1
  2485.     LI=MIN0(LI+3,109)
  2486. C DO MASKING TO GET BINARY COORDS
  2487.     CALL IN2AS(ID1,NAME)
  2488. C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
  2489.     IL2=ID2-1
  2490.     WRITE(NUMBR6(1:6),1000)IL2
  2491. C    ENCODE(6,1000,NUMBER)IL2
  2492. 1000    FORMAT(I6)
  2493. C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
  2494. C THROW OUT SPACES AND COPY THE REST.
  2495.     DO 202 N=1,4
  2496.     IF(ICHAR(NAME(N)).LE.32)GOTO 202
  2497.     LNOUT(LO)=NAME(N)
  2498.     LO=LO+1
  2499.     IF(LO.GT.110)GOTO 300
  2500. 202    CONTINUE
  2501.     DO 203 N=1,6
  2502.     IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
  2503. C IF 32 ISN'T SPACE, LOSE
  2504.     LNOUT(LO)=NUMBER(N)
  2505.     LO=LO+1
  2506.     IF(LO.GT.110)GOTO 300
  2507. 203    CONTINUE
  2508.     GOTO 300
  2509. C COPY MISC. CHARACTER
  2510. 200    CONTINUE
  2511.     II=ICHAR(LNIN(LI))
  2512.     IF(II.LT.230.OR.II.GT.254)GOTO 220
  2513. C FUNCTION NAME...
  2514.     II=II-229
  2515.     LNOUT(LO)=FCHNM(1,II)
  2516.     LNOUT(LO+1)=FCHNM(2,II)
  2517.     LNOUT(LO+2)=FCHNM(3,II)
  2518.     LI=LI+1
  2519.     LO=LO+3
  2520. C FILL IN ASCII FORM OF FUNCTION HERE...
  2521.     GOTO 300
  2522. 220    CONTINUE
  2523.     LNOUT(LO)=LNIN(LI)
  2524.     LO=LO+1
  2525.     LI=LI+1
  2526. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  2527. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  2528.     LO=MIN0(LO,110)
  2529.     DO 400 N=LO,110
  2530. 400    LNOUT(N)=char(0)
  2531.     DO 1 N=111,128
  2532. 1    LNOUT(N)=LNIN(N)
  2533. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  2534.     RETURN
  2535.     END
  2536. c -h- cmdmun.for    Fri Aug 22 13:00:17 1986    
  2537.     SUBROUTINE CMDMUN(LINE)
  2538. C COPYRIGHT (C) 1983-1991 GLENN AND MARY EVERHART
  2539. C ALL RIGHTS RESERVED
  2540. ccc
  2541. ccc junk VT100 escape sequence parsing except for arrow keys and
  2542. ccc PF2 since it's mostly not useful in MSDOS anyway.
  2543. ccc
  2544.     CHARACTER*1 LINE(120),LC,LINBUF(220),CW(134)
  2545. C    InTeGer*4 IOLVL,IGOLD
  2546.     EXTERNAL INDX
  2547. C    COMMON/IOLVL/IOLVL,IGOLD
  2548.     InTeGer*4 RRWACT,RCLACT
  2549. C    COMMON/RCLACT/RRWACT,RCLACT
  2550.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2551.      1  IDOL7,IDOL8
  2552. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2553. C     1  IDOL7,IDOL8
  2554.     Logical LEXIST
  2555.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2556. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2557.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2558. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2559. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2560. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2561.     InTeGer*4 KLVL
  2562. C    COMMON/KLVL/KLVL
  2563.     InTeGer*4 IOLVL,IGOLD
  2564. C    COMMON/IOLVL/IOLVL
  2565. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2566. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2567.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2568.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2569.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  2570.      3  k3dfg,kcdelt,krdelt,kpag
  2571. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2572. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2573. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2574. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2575. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2576.     Integer*4 FH
  2577.     Common/CONSFH/FH
  2578.     Integer Initd,UseDK,UseDF
  2579.     common/udfudk/usedf,usedk
  2580.     save initd
  2581.     Data Initd/0/
  2582. c Assume compilation with -h so this stays around
  2583.     If(Initd.ne.0)Goto 2408
  2584.     Initd=1
  2585.     UseDF=0
  2586.     UseDK=0
  2587. c Before inserting the DK: part, check that dk:AKA.CMD can be found.
  2588.     Inquire(File='AKA.CMD',Exist=Lexist)
  2589.     If(Lexist)UseDF=1
  2590.     If(LExist)goto 2408
  2591. C Inquire on login directory first; if file not there THEN look in DK:
  2592. c This allows one to avoid a system requestor for device DK
  2593.     Inquire(File='DK:AKA.CMD',EXIST=LEXIST)
  2594.     If(Lexist)UseDF=1
  2595.     IF(Lexist)UseDK=1
  2596. c Usedk = 1 if stuff is seen in dk:
  2597. c usedf = 1 if stuff found in default OR dk:
  2598. 2408    Continue
  2599.     ITERX=0
  2600. C ALLOW RESCAN OF READ-IN COMMANDS UP TO 10 TIMES.
  2601. 6501    CONTINUE
  2602.     ITERX=ITERX+1
  2603.     IF(ITERX.GT.10)RETURN
  2604.     LI=1
  2605. C ALLOW ARROWS OR OTHER SIMILAR KEYS TO BE RECOGNIZED
  2606.     LL=ICHAR(LINE(LI))
  2607. C ALLOW ! OR ESCAPE TO BE LEADIN FOR ESCAPE SEQUENCES
  2608.     IF(LL.EQ.155.OR.LL.EQ.33.OR.LL.EQ.27)GOTO 1000
  2609. C ALLOW % SPECIAL TREATMENT
  2610.     IF(ICHAR(LINE(1)).EQ.37)GOTO 7000
  2611.     IF(LINE(1).EQ.'^')IGOLD=IGOLD+1
  2612.     IF(LINE(1).EQ.'^')GOTO 7223
  2613. C IF WE SEE , COULB BE THAT ESC GOT EATEN BY VMS...
  2614.     IF(LINE(LI).EQ.'[')GOTO 1000
  2615. C CONVERT LOWER TO UPPER CASE
  2616.     NMX=120
  2617.     DO 41 N=1,120
  2618. C CHECK FOR DOUBLE QUOTE (34 DECIMAL). LEAVE L.C. IF SO
  2619.     NNN=ICHAR(LINE(N))
  2620.     IF(NNN.EQ.34)NMX=2
  2621. C IF WE SEE " CHARACTER THEN ONLY CONVERT 1ST 2 CHARACTERS TO U.C.
  2622.     if(n.gt.3)goto 41
  2623.     if(nnn.eq.64.or.nnn.eq.125.or.nnn.eq.36)nmx=1
  2624. C characters }, $, or @ in column 1 mean no messing with case...unix hack...
  2625. 41    CONTINUE
  2626.     JFED=0
  2627.     DO 1 N=1,NMX
  2628.     LL=ICHAR(LINE(N))
  2629.     IF(LL.GT.96.AND.LL.LT.123)LL=LL-32
  2630.     LINE(N)=CHAR(LL)
  2631.     IF(LINE(N).EQ.'_'.AND.LINE(N+1).EQ.'_')JFED=N
  2632. 1    CONTINUE
  2633.     IF(JFED.LE.0)GOTO 520
  2634. C IF __ SEEN (2 UNDERSCORES IN A ROW), CALL FRMEDT AFTER REMOVING THE __ FROM
  2635. C THE COMMAND LINE.
  2636.     DO 521 KKK=JFED,118
  2637.     LINE(KKK)=LINE(KKK+2)
  2638. 521    CONTINUE
  2639.     LINE(119)=Char(0)
  2640.     LINE(120)=Char(0)
  2641.     KKK=110
  2642.     CALL FRMEDT(LINE,KKK)
  2643. 520    CONTINUE
  2644.     IF(LINE(1).NE.'M')GOTO 2000
  2645. C    IF(LINE(1).NE.'M')RETURN
  2646.     LI=2
  2647.     GOTO 1000
  2648. 1000    CONTINUE
  2649. C HANDLE ESCAPE SEQUENCES
  2650. C ENCODE VT100 SEQUENCES HERE. MUST MODIFY FOR OTHERS.
  2651. C IF VMS PASSES 2 ESCS, PASS 1ST, TEST SECOND.
  2652. C NOTE CURSOR UP,DOWN, RIGHT, LEFT ARE CODED AS ESC A,B,C, OR D
  2653. C WITH POSSIBLE CRUFT BETW ESC AND THE LETTER.
  2654.     LL=ICHAR(LINE(LI+1))
  2655.     IF(LL.EQ.155.OR.LL.EQ.27)LI=LI+1
  2656.     LC=(LINE(LI+1))
  2657.     IF(LC.EQ.'['.OR.LC.EQ.'O')LC=(LINE(LI+2))
  2658.     IF(LC.NE.'?'.AND.LC.NE.'Q')GOTO 10
  2659. C MAKE PF2 MEAN HELP, JUST LIKE EDT
  2660. C FIX UP AMIGA HELP KEY ALSO TO MEAN HELP...
  2661.     LINE(LI)=CHAR(72)
  2662. C 72 = ASCII FOR 'H'
  2663.     LGGG=IGOLD+8
  2664.     IF(IGOLD.LE.0)GOTO 488
  2665.     LINE(LI+1)=CHAR((LGGG/10)+48)
  2666.     LINE(LI+2)=CHAR(MOD(LGGG,10)+48)
  2667. 488    CONTINUE
  2668. C    RETURN
  2669.     GOTO 2000
  2670. 10    CONTINUE
  2671. C HANDLE AUX KEYPAD KEYS AS INDIRECTS (FOR NOW)
  2672. C MAP ENTER KEY INTO AUX KEYPAD RANGE
  2673.     IF(LC.EQ.'M')LC='o'
  2674.     IF(LC.GE.'l'.AND.LC.LE.'y')GOTO 2650
  2675.     IF(LC.GE.'P'.AND.LC.LE.'S')GOTO 2100
  2676. C HANDLE INDIRECT CALLS AT 2100 FOR PF1 THRU PF4 IF AANY
  2677.     LL=ICHAR(LC)
  2678.     IF(LL.GE.48.AND.LL.LE.63)GOTO 2640
  2679.     LL=LL-65
  2680. C SUBTRACT ASCII A
  2681.     IF (LL.LT.0.OR.LL.GT.3)GOTO 2000
  2682. C ARROW KEYS HERE. ADJUST AND PASS THEM TO REST OF PROGRAM
  2683.     LK=LL
  2684.     IF(LL.EQ.3)LK=2
  2685.     IF(LL.EQ.2)LK=3
  2686.     LK=LK+49
  2687. C ADJUST FOR ASCII VALUE
  2688.     LINE(LI)=CHAR(LK)
  2689. C STASH NEW CELL IN.
  2690. C DON'T DISTURB GOLD STATUS ON MOTION OR ON HELP. ONLY ON INDIRECT
  2691. C COMMAND FILES.
  2692.     RETURN
  2693. C    GOTO 2000
  2694. 2640    CONTINUE
  2695. C AMIGA FUNCTION KEYS
  2696.     LL=LL-48+ICHAR('l')
  2697.     LC=CHAR(LL)
  2698. c Fix up as though VT100 function chars and go on
  2699. 2650    CONTINUE
  2700.     LL=ICHAR(LC)
  2701.     LL=LL-ICHAR('l')+ICHAR('A')
  2702. C MAPPING IS:
  2703. C  KEY    CHAR    AKx.CMD  x=
  2704. C  0    p    E
  2705. c  1    q    F
  2706. C  2    r    G
  2707. c  3    s    H
  2708. c  4    t       I
  2709. c  5    u    J
  2710. c  6    v    K
  2711. c  7    w    L
  2712. c  8    x    M
  2713. c  9    y    N
  2714. c  ,    l    A
  2715. c  -    m    B
  2716. c  .    n    C
  2717. c ENTER o    D
  2718.     LC=CHAR(LL)
  2719.     LINE(1)=CHAR(64)
  2720. C 64 IS ASCII @ CHARACTER
  2721.     IVL=0
  2722. C INCLUDE "DK:" IN STRING
  2723. c
  2724.     If(UseDF.eq.0) Goto 7223
  2725.     If(UseDK.eq.0) Goto 2099
  2726.     LINE(2)='D'
  2727.     LINE(3)='K'
  2728.     LINE(4)=':'
  2729.     IVL=3
  2730. 2099    Continue
  2731.     LINE(2+IVL)='A'
  2732.     LINE(3+IVL)='K'
  2733.     GOTO 2600
  2734. 2100    CONTINUE
  2735. C GENERATE INDIRECT FILE CALLS FROM PF1, PF3, PF4 KEYS IF ANY
  2736. C (THESE GIVE LETTERS P, R, OR S)
  2737.     LINE(1)=CHAR(64)
  2738.     IVL=0
  2739.     If(UseDF.eq.0) Goto 7223
  2740.     If(UseDK.eq.0) Goto 2098
  2741.     LINE(2)='D'
  2742.     LINE(3)='K'
  2743.     LINE(4)=':'
  2744.     IVL=3
  2745. 2098    Continue
  2746.     LINE(2+IVL)='K'
  2747.     LINE(3+IVL)='Y'
  2748. 2600    CONTINUE
  2749.     LINE(4+IVL)=LC
  2750.     IF(IGOLD.LE.0)GOTO 7202
  2751. C GOLD ADDS EXTRA A,B,C,D,E,... ETC. AFTER FILENAME
  2752.     LINE(5+IVL)=CHAR(64+IGOLD)
  2753.     IVL=IVL+1
  2754. C ADD EXTRA LETTER FOR GOLDED COMMANDS
  2755. 7202    CONTINUE
  2756.     LINE(5+IVL)='.'
  2757.     LINE(6+IVL)='C'
  2758.     LINE(7+IVL)='M'
  2759.     LINE(8+IVL)='D'
  2760.     LINE(9+IVL)=char(0)
  2761. C GENERATE @KYP, @KYR, OR @KYS COMMAND ON PF1, PF3, PF4
  2762. 2000    CONTINUE
  2763.     IGOLD=0
  2764.     RETURN
  2765. 7000    CONTINUE
  2766. C PROCESS %%% FORMS
  2767.     I1=INDX(LINE(2),37)
  2768. C IF I1 IS 1, THEN WE JUST HAVE %% AND THERE'S NOTHING TO DUMP TO
  2769. C THE SCREEN. OTHERWISE DUMP IT OUT HERE..
  2770.     I1=I1+1
  2771.     IF(I1.LE.2.OR.I1.GT.80)GOTO 7002
  2772.     II1=I1-1
  2773.     IV=II1-1
  2774.     CALL SWRT(LINE(2),IV)
  2775. 7301    FORMAT(80A1,60A1)
  2776. 7002    CONTINUE
  2777.     IF(I1.GT.80)RETURN
  2778. C COPY WHATEVER NEEDS TO BE COPIED TO LINBUF
  2779.     DO 7003 II=1,80
  2780. 7003    LINBUF(II)=char(0)
  2781.     I2=INDX(LINE(I1+1),37)
  2782.     IF(I2.GT.80)RETURN
  2783.     I2=I2+I1
  2784.     I1=I1+1
  2785.     II2=I2-1
  2786.     II=0
  2787.     IF(II2.LT.I1)GOTO 7540
  2788.     DO 7004 LL=I1,II2
  2789.     II=II+1
  2790. 7004    LINBUF(II)=LINE(LL)
  2791. 7540    CONTINUE
  2792.     IF(I2.GT.80)RETURN
  2793. C IF LINE(I2+1) HAS & THEN CLOSE FILE RIGHT HERE AND BUG OFF
  2794.     IF(LINE(I2+1).NE.'&')GOTO 8005
  2795.     CLOSE (IOLVL)
  2796.     IOLVL=11
  2797.     LINE(I2+1)='\'
  2798. 8005    CONTINUE
  2799. C SEE IF LINE(I2+1) CONTAINS A ?
  2800.     IF(LINE(I2+1).NE.'?'.AND.LINE(I2+1).NE.'\')GOTO 7005
  2801. C HAVE TO READ IN USER'S LINE HERE... READ OFF UNIT 5 ALWAYS...
  2802.     LX=II+1
  2803. c    rewind 11
  2804. c    If(FH.NE.0)goto 9201
  2805. c    READ(11,7301,END=7035,ERR=7035)(LINBUF(II),II=LX,120)
  2806. c    rewind 11
  2807. c    Goto 9202
  2808. c9201    Continue
  2809. c read in main window
  2810.     Call Getttl(CW)
  2811.     If(ichar(cw(1)).eq.26.or.
  2812.      1  ichar(cw(1)).eq.28)goto 7035
  2813. c filter so funny chars are treated as eof... ctl Z or ctl \ are eof.
  2814.     KK=1
  2815. c copy to Linbuf array (as much as fits, anyway
  2816.     Do 9203 II=LX,120
  2817.     Linbuf(II)=CW(KK)
  2818.     KK=KK+1
  2819. 9203    Continue
  2820. c9202    Continue
  2821. c For AMIGA we use lun 11 for console, both input and output,
  2822. c for all commands except normal sheet operation (e.g. help etc.)
  2823. C NOW SEE IF LINBUF(LX) IS EITHER A \ CHAR OR ANY CONTROL CHARACTER
  2824.     LC=LINBUF(LX)
  2825.     IF(LINE(I2+1).EQ.'\'.OR.LINE(I2+1).EQ.'!')GOTO 7005
  2826.     IF(IOLVL.EQ.11)GOTO 7005
  2827. C IF WE SEE ANYTHING EXCEPT A CONTROL CHAR OR \, REWIND THE FILE...
  2828. C THIS ALLOWS US TO HAVE A SORT OF "ENTER MODE" AND A "COMMAND MODE"
  2829. C A LA SUPERCALC ETC.
  2830.     IF(LC.NE.'\'.AND.LC.GT.CHAR(32))REWIND IOLVL
  2831. C COMMENT OUT ANY TERMINAL COMMAND
  2832.     IF(LC.EQ.'\'.OR.LC.EQ.'!'.OR.LC.LE.CHAR(32))LINBUF(1)='*'
  2833.     GOTO 7005
  2834. 7035    CONTINUE
  2835. C RECOVER AFTER CTL-Z ON EXPECTED INPUT.
  2836. C    REWIND 5
  2837.     LINBUF(1)='*'
  2838.     CLOSE (IOLVL)
  2839. c    IF(IOLVL.EQ.11)OPEN(11,FILE='CON:40/150/300/40/Analy Command')
  2840.     IOLVL=11
  2841. 7005    CONTINUE
  2842.     DO 7006 II=1,120
  2843. 7006    LINE(II)=LINBUF(II)
  2844.     GOTO 6501
  2845. C ALLOW RESCAN OF COMMAND LINE AFTER READ-IN.
  2846. C    RETURN
  2847. C RETURN AFTER BUMPING IGOLD. COMMENT OUT CMD
  2848. 7223    CONTINUE
  2849.     LINE(1)='*'
  2850.     RETURN
  2851.     END
  2852. c -h- cmnd.f40    Fri Aug 22 13:00:17 1986    
  2853.     SUBROUTINE CMND(RETCD)
  2854. C COPYRIGHT (C) 1983 GLENN EVERHART
  2855. C ALL RIGHTS RESERVED
  2856. C 60=MAX REAL ROWS
  2857. C 301=MAX REAL COLS
  2858. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  2859. C VBLS AND TYPE DIMENSIONED 60,301
  2860. C   ***************************************************
  2861. C   *                                                 *
  2862. C   *         SUBROUTINE  CMND                        *
  2863. C   *                                                 *
  2864. C   ***************************************************
  2865. C
  2866. C
  2867. C  UPON ENTRANCE, NONBLK POINT TO THE "*" IN LINE
  2868. C  INDICATING A COMMAND.  THIS ROUTINE DETERMINES WHICH COMMAND
  2869. C  IS DESIRED AND CALLS THE APPROPRIATE SUBROUTINE.
  2870. C
  2871. C  RETCD:
  2872. C  1=NORMAL
  2873. C  2=BYPASS NEXT READ BECAUSE READ COMMAND HAS BEEN EXECUTED
  2874. C     TO CHANGE LINE(80)
  2875. C  3=ERROR, SO GO TO 1000 TO SET LEVEL=1
  2876. C
  2877. C
  2878. C MODIFY CLASSES: M1
  2879. C
  2880.  
  2881. C
  2882. C   CMND CALLS
  2883. C
  2884. C  AT      TO PROCESS A FILE OF CALC COMMANDS
  2885. C  BASCNG  TO CHANGE THE DEFAULT BASE FOR CONSTANTS
  2886. C  CLOSE   CLOSE FILE OF CALC COMMANDS
  2887. C  DECLR   DECLARE VAIABLES TO BE A CERTAIN DATA TYPE
  2888. C  ERRMSG  PRINTS ERROR MESSAGES
  2889. C  EXIT    RETURN TO OPERATING SYSTEM
  2890. C  GETNNB  GETS NEXT NON-BLANK FROM LINE(80)
  2891. C  STRCMP  LOOKS FOR A SPECIFIED STRING IN LINE(80)
  2892. C  ZERO    ZEROES ALL VARIABLES
  2893. C  ZNEG    TO SEE IF A VARIABLE HAS POSITIVE VALUE
  2894. C
  2895. C
  2896. C
  2897. C  CMND IS CALLED BY CALC WHO HAS IDENTIFIED THE '*'
  2898. C  INDICATING A COMMAND IS DESIRED.
  2899. C
  2900. C
  2901. C
  2902. C
  2903. C   VARIABLE      USE
  2904. C
  2905. C
  2906. C  CCHAR      TEMPORARILY HOLDS A SINGLE CHARACTER.
  2907. C  DIGITS    HOLDS ASCII REPRESENTATION OF DIGITS.
  2908. C  I         TEMPORARY INDEX.
  2909. C  ID        ARGUMENT FOR SUBROUTINE DECLR. INDICATES
  2910. C            A PARTICULAR DATA TYPE.
  2911. C  IPT       POINTER FOR LINE(80).
  2912. C  ITCNTV    0 IF NO ITERATION. IF POSITIVE, INDEX
  2913. C            OF VARIABLE USED TO CONTROL ITERATION ON THAT LEVEL.
  2914. C  KIND(15)  HOLDS FIRST LETTER OF ALL LEGAL COMMANDS.
  2915. C  LEVEL     HOLDS LOGICAL I/O UNIT WHERE NEXT COMMAND COMES FROM.
  2916. C  LINE(80)  HOLDS COMMAND LINE.
  2917. C  NONBLK    POINTER FOR LINE(80).
  2918. C  RETCD     HOLDS RETURN CODE.
  2919. C  RETCD2    HOLDS RETURN CODE.
  2920. C  VIEWSW    VIEW SWITCH:
  2921. C            0 = OFF
  2922. C            1 = DISPLAY COMMAND LINES
  2923. C            2 = DISPLAY VALUE OF EXPRESSIONS
  2924. C            3 = DISPLAY ALL
  2925. C
  2926. C
  2927. C
  2928. C    SUBROUTINE CMND(RETCD)
  2929. C
  2930. C
  2931. C    EXTERNAL INDX
  2932.     InTeGer*4 LEVEL,NONBLK,LEND
  2933.     InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
  2934. C    InTeGer*4 IOLVL
  2935. C    COMMON/IOLVL/IOLVL
  2936.     InTeGer*4 ZNEG,ITCNTV(6)
  2937. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2938. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2939.     InTeGer*4 RRWACT,RCLACT
  2940. C    COMMON/RCLACT/RRWACT,RCLACT
  2941.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2942.      1  IDOL7,IDOL8
  2943. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2944. C     1  IDOL7,IDOL8
  2945.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2946. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2947.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2948. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2949. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2950. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2951.     InTeGer*4 KLVL
  2952. C    COMMON/KLVL/KLVL
  2953.     InTeGer*4 IOLVL,IGOLD
  2954. C    COMMON/IOLVL/IOLVL
  2955. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2956. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2957.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2958.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2959.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  2960.      3  k3dfg,kcdelt,krdelt,kpag
  2961. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2962. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2963. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2964.     Character*1 WRK(130)
  2965.     CHARACTER*1 WRKX(130),WRK2X(130)
  2966.     CHARACTER*1 WRK2(128)
  2967.     CHARACTER*35 CWRK,CWRKX,CWRK2
  2968.     CHARACTER*11 CWRK2B
  2969.     Character*1 wrk2b(11)
  2970.     EQUIVALENCE(CWRK2B(1:1),WRK2(1),wrk2b(1))
  2971.     EQUIVALENCE(CWRK2(1:1),WRK2(1))
  2972.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  2973. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  2974. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  2975. c    EQUIVALENCE(WRK(1),WRKX(1))
  2976.     EQUIVALENCE(WRK2(1),WRK2X(1))
  2977.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  2978.     Real*8 VAVBLS(3,27)
  2979.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  2980.     InTeGer*4 TYPE(1,2),VLEN(9)
  2981.     REAL*8 XAC,XVBLS(1,1)
  2982.     INTEGER*4 JVBLS(2,1,1)
  2983.     EQUIVALENCE(XAC,AVBLS(1,27))
  2984.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  2985.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  2986.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  2987.     CHARACTER*1 FVLD(1,1)
  2988.     COMMON/FVLDC/FVLD
  2989. C
  2990.     CHARACTER*1  LINE(80),KIND(23),ASCII(4),DEC(6),HEX(2),INT(6),
  2991.      ;  M10(2),M8(1),M16(2),OCTAL(4),REAL(3),CCHAR
  2992.     CHARACTER*1 DIGITS(16,3)
  2993. C
  2994.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  2995.     COMMON /ITERA/ITCNTV
  2996.     COMMON /DIGV/ DIGITS
  2997.     character*127 c11wrk
  2998. C
  2999.     save kind,ascii,dec,hex,m19,m8,m16,octal,real
  3000.     DATA KIND
  3001.      1/'@','A','B','C','D','E','H','I','M','N','O','R','S','V','Z'
  3002.      2,'P','W','G','Q','F','J','X','U'/
  3003. C NOTE PWGQFJX ADDED BY GCE FOR ANALYTICALC INTERFACE.
  3004. C  FREE: K,U,Y, + SPECIAL CHARACTERS (LIKE .,;'"#$%^, ETC.)
  3005.     DATA  ASCII/'S','C','I','I'/,  DEC/'E','C','I','M','A','L'/
  3006.     DATA  HEX/'E','X'/, INT/'N','T','E','G','E','R'/
  3007.     DATA  M10/'1','0'/,  M8/'8'/
  3008.     DATA  M16/'1','6'/
  3009.     DATA  OCTAL/'C','T','A','L'/
  3010.     DATA  REAL/'E','A','L'/
  3011. C    DATA WRKX/130*0/,WRK2X/130*0/
  3012. C
  3013. C
  3014. C
  3015. C PICK UP NON-BLANK CHARACTER AFTER '*'
  3016.     RETCD=1
  3017.     CALL GETNNB(IPT,RETCD2)
  3018.     GOTO(2,4),RETCD2
  3019.     STOP 2
  3020. 2    NONBLK=IPT
  3021. C NONBLK POINTS TO 1ST NONBLANK CHARACTER AFTER *
  3022. C
  3023.     DO 3 I=1,23
  3024.     IF (LINE(NONBLK).EQ.KIND(I)) GOTO 6
  3025. 3    CONTINUE
  3026. C
  3027. C
  3028. C UNIDENTIFIED COMMAND
  3029. 4    GOTO 995
  3030. C
  3031. C
  3032. C
  3033. C GO TO DIFFERENT SECTIONS ON THE BASIS OF THE FIRST CHARACTER
  3034. C OF THE COMMAND.
  3035. 6    GOTO (10,20,30,1000,40,50,60,70,80,90,100,110,50,
  3036.      1  130,140,210,220,250,290,330,360,480,780),I
  3037.     STOP 6
  3038. C
  3039. C
  3040. C
  3041. C
  3042. C **************************************************
  3043. C *****    *@  INDIRECT COMMAND PROCESSING    ******
  3044. C **************************************************
  3045. 10    CALL AT(RETCD)
  3046.     GOTO (1000,999),RETCD
  3047.     STOP 10
  3048. C
  3049. C
  3050. C
  3051. C
  3052. C **************************************************
  3053. C ******      *A     DECLARE TYPE ASCII       ******
  3054. C **************************************************
  3055. 20    CALL STRCMP (ASCII,4,RETCD2)
  3056.     ID=1
  3057.     GOTO (200,995),RETCD2
  3058.     STOP 20
  3059. C
  3060. C
  3061. C
  3062. C
  3063. C **************************************************
  3064. C ******       *B      BASE DEFAULT          *******
  3065. C **************************************************
  3066. 30    CONTINUE
  3067.     CALL BASCNG(RETCD2)
  3068.     write(c11wrk,34)based
  3069.     c11wrk(20:20)=char(13)
  3070.     c11wrk(21:21)=char(10)
  3071.     IF(VIEWSW.NE.0)call vwrt(c11wrk,21)
  3072. 34    FORMAT(' DEFAULT BASE IS ',I2)
  3073.     GO TO (1000,999),RETCD2
  3074.     STOP 30
  3075. C
  3076. C
  3077. C
  3078. C
  3079. C ********************************************************
  3080. C **   *C   COMMENT, JUST RETURN (VIA STATEMENT 1000)   **
  3081. C ********************************************************
  3082. C
  3083. C
  3084. C
  3085. C **************************************************
  3086. C *******     *D     DECLARE TYPE DECIMAL    *******
  3087. C **************************************************
  3088. 40    CALL STRCMP(DEC,6,RETCD2)
  3089.     ID=2
  3090.     GOTO (200,995),RETCD2
  3091.     STOP 40
  3092. C
  3093. C
  3094. C **************************************************
  3095. C **********          *E   EXIT             ********
  3096. C **************************************************
  3097. 50    CONTINUE
  3098. C SET RETCD=4 ON EXIT IF EXIT COMMAND, SO CALC RETURNS TO ITS CALLER.
  3099.     IF (LEVEL.EQ.1) RETCD=4
  3100.     IF (LEVEL.EQ.1) RETURN
  3101. C    IF (LEVEL.EQ.1) CALL EXIT
  3102.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  3103.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  3104. C ITERATION VARIABLE IS POSITIVE SO EXECUTE FILE AGAIN
  3105.     REWIND LEVEL
  3106.     GO TO 1000
  3107. C
  3108. C NOTE THAT WHEN EXITING A LEVEL THAT WAS ITERATED, ITCNTV
  3109. C IS NOT SET TO ZERO. THIS REQUIRES THAT WHEN ENTERED AT
  3110. C SUBROUTINE 'AT' AND ITERATION IS NOT DESIRED, THAT ITCNTV
  3111. C MUST BE SET TO ZERO THERE
  3112.  
  3113. 55    CLOSE(LEVEL)
  3114.     LEVEL=LEVEL-1
  3115. 59    GOTO 1000
  3116. C
  3117. C
  3118. C
  3119. C
  3120. C
  3121. C **************************************************
  3122. C * *H DECLARE VARIABLES TO BE OF TYPE HEXADECIMAL *
  3123. C **************************************************
  3124. 60    CALL STRCMP (HEX,2,RETCD2)
  3125.     ID=3
  3126.     GOTO (200,995),RETCD2
  3127.     STOP 60
  3128. C
  3129. C
  3130. C
  3131. C
  3132. C **************************************************
  3133. C * *I DECLARE VARIABLE TO BE OF TYPE INTEGER (*4) *
  3134. C **************************************************
  3135. 70    CALL STRCMP (INT,6,RETCD2)
  3136.     ID=4
  3137.     GOTO (200,995),RETCD2
  3138.     STOP 70
  3139. C
  3140. C
  3141. C **************************************************
  3142. C *  *M  DECLARE VARIABLE TO BE MULTIPLE PRECISION *
  3143. C **************************************************
  3144. 80    CALL STRCMP (M10,2,RETCD2)
  3145.     ID=5
  3146.     GOTO (200,84),RETCD2
  3147.     STOP 80
  3148. C
  3149. C
  3150. C  SEE IF MULTIPLE PRECISION IS OCTAL
  3151. 84    CALL STRCMP (M8,1,RETCD2)
  3152.     ID=6
  3153.     GOTO (200,88),RETCD2
  3154.     STOP 84
  3155. C
  3156. C
  3157. C  SEE IF MULTIPLE PRECISION HEXADECIMAL
  3158. 88    CALL STRCMP (M16,2,RETCD2)
  3159.     ID=7
  3160.     GOTO (200,995),RETCD2
  3161.     STOP 88
  3162. C
  3163. C
  3164. C
  3165. C
  3166. C ************************************************************
  3167. C **  *N SUPPRESS PRINTING OF VARIABLES WHEN VALUES CHANGE  **
  3168. C ************************************************************
  3169. 90    VIEWSW=1
  3170.     GOTO 1000
  3171. C
  3172. C
  3173. C
  3174. C
  3175. C **************************************************
  3176. C ***  *O  DECLARE VARIABLE TO BE OF TYPE OCTAL  ***
  3177. C **************************************************
  3178. 100    CALL STRCMP (OCTAL,4,RETCD2)
  3179.     ID=8
  3180.     GOTO (200,995),RETCD2
  3181.     STOP 100
  3182. C
  3183. C
  3184. C
  3185. C
  3186. C
  3187. C **************************************************
  3188. C ***********     *R ENCOUNTERED       *************
  3189. C **************************************************
  3190. C
  3191. C  *R    SEE IF A REAL DECLARATION
  3192. 110    CALL STRCMP (REAL,3,RETCD2)
  3193.     ID=9
  3194.     GOTO (200,114),RETCD2
  3195.     STOP 110
  3196. C
  3197. C
  3198. C  OTHERWISE ASSUME A READ IS REQUIRED
  3199. 114    IF (LEVEL.NE.1) GOTO 117
  3200. c    Rewind 11
  3201.     c11wrk=char(13) // char(10) // 'Calr>'
  3202.     call vwrt(c11wrk,7)
  3203. c    WRITE(11,116)
  3204. c    Rewind 11
  3205.     GOTO 118
  3206. c116    FORMAT(' CALR>',$)
  3207. 117    Continue
  3208. c    Rewind 11
  3209.     c11wrk=char(13) // char(10) // 'Calc0>'
  3210.     c11wrk(7:7)=char(48+level)
  3211.     call vwrt(c11wrk,8)
  3212. cc    WRITE (11,119) LEVEL
  3213. c    Rewind 11
  3214. 119    FORMAT (' CALC<',I1,'>',$)
  3215. 118    Continue
  3216. c    Rewind 11
  3217.     Call vget(line,80)
  3218. c    READ (11,115,END=1000,ERR=990) LINE
  3219. c    Rewind 11
  3220. 115    FORMAT (80A1)
  3221. C
  3222. C  NOTE THAT IF <CR> IS HIT AS THE ONLY INPUT, RETURN IS NORMAL
  3223. C  AND PROCESSING CONTINUES ON LEVEL (RETCD=2)
  3224.     RETCD=2
  3225.     GOTO 1000
  3226. C
  3227. C
  3228. C
  3229. C
  3230. C
  3231. C ************************************************************
  3232. C ***  *V ACTIVATE PRINTING OF VARIABLE WHEN VALUES CHANGE ***
  3233. C ************************************************************
  3234. 129    NONBLK=IPT
  3235. 130    CALL GETNNB(IPT,RETCD2)
  3236.     GO TO (129,132),RETCD2
  3237.     STOP  130
  3238. 132    CCHAR=LINE(NONBLK)
  3239.     IF(CCHAR.NE.DIGITS(10,1))GO TO 134
  3240. C
  3241. C  *VIEW 0 ENCOUNTERED
  3242.     VIEWSW=0
  3243.     GO TO 1000
  3244. 134    IF(CCHAR.NE.DIGITS(1,1))GO TO 136
  3245. C
  3246. C *VIEW 1 ENCOUNTERED
  3247.     VIEWSW=1
  3248.     GO TO 1000
  3249. 136    IF(CCHAR.NE.DIGITS(2,1))GO TO 138
  3250.     VIEWSW=2
  3251.     GO TO 1000
  3252. 138    VIEWSW=3
  3253.     GOTO 1000
  3254. C
  3255. C
  3256. C
  3257. C
  3258. C **************************************************
  3259. C **********   *Z   ZERO OUT ALL VARIABLES  ********
  3260. C **************************************************
  3261. 140    CALL ZERO
  3262.     GOTO 1000
  3263. C
  3264. C
  3265. C
  3266. C
  3267. C
  3268. C MAKE DECLARATIONS
  3269. 200    CALL DECLR(ID,RETCD2)
  3270.     GO TO(1000,999),RETCD2
  3271.     STOP 200
  3272. C
  3273. C
  3274. C
  3275. C
  3276. C
  3277. C **** ERROR PROCESSING ****
  3278. C
  3279. 990    I=27
  3280.     REWIND LEVEL
  3281.     GO TO 998
  3282. 995    I=3
  3283. 998    CALL ERRMSG(I)
  3284. 999    RETCD=3
  3285. 1000    CONTINUE
  3286.     RETURN
  3287. C
  3288. C P COMMAND - SET PLACEMENT OF PHYSICAL POSN IN SHEET
  3289. C *P WILL PROMPT FOR INPUTS OF LOCATIONS.
  3290. C
  3291. 210    CONTINUE
  3292. C
  3293.     RETCD=1
  3294.     CALL CMND2(RETCD,1)
  3295.     RETURN
  3296. C W COMMAND - WRITE % TO CURRENT PHYSICAL LOC IN SHEET. USE E32.25
  3297. C FORMAT.
  3298. C  DOES NOT PROMPT. THEREFORE, IF USED INSIDE SPREADSHEET, HAS THE
  3299. C  EFFECT OF CONVERTING CURRENT CELL'S FORMULA TO A LITERAL NUMBER
  3300. C  AND FREEZING IT THAT WAY. THEREFORE A FORMULA CONTAINING *W WILL
  3301. C  NORMALLY ONLY EXECUTE THE *W ONCE (AFTERWARDS BEING OVERWRITTEN).
  3302. C
  3303. 220    CONTINUE
  3304.     RETCD=1
  3305.     CALL CMND2(RETCD,2)
  3306. C
  3307.     RETURN
  3308. C
  3309. C *G SEEN.
  3310. C THE SYNTAX OF *G IS *G V1,V2 WHICH WILL GET VALUE OF VBLS(G1,G2)
  3311. C  AND LOAD IT INTO %. THE DIMENSIONS ARE CLAMPED TO LEGAL BOUNDS
  3312. C  AND TYPE=4 MEANS USE INTEGER, TYPE=2 CONVERTS VARIABLES TO
  3313. C  INTEGER. CALLS VARSCN TO DO THIS STUFF.
  3314. C  THIS GIVES A MEASURE OF INDIRECTION.
  3315. 250    CONTINUE
  3316.     RETCD=1
  3317. C SAY ALL'S WELL.
  3318.     CALL CMND2(RETCD,3)
  3319. C
  3320.     RETURN
  3321. C
  3322. C *Q QUERY DATABASE COMMAND
  3323. C
  3324. C
  3325. 290    CONTINUE
  3326.     RETCD=1
  3327.     CALL CMND2(RETCD,4)
  3328. C
  3329.     RETURN
  3330. C
  3331. C *F LABEL  GOTO LABEL COMMAND (CONDITIONAL)
  3332. C
  3333. C
  3334. C THE SYNTAX OF THE *F COMMAND IS :
  3335. C  *F LABEL
  3336. C  WITH THE OPERATION OF LOCATING A LINE BEGINNING WITH THE
  3337. C  STRING "*CLABEL" (SO IT IS PASSED OVER BY NORMAL CALC
  3338. C  PROCESSING). THE INPUT FILE ON IOLVL IS REWOUND AND
  3339. C  SCANNING GOES TO THE EOF OR UNTIL THE STRING IS FOUND.
  3340. C  RETCD=2 IF NO SUCH LABEL IS FOUND.
  3341. C
  3342. C  AS A FURTHER AID, IF THE % VARIABLE IS 0 OR NEGATIVE, THE
  3343. C  COMMAND IS IGNORED.
  3344. 330    CONTINUE
  3345.     RETCD=1
  3346.     CALL CMND2(RETCD,5)
  3347. C
  3348.     RETURN
  3349. C
  3350. C *J LABEL - JUST LIKE *F LABEL BUT ON CALC'S COMMAND FILES.
  3351. C I.E., FINDS A LINE STARTING WITH *CLABEL
  3352. C (NOTE IT STARTS FROM START OF FILE AND DOES THIS ONLY IF % IS POSITIVE).
  3353. C ITERATION OF COMMAND FILES REMAINS UNDER NORMAL CONTROL.
  3354. 360    CONTINUE
  3355.     RETCD=1
  3356.     CALL CMND2(RETCD,6)
  3357.     RETURN
  3358. C *X COMMAND
  3359. C  XC FILESPEC CELLNAME
  3360. C    READS FILESPEC AS A SAVED SPEADSHEET (NUMERIC OR FORMULA)
  3361. C  AND LOADS ITS VALUE INTO CURRENT CELL AND % ACCUMULATOR. DOES
  3362. C  NOT LOAD FORMULA UNLESS F SEEN. THUS 2 VARIANTS:
  3363. C   *XF FILESPEC CELLNAME    LOAD FORMULA AND VALUE
  3364. C   *XV FILESPEC CELLNAME    LOAD VALUE
  3365. C NOTE ANY CHARACTER AFTER *X THAT ISN'T "F" IS EQUIVALENT TO V FOR EASY USE.
  3366. 480    CONTINUE
  3367.     RETCD=1
  3368.     CALL CMND2(RETCD,7)
  3369.     RETURN
  3370. C *U FUNCTION ARGS
  3371. C HANDLE USER FUNCTION CALL...
  3372. 780    CONTINUE
  3373.     RETCD=1
  3374. C PASS LINE AND ARGS TO SUBROUTINE TO PARSE (EXTERNALIZE THE WORK)
  3375. C COMMON /V/ HAS DATA NEEDED FOR ARGUMENTS...
  3376.     CALL USRFCT(LINE,RETCD,WRK2)
  3377. C IF RETCD CHANGES IN USRFCT THIS ALLOWS ERROR CODES BACK.
  3378.     RETURN
  3379.     END
  3380. c -h- cmnd2.f40    Fri Aug 22 13:00:17 1986    
  3381.     SUBROUTINE CMND2(RETCD,I)
  3382. C COPYRIGHT (C) 1983 GLENN EVERHART
  3383. C ALL RIGHTS RESERVED
  3384. C
  3385. C EXTRA ROUTINES MOVED HERE FROM INSIDE CMND SO THAT THEY CAN BE OVERLAIN IN
  3386. C 256K VERSION TO GAIN A GREAT DEAL OF SPACE.
  3387.     INCLUDE aparms.inc
  3388.     EXTERNAL INDX
  3389.     InTeGer*4 LEVEL,NONBLK,LEND
  3390.     InTeGer*4  RETCD,VIEWSW,BASED
  3391. C    InTeGer*4 IOLVL,retcd2
  3392. C    COMMON/IOLVL/IOLVL
  3393.     InTeGer*4 ZNEG,ITCNTV(6)
  3394. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3395. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3396.     InTeGer*4 RRWACT,RCLACT
  3397. C    COMMON/RCLACT/RRWACT,RCLACT
  3398.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  3399.      1  IDOL7,IDOL8
  3400. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  3401. C     1  IDOL7,IDOL8
  3402.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  3403. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3404.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3405. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3406. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  3407. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  3408.     InTeGer*4 KLVL,ierror
  3409. C    COMMON/KLVL/KLVL
  3410.     InTeGer*4 IOLVL,IGOLD
  3411. C    COMMON/IOLVL/IOLVL
  3412. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  3413. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  3414.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  3415.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  3416.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  3417.      3  k3dfg,kcdelt,krdelt,kpag
  3418. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  3419. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  3420. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  3421.     CHARACTER*1 WRK2(128),LETA
  3422.     CHARACTER*35 CWRK,CWRKX,CWRK2
  3423.     CHARACTER*50 CWRK50
  3424.     EQUIVALENCE (CWRK50(1:1),CWRK(1:1))
  3425.     CHARACTER*11 CWRK2B
  3426.     Character*1 wrk2b(11)
  3427.     CHARACTER*1 WRKX(130),WRK2X(130)
  3428.     Character*1 WRK(128)
  3429.     EQUIVALENCE(CWRK2B,WRK2(1),Wrk2b(1),Cwrk2)
  3430. c    EQUIVALENCE(CWRK2,WRK2(1))
  3431.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  3432. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  3433. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  3434. c    EQUIVALENCE(WRK(1),WRKX(1))
  3435.     EQUIVALENCE(WRK2(1),WRK2X(1))
  3436.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  3437.     Real*8 VAVBLS(3,27)
  3438.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  3439.     InTeGer*4 TYPE(1,2),VLEN(9)
  3440.     REAL*8 XAC,XVBLS(1,1),xyval
  3441.     INTEGER*4 JVBLS(2,1,1)
  3442.     EQUIVALENCE(XAC,AVBLS(1,27))
  3443.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  3444.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  3445.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  3446.     CHARACTER*1 FVLD(1,1)
  3447.     COMMON/FVLDC/FVLD
  3448. C    character*1 cchar
  3449.     CHARACTER*1  LINE(80)
  3450.     CHARACTER*1 DIGITS(16,3)
  3451. C
  3452.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  3453.     COMMON /ITERA/ITCNTV
  3454.     COMMON /DIGV/ DIGITS
  3455. C I ARGUMENT SELECTS COMMAND.
  3456. C 1 = *P
  3457. C 2 = *W
  3458. C 3 = *G 
  3459. C 4 = *Q
  3460. C 5 = *F
  3461. C 6 = *G
  3462. C 7 = *X
  3463.     IF(I.NE.1)GOTO 7000
  3464. C *P COMMANDS
  3465. C IF THE COMMAND IS *P VAR THEN SET TO VARIABLE LOCATION.
  3466.     KK1=3
  3467.     KK2=20
  3468.     IF(LINE(3).EQ.'@')GOTO 217
  3469. C ONLY LOOK IN COLS 3-20. COLUMNS 1,2 ARE THE *W COMMAND.
  3470.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3471.     IF(IVLD.NE.0)GOTO 216
  3472.     GOTO 218
  3473. 217    CONTINUE
  3474. C ALLOW *W@V1,V2 TO GOTO LOCATION OF V1,V2 (COL,ROW)
  3475. C  THIS ALLOWS PROGRAMMED ACCESS TO VARIABLES.
  3476.     L1=4
  3477.     L2=60
  3478.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3479.     IF(IVLD1.EQ.0)GOTO 1000
  3480.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3481.     IF(TYPE(1,1).EQ.2)GOTO 219
  3482.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3483.     LCL=JVBLS(1,1,1)
  3484.     GOTO 2200
  3485. 219    CONTINUE
  3486.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3487.     LCL=XVBLS(1,1)
  3488. 2200    CONTINUE
  3489. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3490.     L1=LSTCH+1
  3491.     L2=60
  3492. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3493.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3494.     IF(IVLD2.EQ.0)GOTO 1000
  3495. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3496.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3497.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3498.     LRW=JVBLS(1,1,1)
  3499.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3500.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3501. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3502.     LRW=LRW+1
  3503. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3504. C CLAMPING TO MAX VALUES.
  3505.     LCL=MAX0(1,LCL)
  3506.     LRW=MAX0(1,LRW)
  3507.     LCL=MIN0(LCL,MCOLS)
  3508.     LRW=MIN0(LRW,MROWS)
  3509.     KK=LCL
  3510.     KKK=LRW
  3511.     GOTO 216
  3512. 218    CONTINUE
  3513. c    rewind 11
  3514.     IF(LEVEL.EQ.1)call Vwrt(' Set Phys loc. Column=',22)
  3515. c211    FORMAT(' SET PHYS LOC. COLUMN=')
  3516. c    rewind 11
  3517.     LLLV=LEVEL
  3518.     IF(LEVEL.EQ.1)LLLV=11
  3519.     if(lllv.ne.11)READ(LLLV,212,END=700,ERR=700)KK
  3520.     if(lllv.eq.11)call vgeti(kk)
  3521. 212    FORMAT(I7)
  3522. c    rewind 11
  3523.     IF(LEVEL.EQ.1)Call Vwrt(' Set Phys loc. Row=',19)
  3524. c213    FORMAT(' SET PHYS LOC. ROW =')
  3525. c    rewind 11
  3526.     If(lllv.ne.11)READ(LLLV,212,END=700,ERR=700)KKK
  3527.     if(lllv.eq.11)call Vgeti(kkk)
  3528. c    rewind 11
  3529.     KKK=KKK+1
  3530. 216    KK=MAX0(1,KK)
  3531.     KKK=MAX0(1,KKK)
  3532.     KK=MIN0(MCOLS,KK)
  3533.     KKK=MIN0(MROWS,KKK)
  3534. C CLAMP TO LEGAL SIZE
  3535.     PROW=KK
  3536.     PCOL=KKK
  3537. C
  3538.     RETURN
  3539. C TERMINAL READ ERROR AND END PROCESSING
  3540. 700    CONTINUE
  3541. c    IF(LEVEL.EQ.1)CLOSE(11)
  3542. c    IF(LEVEL.EQ.1)OPEN(11,FILE='CON:20/100/300/40/Analy Command')
  3543.     IF(LEVEL.NE.1)REWIND LEVEL
  3544.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  3545.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  3546.     RETURN
  3547. 7000    CONTINUE
  3548.     IF(I.NE.2)GOTO 7200
  3549. C *W COMMANDS
  3550. C    IRX=(PCOL-1)*60+PROW
  3551.     CALL REFLEC(PCOL,PROW,IRX)
  3552.     CALL WRKFIL(IRX,WRK,0)
  3553. C    READ(7'IRX)WRK
  3554. C GET RECORD INTO MEMORY
  3555.     IF(LINE(3).EQ.'F')GOTO 224
  3556.     WRITE(CWRK(1:35),221)XAC
  3557. C    ENCODE(35,221,WRK)XAC
  3558. C PUT VARIABLE VALUE AS STRING INTO FILE BUFFER
  3559. 221    FORMAT(D32.25)
  3560.     GOTO 225
  3561. 224    CONTINUE
  3562. C WRITE AND USE LOCAL FORMAT
  3563.     WRK2(1)='('
  3564.     DO 226 K=1,9
  3565.     WRK2(1+K)=WRK(119+K)
  3566. 226    CONTINUE
  3567.     WRK2(11)=')'
  3568.     WRITE(CWRK(1:35),WRK2B)XAC
  3569. 225    CONTINUE
  3570.     DO 222 K=36,110
  3571. 222    WRK(K)=CHAR(32)
  3572.     CALL WRKFIL(IRX,WRK,1)
  3573. C    WRITE(7'IRX)WRK
  3574.     RETURN
  3575. 7200    CONTINUE
  3576.     IF(I.NE.3)GOTO 7400
  3577. C *G COMMANDS
  3578.     L1=3
  3579.     L2=60
  3580.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3581.     IF(IVLD1.EQ.0)GOTO 1000
  3582.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3583.     IF(TYPE(1,1).EQ.2)GOTO 251
  3584.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3585.     LCL=JVBLS(1,1,1)
  3586.     GOTO 252
  3587. 251    CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3588.     LCL=XVBLS(1,1)
  3589. 252    CONTINUE
  3590. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3591.     L1=LSTCH+1
  3592.     L2=60
  3593. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3594.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3595.     IF(IVLD2.EQ.0)GOTO 1000
  3596. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3597.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3598.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3599.     LRW=JVBLS(1,1,1)
  3600.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3601.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3602. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3603.     LRW=LRW+1
  3604. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3605. C CLAMPING TO MAX VALUES.
  3606.     LCL=MAX0(1,LCL)
  3607.     LRW=MAX0(1,LRW)
  3608.     LCL=MIN0(LCL,MCOLS)
  3609.     LRW=MIN0(LRW,MROWS)
  3610. C RETURN VALUE.
  3611.     CALL TYPGET(LCL,LRW,TYPE(1,1))
  3612.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(LCL,LRW,XAC)
  3613.     IF(TYPE(1,1).NE.2)CALL JVBLGT(1,LCL,LRW,JVBLS(1,1,1))
  3614.     IF(TYPE(1,1).NE.2)XAC=JVBLS(1,1,1)
  3615. C USE IMPLICIT CONVERSION FROM FORTRAN HERE. NOTE WE RETURN WITH
  3616. C THE LOOKED UP VALUE IN XAC.
  3617.     RETURN
  3618. 7400    CONTINUE
  3619.     IF(I.NE.4)GOTO 7600
  3620. C *Q COMMANDS
  3621. C *Q QUERY DATABASE COMMAND
  3622. C
  3623. C
  3624. C THIS COMMAND IS DESIGNED TO PERMIT CALC TO ACCESS SEQUENTIAL (FOR NOW)
  3625. C FILES AND PULL IN VALUES. ARRAY WRK IS USED TO HOLD THE RECORDS AND
  3626. C MAY DISPLAY WHATEVER IS DESIRED.
  3627. C
  3628. C OPERATION IS AS FOLLOWS:
  3629. C
  3630. C *QW/F filespec ?KEYSTRING? <cc>
  3631. C WHERE THE W/F FLAG MEANS WRITE TO FORMULA AT CURRENT LOC (MAYBE MODIFIED
  3632. C EARLIER BY THE *P COMMAND) AND F FLAG MEANS RETURN % AS VALUE OBTAINED BY
  3633. C ATTEMPTING A DECODE ON THE FILE LINE BETWEEN DELIMITER CHARACTERS
  3634. C cc GIVEN INSIDE  CHARACTERS. FILE IS ASSUMED TO START WITH
  3635. C "KEYSTRING" WHERE ANY CHARACTER IS A MATCH EXACTLY EXCEPT THAT
  3636. C THE _ CHARACTER INDICATES A WILDCARD.
  3637. C SPECIAL CASES:
  3638. C  IF ` IS 1ST CHAR OF KEYSTRING, RECORDS MUST HAVE KEYSTRING STARTING
  3639. C AT COL 1 (EXCLUDING THE `)
  3640. C  IF <CC> STRING HAS ` AS 1ST CHARACTER, THEN IT IS OF FORM
  3641. C <`NM> WHERE N=ASCII CODE FOR COLUMN WANTED + 32 AND M = ASCII CODE
  3642. C   FOR LENGTH DESIRED + 32
  3643. C  THIS ALLOWS POSITIONAL RETRIEVAL (THOUGH PAINFULLY)
  3644. C
  3645. C A SECOND KEYSTRING MAY BE ENTERED INSIDE A SECOND PAIR OF ? CHARACTERS TOO.
  3646. C  THE SEARCH WILL SEEK THE KEYS ANYWHERE IN THE RECORDS READ, UP TO 128
  3647. C  CHARACTERS LONG EACH.
  3648. C SECOND KEYSTRING MAY NOT BE ANCHORED TO START OF LINE.
  3649. C  AS AN ADDED ATTRACTION:
  3650. C   *QFK  OR *QFN  WON'T CLOSE LUN 4 AT END. IN ADDITION *QFN WON'T
  3651. C  CLOSE IT AT START EITHER ALLOWING SEQUENTIAL RETRIEVALS OUT OF
  3652. C  DATA FILES. DITTO *QW VARIANTS.
  3653. C    IRX=(PCOL-1)*60+PROW
  3654.     CALL REFLEC(PCOL,PROW,IRX)
  3655. C    IF(LINE(3).EQ.'W')READ(7'IRX)WRK
  3656.     IF(LINE(3).EQ.'W')CALL WRKFIL(IRX,WRK,0)
  3657.     IF(LINE(3).NE.'W'.AND.LINE(3).NE.'F')RETURN
  3658.     IL=INDX(LINE,32)
  3659.     IF(IL.GT.40)GOTO 299
  3660.     IL2=INDX(LINE(IL+1),32)
  3661.     IF(IL2.GT.38)GOTO 299
  3662. C ENSURE LUN 4 AVAILABLE
  3663.     IF(LINE(4).NE.'C'.AND.LINE(4).NE.'N')CLOSE(4)
  3664.     LINE(IL2+IL)=CHAR(0)
  3665.     IF(LINE(4).NE.'N'.AND.LINE(4).NE.'C')
  3666.      1   CALL RASSIG(4,LINE(IL+1),ierror)
  3667.     if(ierror.ne.0)return
  3668. C THIS MAKES LUN 4 BE THE ONE WE WANT
  3669.     LINE(IL2+IL)=CHAR(32)
  3670.     KKK=ICHAR('?')
  3671.     IQ1=INDX(LINE,KKK)
  3672. C LOCATE THE KEY
  3673.     IF(IQ1.GE.70)GOTO 299
  3674.     KKK=ICHAR('?')
  3675.     IQ2=INDX(LINE(IQ1+1),KKK)
  3676.     IF(IQ2.GE.72)GOTO 299
  3677. C NOW KNOW KEY IS IQ2-1 LONG, STARTS AT IQ1+1
  3678. C
  3679. C ALLOW DOUBLE KEYS IF ANOTHER ?? PAIR IS SEEN.
  3680.     KEYS2=0
  3681.     KKK=ICHAR('?')
  3682.     IQ3=INDX(LINE(IQ1+IQ2+1),KKK)
  3683.     IF(IQ3.GT.3)GOTO 297
  3684. C WELL, THERE'S A 2ND STRING THERE MAYBE.
  3685.     IQ4=INDX(LINE(IQ3+IQ1+IQ2+1),KKK)
  3686.     IF(IQ4.GT.30)GOTO 297
  3687.     IF(IQ4.EQ.1)GOTO 297
  3688.     KEYS2=1
  3689. C FLAG WE HAVE A SECOND KEY. SOMETHING'S THERE.
  3690.     LCL=IQ3+IQ2+IQ1+1
  3691.     LRW=LCL+IQ4-1
  3692. 297    READ(4,332,END=299,ERR=299)WRK2
  3693.     IQQ=IQ2-1
  3694.     IXX=128-IQ2
  3695. C COMPARE THE ENTIRE RECORD FOR THE KEY, MATCH ANYWHERE.
  3696.     IF(LINE(IQ1+1).NE.'`')GOTO 376
  3697. C IF 1ST CHAR OF KEY IS ` THEN SEARCH BEGINS AT LINE START ONLY. KEY IS
  3698. C 1 LESS.
  3699.     IQ1=1+IQ1
  3700.     IXX=1
  3701.     IQQ=IQQ-1
  3702. C ADJUST SO SEARCH IS 1 CHAR LESS.
  3703. 376    CONTINUE
  3704.     DO 350 KKK=1,IXX
  3705.     CALL SCMP(LINE(IQ1+1),WRK2(KKK),IQQ,ICOD)
  3706.     IF(ICOD.NE.0)GOTO 351
  3707. 350    CONTINUE
  3708. C DON'T JUST FALL THRU
  3709.     GOTO 353
  3710. 351    CONTINUE
  3711.     IF(KEYS2.EQ.0)GOTO 353
  3712. C CHECK SECOND KEY STRING IN RECORD IF ANY WAS ASKED FOR.
  3713. C (THAT'S ALL YOU GET. 2 KEYS MAX.)
  3714. C LINE(LCL) TO LINE(LRW) CONTAINS KEY.
  3715.     IXY=128-IQ4+1
  3716.     ICC=IQ4-1
  3717.     DO 354 KKK=1,IXY
  3718.     CALL SCMP(LINE(LCL),WRK2(KKK),ICC,ICOD)
  3719.     IF(ICOD.NE.0)GOTO 355
  3720. 354    CONTINUE
  3721. 355    CONTINUE
  3722. 353    IF(ICOD.EQ.0)GOTO 297
  3723. C HERE FOUND THE KEYED RECORD. NOW EXAMINE COMMAND LINE FOR
  3724. C SPECIAL CHARACTERS. IF NONE, JUST COPY THE FIRST CHARACTERS
  3725. C IN THE TEXT INTO EITHER THE BUFFER OR ENCODE THEM.
  3726.     KKK=ICHAR('<')
  3727.     IQ1=INDX(LINE,KKK)
  3728.     IF(IQ1.LE.0.OR.IQ1.GT.75)GOTO 296
  3729.     KKK=ICHAR('>')
  3730.     IQ2=INDX(LINE(IQ1+1),KKK)
  3731.     IF(IQ2.LE.0.OR.IQ2.GT.8)GOTO 296
  3732.     KKQ=ICHAR(LINE(IQ1+1))
  3733.     KK=INDX(WRK2,KKQ)
  3734. C MUNGE THE SEARCH SO THAT IF THE SPECIAL CHAR IS ` THEN THE NEXT 2
  3735. C CHARACTERS HAVE START AND LENGTH ENCODED AS ASCII CODE -32 DECIMAL
  3736. C WHICH ALLOWS FIELDS TO BE PLACED ANYWHERE (THOUGH SOMEWHAT PAINFULLY)
  3737.     IF(LINE(IQ1+1).EQ.'`')KK=ICHAR(LINE(IQ1+2))-32
  3738.     IF(KK.GT.125)GOTO 299
  3739. C NOTE THAT THE KEY FORM WOULD THEN GIVE
  3740. C  <`!@> FOR START COLUMN=1 AND LENGTH =32 (ASCII 64 = @ AND ASCII 33 = !)
  3741. C THIS MEANS USER HAS TO KNOW ASCII ORDER BUT AT LEAST IT'S IN MANUAL.
  3742.     IF(LINE(IQ1+1).EQ.'`')KKK=ICHAR(LINE(IQ1+3))-32
  3743.     KKQ=ICHAR(LINE(IQ1+2))
  3744.     IF(LINE(IQ1+1).NE.'`')KKK=INDX(WRK2(KK+1),KKQ)+KK
  3745.     GOTO 295
  3746. 296    CONTINUE
  3747. C DEFAULT, NO SPECIAL CHARS.
  3748.     KK=0
  3749.     KKK=110
  3750. 295    CONTINUE
  3751.     KL=KKK-KK-1
  3752.     KK=KK+1
  3753.     IF(LINE(3).NE.'W')GOTO 294
  3754.     KL=MIN0(KL,109)
  3755.     DO 293 N=1,KL
  3756.     WRK(N)=WRK2(KK)
  3757. 293    KK=KK+1
  3758.     WRK(KL+1)=char(0)
  3759. C WRITE OUT THE RECORD'S KEY PART INTO SHEET FILE
  3760.     CALL WRKFIL(IRX,WRK,1)
  3761. C    WRITE(7'IRX)WRK
  3762.     XAC=1.
  3763.     GOTO 298
  3764. 294    CONTINUE
  3765. C FLOAT THE VALUE, RETURN IN XAC
  3766.     DO 750 N=1,35
  3767.     WRK(N)=CHAR(32)
  3768.     IF(N.LE.KL)WRK(N)=WRK2(KK-1+N)
  3769. 750    CONTINUE
  3770.     READ(CWRK(1:35),221,ERR=299)XAC
  3771. C    DECODE(KL,221,WRK2(KK),ERR=299)XAC
  3772. 298    CONTINUE
  3773. C IF IT'S A KEEP OR NEXT TYPE OPERATION, LEAVE LUN 4 OPEN.
  3774. C FIRST ONE MUST BE A KEEP (TO OPEN FILE IN THE FIRST PLACE)
  3775. C AND SUBSEQUENT OPERATIONS MAY BE A N OPERATIONS, WHICH
  3776. C WILL JUST CONTINUE SEQUENTIAL READIN OF DATA. USER HAS TO
  3777. C KEEP TRACK. NOTE RETURN VALUE IS -999999. (6 9'S) IF WE
  3778. C FAIL AND HAVE TO CLOSE FILE.
  3779.     IF(LINE(4).EQ.'K'.OR.LINE(4).EQ.'N')RETURN
  3780.     CLOSE(4)
  3781.     RETURN
  3782. 299    CONTINUE
  3783. C RETURN -999999 IF WE FAIL IN FINDING FILE.
  3784.     XAC=-999999.
  3785.     CLOSE(4)
  3786. C    COME HERE FOR NON-RECOVERABLE ERRORS IN FORMAT TOO.
  3787. C
  3788.     RETURN
  3789. 7600    CONTINUE
  3790.     IF(I.NE.5)GOTO 7800
  3791. C *F COMMANDS
  3792.     IF(XAC.LE.0)RETURN
  3793.     REWIND IOLVL
  3794.     IF(IOLVL.EQ.11)RETURN
  3795. 333    READ(IOLVL,332,END=331,ERR=331)WRK
  3796. 332    FORMAT(128A1)
  3797.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 333
  3798.     ISSL=2
  3799.     ISSS=2
  3800.     IF(LINE(3).EQ.' ')ISSL=3
  3801.     IF(WRK(3).EQ.' ')ISSS=3
  3802.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3803.     IF(ICODE.EQ.0)GOTO 333
  3804.     RETURN
  3805. C ERROR ENTRY WHERE WE SEE WE FAILED TO FIND LABEL.
  3806. 331    CONTINUE
  3807.     IF(IOLVL.NE.11)CLOSE(IOLVL)
  3808.     IOLVL=11
  3809.     RETCD=2
  3810. C
  3811.     RETURN
  3812. 7800    CONTINUE
  3813.     IF(I.NE.6)GOTO 8000
  3814. C *G
  3815.     IF(LEVEL.EQ.1.OR.XAC.LE.0)RETURN
  3816.     REWIND LEVEL
  3817. 363    READ(LEVEL,362,END=55,ERR=55)WRK
  3818. 362    FORMAT(128A1)
  3819.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 363
  3820.     ISSL=2
  3821.     ISSS=2
  3822.     IF(LINE(3).EQ.' ')ISSL=3
  3823.     IF(WRK(3).EQ.' ')ISSS=3
  3824.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3825.     IF(ICODE.EQ.0)GOTO 363
  3826. C
  3827.     RETURN
  3828. 8000    CONTINUE
  3829.     IF(I.NE.7)GOTO 8200
  3830. C *X COMMANDS
  3831. C NOW GET THE ARGS
  3832.     JFFG=0
  3833.     IF(LINE(3).EQ.'F')JFFG=1
  3834. C NOW HAVE FORMULA FLAG.
  3835.     IQ3=4
  3836. C ALLOW 1 SPACE OPTIONALLY
  3837.     IF(LINE(IQ3).EQ.' ')IQ3=5
  3838.     IQ1=INDX(LINE(IQ3),32)
  3839.     IQ1=IQ1+IQ3-1
  3840. C NULL TERMINATE FILENAME WHILE PARSING IT (DON'T LET ASSIGN SEE VBL NAME)
  3841.     LINE(IQ1)=char(0)
  3842.     CLOSE(4)
  3843. 9770    CALL RASSIG(4,LINE(IQ3),ierror)
  3844.     if(ierror.ne.0)return
  3845. C REPLACE THE SPACE FOR VARSCN'S SIGHT
  3846.     LINE(IQ1)=CHAR(32)
  3847. C IQ1 NOW HAS START INDEX FOR VARSCN DESIRED... GO GET VRBL NAME.
  3848.     KK1=IQ1
  3849.     KK2=IQ1+20
  3850.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3851.     IF(IVLD.LE.0)GOTO 481
  3852. C GOT VALID VARIABLE NAME. KK,KKK ARE ROW,COL
  3853. C NOW WE KNOW HOW TO RETRIEVE THE DATA OFF FILE IN UNIT 4
  3854. C READ INTO WRK ARRAY TILL WE GET IT.
  3855.     IQ3=KK
  3856.     IQ4=KKK-1
  3857. 483    READ(4,332,END=488,ERR=488)WRK
  3858. C IGNORE TITLE
  3859. 486    CONTINUE
  3860. C NOTE WE READ IN THE NUMBER IN NUMERIC FORMAT. EASIER THAT WAY.
  3861. c    IF(JFFG.EQ.0)READ(4,484,END=488,ERR=488)IRRW,ICCL,XYVAL
  3862. c    IF(JFFG.NE.0)READ(4,489,END=488,ERR=488)IRRW,ICCL,
  3863. c     1  (WRK(IV),IV=1,110)
  3864. c484    FORMAT(1X,I5,1X,I5,1X,E50.35)
  3865. c489    FORMAT(1X,I5,1X,I5,1X,110A1)
  3866.     READ(4,484,END=488,ERR=488)LETA,IRRW,ICCL,
  3867.      1  (WRK(IV),IV=1,110)
  3868. C ALWAYS READ TEXT AS ALPHA
  3869.     READ(CWRK50(1:50),6486,ERR=5486)XYVAL
  3870. C DECODE AND STORE IN XYVAL IF POSSIBLE
  3871. 6486    FORMAT(BN,D50.35)
  3872. 5486    CONTINUE
  3873. C HACK OUT TRAILING BLANKS
  3874.     DO 5322 IV=1,110
  3875.     IVV=111-IV
  3876.     IF(ICHAR(WRK(IVV)).GT.32)GOTO 5323
  3877.     WRK(IVV)=CHAR(0)
  3878. 5322    CONTINUE
  3879. 5323    CONTINUE
  3880. C &&&&
  3881. 484    FORMAT(1A1,I5,1X,I5,1X,110A1,50A1)
  3882.     READ(4,485,END=488,ERR=488)LFVLD,(WRK(IV),IV=120,128),KKTYP
  3883. C ALLOW FLAG OF 3 FOR NUMERIC,RECALCULATE... 2 FOR NUMERIC, NO RECALC.
  3884. C 1 CONTINUES TO MEAN ALWAYS RECALCULATE.
  3885.     IF(LFVLD.LT.-1)LFVLD=-3
  3886.     IF(LFVLD.GT.1)LFVLD=3
  3887. C
  3888. 485    FORMAT(I3,1X,9A1,1X,I5)
  3889. C READS IN AN ENTRY OF SAVED SHEET. TEST IF IN OUR RANGE.
  3890.     IF(IRRW.EQ.IQ3.AND.ICCL.EQ.IQ4)GOTO 487
  3891.     GOTO 486
  3892. 487    CONTINUE
  3893. C SUCCESS. NOW FILL IN VALUE OR FORMULA.
  3894.     IF(JFFG.EQ.0)GOTO 6487
  3895. C IF READING IN FORMULA, TRY AND GET VALUE OUT OF VALUE
  3896. C RECORD
  3897.     IF(LETA.NE.'p')GOTO 6487
  3898. C OK, THIS IS A VALUE RECORD WHICH SHOULD BE IMMEDIATELY FOLLOWED
  3899. C BY A FORMULA RECORD.
  3900. C   JUST DECODE THE VALUE AND RECORD IT.
  3901. C  ... ACTUALLY IT'S ALREADY DECODED SO JUST RECORD IT.
  3902.     CALL XVBLST(PROW,PCOL,XYVAL)
  3903.     XAC=XYVAL
  3904. C GO BACK AND GET FORMULA
  3905.     GOTO 486
  3906. 6487    CONTINUE
  3907. C    IRX=(PCOL-1)*60+PROW
  3908.     CALL REFLEC(PCOL,PROW,IRX)
  3909.     WRK(118)=CHAR(15)
  3910.     WRK(119)=CHAR(LFVLD)
  3911.     CALL FVLDST(PROW,PCOL,LFVLD)
  3912. C    FVLD(PROW,PCOL)=LFVLD
  3913. C SET UP TO SAVE FORMULA.
  3914. C SAVE EITHER FORMULA OR VALUE.
  3915.     IF(JFFG.EQ.0)GOTO 4890
  3916.     CALL CA2E(WRK,WRK2)
  3917.     CALL WRKFIL(IRX,WRK2,1)
  3918.     GOTO 488
  3919. 4890    CONTINUE
  3920. C SET UP NUMBER IF HERE.
  3921.     CALL TYPSET(PROW,PCOL,KKTYP)
  3922. C    TYPE(PROW,PCOL)=KKTYP
  3923.     CALL FVLDST(PROW,PCOL,LFVLD)
  3924. C    FVLD(PROW,PCOL)=LFVLD
  3925.     CALL XVBLST(PROW,PCOL,XYVAL)
  3926. C    XVBLS(PROW,PCOL)=XYVAL
  3927.     XAC=XYVAL
  3928. 488    CONTINUE
  3929.     CLOSE(4)
  3930.     RETURN
  3931. 481    CONTINUE
  3932.     CLOSE(4)
  3933.     RETCD=2
  3934. C
  3935.     RETURN
  3936. 8200    CONTINUE
  3937. 55    CLOSE(LEVEL)
  3938.     LEVEL=LEVEL-1
  3939. 1000    CONTINUE
  3940.     RETURN
  3941.     END
  3942. c -h- contyp.for    Fri Aug 22 13:00:17 1986    
  3943.     SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  3944. C COPYRIGHT (C) 1983 GLENN EVERHART
  3945. C ALL RIGHTS RESERVED
  3946. C 60=MAX REAL ROWS
  3947. C 301=MAX REAL COLS
  3948. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  3949. C VBLS AND TYPE DIMENSIONED 60,301
  3950. C *                                                *
  3951. C *            SUBROUTINE CONTYP                   *
  3952. C
  3953. C
  3954. C  CONVERTS CONSTANT IN STACK(I,INDXX) FROM OLDTYP TO NEWTYP
  3955. C  IF OLDTYP.EQ.NEWTYP A RETURN IS MADE IMMEDIATELY.
  3956. C  NOTE THAT TYPE(INDXX) IS NOT CHANGED BY THIS ROUTINE
  3957. C  TYPE CODES:
  3958. C
  3959. C    0    NO CHANGE
  3960. C    1    ASCII
  3961. C    2    DECIMAL
  3962. C    3    HEXADECIMAL
  3963. C    4    INTEGER
  3964. c note: multiple precision conversions diked out
  3965. C    5    M10
  3966. C    6    M8
  3967. C    7    M16
  3968. C    8    OCTAL
  3969. C    9    REAL
  3970. C
  3971. C  RETCD    MEANING
  3972. C
  3973. C    1    O.K.
  3974. C    2    ERROR
  3975. C
  3976. C
  3977. C   MODIFY CLASSES:  M3,M4,M8
  3978. C
  3979. C  CONTYP CALLS:
  3980. C
  3981. C   ERRMSG   PRINTS OUT ERROR MESSAGES
  3982. C   MULCON   CONVERTS MULTIPLE PRECISION TO MULTIPLE PRECISION
  3983. C            OF A DIFFERENT BASE
  3984. C
  3985. C
  3986. C
  3987. C  CONTYP IS CALLED BY
  3988. C
  3989. C   CALUN    CALCULATES UNARY OPERATIONS
  3990. C   CALBIN   CALCULATES BINARY OPERATIONS
  3991. C   VARIABLE     USE
  3992. C
  3993. C  BASE        HOLDS BASE OR POWERS OF THAT BASE (INTEGER*4).
  3994. C  BASVEC      HOLDS LEGAL BASES: 8,10, AND 16
  3995. C  EIGHT(8)    CHARACTER*1 ARRAY TO PICK OFF REAL*8 VALUES.
  3996. C  FOUR(4)     CHARACTER*1 ARRAY TO PICK OFF INTEGER*4 VALUES.
  3997. C  I,J,M       TEMPORARY VALUES.
  3998. C  IBASE       HOLDS BASE OF A NUMBER WHEN BASE HOLDS THE POWERS
  3999. C              OF THAT BASE.
  4000. C  IEND        HOLDS THE NUMBER OF MULTIPLE PRECISION DIGITS THAT
  4001. C              WILL BE PICKED UP WHEN CONVERTING TO INTEGER*4.
  4002. C  INDXX       POINTER TO VARIABLE BEING CONVERTED.
  4003. C  INT         HOLDS INTEGER*4 VALUES EQUIVALENCED TO VECTOR FOUR.
  4004. C  IS          TEMPORARILY HOLDS MULTIPLE PRECISION BASE 8 OR BASE
  4005. C              16 DIGITS.
  4006. C  IS2         TEMPORARILY HOLDS A DIGIT VALUE WHEN CHECKING MULTIPLE
  4007. C              PRECISION BASE 8 AND BASE 16 NUMBERS TO SEE IF THEY
  4008. C              ARE TOO LARGE TO FIT IN INTEGER*4.
  4009. C  ISGN        USED WHEN DETERMINING THE MAXIMUM NUMBER THAT CAN BE
  4010. C              HELD BY INTEGER*4. 1=POSITIVE, 2= NEGATIVE. ALSO HOLDS
  4011. C              0 OR 7 FOR BASE 8 MAXIMUM NUMBER CHECK. HOLDS 0 OR 15
  4012. C              FOR BASE 16 MAXIMUM NUMBER CHECK.
  4013.  
  4014. C  K           TEMPORARILY HOLDS INTEGER*4 VALUES.
  4015. C  NEWTYP      NEW DATA TYPE REQUESTED.
  4016. C  OLDTYP      DATA TYPE OF THE VARIABLE TO BE CONVERTED.
  4017. C  RBASE       BASE WHEN CONVERTING FROM MULTIPLE PRECISION TO REAL*8.
  4018. C  REAL        HOLDS REAL*8 VALUES. EQUIVALENCED TO ARRAY EIGHT.
  4019. C  RETCD       RETURN CODE. 1=O.K.  2=ERROR.
  4020. C  RPOWER      HOLDS POWERS OF RBASE WHEN CONVERTING FROM MULTIPLE
  4021. C              PRECISION TO REAL*8.
  4022. C  STACK(I,INDXX)  HOLDS VARIABLE TO BE CONVERTED.
  4023. C
  4024. C
  4025. C    SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  4026. C
  4027. c    REAL*8 REAL,RBASE,RPOWER,DFLOAT
  4028.     Real*8 real,dfloat
  4029. c    INTEGER*4 K,INT,BASE,M
  4030.     Integer*4 int
  4031.     InTeGer*4 OLDTYP,NEWTYP,RETCD,BASVEC(3),INDXX
  4032.     InTeGer*4 MAX10(10,2)
  4033.     InTeGer*4 I
  4034. c    InTeGer*4 ISGN,IS,IS2
  4035. C
  4036.     CHARACTER*1 EIGHT(8),FOUR(4)
  4037.     CHARACTER*1 STACK(8,40)
  4038. C
  4039.     EQUIVALENCE (FOUR,INT),(REAL,EIGHT)
  4040. C
  4041.     save basvec,max10
  4042.     DATA BASVEC/10,8,16/
  4043.     DATA MAX10/2,1,4,7,4,8,3,6,4,7,2,1,4,7,4,8,3,6,4,8/
  4044. C
  4045. C
  4046. C  SET DEFAULT RETURN CODE
  4047.     RETCD=1
  4048.     IF(OLDTYP.GT.0)GO TO 910
  4049. C
  4050. C VARIABLE UNDEFINED
  4051.     CALL ERRMSG(16)
  4052.     RETCD=2
  4053.     RETURN
  4054. C
  4055. C
  4056. C
  4057. 910    IF(NEWTYP.EQ.0) RETURN
  4058.     IF (OLDTYP.EQ.NEWTYP) RETURN
  4059.     GOTO (1000,2000,3000,3000,4000,5000,6000,3000,2000), OLDTYP
  4060.     STOP 1000
  4061. C
  4062. C
  4063. C
  4064. C **************************************************
  4065. C **************  OLDTYP = ASCII  ******************
  4066. C **************************************************
  4067. C
  4068. C  START BY CONVERTING TO INTEGER*4
  4069. 1000    CONTINUE
  4070. C
  4071. C
  4072. C  IF INTEGER, HEXADECIMAL OR OCTAL, ALMOST DONE
  4073.     DO 1002 I=2,8
  4074. 1002    STACK(I,INDXX)=char(0)
  4075.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  4076. C
  4077. C
  4078. C
  4079.     DO 1008 I=1,4
  4080. 1008    FOUR(I)=STACK(I,INDXX)
  4081.     IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) GOTO 1200
  4082. C
  4083. C
  4084. C  MULTIPLE PRECISION
  4085. 1010    continue
  4086.     RETURN
  4087. C
  4088. C
  4089. C  DECIMAL OR REAL
  4090. 1200    REAL=DFLOAT(INT)
  4091.     DO 1210 I=1,8
  4092. 1210    STACK(I,INDXX)=EIGHT(I)
  4093.     RETURN
  4094. C
  4095. C
  4096. C
  4097. C **************************************************
  4098. C *********  OLDTYP = DECIMAL OR REAL  *************
  4099. C **************************************************
  4100. C
  4101. 2000    IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) RETURN
  4102. C
  4103. C
  4104.     DO 2002 I=1,8
  4105. 2002    EIGHT(I)=STACK(I,INDXX)
  4106. C
  4107. C
  4108. C  ZERO STACK(I,INDXX)
  4109.     DO 2004 I=1,8
  4110. 2004    STACK(I,INDXX)=CHAR(0)
  4111. C
  4112. C
  4113. C  CONVERT TO INTEGER
  4114. C  MAKE SURE CONVERSION DOESN'T BLOW UP
  4115.     IF(REAL.LT.-2147483648.D0.OR.REAL.GT.2147483647.D0)
  4116.      1 GOTO 6050
  4117. C
  4118. C
  4119. C
  4120. 2007    INT=REAL
  4121. C
  4122. C SEE IF NEWTYP IS MULTIPLE PRECISION
  4123.     IF (NEWTYP.GE.5.AND.NEWTYP.LE.7) GOTO 1010
  4124.     DO 2008 I=1,4
  4125. 2008    STACK(I,INDXX)=FOUR(I)
  4126. C
  4127. C RETURN IF TYPE IS INTEGER, HEX, OR OCTAL
  4128.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  4129. C
  4130. C ASCII SO CLEAR OUT BYES 2,3, AND 4
  4131. 2009    DO 2010 I=2,4
  4132. 2010    STACK(I,INDXX)=CHAR(0)
  4133.     RETURN
  4134. C
  4135. C
  4136. C
  4137. C
  4138. C
  4139. C
  4140. C **************************************************
  4141. C *******  OLDTYP = INTEGER, HEX, OR OCTAL  ********
  4142. C **************************************************
  4143. C
  4144. 3000    IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  4145.     DO 3002 I=1,4
  4146. 3002    FOUR(I)=STACK(I,INDXX)
  4147. C
  4148. C SEE IF NEWTYP IS ASCII
  4149.     IF (NEWTYP.EQ.1) GOTO 2009
  4150. C
  4151. C IF NOT REAL*8 THEN IT IS MULTIPLE PRECISION (PROCESS AT 1010)
  4152.     IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 1010
  4153. C
  4154. C PROCESS AS REAL*8
  4155.     GOTO 1200
  4156. C
  4157. C *************  OLDTYP = M10  *********************
  4158. C
  4159. 4000    CONTINUE
  4160.     RETURN
  4161. 4040    continue
  4162.     RETURN
  4163. C
  4164. C **************  OLDTYP = M8  *********************
  4165. C
  4166. 5000    CONTINUE
  4167. C ***************  OLDTYP = M16  *******************
  4168. C
  4169. 6000    CONTINUE
  4170.     RETURN
  4171. C
  4172. C ***** ERROR RETURN ******
  4173. 6050    RETCD=2
  4174. C ILLEGAL CONVERSION ATTEMPTED.
  4175.     CALL ERRMSG(26)
  4176.     RETURN
  4177. C
  4178.     END
  4179. c -h- imask.for    Fri Aug 22 12:54:45 1986    
  4180.     INTEGER FUNCTION IMASK(I1,I2)
  4181.     InTeGer*4 I1,I2
  4182.     InTeGer*4 IXX
  4183.     IXX=I1.AND.I2
  4184.     IMASK=IXX
  4185. c    imask=iand(i1,i2)
  4186.     RETURN
  4187.     END
  4188. c    integer function ior(i1,i2)
  4189. c    integer*4 i1,i2,ixx
  4190. c    ixx=i1.OR.i2
  4191. c    imask=ixx
  4192. c    return
  4193. c    end
  4194.     REAL*8 FUNCTION DFLOAT(IN)
  4195.     INTEGER IN
  4196.     REAL*8 XX
  4197.     XX=IN
  4198.     DFLOAT=XX
  4199.     RETURN
  4200.     END
  4201. C ********ANALYASM.FTN ##################################3
  4202. c AnalytiCalc Amiga specific terminal I/O routines.
  4203. c note ttyini is also special and opens console window...
  4204.     Subroutine SWRT(ibuf,isz)
  4205. c write isz bytes from ibuf onto console window
  4206.     Include dos.inc
  4207.     Integer*4 Isz,i
  4208.     Integer*4 cwrite
  4209. cc    external cmove,cattron,cread !$pragma C(cmove,cattron,cread)
  4210. cc    external ccleareol,cclear,crefresh !$pragma C(ccleareol,cclear,crefresh)
  4211. cc    external cattroff,cclose,copen !$pragma C(cattroff,cclose,copen)
  4212. cc    external cwrite !$pragma C(cwrite)
  4213. c    External cwrite,cread
  4214. C    common/consfh/fh
  4215.     CHARACTER*1 OARRY(100)
  4216.     InTeGer*4 OSWIT,OCNTR
  4217. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  4218. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  4219.     InTeGer*4 IPS1,IPS2,MODFLG
  4220. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  4221.        InTeGer*4 XTCFG,IPSET,XTNCNT
  4222.        CHARACTER*1 XTNCMD(80)
  4223. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  4224. C VARY FLAG ITERATION COUNT
  4225.     INTEGER KALKIT
  4226. C    COMMON/VARYIT/KALKIT
  4227.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  4228.     InTeGer*4 RCMODE,IRCE1,IRCE2
  4229. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4230. C     1  IRCE2
  4231. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  4232. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  4233. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  4234. C RCFGX ON.
  4235. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  4236. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  4237. C  AND VM INHIBITS. (SETS TO 1).
  4238.     INTEGER*4 FH
  4239. C FILE HANDLE FOR CONSOLE I/O (RAW)
  4240. C    COMMON/CONSFH/FH
  4241.     CHARACTER*1 ARGSTR(52,4)
  4242. C    COMMON/ARGSTR/ARGSTR
  4243.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  4244.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  4245.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4246.      3  IRCE2,FH,ARGSTR
  4247.     integer*4 j,iisz,amiga
  4248.     external amiga
  4249.     character*2 crlf
  4250.     character*80 ibuf
  4251.     do 1 i=1,isz
  4252.     j=isz+1-i
  4253.     if(ichar(ibuf(j:j)).gt.6) goto 2
  4254. 1    continue
  4255. 2    continue
  4256. cccc *** begin unix specific changes
  4257. cccc must ensure we don't emit CR from here...only LF...at bol
  4258. cccc since CR erases the line to be displayed.
  4259. ccc    ilfdn=0
  4260. ccc    idocr=0
  4261. ccc    do 3 n=1,j
  4262. ccc    if(ichar(ibuf(n:n)).ne.13)goto 4
  4263. cccc a c.r. seen. Delay it until a LF seen if any
  4264. cccc emit a space to avoid vertical spacing
  4265. ccc    ibuf(n:n)=char(32)
  4266. cccc convert cr to lf (UNIX ONLY!!!)
  4267. ccc    idocr=1
  4268. ccc4    continue
  4269. ccc    if(ichar(ibuf(n:n)).ne.10)goto 3
  4270. ccc    ilfdn=1
  4271. ccc3    continue
  4272. cccc ** end unix specific changes
  4273. ccc    iisz=j
  4274.     if(fh.ne.0)I=amiga(Write,fh,ibuf,isz)
  4275. ccc    If(fh.ne.0)I=cwrite(fh,%ref(ibuf),iisz)
  4276. ccc    crlf(1:1)=char(13)
  4277. ccc    crlf(2:2)=char(10)
  4278. ccc    if(idocr.ne.0.and.ilfdn.ne.0.and.fh.ne.0)I=
  4279. ccc     1  cwrite(fh,%ref(crlf),2)
  4280.     return
  4281.     end
  4282.     Subroutine ttyin(IIMODE,line)
  4283. c read 132 char line off console
  4284. C iimode=0 in Command-Mostly mode, 1 in Enter mostly mode.
  4285.     Integer*4 iact,n,IIMODE
  4286.     include dos.inc
  4287.     Integer*4 cwrite
  4288. cc    External cread,cwrite !$pragma C(cread,cwrite)
  4289. cc    External copen,cclose !$pragma C(copen,cclose)
  4290. C    common/consfh/fh
  4291.     integer*4 amiga
  4292.     external amiga
  4293.     CHARACTER*1 OARRY(100)
  4294.     InTeGer*4 OSWIT,OCNTR
  4295. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  4296. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  4297.     InTeGer*4 IPS1,IPS2,MODFLG
  4298. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  4299.        InTeGer*4 XTCFG,IPSET,XTNCNT
  4300.        CHARACTER*1 XTNCMD(80)
  4301. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  4302. C VARY FLAG ITERATION COUNT
  4303.     INTEGER KALKIT
  4304. C    COMMON/VARYIT/KALKIT
  4305.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  4306.     InTeGer*4 RCMODE,IRCE1,IRCE2
  4307. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4308. C     1  IRCE2
  4309. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  4310. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  4311. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  4312. C RCFGX ON.
  4313. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  4314. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  4315. C  AND VM INHIBITS. (SETS TO 1).
  4316.     INTEGER*4 FH
  4317.     Character*1 wrkchr,lstchr
  4318.     Integer*4 iescst
  4319. C FILE HANDLE FOR CONSOLE I/O (RAW)
  4320. C    COMMON/CONSFH/FH
  4321.     CHARACTER*1 ARGSTR(52,4)
  4322. C    COMMON/ARGSTR/ARGSTR
  4323.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  4324.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  4325.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  4326.      3  IRCE2,FH,ARGSTR
  4327.     character*1 line(132)
  4328.     InTeGer*4 RRWACT,RCLACT
  4329. C    COMMON/RCLACT/RRWACT,RCLACT
  4330.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  4331.      1  IDOL7,IDOL8
  4332. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  4333. C     1  IDOL7,IDOL8
  4334.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  4335. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4336.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4337. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4338. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  4339. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  4340.     InTeGer*4 KLVL
  4341. C    COMMON/KLVL/KLVL
  4342.     InTeGer*4 IOLVL,IGOLD
  4343. C    COMMON/IOLVL/IOLVL
  4344. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  4345. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  4346.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4347.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4348.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  4349.      3  k3dfg,kcdelt,krdelt,kpag
  4350. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4351. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4352. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  4353.     Integer UseDK,UseDF
  4354.     common/udfudk/usedf,usedk
  4355.     Integer*4 Kone
  4356.     character*4 cwi4
  4357.     Character*1 xlf
  4358. CCC    InTeGer*4 LLCMD,LLDSP,initd
  4359. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4360. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  4361.     xlf=char(10)
  4362.     iescst=0
  4363.     Kone=1
  4364.     wrkchr=char(0)
  4365. c initially, no ESC seen
  4366. c Set up to read raw: device OK.
  4367. c If we see an ESC character then look for either a return
  4368. c (to terminate in any case) or some character whose value is
  4369. c greater than 64. However ESC O will be passed and the scan will
  4370. c continue.
  4371. C implement deletion of last character also with DEL or with
  4372. C backspace keys
  4373. c
  4374. c Initially zero entire buffer so we later can find length via looking
  4375. c for anything non-zero. Also serves to put in terminators for things
  4376. c like the INDX function to prevent them from running on indefinitely.
  4377.     do 1 n=1,132
  4378. 1    line(n)=char(0)
  4379. c if mode 0, (command mostly) then / is NOT special
  4380.     if(fh.eq.0)goto 1000
  4381. c Here begin the read loop
  4382.     n=1
  4383. 4000    continue
  4384.     lstchr=wrkchr
  4385.     wrkchr=char(0)
  4386. C zero wrkchr for safety
  4387.     kesc=0
  4388.     iact=0
  4389.     iact=amiga(Read,fh,wrkchr,Kone)
  4390. ccc     call cread(fh,%ref(wrkchr),Kone,kesc,iact)
  4391. c kesc returns special curses chars; if over 256, they mean esc
  4392. c sequences and the like...
  4393. ccc    if (kesc.gt.256)goto 7000
  4394.     If(Iact.le.0)goto 4000
  4395.     If(ichar(wrkchr).eq.0)goto 4000
  4396. CCC Add this to just read the line
  4397. CC    iact=amiga(Read,fh,line,132)
  4398. ccCC    iact=(fh,line,132)
  4399. 4050    Continue
  4400.     If(ichar(wrkchr).ne.8.and.ichar(wrkchr).ne.127)goto 4100
  4401. C back up a character and try again
  4402. c Last char was backspace or DEL, so back up by one, echo backspace.
  4403.     n=max0(1,(n-1))
  4404.     lstchr=char(8)
  4405. C echo a backspace
  4406. C 8 is ASCII backspace...
  4407.     ii=Amiga(Write,fh,Lstchr,Kone)
  4408. ccc    ii=cwrite(fh,%ref(Lstchr),Kone)
  4409.     Goto 4000
  4410. 4100    Continue
  4411. c C.R. is 13, LF is 10, FF is 14, so terminate on any of these
  4412. c traditional line terminators.
  4413.     If(ichar(wrkchr).lt.16)goto 5000
  4414. c Normal character, just echo it.
  4415.     ii=Amiga(Write,fh,wrkchr,kone)
  4416. ccc    ii=cwrite(fh,%ref(wrkchr),kone)
  4417. c echo the character back
  4418. c Then store it.
  4419.     line(n)=wrkchr
  4420.     n=min0(n+1,131)
  4421.     if(ichar(wrkchr).eq.27.or.ichar(Wrkchr).eq.155)iescst=1
  4422. c <ESC>O is actually an escape sequence initiator
  4423.     If(iescst.eq.1.and.wrkchr.eq.'O'.and.ichar(lstchr)
  4424.      1  .eq.27) goto 4200
  4425. c Otherwise an escape sequence ends in a letter
  4426.     If(Iescst.eq.0)goto 4200
  4427.     ii=ichar(wrkchr)
  4428.     If(ii.eq.91)goto 4200
  4429. c 91 is ascii for [
  4430.     If(ii.le.64.or.ii.ge.127)Goto 4200
  4431.     Return
  4432. C terminate read at end of any escape sequence
  4433. c from A to z except [ are possible esc seq delimiters.
  4434. 4200    Continue
  4435. c The above condition terminates an ESC sequence after ESC and any other
  4436. c characters followed by (and including) any character greater than 'A'
  4437. c which should take care of just about every ANSI escape sequence.
  4438.     if(n.lt.131)goto 4000
  4439. c Terminate even if we never get C.R. but not 'till we've got
  4440. c all there is to get...
  4441.     Return
  4442. 5000    continue
  4443. c Echo line terminator
  4444.     line(n)=wrkchr
  4445.     ii=Amiga(Write,fh,wrkchr,kone)
  4446.     If(ichar(wrkchr).eq.13)ii=Amiga(Write,fh,xlf,Kone)
  4447. ccc    ii=cwrite(fh,%ref(wrkchr),kone)
  4448. ccc    If(ichar(wrkchr).eq.13)ii=cwrite(fh,%ref(xlf),Kone)
  4449. c echo lf after cr
  4450. c done reading now.
  4451.     Return
  4452. 1000    Continue
  4453. C fakeout fallback position, reading workbench window
  4454.     Read(*,1500)line
  4455. 1500    format(132a1)
  4456.     return
  4457. C the material below 7000 is used in the curses version which is more
  4458. C trouble than it's worth to link on amiga; absoft fortran does
  4459. C not lend itself to linking with C code, unfortunately.
  4460. ccc7000    continue
  4461. cccc just got an escape sequence. Fake entry of appropriate command
  4462. cccc for AnalytiCalc and terminate the call...
  4463. cccc&&&&&&&&
  4464. cccc kesc=258=dow,,259=up,260=left,261=right
  4465. ccc    kkkk=n
  4466. cccc save n for a little below
  4467. ccc    line(n)=char(27)
  4468. ccc    n=min0(n+1,131)
  4469. ccc    line(n)='['
  4470. ccc    n=min0(n+1,131)
  4471. ccc    if(kesc.gt.261)goto 7001
  4472. ccc    if (kesc.eq.258)line(n)='B'
  4473. ccc    if (kesc.eq.259)line(n)='A'
  4474. ccc    if (kesc.eq.260)line(n)='D'
  4475. ccc    if (kesc.eq.261)line(n)='C'
  4476. cccc model vt100 esc seqs so they'll work in either mode
  4477. ccc    n=min0(n+1,131)
  4478. ccc    return
  4479. cccc handle HELP key; use a dedicated key rather than PF2 in this
  4480. cccc case. This is value 363.
  4481. ccc7001    if (kesc.ne.363) goto 7002
  4482. ccc    line(n)='Q'
  4483. ccc    n=min0(n+1,131)
  4484. ccc    return
  4485. ccc7002    continue
  4486. cccc    if(kesc.lt.264.or.kesc.gt.277)goto 7003
  4487. cccc handle function keys (first bunch of 'em anyway)
  4488. cccc    line(n)=char((kesc-264)+ichar('l'))
  4489. cccc    n=min0(n+1,131)
  4490. cccc returns fake "keypad" cmds
  4491. cccc    return
  4492. ccc7003    continue
  4493. cccc anything else, try and invoke a cmd file.
  4494. ccc    n=kkkk
  4495. ccc    if(n.gt.100)return
  4496. ccc    line(n)='@'
  4497. ccc    n=n+1
  4498. ccc    if(usedk.eq.0)goto 7004
  4499. ccc    line(n)='A'
  4500. ccc    n=n+1
  4501. ccc    line(n)='D'
  4502. ccc    n=n+1
  4503. ccc    line(n)='K'
  4504. ccc    n=n+1
  4505. ccc    line(n)=':'
  4506. ccc    n=n+1
  4507. ccc7004    continue
  4508. ccc    line(n)='A'
  4509. ccc    n=n+1
  4510. ccc    line(n)='C'
  4511. ccc    n=n+1
  4512. ccc    line(n)='C'
  4513. ccc    n=n+1
  4514. cccc decode into cwi4 the key value from curses and tack that onto
  4515. cccc the filename
  4516. ccc    write(cwi4,7005)kesc
  4517. ccc7005    format(i3)
  4518. cccc know that there will be 3 digits
  4519. ccc    line(n)=cwi4(1:1)
  4520. ccc    line(n+1)=cwi4(2:2)
  4521. ccc    line(n+2)=cwi4(3:3)
  4522. cccc add the type ".cmd"
  4523. ccc    line(n+3)='.'
  4524. ccc    line(n+4)='C'
  4525. ccc    line(n+5)='M'
  4526. ccc    line(n+6)='D'
  4527. cccc that should do it...
  4528. ccc    return
  4529.     end
  4530.     subroutine swset(i)
  4531.     integer*4 i
  4532. c dummy setup sub
  4533.     return
  4534.     end
  4535.     subroutine exitqq
  4536. c exit routine ... just do fortran stop to make it complete
  4537. creset nlormal math
  4538. c    call standard_arithmetic()
  4539.     stop "Thanks for using AnalyRim ... bye now"
  4540.        end
  4541.     subroutine xsystem(line)
  4542.     include dos.inc
  4543. c execute an amigados command
  4544. c    integer*4 inp,outp
  4545.     character*80 line
  4546.     character*80 l2
  4547.     logical*4 succ
  4548.     Logical*4 Amiga
  4549.     External Amiga
  4550. c search for a null first
  4551.     do 11 n=1,79
  4552.     kk=n
  4553.     if(ichar(line(n:n)).eq.0)goto 22
  4554. 11    continue
  4555. 22    continue
  4556.     do 1 n=1,79
  4557.     m=81-n
  4558. c space is ascii code 32
  4559. c look for trailing whitespace to remove
  4560.     if(ichar(line(m:m)).gt.32)goto 2
  4561. 1    continue
  4562. 2    n=m
  4563.     n=min0(kk-1,n)
  4564. c pick as end either first null seen or first
  4565. c whitespace.
  4566. c n= last character of non-null
  4567.     k=1
  4568.     if((line(1:1).eq.'$').or.(line(1:1).eq.'}'))k=2
  4569.     if(k.ge.n)return
  4570.     open(unit=2,file='ram:AnalyJnk.Tmp')
  4571.     write(2,1000)line(k:n)
  4572.     if(line(1:1).eq.'$')write(2,1001)
  4573. 1000    format(A)
  4574. 1001    Format('EndCLI')
  4575.     close(unit=2)
  4576.     inp=0
  4577.     outp=0
  4578.     if(line(1:1).eq.'$')l2=
  4579.      1  'NEWCLI CON:0/0/600/190/ASpwn FROM ram:AnalyJnk.Tmp'
  4580.      2  // char(0)
  4581.     if(line(1:1).ne.'$')l2=
  4582.      1  'NEWSHELL CON:0/0/600/190/ASpwn FROM ram:AnalyJnk.Tmp'
  4583.      2  // char(0)
  4584.     succ=amiga(Execute,l2,
  4585.      2  inp,outp)
  4586. cccc    line(1:1)=' '
  4587. cccc    kkkk=n+1
  4588. cccc    line(kkkk:kkkk)=char(0)
  4589. ccccc    succ=system(line(1:kkkk))
  4590. ccc    succ=lib$spawn(line(1:n))
  4591. c execute argument as sh command in unix.
  4592.     return
  4593.     end
  4594. C ************ AnalyDM.Ftn ######################################
  4595. c -h- declr.for    Fri Aug 22 13:02:54 1986    
  4596.     SUBROUTINE DECLR(ITYP,RETCD)
  4597. C COPYRIGHT (C) 1983 GLENN EVERHART
  4598. C ALL RIGHTS RESERVED
  4599. C 60=MAX REAL ROWS
  4600. C 301=MAX REAL COLS
  4601. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  4602. C VBLS AND TYPE DIMENSIONED 60,301
  4603. C **************************************************
  4604. C *                                                *
  4605. C *       SUBROUTINE  DECLR (ITYP,RETCD)           *
  4606. C *                                                *
  4607. C **************************************************
  4608. C
  4609. C
  4610. C ANALYZES VECTOR LINE TO DETERMINE WHAT VARIABLES GET THEIR
  4611. C TYPES CHANGED. THE NEW TYPE IS SPECIFIED AS AN ARGUMENT IN
  4612. C THE CALL:
  4613. C
  4614. C
  4615. C  TYPE CODE
  4616. C    1  ASCII
  4617. C    2  DECIMAL (REAL BUT DECIMAL POINT FOR OUTPUT)
  4618. C    3  HEXADECIMAL
  4619. C    4  INTEGER
  4620. C    5  MULTIPLE PRECISION (BASE 10)
  4621. C    6  MULTIPLE PRECISION (BASE 8)
  4622. C    7  MULTIPLE PRECISION (BASE 16)
  4623. C    8  OCTAL
  4624. C    9  REAL
  4625. C
  4626. C  IF NEGATIVE, TYPE IS DEFINED BUT VARIABLE HAS
  4627. C  NOT BEEN ASSIGNED A VALUE
  4628. C
  4629. C
  4630. C  RETCD     MEANING
  4631. C  1    =    O.K.
  4632. C  2    =    ERROR
  4633. C
  4634. C  NOTE:  AS IN FORTRAN, VARIABLES IN DECLARATIONS MUST BE SEPARATED
  4635. C         BY COMMAS
  4636. C
  4637. C
  4638. C  MODIFICATION CLASSES: M1, M2
  4639. C
  4640. C
  4641. C
  4642. C
  4643. C DECLR CALLS:
  4644. C
  4645. C  ERRMSG   PRINTS ERROR MESSAGES
  4646. C
  4647. C
  4648. C
  4649. C DECLR IS CALLED BY CMND, THE ROUTINE THAT DECODES COMMANDS.
  4650. C
  4651. C
  4652. C
  4653. C
  4654. C       VARIABLE        USE
  4655. C
  4656. C    ALPHA           LIST OF LEGAL VARIABLE NAMES. THE FIRST 26 ARE
  4657. C                    ALPHABETIC, THE 27TH IS THE CHARACTER '%'.
  4658. C    BLANK           ' '
  4659. C    I,I2,I3         TEMPORARY VALUES.
  4660. C    ITYP            CODE THAT GIVES THE TYPE OF VARIABLE FOR A
  4661. C                    PARTICULAR CALL TO THIS ROUTINE. VARIABLES ARE
  4662. C                    EITHER DECLARED TO BE OF THIS TYPE OR, IF NO
  4663. C                    VARIABLES ARE SPECIFIED, A LIST OF ALL THE
  4664. C                    VARIABLES OF THAT TYPE ARE GIVEN.
  4665. C    LEND            LAST NON-BLANK IN VECTOR LINE(80).
  4666. C    LINE(80)        HOLDS INPUT COMMAND LINE. IF DECLARATION HAS
  4667. C                    NO ARGUMENT, THIS VECTOR IS THEN USED TO OUTPUT
  4668. C                    A LIST OF VARIABLES OF THE TYPE SPECIFIED.
  4669. C    NONBLK          START SCAN OF VARIABLE LIST.
  4670. C    TYPE            HOLDS THE TYPE CODE FOR EACH VARIABLE.
  4671. C
  4672. C
  4673. C
  4674. C
  4675. C
  4676. C
  4677. C
  4678. C    SUBROUTINE DECLR(ITYP,RETCD)
  4679.     InTeGer*4 LEVEL,NONBLK,LEND
  4680.     InTeGer*4  RETCD,VIEWSW,BASED,VLEN(9)
  4681.     InTeGer*4 TYPE(1,2)
  4682.     InTeGer*4 I,I2,I3,ITYP
  4683. C
  4684.     CHARACTER*1  LINE(80),AVBLS(24,27),VBLS(8,1,1)
  4685.     Real*8 VAVBLS(3,27)
  4686.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  4687.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  4688.     Character*127 cwrk
  4689. C
  4690.     COMMON  /V/TYPE,AVBLS,VBLS,VLEN
  4691.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  4692.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  4693. C
  4694. C
  4695. C
  4696.     IF(NONBLK.EQ.LEND)GO TO 500
  4697. C
  4698. C
  4699. C **************************************************
  4700. C ****** DECLARE VARIABLES TO BE OF TYPE ITYP ******
  4701. C **************************************************
  4702.     I2=NONBLK+1
  4703. 10    CONTINUE
  4704. C10    IF (LINE(I2).EQ.BLANK) GOTO 60
  4705. C    DO 20 I3=1,26
  4706. C    IF (LINE(I2).EQ.ALPHA(I3)) GOTO 30
  4707. C20    CONTINUE
  4708. C *****&&&&& ADD VARIABLE SIZE SUPPORT - GCE
  4709.     CALL VARSCN(LINE,I2,LEND,LSTCHR,ID1,ID2,IVALID)
  4710. C VARSCN SEARCHES FOR VALID VARIABLE NAME STRINGS INCLUDING C$+EXPR
  4711. C AND R$+EXPR FOR LOC-RELATIVE NAMES IN ABSOLUTE AND C@+N, R@+N FOR RELATIVE
  4712. C NAMES IN DISPLAY SYSTEM. IT RETURNS THE ID1, ID2 INDICES FOR
  4713. C THE VARIABLES IN VBLS ARRAY AND TYPE ARRAY. FOR SINGLE ALPHAS
  4714. C A-Z, ID1 RETURNS 1-26 AND ID2=1. % RETURNS ID1=27, ID2=1.
  4715.     IF(IVALID.EQ.0) GOTO 22
  4716. C VALID FLAG IS NONZERO IF VARIABLE NAME IS VALID, ELSE 0.
  4717.     I2=LSTCHR
  4718. C LSTCHR RETURNS LAST CHARACTER OF NAME
  4719.     GOTO 30
  4720. C
  4721. C  ILLEGAL CHARACTER IN DECLARATION'S VARIABLE LIST
  4722. 22    I=4
  4723. C
  4724. C
  4725. C
  4726. C ******* ERROR RETURN *******
  4727. 25    RETCD=2
  4728.     CALL ERRMSG(I)
  4729.     RETURN
  4730. C
  4731. C
  4732. C
  4733. C
  4734. 30    CONTINUE
  4735. C IF OLD VARIABLE WAS UNDEFINED, MAKE NEW TYPE LESS THAN 0 ALSO.
  4736. C THIS ALLOWS ONE TO EXAMINE INTERNAL VALUES FOR DIFFERENT DATA
  4737. C TYPES. IF THIS IS NOT NEEDED, IT WOULD BE CLEANER TO ALWAYS MAKE
  4738. C VARIABLES UNDEFINED WHEN THEIR DATA TYPE IS CHANGED. TO DO THIS
  4739. C JUST USE THE STATEMENT
  4740. C    I=-ITYP
  4741.     I=ITYP
  4742. C ****&&&&&& NOTE TYPE NOW 2-DIM
  4743.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  4744.     IF(TYPE(1,1).LE.0)I=-I
  4745.     CALL TYPSET(ID1,ID2,I)
  4746. C    TYPE(ID1,ID2)=I
  4747.     I3=I2+1
  4748.     IF (I3.GT.LEND) GOTO 1000
  4749.     DO 40 I2=I3,LEND
  4750.     IF (LINE(I2).EQ.BLANK) GOTO 40
  4751.     IF (LINE(I2).EQ.COMMA) GOTO 45
  4752. C
  4753. C VARIABLES NOT SEPARATED BY COMMAS
  4754.     I=5
  4755.     GO TO 25
  4756. 40    CONTINUE
  4757.     GOTO 1000
  4758. 45    IF (I2.EQ.LEND) GOTO 22
  4759. 60    I2=I2+1
  4760.     IF (I2.LE.LEND) GOTO 10
  4761.     GO TO 1000
  4762. C
  4763. C
  4764. C
  4765. C
  4766. C
  4767. C
  4768. C **********************************************************************
  4769. C ** NO ARGUMENTS SO SHOW WHAT VARIABLES HAVE BEEN DECLARED THAT TYPE **
  4770. C **********************************************************************
  4771. 500    CONTINUE
  4772.     IF(VIEWSW.EQ.0) GO TO 1000
  4773. C PERHAPS THE ABOVE LINE SHOULD BE REMOVED (???)
  4774. C
  4775. C
  4776. C BLANK OUT OUTPUT LINE.
  4777.     DO 510 I=1,80
  4778. 510    LINE(I)=BLANK
  4779. C
  4780. C
  4781. C SEARCH FOR VARIABLES OF TYPE ITYP. PUT THEM IN LINE(I2) WHEN FOUND FOR
  4782. C LATER PRINTING.
  4783.     I2=0
  4784.     DO 550 I=1,27
  4785. C FAKE UP DISPLAY
  4786. C ****&&&&&
  4787.     CALL TYPGET(I,1,TYPE(1,1))
  4788.     IF(IABS(TYPE(1,1)).NE.ITYP)GO TO 550
  4789.     I2=I2+1
  4790.     LINE(I2)=ALPHA(I)
  4791. 550    CONTINUE
  4792. C
  4793. C
  4794. C GO TO SECTION APPROPRIATE FOR PRINTING EITHER THE LIST OF VARIABLES OR
  4795. C A MESSAGE INDICATING THAT NO VARIABLES ARE OF THAT TYPE.
  4796.     IF(I2.EQ.0) GO TO 600
  4797. C
  4798. C
  4799. C OUTPUT A LIST OF VARIABLES OF TYPE ITYP
  4800.     write(cwrk,560)(line(i),i=1,i2)
  4801.     Call vwrt(char(13)//char(10),2)
  4802.     call vwrt('Variables so declared=',22)
  4803.     call vwrt(cwrk,i2)
  4804. c    WRITE(11,560) (LINE(I),I=1,I2)
  4805. 560    format(30a1)
  4806. c560    FORMAT(' VARIABLES SO DECLARED = ',30A1)
  4807.     GO TO 1000
  4808. C
  4809. C
  4810. C
  4811. C
  4812. C NO VARIABLES OF THAT TYPE
  4813. 600    Continue
  4814.     Call vwrt(char(13)//char(10),2)
  4815.     Call vwrt(' No variables of that type',26)
  4816. c600    WRITE(11,610)
  4817. 610    FORMAT(' NO VARIABLES OF THAT TYPE')
  4818. C
  4819. C
  4820. C
  4821. C **** NORMAL RETURN ****
  4822. 1000    RETCD=1
  4823.     RETURN
  4824.     END
  4825. c -h- doentr.for    Fri Aug 22 13:03:06 1986    
  4826.     SUBROUTINE DOENTR(FORM,LOW,LHIGH)
  4827. C +++++++++++++++++++++++++++++++++++
  4828. C    Character*1 cmdlin(132)
  4829.     CHARACTER*1 FORM,FVLD
  4830.     Include aparms.inc
  4831. c    INTEGER*4 VNLT
  4832.     DIMENSION FORM(128),FVLD(1,1)
  4833. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  4834. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  4835. C SO INITIALLY IGNORE.
  4836. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4837. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4838.     InTeGer*4 RRWACT,RCLACT
  4839. C    COMMON/RCLACT/RRWACT,RCLACT
  4840.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  4841.      1  IDOL7,IDOL8
  4842. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  4843. C     1  IDOL7,IDOL8
  4844.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  4845. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  4846.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4847. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  4848. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  4849. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  4850.     InTeGer*4 KLVL
  4851. C    COMMON/KLVL/KLVL
  4852.     InTeGer*4 IOLVL,IGOLD
  4853. C    COMMON/IOLVL/IOLVL
  4854. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  4855. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  4856.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4857.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4858.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  4859.      3  k3dfg,kcdelt,krdelt,kpag
  4860. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  4861. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  4862. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  4863.     EXTERNAL INDX
  4864.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  4865.     COMMON/D2R/NRDSP,NCDSP
  4866.     InTeGer*4 TYPE(1,2),VLEN(9)
  4867.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  4868.     Real*8 VAVBLS(3,27)
  4869.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  4870.     REAL*8 ACY
  4871.     EQUIVALENCE(ACY,AVBLS(1,27))
  4872.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  4873.     COMMON/FVLDC/FVLD
  4874. C +++++++++++++++++++++++++++++++++++
  4875. C ENABLE { FORMS TO HANDLE ALL POSSIBLE EQUATIONS.
  4876.     CALL FRMEDT(FORM,LLST)
  4877.     IITR=0
  4878. 5050    IITR=IITR+1
  4879.     FORM(111)=Char(0)
  4880.     LCURR=LOW
  4881. C DO AN ENTRY. MUST SCAN FOR MULTIPLE STATEMENTS PER LINE AND ALSO
  4882. C RECOGNIZE FUNCTION NAMES.
  4883. 1000    CONTINUE
  4884.     KKK=ICHAR('\')
  4885.     LSL=INDX(FORM(LCURR),KKK)
  4886.     IF(LSL.EQ.0)LSL=LHIGH-LCURR+1
  4887. C CLAMP AT 80 CHARS LONG INPUT.
  4888.     IF(LSL.LE.79)GOTO 1200
  4889. C STMT HAS NO MULTIPLES. SQUASH IT TO USE ONLY 1ST PART...
  4890.     LSL=79
  4891.     LCURR=LHIGH
  4892.     FORM(80)=Char(0)
  4893. 1200    CONTINUE
  4894.     IF(FORM(LCURR).NE.'<')GOTO 5052
  4895.     IF(ACY.GT.0. .AND.
  4896.      2  IITR.LT.100)GOTO 5050
  4897. C ALLOW IN-FORMULA LOOPING PROVIDED % IS POSITIVE AND
  4898. C WITH LIMITED RETRIES...
  4899. C AVOID CALLING DOSTMT WITH BOGUS < CHARACTER AS "FORMULA" SO
  4900. C WE AVOID ERROR MESSAGES.
  4901.     GOTO 5051
  4902. 5052    CONTINUE
  4903.     CALL DOSTMT(FORM(LCURR),LSL)
  4904. 5051    IF (LCURR.GE.LHIGH)RETURN
  4905.     LCURR=LCURR+LSL
  4906.     If(Lcurr.lt.Lhigh)GOTO 1000
  4907.     Return
  4908.     END
  4909. c -h- doif.for    Fri Aug 22 13:03:17 1986    
  4910.     SUBROUTINE DOIF(LINE,LLB,LRB,LLAST)
  4911. C    PARAMETER 1=1,12=12
  4912.     EXTERNAL INDX
  4913.     CHARACTER*1 LINE(110)
  4914.     REAL*8 V1,V2
  4915.     V1=0.
  4916.     V2=0.
  4917.     LS=LRB-LLB+1
  4918.     CALL GETLOG(LINE(LLB),LS,LOGTYP,LASST)
  4919.     LOV1=LLB
  4920.     LHIV1=LASST+LLB-1
  4921.     IF(LOV1.GE.LHIV1)GOTO 100
  4922. C USE SUM FUNCTION HERE AS TYPE OF FCN
  4923.     LT=4
  4924.     CALL DOMFCN(LINE,LOV1,LHIV1,LT,V1)
  4925. 100    CONTINUE
  4926.     IF(LOGTYP.EQ.0)GOTO 1000
  4927.     LOV2=LASST+2+LLB
  4928.     LHIV2=LRB
  4929.     IF(LOV2.GE.LHIV2)GOTO 200
  4930.     LT=4
  4931.     CALL DOMFCN(LINE,LOV2,LHIV2,LT,V2)
  4932. 200    CONTINUE
  4933.     CALL TEST(LOGTYP,LFLAG,V1,V2)
  4934.     IF(LFLAG.EQ.0)GOTO 700
  4935. C HERE HAVE "TRUE" ALTERNATIVE OF IF STMT
  4936.     KKK=ICHAR('|')
  4937.     LBAR=INDX(LINE,KKK)
  4938.     LBAR=MIN0(LBAR,LLAST)
  4939.     LSTM=LRB+1
  4940. C LSTM TO LBAR IS NOW THE STMT TO EVALUATE. SINCE WE ALREADY HAVE A
  4941. C ROUTINE TO EVALUATE A STMT, DO SO. NOTE PARTIAL RECURSION, SO
  4942. C NO NESTED IFS ALLOWED, AND CALL MUST PERMIT RECURSION ON YOUR
  4943. C MACHINE OR FORGET IT. (OK ON PDP11, VAX).
  4944.     LSZ=LBAR-LSTM
  4945.     IF(LSZ.LT.1)GOTO 1000
  4946.     LSZ=LSZ+1
  4947.     CALL DOSTMI(LINE(LSTM),LSZ)
  4948.     GOTO 1000
  4949. 700    CONTINUE
  4950. C HERE HAVE "FALSE" ALTERNATIVE OF IF STMT
  4951.     KKK=ICHAR('|')
  4952.     LBAR=INDX(LINE,KKK)+1
  4953.     LBAR=MIN0(LBAR,LLAST)
  4954.     LSZ=LLAST-LBAR
  4955.     IF(LSZ.LT.1)GOTO 1000
  4956.     LSZ=LSZ+1
  4957.     CALL DOSTMI(LINE(LBAR),LSZ)
  4958. 1000    CONTINUE
  4959. C THAT'S ALL.
  4960.     RETURN
  4961.     END
  4962. c -h- domath.fms    Fri Aug 22 13:03:28 1986    
  4963.     SUBROUTINE DOMATH(INDEXF,VAR,AC,SS,CTR,ACX)
  4964. C COPYRIGHT (C) 1985, 1986 GLENN C.EVERHART
  4965. C ALL RIGHTS RESERVED
  4966.     INCLUDE aparms.inc
  4967. C    EXTERNAL INDX
  4968.     REAL*8 AC,SS,CTR,ACX,RWRK1,RWRK2
  4969.     DIMENSION EP(20)
  4970.     InTeGer*4 DLFG
  4971. C    COMMON/DLFG/DLFG
  4972.     InTeGer*4 KDRW,KDCL
  4973. C    COMMON/DOT/KDRW,KDCL
  4974.     InTeGer*4 DTRENA
  4975. C    COMMON/DTRCMN/DTRENA
  4976.     REAL*8 EP,PV,FV
  4977.     INTEGER*4 KIRR
  4978. C    COMMON/ERNPER/EP,PV,FV,KIRR
  4979.     InTeGer*4 LASTOP
  4980. C    COMMON/ERROR/LASTOP
  4981.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  4982. C    COMMON/FMTBFR/FMTDAT
  4983.     CHARACTER*1 EDNAM(16)
  4984. C    COMMON/EDNAM/EDNAM
  4985.     InTeGer*4 MFID(2),MFMOD(2)
  4986. C    COMMON/FRM/MFID,MFMOD
  4987.     InTeGer*4 JMVFG,JMVOLD
  4988. C    COMMON/FUBAR/JMVFG,JMVOLD
  4989.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  4990.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  4991. CCC    REAL*8 EP,PV,FV
  4992. CCC    COMMON/ERNPER/EP,PV,FV,KIRR
  4993.     REAL*8 VAR,TE
  4994.     INTEGER*4 IWRK1,IWRK2,IDUM
  4995.     LOGICAL*4 LWRK1,LWRK2,LWRK3
  4996.     INTEGER*4 IWRK3
  4997.     EQUIVALENCE(IWRK1,LWRK1),(IWRK2,LWRK2),(IWRK3,LWRK3)
  4998.     InTeGer*4 ICREF,IRREF
  4999. C    COMMON/MIRROR/ICREF,IRREF
  5000.     InTeGer*4 MODPUB,LIMODE
  5001. C    COMMON/MODPUB/MODPUB,LIMODE
  5002.     InTeGer*4 KLKC,KLKR
  5003.     REAL*8 AACP,AACQ
  5004. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  5005.     InTeGer*4 NCEL,NXINI
  5006. C    COMMON/NCEL/NCEL,NXINI
  5007.     CHARACTER*1 NAMARY(20,MROWS)
  5008. C    COMMON/NMNMNM/NAMARY
  5009.     InTeGer*4 NULAST,LFVD
  5010. C    COMMON/NULXXX/NULAST,LFVD
  5011.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  5012.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  5013. CCC    REAL*8 AACP,AACQ
  5014. CCC    InTeGer*4 KLKC,KLKR
  5015. CCC    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  5016.     IF(INDEXF.NE.1)GOTO 100
  5017. C MIN
  5018.     IF(VAR.GE.AC)GOTO 105
  5019.     AC=VAR
  5020.     AACP=KLKC
  5021.     AACQ=KLKR
  5022. 105    CONTINUE
  5023.     ACX=AC
  5024.     RETURN
  5025. 100    IF(INDEXF.NE.2)GOTO 200
  5026. C MAX
  5027.     IF(VAR.LE.AC)GOTO 107
  5028.     AC=VAR
  5029.     AACP=KLKC
  5030.     AACQ=KLKR
  5031. 107    CONTINUE
  5032. C    IF(VAR.GT.AC)AC=VAR
  5033.     ACX=AC
  5034.     RETURN
  5035. 200    IF(INDEXF.NE.3)GOTO 300
  5036. C AVG
  5037.     AC=AC+VAR
  5038.     CTR=CTR+1.
  5039.     ACX=AC/CTR
  5040.     RETURN
  5041. 300    IF(INDEXF.NE.4)GOTO 400
  5042. C SUM
  5043.     AC=AC+VAR
  5044.     ACX=AC
  5045.     RETURN
  5046. 400    IF(INDEXF.NE.5)GOTO 500
  5047. C STD (STANDARD DEVIATION SQUARED)
  5048.     AC=AC+VAR
  5049.     SS=SS+(VAR*VAR)
  5050.     CTR=CTR+1.
  5051.     ACX=(SS-((AC*AC)/CTR))/CTR
  5052.     RETURN
  5053. 500    CONTINUE
  5054.     IF(INDEXF.NE.7)GOTO 600
  5055. C AND
  5056.     IF(SS.NE.0.)IWRK1=AC
  5057.     IF(SS.EQ.0.)IWRK1=VAR
  5058.     SS=1.
  5059.     IWRK2=VAR
  5060.     LWRK1=LWRK1.AND.LWRK2
  5061.     AC=IWRK1
  5062.     ACX=AC
  5063.     RETURN
  5064. 600    IF(INDEXF.NE.8)GOTO 700
  5065. C INCLUSIVE OR
  5066.     IWRK1=AC
  5067.     IWRK2=VAR
  5068.     LWRK1=LWRK1.OR.LWRK2
  5069.     AC=IWRK1
  5070.     ACX=AC
  5071.     RETURN
  5072. 700    IF (INDEXF.NE.9)GOTO 800
  5073. C NOT
  5074.     IWRK1=VAR
  5075.     LWRK1=.NOT.LWRK1
  5076.     AC=IWRK1
  5077.     ACX=AC
  5078.     RETURN
  5079. 800    IF(INDEXF.NE.10)GOTO 1000
  5080. C CNT
  5081. C COUNT NONZERO ENTRIES
  5082.     IF(VAR.NE.0.)AC=AC+1.
  5083.     ACX=AC
  5084.     RETURN
  5085. 1000    CONTINUE
  5086.     IF(INDEXF.NE.11)GOTO 1100
  5087. C NPV
  5088.     IF(SS.EQ.0.)GOTO 1050
  5089.     CTR=CTR+1.
  5090. C    AC=AC+VAR*CTR/SS
  5091.     AC=AC+VAR/(SS**(CTR-1))
  5092.     ACX=AC
  5093.     RETURN
  5094. C    GOTO 1200
  5095. 1050    CONTINUE
  5096.     SS=VAR+1.
  5097.     ACX=0.
  5098.     RETURN
  5099. 1100    if(indexf.ne.12) GOTO 1200
  5100. C LKP
  5101.     IF(SS.NE.0.)GOTO 1150
  5102.     SS=1.
  5103.     AC=VAR
  5104.     ACX=-1.
  5105.     RETURN
  5106. C    GOTO 1200
  5107. 1150    CONTINUE
  5108. C    IF(VAR.GE.AC.AND.ACX.LT.0.)ACX=CTR
  5109.     IF(VAR.LT.AC.OR.ACX.GE.0.)GOTO 1155
  5110.     ACX=CTR
  5111.     AACP=KLKC
  5112.     AACQ=KLKR
  5113. 1155    CONTINUE
  5114.     CTR=CTR+1.
  5115.     RETURN
  5116. 1200    CONTINUE
  5117.     IF(INDEXF.NE.13)GOTO 1300
  5118. C LKN
  5119.     IF(SS.NE.0.)GOTO 1250
  5120.     SS=1.
  5121.     AC=VAR
  5122.     ACX=-1.
  5123.     GOTO 1300
  5124. 1250    CONTINUE
  5125. C    IF(VAR.LE.AC.AND.ACX.LT.0.)ACX=CTR
  5126.     IF(VAR.GT.AC.OR.ACX.GT.0.)GOTO 1256
  5127.     ACX=CTR
  5128.     AACP=KLKC
  5129.     AACQ=KLKR
  5130. 1256    CONTINUE
  5131.     CTR=CTR+1.
  5132.     RETURN
  5133. 1300    CONTINUE
  5134.     IF(INDEXF.NE.14)GOTO 1400
  5135. C LKE
  5136.     IF(SS.NE.0.)GOTO 1350
  5137.     SS=1.
  5138.     AC=VAR
  5139.     ACX=-1.
  5140.     GOTO 1400
  5141. 1350    CONTINUE
  5142. C    IF(VAR.EQ.AC.AND.ACX.LT.0.)ACX=CTR
  5143.     IF(VAR.NE.AC.OR.ACX.GE.0.)GOTO 1355
  5144.     ACX=CTR
  5145.     AACP=KLKC
  5146.     AACQ=KLKR
  5147. 1355    CONTINUE
  5148.     CTR=CTR+1.
  5149.     RETURN
  5150. 1400    CONTINUE
  5151.     IF(INDEXF.NE.15)GOTO 1500
  5152. C XOR
  5153.     IF(SS.NE.0)IWRK1=AC
  5154.     IF(SS.EQ.0)IWRK1=VAR
  5155.     SS=SS+1.
  5156.     IF(SS.EQ.1.)GOTO 1405
  5157.     IWRK2=VAR
  5158.     LWRK3=LWRK1.OR.LWRK2
  5159.     LWRK1=LWRK1.AND.LWRK2
  5160.     IWRK1=IWRK3-IWRK1
  5161. 1405    AC=IWRK1
  5162.     ACX=AC
  5163.     RETURN
  5164. 1500    CONTINUE
  5165.     IF(INDEXF.NE.16)GOTO 1600
  5166. C EQV
  5167. C NOTE THE EQUIVALENCE FUNCTION IS JUST THE COMPLEMENT OF
  5168. C THE XOR FUNCTION. DO THE COMPLEMENT VIA THE .NOT. OPERATOR.
  5169.     IF(SS.NE.0)IWRK1=AC
  5170.     IF(SS.EQ.0)IWRK1=VAR
  5171.     SS=SS+1.
  5172.     IF(SS.EQ.1.)GOTO 1505
  5173.     IWRK2=VAR
  5174.     LWRK3=LWRK1.OR.LWRK2
  5175.     LWRK1=LWRK1.AND.LWRK2
  5176.     IWRK1=IWRK3-IWRK1
  5177.     LWRK1=.NOT.LWRK1
  5178. 1505    AC=IWRK1
  5179.     ACX=AC
  5180.     RETURN
  5181. 1600    CONTINUE
  5182.     IF(INDEXF.NE.17)GOTO 1700
  5183. C MOD
  5184. C MODULO (V1 MOD V2)
  5185.     IF(SS.NE.0)RWRK1=AC
  5186.     IF(SS.EQ.0)RWRK1=VAR
  5187.     SS=SS+1.
  5188.     IF(SS.EQ.1.)GOTO 1605
  5189.     RWRK2=VAR
  5190.     RWRK1=DMOD(RWRK1,RWRK2)
  5191. 1605    AC=RWRK1
  5192.     ACX=AC
  5193.     RETURN
  5194. 1700    CONTINUE
  5195.     IF(INDEXF.NE.18)GOTO 1800
  5196. C REMAINDER -- INTEGER MODULO
  5197.     IF(SS.NE.0)IWRK1=AC
  5198.     IF(SS.EQ.0)IWRK1=VAR
  5199.     SS=SS+1.
  5200.     IF(SS.EQ.1.)GOTO 1705
  5201.     IWRK2=VAR
  5202.     IWRK1=JMOD(IWRK1,IWRK2)
  5203. 1705    AC=IWRK1
  5204.     ACX=AC
  5205.     RETURN
  5206. 1800    CONTINUE
  5207.     IF(INDEXF.NE.19)GOTO 1900
  5208. C SGN
  5209. C RETURN 1.0 * SIGN OF ARGUMENT.
  5210.     AC=DSIGN(1.0D0,VAR)
  5211.     ACX=AC
  5212.     RETURN
  5213. 1900    CONTINUE
  5214.     IF(INDEXF.NE.20)GOTO 2000
  5215. C IRR - INTERNAL RATE OF RETURN
  5216.     AC=0.
  5217.     ACX=0.
  5218.     IF(KIRR.LT.20)KIRR=KIRR+1
  5219.     IF(KIRR.EQ.1)PV=VAR
  5220.     IF(KIRR.EQ.2)FV=VAR
  5221.     IF(KIRR.LT.3)RETURN
  5222. C IRRPV,FV,RETURNS...
  5223.     IWRK1=KIRR-2
  5224.     EP(IWRK1)=VAR
  5225.     RWRK1=.15
  5226.     RWRK2=.25
  5227. C ITERATIVELY SOLVE FOR INTERNAL RATE OF RETURN.
  5228. 1903    TE=0.
  5229.     SS=FV/((1.D0+RWRK1)**(IWRK1))
  5230.     DO 1905 IWRK2=1,IWRK1
  5231.     AC=EP(IWRK2)/((1.D0+RWRK1)**IWRK2)
  5232.     SS=SS+AC
  5233. 1905    CONTINUE
  5234.     RWRK2=RWRK1*(SS+TE)/PV
  5235.     IF(DABS(RWRK1-RWRK2).LT..00001)GOTO 1910
  5236.     RWRK1=RWRK2
  5237.     GOTO 1903
  5238. 1910    CONTINUE
  5239.     AC=RWRK2
  5240.     ACX=AC
  5241.     RETURN
  5242. 2000    CONTINUE
  5243.     IF(INDEXF.NE.21)GOTO 2100
  5244. C RND[] - RANDOM NUMBER RETURN
  5245.     AC=RND(IDUM)
  5246.     ACX=AC
  5247.     RETURN
  5248. 2100    CONTINUE
  5249.        IF(INDEXF.NE.22)GOTO 2200
  5250. C PMT FUNCTION
  5251. C PMT[PRINCIPAL, INTEREST, NPERIODS] ARE ARGS
  5252. C PAYMENT (MORTGAGE PAYMENT PER PERIOD
  5253. C COMPUTED AS PAYMENT=PRINCIPAL*(INTEREST/(1-(1+INTEREST)**NPERIODS))
  5254. C (CORRECT EVEN IF INTEREST=0
  5255. C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
  5256.     AC=0.
  5257.     ACX=0.
  5258.     KIRR=KIRR+1
  5259.     EP(KIRR)=VAR
  5260.     IF(KIRR.LT.3)RETURN
  5261. C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
  5262.     AC=EP(1)*(EP(2)/(1.-((1.+EP(2))**(-EP(3)))))
  5263.     ACX=AC
  5264.     RETURN
  5265. 2200    CONTINUE
  5266.     IF(INDEXF.NE.23)GOTO 2300
  5267. C PVL FUNCTION
  5268. C PVL[PAYMENT,INTEREST,NPERIODS] ARE ARGS
  5269. C PRESENT VALUE COMPUTED AS
  5270. C PV=PAYMENT*(1.-(1.+INTEREST)**-NPERIODS)/INTEREST
  5271. C (REUSE COUNTER USED IN IRR ARGUMENTS HERE)
  5272.     AC=0.
  5273.     ACX=0.
  5274.     KIRR=KIRR+1
  5275.     EP(KIRR)=VAR
  5276.     IF(KIRR.LT.3)RETURN
  5277. C FIRST GET ALL THE INPUTS, THEN DO THE REAL RESULT.
  5278.     AC=EP(1)*EP(3)
  5279.     IF(EP(3).EQ.0..OR.EP(2).EQ.0.)GOTO 2205
  5280.     AC=EP(1)*((1.-(1.+EP(2))**(-EP(3)))/EP(2))
  5281. 2205    ACX=AC
  5282.     RETURN
  5283. 2300    CONTINUE
  5284.     IF(INDEXF.NE.24)GOTO 2400
  5285. C AVE AVERAGE EXCLUDING ZERO CELLS
  5286.     IF(VAR.EQ.0.)GOTO 2305
  5287.     AC=AC+VAR
  5288.     CTR=CTR+1.
  5289. 2305    ACX=AC/DMAX1(CTR,1.0D0)
  5290.     RETURN
  5291. 2400    CONTINUE
  5292.     IF(INDEXF.NE.25)GOTO 2500
  5293. C CHS
  5294. C CHOOSE FROM ARGS USING 1ST ARG AS COUNT INTO RANGE...
  5295. C (SIMILAR TO CLASSICAL "CHOOSE" FUNCTION...)
  5296. C RETURNS 0.0 OR VALUE OF NTH ARG WHERE N IS INDEX OF ARG...
  5297. C    IF(KIRR.EQ.0)ACX=0.
  5298.     KIRR=KIRR+1
  5299.     IF(KIRR.EQ.1)IWRK1=VAR+1.
  5300.     IF(KIRR.NE.IWRK1)GOTO 2450
  5301. C SAVE LOCATION ALSO OF CELLS.
  5302. C THIS ALLOWS US TO FIND ADDRESSES OF SELECTED CELLS IN CHOOSE FOR ADDRESS MATH.
  5303.     AACP=KLKC
  5304.     AACQ=KLKR
  5305.     SS=VAR
  5306. 2450    CONTINUE
  5307.     ACX=SS
  5308.     AC=ACX
  5309.     RETURN
  5310. 2500    CONTINUE
  5311.     IF(INDEXF.NE.26)GOTO 2600
  5312. C ATM ARCTAN OF 2 ARGS
  5313.     IF(SS.NE.0.)RWRK1=AC
  5314.     IF(SS.EQ.0.)RWRK1=VAR
  5315.     SS=SS+1.
  5316.     IF(SS.LE.1.1)GOTO 2505
  5317.     RWRK2=VAR
  5318. C GET 4 QUADRANT ARCTAN
  5319.     RWRK1=DATAN2(RWRK1,RWRK2)
  5320. 2505    AC=RWRK1
  5321.     ACX=AC
  5322.     RETURN
  5323. 2600    CONTINUE
  5324.     RETURN
  5325.     END
  5326. c -h- domfcn.for    Fri Aug 22 13:03:40 1986    
  5327.     SUBROUTINE DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
  5328. C LLB = LOC OF
  5329. C LRB = LOC OF
  5330. C INDEXF IS AS ABOVE. GUARANTEED IN RANGE 1-5.
  5331.     INCLUDE aparms.inc
  5332.     CHARACTER*1 LINE(110)
  5333. C +++++++++++++++++++++++++++++++++++
  5334. C PARAMETER 18060=60*301
  5335.     CHARACTER*1 FVLD
  5336.     EXTERNAL INDX
  5337. c    INTEGER*4 VNLT
  5338.     DIMENSION FVLD(1,1)
  5339. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  5340. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  5341. C SO INITIALLY IGNORE.
  5342. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5343. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5344.     InTeGer*4 RRWACT,RCLACT
  5345. C    COMMON/RCLACT/RRWACT,RCLACT
  5346.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5347.      1  IDOL7,IDOL8
  5348. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5349. C     1  IDOL7,IDOL8
  5350.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5351. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5352.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5353. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5354. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5355. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5356.     InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kshtf
  5357. C    COMMON/KLVL/KLVL
  5358.     InTeGer*4 IOLVL,IGOLD
  5359. C    COMMON/IOLVL/IOLVL
  5360. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5361. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5362.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5363.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5364.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5365.      3  k3dfg,kcdelt,krdelt,kshtf
  5366. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5367. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5368. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5369. c     3  K3DFG,KCDelt,KRDelt,kpag
  5370.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  5371.     COMMON/D2R/NRDSP,NCDSP
  5372.     InTeGer*4 TYPE(1,2),VLEN(9)
  5373.     REAL*8 XVBLS(1,1)
  5374.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  5375.     Real*8 VAVBLS(3,27)
  5376.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  5377.     INTEGER*4 JVBLS(2,1,1)
  5378.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  5379.     REAL*8 XXX
  5380.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  5381.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  5382.     REAL*8 ACX,ACY
  5383.     REAL*8 AC,SS,CTR
  5384.     EQUIVALENCE(ACY,AVBLS(1,27))
  5385.     InTeGer*4 DLFG
  5386. C    COMMON/DLFG/DLFG
  5387.     InTeGer*4 KDRW,KDCL
  5388. C    COMMON/DOT/KDRW,KDCL
  5389.     InTeGer*4 DTRENA
  5390. C    COMMON/DTRCMN/DTRENA
  5391.     REAL*8 EP,PV,FV
  5392.     DIMENSION EP(20)
  5393.     INTEGER*4 KIRR
  5394. C    COMMON/ERNPER/EP,PV,FV,KIRR
  5395.     InTeGer*4 LASTOP
  5396. C    COMMON/ERROR/LASTOP
  5397.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  5398. C    COMMON/FMTBFR/FMTDAT
  5399.     CHARACTER*1 EDNAM(16)
  5400. C    COMMON/EDNAM/EDNAM
  5401.     InTeGer*4 MFID(2),MFMOD(2)
  5402. C    COMMON/FRM/MFID,MFMOD
  5403.     InTeGer*4 JMVFG,JMVOLD
  5404. C    COMMON/FUBAR/JMVFG,JMVOLD
  5405.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  5406.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  5407. CCC    InTeGer*4 KDRW,KDCL
  5408. CCC    COMMON /DOT/KDRW,KDCL
  5409.     CHARACTER*1 ILINE(106)
  5410.     InTeGer*4 ILNFG,ILNCT
  5411.     COMMON/ILN/ILNFG,ILNCT,ILINE
  5412.     COMMON/FVLDC/FVLD
  5413.     InTeGer*4 ICREF,IRREF
  5414. C    COMMON/MIRROR/ICREF,IRREF
  5415.     InTeGer*4 MODPUB,LIMODE
  5416. C    COMMON/MODPUB/MODPUB,LIMODE
  5417.     InTeGer*4 KLKC,KLKR
  5418.     REAL*8 AACP,AACQ
  5419. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  5420.     InTeGer*4 NCEL,NXINI
  5421. C    COMMON/NCEL/NCEL,NXINI
  5422.     CHARACTER*1 NAMARY(20,MROWS)
  5423. C    COMMON/NMNMNM/NAMARY
  5424.     InTeGer*4 NULAST,LFVD
  5425. C    COMMON/NULXXX/NULAST,LFVD
  5426.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  5427.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  5428. CCC    InTeGer*4 KLKC,KLKR
  5429.     REAL*8 ACP,ACQ
  5430. CCC    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  5431.     EQUIVALENCE(ACP,AVBLS(1,16)),(ACQ,AVBLS(1,17))
  5432. C +++++++++++++++++++++++++++++++++++
  5433. C
  5434. C FIRST GET A VARIABLE NAME. ALL MATH FUNCTIONS REQUIRE VARIABLE
  5435. C NAMES SINCE THEIR VARIABLES ARE THEIR ONLY VALID ARGS.
  5436.     CALL MTHINI(INDEXF,AC,SS,CTR,ACX)
  5437. C SET UP PROPER INITS
  5438. C KV2=1 IF A 2ND VBL EXISTS
  5439.     LCR=LLB+1
  5440.     AACP=ACP
  5441.     AACQ=ACQ
  5442. C INIT SAVED P, Q AC'S HERE IN CASE DOMATH MODIFIES...
  5443. C THIS ALLOWS SELECTION FUNCTIONS TO SET COL, ROW IN P AND Q AC.
  5444. 100    CONTINUE
  5445.     KV2=0
  5446.     LB=LCR
  5447.     LE=LRB-1
  5448.     IF(LB.GE.LE)RETURN
  5449.     CALL VARSCN(LINE,LB,LE,LASST,ID1,ID2,IVALID)
  5450.     IF(IVALID.EQ.0)RETURN
  5451. C USE extra cell to check for different sheets, same row/col
  5452. C use separator of } to indicate range is depth.
  5453.     KPG1=KSHTF
  5454.     KDEPSP=0
  5455.     if(Line(Lasst).eq.'}')Goto 8601
  5456.     IF(LINE(LASST).NE.':')GOTO 110
  5457.     Goto 8603
  5458. 8601    Continue
  5459.     KDepsp=1
  5460. 8603    Continue
  5461.     LB=LASST+1
  5462.     LE=LRB-1
  5463.     CALL VARSCN(LINE,LB,LE,LASST,ID1B,ID2B,IVALID)
  5464.     IF(IVALID.NE.0)KV2=1
  5465.     KPG2=KSHTF
  5466.     If(KDepsp.ne.1)goto 8604
  5467.     KDp=0
  5468.     If (kv2.eq.0)goto 8606
  5469.     KDp=kpg2-kpg1
  5470. C KDp is depth to go through. If negative set to zero.
  5471.     if(KDp.lt.0)kdp=0
  5472. 8606    Continue
  5473. 8605    Continue
  5474.     CALL XVBLGT(ID1,ID2,XVBLS(1,1))
  5475.     XXX=XVBLS(1,1)
  5476.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  5477. C USE EQUIVALENCE OF JVBLS AND XVBLS
  5478.     IF(ABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5479.     KLKC=ID1
  5480.     KLKR=ID2-1
  5481.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5482.     id1=id1+kcdelt
  5483.     id2=id2+krdelt
  5484.     kdp=kdp-1
  5485. C Handle all math over the depth argument.
  5486. C (Only partially decode; if argument is ill-formed
  5487. C  then just act as if range were directly below the
  5488. C  top cell.)
  5489.     if(KDp.ge.0)goto 8605
  5490.     GoTo 200
  5491. 8604    Continue
  5492. 110    CONTINUE
  5493.     CALL XVBLGT(ID1,ID2,XVBLS(1,1))
  5494.     XXX=XVBLS(1,1)
  5495. C    XXX=XVBLS(ID1,ID2)
  5496.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  5497. C USE EQUIVALENCE OF JVBLS AND XVBLS
  5498.     IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5499.     KLKC=ID1
  5500.     KLKR=ID2-1
  5501.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5502.     IF(KV2.EQ.0)GOTO 200
  5503.     IF(ID1.NE.ID1B) GOTO 120
  5504.     IF(ID2.GT.ID2B)GOTO 200
  5505.     M=ID2+1
  5506.     DO 121 MM=M,ID2B
  5507.     CALL XVBLGT(ID1,MM,XVBLS(1,1))
  5508.     XXX=XVBLS(1,1)
  5509.     CALL TYPGET(ID1,MM,TYPE(1,1))
  5510. C    XXX=XVBLS(ID1,MM)
  5511.     IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5512.     KLKC=ID1
  5513.     KLKR=MM-1
  5514.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5515. 121    CONTINUE
  5516.     GOTO 200
  5517. 120    CONTINUE
  5518.     IF(ID2.NE.ID2B)GOTO 130
  5519.     IF(ID1.GT.ID1B)GOTO 200
  5520.     M=ID1+1
  5521.     DO 131 MM=M,ID1B
  5522.     CALL XVBLGT(MM,ID2,XVBLS(1,1))
  5523.     XXX=XVBLS(1,1)
  5524. C    XXX=XVBLS(MM,ID2)
  5525.     CALL TYPGET(MM,ID2,TYPE(1,1))
  5526.     IF(IABS(TYPE(1,1)).NE.2)XXX=JVBLS(1,1,1)
  5527.     KLKC=MM
  5528.     KLKR=ID2-1
  5529.     CALL DOMATH(INDEXF,XXX,AC,SS,CTR,ACX)
  5530. 131    CONTINUE
  5531. 130    CONTINUE
  5532. 200    CONTINUE
  5533. C IF NEXT CHAR IS A COMMA, SKIP IT AND KEEP UP SCAN UNLESS DONE
  5534.     IF(LINE(LASST).EQ.',')GOTO 300
  5535.     ACP=AACP
  5536.     ACQ=AACQ
  5537. C USE P, Q ACCUMULATORS FOR SELECTED COL, ROW COORDS FROM DOMATH
  5538.     RETURN
  5539. 300    LCR=LASST+1
  5540.     GOTO 100
  5541.     END
  5542. c -h- dostmi.for    Fri Aug 22 13:03:55 1986    
  5543.     SUBROUTINE DOSTMI(LINE,LLAST)
  5544. C COPY OF DOSTMT FOR IF FUNCTION.
  5545. C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
  5546. C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
  5547.     CHARACTER*1 LINE(110)
  5548.     Include aparms.inc
  5549. C +++++++++++++++++++++++++++++++++++
  5550. C PARAMETER 18060=60*301
  5551.     EXTERNAL INDX
  5552.     CHARACTER*1 FVLD
  5553. c    INTEGER*4 VNLT
  5554.     DIMENSION FVLD(1,1)
  5555. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  5556. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  5557. C SO INITIALLY IGNORE.
  5558.     COMMON/FVLDC/FVLD
  5559. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5560. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5561.     InTeGer*4 RRWACT,RCLACT
  5562. C    COMMON/RCLACT/RRWACT,RCLACT
  5563.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5564.      1  IDOL7,IDOL8
  5565. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5566. C     1  IDOL7,IDOL8
  5567.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5568. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5569.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5570. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5571. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5572. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5573.     InTeGer*4 KLVL
  5574. C    COMMON/KLVL/KLVL
  5575.     InTeGer*4 IOLVL,IGOLD
  5576. C    COMMON/IOLVL/IOLVL
  5577. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5578. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5579.  
  5580.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5581.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5582.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5583.      3  k3dfg,kcdelt,krdelt,kpag
  5584. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5585. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5586. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  5587.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  5588.     COMMON/D2R/NRDSP,NCDSP
  5589.     InTeGer*4 TYPE(1,2),VLEN(9)
  5590.     REAL*8 XVBLS(1,1)
  5591.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  5592.     Real*8 VAVBLS(3,27)
  5593.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  5594.     INTEGER*4 JVBLS(2,1,1)
  5595.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  5596.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  5597.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  5598.     REAL*8 ACY,AACY
  5599.     INTEGER*4 IACY,IIJACY
  5600.     EQUIVALENCE(IIJACY,AACY)
  5601.     EQUIVALENCE(IACY,AVBLS(1,27))
  5602.     EQUIVALENCE(ACY,AVBLS(1,27))
  5603.     InTeGer*4 DLFG
  5604. C    COMMON/DLFG/DLFG
  5605.     InTeGer*4 KDRW,KDCL
  5606. C    COMMON/DOT/KDRW,KDCL
  5607.     InTeGer*4 DTRENA
  5608. C    COMMON/DTRCMN/DTRENA
  5609.     REAL*8 EP,PV,FV
  5610.     DIMENSION EP(20)
  5611.     INTEGER*4 KIRR
  5612. C    COMMON/ERNPER/EP,PV,FV,KIRR
  5613.     InTeGer*4 LASTOP
  5614. C    COMMON/ERROR/LASTOP
  5615.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  5616. C    COMMON/FMTBFR/FMTDAT
  5617.     CHARACTER*1 EDNAM(16)
  5618. C    COMMON/EDNAM/EDNAM
  5619.     InTeGer*4 MFID(2),MFMOD(2)
  5620. C    COMMON/FRM/MFID,MFMOD
  5621.     InTeGer*4 JMVFG,JMVOLD
  5622. C    COMMON/FUBAR/JMVFG,JMVOLD
  5623.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  5624.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  5625. CCC    InTeGer*4 KDRW,KDCL
  5626. CCC    COMMON /DOT/KDRW,KDCL
  5627.     CHARACTER*1 ILINE(106)
  5628.     InTeGer*4 ILNFG,ILNCT
  5629.     COMMON/ILN/ILNFG,ILNCT,ILINE
  5630. C +++++++++++++++++++++++++++++++++++
  5631.     CALL FNAME(LINE,LLAST,INDEXF)
  5632. C ABOVE GETS FUNCTION NAMES.
  5633. C    NAME    INDEXF
  5634. C    MIN    1
  5635. C    MAX    2
  5636. C    AVG    3
  5637. C    SUM    4
  5638. C    STD    5    (STD DEVIATION)
  5639. C    IF    6    (IF STMT)
  5640. C    AND    7
  5641. C    OR    8
  5642. C    NOT    9
  5643. C    CNT    10 (COUNTS NONZERO ENTRIES)
  5644. C    NPV    11 NET PRESENT VALUE
  5645. C    LKP    12 LOOKUP IN LIST, GIVE OFFSET 0 BASED
  5646. C    LKN    13    LOOKUP NEGATIVE (INVERSE OF LKP)
  5647. C    LKE    14    LOOKUP EQUAL
  5648. C    XOR    15    EXCLUSIVE OR
  5649. C    EQV    16    EQUIVALENCE (TRUE IF BITS EQUAL)
  5650. C    MOD    17    V1 MODULO V2
  5651. C    REM    18    REMAINDER OF V1/V2
  5652. C    SGN    19    SIGN OF V1 (-1.,0., OR +1.)
  5653. C    IRR    20    INTERNAL RATE OF RETURN
  5654. C USE  AND  TO DELIMIT FUNCTION ARGS.
  5655. C *****************************************************************************
  5656. C **** NOTE: MAX 20 IS KEPT AS A LITERAL IN NEXTEL ALSO AS FLAG THAT FUNCTION
  5657. C **** FAILED TO FIND VALID LITERAL. CHANGE THERE TOO IF YOU ADD MORE FUNCTIONS.
  5658.     IF(INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 1000
  5659. C HERE IF A FUNCTION OR AN IF STMT (FORMAT= IF varRELvarstmt|else-stmt)
  5660. C
  5661. C ALLOW CALC TO HANDLE ALL BUT IF STMTS
  5662.     IF(INDEXF.NE.6)GOTO 1000
  5663. C
  5664. C **** FIXUP '' NEXT. 2 LINES. REPLACE HERE... ***
  5665.     KKK=ICHAR('[')
  5666.     LLB=INDX(LINE,KKK)
  5667.     KKK=ICHAR(']')
  5668.     LRB=INDX(LINE,KKK)
  5669. C *** ERROR WITH FORMAT -- NO  SEEN IN TIME. JUST IGNORE IT.
  5670.     IF(LLB.GT.LLAST)RETURN
  5671.     IF(LRB.GT.LLAST)LRB=LLAST
  5672. C ** COMMENT OUT NEVER-USED CODE NEXT AREA...
  5673. C
  5674. C    IF(INDEXF.EQ.6)GOTO 2000
  5675. CC ISOLATE MATH FUNCTIONS
  5676. C    CALL DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
  5677. CC GET % ABOVE
  5678. C    CALL TYPGET(KDRW,KDCL,TYPE(1,1))
  5679. C    IF(IABS(TYPE(1,1)).NE.2)GOTO 1760
  5680. C    CALL XVBLST(KDRW,KDCL,ACX)
  5681. CC    XVBLS(KDRW,KDCL)=ACX
  5682. CC LEAVE RESULT IN % TOO.
  5683. C    ACY=ACX
  5684. C    CALL TYPSET(27,1,TYPE(1,1))
  5685. CC    TYPE(27,1)=TYPE(KDRW,KDCL)
  5686. C    RETURN
  5687. C1760    JVBLS(1,1,1)=ACX
  5688. C    CALL JVBLST(1,KDRW,KDCL,JVBLS(1,1,1))
  5689. CC    JVBLS(1,KDRW,KDCL)=ACX
  5690. C    RETURN
  5691. 2000    CONTINUE
  5692. C HANDLE AN "IF" STATEMENT
  5693. C ILLEGAL HERE INSIDE AN IF, SO JUST IGNORE IT.
  5694. C    CALL DOIF(LINE,LLB,LRB,LLAST)
  5695. C PASS LLAST TO DOIF SINCE WE DON'T EXPECT ] AS LAST CHAR OF STMT.
  5696. C NO DIRECT SET OF VRBL HERE...
  5697.     RETURN
  5698. 1000    CONTINUE
  5699. C HERE JUST HAVE SOMETHING TO PASS TO CALC. DO SO.
  5700.     ILNFG=1
  5701.     LMX=LLAST-1
  5702.     DO 1001 N1=1,LMX
  5703. 1001    ILINE(N1)=LINE(N1)
  5704.     ILNCT=LMX
  5705. C PROTECT CALC FROM ANY PART OF A LINE LONGER THAN 80 CHARS (ITS MAX)
  5706.     IF(ILNCT.GT.80)ILNCT=80
  5707.     CALL CALC
  5708. C STORE EXPRESSION RESULT.
  5709. C CONVERT BETWEEN TYPES FIRST IF NEED BE
  5710.     CALL TYPGET(KDRW,KDCL,LMX)
  5711.     CALL TYPGET(27,1,N1)
  5712.     LMX=IABS(LMX)
  5713.     N1=IABS(N1)
  5714.     IF(N1.EQ.1.OR.(N1.GE.3.AND.N1.LE.8))GOTO 8739
  5715.     N1=2
  5716.     GOTO 8740
  5717. 8739    CONTINUE
  5718.     N1=4
  5719. 8740    CONTINUE
  5720. C ONLY CONCERN HERE IS REAL TYPES (CODE=2) AND INT TYPES (CODE=4)
  5721.     AACY=ACY
  5722.     IF(N1.EQ.LMX)GOTO 2670
  5723.     IF(N1.EQ.2)IIJACY=ACY
  5724.     IF(N1.EQ.4)AACY=IACY
  5725. C DO WHICHEVER CONVERSION IS NEEDED IF ONE IS NEEDED AT ALL.
  5726. 2670    CONTINUE
  5727.     CALL XVBLST(KDRW,KDCL,AACY)
  5728. C    XVBLS(KDRW,KDCL)=ACY
  5729.     RETURN
  5730.     END
  5731. c -h- dostmt.for    Fri Aug 22 13:03:55 1986    
  5732.     SUBROUTINE DOSTMT(LINE,LLAST)
  5733. C HANDLE 1 STATEMENT PARSING (DOES A BIT MORE OF THE WORK WITH THE
  5734. C PART OF THE LINE STRIPPED TO HAVE EXACTLY ONE COMMAND IN IT.
  5735.     CHARACTER*1 LINE(110)
  5736.     Include aparms.inc
  5737. C +++++++++++++++++++++++++++++++++++
  5738.     CHARACTER*1 FVLD
  5739.     EXTERNAL INDX
  5740. c    INTEGER*4 VNLT
  5741.     DIMENSION FVLD(1,1)
  5742. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  5743. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  5744. C SO INITIALLY IGNORE.
  5745.     COMMON/FVLDC/FVLD
  5746.     InTeGer*4 RRWACT,RCLACT
  5747. C    COMMON/RCLACT/RRWACT,RCLACT
  5748.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5749.      1  IDOL7,IDOL8
  5750. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5751. C     1  IDOL7,IDOL8
  5752.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5753. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5754.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5755. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5756. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5757. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5758.     InTeGer*4 KLVL
  5759. C    COMMON/KLVL/KLVL
  5760.     InTeGer*4 IOLVL,IGOLD
  5761. C    COMMON/IOLVL/IOLVL
  5762. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5763. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5764.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5765.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5766.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5767.      3  k3dfg,kcdelt,krdelt,kpag
  5768. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5769. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5770. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  5771. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5772. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5773.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  5774.     COMMON/D2R/NRDSP,NCDSP
  5775.     InTeGer*4 TYPE(1,2),VLEN(9)
  5776.     REAL*8 XVBLS(1,1)
  5777.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  5778.     Real*8 VAVBLS(3,27)
  5779.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  5780.     INTEGER*4 JVBLS(2,1,1)
  5781.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  5782.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  5783.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  5784.     REAL*8 ACY,AACY
  5785.     INTEGER*4 IACY,IIJACY
  5786.     EQUIVALENCE(IACY,AVBLS(1,27))
  5787.     EQUIVALENCE(ACY,AVBLS(1,27))
  5788.     EQUIVALENCE(IIJACY,AACY)
  5789.     InTeGer*4 DLFG
  5790. C    COMMON/DLFG/DLFG
  5791.     InTeGer*4 KDRW,KDCL
  5792. C    COMMON/DOT/KDRW,KDCL
  5793.     InTeGer*4 DTRENA
  5794. C    COMMON/DTRCMN/DTRENA
  5795.     REAL*8 EP,PV,FV
  5796.     DIMENSION EP(20)
  5797.     INTEGER*4 KIRR
  5798. C    COMMON/ERNPER/EP,PV,FV,KIRR
  5799.     InTeGer*4 LASTOP
  5800. C    COMMON/ERROR/LASTOP
  5801.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  5802. C    COMMON/FMTBFR/FMTDAT
  5803.     CHARACTER*1 EDNAM(16)
  5804. C    COMMON/EDNAM/EDNAM
  5805.     InTeGer*4 MFID(2),MFMOD(2)
  5806. C    COMMON/FRM/MFID,MFMOD
  5807.     InTeGer*4 JMVFG,JMVOLD
  5808. C    COMMON/FUBAR/JMVFG,JMVOLD
  5809.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  5810.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  5811. CCC    InTeGer*4 KDRW,KDCL
  5812. CCC    COMMON /DOT/KDRW,KDCL
  5813.     CHARACTER*1 ILINE(106)
  5814.     InTeGer*4 ILNFG,ILNCT
  5815.     COMMON/ILN/ILNFG,ILNCT,ILINE
  5816.  
  5817. C +++++++++++++++++++++++++++++++++++
  5818.     CALL FNAME(LINE,LLAST,INDEXF)
  5819. C ABOVE GETS FUNCTION NAMES.
  5820. C    NAME    INDEXF
  5821. C    MIN    1
  5822. C    MAX    2
  5823. C    AVG    3
  5824. C    SUM    4
  5825. C    STD    5    (STD DEVIATION)
  5826. C    IF    6    (IF STMT)
  5827. C    AND    7
  5828. C    OR    8
  5829. C    NOT    9
  5830. C    CNT    10 (COUNTS NONZERO ENTRIES)
  5831. C    NPV    11 NET PRESENT VALUE
  5832. C    LKP    12 LOOKUP IN LIST, GIVE OFFSET 0 BASED
  5833. C    LKN    13    LOOKUP NEGATIVE (INVERSE OF LKP)
  5834. C    LKE    14    LOOKUP EQUAL
  5835. C    XOR    15    EXCLUSIVE OR
  5836. C    EQV    16    EQUIVALENCE (TRUE IF BITS EQUAL)
  5837. C    MOD    17    V1 MODULO V2
  5838. C    REM    18    REMAINDER OF V1/V2
  5839. C    SGN    19    SIGN OF V1 (-1.,0., OR +1.)
  5840. C    IRR    20    INTERNAL RATE OF RETURN
  5841. C    RND    21    RANDOM NUMBER BETWEEN 0 AND 1.
  5842. C    PMT    22    PAYMENT FUNCTION
  5843. C    PVL    23    PRESENT VALUE
  5844. C    AVE    24    AVEREAGE EXCLUDING ZERO CELLS
  5845. C    CHS    25    CHOOSE
  5846. C    ATM    26    ARC TAN OF MULTIPLE ARGS (2 ARGS)
  5847. C USE  AND  TO DELIMIT FUNCTION ARGS.
  5848. C *****************************************************************************
  5849. C **** NOTE: MAX 26 IS KEPT AS A LITERAL IN NEXTEL ALSO AS FLAG THAT FUNCTION
  5850. C **** FAILED TO FIND VALID LITERAL. CHANGE THERE TOO IF YOU ADD MORE FUNCTIONS.
  5851.     IF(INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 1000
  5852. C HERE IF A FUNCTION OR AN IF STMT (FORMAT= IF varRELvarstmt|else-stmt)
  5853. C
  5854. C ALLOW CALC TO HANDLE ALL BUT IF STMTS
  5855.     IF(INDEXF.NE.6)GOTO 1000
  5856. C
  5857.     KKK=ICHAR('[')
  5858.     LLB=INDX(LINE,KKK)
  5859.     KKK=ICHAR(']')
  5860.     LRB=INDX(LINE,KKK)
  5861. C *** ERROR WITH FORMAT -- NO  SEEN IN TIME. JUST IGNORE IT.
  5862.     IF(LLB.GT.LLAST)RETURN
  5863.     IF(LRB.GT.LLAST)LRB=LLAST
  5864. C *** NOTA BENE
  5865. C NEXT STUFF COMMENTED BECAUSE WE CAN NEVER EXECUTE IT...
  5866. C    IF(INDEXF.EQ.6)GOTO 2000
  5867. CC ISOLATE MATH FUNCTIONS
  5868. C    CALL DOMFCN(LINE,LLB,LRB,INDEXF,ACX)
  5869. CC GET % ABOVE
  5870. C    CALL TYPGET(KDRW,KDCL,TYPE(1,1))
  5871. C    IF(IABS(TYPE(1,1)).NE.2)GOTO 1760
  5872. C    CALL XVBLST(KDRW,KDCL,ACX)
  5873. CC    XVBLS(KDRW,KDCL)=ACX
  5874. CC LEAVE RESULT IN % TOO.
  5875. C    ACY=ACX
  5876. C    CALL TYPSET(27,1,TYPE(1,1))
  5877. CC    TYPE(27,1)=TYPE(KDRW,KDCL)
  5878. C    RETURN
  5879. C1760    JVBLS(1,1,1)=ACX
  5880. C    CALL JVBLST(1,KDRW,KDCL,JVBLS(1,1,1))
  5881. CC    JVBLS(1,KDRW,KDCL)=ACX
  5882. C    RETURN
  5883. 2000    CONTINUE
  5884. C HANDLE AN "IF" STATEMENT
  5885.     CALL DOIF(LINE,LLB,LRB,LLAST)
  5886. C PASS LLAST TO DOIF SINCE WE DON'T EXPECT  AS LAST CHAR OF STMT.
  5887. C NO DIRECT SET OF VRBL HERE...
  5888.     RETURN
  5889. 1000    CONTINUE
  5890. C HERE JUST HAVE SOMETHING TO PASS TO CALC. DO SO.
  5891.     ILNFG=1
  5892.     LMX=LLAST-1
  5893.     DO 1001 N1=1,LMX
  5894. 1001    ILINE(N1)=LINE(N1)
  5895.     ILNCT=LMX
  5896. C PROTECT CALC FROM ANY PART OF A LINE LONGER THAN 80 CHARS (ITS MAX)
  5897.     IF(ILNCT.GT.80)ILNCT=80
  5898.     CALL CALC
  5899. C STORE EXPRESSION RESULT.
  5900. C FIRST BE SURE STORING RIGHT TYPE
  5901.     CALL TYPGET(KDRW,KDCL,LMX)
  5902. C ONLY WORRY HERE ABOUT INTEGER VS REAL (INT=4, REAL=2 CODE)
  5903.     CALL TYPGET(27,1,N1)
  5904.     N1=IABS(N1)
  5905.     LMX=IABS(LMX)
  5906. C LET ALL DEFAULT TO TYPE 2 (FLOATING) EXCEPT EXPLICIT INTS
  5907.     IF((N1.EQ.1).OR.(N1.GE.3.AND.N1.LE.8))GOTO 2739
  5908.     N1=2
  5909.     GOTO 2740
  5910. 2739    CONTINUE
  5911.     N1=4
  5912. 2740    CONTINUE
  5913.     AACY=ACY
  5914.     IF((N1).EQ.(LMX))GOTO 2670
  5915. C TYPES DIFFER. CONVERT BETWEEN ACY AND IACY.
  5916.     IF((N1).EQ.4)AACY=IACY
  5917.     IF((N1).EQ.2)IIJACY=ACY
  5918. 2670    CONTINUE
  5919.     CALL XVBLST(KDRW,KDCL,AACY)
  5920. C    XVBLS(KDRW,KDCL)=ACY
  5921.     RETURN
  5922.     END
  5923. c -h- dspfil.for    Fri Aug 22 13:04:12 1986    
  5924.     SUBROUTINE DSPFIL(ICODE,FORM,FORM2,FVLDTP,
  5925.      1  LFTMST,LENTL,LOCOL,FILINE,LLVL,LLU,LLVLF,J)
  5926. C COPYRIGHT (C) 1983 GLENN EVERHART
  5927. C ALL RIGHTS RESERVED
  5928. C DISPLAY SPREAD SHEET ON SCREEN OR IN FILE IF ICODE=10
  5929.     Include aparms.inc
  5930. C USES UVT100 TO TWEAK THE VT100. NO WRAP IS ASSUMED SO
  5931. C OUTPUT UP TO 132 COLS BY 24 LINES IS OK. ONLY CHECK
  5932. C WIDTH TO ALLOW VT100 LOOKALIKES WITH MORE DISPLAY LINES TOO.
  5933. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  5934. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  5935. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  5936. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  5937. C FROM THE DISK BASED FILE HERE.
  5938. C    CHARACTER*127 CWRK
  5939. C    CHARACTER*1 CCWRK(128)
  5940.     InTeGer*4 ICODE,LFTMST
  5941. C    EQUIVALENCE(CWRK,CCWRK(1))
  5942.     InTeGer*4 LLU,LLVL,LLVLF
  5943.     InTeGer*4 RRWACT,RCLACT
  5944. C    COMMON/RCLACT/RRWACT,RCLACT
  5945.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  5946.      1  IDOL7,IDOL8
  5947. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  5948. C     1  IDOL7,IDOL8
  5949.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  5950. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  5951.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5952. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  5953. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  5954. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  5955.     InTeGer*4 KLVL
  5956. C    COMMON/KLVL/KLVL
  5957.     InTeGer*4 IOLVL,IGOLD
  5958. C    COMMON/IOLVL/IOLVL
  5959. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  5960. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  5961.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5962.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5963.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  5964.      3  k3dfg,kcdelt,krdelt,kpag
  5965. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  5966. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  5967. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  5968. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  5969. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  5970.     EXTERNAL INDX
  5971.     CHARACTER*7 PRTLX
  5972.     CHARACTER*1 FORM,FVLD,PRTLIN(132)
  5973.     EQUIVALENCE(PRTLX(1:1),PRTLIN(1))
  5974. C    INTEGER*4 VNLT
  5975.     CHARACTER*1 FVLDTP
  5976. c    CHARACTER*1 LBEL(4)
  5977.     CHARACTER*1 FORM2(128),NMSH(80)
  5978.     COMMON/NMSH/NMSH
  5979. C FLAG BORDR=1 IF WE WANT TO OMIT BORDERS ON DRAWING
  5980. C THE SCREEN DISPLAY TO A FILE.
  5981. c    InTeGer*4 BORDR,TOMT
  5982. C COMMON ICPOS ALLOWS UVT100 ROUTINE ACCESS TO DISPLAYED NUMBERS
  5983. C FOR USES SUCH AS SETTING COLORS...
  5984.     CHARACTER*1 OARRY(100)
  5985.     InTeGer*4 OSWIT,OCNTR
  5986. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  5987. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  5988.     InTeGer*4 IPS1,IPS2,MODFLG
  5989. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  5990.        InTeGer*4 XTCFG,IPSET,XTNCNT
  5991.        CHARACTER*1 XTNCMD(80)
  5992. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  5993. C VARY FLAG ITERATION COUNT
  5994.     INTEGER KALKIT
  5995. C    COMMON/VARYIT/KALKIT
  5996.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  5997.     InTeGer*4 RCMODE,IRCE1,IRCE2
  5998. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  5999. C     1  IRCE2
  6000. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  6001. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  6002. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  6003. C RCFGX ON.
  6004. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  6005. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  6006. C  AND VM INHIBITS. (SETS TO 1).
  6007.     INTEGER*4 FH
  6008. C FILE HANDLE FOR CONSOLE I/O (RAW)
  6009. C    COMMON/CONSFH/FH
  6010.     CHARACTER*1 ARGSTR(52,4)
  6011. C    COMMON/ARGSTR/ARGSTR
  6012.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  6013.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  6014.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  6015.      3  IRCE2,FH,ARGSTR
  6016. CCC    InTeGer*4 IC1POS,IC2POS
  6017. CCC    COMMON/ICPOS/IC1POS,IC2POS
  6018.     REAL*8 XVBLS(1,1)
  6019.     CHARACTER*1 DFE(14)
  6020.     CHARACTER*14 CDFE
  6021.     EQUIVALENCE(CDFE(1:1),DFE(1))
  6022.     DIMENSION FORM(128),FVLD(1,1)
  6023. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  6024. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  6025. C SO INITIALLY IGNORE.
  6026. C
  6027. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  6028. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  6029. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6030. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6031.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  6032.     COMMON/D2R/NRDSP,NCDSP
  6033.     InTeGer*4 ILNFG,ILNCT
  6034.     CHARACTER*1 ILINE(106)
  6035.     COMMON/ILN/ILNFG,ILNCT,ILINE
  6036.     INTEGER LENTL(5),LOCOL(5)
  6037.     CHARACTER*1 FILINE(208)
  6038. CCC    CHARACTER*1 OARRY(100)
  6039. CCC    InTeGer*4 OSWIT,OCNTR
  6040. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  6041. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  6042.     InTeGer*4 TYPE(1,2),VLEN(9)
  6043.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  6044.     Real*8 VAVBLS(3,27)
  6045.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  6046.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  6047.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  6048. CCC    InTeGer *4 FORMFG,RCFGX
  6049. CCC    COMMON/FFGG/FORMFG,RCFGX
  6050. C
  6051. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  6052. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  6053. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  6054. C DISPLAY ACTUALLY USED FOR SCREEN.
  6055.     Integer*4 CWids(JIDcl)
  6056. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  6057. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  6058. C AS 20 NOT 75.
  6059.     REAL*8 DVS(JIDcl,JIDrw)
  6060.     INTEGER*4 LDVS(2,JIDcl,JIDrw)
  6061.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  6062.     COMMON /FVLDC/FVLD
  6063. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  6064. C 10 CHARACTERS PER ENTRY.
  6065. C    COMMON/DSPCMN/DVS,DFMTS,CWIDS
  6066.     COMMON/DSPCMN/DVS,CWIDS
  6067. C THISRW,THISCL = CURRENT DISPLAYED LOCS.
  6068. c    InTeGer*4 THISRW,THISCL
  6069. C NOTE ROWS ARE DOWN, COLS ACROSS INTERNALLY.
  6070. C COLUMN 2 = NUMBERS. DISPLAY COLS 2-22 WITH COL 1=TITLE
  6071. C COL 23,24 FOR COMMANDS.(23 (PARAMETER) ACTUALLY.)
  6072. C ROW OFFSET BY 6 FOR NUMBERS.
  6073. C
  6074. C MAINTAIN AN "INITIALIZED" BITMAP HERE TO USE TO AVOID GOING TO
  6075. C FVLD.
  6076. C    CHARACTER*1 IBITMP
  6077. C    DIMENSION IBITMP(2258)
  6078. C    COMMON/INITD/IBITMP
  6079. C NOTE BITMAP IS ZEROED IN SPREDSHT MAIN PROGRAM (OR AT SAVE CMD)
  6080. C AND IS SET HERE (AND HERE ONLY). ONLY USED HERE TOO...
  6081. C    character*100 fwt
  6082. C
  6083. C CODE FOR WINDOW TILING AND FILE READIN...
  6084. C &%FILENAME,NSKIP,NLEN READS FILE SKIPPING NSKIP RECS AND
  6085. C GETS NLEN RECS IN
  6086. C
  6087. C &&%FILENAME,NSKIP,NLEN JUST INSERTS FILE INTO PRINTOUT
  6088.     IF(IDOL4.EQ.0)GOTO 9880
  6089.     LFTMST=J
  6090. C NEED TO DO IT HERE...
  6091. C FORM ARRAY HAS FILE NAME INFO, IF ANY...
  6092.     KKK=ICHAR('&')
  6093.     LLA=INDX(FORM,KKK)
  6094.     IF(LLA.LE.0.OR.LLA.GT.100)GOTO 9882
  6095.     IF(FORM(LLA+1).EQ.'&')GOTO 9881
  6096. C CHECK &% FORM
  6097.     IF(FORM(LLA+1).NE.'%')GOTO 9882
  6098. C GOT &% FORM HERE.
  6099.     IF(LLVL.EQ.0.OR.LLVLF.EQ.1)GOTO 9885
  6100.     DO 9886 LNNN=1,LLVL
  6101.     LLVLN=LLVL+10
  6102.     CLOSE(LLVLN)
  6103. 9886    CONTINUE
  6104.     LLVL=0
  6105. 9885    CONTINUE
  6106.     LTST=LLA+2
  6107.     LLVLF=1
  6108. C OPEN LLVL
  6109.     CALL GETFNL(FORM(LTST),LSKIP,LLEN)
  6110.     IF(LLEN.LE.0)GOTO 9882
  6111.     LLVL=LLVL+1
  6112.     LLU=LLVL+10
  6113.     IF(LLVL.GT.4)GOTO 9931
  6114.     CALL RASSIG(LLU,FORM(LTST),ierror)
  6115.     if(ierror.ne.0)goto 9931
  6116.     GOTO 9930
  6117. 9931    CONTINUE
  6118.     LENTL(LLVL)=0
  6119.     LOCOL(LLVL)=0
  6120.     CLOSE(LLU)
  6121.     LLVL=LLVL-1
  6122.     LLU=LLVL+10
  6123.     GOTO 9882
  6124. 9930    CONTINUE
  6125.     LOCOL(LLVL)=LFTMST
  6126.     LENTL(LLVL)=LLEN
  6127.     IF(LSKIP.LE.0)GOTO 9906
  6128.     DO 9907 LL=1,LSKIP
  6129. 9907    READ(LLU,9889,END=9909,ERR=9909)FILINE
  6130.     DO 9910 N=1,208
  6131. 9910    FILINE(N)=CHAR(32)
  6132.     GOTO 9911
  6133. 9909    CONTINUE
  6134. C EOF SO CLOSE LUN
  6135.     LENTL(LLVL)=0
  6136.     CLOSE(LLU)
  6137.     LLVL=LLVL-1
  6138.     IF(LLVL.LE.0)GOTO 9880
  6139.     LLU=LLVL+10
  6140. 9911    CONTINUE
  6141. 9906    CONTINUE
  6142. C FILE SET UP NOW... READ IN AT 9982...
  6143. C RECORD COL # OVER FOR THIS RECURSION LEVEL
  6144.     GOTO 9882
  6145. 9881    CONTINUE
  6146. C HERE LOOK FOR && FORM. IF NONE SEEN, SKIP THIS
  6147.     IF(FORM(LLA+1).NE.'&'.OR.FORM(LLA+2).NE.'%')GOTO 9882
  6148. C HERE HAVE A FORM &&%FILE,NS,NL
  6149. C SO CLOSE OFF ALL WINDOWS IN USE AND READ IN FIRST LEVEL FILE SEEN.
  6150.     IF(LLVL.EQ.0.OR.LLVLF.EQ.2)GOTO 9884
  6151.     DO 9883 LNN=1,LLVL
  6152.     LNN1=LNN+10
  6153.     CLOSE(LNN1)
  6154. 9883    CONTINUE
  6155. C NOW ALL OPEN UNITS CLOSED
  6156.     LLVLF=2
  6157.     LLVL=0
  6158. 9884    CONTINUE
  6159.     LTST=LLA+3
  6160. C OPEN LLVL
  6161. 9937    CALL GETFNL(FORM(LTST),LSKIP,LLEN)
  6162.     IF(LLEN.LE.0)GOTO 9882
  6163.     LLVL=LLVL+1
  6164.     LLU=LLVL+10
  6165.     IF(LLVL.GT.4)GOTO 9933
  6166. C    OPEN(LLU,NAME=FORM(LTST),TYPE='OLD',
  6167. C     1  ERR=9933)
  6168.     CALL RASSIG(LLU,FORM(LTST),ierror)
  6169.     if(ierror.ne.0)goto 9933
  6170.     GOTO 9934
  6171. 9933    CONTINUE
  6172.     LLVL=LLVL-1
  6173.     LLU=LLVL+10
  6174.     GOTO 9882
  6175. 9934    CONTINUE
  6176.     LOCOL(LLVL)=LFTMST
  6177.     LENTL(LLVL)=LLEN
  6178.     IF(LSKIP.LE.0)GOTO 9888
  6179.     DO 9887 LL=1,LSKIP
  6180. 9887    READ(LLU,9889,ERR=9901,END=9901)FILINE
  6181. 9889    FORMAT(208A1)
  6182. C8998    FORMAT(1X,208A1)
  6183. 9898    FORMAT(132A1)
  6184.     DO 9908 N=1,208
  6185. 9908    FILINE(N)=Char(32)
  6186. C PUT IN LEADING SPACES INTO FILINE
  6187.     GOTO 9902
  6188. 9901    CONTINUE
  6189.     CLOSE(LLU)
  6190.     LLVL=LLVL-1
  6191.     IF(LLVL.LE.0)GOTO 9880
  6192.     LLU=LLVL+10
  6193. C HIT EOF ON READ, SO BACK UP A LEVEL
  6194. 9902    CONTINUE
  6195. C NOW GO AHEAD & READ... GOT PAST SKIP STUFF.
  6196. 9888    CONTINUE
  6197. C RECORD COL # OVER FOR THIS RECURSION LEVEL
  6198. 9904    IF(LENTL(LLVL).LE.0) GOTO 9901
  6199.     READ(LLU,9889,END=9901,ERR=9901)(FILINE(IV),IV=LOCOL(LLVL),208)
  6200.     LENTL(LLVL)=lentl(llvl)-1
  6201. c update lines left to read in
  6202. C LOOK FOR RECURSIVE CALLS TO DEEPER NESTED FILES TO INCLUDE
  6203.     KKK=ICHAR('&')
  6204.     LTST=INDX(FILINE,KKK)+3
  6205.     LFTMST=LTST-3
  6206. C UPDATE SO IF IT IS A CALL,WE CAN GO HANDLE IT TILL ITS EOF OR A DEEPER CALL
  6207.     IF(LTST.GT.0.AND.LTST.LT.207.AND.FILINE(LTST+1).EQ.'&'
  6208.      1  .AND.FILINE(LTST+2).EQ.'%') GOTO 9937
  6209. C WELL, NOT A DEEPER LEVEL SO JUST GO ON AND READ THIS LEVEL TILL DONE.
  6210.     IF(ICODE.EQ.10)WRITE(8,9889,ERR=9904)FILINE
  6211. c only write 80 chars on ibmpc and its ilk since they screw up on wider.
  6212.     call swrt(filine,80)
  6213. c    WRITE(0,9898,ERR=9904)(FILINE(IVV),IVV=1,132)
  6214.     GOTO 9904
  6215. 9882    CONTINUE
  6216. C HERE HANDLE OLD WINDOW READS IN PROCESS OR JUST EXIT WITHOUT DOING MUCH
  6217.     IF(LLVLF.NE.1)GOTO 9880
  6218. C ONLY HANDLE "OVERLAY" STYLE READS HERE.
  6219. C NORMAL OR-ING IN OF WINDOWS
  6220. C LOOK FOR LUN SUCH THAT J=LOCOL(LUN) INDICATING IT STARTS HERE.
  6221. C READ THIS CELL INTO IT AND FAKE OUT FVLD(1,1) TO GET IT DISPLAYED.
  6222.     IF(LLVL.LE.0)GOTO 9880
  6223.     DO 9912 N=1,LLVL
  6224.     LLM=N+10
  6225.     IF(J.EQ.LOCOL(N))GOTO 9913
  6226. 9912    CONTINUE
  6227.     GOTO 9880
  6228. 9913    CONTINUE
  6229. C NOW READ THE FILE INTO "THIS" CELL (DISPLAY PURPOSES ONLY!)
  6230. C AND FLAG FVLD. Note we assign char(255) to fvldtp to represent -1.
  6231.     LENTL(LLM-10)=LENTL(LLM-10)-1
  6232.     IF(LENTL(LLM-10).GT.0)
  6233.      1  READ(LLM,9889,END=9940,ERR=9940)(FORM(IV),IV=1,109)
  6234.     IF(LENTL(LLM-10).GT.0)FVLDTP=char(255)
  6235.     IF(LENTL(LLM-10).LT.0)GOTO 9940
  6236. C -1 FLAGS THIS AS A "TEXT" CELL DISPLAY.
  6237.     GOTO 9880
  6238. 9940    CONTINUE
  6239.     LENTL(LLM-10)=0
  6240.     LOCOL(LLM-10)=0
  6241.     CLOSE(LLM)
  6242. 9880    CONTINUE
  6243.     RETURN
  6244.     END
  6245. c -h- dspsht.f40    Fri Aug 22 13:04:12 1986    
  6246.     SUBROUTINE DSPSHT(ICODE)
  6247. C COPYRIGHT (C) 1983 GLENN EVERHART
  6248. C ALL RIGHTS RESERVED
  6249.     INCLUDE aparms.inc
  6250. C DISPLAY SPREAD SHEET ON SCREEN OR IN FILE IF ICODE=10
  6251. C USES UVT100 TO TWEAK THE VT100. NO WRAP IS ASSUMED SO
  6252. C OUTPUT UP TO 132 COLS BY 24 LINES IS OK. ONLY CHECK
  6253. C WIDTH TO ALLOW VT100 LOOKALIKES WITH MORE DISPLAY LINES TOO.
  6254. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  6255. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  6256. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  6257. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  6258. C FROM THE DISK BASED FILE HERE.
  6259.     CHARACTER*127 CWRK
  6260.     CHARACTER*1 CCWRK(128)
  6261.     InTeGer*4 ICODE,LLU,LLVL,LLVLF
  6262.     EQUIVALENCE(CWRK(1:1),CCWRK(1))
  6263.     InTeGer*4 RRWACT,RCLACT
  6264. C    COMMON/RCLACT/RRWACT,RCLACT
  6265.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  6266.      1  IDOL7,IDOL8
  6267. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  6268. C     1  IDOL7,IDOL8
  6269.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6270. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6271.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6272. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6273. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  6274. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  6275.     InTeGer*4 KLVL,K3DFG,KCDelt,KRDelt,kpag
  6276. C    COMMON/KLVL/KLVL
  6277.     InTeGer*4 IOLVL,IGOLD
  6278. C    COMMON/IOLVL/IOLVL
  6279. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  6280. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  6281.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  6282.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  6283.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  6284.      3  K3DFG,KCDelt,KRDelt,kpag
  6285. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  6286. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  6287. CCC    InTeGer*4 LLCMD,LLDSP
  6288. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6289. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6290. C    EXTERNAL INDX
  6291.     CHARACTER*7 PRTLX
  6292.     CHARACTER*1 FORM,FVLD,PRTLIN(132)
  6293.     EQUIVALENCE(PRTLX(1:1),PRTLIN(1))
  6294. C    INTEGER*4 VNLT
  6295.     CHARACTER*1 FVLDTP
  6296.     CHARACTER*1 LBEL(4)
  6297.     CHARACTER*1 FORM2(128),NMSH(80)
  6298.     COMMON/NMSH/NMSH
  6299. C FLAG BORDR=1 IF WE WANT TO OMIT BORDERS ON DRAWING
  6300. C THE SCREEN DISPLAY TO A FILE.
  6301.     InTeGer*4 BORDR,TOMT
  6302. C COMMON ICPOS ALLOWS UVT100 ROUTINE ACCESS TO DISPLAYED NUMBERS
  6303. C FOR USES SUCH AS SETTING COLORS...
  6304.     CHARACTER*1 OARRY(100)
  6305.     InTeGer*4 OSWIT,OCNTR
  6306. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  6307. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  6308.     InTeGer*4 IPS1,IPS2,MODFLG
  6309. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  6310.        InTeGer*4 XTCFG,IPSET,XTNCNT
  6311.        CHARACTER*1 XTNCMD(80)
  6312. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  6313. C VARY FLAG ITERATION COUNT
  6314.     INTEGER KALKIT
  6315. C    COMMON/VARYIT/KALKIT
  6316.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  6317.     InTeGer*4 RCMODE,IRCE1,IRCE2
  6318. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  6319. C     1  IRCE2
  6320. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  6321. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  6322. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  6323. C RCFGX ON.
  6324. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  6325. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  6326. C  AND VM INHIBITS. (SETS TO 1).
  6327.     INTEGER*4 FH
  6328. C FILE HANDLE FOR CONSOLE I/O (RAW)
  6329. C    COMMON/CONSFH/FH
  6330.     CHARACTER*1 ARGSTR(52,4)
  6331. C    COMMON/ARGSTR/ARGSTR
  6332.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  6333.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  6334.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  6335.      3  IRCE2,FH,ARGSTR
  6336. CCC    InTeGer*4 IC1POS,IC2POS
  6337. CCC    COMMON/ICPOS/IC1POS,IC2POS
  6338. CCC    InTeGer*4 NULAST,LFVD
  6339. C    INTEGER*4 IOLVL
  6340. C    COMMON/IOLVL/IOLVL
  6341.     InTeGer*4 ICREF,IRREF
  6342. C    COMMON/MIRROR/ICREF,IRREF
  6343.     InTeGer*4 MODPUB,LIMODE
  6344. C    COMMON/MODPUB/MODPUB,LIMODE
  6345.     InTeGer*4 KLKC,KLKR
  6346.     REAL*8 AACP,AACQ
  6347. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  6348.     InTeGer*4 NCEL,NXINI
  6349. C    COMMON/NCEL/NCEL,NXINI
  6350.     CHARACTER*1 NAMARY(20,MROWS)
  6351. C    COMMON/NMNMNM/NAMARY
  6352.     InTeGer*4 NULAST,LFVD
  6353. C    COMMON/NULXXX/NULAST,LFVD
  6354.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  6355.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  6356. CCC    COMMON/NULXXX/NULAST,LFVD
  6357.     REAL*8 XVBLS(1,1),VDSP,VCLC
  6358.     CHARACTER*1 DFE(14)
  6359.     CHARACTER*14 CDFE
  6360.     EQUIVALENCE(CDFE(1:1),DFE(1))
  6361.     DIMENSION FORM(128),FVLD(1,1)
  6362. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  6363. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  6364. C SO INITIALLY IGNORE.
  6365. C
  6366. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  6367. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  6368. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6369. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6370.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  6371.     COMMON/D2R/NRDSP,NCDSP
  6372.     InTeGer*4 ILNFG,ILNCT
  6373.     CHARACTER*1 ILINE(106)
  6374.     COMMON/ILN/ILNFG,ILNCT,ILINE
  6375.     INTEGER LENTL(5),LOCOL(5)
  6376.     CHARACTER*1 FILINE(208)
  6377. CCC    CHARACTER*1 OARRY(100)
  6378. CCC    InTeGer*4 OSWIT,OCNTR
  6379. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  6380. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  6381.     InTeGer*4 TYPE(1,2),VLEN(9)
  6382.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  6383.     Real*8 VAVBLS(3,27)
  6384.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  6385.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  6386.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  6387. CCC    InTeGer *4 FORMFG,RCFGX
  6388. CCC    COMMON/FFGG/FORMFG,RCFGX
  6389. C
  6390. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  6391. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  6392. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  6393. C DISPLAY ACTUALLY USED FOR SCREEN.
  6394.     Integer*4 CWids(JIDcl)
  6395. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  6396. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  6397. C AS 20 NOT 75.
  6398.     REAL*8 DVS(JIDcl,JIDrw)
  6399.     INTEGER*4 LDVS(2,JIDcl,JIDrw)
  6400.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  6401.     COMMON /FVLDC/FVLD
  6402. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  6403. C 10 CHARACTERS PER ENTRY.
  6404. C    COMMON/DSPCMN/DVS,DFMTS,CWIDS
  6405.     COMMON/DSPCMN/DVS,CWIDS
  6406. C THISRW,THISCL = CURRENT DISPLAYED LOCS.
  6407.     InTeGer*4 LFTMST
  6408. c    InTeGer*4 THISRW,THISCL
  6409. C NOTE ROWS ARE DOWN, COLS ACROSS INTERNALLY.
  6410. C COLUMN 2 = NUMBERS. DISPLAY COLS 2-22 WITH COL 1=TITLE
  6411. C COL 23,24 FOR COMMANDS.(23 (PARAMETER) ACTUALLY.)
  6412. C ROW OFFSET BY 6 FOR NUMBERS.
  6413. C
  6414. C MAINTAIN AN "INITIALIZED" BITMAP HERE TO USE TO AVOID GOING TO
  6415. C FVLD.
  6416. C    CHARACTER*1 IBITMP
  6417. C    DIMENSION IBITMP(2258)
  6418. C    COMMON/INITD/IBITMP
  6419. C NOTE BITMAP IS ZEROED IN SPREDSHT MAIN PROGRAM (OR AT SAVE CMD)
  6420. C AND IS SET HERE (AND HERE ONLY). ONLY USED HERE TOO...
  6421.     character*100 fwt
  6422. C    CHARACTER*1 LBITS(8)
  6423. CC    DATA LBITS/1,2,4,8,16,32,64,128/
  6424. C    LBITS(1)=1
  6425. C    LBITS(2)=2
  6426. C    LBITS(3)=4
  6427. C    LBITS(4)=8
  6428. C    LBITS(5)=16
  6429. C    LBITS(6)=32
  6430. C    LBITS(7)=64
  6431. C    LBITS(8)=128
  6432.     IF(ICODE.NE.10)GOTO 3000
  6433.     CALL UVT100(1,LLCMD,1)
  6434.     CALL UVT100(12,2,0)
  6435.     call Vwrt('Enter Print File Spec, / after to omit borders>',47)
  6436.     if(iolvl.ne.11)READ(IOLVL,26,END=8884,ERR=8884)FORM2
  6437.     if(iolvl.eq.11)call vget(form2,128)
  6438. 26    FORMAT(128A1)
  6439. C FIND SIZE OF LINE READ IN
  6440.     DO 750 N=1,128
  6441.     ISZ=129-N
  6442.     IF(FORM2(N).GT.' ')GOTO 751
  6443. 750    CONTINUE
  6444. 751    CONTINUE
  6445.     ISZ=ISZ+1
  6446.     ISZ=MIN0(127,ISZ)
  6447.     FORM2(ISZ+1)=char(0)
  6448.     BORDR=0
  6449.     TOMT=0
  6450.     DO 4111 N=1,ISZ
  6451. C IF FILENAME HAS / AFTERWARDS, OMIT BORDER
  6452.     IF(FORM2(N).EQ.'/')BORDR=1
  6453. C NULL OUT THE / SO THAT FILENAME WILL PARSE CORRECTLY.
  6454.     IF(FORM2(N).EQ.'/')FORM2(N)=char(0)
  6455.     IF(FORM2(N).EQ.'%')TOMT=1
  6456. 4111    CONTINUE
  6457. C    OPEN(8,FILE=FORM2,RECL=600,STATUS='NEW')
  6458.     CALL WASSIG(8,FORM2)
  6459.     KSHEET=0
  6460.     IF(K3DFG.LE.0)GOTO 2890
  6461.     LR=NRDSP(1,1)
  6462.     LC=NCDSP(1,1)
  6463.     CALL GETSHT(LR,LC,KSHEET)
  6464.     IF(KSHEET.EQ.0)GOTO 2890
  6465.     DO 27 N=1,132
  6466. 27    PRTLIN(N)=Char(32)
  6467.     WRITE(PRTLX(1:7),1891)ksheet
  6468. c    ENCODE(7,1891,PRTLIN)KSHEET
  6469.     GOTO 3666
  6470. 2890    CONTINUE
  6471.     DO 9127 N=1,132
  6472. 9127    PRTLIN(N)=Char(32)
  6473.     WRITE(PRTLX(1:7),2)
  6474. C    ENCODE(7,2,PRTLIN)
  6475.     GOTO 3666
  6476. 3000    CONTINUE
  6477.     NULAST=-4
  6478. 3666    CONTINUE
  6479.     CALL UVT100(13,0,0)
  6480.     IF(TOMT.EQ.0.AND.ICODE.EQ.10)WRITE(8,17)NMSH
  6481.     IF(ICODE.EQ.10)GOTO 2000
  6482.     IF(ICODE.NE.2)GOTO 1000
  6483. C DRAW LABELS FIRST
  6484.     CALL UVT100(1,1,1)
  6485.     CALL UVT100(12,2,0)
  6486.     IF(ICODE.NE.10)call swrt(nmsh,80)
  6487.     CALL UVT100(1,2,1)
  6488.     CALL UVT100(12,2,0)
  6489. C ERASE TOP LINE, START AT COL 7
  6490.     KSHEET=0
  6491.     IF(K3DFG.LE.0)GOTO 1890
  6492.     LR=NRDSP(1,1)
  6493.     LC=NCDSP(1,1)
  6494.     CALL GETSHT(LR,LC,KSHEET)
  6495.     IF(KSHEET.EQ.0)GOTO 1890
  6496.     write(fwt(1:7),1891)ksheet
  6497.     call swrt(fwt,7)
  6498. c    WRITE(6,1891)KSHEET
  6499. 1891    FORMAT('PG=',I4)
  6500.     GOTO 2000
  6501. 1890    CONTINUE
  6502.     call swrt('ROW/COL',7)
  6503. 2    FORMAT('ROW\COL')
  6504. C NOTE EXACTLY 7 CHARACTERS IN FORMAT #2
  6505. 2000    CONTINUE
  6506.     J=8
  6507.     CALL UVT100(13,7,0)
  6508.     DO 1 N1=1,DRWV
  6509.     LR=NRDSP(N1,1)
  6510. C NOTE PHYS SHEET OFFSET BY 1 (SEE VARSCN)
  6511. C DISPLAY SHEET NUMBERS START AT 1
  6512.     IF(ICODE.NE.10)CALL UVT100(1,2,J)
  6513.     IF(KSHEET.GT.0.AND.LR.GE.NRDSP(1,1).AND.
  6514.      1   (LR-(KSHEET)*KCDELT).GE.1) LR=LR-(KSHEET)*KCDELT
  6515.     CALL IN2AS(LR,LBEL)
  6516.     IF(ICODE.EQ.10)GOTO 2020
  6517.     write(fwt(1:100),3)LBEL
  6518.     CALL SWRT(fwt(1:100),4)
  6519. c    WRITE(0,3)LBEL
  6520. 3    FORMAT(4A1)
  6521.     IF(LBEL(4).EQ.' '.AND.LBEL(3).EQ.' ')CALL UVT100(1,2,J+2)
  6522.     IF(LBEL(4).EQ.' '.AND.LBEL(3).NE.' ')CALL UVT100(1,2,J+3)
  6523.     write(fwt(1:100),7)n1
  6524.     call swrt(fwt(1:100),3)
  6525. 7    FORMAT('=',I2)
  6526.     GOTO 2030
  6527. 2020    CONTINUE
  6528.     IF((J+CWIDS(N1)-7).GT.121)GOTO 2030
  6529.     ICWD=MAX0(7,CWIDS(N1))
  6530.     WRITE(CWRK(1:127),2021,ERR=2030)LBEL,N1
  6531.     DO 752 N=1,ICWD
  6532.     PRTLIN(J-1+N)=CCWRK(N)
  6533. 752    CONTINUE
  6534. C    ENCODE(ICWD,2021,PRTLIN(J),ERR=2030),LBEL,N1
  6535. 2021    FORMAT(4A1,'=',I2)
  6536. 2030    CONTINUE
  6537.     J=J+CWIDS(N1)
  6538.     IF(J.GT.132)GOTO 40
  6539. 1    CONTINUE
  6540. 40    CONTINUE
  6541. C NOW COL LBLS DONE
  6542. C DO NUMBERS ACROSS LEFT.
  6543. C ONLY DO SO ON SCREEN.
  6544.     IF(BORDR.EQ.0.AND.ICODE.EQ.10)WRITE(8,18)PRTLIN
  6545.     DO 2031 KKK=1,132
  6546.     FILINE(KKK)=Char(32)
  6547. 2031    PRTLIN(KKK)=Char(32)
  6548.     IF(ICODE.EQ.10)GOTO 1000
  6549.     CALL UVT100(13,7,0)
  6550.     MCX=MIN0(LLCMD-1,DCLV)+2
  6551. C    LLVL=0
  6552. C ROWS ARE JUST OFFSET...NO MONKEY BUSINESS.
  6553.     DO 6 N1=3,MCX
  6554.     M1=N1-2
  6555.     LC=NCDSP(1,M1)-1
  6556. C N1=DISPLAY ROW
  6557.     CALL UVT100(1,N1,1)
  6558. C ADJUST DISPLAY LABELS FOR PAGE
  6559.     IF(KSHEET.GT.0.AND.LC.GE.(NCDSP(1,1)-1).AND.
  6560.      1   (LC-KSHEET*KRDELT).GE.1)LC=LC-KSHEET*KRDELT
  6561.     write(fwt(1:100),8)lc
  6562.     call swrt(fwt(1:100),6)
  6563. 8    FORMAT(I5,'>')
  6564. 6    CONTINUE
  6565. C NOW DISPLAY VALUES.
  6566. 1000    CONTINUE
  6567.     CALL UVT100(13,0,0)
  6568. C main screen display loop here.
  6569.     If (NCEL.eq.0) GOTO 1011
  6570.     DO 10 N2=1,DCLV
  6571.     JP=8
  6572.     JPL=125
  6573.     DO 110 N1=1,DRWV
  6574.     M1=NRDSP(N1,N2)
  6575.     M2=NCDSP(N1,N2)
  6576. C M1,M2 = PHYS SHEET COORDS OF WHAT IS DISPLAYED.
  6577.     M2M1=M2-1
  6578.     IF(BORDR.EQ.0.AND.ICODE.EQ.10)WRITE(PRTLX(1:7),8)M2-1
  6579. C *** OMIT DISPLAY IF FVLD=0 ***
  6580. C
  6581.     CALL FVLDGT(M1,M2,FVLD(1,1))
  6582.     IF((ICHAR(FVLD(1,1)).EQ.0).AND.ICODE.NE.2.AND.ICODE.NE.
  6583.      1  10.AND.IDOL4.EQ.0) GOTO 100
  6584. C ******************************
  6585.     VDSP=DVS(N1,N2)
  6586.     CALL XVBLGT(M1,M2,VCLC)
  6587. C    VCLC=XVBLS(M1,M2)
  6588. C SEE IF DISPLAYED AND CALCULATED NUMBERS ARE IDENTICAL.
  6589. C ONLY DISPLAY IF CHANGED.
  6590.     IF(IDOL4.NE.0)GOTO 620
  6591.     IF(VDSP.EQ.VCLC.AND.ICODE.NE.2.AND.ICODE.NE.10)GOTO 100
  6592. 620    IC1POS=M1
  6593.     IC2POS=M2
  6594. C FALL THRU HERE IF WE NEEDTO DISPLAY A NUMBER IN ROW 3+N2, COL N1
  6595. C THEN RE-ESTABLISH FORMAT, ETC.
  6596.     M23=N2+2
  6597.     J=8
  6598.     DO 11 N11=1,N1
  6599. C GET THE COORDS OF OUR CELL.
  6600. 11    J=J+CWIDS(N11)
  6601.     J=J-CWIDS(N1)
  6602. C CURRENT CHARACTER COL NUMBER IS NOW J.
  6603. C    CALL UVT100(1,M23,J)
  6604. C    IRX=(M2-1)*60+M1
  6605.     CALL REFLEC(M2,M1,IRX)
  6606. C
  6607. C GET FORMULA IN NOW
  6608.     CALL WRKFIL(IRX,CWRK(1:127),0)
  6609.     CALL CE2A(CWRK(1:127),FORM)
  6610. C CONVERT ENCODED FORMS TO REGULAR ASCII
  6611. C    READ(7'IRX)FORM
  6612. C ALLOW FOR FVLD TO HAVE CONSTANT VS FORMULA SIGNIFICANCE
  6613.     IF(JCHAR(FORM(119)).LT.-1)FORM(119)=Char(253)
  6614.     IF(JCHAR(FORM(119)).GT.1)FORM(119)=Char(3)
  6615. C
  6616. c try & omit reset here... could mess other places up.
  6617. cC FVLD VALUES OF 2 INDICATE ALREADY-COMPUTED CONSTANTS.DON'T
  6618. cC FORCE THEM TO BE REDONE. OTHERWISE DO FILL IN HOWEVER.
  6619. c    CALL FVLDGT(M1,M2,FVLD(1,1))
  6620. c    IF(ICHAR(FVLD(1,1)).NE.2)CALL FVLDST(M1,M2,FORM(119))
  6621. cC    FVLD(M1,M2)=FORM(119)
  6622. cC    IF(FORM(120).LE.0)CALL FVLDST(M1,M2,char(0))
  6623.     CALL FVLDGT(M1,M2,FVLD(1,1))
  6624.     FVLDTP=FVLD(1,1)
  6625. C HANDLE FILE INCLUSION IN SUBROUTINE...
  6626.     IF (IDOL4.NE.0)CALL DSPFIL(ICODE,FORM,FORM2,FVLDTP,LFTMST,
  6627.      1  LENTL,LOCOL,FILINE,LLVL,LLU,LLVLF,J)
  6628. C NOTE WE CALL DSPFIL SO IT CAN BE OVERLAIN AND LET THE REST
  6629. C OF DSPSHT STAY RESIDENT. (SHOULD SPEED THINGS UP MOST OF
  6630. C THE TIME)...
  6631. C THIS SETTING OF FVLD ALLOWS THE Q OPTION TO WORK.
  6632.     IF(ICHAR(FVLDTP).NE.0)CALL UVT100(1,M23,J)
  6633. 13    CONTINUE
  6634.     CALL XVBLGT(M1,M2,DVS(N1,N2))
  6635. C    DVS(N1,N2)=XVBLS(M1,M2)
  6636.     IF(ICHAR(FVLDTP).EQ.0)GOTO 100
  6637.     IF(FORMFG.LE.0.AND.JCHAR(FVLDTP).GE.0)GOTO 756
  6638.     DO 757 N=1,100
  6639. 757    FORM2(N)=FORM(N)
  6640. 756    CONTINUE
  6641. C     1  ENCODE(100,17,FORM2)(FORM(II),II=1,100)
  6642. 17    FORMAT(1X,80A1)
  6643.     IF(FORMFG.NE.0)GOTO 4321
  6644.     DO 6304 KKKK=1,9
  6645.     KKKKK=ICHAR(FORM(KKKK+119))
  6646. C    KKKKK=DFMTS(KKKK,N1,N2)
  6647. 6304    DFE(KKKK+1)=Char(MAX0(32,KKKKK))
  6648.     DFE(11)=Char(32)
  6649.     DFE(1)='('
  6650.     DFE(12)=' '
  6651. c omit any \ formats from dfe since encode fouls up with them.
  6652.     DFE(13)=' '
  6653.     DFE(14)=')'
  6654.     CALL TYPGET(M1,M2,TYPE(1,1))
  6655. c    IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
  6656. c     1  WRITE(CWRK(1:127),CDFE(1:14),ERR=4321)DVS(N1,N2)
  6657. c    IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
  6658. c     1  WRITE(CWRK(1:127),CDFE(1:14),ERR=4321)LDVS(1,N1,N2)
  6659.     IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
  6660.      1  WRITE(CWRK(1:127),DFE,ERR=4321)DVS(N1,N2)
  6661.     IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
  6662.      1  WRITE(CWRK(1:127),DFE,ERR=4321)LDVS(1,N1,N2)
  6663.     IF(JCHAR(FVLDTP).LE.0)GOTO 4321
  6664.     DO 758 N=1,100
  6665. 758    FORM2(N)=CCWRK(N)
  6666. 4321    CONTINUE
  6667.     KWID=CWIDS(N1)
  6668. C  *** FIND OUT HOW MUCH ROOM THERE IS NOW. WE KNOW WHERE WE'RE DISPLAYING, SO
  6669. C  *** ALLOW NULL CELLS TO BE SHOWN PROVIDED WE ARE:
  6670. C  1. DISPLAYING TEXT IN THE CELL, OR
  6671. C  2. IN VIEW FORMULA MODE, AND THE NEXT CELL(S) OVER ARE NULL (FVLD=0)
  6672.     IF(FORMFG.EQ.0.AND.JCHAR(FVLDTP).GE.0)GOTO 8444
  6673.     III=N1+1
  6674.     IF(III.GT.DRWV)GOTO 8446
  6675.     DO 8445 II=III,DRWV
  6676. C FOLLOW ALONG WITH THE DISPLAY'S MAPPING TO SHEET.
  6677.     IIII=NRDSP(II,N2)
  6678.     IIIII=NCDSP(II,N2)
  6679.     CALL FVLDGT(IIII,IIIII,FVLD(1,1))
  6680.     IF(ICHAR(FVLD(1,1)).NE.0)GOTO 8444
  6681.     KWID=KWID+CWIDS(II)
  6682. 8445    CONTINUE
  6683. 8446    CONTINUE
  6684. C TEST IF LAST CELL IS NULL
  6685. 8444    CONTINUE
  6686.     KWID=MIN0(KWID,JPL)
  6687. C ****** END OF MODS FOR PRINTING INTO ADJACENT NULL CELLS.
  6688.     IF(ICODE.NE.10)CALL SWRT(FORM2,KWID)
  6689.     IF(ICODE.NE.10)GOTO 100
  6690.     IF(JPL-KWID.LT.0)GOTO 115
  6691.     DO 759 II=1,KWID
  6692.     IIII=JP+II-1
  6693. 759    PRTLIN(IIII)=FORM2(II)
  6694. C    ENCODE(KWID,17,PRTLIN(JP),ERR=100)(FORM2(II),II=1,KWID)
  6695. 100    CONTINUE
  6696. 115    CONTINUE
  6697. C HERE KEEP TRACK OF AMOUNT PRINTED.
  6698.     JP=JP+CWIDS(N1)
  6699.     JPL=JPL-CWIDS(N1)
  6700. 110    CONTINUE
  6701.     IF(ICODE.NE.10)GOTO 10
  6702.     DO 634 KKKQ=1,132
  6703.     IF(ICHAR(PRTLIN(KKKQ)).LT.32)PRTLIN(KKKQ)=Char(32)
  6704. 634    CONTINUE
  6705.     WRITE(8,18)(PRTLIN(II),II=1,JP)
  6706. 18    FORMAT(1X,100A1,34A1)
  6707.     DO 19 LN1=1,132
  6708. 19    PRTLIN(LN1)=Char(32)
  6709. 10    CONTINUE
  6710. 1011    Continue
  6711.     IF(ICODE.EQ.10)CLOSE(8)
  6712.     IF(IDOL4.EQ.0)RETURN
  6713.     DO 9915 N=1,4
  6714.     LLU=N+10
  6715.     CLOSE(LLU)
  6716. 9915    CONTINUE
  6717.     LLVL=0
  6718. 8884    RETURN
  6719.     IOLVL=11
  6720.     CLOSE(3)
  6721. c    CLOSE(11)
  6722. c    OPEN(UNIT=11,FILE='CON:0/0/100/100/Analy Command')
  6723.     RETURN
  6724.     END
  6725.     SUBROUTINE GETSHT(LR,LC,KSHEET)
  6726. c FIGURE CORRECT SHEET, ENSURING THAT THE LR,LC PAIR IS
  6727. c SENSIBLY WITHIN IT.
  6728.     Include aparms.inc
  6729. c    INCLUDE VKLUGPRM.FTN''
  6730.     InTeGer*4 RRWACT,RCLACT
  6731. C    COMMON/RCLACT/RRWACT,RCLACT
  6732.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  6733.      1  IDOL7,IDOL8
  6734. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  6735. C     1  IDOL7,IDOL8
  6736.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  6737. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  6738.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6739. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  6740. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  6741. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  6742.     InTeGer*4 KLVL,K3DFG,KCDelt,KRDelt,kpag
  6743. C    COMMON/KLVL/KLVL
  6744.     InTeGer*4 IOLVL,IGOLD
  6745. C    COMMON/IOLVL/IOLVL
  6746. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  6747. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  6748.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  6749.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  6750.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  6751.      3  K3DFG,KCDelt,KRDelt,kpag
  6752.     KSHEET=0
  6753.     KK1=MRC
  6754.     KK2=MRC
  6755.     IF(KRDELT.GT.0)KK1=(LC-2)/KRDELT
  6756.     IF(KCDELT.GT.0)KK2=(LR-1)/KCDELT
  6757.     KK=MIN0(KK1,KK2)
  6758.     IF(KK.GE.(MRC-100))GOTO 222
  6759. C IF BOTH DELTAS ARE ZERO DON'T TOUCH ANYTHING.
  6760.     KSHEET=MAX0(KK,0)
  6761. C KSHEET NONZERO FLAGS WE MAKE THE MOD
  6762.     IF(LR.LT.KSHEET*KCDELT)GOTO 2220
  6763.     IF((LC-1).LT.KSHEET*KRDELT)GOTO 2220
  6764. 222    CONTINUE
  6765.     GOTO 2221
  6766. 2220    CONTINUE
  6767.     KSHEET=0
  6768. 2221    CONTINUE
  6769.     RETURN
  6770.     END
  6771. c -h- errcx.for    Fri Aug 22 13:08:07 1986    
  6772.     SUBROUTINE ERRCX (RETCD)
  6773. C COPYRIGHT (C) 1983 GLENN EVERHART
  6774. C ALL RIGHTS RESERVED
  6775. C 60=MAX REAL ROWS
  6776. C 301=MAX REAL COLS
  6777. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  6778. C VBLS AND TYPE DIMENSIONED 60,301
  6779. C **************************************************
  6780. C *                                                *
  6781. C *            SUBROUTINE ERRCX                    *
  6782. C *                                                *
  6783. C **************************************************
  6784. C
  6785. C
  6786. C THIS SUBROUTINE DOES INITIAL SYNTAX CHECKING ON THE INPUT
  6787. C LINE. THE CHECKS MAKE SURE THAT PARENTHESES ARE BALANCED
  6788. C AND THAT THE EQUAL SIGN IS NOT MISUSED.
  6789. C
  6790. C RETCD     MEANING
  6791. C
  6792. C   1        NO ERRORS DETECTED
  6793. C   2        ERROR FOUND
  6794. C
  6795. C
  6796. C
  6797. C
  6798. C   MODIFICATION CLASSES: M1
  6799. C
  6800. C
  6801. C
  6802. C
  6803. C ERRCX CALLS ERRMSG WHICH PRINTS ERROR MESSAGES.
  6804. C
  6805. C
  6806. C
  6807. C ERRCX IS CALLED BY CALC
  6808. C
  6809. C
  6810. C
  6811. C   VARIABLE       USE
  6812. C
  6813. C    ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC
  6814. C                 OR THE CHARACTER %.
  6815. C    BLANK        ' '
  6816. C    I,J          HOLDS TEMPORARY VALUES.
  6817. C    LAST         HOLDS A CODE WHEN LOOKING FOR ERRORS INVOLVING
  6818. C                 THE EQUAL SIGN.
  6819. C    LEND         LAST NON-BLANK CHARACTER IN LINE(80).
  6820. C    LPAR         '('
  6821.  
  6822. C    PARCNT       0 IF PARENTHESIS ENCOUNTERED BALANCE. INCREASED
  6823. C                 BY 1 FOR EVERY LEFT PARENTHESIS, DECREASED BY
  6824. C                 BY 1 FOR EVERY RIGHT PERENTHESIS FOUND.
  6825. C    RETCD        HOLDS RETURN CODE. 1=O.K.  2=ERROR
  6826. C    RPAR         ')'
  6827. C
  6828. C
  6829. C
  6830. C    MODIFIED    REASON
  6831. C
  6832. C    18-MAY-1981    WHEN CHECKING FOR BALANCED PARENTHESIS, DON'T
  6833. C            INCLUDE THOSE THAT ARE PRECEEDED BY A SINGLE QUOTE
  6834. C            (CODE AT DO 100) (PB)
  6835. C
  6836. C
  6837. C
  6838. C    SUBROUTINE ERRCX (RETCD)
  6839.     InTeGer*4 LEVEL,NONBLK,LEND
  6840.     InTeGer*4 RETCD,PARCNT,VIEWSW,BASED
  6841.     InTeGer*4 I,LAST
  6842. C
  6843.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  6844.     CHARACTER*1 LINE(80)
  6845.     CHARACTER*1 QUOTE
  6846.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  6847.     COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  6848.     save quote
  6849.     DATA QUOTE/''''/
  6850. C
  6851. C
  6852. C
  6853.     RETCD=1
  6854. C
  6855. C **************************************************
  6856. C ******  MAKE SURE PARENTHESIS ARE BALANCED  ******
  6857. C **************************************************
  6858. C
  6859.     PARCNT=0
  6860.     I=NONBLK
  6861. 4100    CONTINUE
  6862. C    DO 100 I=NONBLK,LEND
  6863. C SKIP VARIABLE NAMES WHICH ARE IN ENCODED FORM
  6864.     IF(ICHAR(LINE(I)).NE.255)GOTO 4101
  6865.     I=I+2
  6866.     GOTO 100
  6867. C AT 100 ADD 1 MORE TO I, SKIPPING CRUFT.
  6868. 4101    CONTINUE
  6869.     IF (LINE(I).EQ.LPAR) GOTO 50
  6870.     IF (LINE(I).EQ.RPAR) GOTO 80
  6871.     GOTO 100
  6872. C
  6873. C ENCOUNTERED A LEFT PARENTHESIS, COUNT IT ONLY IF PRECEEDING
  6874. C CHARACTER IS NOT A SINGLE QUOTE
  6875. 50    IF(I.EQ.NONBLK) GOTO 60
  6876.     IF(LINE(I-1).EQ.QUOTE) GOTO 100
  6877. 60    PARCNT=PARCNT+1
  6878.     GOTO 100
  6879. C
  6880. C ENCOUNTERED A RIGHT PARENTHESIS, COUNT IT ONLY IF PRECEEDING
  6881. C CHARACTER IS NOT A SINGLE QUOTE
  6882. 80    IF(I.EQ.NONBLK) GOTO 90
  6883.     IF(LINE(I-1).EQ.QUOTE) GOTO 100
  6884. 90    PARCNT=PARCNT-1
  6885.     IF(PARCNT.LT.0)GOTO 160
  6886. 100    CONTINUE
  6887.     I=I+1
  6888.     IF(I.LE.LEND)GOTO 4100
  6889. C
  6890.     IF (PARCNT.EQ.0) GOTO 200
  6891. C
  6892. C
  6893. C UNBALANCED PARENTHESIS
  6894.     I=6
  6895. 140    CALL ERRMSG(I)
  6896. 150    RETCD=2
  6897.     RETURN
  6898. C
  6899. C
  6900. C ILLEGAL EXPRESSION LIKE ')))X((('
  6901. 160    I=8
  6902.     GOTO 140
  6903. C
  6904. C
  6905. C **************************************************
  6906. C *********   = SIGN SYNTAX CHECK   ****************
  6907. C **************************************************
  6908. C
  6909. 200    CONTINUE
  6910. C
  6911. C
  6912. C  ALLOW A=B=C+2
  6913. C  MAY ONLY ASSIGN VALUES TO SINGLE UNSIGNED VARIABLES.
  6914. C  ALSO CATCH  =A
  6915. C       AND    A==B
  6916. C
  6917. C  LAST    =  0    FIRST CHAR OR FOUND =
  6918. C       1    1 ALPHA CHARACTER
  6919. C       2    MORE THAN 1 ALPHA OR
  6920. C        ENCOUNTERED NON-ALPHA
  6921. C        (BUT NOT = OR BLANK)
  6922. C
  6923. C
  6924.     LAST=0
  6925.     I=NONBLK
  6926. 271    CONTINUE
  6927. C    DO 270 I=NONBLK,LEND
  6928.     IF (LINE(I).EQ.BLANK) GOTO 270
  6929.     IF (LINE(I).EQ.EQ) GOTO 230
  6930. C
  6931. C
  6932. C  LOOK FOR ALPHA
  6933. C    DO 220 J=1,27
  6934. C    IF (LINE(I).EQ.ALPHA(J)) GOTO 240
  6935. C220    CONTINUE
  6936. C LOOK FOR ANY VARIABLE NAME (NOT JUST ALPHA) (GCE)
  6937.     LLND=LEND
  6938.     CALL VARSCN(LINE,I,LLND,LSTCHR,ID1,ID2,IVALID)
  6939.     IF(IVALID.EQ.0) GOTO 220
  6940.     I=LSTCHR
  6941.     IF(LSTCHR.LT.LEND)I=LSTCHR-1
  6942. C IF WE GET A GOOD VARIABLE NAME POINT AT ITS END AND GO SAY WE'RE OK.
  6943.     GOTO 240
  6944. 220    CONTINUE
  6945. C
  6946. C
  6947. C   MORE THAN 1 ALPHA OR ENCOUNTERED NON-ALPHA
  6948. C (BUT NOT = SIGN OR BLANK)
  6949. 225    LAST=2
  6950.     GOTO 270
  6951. C
  6952. C
  6953. C = SIGN ENCOUNTERED
  6954. 230    IF (LAST.EQ.1) GOTO 235
  6955. C
  6956. C ILLEGAL USE OF = SIGN
  6957.     GOTO 290
  6958. C
  6959. C HAD 1 ALPHA CHARACTER FOLLOWED BY = SIGN
  6960. 235    LAST=0
  6961.     GOTO 270
  6962. C
  6963. C ENCOUNTERED A VARIABLE NAME (1 CHARACTER)
  6964. 240    IF (LAST.EQ.2) GOTO 270
  6965.     IF (LAST.EQ.1) GOTO 225
  6966. C
  6967. C
  6968. C EXACTLY 1 ALPHA CHARACTER EITHER AS FIRST CHARACTER
  6969. C ENCOUNTERED OR AS THE 1ST CHARACTER AFTER AN = SIGN.
  6970.     LAST=1
  6971. 270    CONTINUE
  6972.     I=I+1
  6973.     IF(I.LE.LEND) GOTO 271
  6974. C *****&&&&&  SIMULATE DO LOOP TO ALLOW MONKEYING WITH INDEX INSIDE.
  6975. C WHICH IS DONE SO WE CAN HUNT FOR VARIABLES BY NAME...
  6976. C
  6977. C
  6978. C <<<<<<<<<<<< ADD ADDITIONAL CHECKS HERE >>>>>>>>>>
  6979. C
  6980.     RETURN
  6981. C
  6982. C
  6983. C ILLEGAL USE OF = SIGN
  6984. 290    I=17
  6985.     GO TO 140
  6986.     END
  6987. c -h- errmsg.for    Fri Aug 22 13:08:07 1986    
  6988.     SUBROUTINE ERRMSG (IMSG)
  6989. C COPYRIGHT (C) 1983 GLENN EVERHART
  6990. C ALL RIGHTS RESERVED
  6991. C 60=MAX REAL ROWS
  6992. C 301=MAX REAL COLS
  6993. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  6994. C VBLS AND TYPE DIMENSIONED 60,301
  6995. C **************************************************
  6996. C *                                                *
  6997. C *       SUBROUTINE  ERRMSG(MSG)                  *
  6998. C *                                                *
  6999. C **************************************************
  7000. C
  7001. C
  7002. C PRINTS OUT ERROR MESSAGES AS REQUESTED BY CODE IN MSG.
  7003. C
  7004. C ERRMSG IS CALLED BY THE FOLLOWING ROUTINES:
  7005. C
  7006. C AT
  7007. C BASCNG
  7008. C CALBIN
  7009. C CALC
  7010. C CALUN
  7011. C CMND
  7012. C CONTYP
  7013. C DECLR
  7014. C ERRCX
  7015. C INPOST
  7016. C MULADD
  7017. C MULDIV
  7018. C MULMUL
  7019. C NEXTEL
  7020. C POSTVL
  7021. C VAROUT
  7022. C ZNEG
  7023. C
  7024. C
  7025. C    VARIABLE    USE
  7026. C
  7027. C   I         TEMPORARY VARIABLE TO AVOID SIDE-EFFECT WITH CALLS
  7028. C             THAT USE A CONSTANT FOR THE ARGUMENT.
  7029. C   MSG       ERROR MESSAGE CODE.
  7030. C
  7031. C
  7032. C
  7033. C  NOTE: USE CODE 25 FOR UNKNOWN CAUSES.
  7034. C
  7035. C
  7036. C
  7037. C    SUBROUTINE ERRMSG (MSG)
  7038. C
  7039.     InTeGer*4 IMSG,I
  7040.     CHARACTER*20 MSG(27)
  7041.     CHARACTER*8 EMSG
  7042.     save msg
  7043.     DATA EMSG/'*ERROR* '/
  7044.     DATA MSG(1)/'1ST CHAR ILLEGAL   '/
  7045.     DATA MSG(2)/'INDIR.NEST OVFLOW  '/
  7046.     DATA MSG(3)/'UNIDENTIFIED CMND  '/
  7047.     DATA MSG(4)/'ILL CHR IN VBL LIST'/
  7048.     DATA MSG(5)/'VBLS NT SEP W/COMMA'/
  7049.     DATA MSG(6)/'UNBAL PARENTHESIS  '/
  7050.     DATA MSG(7)/'STACK 1 OVERFLOW   '/
  7051.     DATA MSG(8)/'ILLEGAL EXPRESSION '/
  7052.     DATA MSG(9)/'STACK 2 OVERFLOW   '/
  7053.     DATA MSG(10)/'FCN ILL W/INT ARGS '/
  7054.     DATA MSG(11)/'FCN ILL W/MPR ARGS '/
  7055.     DATA MSG(12)/'FCN ILL W/ASCI ARG '/
  7056.     DATA MSG(13)/'FCN ILL W/REAL ARG '/
  7057.     DATA MSG(14)/'SQRT OF NEG NUMBER '/
  7058.     DATA MSG(15)/'MP EXP W/NEG POWER '/
  7059.     DATA MSG(16)/'UNDEFINED VARIABLE '/
  7060.     DATA MSG(17)/'ILL USE OF = SIGN  '/
  7061.     DATA MSG(18)/'UNIDENTIFIED FUNCT '/
  7062.     DATA MSG(19)/'ILLEGAL BASE SPEC  '/
  7063.     DATA MSG(20)/'ILLEGAL CHARACTER  '/
  7064.     DATA MSG(21)/'. OK ONLY W/BASE 10'/
  7065.     DATA MSG(22)/'OVER 19 DIGIT MP NO'/
  7066.     DATA MSG(23)/'DIVIDE BY ZERO ERR '/
  7067.     DATA MSG(24)/'ILL REAL EXP FIELD '/
  7068.     DATA MSG(25)/'WEIRD BUG. CALL GE.'/
  7069.     DATA MSG(26)/'ILLEG CONVERSION   '/
  7070.     DATA MSG(27)/'READ ERROR         '/
  7071. C
  7072. C
  7073.     CALL UVT100(1,1,10)
  7074. C WRITE "*ERROR*" FOLLOWED BY MESSAGE TEXT/
  7075.     CALL SWRT(EMSG,8)
  7076.     I=IMSG
  7077.     IF(I.LE.0.OR.I.GT.27)I=25
  7078.     CALL SWRT(MSG(I),20)
  7079. C
  7080. 99    RETURN
  7081.     END
  7082. c -h- flip.for    Fri Aug 22 13:09:05 1986    
  7083.     SUBROUTINE FLIP (VEC,SIZE,PT)
  7084. C COPYRIGHT (C) 1983 GLENN EVERHART
  7085. C ALL RIGHTS RESERVED
  7086. C 60=MAX REAL ROWS
  7087. C 301=MAX REAL COLS
  7088. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  7089. C VBLS AND TYPE DIMENSIONED 60,301
  7090. C **************************************************
  7091. C *                                                *
  7092. C *         SUBROUTINE FLIP(VEC,SIZE,PT)           *
  7093. C *                                                *
  7094. C **************************************************
  7095. C
  7096. C
  7097. C  FLIPS THE NON-ZERO DIGITS UP TO PT IN VECTOR VEC IN REVERSE
  7098. C  ORDER.  USED TO PLACE NUMBERS IN PROPER ORDER INTO VBLS THAT
  7099. C  HAVE BEEN READ IN HIGH ORDER FIRST.
  7100. C
  7101. C FLIP IS CALLED BY NEXTEL
  7102. C
  7103. C   VARIABLE   USE
  7104. C
  7105. C     H1     TEMPORARILY HOLDS A CHARACTER*1 VALUE
  7106. C     I      INDEXES DIGITS THAT ARE FLIPPED.
  7107. C     K      THE MIDPOINT OF THE FLIPPING ACTION.
  7108. C     PT     HOLDS THE RANGE OF THE FLIPPING ACTION.
  7109. C            (USUALLY THE HIGH ORDER NON-ZERO DIGIT)
  7110. C
  7111. C
  7112. C
  7113. C    SUBROUTINE FLIP (VEC,SIZE,PT)
  7114. C
  7115. C
  7116.     InTeGer*4 SIZE,PT
  7117.     InTeGer*4 K
  7118. C
  7119.     CHARACTER*1 VEC(SIZE), H1
  7120. C
  7121. C
  7122.     K=PT/2
  7123.     IF (K.EQ.0) GOTO 20
  7124.     DO 10 I=1,K
  7125.     H1=VEC(I)
  7126.     VEC(I)=VEC(PT+1-I)
  7127. 10    VEC(PT+1-I)=H1
  7128. 20    RETURN
  7129.     END
  7130. c -h- fname.fms    Fri Aug 22 13:09:16 1986    
  7131.     SUBROUTINE FNAME(LINE,LLAST,INDEXF)
  7132. C RETURN FUNCTION NAME IF ANY
  7133. C IMPLEMENT CODE RECOGNITION ALSO...
  7134. C CODES 230-254 ARE THE FUNCTION NAMES... REPLACE THE 3 BYTES BY 1
  7135. C CODE BYTE TO IMPLEMENT...
  7136. C
  7137.     CHARACTER*1 LINE(110)
  7138. c    EXTERNAL INDX
  7139.     INTEGER*4 FNAM(26)
  7140.     character*4 fnmx(26)
  7141.     equivalence(fnmx(1)(1:1),fnam(1))
  7142.     CHARACTER*1 FCHNM(4,26)
  7143.     EQUIVALENCE(FNAM(1),FCHNM(1,1))
  7144.     save fnmx
  7145.     DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
  7146.      1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
  7147.      2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
  7148.      3  'RND ','PMT','PVL','AVE','CHS','ATM'/
  7149.     INDEXF=0
  7150.     N1=ICHAR(LINE(1))
  7151. C RECOGNIZE ENCODED VARIABLE NAMES.
  7152.     IF(N1.LT.230.OR.N1.GT.254)GOTO 3000
  7153.     INDEXF=N1-229
  7154.     RETURN
  7155. 3000    CONTINUE
  7156.     DO 1 N1=1,26
  7157.     DO 2 N2=1,3
  7158.     IF(LINE(N2).NE.FCHNM(N2,N1))GOTO 1
  7159. 2    CONTINUE
  7160. C IF WE FALL THROUGH, WE HAVE A VALID FCN NAME INDEX IN INDEXF
  7161.     INDEXF=N1
  7162.     GOTO 3
  7163. 1    CONTINUE
  7164. 3    CONTINUE
  7165.     RETURN
  7166.     END
  7167. c -h- frmedt.ftn    Fri Aug 22 13:09:29 1986    
  7168.     SUBROUTINE FRMEDT(INLIN,LEND)
  7169. C COPYRIGHT 1984 GLENN AND MARY EVERHART
  7170. C ALL RIGHTS RESERVED
  7171. C FORMULA EDIT TO FIND AND EDIT FORMULAS OF FORM
  7172. C    {VAR
  7173. C AND REPLACE THE VARIABLE SPEC BY FORMULA FOR THAT VARIABLE
  7174.     INCLUDE aparms.inc
  7175.     CHARACTER*1 INLIN(110),WRK1(120),WRK2(128)
  7176.     CHARACTER*3 WRK13
  7177.     EQUIVALENCE(WRK13(1:1),WRK1(23))
  7178.     InTeGer*4 RRWACT,RCLACT
  7179. C    COMMON/RCLACT/RRWACT,RCLACT
  7180.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  7181.      1  IDOL7,IDOL8
  7182. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  7183. C     1  IDOL7,IDOL8
  7184.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  7185. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  7186.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  7187. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  7188. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  7189. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  7190.     InTeGer*4 KLVL
  7191. C    COMMON/KLVL/KLVL
  7192.     InTeGer*4 IOLVL,IGOLD
  7193. C    COMMON/IOLVL/IOLVL
  7194. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  7195. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  7196.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  7197.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  7198.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  7199.      3  k3dfg,kcdelt,krdelt,kpag
  7200. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  7201. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  7202. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  7203. CCC    InTeGer*4 LLCMD,LLDSP
  7204. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  7205. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  7206. C ADD LOGICAL NAMES IN THE FOLLOWING FASHION, TO BE MANIPULATED
  7207. C HERE ALONE:
  7208. C
  7209. C STORE LOGICAL NAMES, UP TO 16 CHARS, HERE IN AN ARRAY WITH
  7210. C DESIRED ID1,ID2 VALUES OF CELLS TO LOAD. WHERE A {NAME IS SEEN,
  7211. C REPLACE WITH DESIRED CELL ADDRESS.
  7212. C  TO DEFINE LOGICAL NAMES, LOOK FOR = AFTER A NAME. IF = IS SEEN
  7213. C  AFTER THE { CHARACTER, ASSUME IT'S A LINE OF FORM {SALES=AA0
  7214. C  (OR {SALES=00 TO DEASSIGN) AND STORE THE NAME. UP TO THE USER
  7215. C  TO PUT THE DESIRED FORMULA IN AS HE LIKES. MAY USE A TEST STMT
  7216. C  IF DESIRED.
  7217. CCC    CHARACTER*1 NAMARY(20,301)
  7218. C ALLOW AS MANY NAMES AS THERE ARE ROWS... ARBITRARY...
  7219.     InTeGer*4 ICREF,IRREF
  7220. C    COMMON/MIRROR/ICREF,IRREF
  7221.     InTeGer*4 MODPUB,LIMODE
  7222. C    COMMON/MODPUB/MODPUB,LIMODE
  7223.     InTeGer*4 KLKC,KLKR
  7224.     REAL*8 AACP,AACQ
  7225. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7226.     InTeGer*4 NCEL,NXINI
  7227. C    COMMON/NCEL/NCEL,NXINI
  7228.     CHARACTER*1 NAMARY(20,MROWS)
  7229. C    COMMON/NMNMNM/NAMARY
  7230.     InTeGer*4 NULAST,LFVD
  7231. C    COMMON/NULXXX/NULAST,LFVD
  7232.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7233.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7234.     InTeGer*2 NAMNUM(10,MROWS)
  7235.     EQUIVALENCE(NAMARY(1,1),NAMNUM(1,1))
  7236. CCC    COMMON/NMNMNM/NAMARY
  7237. C NAMNUM(9,RCL) AND NAMNUM(10,RCL) ARE RRW AND RCL
  7238. C STORAGE. NAMARY(1-18,RCL) STORES NAME ASCII TEXT (POSSIBLY
  7239. C NULL TERMINATED). FIND CELLS VIA LINEAR SEARCH.
  7240.     SAVE NAMMAX
  7241.     InTeGer*4 NAMMAX
  7242. C NAMMAX IS MAX DIM OF NAMARY THAT'S FILLED IN.
  7243.     EXTERNAL INDX
  7244.     InTeGer*4 LEND
  7245.     save nammax
  7246.     DATA NAMMAX/0/
  7247.     LCNT=0
  7248. 1000    IF(LCNT.GT.20)RETURN
  7249.     KKK=ICHAR('{')
  7250.     I1=INDX(INLIN,KKK)
  7251.     IF(I1.LE.0.OR.I1.GT.70)RETURN
  7252. C ONLY ALLOW IF THERE IS A { CHAR THERE
  7253.     IF(INLIN(I1).NE.'{')RETURN
  7254.     KKK=ICHAR('=')
  7255.     I2=INDX(INLIN,KKK)
  7256.     IF(I2.LE.0.OR.I2.LT.I1.OR.I2.GT.70.OR.INLIN(I2)
  7257.      1  .NE.'=')GOTO 5400
  7258.     IF((I2-I1).LE.1)GOTO 5400
  7259. C HERE SEE AN = SIGN AFTER A {VAR STRING. ATTEMPT TO EVALUATE.
  7260. C GUARANTEED AT LEAST 1 CHARACTER OF NAME.
  7261.     I3=MIN0((I2-I1-1),16)
  7262. c check if * seen ( text would then be  {*= ) for printout
  7263.  
  7264. c of symbol table
  7265.     IF(INLIN(I1+1).NE.'*')GOTO 5600
  7266.     IF(NAMMAX.LE.0)GOTO 5600
  7267.     CALL UVT100(1,LLCMD,1)
  7268.     CALL UVT100(12,2,0)
  7269. C ERASE LINE
  7270.     CALL VWRT('Output File:',12)
  7271.     call vget(wrk1,80)
  7272. c    read(11,5602,end=5419,err=5419)(wrk1(II),II=1,80)
  7273. 5602    format(80a1)
  7274.     DO 5603 N=1,79
  7275.     NN=80-N
  7276.     IF(JCHAR(WRK1(NN)).GT.32)GOTO 5604
  7277.     WRK1(NN)=Char(0)
  7278. 5603    CONTINUE
  7279. 5604    CONTINUE
  7280.     close(8)
  7281.     CALL WASSIG(8,WRK1)
  7282. C OPEN OUTPUT FOR WRITE
  7283. C THEN DUMP SYMBOLS THERE
  7284. C SYMBOL TABLE DUMP CAN BE SAVED ANYWHERE AND REENTERED AS
  7285. C ASSIGNMENT STMTS.
  7286.     WRK1(1)='{'
  7287.     DO 5607 N=2,110
  7288. 5607    WRK1(N)=char(0)
  7289.     WRK1(18)='='
  7290.     DO 5605 N=1,NAMMAX
  7291.     IF(NAMNUM(9,N)+NAMNUM(10,N).LE.0)GOTO 5605
  7292.     DO 5608 NN=1,16
  7293. 5608    WRK1(NN+1)=NAMARY(NN,N)
  7294.     CALL IN2AS(KK,WRK1(19))
  7295.     NAMNUM(9,N)=KK
  7296.     WRITE(WRK13(1:3),5606,ERR=5419)NAMNUM(10,N)-1
  7297. C    ENCODE(3,5606,WRK1(23))NAMNUM(10,N)-1
  7298. 5606    FORMAT(I3)
  7299.     K=3
  7300.     WRK2(1)='T'
  7301.     WRK2(2)='E'
  7302.     WRK2(3)=' '
  7303.     DO 5609 KK=1,106
  7304.     I4=JCHAR(WRK1(KK))
  7305.     IF(I4.LE.32)GOTO 5609
  7306.     K=K+1
  7307.     WRK2(K)=CHAR(I4)
  7308. 5609    CONTINUE
  7309. C WRITE OUT DEFINITIONS AS IF THEY WERE ASSIGMNENT STMTS.
  7310.     WRITE(8,5610)(WRK2(KK),KK=1,K)
  7311. 5610    FORMAT(110A1)
  7312. 5605    CONTINUE
  7313.     CLOSE(8)
  7314.     GOTO 5419
  7315. 5600    CONTINUE
  7316.     LO=I2+1
  7317.     IHI=LO+25
  7318.     CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
  7319. C IF IVLD=0 ASSUME WE'RE UNDEFINING THE SYMBOL
  7320.     IF(IVLD.GT.0)GOTO 5402
  7321. C INVALID SYMBOL. UNDEFINE THE STRING.
  7322.     DO 5403 I4=1,NAMMAX
  7323.     DO 5404 I5=1,I3
  7324. C REQUIRE WHOLE STRING FOR SEARCH.
  7325.     IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5403
  7326. 5404    CONTINUE
  7327. C GOT IT IF WE FALL THRU
  7328.     NAMNUM(9,I4)=0
  7329.     NAMNUM(10,I4)=0
  7330. C ZERO THE ELEMENT DEFINITION AND FORGET IT...
  7331.     DO 5432 I5=1,16
  7332. 5432    NAMARY(I5,I4)=Char(0)
  7333. 5403    CONTINUE
  7334.     GOTO 5419
  7335. 5402    CONTINUE
  7336. C VALID ARRAY ELEMENT, DEFINE IT.
  7337.     IF(NAMMAX.LE.0)GOTO 5406
  7338.     DO 5405 I4=1,NAMMAX
  7339.     IF(NAMNUM(9,I4)+NAMNUM(10,I4).EQ.0)GOTO 5410
  7340. 5405    CONTINUE
  7341.     GOTO 5406
  7342. 5410    CONTINUE
  7343. C GOT IT IF WE FALL THRU
  7344.     NAMNUM(9,I4)=ID1
  7345.     NAMNUM(10,I4)=ID2
  7346. C ZERO THE ELEMENT DEFINITION AND FORGET IT...
  7347.     GOTO 5407
  7348. 5406    CONTINUE
  7349.     IF(NAMMAX.LT.0)NAMMAX=0
  7350.     NAMMAX=MIN0(NAMMAX+1,MROWS)
  7351.     NAMNUM(9,NAMMAX)=ID1
  7352.     NAMNUM(10,NAMMAX)=ID2
  7353. C NOW SAVE THE SYMBOL NAME
  7354.     I4=NAMMAX
  7355. 5407    CONTINUE
  7356.     DO 5409 I5=1,16
  7357. 5409    NAMARY(I5,I4)=char(0)
  7358.     DO 5408 I5=1,I3
  7359.     NAMARY(I5,I4)=INLIN(I1+I5)
  7360. 5408    CONTINUE
  7361. C NO FURTHER PROCESSING IF WE DID ANY DEFINITION... JUST EXIT
  7362. 5419    CONTINUE
  7363.     INLIN(1)='%'
  7364. C IF A DEFINITION, JUST PUT SOMETHING INNOCUOUS INTO LINE FOR
  7365. C LATER PROCESSING.
  7366.     DO 5421 I5=2,110
  7367. 5421    INLIN(I5)=char(0)
  7368.     RETURN
  7369. 5400    CONTINUE
  7370. C NOW THAT DEFINITIONS ARE TAKEN CARE OF (IF ANY)
  7371. C HANDLE SYMBOLIC SEARCHES
  7372.     if(nammax.le.0)goto 5505
  7373.     LSTCHR=I1+1
  7374.     DO 5501 I4=1,NAMMAX
  7375.     DO 5502 I5=1,16
  7376.     IF(JCHAR(NAMARY(I5,I4)).LE.47)GOTO 5502
  7377.     IF(JCHAR(INLIN(I1+I5)).LE.47)GOTO 5502
  7378.     LSTCHR=I1+I5+1
  7379.     IF(INLIN(I1+I5).NE.NAMARY(I5,I4))GOTO 5501
  7380. CC SKIP OUT IF WE HAVE A TERMINATING CHARACTER IN DEF
  7381. CC AND HAD AT LEAST 1 NONTERMINATING CHAR IN DEFINITION.
  7382. C    IF(JCHAR(NAMARY(1,I4)).GT.47.AND.
  7383. C     1     JCHAR(NAMARY(I5,I4)).LE.47) GOTO 5560
  7384. 5502    CONTINUE
  7385. 5560    CONTINUE
  7386. C IF WE FALL THRU WE HAVE A MATCH
  7387.     ID1=NAMNUM(9,I4)
  7388.     ID2=NAMNUM(10,I4)
  7389. C LAST CHECK: BE SURE WE AREN'T GIVING A DELETED SYMBOL.
  7390.     IF((ID1+ID2).GT.0)GOTO 5500
  7391. 5501    CONTINUE
  7392. 5505    continue
  7393.     LO=I1+1
  7394.     IHI=LO+25
  7395.     CALL VARSCN(INLIN,LO,IHI,LSTCHR,ID1,ID2,IVLD)
  7396.     IF(IVLD.LE.0)RETURN
  7397. 5500    CONTINUE
  7398.     DO 11 N1=1,120
  7399. 11    WRK1(N1)=char(0)
  7400. C HERE HAVE A VALID CONSTRUCT SO REPLACE IT
  7401. C (ONLY ONE PER LINE THIS TIME ROUND)
  7402. C    IRX=(ID2-1)*60+ID1
  7403.     CALL REFLEC(ID2,ID1,IRX)
  7404. C COPY FIRST PART OF FORMULA TO WORK ARRAY
  7405.     LO=I1-1
  7406.     IHI=0
  7407.     IF(LO.LE.0)GOTO 10
  7408.     DO 1 N1=1,LO
  7409.     IHI=N1
  7410.     WRK1(IHI)=INLIN(N1)
  7411. 1    CONTINUE
  7412. 10    CONTINUE
  7413.     IHI=IHI+1
  7414.     CALL WRKFIL(IRX,WRK2,0)
  7415. C WRKFIL READS THE FORMULA INTO WRK2. NEXT FIND END OF TEXT
  7416.     DO 2 N1=1,110
  7417.     LO=111-N1
  7418.     IF(ICHAR(WRK2(LO)).GT.32)GOTO 3
  7419. 2    CONTINUE
  7420. 3    CONTINUE
  7421. C LO NOW IS LENGTH OF FORMULA
  7422.     DO 4 N1=1,LO
  7423.     WRK1(IHI)=WRK2(N1)
  7424.     IF(IHI.LT.110)IHI=IHI+1
  7425. 4    CONTINUE
  7426. C TACK ON ANY MORE TEXT
  7427. C RELY ON INLIN BEING 110 CHARS LONG
  7428.     DO 5 N1=LSTCHR,110
  7429.     WRK1(IHI)=INLIN(N1)
  7430.     IF(IHI.LT.110)IHI=IHI+1
  7431. 5    CONTINUE
  7432. C NOW COPY 110 CHARS BACK TO INLIN
  7433.     DO 6 N1=1,110
  7434. 6    INLIN(N1)=WRK1(N1)
  7435.     DO 7 N1=1,110
  7436.     LO=111-N1
  7437.     IF(ICHAR(INLIN(LO)).GT.32)GOTO 8
  7438. C    INLIN(LO)=CHAR(32)
  7439. 7    CONTINUE
  7440. 8    LEND=LO
  7441.     LCNT=LCNT+1
  7442.     GOTO 1000
  7443. C KEEP LOOKING & RECURSING BUT IMPOSE LIMIT
  7444. C    RETURN
  7445.     END
  7446. c -h- fvldgt.for    Fri Aug 22 13:10:38 1986    
  7447.         SUBROUTINE FVLDGT(ID1,ID2,IVAL)
  7448. C
  7449. C FVLDGT - RETURN FVLD BYTE GIVEN 2 DIMS OF ITS "LOCATION"
  7450.     INCLUDE aparms.inc
  7451.         InTeGer*4 ID1,ID2
  7452.         CHARACTER*1 IVAL
  7453. C NEXT BITMAPS IMPLEMENT FVLD
  7454.     EXTERNAL INDX
  7455.         CHARACTER*1 LBITS(8)
  7456.         COMMON/BITS/LBITS
  7457.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  7458.     CHARACTER*1 FVXX(Imps3)
  7459.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  7460.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  7461.         Common/FVLDM/FVXX
  7462. c        COMMON/FVLDM/FV1,FV2,FV4
  7463. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  7464. C TYPES OF AC'S STORAGE:
  7465.         CHARACTER*1 ITYP(Imp1s)
  7466.         InTeGer*4 IATYP(27),ijnkq
  7467.         COMMON/TYP/IATYP,ITYP,ijnkq
  7468.     InTeGer*4 ICREF,IRREF
  7469. C    COMMON/MIRROR/ICREF,IRREF
  7470.     InTeGer*4 MODPUB,LIMODE
  7471. C    COMMON/MODPUB/MODPUB,LIMODE
  7472.     InTeGer*4 KLKC,KLKR
  7473.     REAL*8 AACP,AACQ
  7474. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7475.     InTeGer*4 NCEL,NXINI
  7476. C    COMMON/NCEL/NCEL,NXINI
  7477.     CHARACTER*1 NAMARY(20,Mrows)
  7478. C    COMMON/NMNMNM/NAMARY
  7479.     InTeGer*4 NULAST,LFVD
  7480. C    COMMON/NULXXX/NULAST,LFVD
  7481.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7482.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7483. CCC    InTeGer*4 ICREF,IRREF
  7484. CCC    COMMON/MIRROR/ICREF,IRREF
  7485. C
  7486. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  7487. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  7488. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  7489. C AREAS WITH DATA.
  7490.     InTeGer*4 DLFG
  7491. C    COMMON/DLFG/DLFG
  7492.     InTeGer*4 KDRW,KDCL
  7493. C    COMMON/DOT/KDRW,KDCL
  7494.     InTeGer*4 DTRENA
  7495. C    COMMON/DTRCMN/DTRENA
  7496.     REAL*8 EP,PV,FV
  7497.     DIMENSION EP(20)
  7498.     INTEGER*4 KIRR
  7499. C    COMMON/ERNPER/EP,PV,FV,KIRR
  7500.     InTeGer*4 LASTOP
  7501. C    COMMON/ERROR/LASTOP
  7502.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  7503. C    COMMON/FMTBFR/FMTDAT
  7504.     CHARACTER*1 EDNAM(16)
  7505. C    COMMON/EDNAM/EDNAM
  7506.     InTeGer*4 MFID(2),MFMOD(2)
  7507. C    COMMON/FRM/MFID,MFMOD
  7508.     InTeGer*4 JMVFG,JMVOLD
  7509. C    COMMON/FUBAR/JMVFG,JMVOLD
  7510.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  7511.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  7512. CCC        CHARACTER*1 FMTDAT(9,Ifmtbk)
  7513. CCC        COMMON/FMTBFR/FMTDAT
  7514.         CHARACTER*1 I1,I2,I4
  7515.     CHARACTER*1 IT1,IT2,IT4,IT8
  7516.     LOGICAL*4 LT1,LT2,LT4,LT8
  7517.     InTeGer*4 KT1,KT2,KT4,KT8
  7518.     CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
  7519.        EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
  7520.      1(LT8,IT82(1))
  7521.        EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
  7522.      1 (KT8,IT82(1))
  7523. C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
  7524. C ORDER BYTE WITH EQUIVALENCES
  7525.     EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
  7526.      1 (IT82(2),IT8)
  7527.     IF(ID2.GT.0)GOTO 2000
  7528. C TRICK ENTRY USING ID IN FIRST ARG, 0 IN 2ND ARG...
  7529. C TELL XVBLST/XVBLGT ABOUT FV4 STATE (SET BY CALL WITH -4 BYTE ON FVLDST)
  7530.     ID=ID1
  7531.         IBT=((ID-1)/8)+1
  7532.     KT1=ID-1
  7533.     KT2=7
  7534.     KT1=IMASK(KT1,KT2)
  7535. C    LT1=LT1.AND.LT2
  7536.     IBIT=KT1+1
  7537. C        IBIT=((ID-1).AND.7)+1
  7538. C        I1=FV1(IBT).AND.LBITS(IBIT)
  7539. C        I2=FV2(IBT).AND.LBITS(IBIT)
  7540. C        I4=FV4(IBT).AND.LBITS(IBIT)
  7541.     KT1=ICHAR(FV1(IBT))
  7542.     KT2=ICHAR(FV2(IBT))
  7543.     KT4=ICHAR(FV4(IBT))
  7544.     KT8=ICHAR(LBITS(IBIT))
  7545.     KT1=IMASK(KT1,KT8)
  7546. C    LT1=LT1.AND.LT8
  7547.     KT2=IMASK(KT2,KT8)
  7548. C    LT2=LT2.AND.LT8
  7549.     KT4=IMASK(KT4,KT8)
  7550. C    LT4=LT4.AND.LT8
  7551.     I1=CHAR(KT1)
  7552.     I2=CHAR(KT2)
  7553.     I4=CHAR(KT4)
  7554.     IVAL=char(0)
  7555. C RETURN NONZERO IF ANY BITS ARE SET.
  7556.     IF((KT1+KT2+KT4).NE.0)IVAL=char(1)
  7557. C    IF((I1+I2+I4).NE.0)IVAL=1
  7558.     RETURN
  7559. 2000    CONTINUE
  7560. C REFLECT ALL BACK TO PRIME STORAGE REGION
  7561. C        ID=(ID2-1)*60+ID1
  7562.     IF(ID2.EQ.1.AND.ID1.LE.MRC)GOTO 7806
  7563.     CALL REFLEC(ID2,ID1,ID)
  7564.     GOTO 7807
  7565. 7806    CONTINUE
  7566.     ID=ID1
  7567. 7807    IBT=((ID-1)/8)+1
  7568.     KT1=ID-1
  7569.     KT2=7
  7570.     KT1=IMASK(KT1,KT2)
  7571. C    LT1=LT1.AND.LT2
  7572.     IBIT=KT1+1
  7573. C        IBIT=((ID-1).AND.7)+1
  7574. C        I1=FV1(IBT).AND.LBITS(IBIT)
  7575. C        I2=FV2(IBT).AND.LBITS(IBIT)
  7576. C        I4=FV4(IBT).AND.LBITS(IBIT)
  7577.     KT1=ICHAR(FV1(IBT))
  7578.     KT2=ICHAR(FV2(IBT))
  7579.     KT4=ICHAR(FV4(IBT))
  7580.     KT8=ICHAR(LBITS(IBIT))
  7581. C    LT1=LT1.AND.LT8
  7582. C    LT2=LT2.AND.LT8
  7583. C    LT4=LT4.AND.LT8
  7584.     KT1=IMASK(KT1,KT8)
  7585.     KT2=IMASK(KT2,KT8)
  7586.     KT4=IMASK(KT4,KT8)
  7587. C    I1=CHAR(KT1)
  7588. C    I2=CHAR(KT2)
  7589. C    I4=CHAR(KT4)
  7590.         IVL=0
  7591.         IF(KT1.NE.0)IVL=1
  7592.         IF(KT2.NE.0)IVL=IVL+2
  7593.         IF(KT4.NE.0)IVL=-IVL
  7594.         IVAL=CHAR(IVL)
  7595. C READS OFF FVLD BYTE FROM 3 BITS, HIGH ONE IS SIGN. TREAT AS SIGN-
  7596. C MAGNITUDE NUMBER IN RANGE -3 TO +3,
  7597.         RETURN
  7598.         END
  7599. c -h- fvldst.for    Fri Aug 22 13:10:51 1986    
  7600.         SUBROUTINE FVLDST(ID1,ID2,IVAL)
  7601. C
  7602. C FVLDST - SET THE BYTE IN FVLD ARRAY
  7603. C NEXT BITMAPS IMPLEMENT FVLD
  7604.     Include aparms.inc
  7605.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  7606.     CHARACTER*1 FVXX(IMps3)
  7607.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  7608.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  7609.         Common/FVLDM/FVXX
  7610. c        COMMON/FVLDM/FV1,FV2,FV4
  7611.         CHARACTER*1 IVAL
  7612.         CHARACTER*1 LBITS(8)
  7613.     EXTERNAL INDX
  7614.         COMMON/BITS/LBITS
  7615. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  7616. C TYPES OF AC'S STORAGE:
  7617.         CHARACTER*1 ITYP(Imp1s)
  7618.         InTeGer*4 IATYP(27),ijnkq
  7619.         COMMON/TYP/IATYP,ITYP,ijnkq
  7620.     InTeGer*4 ICREF,IRREF
  7621. C    COMMON/MIRROR/ICREF,IRREF
  7622.     InTeGer*4 MODPUB,LIMODE
  7623. C    COMMON/MODPUB/MODPUB,LIMODE
  7624.     InTeGer*4 KLKC,KLKR
  7625.     REAL*8 AACP,AACQ
  7626. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7627.     InTeGer*4 NCEL,NXINI
  7628. C    COMMON/NCEL/NCEL,NXINI
  7629.     CHARACTER*1 NAMARY(20,MRows)
  7630. C    COMMON/NMNMNM/NAMARY
  7631.     InTeGer*4 NULAST,LFVD
  7632. C    COMMON/NULXXX/NULAST,LFVD
  7633.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7634.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7635. CCC    InTeGer*4 ICREF,IRREF
  7636. CCC    COMMON/MIRROR/ICREF,IRREF
  7637. C
  7638. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  7639. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  7640. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  7641. C AREAS WITH DATA.
  7642.     InTeGer*4 DLFG
  7643. C    COMMON/DLFG/DLFG
  7644.     InTeGer*4 KDRW,KDCL
  7645. C    COMMON/DOT/KDRW,KDCL
  7646.     InTeGer*4 DTRENA
  7647. C    COMMON/DTRCMN/DTRENA
  7648.     REAL*8 EP,PV,FV
  7649.     DIMENSION EP(20)
  7650.     INTEGER*4 KIRR
  7651. C    COMMON/ERNPER/EP,PV,FV,KIRR
  7652.     InTeGer*4 LASTOP
  7653. C    COMMON/ERROR/LASTOP
  7654.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  7655. C    COMMON/FMTBFR/FMTDAT
  7656.     CHARACTER*1 EDNAM(16)
  7657. C    COMMON/EDNAM/EDNAM
  7658.     InTeGer*4 MFID(2),MFMOD(2)
  7659. C    COMMON/FRM/MFID,MFMOD
  7660.     InTeGer*4 JMVFG,JMVOLD
  7661. C    COMMON/FUBAR/JMVFG,JMVOLD
  7662.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  7663.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  7664. CCC        CHARACTER*1 FMTDAT(9,Ifmtbk)
  7665.     InTeGer*4 IVV,I1,I2,I3,ITA
  7666.     LOGICAL*4 L2,L1,LVV,LTA
  7667.     EQUIVALENCE(L2,I2),(L1,I1),(LVV,IVV)
  7668.     EQUIVALENCE(LTA,ITA)
  7669. CCC        COMMON/FMTBFR/FMTDAT
  7670. c    CHARACTER*1 IT1,IT2,IT4,IT8
  7671.     LOGICAL*4 LT1,LT2,LT4,LT8
  7672.     InTeGer*4 KT1,KT2,KT4,KT8,KW1,KW2
  7673.     CHARACTER*1 IT12(2),IT22(2),IT42(2),IT82(2)
  7674.     EQUIVALENCE(LT1,IT12(1)),(LT2,IT22(1)),(LT4,IT42(1)),
  7675.      1  (LT8,IT82(1))
  7676.     EQUIVALENCE(KT1,IT12(1)),(KT2,IT22(1)),(KT4,IT42(1)),
  7677.      1  (KT8,IT82(1))
  7678. C INTEL 8088 USES 1ST CHAR IN HIGH BYTE SO FORCE IT1, IT2, IT4 ETC TO LOW
  7679. C ORDER BYTE WITH EQUIVALENCES
  7680. C    EQUIVALENCE(IT12(2),IT1),(IT22(2),IT2),(IT42(2),IT4),
  7681. C     1  (IT82(2),IT8)
  7682. C        CHARACTER*1 I4
  7683.     IF(ID2.EQ.1.AND.ID1.LE.MRC)GOTO 7806
  7684. C ALLOW DELIBERATE CALL WITH EFFECTIVELY ONE ARG.
  7685. 7807    CALL REFLEC(ID2,ID1,ID)
  7686.     GOTO 7808
  7687. 7806    CONTINUE
  7688. C        ID=(ID2-1)*60+ID1
  7689.     ID=ID1
  7690. 7808    IBT=((ID-1)/8)+1
  7691.     KT1=ID-1
  7692.     KT2=7
  7693.     KT1=IMASK(KT1,KT2)
  7694. C    LT1=LT1.AND.LT2
  7695.     IBIT=KT1+1
  7696. C        IBIT=((ID-1).AND.7)+1
  7697. C ZERO ALL 3 FVLD BITS FIRST
  7698. C        FV1(IBT)=FV1(IBT).AND..NOT.LBITS(IBIT)
  7699. C        FV2(IBT)=FV2(IBT).AND..NOT.LBITS(IBIT)
  7700. C        FV4(IBT)=FV4(IBT).AND..NOT.LBITS(IBIT)
  7701.     KT1=ICHAR(FV1(IBT))
  7702.     KT2=ICHAR(FV2(IBT))
  7703.     KT4=ICHAR(FV4(IBT))
  7704.     KT8=ICHAR(LBITS(IBIT))
  7705.     ITA=-KT8-1
  7706. C ITA IS NOW THE COMPLEMENT OF KT8
  7707. C THUS, THE SELECTED BIT IS OFF IN IT, ALL OTHERS ON.
  7708. C    LT1=LT1.AND.LTA
  7709. C    LT2=LT2.AND.LTA
  7710. C    LT4=LT4.AND.LTA
  7711.     KT1=IMASK(KT1,ITA)
  7712.     KT2=IMASK(KT2,ITA)
  7713.     KT4=IMASK(KT4,ITA)
  7714. C FILL IN ALL 3 BITMAPS WITH THEIR PREVIOUS CONTENTS EXCEPT THE
  7715. C CHOSEN BITS.
  7716.     FV1(IBT)=CHAR(KT1)
  7717.     FV2(IBT)=CHAR(KT2)
  7718.     FV4(IBT)=CHAR(KT4)
  7719.     IVVV=JCHAR(IVAL)
  7720.         IVV=IABS(IVVV)
  7721.         I3=0
  7722.         IF(IVVV.LT.0)I3=1
  7723. C    I1=1
  7724. C    I2=2
  7725.     KW2=2
  7726.     KW1=1
  7727.     I2=IMASK(IVV,KW2)
  7728.     I1=IMASK(IVV,KW1)
  7729. C        L2=LVV.AND.L2
  7730. C        L1=LVV.AND.L1
  7731. C NOTE WE ASSUME HEAVILY THAT LOGICAL OPERATIONS WORK BY BINARY
  7732. C ANDS AND ORS IN DATA.
  7733. C ** NOTE WE DON'T NEED TO RELOAD THE KT1 THRU KT4 INTEGERS... ALL ALREADY
  7734. C ARE LOADED... DITTO KT8
  7735. C    KT1=ICHAR(FV1(IBT))
  7736. C    KT2=ICHAR(FV2(IBT))
  7737. C    KT4=ICHAR(FV4(IBT))
  7738. C    KT8=ICHAR(LBITS(IBIT))
  7739.     LT1=LT1.OR.LT8
  7740.     LT2=LT2.OR.LT8
  7741.     LT4=LT4.OR.LT8
  7742. ccc    kt1=ior(kt1,kt8)
  7743. ccc    kt2=ior(kt2,kt8)
  7744. ccc    kt4=ior(kt4,kt8)
  7745. C        IF(I1.NE.0)FV1(IBT)=FV1(IBT).OR.LBITS(IBIT)
  7746. C        IF(I2.NE.0)FV2(IBT)=FV2(IBT).OR.LBITS(IBIT)
  7747. C        IF(I3.NE.0)FV4(IBT)=FV4(IBT).OR.LBITS(IBIT)
  7748.         IF(I1.NE.0)FV1(IBT)=CHAR(KT1)
  7749.         IF(I2.NE.0)FV2(IBT)=CHAR(KT2)
  7750.         IF(I3.NE.0)FV4(IBT)=CHAR(KT4)
  7751.         RETURN
  7752.         END
  7753. c -h- fvpeek.fms    Fri Aug 22 13:11:27 1986    
  7754. C DUMMY FVPEEK
  7755.     SUBROUTINE FVPEEK(ID1,ID2,IGO)
  7756.     InTeGer*4 ID1,ID2,IGO
  7757.     IGO=ID1
  7758.     RETURN
  7759.     END
  7760. c -h- getfnl.for    Fri Aug 22 13:12:09 1986    
  7761.     SUBROUTINE GETFNL(LINE,LSKP,LLEN)
  7762. C PARSE OUT FILENAME AND GET LSKP, LLEN NUMBERS
  7763.     EXTERNAL INDX
  7764.     CHARACTER*1 LINE(80)
  7765.     InTeGer*4 LSKP,LLEN,LO,HI
  7766.     LSKP=0
  7767.     LLEN=32000
  7768. C SET INITIAL NUMBERS TO READ WHOLE FILE
  7769.     KKK=ICHAR(',')
  7770.     N=INDX(LINE,KKK)
  7771.     IF(N.LE.0.OR.N.GT.78)RETURN
  7772. C IF CANNOT FIND COMMA, JUST SKIP OUT & TRY TO CATCH ERRORS ON OPEN.
  7773.     LINE(N)=char(0)
  7774. C NULL TERMINATE FILENAME
  7775.     LO=N+1
  7776.     HI=LO+20
  7777.     CALL GN(LO,HI,LSKP,LINE)
  7778.     LO=N+1
  7779.     KKK=ICHAR(',')
  7780.     N=INDX(LINE(LO),KKK)
  7781.     IF(N.LE.0.OR.N.GT.30)RETURN
  7782.     LO=LO+N
  7783.     HI=LO+20
  7784.     CALL GN(LO,HI,LLEN,LINE)
  7785. C SHOULD HAVE NUMBERS NOW
  7786.     RETURN
  7787.     END
  7788. c -h- getlog.for    Fri Aug 22 13:12:16 1986    
  7789.     SUBROUTINE GETLOG(LINE,LMX,LOGTYP,LASST)
  7790.     CHARACTER*1 LINE(110)
  7791.     EXTERNAL INDX
  7792.     CHARACTER*1 LFN(4,6)
  7793.     CHARACTER*4 XLF(6)
  7794.     INTEGER*4 LF(6)
  7795.     EQUIVALENCE(XLF(1)(1:1),LF(1),LFN(1,1))
  7796. C    EQUIVALENCE(LF(1),LFN(1,1))
  7797.     save xlf
  7798.     DATA XLF/'.GT.','.LT.','.EQ.','.NE.','.GE.','.LE.'/
  7799. C LOGTYP RELATIONSHIP TO RELATIONSHIPS OF 2 VARIABLES
  7800. C IS DEFINED IN ABOVE DATA STMT.
  7801. C IF LINE CONTAINS STRING IN NAME, RETURN TYPE AND END LOC.
  7802.     LMX4=LMX-3
  7803.     DO 100 LL=1,6
  7804.     LOGTYP=LL
  7805.     DO 1 N1=1,LMX4
  7806.     IF(LINE(N1  ).NE.LFN(1,LL))GOTO 2
  7807.     IF(LINE(N1+1).NE.LFN(2,LL))GOTO 2
  7808.     IF(LINE(N1+2).NE.LFN(3,LL))GOTO 2
  7809.     IF(LINE(N1+3).NE.LFN(4,LL))GOTO 2
  7810. C HERE HAVE A MATCH
  7811.     LASST=N1
  7812. C RETURN LOC OF NEXT CHAR AFTER RELATION.
  7813.     GOTO 200
  7814. 2    CONTINUE
  7815. 1    CONTINUE
  7816. 100    CONTINUE
  7817.     LOGTYP=0
  7818. 200    CONTINUE
  7819.     RETURN
  7820.     END
  7821. c -h- getnnb.for    Fri Aug 22 13:13:44 1986    
  7822.     SUBROUTINE GETNNB(IPT,RETCD)
  7823. C COPYRIGHT (C) 1983 GLENN EVERHART
  7824. C ALL RIGHTS RESERVED
  7825. C 60=MAX REAL ROWS
  7826. C 301=MAX REAL COLS
  7827. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  7828. C VBLS AND TYPE DIMENSIONED 60,301
  7829. C **************************************************
  7830.  
  7831. C *                                                *
  7832. C *         SUBROUTINE GETNNB(IPT,RETCD)           *
  7833. C *                                                *
  7834. C **************************************************
  7835. C
  7836. C
  7837. C  GET NEXT NON-BLANK ELEMENT FROM LINE STARTING AT NONBLK+1
  7838. C
  7839. C  RETCD =  1   O.K.
  7840. C        2   NO NON-BLANK FOUND
  7841. C
  7842. C  IPT POINTS TO POSITION IN LINE WHERE NEXT NON-BLANK IS FOUND.
  7843. C  IT IS UP TO CALLING PROGRAM TO RESET NONBLK FOR NEXT SCAN.
  7844. C
  7845. C
  7846. C
  7847. C GETNNB IS CALLED BY
  7848. C
  7849. C AT
  7850. C BASCNG
  7851. C CMND
  7852. C NEXTEL
  7853. C STRCMP
  7854. C
  7855. C
  7856. C   VARIABLE    USE
  7857. C
  7858. C    BLANK      ' '
  7859. C    IPT        RETURNS POSITION OF NEXT NON-BLANK.
  7860. C    K          HOLDS TEMPORARY VALUES.
  7861. C    LEND       LAST NON-BLANK IN LINE(80).
  7862. C    NONBLK     HOLDS CHARACTER TO LEFT OF THE START OF THE SCAN.
  7863. C    RETCD      HOLDS THE RETURN CODE. 1=O.K.  2=THE REST IS BLANKS.
  7864. C
  7865. C
  7866. C    SUBROUTINE GETNNB(IPT,RETCD)
  7867. C
  7868. C
  7869.     InTeGer*4 IPT
  7870.     InTeGer*4 LEVEL,NONBLK,LEND
  7871.     InTeGer*4 VIEWSW,BASED,RETCD
  7872.     InTeGer*4 K
  7873. C
  7874.     CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  7875. C
  7876.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  7877.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  7878. C
  7879.     RETCD=1
  7880.     IF (NONBLK.GE.LEND) GOTO 999
  7881. C
  7882. C AT LEAST 1 NON-BLANK EXISTS.
  7883.     K=NONBLK+1
  7884.     DO 10 IPT=K,LEND
  7885.     IF (LINE(IPT).NE.BLANK) GOTO 1000
  7886. 10    CONTINUE
  7887. C
  7888. C
  7889. C ACTUALLY, SHOULD NEVER FALL THROUGH IF 'LEND' IS SET CORRECTLY.
  7890. C
  7891. C
  7892. C THE REST ARE BLANKS
  7893. 999    RETCD=2
  7894. 1000    RETURN
  7895.     END
  7896. c -h- getttl.for    Fri Aug 22 13:14:41 1986    
  7897.     SUBROUTINE GETTTL(LINE)
  7898.     Include aparms.inc
  7899.     CHARACTER*1 LINE(132)
  7900.     CHARACTER*3 FNAME
  7901.     CHARACTER*1 FN(3)
  7902.     EQUIVALENCE (FN(1),FNAME(1:1))
  7903.     InTeGer*4 IBBX
  7904.     InTeGer*4 ICREF,IRREF
  7905. C    COMMON/MIRROR/ICREF,IRREF
  7906.     InTeGer*4 MODPUB,LIMODE
  7907. C    COMMON/MODPUB/MODPUB,LIMODE
  7908.     InTeGer*4 KLKC,KLKR
  7909.     REAL*8 AACP,AACQ
  7910. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  7911.     InTeGer*4 NCEL,NXINI
  7912. C    COMMON/NCEL/NCEL,NXINI
  7913.     CHARACTER*1 NAMARY(20,MRows)
  7914. C    COMMON/NMNMNM/NAMARY
  7915.     InTeGer*4 NULAST,LFVD
  7916. C    COMMON/NULXXX/NULAST,LFVD
  7917.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  7918.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  7919. CCC    COMMON/MODPUB/MODPUB,LIMODE
  7920. C MODPUB = MODE USED IN CMD MODE GTMODE ROUTINE
  7921.     InTeGer*4 RRWACT,RCLACT
  7922. C    COMMON/RCLACT/RRWACT,RCLACT
  7923.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  7924.      1  IDOL7,IDOL8
  7925. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  7926. C     1  IDOL7,IDOL8
  7927.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  7928. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  7929.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  7930. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  7931. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  7932. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  7933.     InTeGer*4 KLVL
  7934. C    COMMON/KLVL/KLVL
  7935.     InTeGer*4 IOLVL,IGOLD
  7936. C    COMMON/IOLVL/IOLVL
  7937. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  7938. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  7939.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  7940.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  7941.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  7942.      3  k3dfg,kcdelt,krdelt,kpag
  7943. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  7944. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  7945. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  7946. CCC    InTeGer*4 LLCMD,LLDSP
  7947. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  7948. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  7949. C LIMODE IS WHAT GETS SET UP IN /# CMND
  7950.     IBBX=0
  7951. C
  7952. C CODE FOR FORTRAN READ...
  7953. C  **** HERE IS THE SECTION OF CODE YOU NEED FOR NON-VMS-SPECIFIC VERSION
  7954. C NOTE READS UNIT 0 TO GET CONSOLE.
  7955. C CHECK THAT WE'RE READING CONSOLE. IF LUN 5 IS OFF CONSOLE, THEN
  7956. C READ USING DIRECT DOS CALLS.
  7957. C  IF (STILL) IN AN INITIALIZER FILE, READ USING REGULAR FORTRAN READS
  7958. C AND ACT NORMALLY.
  7959. C  DISCOVER CONSOLE BECAUSE FILENAME IS 'CON:' OR 'CON'.
  7960. CC    INQUIRE(UNIT=5,NAME=FNAME)
  7961. CC    IF (FN(1).NE.'C'.OR.FN(2).NE.'O'.OR.FN(3).NE.'N')
  7962. CC     1 GOTO 5000
  7963. C CALL ASSEMBLER ROUTINE TO GET CHARACTERS.
  7964.     DO 5001 N=1,132
  7965. 5001    LINE(N)=CHAR(0)
  7966. C FIX IT UP SO A NULL LINE LOOKS HARMLESS...
  7967.     LINE(1)=' '
  7968. C NULL THE LINE FIRST IN FORTRAN; MAKES IT EASIER TO DO ASSEMBLER STUFF.
  7969.     CALL TTYIN(MODPUB,LINE)
  7970.     IF(LINE(1).NE.'/')GOTO 5540
  7971. C DISPLAY HELP MSG AT BOTTOM
  7972.     IF(MODPUB.EQ.0)GOTO 5540
  7973. C ONLY DISPLAY IF IN "AUTOENTER" MODE
  7974. c    CALL UVT100(1,LLDSP,1)
  7975. c    CALL SWRT('Add,Cpy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set',46)
  7976. c    CALL SWRT(',Tst,View,Wrt,Xit,Zap,/,Help',28)
  7977. c    CALL UVT100(1,LLCMD,11)
  7978. C CALL TTYIN NEXT WITH 0 SO / ISN'T TERMINATOR.
  7979. c    N=0
  7980. C    CALL TTYIN(N,LINE(2))
  7981. 5540    CONTINUE
  7982.     IF(ICHAR(LINE(1)).EQ.26)
  7983.      1  GOTO 2000
  7984. C Add,Copy,Dsp,Fil,Get,Kalc,Loc,Mov,Put,Recal,Set,Test,View,Wrt,Xit,Zap,Help,/
  7985. C READ IN AFTER CLOSE AND RE-OPEN IF WE GET EOF ON INPUT SIGNALLED
  7986. C BY CONTROL Z.
  7987. C ASSUME WE'LL USE DOS FUNCTION 1 FOR READIN AND ECHO
  7988. C AND THEN END THE READIN AFTER FIRST CONTROL SEQUENCE.
  7989. C    GOTO 6000
  7990. C5000    CONTINUE
  7991. C    READ(5,1000,END=2000,ERR=2000)LINE
  7992. 1000    FORMAT(132A1)
  7993. 6000    CONTINUE
  7994. CC    IF(ICHAR(LINE(1)).NE.0)RETURN
  7995. CCC IF WE GET 0 MAYBE IT'S AN EXTENDED CODE. TRY RETURNING A HASHED
  7996. CCC VALUE HERE. USE __{CELL WHERE CELL IS A FOLLOWED BY (B+CODE) WHERE
  7997. CC CODE IS THE VALUE RETURNED...
  7998. CC    LINE(5)=CHAR(ICHAR(LINE(2))+66-59)
  7999. CC EXTENDED CODES WE CARE ABOUT START AT 59.
  8000. CC MAP INTO EXTENDED AC'S STARTING AT AB SINCE AA IS THE SAME AS % ACCUMULATOR
  8001. CC WHICH CAN'T BE REASSIGNED THIS WAY.
  8002. C    LINE(5)=CHAR(ICHAR(LINE(2))+7)
  8003. C    LINE(1)='_'
  8004. C    LINE(2)='_'
  8005. C    LINE(3)='{'
  8006. C    LINE(4)='A'
  8007. C
  8008. C WE SHOULD "KNOW" COORDS HERE DESIRED...
  8009. C THEY RUN FROM B TO Z...IMPLYING ID1=28 THRU 53
  8010. CC    II=ICHAR(LINE(5))-66+28
  8011. C    II=ICHAR(LINE(5))-38
  8012. C SCREEN OUT EXTRA JUNK THAT WOULD COME FROM HIGH FUNCT CODES...
  8013. C (DON'T BOTHER MAPPING A<Z+1> TO BA AND SO ON... ONLY 6
  8014. C KEYS IN USABLE RANGE ANYHOW...
  8015. C    IF(II.GT.52)GOTO 1200
  8016. C    III=1
  8017. C    CALL FVLDGT(II,III,IBBX)
  8018. C    IF(IBBX.EQ.0)GOTO 1200
  8019. C SKIP OVER CELLS THAT ARE EMPTY.
  8020. C
  8021. C NULL OUT REMAINDER OF THE LINE TO AVOID CONFUSION HERE.
  8022. C NOTE WE ONLY DO THIS WHERE WE SAW AN INITIAL NULL INDICATING AN
  8023. C EXTENDED FUNCTION INPUT.
  8024. C    IBBX=6
  8025. C    GOTO 1201
  8026. C1200    IBBX=1
  8027. C1201    CONTINUE
  8028. C    DO 1100 N=IBBX,132
  8029. C1100    LINE(N)=CHAR(0)
  8030.     RETURN
  8031. 2000    CONTINUE
  8032. c    CLOSE(18)
  8033.     IOLVL=11
  8034. c    OPEN(18,FILE='CON:20/40/150/150/Analy Command Input')
  8035.     CLOSE(3)
  8036. CC RETRY A READ AFTER EOF...
  8037.     Call vget(line,80)
  8038. c    READ(11,1000,END=4000,ERR=4000)LINE
  8039. c    rewind 11
  8040.     RETURN
  8041. 4000    CONTINUE
  8042. CC IF WE KEEP GETTING ERRORS, JUST QUIT.
  8043. CC AT LEAST STAY AROUND. USER CAN DO @\DEV\CON
  8044. CC TO PARTLY RECOVER...
  8045. C    STOP
  8046. C TRY TO RESET TTY EOF
  8047. C *********
  8048.     RETURN
  8049.     END
  8050. c -h- gmadd.for    Fri Aug 22 13:16:31 1986    
  8051.     SUBROUTINE GMADD(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
  8052. C MODIFIED FOR PCCPC
  8053.     Include aparms.inc
  8054. C      SUBROUTINE GMADD(A,B,R,N,M)
  8055.        REAL*8 A,B,R
  8056.        DIMENSION A(1),B(1),R(1)
  8057. C      NM=N*M
  8058.     IAB=(IA2-1)*MCols+IA1-1
  8059.     IBB=(IB2-1)*MCols+IB1-1
  8060.     IRB=(IR2-1)*MCols+IR1-1
  8061.       DO 10 I=1,N
  8062.       DO 10 J=1,M
  8063.     IJ=(I-1)*MCols+J
  8064.     CALL XVBLGT(IJ+IAB,0,A)
  8065.     CALL XVBLGT(IJ+IBB,0,B)
  8066.     R(1)=A(1)+B(1)
  8067.     CALL XVBLST(IJ+IRB,0,R)
  8068. 10    CONTINUE
  8069. C   10 R(IJ)=A(IJ)+B(IJ)
  8070.       RETURN
  8071.       END
  8072. c -h- gmprd.for    Fri Aug 22 13:16:31 1986    
  8073.     SUBROUTINE GMPRD(IA1,IA2,IB1,IB2,IR1,IR2,N,M,L)
  8074.     Include aparms.inc
  8075. C      SUBROUTINE GMPRD(A,B,R,N,M,L)
  8076.     REAL*8 A,B,R
  8077.         DIMENSION A(1),B(1),R(1)
  8078. C SPECIAL MATRIX MULTIPLY WITHIN SPREADSHEET MATRIX
  8079.     IAB=(IA2-1)*MCols+IA1-1
  8080.     IBB=(IB2-1)*MCols+IB1-1
  8081.     IRB=(IR2-1)*MCols+IR1-1
  8082.     DO 10 K=1,L
  8083.     DO 10 J=1,M
  8084.     NL=(J-1)*MCols+K
  8085.     R(1)=0.
  8086.     CALL XVBLST(IRB+NL,0,R)
  8087.     DO 10 I=1,N
  8088.     NM=(J-1)*MCols+I
  8089.     ML=(I-1)*MCols+K
  8090.     CALL XVBLGT(IAB+NM,0,A)
  8091.     CALL XVBLGT(IBB+ML,0,B)
  8092.     A(1)=A(1)*B(1)
  8093.     CALL XVBLGT(IRB+NL,0,R)
  8094.     R(1)=R(1)+A(1)
  8095. 10    CALL XVBLST(IRB+NL,0,R)
  8096. C    R(NL)=R(NL)+A(NM)*B(ML)
  8097. C10    CONTINUE
  8098.       RETURN
  8099.       END
  8100. c -h- gmsub.for    Fri Aug 22 13:16:31 1986    
  8101.     SUBROUTINE GMSUB(IA1,IA2,IB1,IB2,IR1,IR2,N,M)
  8102. C      SUBROUTINE GMSUB(A,B,R,N,M)
  8103.     Include aparms.inc
  8104.     REAL*8 A,B,R
  8105.     IAB=(IA2-1)*MCols+IA1-1
  8106.     IBB=(IB2-1)*MCols+IB1-1
  8107.     IRB=(IR2-1)*MCols+IR1-1
  8108. C      NM=N*M
  8109.       DO 10 I=1,N
  8110.       DO 10 J=1,M
  8111.       IJ=(I-1)*MCols+J
  8112.     CALL XVBLGT(IAB+IJ,0,A)
  8113.     CALL XVBLGT(IBB+IJ,0,B)
  8114.     A=A-B
  8115.     CALL XVBLST(IRB+IJ,0,A)
  8116. 10    CONTINUE
  8117. C   10 R(IJ)=A(IJ)-B(IJ)
  8118.       RETURN
  8119.       END
  8120. c -h- gmtx.for    Fri Aug 22 13:16:31 1986    
  8121.     SUBROUTINE GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
  8122.      1  ID2B,RETCD)
  8123.     CHARACTER*1 LINE(80)
  8124.     integer retcd
  8125. C REQ END MTX NAME IN 20 CHARS.
  8126. C SHOULD BE OK
  8127.     LEND=IBGN+20
  8128. C GET LOC OF MATRIX A (MUST BE SQUARE)
  8129.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  8130.     IF(IVALID.EQ.0)GOTO 300
  8131.     IF(LINE(LSTCHR).NE.':')GOTO 300
  8132.     IBGN=LSTCHR+1
  8133.     LEND=IBGN+20
  8134.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  8135.     IF(IVALID.EQ.0)GOTO 300
  8136. 1000    RETURN
  8137. 300    RETCD=3
  8138.     RETURN
  8139.     END
  8140. c -h- gn.for    Fri Aug 22 13:16:49 1986    
  8141.     SUBROUTINE GN(LAST,LEND,NUM,LINE)
  8142.     IMPLICIT InTeGer*4(A-Z)
  8143. C    PARAMETER 1=1,14=14
  8144.     DIMENSION LINE(110)
  8145.     CHARACTER*1 LINE
  8146.     EXTERNAL INDX
  8147.     CHARACTER*1 NCH
  8148.     InTeGer*4 CH,SFG
  8149.     NUM=0
  8150.     JSSF=0
  8151.     ISSF=0
  8152.     CH=0
  8153.     SFG=1
  8154.     NCH=char(0)
  8155.     DO 1 N=LAST,LEND
  8156.     M=N
  8157.     NCH=LINE(N)
  8158.     CH=ICHAR(NCH)
  8159.     IF(CH.EQ.0)GOTO 2
  8160.     IF(CH.EQ.45)SFG=-1
  8161. C SFG=SIGN FLAG
  8162. C 43 IS ASCII FOR +; 45 IS ASCII FOR - SIGN.
  8163. C IGNORE + SIGNS
  8164.     IF(CH.GT.32)ISSF=ISSF+1
  8165.     IF(ISSF.EQ.0.AND.CH.EQ.32)GOTO 1
  8166. C IGNORE SPACES TOO, PROVIDED THEY ARE LEADING SPACES.
  8167. C (OTHERS MAY BE DELIMITERS.)
  8168.     IF(CH.EQ.43.OR.CH.EQ.45)JSSF=JSSF+1
  8169.     IF(JSSF.GT.1.AND.(CH.EQ.43.OR.CH.EQ.45))GOTO 2
  8170. C IF WE HAVEN'T SEEN A +/- PROCESS IT HERE.
  8171.     IF(CH.EQ.43)GOTO 1
  8172.     IF(CH.EQ.45)GOTO 1
  8173.     IF(CH.LT.48.OR.CH.GT.57)GOTO 2
  8174. C TERMINATE ON ANY NON NUMERIC. SHOULD ALLOW TERMINATE ON SECOND #.
  8175.     IF(NUM.LT.3100)NUM=10*NUM+(CH-48)
  8176. 1    CONTINUE
  8177. C NEXT LINE WAS MAX0...
  8178. 2    LAST=MIN0(M,LEND)
  8179.     NUM=NUM*SFG
  8180. C ACCOUNTED FOR SIGN; NOW RETURN
  8181.     RETURN
  8182.     END
  8183. c -h- gtmung.for    Fri Aug 22 13:17:12 1986    
  8184.     SUBROUTINE GTMUNG(LINE)
  8185.     Include aparms.inc
  8186.     CHARACTER*1 LINE(132)
  8187.     InTeGer*4 IMODE
  8188.     CHARACTER*1 C2
  8189.     InTeGer*4 ICREF,IRREF
  8190. C    COMMON/MIRROR/ICREF,IRREF
  8191.     InTeGer*4 MODPUB,LIMODE
  8192. C    COMMON/MODPUB/MODPUB,LIMODE
  8193.     InTeGer*4 KLKC,KLKR
  8194.     REAL*8 AACP,AACQ
  8195. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  8196.     InTeGer*4 NCEL,NXINI
  8197. C    COMMON/NCEL/NCEL,NXINI
  8198.     CHARACTER*1 NAMARY(20,MRows)
  8199. C    COMMON/NMNMNM/NAMARY
  8200.     InTeGer*4 NULAST,LFVD
  8201. C    COMMON/NULXXX/NULAST,LFVD
  8202.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  8203.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  8204. CCC    COMMON/MODPUB/MODPUB,LIMODE
  8205.     save imode
  8206.     DATA IMODE/0/
  8207. C HANDLE EXTRA MODE PARSING...DEFAULT,TO AVOID ENTER CMD IF NOT NEEDED.
  8208.     I=ICHAR(LINE(1))
  8209.     IF(I.LT.34.OR.I.GT.122)GOTO 6000
  8210.     IF(I.EQ.42)GOTO 6000
  8211. C ASSUME OTHER REASONABLE CHARS ARE CMDS
  8212.     IF(I.GT.34.AND.I.LT.40)GOTO 6000
  8213.     IF(I.EQ.95)GOTO 6000
  8214.     IF(I.GE.58.AND.I.LE.64)GOTO 6000
  8215.     IF(LINE(1).NE.'/')GOTO 100
  8216.     IF(LINE(2).NE.'/')GOTO 110
  8217. C SETUP OLD MODE WITH //
  8218.     IMODE=0
  8219.     GOTO 900
  8220. 110    CONTINUE
  8221.     IF(LINE(2).NE.';')GOTO 120
  8222. C SETUP NEW MODE WITH /;
  8223.     IMODE=1
  8224.     GOTO 900
  8225. 120    CONTINUE
  8226.     IF(LINE(2).NE.'#')GOTO 124
  8227. C SWAP OLD, CURRENT MODES
  8228. C USE IN CMD FILES SO /# SWAPS MODES, THEN // SETS OLD MODE,
  8229. C THEN /# SWAPS BACK
  8230. C (THAT WAY, USER'S MODE DOESN'T CHANGE.)
  8231.     I=LIMODE
  8232.     LIMODE=IMODE
  8233.     IMODE=I
  8234.     GOTO 900
  8235. 124    CONTINUE
  8236.     IF(IMODE.EQ.0)GOTO 6000
  8237. C IF WE JUST SAW /COMMAND, MUNGE OUT THE INITIAL /
  8238.     DO 130 I=1,131
  8239. 130    LINE(I)=LINE(I+1)
  8240.     GOTO 6000
  8241. 100    CONTINUE
  8242.     IF(IMODE.EQ.0)GOTO 6000
  8243. C INPUT DIDN'T START WITH / SO TRY AND MAKE UP AN ENTER
  8244.     IF(LINE(2).EQ.'&')GOTO 6000
  8245. C 1& 2& ETC WORK STILL AS CURSOR CONTROLS
  8246.     C2='N'
  8247.     IF(LINE(1).EQ.'"')C2='"'
  8248. C    IF(LINE(1).GE.'0'.AND.LINE(1).LE.'9')C2='V'
  8249.     IF(LINE(1).LT.'0'.OR.LINE(1).GT.'9')GOTO 170
  8250. C INITIAL CHAR IS A DIGIT. IF 2ND CHAR IS ALSO A DIGIT OR
  8251. C SOMETHING REASONABLE THEN TREAT AS "EV" CMD. OTHERWISE
  8252. C JUST PASS AS A COMMAND SO CURSOR CTLS WORK STILL.
  8253.     IF(LINE(2).LE.' ')GOTO 6000
  8254. C ALLOW DIGIT FOLLOWED BY SPACE OR C.R. TO BE JUST CURSOR MOVE
  8255.     C2='V'
  8256. 170    CONTINUE
  8257. C MOVE DOWN PAST 'EV'
  8258.     II=3
  8259. C ALLOW US TO REMOVE INITIAL " IN E" CASE...
  8260.     IF(C2.EQ.'"')II=2
  8261.     DO 150 I=1,129
  8262.     M=133-I
  8263.     MM=M-II
  8264. 150    LINE(M)=LINE(MM)
  8265.     LINE(1)='E'
  8266.     LINE(2)=C2
  8267.     LINE(3)=' '
  8268.     GOTO 6000
  8269. 900    LINE(1)='*'
  8270. C MAKE COMMENT, THEN GO
  8271. 6000    CONTINUE
  8272. C MAINTAIN MODE FOR REST OF WORLD
  8273.     MODPUB=IMODE
  8274.     RETURN
  8275.     END
  8276. c -h- gtprd.for    Fri Aug 22 13:17:12 1986    
  8277.     SUBROUTINE GTPRD(IA1,IA2,IB1,IB2,IR1,IR2,N,M,L)
  8278.     Include aparms.inc
  8279.     REAL*8 A,B,R
  8280.       DIMENSION A(1),B(1),R(1)
  8281. C SPECIAL MATRIX MULTIPLY WITHIN SPREADSHEET MATRIX
  8282.     IAB=(IA2-1)*MCols+IA1-1
  8283.     IBB=(IB2-1)*MCols+IB1-1
  8284.     IRB=(IR2-1)*MCols+IR1-1
  8285.     DO 10 K=1,L
  8286.     DO 10 J=1,M
  8287.     NL=(J-1)*MCols+K
  8288.     R(1)=0.
  8289.     CALL XVBLST(NL+IRB,0,R)
  8290.     DO 10 I=1,N
  8291. C INVERT ROW/COLUMN USE FOR MATRIX A
  8292.     NM=(I-1)*MCols+J
  8293.     ML=(I-1)*MCols+K
  8294.     CALL XVBLGT(IAB+NM,0,A)
  8295.     CALL XVBLGT(IBB+ML,0,B)
  8296.     A(1)=A(1)*B(1)
  8297.     CALL XVBLGT(IRB+NL,0,R)
  8298.     R(1)=R(1)+A(1)
  8299.     CALL XVBLST(IRB+NL,0,R)
  8300. C    R(NL)=R(NL)+A(NM)*B(ML)
  8301. 10    CONTINUE
  8302.       RETURN
  8303.       END
  8304. c -h- index.fdd    Fri Aug 22 13:20:45 1986    
  8305.       INTEGER FUNCTION INDX ( STR, C )
  8306. C
  8307.     INTEGER*4 C
  8308.       CHARACTER * 1 STR ( 1 )
  8309. C
  8310. C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
  8311. C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
  8312. C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
  8313.     I3B=0
  8314.       DO 20019  I = 1, 256
  8315.       IF (ICHAR(STR(I)).NE.0) GOTO 20021
  8316. C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR 0
  8317.       INDX=0
  8318.       RETURN
  8319. 20021 CONTINUE
  8320.     IF(ICHAR(STR(I)).EQ.255)I3B=3
  8321.     IF(I3B.LE.0)GOTO 2000
  8322. C SKIP ENCODED VARIABLES
  8323.     I3B=I3B-1
  8324.     GOTO 20019
  8325. 2000    CONTINUE
  8326.       IF (.NOT.( STR ( I ) .EQ. CHAR(C) )) GOTO 20023
  8327.     ix=i
  8328.     if(i.gt.250)ix=0
  8329.       INDX = ( IX )
  8330.       RETURN
  8331. 20023 CONTINUE
  8332. 20022 CONTINUE
  8333. C
  8334. 20019 CONTINUE
  8335. 20020 CONTINUE
  8336.     INDX=255
  8337.     RETURN
  8338.       END
  8339. c -h- in2as.for    Fri Aug 22 13:21:02 1986    
  8340.     SUBROUTINE IN2AS(ROW,CHRS)
  8341.     InTeGer*4 ROW
  8342.     CHARACTER*1 CHRS(4)
  8343.     INTEGER*4 AC,AC1,AC2
  8344.     DO 1 N1=1,4
  8345. 1    CHRS(N1)=CHAR(32)
  8346. C CONVERT ROW TO LETTERS. ASSUMES COL=2 OR MORE. ROW 1=A-Z
  8347. C ROW 2=AA-AZ, THEN BA-BZ ETC.
  8348.     AC=ROW
  8349.     DO 2 N=1,4
  8350.     M=5-N
  8351. C CONVERT BACKWARDS INTO CHRS
  8352.     AC1=(AC/26)
  8353.     AC2=AC1*26
  8354.     IX=AC-AC2
  8355.     IF(.NOT.(IX.EQ.0.AND.AC1.GT.0))GOTO 772
  8356. C CORRECT SO WE GET Z, NOT A<NULL> FOR LABELS.
  8357.     IX=26
  8358.     AC1=AC1-1
  8359. 772    CONTINUE
  8360.     IF(IX.GT.0)CHRS(M)=CHAR(IX+64)
  8361. C CONVERT TO ASCII A-Z CHARACTER
  8362.     AC=AC1
  8363. 2    CONTINUE
  8364. C JUST IGNORE ANY OVERFLOW.
  8365.     RETURN
  8366.     END
  8367. c -h- indxq.for    Fri Aug 22 13:21:14 1986    
  8368.       INTEGER FUNCTION INDXQ ( STR, C )
  8369. C
  8370.     INTEGER*4 C
  8371.       CHARACTER * 1 STR ( 1 )
  8372. C
  8373. C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
  8374. C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
  8375. C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
  8376.     I3B=0
  8377.       DO 20019  I = 1, 256
  8378.       IF (ICHAR(STR(I)).NE.0) GOTO 20021
  8379. C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR OF THE
  8380. C END OF THE STRING FOR ANALYTICALC. NOTE THAT THIS DIFFERS
  8381. C FROM USUAL RATFOR VERSION.
  8382.       INDXQ=I
  8383.       RETURN
  8384. 20021 CONTINUE
  8385.     IF(ICHAR(STR(I)).EQ.255)I3B=3
  8386.     IF(I3B.LE.0)GOTO 2000
  8387. C SKIP ENCODED VARIABLES
  8388.     I3B=I3B-1
  8389.     GOTO 20019
  8390. 2000    CONTINUE
  8391.       IF (.NOT.( STR ( I ) .EQ. CHAR(C) )) GOTO 20023
  8392.       INDXQ = ( I )
  8393.       RETURN
  8394. 20023 CONTINUE
  8395. 20022 CONTINUE
  8396. C
  8397. 20019 CONTINUE
  8398. 20020 CONTINUE
  8399.     INDXQ=0
  8400.     RETURN
  8401.       END
  8402. c -h- inpost.for    Fri Aug 22 13:21:23 1986    
  8403.     SUBROUTINE INPOST (RETCD)
  8404. C COPYRIGHT (C) 1983 GLENN EVERHART
  8405. C ALL RIGHTS RESERVED
  8406.     Include aparms.inc
  8407. C 60=MAX REAL ROWS
  8408. C 301=MAX REAL COLS
  8409. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  8410. C VBLS AND TYPE DIMENSIONED 60,301
  8411. C **************************************************
  8412. C *                                                *
  8413. C *            SUBROUTINE  INPOST                  *
  8414. C *                                                *
  8415. C **************************************************
  8416. C
  8417. C
  8418. C  CONVERTS THE INPUT STRING (INFIX NOTATION) TO POSTFIX
  8419. C  FOR LATER EVALUATION BY POSTVL
  8420. C
  8421. C
  8422. C
  8423. C  MODIFICATION CODES:  M3,M10
  8424. C
  8425. C
  8426. C MODIFIED 10-MAR-78 P.B. CHANGED STACK VALUE FOR FUNCTIONS FROM 15 TO 45
  8427. C   THIS CORRECTS IMPROPER EVALUATION OF SQRT(1.)-2.
  8428. C
  8429. C
  8430. C
  8431. C
  8432. C INPOST CALLS
  8433. C
  8434. C  ERRMSG   PRINTS ERROR MESSAGES
  8435. C  NEXTEL   GETS THE NEXT ELEMENT FROM LINE(80)
  8436. C
  8437. C
  8438. C
  8439. C INPOST IS CALLED BY CALC
  8440. C
  8441. C
  8442. C
  8443. C
  8444. C
  8445. C
  8446. C        THE VARIABLE AND FUNCTION CODES.
  8447. C TABLE ALSO GIVES COMPARE VALUES AND STACK VALUES OF
  8448. C FUNCTIONS THAT OCCUR WHEN EXPRESSIONS ARE EVALUATED.
  8449. C
  8450. C
  8451. C
  8452. C
  8453. C    STACK
  8454. C    ELEMENT                COMPARE    STACK
  8455. C    CODE    TYPE        BYTES    VALUE    VALUE
  8456. C
  8457. C    0    UNDEFINED    -    -    -
  8458. C    1    ASCII        1    -    -
  8459. C    2    DECIMAL        8    -    -
  8460. C    3    HEXADECIMAL    4    -    -
  8461. C    4    INTEGER        4    -    -
  8462. C    5    MULT.PREC.(10)    20    -    -
  8463. C    6    MULT.PREC.(8)    20    -    -
  8464. C    7    MULT.PREC.(16)    20    -    -
  8465. C    8    OCTAL        4    -
  8466. C    9    REAL        8    -    -
  8467. C    10-30    UNDEFINED    -    -    -
  8468. C
  8469. C    ----------FUNCTIONS------------
  8470. C
  8471. C    31    ABS (=DABS)    -    70    45
  8472. C    32    IABS        -    70    45
  8473. C    33    FLOAT        -    70    45
  8474. C    34    IFIX        -    70    45
  8475. C    35    AINT        -    70    45
  8476. C    36    INT (=IDINT)    -    70    45
  8477. C    37    EXP (=DEXP)    -    70    45
  8478. C    38    ALOG (=DLOG)    -    70    45
  8479. C    39    ALOG10(=DLOG10)    -    70    45
  8480. C    40    SQRT (=DSQRT)    -    70    45
  8481. C    41    SIN (=DSIN)    -    70    45
  8482. C    42    COS (=DCOS)    -    70    45
  8483. C    43    TANH (=DTANH)    -    70    45
  8484. C    44    ATAN (=DATAN)    -    70    45
  8485. C    45-47    ASIN,ACOS,TAN    -    70    45
  8486. C    45    RESERVED    -    -    -
  8487. C       48-100  RESERVED        -       -       -
  8488. C
  8489. C       110     (               -       70      15
  8490. C       111     UNARY -         -       50      49
  8491. C       112     **              -       40      39
  8492. C       113     *               -       30      31
  8493. C       114     /               -       30      31
  8494. C       115     +               -       20      21
  8495. C       116     -               -       20      21
  8496. C       117     )               -       10      -
  8497. C
  8498. C       200     =               -       10      10
  8499. C
  8500. C
  8501. C
  8502. C    VARIABLE      USE
  8503. C
  8504. C    I,K          HOLDS TEMPORARY InTeGer*4 VALUES.
  8505. C    LASTOP       HOLDS THE TYPE OF LAST ELEMENT OBTAINED
  8506. C                 ON LINE(80). SET AT 0 AT BEGINNING OF EXPRESSION.
  8507. C                 USED BY NEXTEL TO IDENTIFY UNARY OPERATORS.
  8508. C    NONBLK       POINTER IN LINE(80). NEXTEL STARTS SCAN AT NONBLK+1.
  8509. C    OPVAL(200,2)   HOLDS THE COMPARE AND STACK VALUE OF EACH OPERATOR.
  8510. C    PARVAL       HOLDS 110 WHICH IS THE CODE FOR '(' IN STACK 2.
  8511. C    RETCD        RETURN CODE. 1=O.K.  2=ERROR.
  8512. C    RETCD2       RETURN CODE FOR CALL TO NEXTEL.
  8513. C    RETTYP       HOLDS TYPE OF NEXT ELEMENT IN LINE, EITHER A FUNCTION
  8514. C                 CODE OR A DATA TYPE CODE.
  8515. C    RETVAL(100)  HOLDS VALUE OF NEXT ELEMENT IN LINE(80).
  8516. C    ST1LIM       HOLDS LIMIT OF STACK 1.
  8517. C    ST2LIM       HOLDS LIMIT OF STACK 2.
  8518. C    ST1PT        STACK 1 POINTER.
  8519. C    ST2PT        STACK 2 POINTER.
  8520. C    ST1TYP       TYPE OF EACH ELEMENT IN STACK 1
  8521. C    ST2TYP       TYPE OF EACH ELEMENT IN STACK 2
  8522. C    VLEN         HOLDS THE NUMBER OF BYTES USED BY EACH DATA TYPE.
  8523. C
  8524. C
  8525. C
  8526. C
  8527. C    SUBROUTINE INPOST (RETCD)
  8528. C
  8529. C
  8530. C
  8531.     InTeGer*4 LEVEL,NONBLK,LEND
  8532.     InTeGer*4 LASTOP
  8533.     InTeGer*4 VIEWSW,BASED
  8534.     InTeGer*4 OPVAL(200,2),PARVAL
  8535.     InTeGer*4 RETCD,RETCD2,RETTYP
  8536.     InTeGer*4 TYPE(1,2)
  8537.     InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT
  8538.     InTeGer*4 ST1LIM,ST2LIM
  8539.     InTeGer*4 VLEN(9)
  8540.     InTeGer*4 I,K
  8541. C
  8542.     CHARACTER*1 LINE(80)
  8543.     CHARACTER*1 AVBLS(24,27),RETVAL(20)
  8544.     Real*8 VAVBLS(3,27)
  8545.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  8546.     CHARACTER*1 VBLS(8,1,1)
  8547.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  8548. C
  8549. C
  8550.     COMMON /STACKx/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  8551.      1  ST1LIM,ST2LIM
  8552.     COMMON /V/TYPE,AVBLS,VBLS,VLEN
  8553.     InTeGer*4 DLFG
  8554. C    COMMON/DLFG/DLFG
  8555.     InTeGer*4 KDRW,KDCL
  8556. C    COMMON/DOT/KDRW,KDCL
  8557.     InTeGer*4 DTRENA
  8558. C    COMMON/DTRCMN/DTRENA
  8559.     REAL*8 EP,PV,FV
  8560.     DIMENSION EP(20)
  8561.     INTEGER*4 KIRR
  8562. C    COMMON/ERNPER/EP,PV,FV,KIRR
  8563. c    InTeGer*4 LASTOP
  8564. C    COMMON/ERROR/LASTOP
  8565.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  8566. C    COMMON/FMTBFR/FMTDAT
  8567.     CHARACTER*1 EDNAM(16)
  8568. C    COMMON/EDNAM/EDNAM
  8569.     InTeGer*4 MFID(2),MFMOD(2)
  8570. C    COMMON/FRM/MFID,MFMOD
  8571.     InTeGer*4 JMVFG,JMVOLD
  8572. C    COMMON/FUBAR/JMVFG,JMVOLD
  8573.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  8574.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  8575. CCC    COMMON /ERROR/ LASTOP
  8576.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  8577. C
  8578.     save opval,parval
  8579. C
  8580.     DATA OPVAL/30*-1,17*70,62*-1,70,50,40,30,30,20,20,10,82*-1,10,
  8581.      1             30*-1,17*45,62*-1,15,49,39,31,31,21,21,-1,82*-1,10/
  8582.     DATA PARVAL/110/
  8583. C
  8584. C
  8585. C
  8586. C
  8587. C
  8588. C  INITIALIZE STACKS, RETURN CODE DEFAULT, AND LASTOP
  8589.     RETCD=1
  8590.     ST1PT=1
  8591.     ST2PT=1
  8592.     LASTOP=0
  8593. C
  8594. C SET UP FOR NEXTEL CALL
  8595.     NONBLK=NONBLK-1
  8596. C
  8597. C
  8598. C
  8599. C
  8600. C **************************************************
  8601. C ***** GET NEXT ELEMENT OF EXPRESSION *************
  8602. C **************************************************
  8603. C
  8604. C
  8605. C
  8606. C  NEXTEL RETURNS
  8607. C    1    IF OPERAND
  8608. C    2    IF OPERATOR (VALUE IN RETTYP)
  8609. C    3    IF NO MORE ELEMENTS
  8610. C    4    IF ERROR
  8611. C
  8612. C
  8613. 50    CALL NEXTEL (RETVAL,RETTYP,RETCD2)
  8614.     GOTO (100,200,300,999),RETCD2
  8615.     STOP 50
  8616. C
  8617. C
  8618. C
  8619. C
  8620. C
  8621. C **************************************************
  8622. C ********  OPERAND FOUND, PUT ON STACK 1  *********
  8623. C **************************************************
  8624. C
  8625. C STACK 1 OVERFLOW CHECK
  8626. 100    IF (ST1PT.GT.ST1LIM) GOTO 990
  8627. C
  8628. C
  8629. C
  8630. C
  8631. C
  8632. 109    CONTINUE
  8633. C
  8634. C  SUBROUTINE ERRCX HAS ALREADY ASSURED THAT
  8635. C  IF AN OPERAND IS FOLLOWED BY AN = SIGN, THAT VARIABLE
  8636. C  IS NOT PART OF AN EXPRESSION.
  8637. C
  8638. C  VARIABLE INDEX IS TO BE PLACED IN STACK1 (1,ST1PT)
  8639. C  SO IF YOU WANTED TO SPEED THE OPERATION AT THE EXPENSE
  8640. C  OF SPACE, YOU WOULD ONLY COPY RETVAL(1) IF RETTYP < 0
  8641.     K=VLEN(IABS(RETTYP))
  8642.     DO 110 I=1,K
  8643. 110    STACK1(I,ST1PT)=RETVAL(I)
  8644.     ST1TYP(ST1PT)=RETTYP
  8645.     ST1PT=ST1PT+1
  8646.     GOTO 50
  8647. C
  8648. C
  8649. C
  8650. C
  8651. C
  8652. C
  8653. C
  8654. C
  8655. C **************************************************
  8656. C *****************  OPERATOR  *********************
  8657. C **************************************************
  8658. C
  8659. 200    CONTINUE
  8660. C
  8661. C IF NO OTHER OPERATOR ON STACK 2, PLACE ON STACK 2
  8662.     IF (ST2PT.EQ.1) GOTO 222
  8663. C
  8664. C
  8665. C COMPARE VALUE WITH OPERATOR IN STACK2, IF GREATER OR EQUAL THEN
  8666. C PLACE IN STACK 2 BECAUSE IT HAS HIGHER PRECEDENCE AND IS ASSOCIATED
  8667. C WITH PREVIOUSLY ENCOUNTERED OPERAND, IS A UNARY OPERATOR ASSOCIATED
  8668. C WITH THE FOLLOWING ELEMENT, OR IS A '(' WHICH IS SAVED UNTIL A ')'
  8669. C IS FOUND.
  8670. C
  8671.     K=ST2TYP(ST2PT-1)
  8672.     IF (OPVAL(RETTYP,1).GE.OPVAL(K,2)) GOTO 220
  8673. C
  8674. C
  8675. C IF POPPING OFF ELEMENTS FROM STACK2 BECAUSE ')' WAS FOUND THEN WHEN
  8676. C ')' IS FOUND WE GO TO 230 TO REMOVE THE OPERATOR '(' FROM STACK 2.
  8677. C
  8678.     IF (PARVAL.EQ.K) GOTO 230
  8679.     IF (ST1PT.GT.ST1LIM) GOTO 990
  8680. C
  8681. C
  8682. C
  8683. C OPERATOR ON STACK 2 GOES ONTO STACK 1.
  8684. C
  8685.     ST1TYP(ST1PT)=K
  8686.     ST1PT=ST1PT+1
  8687.     ST2PT=ST2PT-1
  8688.     GOTO 200
  8689. C
  8690. C
  8691. C  PUT OPERATOR ON STACK 2
  8692. 220    IF (ST2PT.GT.ST2LIM) GOTO 992
  8693. 222    ST2TYP(ST2PT)=RETTYP
  8694.     ST2PT=ST2PT+1
  8695.     GOTO 50
  8696. C
  8697. C
  8698. C REMOVE '(' FROM STACK 2
  8699. 230    ST2PT=ST2PT-1
  8700.     GOTO 50
  8701. C
  8702. C
  8703. C
  8704. C
  8705. C
  8706. C **************************************************
  8707. C ******* NO MORE ELEMENTS IN LINE *****************
  8708. C **************************************************
  8709. C
  8710. C CLEAN OFF STACK 2
  8711. 300    IF (ST2PT.EQ.1) GOTO 1000
  8712. C
  8713. C IF A '(' GO TO 350 TO THROW IT AWAY.
  8714.     IF (ST2TYP(ST2PT-1).EQ.PARVAL) GOTO 350
  8715.     IF (ST1PT.GT.ST1LIM) GOTO 990
  8716. C
  8717. C
  8718. C
  8719. C PLACE ELEMENT ON STACK 2 ONTO STACK 1.
  8720. C
  8721.     ST1TYP(ST1PT)=ST2TYP(ST2PT-1)
  8722.     ST1PT=ST1PT+1
  8723. C
  8724. C THROW AWAY '(' FROM STACK 2.
  8725. 350    ST2PT=ST2PT-1
  8726.     GOTO 300
  8727. C
  8728. C
  8729. C
  8730. C
  8731. C *** ERROR HANDLING ***
  8732. C
  8733. C STACK 1 OVERFLOW
  8734. 990    I=7
  8735.     GO TO 998
  8736. C
  8737. C STACK 2 OVERFLOW
  8738. 992    I=9
  8739. C
  8740. C
  8741. 998    CALL ERRMSG(I)
  8742. 999    RETCD=2
  8743. 1000    RETURN
  8744. C
  8745.     END
  8746. c -h- isgn.for    Fri Aug 22 13:21:52 1986    
  8747.       INTEGER FUNCTION ISGN(IARG)
  8748.       InTeGer*4 IARG
  8749.       IF(IARG.EQ.0)ISGN=0
  8750.       IF(IARG.GT.0)ISGN=1
  8751.       IF(IARG.LT.0)ISGN=-1
  8752.       RETURN
  8753.       END
  8754. c -h- jchar.for    Fri Aug 22 13:22:15 1986    
  8755.     INTEGER FUNCTION JCHAR(CHR)
  8756.     CHARACTER*1 CHR
  8757. c    INTEGER*1 ICH
  8758. C RETURN INTEGER VALUE OF CHARACTER AS IF IT WERE A SIGNED
  8759. C INTEGER BETWEEN -128 AND +127
  8760.     INTEGER*4 I
  8761. c    EQUIVALENCE(CHR,ICH)
  8762.     I=ICHAR(CHR)
  8763. c    I=ICH
  8764.     IF(I.GT.127)I=I-256
  8765.     JCHAR=I
  8766.     RETURN
  8767.     END
  8768. c -h- jmod.for    Fri Aug 22 13:22:15 1986    
  8769. C INTEGER*4 MODULO FUNCTION
  8770.     INTEGER*4 FUNCTION JMOD(I1,I2)
  8771.     INTEGER*4 I1,I2,I
  8772.     I=MOD(I1,I2)
  8773.     JMOD=I
  8774.     RETURN
  8775.     END
  8776. c -h- julasc.for    Fri Aug 22 13:22:15 1986    
  8777.     SUBROUTINE JULASC(N,DATSTc,IYR,IMO,IDA)
  8778. C CONVERT JULIAN DATE N INTO ASCII STRING STR
  8779.     character*8 datstc,dst
  8780.     INTEGER*4 DATST(2),DAT(2)
  8781.     equivalence(dst,datst(1))
  8782.     CHARACTER*1 DATSTR(8)
  8783.     CHARACTER*2 YRST(1),MOST(1),DAST(1)
  8784.     EQUIVALENCE(YRST(1)(1:1),DATSTR(1)),
  8785.      1  (MOST(1)(1:1),DATSTR(4))
  8786.     EQUIVALENCE(DAT(1),DATSTR(1))
  8787.     EQUIVALENCE(DAST(1)(1:1),DATSTR(7))
  8788.     InTeGer*4 MLEN(12)
  8789.     save mlen
  8790.     DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/
  8791.     DATSTR(3)='/'
  8792.     DATSTR(6)='/'
  8793. C FIRST SUBTRACT OFF WHOLE YEARS
  8794.     IYR=N/365
  8795.     N=N-(365*IYR)
  8796. C ADJUST FOR LEAP YRS SINCE 1981
  8797.     IAC=IYR/4
  8798.     N=N-IAC
  8799. C Account for when this year is a leap year
  8800.     MLEN(2)=28
  8801.     IF(Mod((IYR+81),4).eq.0) MLEN(2)=29
  8802. c (OK for rest of 20th century, anyhow.)
  8803. C (Also OK in 21st, since 2000 IS a leap year (divisible by 400))
  8804. C NOW SUBTRACT OFF MONTHS AS LONG AS POSSIBLE
  8805.     DO 1 NN=1,12
  8806.     IMO=NN
  8807.     IF(N.LE.MLEN(NN))GOTO 2
  8808.     N=N-MLEN(NN)
  8809. 1    CONTINUE
  8810. 2    CONTINUE
  8811.     IDA=N
  8812.     IYR=IYR+81
  8813.     WRITE(YRST(1)(1:2),3,ERR=5)IYR
  8814. C    ENCODE(2,3,YRST,ERR=5)IYR
  8815. 3    FORMAT(I2)
  8816.     WRITE(MOST(1)(1:2),3,ERR=5)IMO
  8817. C    ENCODE(2,3,MOST,ERR=5)IMO
  8818.     WRITE(DAST(1)(1:2),3,ERR=5)IDA
  8819. C    ENCODE(2,3,DAST,ERR=5)IDA
  8820. 5    CONTINUE
  8821.     IF(DATSTR(1).EQ.' ')DATSTR(1)='0'
  8822.     IF(DATSTR(4).EQ.' ')DATSTR(4)='0'
  8823.     IF(DATSTR(7).EQ.' ')DATSTR(7)='0'
  8824.     DATST(1)=DAT(1)
  8825.     DATST(2)=DAT(2)
  8826. C USE INTEGERS SINCE REAL*8 MIGHT OMIT FULL COPY IF
  8827. C EXPONENT BYTE IS 0, AND CHARS MAY CAUSE NORMALIZATION
  8828. C PROBLEMS SOMETIMES.
  8829.     datstc=dst
  8830.     RETURN
  8831.     END
  8832. c -h- julian.for    Fri Aug 22 13:22:15 1986    
  8833. C JULIAN DATE ROUTINES
  8834. C CALLS:
  8835. C    N=JULIAN(YY/MM/DD)
  8836. C    RETURNS JULIAN DATE BASED ON 1/1/80 FOR THAT DATE
  8837. C
  8838. C    CALL JULASC(N,STRADR)
  8839. C    TAKES JULIAN DATE AND DECODES TO ASCII YY/MM/DD
  8840. C
  8841. C    N=JULMDY(IYR,IMO,IDA)
  8842. C    RETURNS JULIAN DATE GIVEN SEPARATE Y,M,D
  8843. C
  8844.     FUNCTION JULIAN(DATSTc)
  8845.     character*8 datstc,dst
  8846.     INTEGER*4 DATST(2),DAT(2)
  8847.     equivalence(dst,datst(1))
  8848.     CHARACTER*1 DATSTR(8)
  8849.     CHARACTER*1 YRST(2),MOST(2),DAST(2)
  8850.     CHARACTER*2 YRST2,MOST2,DAST2
  8851.     EQUIVALENCE(YRST2(1:1),YRST(1),DATSTR(1),DAT(1)),
  8852.      1  (MOST2(1:1),MOST(1),DATSTR(4)),
  8853.      2  (DAST2(1:1),DAST(1),DATSTR(7))
  8854. C    EQUIVALENCE(DATSTR(1),DAT(1))
  8855. C    EQUIVALENCE(YRST(1),DATSTR(1)),(MOST(1),DATSTR(4))
  8856. C    EQUIVALENCE(DAST(1),DATSTR(7))
  8857.     dst=datstc
  8858.     DAT(1)=DATST(1)
  8859.     DAT(2)=DATST(2)
  8860.     IJUL=1
  8861.     READ(YRST2(1:2),1,ERR=2)IYR
  8862. C    DECODE(2,1,YRST,ERR=2)IYR
  8863. 1    FORMAT(I2)
  8864.     READ(MOST2(1:2),1,ERR=2)IMO
  8865.     READ(DAST2(1:2),1,ERR=2)IDA
  8866. C    DECODE(2,1,MOST,ERR=2)IMO
  8867. C    DECODE(2,1,DAST,ERR=2)IDA
  8868.     IJUL=JULMDY(IYR,IMO,IDA)
  8869. 2    CONTINUE
  8870.     JULIAN=IJUL
  8871.  
  8872.     RETURN
  8873.     END
  8874. c -h- julmdy.for    Fri Aug 22 13:22:15 1986    
  8875.     FUNCTION JULMDY(IYR,IMO,IDA)
  8876.     InTeGer*4 MLEN(12)
  8877.     save mlen
  8878.     DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/
  8879. C JULIAN DATE FROM Y,M,D
  8880. C BASE=1/1/81
  8881.     IJUL=1
  8882.     IF(IYR.LT.80)GOTO 999
  8883.     IYR=IYR-81
  8884.     IF(IMO.LE.0.OR.IMO.GT.12)GOTO 999
  8885.     IF(IDA.GT.31)GOTO 999
  8886. C JUST RETURN ILLEGAL ENTRIES AS 1/1/80
  8887.     AC=365.25*FLOAT(IYR)
  8888.     IAC=AC
  8889. C SLIGHTLY CRUDE BUT WORKABLE TREATMENT OF YEARS
  8890.     IJUL=IJUL+IAC
  8891. C NOW ADD IN MONTHS.
  8892.     IF(IMO.GT.2.AND.MOD(IYR+1,4).EQ.0)IJUL=IJUL+1
  8893. C ABOVE ACCOUNTS FOR LEAP YEARS
  8894.     III=IMO-1
  8895.     IF(III.LE.0)GOTO 22
  8896.     DO 2 N=1,III
  8897. 2    IJUL=IJUL+MLEN(N)
  8898. 22    CONTINUE
  8899. C NEXT DO DAYS
  8900.     IJUL=IJUL+IDA-1
  8901. C JUST ADD IN DAYS. SHOULD BE GOOD ENOUGH.
  8902. 999    CONTINUE
  8903.     JULMDY=IJUL
  8904.     RETURN
  8905.     END
  8906. c -h- jvblgt.for    Fri Aug 22 13:22:15 1986    
  8907.         SUBROUTINE JVBLGT(ID1,ID2,ID3,IVAL)
  8908. C
  8909. C JVBLGT - GET INTEGER*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY
  8910. C  DIMENSIONED (2,60,301). HANDLE BY CALLING XVBLGT TO GET
  8911. C  CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE
  8912.         InTeGer*4 ID1,ID2,ID3
  8913.         INTEGER*4 IVAL,LL(2)
  8914.         REAL*8 XX
  8915.         EQUIVALENCE(LL(1),XX)
  8916.         CALL XVBLGT(ID2,ID3,XX)
  8917.         IVAL=LL(ID1)
  8918.         RETURN
  8919.         END
  8920. c -h- jvblst.for    Fri Aug 22 13:22:15 1986    
  8921.         SUBROUTINE JVBLST(ID1,ID2,ID3,IVAL)
  8922. C JVBLST - SET I*4 WORD OF 3 DIM VBLS ARRAY, ORIGINALLY
  8923. C  DIMENSIONED (2,60,301). HANDLE BY CALLING XVBLST TO GET
  8924. C  CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE
  8925.         InTeGer*4 ID1,ID2,ID3
  8926.         INTEGER*4 IVAL,LL(2)
  8927.         REAL*8 XX
  8928.         EQUIVALENCE(LL(1),XX)
  8929. C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONES WE WANT. THEN...
  8930.         CALL XVBLGT(ID2,ID3,XX)
  8931.         LL(ID1)=IVAL
  8932. C PUT BACK THE 8 BYTES.
  8933.         CALL XVBLST(ID2,ID3,XX)
  8934.         RETURN
  8935.         END
  8936. c -h- mdet.for    Fri Aug 22 13:25:39 1986    
  8937.     SUBROUTINE MDET(XVBLS,I1,I2,J1,J2,DET)
  8938.     Include aparms.inc
  8939.     REAL*8 XVBLS(1),DET,SUMA,SUMB
  8940. C NOTE XVBLS IS 60 BY 301 MATRIX IN PORTACALC
  8941. C I1,I2 ARE TOP COL,ROW COORD; J1,J2 ARE BOTTOM
  8942. C STORAGE OF XVBLS IS (COL,ROW) SO LOCATIONS INSIDE
  8943. C IT ARE
  8944. C  ADDR=(ROW-1)*60+COL (60 IS # OF COLS)
  8945.     DET=0.
  8946.     N=J1-I1+1
  8947.     M=J2-I2+1
  8948.     IF(N.NE.M)RETURN
  8949.     IF(N.LE.1)RETURN
  8950. C ONLY SQUARE MATRICES MAY HAVE NONZERO DETERMINANTS
  8951. C ALSO, DIMENSION HAS TO BE > 1
  8952.     NN=N
  8953. C  FIXUP... (OK FOR N=2,3 ANYHOW)
  8954.     IF(N.EQ.2)NN=N-1
  8955. C  SUM OVER DIAGS...
  8956. C MULTIPLY DIAGONALS FROM TOP AND BOTTOM ROWS OF MATRIX AND GET
  8957. C DIFFERENCE EACH TIME FOR ACCURACY
  8958.     DO 1 N1=1,NN
  8959.     SUMA=1.
  8960.     SUMB=1.
  8961.     DO 2 N2=1,N
  8962.     NCL=N1+N2-1
  8963.     N2L=N+1-N2
  8964.     IF(NCL.GT.N)NCL=NCL-N
  8965. C NOW MULTIPLY SUMA (POSITIVE TERMS) BY X(NCL,N2) AND SUMB(NEG TERMS)
  8966. C BY X(NCL,N2L)
  8967.     LA=(N2-2+I2)*MCols+I1+NCL-1
  8968.     LB=(N2L-2+I2)*MCols+I1+NCL-1
  8969.     CALL XVBLGT(LA,0,XVBLS(1))
  8970.     SUMA=SUMA*XVBLS(1)
  8971.     CALL XVBLGT(LB,0,XVBLS(1))
  8972.     SUMB=SUMB*XVBLS(1)
  8973. 2    CONTINUE
  8974. C NOW ACCUMULATE TERMS IN DETERMINANT
  8975.     DET=DET+SUMA-SUMB
  8976. C DO IN THIS ORDER TO AVOID EXCESSIVE LOSS OF PRECISION DUE TO
  8977. C DIFFERENCES OF LARGE TERMS. THIS IS BAD ENOUGH AS IT IS...
  8978. 1    CONTINUE
  8979.     RETURN
  8980.     END
  8981. c -h- mthini.for    Fri Aug 22 13:25:45 1986    
  8982.     SUBROUTINE MTHINI(INDEXF,AC,SS,CTR,ACX)
  8983.     DIMENSION EP(20)
  8984.     Include aparms.inc
  8985.     InTeGer*4 DLFG
  8986. C    COMMON/DLFG/DLFG
  8987.     InTeGer*4 KDRW,KDCL
  8988. C    COMMON/DOT/KDRW,KDCL
  8989.     InTeGer*4 DTRENA
  8990. C    COMMON/DTRCMN/DTRENA
  8991.     REAL*8 EP,PV,FV
  8992.     INTEGER*4 KIRR
  8993. C    COMMON/ERNPER/EP,PV,FV,KIRR
  8994.     InTeGer*4 LASTOP
  8995. C    COMMON/ERROR/LASTOP
  8996.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  8997. C    COMMON/FMTBFR/FMTDAT
  8998.     CHARACTER*1 EDNAM(16)
  8999. C    COMMON/EDNAM/EDNAM
  9000.     InTeGer*4 MFID(2),MFMOD(2)
  9001. C    COMMON/FRM/MFID,MFMOD
  9002.     InTeGer*4 JMVFG,JMVOLD
  9003. C    COMMON/FUBAR/JMVFG,JMVOLD
  9004.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  9005.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  9006. CCC    REAL*8 EP,PV,FV
  9007. CCC    COMMON/ERNPER/EP,PV,FV,KIRR
  9008.     REAL*8 AC,SS,CTR,ACX
  9009.     KIRR=0
  9010.     SS=0.
  9011.     CTR=0.
  9012.     ACX=0.
  9013.     DO 1 N=1,20
  9014. 1    EP(N)=0.
  9015.     AC=0.
  9016.     IF(INDEXF.EQ.1)AC=1.E20
  9017.     IF(INDEXF.EQ.2)AC=-1.E20
  9018.     RETURN
  9019.     END
  9020. c -h- mtxequ.for    Fri Aug 22 13:25:54 1986    
  9021.        SUBROUTINE MTXEQU(A1,A2,B1,B2,N,M,D)
  9022.     Include aparms.inc
  9023.     real*8 save,d
  9024. C A1,A2 ARE DIMENSIONS OF A SUBMATRIX ORIGIN IN XVBLS
  9025. C B1,B2 ARE DIMS OF B SUBMATRIX
  9026. C
  9027. C NOTE THIS PROGRAM MUST BE MODIFIED TO WORK WITHIN THE SPREAD
  9028. C SHEET MATRIX RATHER THAN JUST ASSUMING THAT THE N DIMENSION
  9029. C AND M DIMENSION GIVE THE STORAGE ADDRESSES... ALTERNATIVELY,
  9030. C THE PROGRAM MUST OPERATE ONLY ON COPIED, DENSELY STORED
  9031. C MATRICES.
  9032. C
  9033. C
  9034. C   ORIGINAL PROGRAM TEXT FOLLOWS:
  9035. C       DIMENSION A(1),B(1)
  9036. CC ALTER DECLARATIONS FOR USE WITH SPREAD SHEET
  9037. C    REAL*8 A,B
  9038. C       KMAX=N-1
  9039. C       DO 90 K=1,KMAX
  9040. C       AMAX=0.
  9041. C       J2=K
  9042. C       DO 20 J1=K,N
  9043. C       IK=(J1-1)*N+K
  9044. C       IF(ABS(AMAX)-ABS(A(IK)))10,20,20
  9045. C10       AMAX=A(IK)
  9046. C       J2=J1
  9047. C20       CONTINUE
  9048. CC       EXCHANGE ROW K,J2 IF NECESSARY
  9049. C       IF(J2-K)30,60,30
  9050. C30       DO 40 J=K,N
  9051. C       J3=(K-1)*N+J
  9052. C       J4=(J2-1)*N+J
  9053. C       SAVE=A(J3)
  9054. C       A(J3)=A(J4)
  9055. C       A(J4)=SAVE
  9056. C40       CONTINUE
  9057. C       DO 50 J=1,M
  9058. C       J3=(K-1)*M+J
  9059. C       J4=(J2-1)*M+J
  9060. C       SAVE=B(J3)
  9061. C       B(J3)=B(J4)
  9062. C50       B(J4)=SAVE
  9063. CC       REDUCTION
  9064. C60       K1=K+1
  9065. C       KK=(K-1)*N+K
  9066. C       DO 80 I=K1,N
  9067. C       IK=(I-1)*N+K
  9068. C       DO 70 J=K1,N
  9069. C       IJ=(I-1)*M+J
  9070. C       KJ=(K-1)*M+J
  9071.  
  9072. C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
  9073. C       DO 80 J=1,M
  9074. C       IJ=(I-1)*M+J
  9075. C       KJ=(K-1)*N+J
  9076. C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
  9077. C90       CONTINUE
  9078. CC       SUBSTITUTE BACK
  9079. CC       NN=(N-1)*N+N
  9080. C       NN=N*N
  9081. C       DO 110 J=1,M
  9082. C       NJ=(N-1)*M+J
  9083. C       B(NJ)=B(NJ)/A(NN)
  9084. C       I1MAX=N-1
  9085. C       IF(I1MAX)110,110,95
  9086. C95       DO 111 I1=1,I1MAX
  9087. C       I=N-I1
  9088. C       IJ=(I-1)*M+J
  9089. C       II=(I-1)*N+I
  9090. C       I2=I+1
  9091. C       DO 100 L=I2,N
  9092. C       IL=(I-1)*N+L
  9093. C       LJ=(L-1)*M+J
  9094. C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
  9095. C       B(IJ)=B(IJ)/A(II)
  9096. C111       CONTINUE
  9097. C110       CONTINUE
  9098. C       RETURN
  9099. C       END
  9100.     INTEGER A1,A2,B1,B2
  9101. C       DIMENSION A(1),B(1)
  9102. C ALTER DECLARATIONS FOR USE WITH SPREAD SHEET
  9103. C NOTE THAT OUR COLUMN DIMENSION IS 60, NOT N OR M HERE
  9104. C SUBSCRIPTS ARE (ROW-1)*COL-DIMENSION + COL
  9105. C  THEREFORE, CHANGE *N OR *M IN SUBSCRIPT COMPUTATIONS TO
  9106. C  *60
  9107.     REAL*8 A,AW1,AW2,BW1,BW2,AW3,AW4,AMAX
  9108.     INTEGER ABASE,BBASE
  9109.     ABASE=(A2-1)*MCols+A1-1
  9110.     BBASE=(B2-1)*MCols+B1-1
  9111.     D=1.
  9112.        KMAX=N-1
  9113.        DO 90 K=1,KMAX
  9114.        AMAX=0.
  9115.        J2=K
  9116.        DO 20 J1=K,N
  9117.        IK=(J1-1)*MCols+K
  9118.     CALL XVBLGT(IK+ABASE,0,A)
  9119.        IF(DABS(AMAX)-DABS(A))10,20,20
  9120. 10       AMAX=A
  9121.        J2=J1
  9122. 20       CONTINUE
  9123. C       EXCHANGE ROW K,J2 IF NECESSARY
  9124.        IF(J2-K)30,60,30
  9125. 30       DO 40 J=K,N
  9126.        J3=(K-1)*MCols+J
  9127.        J4=(J2-1)*MCols+J
  9128.     CALL XVBLGT(J3+ABASE,0,SAVE)
  9129. C       SAVE=A(J3)
  9130.     CALL XVBLGT(J4+ABASE,0,AW1)
  9131.     CALL XVBLST(J3+ABASE,0,AW1)
  9132.     CALL XVBLST(J4+ABASE,0,SAVE)
  9133. C       A(J3)=A(J4)
  9134. C       A(J4)=SAVE
  9135. 40       CONTINUE
  9136.        DO 50 J=1,M
  9137.        J3=(K-1)*MCols+J
  9138.        J4=(J2-1)*MCols+J
  9139. C       SAVE=B(J3)
  9140. C       B(J3)=B(J4)
  9141. C50       B(J4)=SAVE
  9142.     CALL XVBLGT(J3+BBASE,0,SAVE)
  9143.     CALL XVBLGT(J4+BBASE,0,BW1)
  9144.     CALL XVBLST(J3+BBASE,0,BW1)
  9145.     CALL XVBLST(J4+BBASE,0,SAVE)
  9146. 50    CONTINUE
  9147. C       REDUCTION
  9148. 60       K1=K+1
  9149.        KK=(K-1)*MCols+K
  9150.     CALL XVBLGT(KK+ABASE,0,A)
  9151.     IF(A.EQ.0)GOTO 999
  9152. C    IF(A(KK).EQ.0.)GOTO 999
  9153.        DO 80 I=K1,N
  9154.        IK=(I-1)*MCols+K
  9155.        DO 70 J=K1,N
  9156.        IJ=(I-1)*MCols+J
  9157.        KJ=(K-1)*MCols+J
  9158. C70       A(IJ)=A(IJ)-A(KJ)*A(IK)/A(KK)
  9159.     CALL XVBLGT(IJ+ABASE,0,AW1)
  9160.     CALL XVBLGT(KJ+ABASE,0,AW2)
  9161.     CALL XVBLGT(IK+ABASE,0,AW3)
  9162.     CALL XVBLGT(KK+ABASE,0,AW4)
  9163.     AW1=AW1-AW2*AW3/AW4
  9164.     CALL XVBLST(IJ+ABASE,0,AW1)
  9165. 70    CONTINUE
  9166.        DO 80 J=1,M
  9167.        IJ=(I-1)*MCols+J
  9168.        KJ=(K-1)*MCols+J
  9169. C80       B(IJ)=B(IJ)-B(KJ)*A(IK)/A(KK)
  9170.     CALL XVBLGT(IJ+BBASE,0,BW1)
  9171.     CALL XVBLGT(KJ+BBASE,0,BW2)
  9172.     BW1=BW1-BW2*AW3/AW4
  9173.     CALL XVBLST(IJ+BBASE,0,BW1)
  9174. 80    CONTINUE
  9175. 90       CONTINUE
  9176. C       SUBSTITUTE BACK
  9177.        NN=(N-1)*MCols+N
  9178. C       NN=N*N
  9179.     CALL XVBLGT(NN+ABASE,0,AW1)
  9180.     IF(AW1.EQ.0.)GOTO 999
  9181.        DO 110 J=1,M
  9182.        NJ=(N-1)*MCols+J
  9183. C       B(NJ)=B(NJ)/A(NN)
  9184.     CALL XVBLGT(NJ+BBASE,0,BW1)
  9185.     BW1=BW1/AW1
  9186.     CALL XVBLST(NJ+BBASE,0,BW1)
  9187.        I1MAX=N-1
  9188.        IF(I1MAX)110,110,95
  9189. 95       DO 111 I1=1,I1MAX
  9190.        I=N-I1
  9191.        IJ=(I-1)*MCols+J
  9192.        II=(I-1)*MCols+I
  9193.        I2=I+1
  9194.     CALL XVBLGT(II+ABASE,0,AW1)
  9195.        DO 100 L=I2,N
  9196.        IL=(I-1)*MCols+L
  9197.        LJ=(L-1)*MCols+J
  9198. C100       B(IJ)=B(IJ)-A(IL)*B(LJ)
  9199.     CALL XVBLGT(IJ+BBASE,0,BW1)
  9200.     CALL XVBLGT(IL+ABASE,0,AW2)
  9201.     CALL XVBLGT(LJ+BBASE,0,BW2)
  9202.     BW1=BW1-AW2*BW2
  9203.     CALL XVBLST(IJ+BBASE,0,BW1)
  9204. 100    CONTINUE
  9205. C       B(IJ)=B(IJ)/A(II)
  9206.     BW1=BW1/AW1
  9207.     CALL XVBLST(IJ+BBASE,0,BW1)
  9208. 111       CONTINUE
  9209. 110       CONTINUE
  9210.        RETURN
  9211. 999    CONTINUE
  9212.     D=0.
  9213.     RETURN
  9214.        END
  9215. C *********************  AnalyF6.Ftn ###################################
  9216. c -h- varscn.for    Fri Aug 22 13:37:17 1986    
  9217. C $DO66
  9218.     SUBROUTINE VARSCN(LINE,IBGN,LEND,LSTCHR,ID1,ID2,IVALID)
  9219. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  9220. C ALL RIGHTS RESERVED
  9221. C
  9222. C VARSCN - SCAN COMMAND LINE FOR VARIABLE NAMES.
  9223. C
  9224. C    SCANS FOR VARIABLE NAMES OF FORM AAANNN WHERE AAA = LETTERS
  9225. C BETWEEN A AND Z UP TO NON-ALPHA, CORRESPONDING TO ROW, FOLLOWED BY
  9226. C NUMBERS IN THE 0-9 RANGE MAKING A DECIMAL COLUMN NUMBER.
  9227. C
  9228. C THE LETTERS ARE FORMED BY
  9229. C A-Z ALONE GIVE ROW 1-26, COL 1. % IS ROW 27,COL1
  9230. C A1-Z1 GIVE ROW 1-26, COL 2
  9231. C AA1-ZZ1 ARE ROW 27-52, COL 2
  9232. C
  9233. C In this version we also recognize cell names using an optional third
  9234. C dimension. Forms like B14#2 would be interpreted as cell B14 of sheet
  9235. C 2 (sheets start at 0). This is a display trick mainly, as cell offsets
  9236. C will be treated as simple 2D addresses as before. However, it will allow
  9237. C some greater automation of the notion of multiple areas. Each "page" is
  9238. C formed by adding constants KCDELT and KRDELT to the column and row
  9239. C of the base number, multiplied by the offset in sheets. These constants
  9240. C are initially zero, collapsing all "pages" on top of one another. This
  9241. C interpretation will occur provided K3DFG is 0 or positive. If it is 
  9242. C negative all 3D interpretation will be ignored, and even parsing of
  9243. C the cell names for trailing # characters will be disabled. (This will
  9244. C allow strict return to the older meanings.)
  9245.     IMPLICIT InTeGer*4 (A-Z)
  9246. C NOTE COL 1 IS DUMMY. DISPLAY THE SHEET SIDEWAYS SO WE GET USUAL VISUAL
  9247. C ROWS, COLS., AND ACCUMULATORS A-Z,% JUST APPEAR AS A FICTITIOUS ROW 0
  9248. C ON DISPLAY, INSTEAD OF REAL COLUMN 1 HERE.
  9249.     Include aparms.inc
  9250.     DIMENSION LINE(LEND)
  9251.     CHARACTER*1 LINE
  9252.     InTeGer*4 TYPE(1,2),VLEN(9)
  9253.     REAL*8 XVBLS(1,1)
  9254.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  9255.     Real*8 VAVBLS(3,27)
  9256.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  9257.     REAL*8 XAVB,xac
  9258.     REAL*4 XAV2(2)
  9259.     CHARACTER*1 XAV1(8)
  9260.     EXTERNAL INDX
  9261.     EQUIVALENCE(XAVB,XAV2(1)),(XAVB,XAV1(1))
  9262.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  9263.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  9264. C ***<<< KLSTO COMMON START >>>***
  9265.     InTeGer*4 DLFG
  9266. C    COMMON/DLFG/DLFG
  9267.     InTeGer*4 KDRW,KDCL
  9268. C    COMMON/DOT/KDRW,KDCL
  9269.     InTeGer*4 DTRENA
  9270. C    COMMON/DTRCMN/DTRENA
  9271.     REAL*8 EP,PV,FV
  9272.     DIMENSION EP(20)
  9273.     INTEGER*4 KIRR
  9274. C    COMMON/ERNPER/EP,PV,FV,KIRR
  9275.     InTeGer*4 LASTOP
  9276. C    COMMON/ERROR/LASTOP
  9277.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  9278. C    COMMON/FMTBFR/FMTDAT
  9279.     CHARACTER*1 EDNAM(16)
  9280. C    COMMON/EDNAM/EDNAM
  9281.     InTeGer*4 MFID(2),MFMOD(2)
  9282. C    COMMON/FRM/MFID,MFMOD
  9283.     InTeGer*4 JMVFG,JMVOLD
  9284. C    COMMON/FUBAR/JMVFG,JMVOLD
  9285.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  9286.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  9287. C ***<<< KLSTO COMMON END >>>***
  9288. CCC    InTeGer*4 DLFG
  9289. CCC    COMMON/DLFG/DLFG
  9290. C DLFG=1 IF D## FORMS ARE SEEN
  9291.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  9292.     COMMON/D2R/NRDSP,NCDSP
  9293. C NRDSP AND NCDSP ARE REAL ROW, COL OF DISPLAY ROW, COL CELLS. NOTE THAT
  9294. C NOT ALL DISPLAY CELLS ARE ALWAYS ACTUALLY SHOWN; ONLY THOSE THAT FIT
  9295. C ARE SHOWN; THE REST "EXIST" BUT DON'T APPEAR UNLESS ROWS ARE SMALL
  9296. C ENOUGH.
  9297. C
  9298. C THIS PROGRAM ALSO HANDLES CELL SPECS OF FORM
  9299. C P#+nnn#+nnn (or P#-nnn#-mmm) FOR Physical cells relative to our current
  9300. C physical cell on the sheet (clamped at boundaries), or of form
  9301. C D#+nnn#+mmm etc for Display cells relative to our current display
  9302. C location as held in the DROW,DCOL cells in commons.
  9303. C ***<<<< RDD COMMON START >>>***
  9304.     InTeGer*4 RRWACT,RCLACT
  9305. C    COMMON/RCLACT/RRWACT,RCLACT
  9306.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  9307.      1  IDOL7,IDOL8
  9308. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  9309. C     1  IDOL7,IDOL8
  9310.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  9311. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9312.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9313. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9314. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  9315. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  9316.     InTeGer*4 KLVL
  9317. C    COMMON/KLVL/KLVL
  9318.     InTeGer*4 IOLVL,IGOLD
  9319. C    COMMON/IOLVL/IOLVL
  9320. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  9321. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  9322.     Integer*4 k3dfg,kcdelt,krdelt,kshtf
  9323.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  9324.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  9325.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  9326.      3  k3dfg,kcdelt,krdelt,kshtf
  9327. C ***<<< RDD COMMON END >>>***
  9328. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6
  9329. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6
  9330. CCC    InTeGer*4 PROW,PCOL
  9331. C ! PHYSICAL ROW, COL BEING HANDLED.
  9332. CCC    InTeGer*4 DROW,DCOL,DCLV,DRWV
  9333.     InTeGer*4 RSM,CSM,AFG,ASM,VCF,CH
  9334. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9335.     LOGICAL*4 L1,L2
  9336. C    LOGICAL*2 L63,L192,L127
  9337.     InTeGer*4 I1,I2
  9338.     InTeGer*4 I63,I192,I127
  9339.     EQUIVALENCE(I1,L1),(I2,L2)
  9340. C    EQUIVALENCE (I63,L63),(I192,L192),(L127,I127)
  9341.     save i63,i192,i127
  9342.     DATA I63/63/,I192/192/,I127/127/
  9343. C DRWV,DCLV = # OF MAX ROWS, COLS ACTUALLY ON SCREEN NOW. DROW,DCOL
  9344. C ARE ACTUAL "CURSOR" LOCATION.
  9345. C
  9346. C ZERO OUR VARIABLES
  9347.     LPFG=0
  9348. C ! FLAG WE GOT A LOGICAL/PHYSICAL # FORM AND TYPE
  9349.     AFG=0
  9350. C ! FLAG WE SAW AN ALPHA
  9351.     ASM=0
  9352. C ! SUM OF ALPHAS HASHCODED (ACCUMULATOR)
  9353.     NSM=0
  9354. C ! ACCUMULATOR FOR NUMERICS
  9355.     NFG=0
  9356. C ! FLAG WE SAW A NUMERIC
  9357.     RSM=0
  9358. C ! AC FOR ROWS IN # FORMS
  9359.     CSM=0
  9360. C ! AC FOR COLS IN # FORMS
  9361.     ISPC=0
  9362. C ! COUNTER FOR NONSPACES SEEN (USED TO STOP ON TRAILING SPACES)
  9363.     ktpnd=0
  9364.     idol1=0
  9365.     idol2=0
  9366.     IF(LINE(IBGN).NE.'%')GOTO 2000
  9367.     ID1=27
  9368.     ID2=1
  9369.     IVALID=1
  9370.     LSTCHR=IBGN+1
  9371. C SPECIAL CASE FOR % = AC #27
  9372.     RETURN
  9373. 2000    CONTINUE
  9374.     DO 1 N=IBGN,LEND
  9375.     VCF=0
  9376.     LSTCHR=N
  9377.     CH=ICHAR(LINE(N))
  9378.     IF (CH.EQ.255)GOTO 5000
  9379. C 5000 DECODES ENCODED FORMS AND RETURNS THEM...
  9380. C
  9381. C IGNORE SPACES AND TABS IF LEADING
  9382.     IF(CH.GT.32)ISPC=ISPC+1
  9383.     IF(CH.GT.0.AND.CH.LE.32.AND.ISPC.EQ.0)GOTO 1
  9384. C SPECIAL CASE TRAILING DOLLAR SIGNS... SKIP AND FLAG
  9385.     IF(CH.NE.36)GOTO 3443
  9386. C 36 IS ASCII FOR $ SIGN
  9387. C SAW A DOLLAR SIGN
  9388.     IF(AFG.EQ.1.AND.NFG.EQ.0)IDOL1=1
  9389.     IF(AFG.EQ.1.AND.NFG.EQ.1)IDOL2=1
  9390. C LEAVES WITH IDOL1 FLAGGED AS 1 IF LETTER PART WAS FOLLOWED BY
  9391. C DOLLAR SIGN, AND IDOL2 FLAGGED IF NUMBER PART WAS FOLLOWED
  9392. C BY DOLLAR. IGNORES ALL OTHER DOLLAR SIGNS.
  9393.     GOTO 1
  9394. 3443    CONTINUE
  9395. C GET CHARACTER VALUE IN.
  9396. C MUST BE UPPERCASE.
  9397.     IF(.NOT.(CH.GE.65.AND.CH.LT.91)) GOTO 100
  9398. C CH IS AN ALPHA, RANGE A-Z
  9399.     VCF=1
  9400. C ! VALID CHAR SEEN
  9401.     AFG=1
  9402. C !SAW THE ALPHA
  9403.     IF(ASM.LT.MRC)ASM=(CH-64)+26*ASM
  9404.     IF(NFG.NE.0)GOTO 103
  9405. C FILTER OUT TOO-LARGE VALUES...
  9406. C leave the 18000 limit in for now; seems big enough!
  9407.     IF(ASM.GT.(mrc-MCols))GOTO 103
  9408. C 60 * 26 IS LIM ABOVE
  9409.     IF(CH.EQ.80)LPFG=1
  9410. C ! FLAG WE GOT PHYS. FORM MAYBE
  9411.     IF(CH.EQ.68)LPFG=2
  9412. C ! FLAG WE GOT DISPLAY FORM MAYBE
  9413. 100    CONTINUE
  9414. C EXPECT # FORMS TO HAVE # JUST AFTER 1ST ALPHA.
  9415. C 35 IS ASCII VALUE OF '#' CHAR.
  9416.     IF(CH.EQ.35)GOTO 1000
  9417. C NEXT TEST NUMERICS
  9418.     IF(.NOT.(CH.GE.48.AND.CH.LE.57))GOTO 101
  9419. C CH IS A NUMERIC, RANGE 0-9
  9420.     VCF=1
  9421. C ! VALID CHAR SEEN
  9422.     NFG=1
  9423. C ! FLAG WE SAW NUMERIC
  9424.     IF(AFG.NE.0)GOTO 102
  9425.     GOTO 103
  9426. 102    CONTINUE
  9427.     IF(NSM.LT.MRC)NSM=(CH-48)+10*NSM
  9428. C FILTER OUT TOO-LARGE VALUES EARLY
  9429. C 301 * 10 IS LIMIT...
  9430.     IF(NSM.GT.(MRC-MCols))GOTO 103
  9431. C ! CONVERT CHARS TO BINARY AS SEEN
  9432. 101    CONTINUE
  9433.     IF(VCF.EQ.0)GOTO 2
  9434. C !END ON ANY INVALID CHARACTER
  9435. 1    CONTINUE
  9436. 2    CONTINUE
  9437.     IF(AFG.EQ.0)GOTO 103
  9438.     GOTO 950
  9439. 103    CONTINUE
  9440. C INVALID ... NUMERIC AND NO PRIOR ALPHA. FLAG BAD NAME AND EXIT.
  9441.     IVALID=0
  9442.     RETURN
  9443. 950    ID1=ASM
  9444.     ID2=1+NSM
  9445. C ! NOTE ID2=1 IF NO NUMERICS SEEN, MORE OTHERWISE.
  9446.     GOTO 1201
  9447. 1000    CONTINUE
  9448. C HERE HANDLE CURRENT-REFERENCED FORMS USING # AS SPECIAL CHARACTER MEANING
  9449. C THE CURRENT POSITION. THESE TYPES OF REFERENCES MAY BE MOVED AROUND THE
  9450. C SHEET WHICH ACCOUNTS FOR THEIR USEFULNESS. SINCE THERE IS A DISPLAY
  9451. C AND PHYSICAL SHEET WHICH ARE MAPPED BY A MAPPING, ALLOW EITHER
  9452. C TO BE REFERENCED. THUS, COMPLEX CALCULATIONS MAY BE DONE BUT LARGELY
  9453. C HIDDEN. THE ACCUMULATORS MAY BE USED AS SCRATCH STORAGE FOR THIS
  9454. C SORT OF THING.
  9455. C SAW THE # SIGN, SO SEE IF THE + OR - N CAN BE DECODED.
  9456. C IF NO P OR D WAS SEEN HOWEVER WE HAVE AN INVALID NAME, SO FLAG IT.
  9457.     IF(LPFG.EQ.0)GOTO 103
  9458. C PASS THE # SIGN PRIOR TO GETTING THE NUMERIC.
  9459.     LSTCHR=LSTCHR+1
  9460.     iundr=0
  9461.     if(line(lstchr).eq.'_')iundr=1
  9462.     if(line(lstchr).eq.'$')iundr=2
  9463.     if(line(lstchr).ne.'%'.and.iundr.eq.0)goto 3900
  9464. c allow p#%ab form to mean use ac a and b to get offsets from "here"
  9465. c allow P#_ab to be absolute address ref for cells (otherwise like p#%ab)
  9466.     CSM=0
  9467.     RSM=0
  9468. C DEFAULT TO "THIS" CELL
  9469.     LSTCHR=LSTCHR+1
  9470. C PASS THE % SIGN (or other special char we recognize)
  9471.     if(Iundr.lt.2)goto 3906
  9472. c
  9473. c P#$var1var2 is a form that allows relative addressing using ANY of the
  9474. c cells for col and row. First cell is col, 2nd is row
  9475. c The pointers so derived are ABSOLUTE, relative to absolute beginning of
  9476. c the sheet. This seems to me more useful than the relative addressing forms.
  9477. c However, I dislike the offset by 1 for rows so will subtract it off so the
  9478. c accumulators will be addressed as row 0.
  9479.     kkk=lstchr
  9480.     kkkk=lstchr+20
  9481.     klstc=kkk
  9482. c
  9483. c Call copy (without this mod) of varscn subroutine to do the examining of 
  9484. c variable names, so we don't wind up recursively calling ourselves.
  9485. c
  9486.     call varsc2(line,kkk,kkkk,klstc,kr1,kr2,kvld)
  9487.     if(kvld.eq.0)goto 3906
  9488. c try normal processing if this doesn't look like regular variables
  9489.     if(line(klstc).eq.':')klstc=klstc+1
  9490.     kkk=klstc
  9491.     kkkk=kkk+20
  9492.     call varsc2(line,kkk,kkkk,klstc,kc1,kc2,kvld)
  9493.     if(kvld.eq.0)goto 3906
  9494. c Update last chharacter seen pointer to pass these variables.
  9495.     if(line(klstc).eq.':')klstc=klstc+1
  9496.     lstchr=klstc
  9497. c Get the values of the variables and store as integers
  9498.     call xvblgt(kr1,kr2,xac)
  9499.     rsm=xac
  9500.     call xvblgt(kc1,kc2,xac)
  9501.     csm=xac
  9502.     goto 3901
  9503. 3906    continue
  9504.     RSM=ICHAR(LINE(LSTCHR))
  9505.     CSM=ICHAR(LINE(LSTCHR+1))
  9506.     LSTCHR=LSTCHR+2
  9507. C FIX UP ASCII OFFSETS, AND MEANWHILE REQUIRE UPPERCASE
  9508. C AND THAT THERE BE 2 AC'S NAMES AFTER THE %.
  9509. C THIS SHOULD BE HANDY FOR COMMAND FILES.
  9510.     RSM=RSM-64
  9511.     CSM=CSM-64
  9512. C NOW RSM, CSM ARE SUBSCRIPTS. PULL OUT VALUES FROM XVBLS
  9513.     IF(RSM.LE.0.OR.RSM.GT.27)GOTO 103
  9514.     IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
  9515.     xavb=vavbls(1,RSM)
  9516. c    DO 3902 IV=1,8
  9517. c3902    XAV1(IV)=AVBLS(IV,RSM)
  9518.     RSM=XAVB
  9519.     xavb=vavbls(1,CSM)
  9520. c    DO 3903 IV=1,8
  9521. c3903    XAV1(IV)=AVBLS(IV,CSM)
  9522.     CSM=XAVB
  9523. C LOADS THE 2 AC'S TO THE OFFSETS AND GOES ON...JUST NEEDS THE
  9524. C 2 LETTERS AFTER P#% OR D#%.
  9525.     goto 3901
  9526. 3900    continue
  9527.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9528. C GN GETS THE +- NN NUMBER AND RETURNS VALUE IN NUM.
  9529. C LSTCHR RETURNS AS NEXT CHAR NOT USED.
  9530.     RSM=NUM
  9531. C 35 IS ASCII FOR '#'
  9532. C allow any delimiter between numbers, though we must have # at start
  9533. C  to delimit valid relative coordinates.
  9534. C    IF(ICHAR(LINE(LSTCHR)).NE.35) GOTO 103
  9535. C IF NO SECOND # SEEN, THE FORM IS INVALID SO SAY SO AND EXIT.
  9536.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9537. CC BUMP PAST THE # IF WE SAW IT.
  9538. C now get the second numeric string and bump LSTCHR past it.
  9539.     NUM=0
  9540.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9541.     CSM=NUM
  9542. C NOW HAVE THE NUMBERS ENCODED. NOTE THAT ## IS VALID.
  9543. 3901    CONTINUE
  9544.     IF(LPFG.EQ.2) GOTO 1200
  9545. C IF HERE, LPFG=1 AND WE ARE ON PHYSICAL SHEET.
  9546.     if(Iundr.ne.0)goto 3908
  9547.     ID2=CSM+PCOL
  9548.     ID1=RSM+PROW
  9549.     goto 1201
  9550. 3908    Continue
  9551.     id2=CSM+1
  9552.     id1=RSM
  9553. c Subtract 1 from row to make accumulator row be number zero. This is more
  9554. c symmetrical with other usages in the sheet cell names. I like it better than
  9555. c making cell A1 be col 1 row 2.
  9556. 1201    CONTINUE
  9557. C Add-in for 3d cells
  9558.     kshtf=0
  9559.     If(k3dfg.lt.0)goto 1202
  9560. C 37 is ascii %
  9561.     IF(LINE(LSTCHR).NE.'%') GOTO 1202
  9562. C pass the trailing % character now
  9563.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9564. C limited form of syntax: either a number is to be used
  9565. C or an accumulator.
  9566.     If(ichar(line(lstchr)).gt.64) goto 1203
  9567. C a number.
  9568.     NUM=0
  9569.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9570.     CSM=NUM
  9571.     Goto 1204
  9572. 1203    Continue
  9573. C a (possible) accumulator
  9574.     csm=ichar(line(lstchr))
  9575.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9576.     CSM=CSM-64
  9577. C Csm now is index to accumulator. Validity check it.
  9578.     IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
  9579.     xavb=vavbls(1,csm)
  9580. c    DO 2902 IV=1,8
  9581. c2902    XAV1(IV)=AVBLS(IV,csm)
  9582. C convert the accumulator value.
  9583.     CSM=XAVB
  9584. 1204    Continue
  9585. C now fix up the col and row returned.
  9586.     id1=id1+(csm*kcdelt)
  9587.     id2=id2+(csm*krdelt)
  9588.     kshtf=csm
  9589. C allow our callers to see what (if any) "page" was flagged.
  9590. C note that zero and no page flagged are treated the same.
  9591. 1202    Continue
  9592. C TO ALLOW REFLECTED VALUES TO WORK, LET ALL NORMAL VALUES BY...
  9593. C    IF(ID1.GT.60.OR.ID1.LE.0)GOTO 103
  9594. C    IF(ID2.GT.301.OR.ID2.LE.0)GOTO 103
  9595.     IVALID=1
  9596. C ALL IS WELL
  9597.     RETURN
  9598. 1200    CONTINUE
  9599. C DISPLAY COLUMN RELATIVE.
  9600.     DLFG=1
  9601. C FLAG WE SAW A D## FORM FOR RECALC
  9602.     DRRW=DROW+RSM
  9603.     DRRW=MAX0(1,DRRW)
  9604.     DRRW=MIN0(JIDcl,DRRW)
  9605.     DCCL=DCOL+CSM
  9606. C ENSURE DISPLAY COORDS IN LEGAL BOUNDS
  9607.     DCCL=MAX0(1,DCCL)
  9608.     DCCL=MIN0(JIDrw,DCCL)
  9609. C CLAMP TO WITHIN LEGAL DIMENSIONS.
  9610.     ID1=NRDSP(DRRW,DCCL)
  9611.     ID2=NCDSP(DRRW,DCCL)
  9612.     GOTO 1201
  9613. 5000    CONTINUE
  9614.     IF(ASM.NE.0.OR.NSM.NE.0)GOTO 103
  9615. C HANDLE 255,CODE1,CODE2 FORMS
  9616. C FIRST BYTE IS ALWAYS 255
  9617. C 2ND BYTE IS: HI 2 BITS ARE HI 2 BITS OF ID2. LO 6 BITS ARE ID1
  9618. C 3RD BYTE IS: LO 8 BITS OF ID2
  9619.     I1=ICHAR(LINE(LSTCHR+1))
  9620.     I2=IMASK(I1,I192)
  9621. C    L2=L1.AND.L192
  9622. C    L1=L1.AND.L63
  9623.     I1=IMASK(I1,I63)
  9624.     ID1=I1
  9625.     I1=ICHAR(LINE(LSTCHR+2))
  9626. C    L1=L1.AND.L127
  9627.     I1=IMASK(I1,I127)
  9628. C MUST HAVE 128 BIT ON IN LOW BYTE TO AVOID NULLS IN IT.
  9629.     ID2=I2*2+I1
  9630.     LSTCHR=LSTCHR+3
  9631.     GOTO 1201
  9632.     END
  9633. c -h- varsc2.for
  9634. C $DO66
  9635.     SUBROUTINE VARSC2(LINE,IBGN,LEND,LSTCHR,ID1,ID2,IVALID)
  9636.     Include aparms.inc
  9637. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  9638. C ALL RIGHTS RESERVED
  9639. C
  9640. C VARSC2 - SCAN COMMAND LINE FOR VARIABLE NAMES.
  9641. C    This copy of VARSCN lacks the P#@var1var2 construct and exists to
  9642. C    be called from VARSCN for that construct to parse the var1 and var2
  9643. C    variable names without risk of a recursive call to varscn (which
  9644. C    Fortran generally cannot handle.)
  9645. C
  9646. C    SCANS FOR VARIABLE NAMES OF FORM AAANNN WHERE AAA = LETTERS
  9647. C BETWEEN A AND Z UP TO NON-ALPHA, CORRESPONDING TO ROW, FOLLOWED BY
  9648. C NUMBERS IN THE 0-9 RANGE MAKING A DECIMAL COLUMN NUMBER.
  9649. C
  9650. C THE LETTERS ARE FORMED BY
  9651. C A-Z ALONE GIVE ROW 1-26, COL 1. % IS ROW 27,COL1
  9652. C A1-Z1 GIVE ROW 1-26, COL 2
  9653. C AA1-ZZ1 ARE ROW 27-52, COL 2
  9654.     IMPLICIT InTeGer*4 (A-Z)
  9655. C NOTE COL 1 IS DUMMY. DISPLAY THE SHEET SIDEWAYS SO WE GET USUAL VISUAL
  9656. C ROWS, COLS., AND ACCUMULATORS A-Z,% JUST APPEAR AS A FICTITIOUS ROW 0
  9657. C ON DISPLAY, INSTEAD OF REAL COLUMN 1 HERE.
  9658.     DIMENSION LINE(LEND)
  9659.     CHARACTER*1 LINE
  9660.     InTeGer*4 TYPE(1,2),VLEN(9)
  9661.     REAL*8 XVBLS(1,1)
  9662.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  9663.     Real*8 VAVBLS(3,27)
  9664.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  9665.     REAL*8 XAVB
  9666.     REAL*4 XAV2(2)
  9667.     CHARACTER*1 XAV1(8)
  9668.     EXTERNAL INDX
  9669.     EQUIVALENCE(XAVB,XAV2(1)),(XAVB,XAV1(1))
  9670.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  9671.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  9672. C ***<<< KLSTO COMMON START >>>***
  9673.     InTeGer*4 DLFG
  9674. C    COMMON/DLFG/DLFG
  9675.     InTeGer*4 KDRW,KDCL
  9676. C    COMMON/DOT/KDRW,KDCL
  9677.     InTeGer*4 DTRENA
  9678. C    COMMON/DTRCMN/DTRENA
  9679.     REAL*8 EP,PV,FV
  9680.     DIMENSION EP(20)
  9681.     INTEGER*4 KIRR
  9682. C    COMMON/ERNPER/EP,PV,FV,KIRR
  9683.     InTeGer*4 LASTOP
  9684. C    COMMON/ERROR/LASTOP
  9685.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  9686. C    COMMON/FMTBFR/FMTDAT
  9687.     CHARACTER*1 EDNAM(16)
  9688. C    COMMON/EDNAM/EDNAM
  9689.     InTeGer*4 MFID(2),MFMOD(2)
  9690. C    COMMON/FRM/MFID,MFMOD
  9691.     InTeGer*4 JMVFG,JMVOLD
  9692. C    COMMON/FUBAR/JMVFG,JMVOLD
  9693.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  9694.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  9695. C ***<<< KLSTO COMMON END >>>***
  9696. CCC    InTeGer*4 DLFG
  9697. CCC    COMMON/DLFG/DLFG
  9698. C DLFG=1 IF D## FORMS ARE SEEN
  9699.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  9700.     COMMON/D2R/NRDSP,NCDSP
  9701. C NRDSP AND NCDSP ARE REAL ROW, COL OF DISPLAY ROW, COL CELLS. NOTE THAT
  9702. C NOT ALL DISPLAY CELLS ARE ALWAYS ACTUALLY SHOWN; ONLY THOSE THAT FIT
  9703. C ARE SHOWN; THE REST "EXIST" BUT DON'T APPEAR UNLESS ROWS ARE SMALL
  9704. C ENOUGH.
  9705. C
  9706. C THIS PROGRAM ALSO HANDLES CELL SPECS OF FORM
  9707. C P#+nnn#+nnn (or P#-nnn#-mmm) FOR Physical cells relative to our current
  9708. C physical cell on the sheet (clamped at boundaries), or of form
  9709. C D#+nnn#+mmm etc for Display cells relative to our current display
  9710. C location as held in the DROW,DCOL cells in commons.
  9711. C ***<<<< RDD COMMON START >>>***
  9712.     InTeGer*4 RRWACT,RCLACT
  9713. C    COMMON/RCLACT/RRWACT,RCLACT
  9714.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  9715.      1  IDOL7,IDOL8
  9716. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  9717. C     1  IDOL7,IDOL8
  9718.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  9719. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9720.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9721. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  9722. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  9723. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  9724.     InTeGer*4 KLVL
  9725. C    COMMON/KLVL/KLVL
  9726.     InTeGer*4 IOLVL,IGOLD
  9727. C    COMMON/IOLVL/IOLVL
  9728. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  9729. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  9730.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  9731.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  9732.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  9733.      3  k3dfg,kcdelt,krdelt,kpag
  9734. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  9735. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  9736. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  9737. C ***<<< RDD COMMON END >>>***
  9738. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6
  9739. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6
  9740. CCC    InTeGer*4 PROW,PCOL
  9741. C ! PHYSICAL ROW, COL BEING HANDLED.
  9742. CCC    InTeGer*4 DROW,DCOL,DCLV,DRWV
  9743.     InTeGer*4 RSM,CSM,AFG,ASM,VCF,CH
  9744. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  9745.     LOGICAL*4 L1,L2
  9746. C    LOGICAL*2 L63,L192,L127
  9747.     InTeGer*4 I1,I2
  9748.     InTeGer*4 I63,I192,I127
  9749.     EQUIVALENCE(I1,L1),(I2,L2)
  9750. C    EQUIVALENCE (I63,L63),(I192,L192),(L127,I127)
  9751.     save i63,i192,i127
  9752.     DATA I63/63/,I192/192/,I127/127/
  9753. C DRWV,DCLV = # OF MAX ROWS, COLS ACTUALLY ON SCREEN NOW. DROW,DCOL
  9754. C ARE ACTUAL "CURSOR" LOCATION.
  9755. C
  9756. C ZERO OUR VARIABLES
  9757.     LPFG=0
  9758. C ! FLAG WE GOT A LOGICAL/PHYSICAL # FORM AND TYPE
  9759.     AFG=0
  9760. C ! FLAG WE SAW AN ALPHA
  9761.     ASM=0
  9762. C ! SUM OF ALPHAS HASHCODED (ACCUMULATOR)
  9763.     NSM=0
  9764. C ! ACCUMULATOR FOR NUMERICS
  9765.     NFG=0
  9766. C ! FLAG WE SAW A NUMERIC
  9767.     RSM=0
  9768. C ! AC FOR ROWS IN # FORMS
  9769.     CSM=0
  9770. C ! AC FOR COLS IN # FORMS
  9771.     ISPC=0
  9772. C ! COUNTER FOR NONSPACES SEEN (USED TO STOP ON TRAILING SPACES)
  9773.     idol1=0
  9774.     idol2=0
  9775.     IF(LINE(IBGN).NE.'%')GOTO 2000
  9776.     ID1=27
  9777.     ID2=1
  9778.     IVALID=1
  9779.     LSTCHR=IBGN+1
  9780. C SPECIAL CASE FOR % = AC #27
  9781.     RETURN
  9782. 2000    CONTINUE
  9783.     DO 1 N=IBGN,LEND
  9784.     VCF=0
  9785.     LSTCHR=N
  9786.     CH=ICHAR(LINE(N))
  9787.     IF (CH.EQ.255)GOTO 5000
  9788. C 5000 DECODES ENCODED FORMS AND RETURNS THEM...
  9789. C
  9790. C IGNORE SPACES AND TABS IF LEADING
  9791.     IF(CH.GT.32)ISPC=ISPC+1
  9792.     IF(CH.GT.0.AND.CH.LE.32.AND.ISPC.EQ.0)GOTO 1
  9793. C SPECIAL CASE TRAILING DOLLAR SIGNS... SKIP AND FLAG
  9794.     IF(CH.NE.36)GOTO 3443
  9795. C 36 IS ASCII FOR $ SIGN
  9796. C SAW A DOLLAR SIGN
  9797.     IF(AFG.EQ.1.AND.NFG.EQ.0)IDOL1=1
  9798.     IF(AFG.EQ.1.AND.NFG.EQ.1)IDOL2=1
  9799. C LEAVES WITH IDOL1 FLAGGED AS 1 IF LETTER PART WAS FOLLOWED BY
  9800. C DOLLAR SIGN, AND IDOL2 FLAGGED IF NUMBER PART WAS FOLLOWED
  9801. C BY DOLLAR. IGNORES ALL OTHER DOLLAR SIGNS.
  9802.     GOTO 1
  9803. 3443    CONTINUE
  9804. C GET CHARACTER VALUE IN.
  9805. C MUST BE UPPERCASE.
  9806.     IF(.NOT.(CH.GE.65.AND.CH.LT.91)) GOTO 100
  9807. C CH IS AN ALPHA, RANGE A-Z
  9808.     VCF=1
  9809. C ! VALID CHAR SEEN
  9810.     AFG=1
  9811. C !SAW THE ALPHA
  9812.     IF(ASM.LT.MRC)ASM=(CH-64)+26*ASM
  9813.     IF(NFG.NE.0)GOTO 103
  9814. C FILTER OUT TOO-LARGE VALUES...
  9815.     IF(ASM.GT.(MRC-MCOls))GOTO 103
  9816. C 60 * 26 IS LIM ABOVE
  9817.     IF(CH.EQ.80)LPFG=1
  9818. C ! FLAG WE GOT PHYS. FORM MAYBE
  9819.     IF(CH.EQ.68)LPFG=2
  9820. C ! FLAG WE GOT DISPLAY FORM MAYBE
  9821. 100    CONTINUE
  9822. C EXPECT # FORMS TO HAVE # JUST AFTER 1ST ALPHA.
  9823. C 35 IS ASCII VALUE OF '#' CHAR.
  9824.     IF(CH.EQ.35)GOTO 1000
  9825. C NEXT TEST NUMERICS
  9826.     IF(.NOT.(CH.GE.48.AND.CH.LE.57))GOTO 101
  9827. C CH IS A NUMERIC, RANGE 0-9
  9828.     VCF=1
  9829. C ! VALID CHAR SEEN
  9830.     NFG=1
  9831. C ! FLAG WE SAW NUMERIC
  9832.     IF(AFG.NE.0)GOTO 102
  9833.     GOTO 103
  9834. 102    CONTINUE
  9835.     IF(NSM.LT.MRC)NSM=(CH-48)+10*NSM
  9836. C FILTER OUT TOO-LARGE VALUES EARLY
  9837. C 301 * 10 IS LIMIT...
  9838.     IF(NSM.GT.(MRC-MCols))GOTO 103
  9839. C ! CONVERT CHARS TO BINARY AS SEEN
  9840. 101    CONTINUE
  9841.     IF(VCF.EQ.0)GOTO 2
  9842. C !END ON ANY INVALID CHARACTER
  9843. 1    CONTINUE
  9844. 2    CONTINUE
  9845.     IF(AFG.EQ.0)GOTO 103
  9846.     GOTO 950
  9847. 103    CONTINUE
  9848. C INVALID ... NUMERIC AND NO PRIOR ALPHA. FLAG BAD NAME AND EXIT.
  9849.     IVALID=0
  9850.     RETURN
  9851. 950    ID1=ASM
  9852.     ID2=1+NSM
  9853. C ! NOTE ID2=1 IF NO NUMERICS SEEN, MORE OTHERWISE.
  9854.     GOTO 1201
  9855. 1000    CONTINUE
  9856. C HERE HANDLE CURRENT-REFERENCED FORMS USING # AS SPECIAL CHARACTER MEANING
  9857. C THE CURRENT POSITION. THESE TYPES OF REFERENCES MAY BE MOVED AROUND THE
  9858. C SHEET WHICH ACCOUNTS FOR THEIR USEFULNESS. SINCE THERE IS A DISPLAY
  9859. C AND PHYSICAL SHEET WHICH ARE MAPPED BY A MAPPING, ALLOW EITHER
  9860. C TO BE REFERENCED. THUS, COMPLEX CALCULATIONS MAY BE DONE BUT LARGELY
  9861. C HIDDEN. THE ACCUMULATORS MAY BE USED AS SCRATCH STORAGE FOR THIS
  9862. C SORT OF THING.
  9863. C SAW THE # SIGN, SO SEE IF THE + OR - N CAN BE DECODED.
  9864. C IF NO P OR D WAS SEEN HOWEVER WE HAVE AN INVALID NAME, SO FLAG IT.
  9865.     IF(LPFG.EQ.0)GOTO 103
  9866. C PASS THE # SIGN PRIOR TO GETTING THE NUMERIC.
  9867.     LSTCHR=LSTCHR+1
  9868.     iundr=0
  9869.     if(line(lstchr).eq.'_')iundr=1
  9870.     if(line(lstchr).ne.'%'.and.iundr.eq.0)goto 3900
  9871. c allow p#%ab form to mean use ac a and b to get offsets from "here"
  9872. c allow P#_ab to be absolute address ref for cells (otherwise like p#%ab)
  9873.     CSM=0
  9874.     RSM=0
  9875. C DEFAULT TO "THIS" CELL
  9876.     LSTCHR=LSTCHR+1
  9877. C PASS THE % SIGN
  9878.     RSM=ICHAR(LINE(LSTCHR))
  9879.     CSM=ICHAR(LINE(LSTCHR+1))
  9880.     LSTCHR=LSTCHR+2
  9881. C FIX UP ASCII OFFSETS, AND MEANWHILE REQUIRE UPPERCASE
  9882. C AND THAT THERE BE 2 AC'S NAMES AFTER THE %.
  9883. C THIS SHOULD BE HANDY FOR COMMAND FILES.
  9884.     RSM=RSM-64
  9885.     CSM=CSM-64
  9886. C NOW RSM, CSM ARE SUBSCRIPTS. PULL OUT VALUES FROM XVBLS
  9887.     IF(RSM.LE.0.OR.RSM.GT.27)GOTO 103
  9888.     IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
  9889.     xavb=vavbls(1,RSM)
  9890. c    DO 3902 IV=1,8
  9891. c3902    XAV1(IV)=AVBLS(IV,RSM)
  9892.     RSM=XAVB
  9893.     xavb=vavbls(1,CSM)
  9894. c    DO 3903 IV=1,8
  9895. c3903    XAV1(IV)=AVBLS(IV,CSM)
  9896.     CSM=XAVB
  9897. C LOADS THE 2 AC'S TO THE OFFSETS AND GOES ON...JUST NEEDS THE
  9898. C 2 LETTERS AFTER P#% OR D#%.
  9899.     goto 3901
  9900. 3900    continue
  9901.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9902. C GN GETS THE +- NN NUMBER AND RETURNS VALUE IN NUM.
  9903. C LSTCHR RETURNS AS NEXT CHAR NOT USED.
  9904.     RSM=NUM
  9905. C 35 IS ASCII FOR '#'
  9906. C allow any delimiter between numbers, though we must have # at start
  9907. C  to delimit valid relative coordinates.
  9908. C    IF(ICHAR(LINE(LSTCHR)).NE.35) GOTO 103
  9909. C IF NO SECOND # SEEN, THE FORM IS INVALID SO SAY SO AND EXIT.
  9910.     LSTCHR=MIN0(LSTCHR+1,LEND)
  9911. CC BUMP PAST THE # IF WE SAW IT.
  9912. C now get the second numeric string and bump LSTCHR past it.
  9913.     NUM=0
  9914.     CALL GN(LSTCHR,LEND,NUM,LINE)
  9915.     CSM=NUM
  9916. C NOW HAVE THE NUMBERS ENCODED. NOTE THAT ## IS VALID.
  9917. 3901    CONTINUE
  9918.     IF(LPFG.EQ.2) GOTO 1200
  9919. C IF HERE, LPFG=1 AND WE ARE ON PHYSICAL SHEET.
  9920.     if(Iundr.eq.1)goto 3908
  9921.     ID2=CSM+PCOL
  9922.     ID1=RSM+PROW
  9923.     goto 1201
  9924. 3908    Continue
  9925.     id2=CSM
  9926.     id1=RSM
  9927. 1201    CONTINUE
  9928. C TO ALLOW REFLECTED VALUES TO WORK, LET ALL NORMAL VALUES BY...
  9929. C    IF(ID1.GT.60.OR.ID1.LE.0)GOTO 103
  9930. C    IF(ID2.GT.301.OR.ID2.LE.0)GOTO 103
  9931.     IVALID=1
  9932. C ALL IS WELL
  9933.     RETURN
  9934. 1200    CONTINUE
  9935. C DISPLAY COLUMN RELATIVE.
  9936.     DLFG=1
  9937. C FLAG WE SAW A D## FORM FOR RECALC
  9938.     DRRW=DROW+RSM
  9939.     DRRW=MAX0(1,DRRW)
  9940.     DRRW=MIN0(JIDcl,DRRW)
  9941.     DCCL=DCOL+CSM
  9942. C ENSURE DISPLAY COORDS IN LEGAL BOUNDS
  9943.     DCCL=MAX0(1,DCCL)
  9944.     DCCL=MIN0(JIDrw,DCCL)
  9945. C CLAMP TO WITHIN LEGAL DIMENSIONS.
  9946.     ID1=NRDSP(DRRW,DCCL)
  9947.     ID2=NCDSP(DRRW,DCCL)
  9948.     GOTO 1201
  9949. 5000    CONTINUE
  9950.     IF(ASM.NE.0.OR.NSM.NE.0)GOTO 103
  9951. C HANDLE 255,CODE1,CODE2 FORMS
  9952. C FIRST BYTE IS ALWAYS 255
  9953. C 2ND BYTE IS: HI 2 BITS ARE HI 2 BITS OF ID2. LO 6 BITS ARE ID1
  9954. C 3RD BYTE IS: LO 8 BITS OF ID2
  9955.     I1=ICHAR(LINE(LSTCHR+1))
  9956.     I2=IMASK(I1,I192)
  9957. C    L2=L1.AND.L192
  9958. C    L1=L1.AND.L63
  9959.     I1=IMASK(I1,I63)
  9960.     ID1=I1
  9961.     I1=ICHAR(LINE(LSTCHR+2))
  9962. C    L1=L1.AND.L127
  9963.     I1=IMASK(I1,I127)
  9964. C MUST HAVE 128 BIT ON IN LOW BYTE TO AVOID NULLS IN IT.
  9965.     ID2=I2*2+I1
  9966.     LSTCHR=LSTCHR+3
  9967.     GOTO 1201
  9968.     END
  9969. c -h- vvary.for    Fri Aug 22 13:37:17 1986    
  9970. C $DO66
  9971. C VARY CONTROL ROUTINE
  9972. C NOTE: THIS ROUTINE RELIES UPON HAVING ITS DATA AREAS REMAIN INTACT
  9973. C ACROSS CALLS. IT MUST NOT BE IN AN OVERLAY SEGMENT OR THAT WILL FAIL
  9974. C AND IT WILL NOT WORK. SPECIFICALLY IT EXPECTS THE AC ARRAY TO BE
  9975. C SET CORRECTLY.
  9976.     SUBROUTINE VVARY(LINE,RETCD,K)
  9977.     CHARACTER*1 LINE(80)
  9978.     INTEGER RETCD
  9979.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  9980.     Real*8 VAVBLS(3,27)
  9981.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  9982.     InTeGer*4 TYPE(1,2),VLEN(9)
  9983.     REAL*8 XAC,XVBLS(1,1)
  9984.     EQUIVALENCE(XAC,AVBLS(1,27))
  9985.     INTEGER*4 JVBLS(2,1,1)
  9986.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  9987.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  9988.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  9989. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  9990. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  9991. C (IMPLEMENT FOR VAX ONLY)
  9992. C ***<<< XVXTCD COMMON START >>>***
  9993.     CHARACTER*1 OARRY(100)
  9994.     InTeGer*4 OSWIT,OCNTR
  9995. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  9996. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  9997. C    InTeGer*4 IPS1,IPS2,MODFLG
  9998.     InTeGer*4 IC1POS,IC2POS,MODFLG
  9999. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  10000. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  10001.        InTeGer*4 XTCFG,IPSET,XTNCNT
  10002.        CHARACTER*1 XTNCMD(80)
  10003. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  10004. C VARY FLAG ITERATION COUNT
  10005.     INTEGER KALKIT
  10006. C    COMMON/VARYIT/KALKIT
  10007.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  10008.     InTeGer*4 RCMODE,IRCE1,IRCE2
  10009. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  10010. C     1  IRCE2
  10011. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  10012. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  10013. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  10014. C RCFGX ON.
  10015. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  10016. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  10017. C  AND VM INHIBITS. (SETS TO 1).
  10018.     INTEGER*4 FH
  10019. C FILE HANDLE FOR CONSOLE I/O (RAW)
  10020. C    COMMON/CONSFH/FH
  10021.     CHARACTER*1 ARGSTR(52,4)
  10022. C    COMMON/ARGSTR/ARGSTR
  10023.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  10024.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  10025.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  10026.      3  IRCE2,FH,ARGSTR
  10027. C ***<<< XVXTCD COMMON END >>>***
  10028. CCC    INTEGER KALKIT
  10029. CCC    COMMON/VARYIT/KALKIT
  10030.     EXTERNAL SIGN
  10031.     INTEGER LPUT,LGET
  10032.     REAL*8 SIGN
  10033.     CHARACTER*1 LAC(8)
  10034.     REAL*8 XVAC,VW
  10035.     EQUIVALENCE(LAC(1),XVAC)
  10036.     REAL *8 AC(26)
  10037.     REAL*8 DERIV(8)
  10038.     REAL*8 DEL(8)
  10039.     REAL*8 OLDVV,OLDX,OLDA
  10040.     INTEGER ACV(8)
  10041.     INTEGER CAC(2)
  10042.     INTEGER CCNT(8)
  10043. C UNCOMMENT THIS COMMON DECLARATION AND MOVE DATA STMTS INTO BLOCK
  10044. C IN ORDER TO OVERLAY THIS...
  10045.     COMMON/VRYDAT/AC,DERIV,DEL,CAC,CCNT,OLDVV,OLDX,OLDA,ACV
  10046. C
  10047. C ACV POINTS TO AC'S VARYING
  10048. C CAC = CURRENT INDEX INTO ACV TO FIND AC BEING VARIED
  10049. C AC IS LAST SET OF ACCUMULATORS SEEN
  10050. C IF ACV ENTRY IS 0, MEANS NO AC TO VARY THERE.
  10051.     INTEGER LW,LX,LI
  10052. C ! LOGICAL W,X,I AC'S
  10053.     INTEGER LA
  10054. C ! LOGICAL A AC
  10055. C
  10056. C    DATA DERIV/8*1./,DEL/8*0./
  10057. C    DATA CAC/1,1/,CCNT/8*0/
  10058. C    DATA ACV/8*0/
  10059. C    DATA OLDVV/1./
  10060. C
  10061. C PARSE ARGUMENTS FIRST
  10062. C FIRST 2 ARGS ARE X AND A AC'S (OR GENERAL CELLS)
  10063. C DEFAULT NO REDOING THIS...
  10064.     KALKIT=0
  10065.     IBGN=K+5
  10066.     LEND=IBGN+20
  10067.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LX,ID2A,IVALID)
  10068.     IF (IVALID.EQ.0)GOTO 9900
  10069.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  10070.     IBGN=LSTCHR+1
  10071.     LEND=IBGN+20
  10072.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LA,ID2B,IVALID)
  10073.     IF (IVALID.EQ.0)GOTO 9900
  10074.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  10075.     IBGN=LSTCHR+1
  10076.     LEND=IBGN+20
  10077.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LW,ID3B,IVALID)
  10078.     IF (IVALID.EQ.0)GOTO 9900
  10079.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  10080.     IF(ID3B.NE.1)GOTO 9900
  10081.     IBGN=LSTCHR+1
  10082.     LEND=IBGN+20
  10083.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LI,ID3B,IVALID)
  10084.     IF (IVALID.EQ.0)GOTO 9900
  10085.     IF(LINE(LSTCHR).NE.',')GOTO 9900
  10086.     IF(ID3B.NE.1)GOTO 9900
  10087. C    IBGN=LSTCHR+1
  10088. C    LEND=IBGN+20
  10089. C LOOP OVER VALUES TO VARY NOW
  10090.     DO 99 N=1,8
  10091. 99    ACV(N)=0.
  10092.     DO 100 N=1,8
  10093. C ALLOW UP TO 8 DIMENSIONS VARIATION
  10094.     IBGN=LSTCHR+1
  10095.     LEND=IBGN+20
  10096.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ACV(N),ID3B,IVALID)
  10097.     IF (IVALID.EQ.0)GOTO 9900
  10098.     IF(LINE(LSTCHR).NE.';')GOTO 110
  10099.     IF(ID3B.NE.1)GOTO 9900
  10100.     IBGN=LSTCHR+1
  10101.     LEND=IBGN+20
  10102. 100    CONTINUE
  10103. 110    CONTINUE
  10104. C NOW HAVE ALL AC POINTERS SET UP.
  10105. C IF I IS NOW 0 OR NEGATIVE (ITER COUNT), REINITIALIZE.
  10106.     ASSIGN 111 TO LGET
  10107.     LLL=LI
  10108.     GOTO 500
  10109. 111    CONTINUE
  10110.     IF(XVAC.GT.0.)GOTO 112
  10111. C INITIALIZE COUNTS
  10112.     LLL=LW
  10113. C GET VALUE OF W FRACTION
  10114.     ASSIGN 114 TO LGET
  10115.     GOTO 500
  10116. 114    CONTINUE
  10117.     VW=XVAC
  10118.     OLDVV=1.
  10119.     DO 113 N=1,8
  10120.     CCNT(N)=0
  10121.     DERIV(N)=1.
  10122.     DEL(N)=VW
  10123. 113    CONTINUE
  10124.     CAC(1)=1
  10125. C COPY CURRENT AC'S INTO SAVED ONES NOW.
  10126.     DO 117 N=1,26
  10127.     LLL=N
  10128.     ASSIGN 118 TO LGET
  10129.     GOTO 500
  10130. 118    AC(N)=XVAC
  10131. 117    CONTINUE
  10132. C AFTER THE INIT, JUST RETURN SINCE WE DON'T WANT TO TRY ANY ITERATIONS
  10133. C WHEN ITER COUNT EXPIRES.
  10134.     KALKIT=0
  10135.     RETURN
  10136. C HERE WHEN ITER COUNT IS POSITIVE.
  10137. 112    CONTINUE
  10138.     XVAC=XVAC-1.
  10139. C UPDATE ITERATION COUNT NOW...
  10140.     KALKIT=XVAC
  10141.     ASSIGN 120 TO LPUT
  10142.     GOTO 600
  10143. 120    CONTINUE
  10144. C
  10145. C NOW PROCEED WITH VARIATIONS...
  10146.     IF(CAC(1).LT.1.OR.CAC(1).GT.8)CAC(1)=1
  10147.     IF(CCNT(CAC(1)).GE.1)GOTO 200
  10148. C CCNT WAS 0 SO WE DIDN'T GET OUR PARTIAL YET. VARY THE
  10149. C AC WE'RE LOOKING AT (CAC = CURRENT AC) AND USE NEW VALUE OF
  10150. C (X-A) FOR A NUMERICAL DERIVATIVE RESULT AFTER A RECALC OF SCREEN...
  10151.     CCNT(CAC(1))=1
  10152. C JUST STARTED THIS AC SO VARY BY THE APPROPRIATE DELTA AND
  10153. C EXIT, ALLOWING PARTIAL TO BE COMPUTED NEXT TIME.
  10154.     LLL=LW
  10155.     ASSIGN 400 TO LGET
  10156.     GOTO 500
  10157. 400    CONTINUE
  10158. C GET W ACC. VALUE
  10159.     VW=XVAC
  10160.     IF(VW.EQ.0.)VW=.5
  10161. C GET CURRENT AC, FIND HOW TO UPDATE IT.
  10162.     LLL=ACV(CAC(1))
  10163.     IF(LLL.LE.0)GOTO 9900
  10164.     ASSIGN 121 TO LGET
  10165.     GOTO 500
  10166. 121    CONTINUE
  10167. C NOW XVAC HAS CURRENT AC FOR THE ONE WE'RE VARYING
  10168. C ADD DEL TO IT AND GET NEW ONE...
  10169. C SAVE OLD X AC VALUE FOR NEXT ITERATION.
  10170. C NOTE LLL IS STILL SET AT CURRENTLY VARYING AC
  10171. C SAVE CURRENT (UNVARIED) VALUE TOO FOR NEXT TIME AROUND.
  10172.     OLDVV=XVAC
  10173.     IF(OLDVV.EQ.0.)OLDVV=1.
  10174.     IF(DEL(CAC(1)).EQ.0.)DEL(CAC(1))=VW
  10175.     XVAC=XVAC*(1.+DEL(CAC(1)))
  10176. C NOW ALL SET... JUST SAVE CURRENT AC'S AND CURRENT X,A
  10177. C SO WE CAN GET DIFFERENCE NEXT TIME AROUND.
  10178. C    AC(ACV(CAC(1)))=XVAC
  10179. C STORE XVAC INTO REAL ACCUMULATORS TOO, SO IT'LL WORK
  10180. C WHEN ALL AC'S ARE RELOADED BELOW.
  10181.     ASSIGN 412 TO LPUT
  10182.     GOTO 600
  10183. 412    CONTINUE
  10184. C AT 1000, RELOAD AC ARRAY FROM REAL AC'S... BUT GET OUR MODIFIED
  10185. C ONE WE JUST STORED TOO.
  10186.     GOTO 1000
  10187. 200    CONTINUE
  10188. C COUNT HERE IS 1 SO WE ALREADY HAVE INFO NOW FOR OUR PARITAL
  10189. C DERIVATIVE. COMPUTE IT AND VARY THE SELECTED AC USING IT
  10190. C THEN STORE IT AND RESET CCNT(CAC) TO 0
  10191.     CCNT(CAC(1))=0
  10192. C MUST GET NEW X AND A VALUES NOW.
  10193.     CALL XVBLGT(LX,ID2A,XVAC)
  10194. C    XVAC=XVBLS(LX,ID2A)
  10195.     IF(ID2A.NE.1)GOTO 201
  10196.     LLL=LX
  10197.     ASSIGN 201 TO LGET
  10198. C EXTRACT CURRENT X FROM AVBLS
  10199.     GOTO 500
  10200. 201    CONTINUE
  10201.     XCURR=XVAC
  10202.     CALL XVBLGT(LA,ID2B,XVAC)
  10203. C    XVAC=XVBLS(1,1)
  10204.     IF(ID2B.NE.1)GOTO 202
  10205.     LLL=LA
  10206.     ASSIGN 202 TO LGET
  10207.     GOTO 500
  10208. 202    CONTINUE
  10209.     ACURR=XVAC
  10210. C NOW WE HAVE ENOUGH TO COMPUTE PARTIAL DERIVATIVE WE NEED.
  10211.     IF(ACV(CAC(1)).LE.0)GOTO 9900
  10212.     IF(OLDVV.EQ.0.)OLDVV=AC(ACV(CAC(1)))
  10213.     IF(OLDVV.EQ.0.)OLDVV=1.
  10214.     DERIV(CAC(1))=((XCURR-ACURR)-(OLDX-OLDA))/(DEL(CAC(1))*OLDVV)
  10215. C NEGATIVE FEEDBACK: IF GOING POSITIVE, MAKE IT NEGATIVE...
  10216. C THIS IS NOT AN ANALYTICAL PROCEDURE ... JUST STEPS IN RIGHT DIRECTION
  10217. C BY APPROPRIATE AMOUNT AND CONTINUES...
  10218. C CLAMP VARIATION TO INITIAL PERCENTAGE IN W ACCUMULATOR
  10219.     LLL=LW
  10220. C OBTAIN VALUE OF W VARIATION NOW...IN CASE USER SETS IT UP TO VARY
  10221.     ASSIGN 203 TO LGET
  10222.     GOTO 500
  10223. 203    CONTINUE
  10224.     VW=XVAC
  10225. C
  10226. C TO ATTEMPT TO GET TO THE ZERO OF (X-A), WE REALLY NEED TO
  10227. C DIVIDE BY THE DERIVATIVE. HOWEVER, IN CASES WHERE THE FUNCTION
  10228. C IS NEAR ITS LOCAL MINIMUM AND SLOWLY VARYING, WE REALLY DON'T WANT
  10229. C TO STEP FAR AWAY (IT MAY NEVER REACH THE ZERO). THEREFORE, TEST
  10230. C TO SEE IF THE DERIVATIVE IS LARGE AND ALLOW DIVISION WHERE IT IS
  10231. C OVER A SOMEWHAT ARBITRARY THRESHOLD (USED 1.0 BELOW), BUT
  10232. C MULTIPLY BY DERIVATIVE OTHERWISE, SO THAT AS THE FUNCTION APPROACHES
  10233. C ZERO SLOPE, THE STEPS GET FINER TO GET INTO THE LOCAL MINIMUM (IF ANY).
  10234. C
  10235. C FORCE NONZERO VARIATION JUST SO WE DON'T GET STUCK.
  10236.     IF(DERIV(CAC(1)).EQ.0.)DERIV(CAC(1))=.01
  10237.     IF(DABS(DERIV(CAC(1))).GT.1.)GOTO 405
  10238.     DEL(CAC(1))=-(OLDX-OLDA)*VW*DERIV(CAC(1))
  10239.     GOTO 406
  10240. 405    CONTINUE
  10241.     DEL(CAC(1))=-(OLDX-OLDA)*VW/DERIV(CAC(1))
  10242. 406    CONTINUE
  10243. C VERY IMPORTANT TO CLAMP SIZE OF STEPS HERE SO WE DON'T WILDLY DIVERGE
  10244. C IN EARLY GOING. SMALL STEPS TAKE LONGER BUT GET TO MINIMA; LARGER ONES
  10245. C WHERE WE DON'T KNOW FUNCTION SHAPE CAN BE DISASTERS.
  10246.     IF(DABS(DEL(CAC(1))).GT.VW)DEL(CAC(1))=VW*SIGN(DEL(CAC(1)))
  10247. C NOW RESTORE AC'S TO OLD ONES AND VARY CURRENT ONE BY
  10248. C THE NEW DELTA.
  10249.     IF(ACV(CAC(1)).LE.0)GOTO 9900
  10250. C NEXT LINE MAKES ADJUSTMENT NEEDED TO OUR VARYING AC.
  10251.     AC(ACV(CAC(1)))=OLDVV*(1.+DEL(CAC(1)))
  10252. C NOW COPY SAVED OLD AC'S ONTO NEW ONES SO WE START WITH AC'S ALL AS THEY
  10253. C WERE IN FIRST STEP SO WE VARY FROM INITIAL X, NOT FROM FIRST VARIED X
  10254. C LOCATION...
  10255.     DO 204 N=1,26
  10256.     XVAC=AC(N)
  10257.     LLL=N
  10258.     ASSIGN 205 TO LPUT
  10259.     GOTO 600
  10260. 205    CONTINUE
  10261. 204    CONTINUE
  10262. C MOVE ON TO THE NEXT CAC VALUE
  10263.     CAC(1)=CAC(1)+1
  10264.     IF(ACV(CAC(1)).LE.0.OR.CAC(1).GT.8)CAC(1)=1
  10265. 1000    CONTINUE
  10266. C SAVE OLD AC'S NOW FOR NEXT TIME
  10267.     DO 1100 N=1,26
  10268.     LLL=N
  10269.     ASSIGN 1101 TO LGET
  10270.     GOTO 500
  10271. 1101    AC(N)=XVAC
  10272. 1100    CONTINUE
  10273. C REMEMBER OLD X AND A VALUES SINCE WE LOOK FOR X=A AS
  10274. C A SEARCH CONDITION. WE MUST ASSUME THAT SOME SORT OF
  10275. C VARIATION OF ACCUMULATORS GIVEN WILL ALLOW US TO SATISFY
  10276. C THE EQUATION (X-A)=0.
  10277.     OLDX=AC(LX)
  10278.     IF(ID2A.NE.1)CALL XVBLGT(LX,ID2A,OLDX)
  10279. C    IF(ID2A.NE.1)OLDX=XVBLS(LX,ID2A)
  10280.     OLDA=AC(LA)
  10281.     IF(ID2B.NE.1)CALL XVBLGT(LA,ID2B,OLDA)
  10282. C    IF(ID2B.NE.1)OLDA=XVBLS(LA,ID2B)
  10283.     RETURN
  10284. 9900    CONTINUE
  10285.     RETCD=3
  10286.     RETURN
  10287. C PROC TO LOAD XVAC WITH VBLS(LLL)
  10288. 500    CONTINUE
  10289.     xvac=vavbls(1,LLL)
  10290. c    DO 501 KKKKN=1,8
  10291. c501    LAC(KKKKN)=AVBLS(KKKKN,LLL)
  10292.     GOTO LGET,(111,114,118,400,121,201,202,203,1101)
  10293. C PROC TO STORE XVAC INTO VBLS(LLL)
  10294. 600    CONTINUE
  10295.     vavbls(1,LLL)=xvac
  10296. c    DO 601 KKKKN=1,8
  10297. c601    AVBLS(KKKKN,LLL)=LAC(KKKKN)
  10298.     GOTO LPUT,(120,412,205)
  10299.     END
  10300. c -h- xqtcmd.for    Fri Aug 22 13:45:23 1986    
  10301. C $DO66
  10302.     SUBROUTINE XQTCMD(ICODE)
  10303. C COPYRIGHT (C) 1983-1990 GLENN AND MARY EVERHART
  10304. c All Rights Reserved
  10305.     Include aparms.inc
  10306. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  10307. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  10308. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  10309. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  10310. C FROM THE DISK BASED FILE HERE.
  10311.     CHARACTER*1 FORM,FVLD,CMDLIN(132),CL127(127)
  10312. C ALLOCATE EXTRA SLOP SPACE AFTER CMDLIN
  10313.     CHARACTER*1 CLWW(136)
  10314.     EQUIVALENCE(CLWW(1),CMDLIN(1))
  10315.     CHARACTER*127 CMDLNA
  10316.     EQUIVALENCE(CMDLIN(1),CL127(1),CMDLNA(1:1))
  10317. C    EQUIVALENCE(CMDLNA,CMDLIN(1))
  10318.     CHARACTER*127 WRKCHR,FORMCH,fwt
  10319. C    equivalence(fwt(1:1),formch(1:1))
  10320.     CHARACTER*1 FORM2(128),NMSH(80)
  10321.     CHARACTER*1 WRKCHA(132),WRK127(127)
  10322.     EQUIVALENCE(WRKCHA(1),WRKCHR(1:1),WRK127(1),FORM2(1))
  10323. C    EQUIVALENCE(FORM2(1),WRK127(1))
  10324. C ***<<<< RDD COMMON START >>>***
  10325.     InTeGer*4 RRWACT,RCLACT
  10326. C    COMMON/RCLACT/RRWACT,RCLACT
  10327.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  10328.      1  IDOL7,IDOL8
  10329. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  10330. C     1  IDOL7,IDOL8
  10331.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  10332. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  10333.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  10334. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  10335. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  10336. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  10337. c    InTeGer*4 KLVL
  10338. C    COMMON/KLVL/KLVL
  10339.     InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kpag
  10340.     InTeGer*4 IOLVL,IGOLD
  10341. C    COMMON/IOLVL/IOLVL
  10342. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  10343. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  10344.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  10345.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  10346.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  10347.      3  k3dfg,kcdelt,krdelt,kpag
  10348. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  10349. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  10350. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  10351. c     3  k3dfg,kcdelt,krdelt,kpag
  10352. C ***<<< RDD COMMON END >>>***
  10353. CCC    InTeGer*4 RRWACT,RCLACT
  10354. CCC    COMMON/RCLACT/RRWACT,RCLACT
  10355. c    INTEGER*4 VNLT
  10356.     EXTERNAL INDX
  10357. c    EQUIVALENCE(FORM2(1),WRKCHR)
  10358.     COMMON/NMSH/NMSH
  10359.     REAL*8 XVBLS(1,1)
  10360.     INTEGER KPYBAK
  10361. CCC    Integer*4 FH
  10362. CCC    Common/CONSFH/FH
  10363. C ***<<< KLSTO COMMON START >>>***
  10364.     InTeGer*4 DLFG
  10365. C    COMMON/DLFG/DLFG
  10366.     InTeGer*4 KDRW,KDCL
  10367. C    COMMON/DOT/KDRW,KDCL
  10368.     InTeGer*4 DTRENA
  10369. C    COMMON/DTRCMN/DTRENA
  10370.     REAL*8 EP,PV,FV
  10371.     DIMENSION EP(20)
  10372.     INTEGER*4 KIRR
  10373. C    COMMON/ERNPER/EP,PV,FV,KIRR
  10374.     InTeGer*4 LASTOP
  10375. C    COMMON/ERROR/LASTOP
  10376.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  10377. C    COMMON/FMTBFR/FMTDAT
  10378.     CHARACTER*1 EDNAM(16)
  10379. C    COMMON/EDNAM/EDNAM
  10380.     InTeGer*4 MFID(2),MFMOD(2)
  10381. C    COMMON/FRM/MFID,MFMOD
  10382.     InTeGer*4 JMVFG,JMVOLD
  10383. C    COMMON/FUBAR/JMVFG,JMVOLD
  10384.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  10385.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  10386. C ***<<< KLSTO COMMON END >>>***
  10387. CCC    InTeGer*4 JMVFG,JMVOLD
  10388.     INTEGER*4 JVBLS(2,1,1)
  10389. CCC    COMMON/IOLVL/IOLVL
  10390. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  10391. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  10392. C PUT JMVFG INTO A PSECT BY ITSELF SO IT WILL SURVIVE OVERLAYS.
  10393. CCC    COMMON/FUBAR/JMVFG,JMVOLD
  10394.     DIMENSION FORM(128),FVLD(1,1)
  10395.     CHARACTER*1 DFE,FVWRK,FRM127(127)
  10396.     EQUIVALENCE(FORM(1),FORMCH(1:1),FRM127(1))
  10397. C    EQUIVALENCE(FORM(1),FRM127(1)),(FRM127(1),FORMCH)
  10398.     DIMENSION DFE(14)
  10399.     CHARACTER*14 CDFE
  10400.     EQUIVALENCE(CDFE(1:1),DFE(1))
  10401. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  10402. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  10403. C SO INITIALLY IGNORE.
  10404. C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
  10405. C
  10406. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  10407. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  10408. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
  10409. CCC     1  IDOL7,IDOL8
  10410.  
  10411. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
  10412. CCC     1  IDOL7,IDOL8
  10413. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  10414. CCC    InTeGer*4 LLCMD,LLDSP
  10415. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  10416.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  10417.     COMMON/D2R/NRDSP,NCDSP
  10418.     InTeGer*4 ILNFG,ILNCT,RCF
  10419. C ***<<< NULETC COMMON START >>>***
  10420.     InTeGer*4 ICREF,IRREF
  10421. C    COMMON/MIRROR/ICREF,IRREF
  10422.     InTeGer*4 MODPUB,LIMODE
  10423. C    COMMON/MODPUB/MODPUB,LIMODE
  10424.     InTeGer*4 KLKC,KLKR
  10425.     REAL*8 AACP,AACQ
  10426. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  10427.     InTeGer*4 NCEL,NXINI
  10428. C    COMMON/NCEL/NCEL,NXINI
  10429.     CHARACTER*1 NAMARY(20,MROWS)
  10430. C    COMMON/NMNMNM/NAMARY
  10431.     InTeGer*4 NULAST,LFVD
  10432. C    COMMON/NULXXX/NULAST,LFVD
  10433.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  10434.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  10435. C ***<<< NULETC COMMON END >>>***
  10436. CCC    COMMON/NCEL/NCEL,NXINI
  10437.     CHARACTER*1 ILINE(106)
  10438.     COMMON/ILN/ILNFG,ILNCT,ILINE
  10439. C ***<<< XVXTCD COMMON START >>>***
  10440.     CHARACTER*1 OARRY(100)
  10441.     InTeGer*4 OSWIT,OCNTR
  10442. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  10443. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  10444. C    InTeGer*4 IPS1,IPS2,MODFLG
  10445.     InTeGer*4 IC1POS,IC2POS,MODFLG
  10446. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  10447. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  10448.        InTeGer*4 XTCFG,IPSET,XTNCNT
  10449.        CHARACTER*1 XTNCMD(80)
  10450. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  10451. C VARY FLAG ITERATION COUNT
  10452.     INTEGER KALKIT
  10453. C    COMMON/VARYIT/KALKIT
  10454.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  10455.     InTeGer*4 RCMODE,IRCE1,IRCE2
  10456. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  10457. C     1  IRCE2
  10458. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  10459. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  10460. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  10461. C RCFGX ON.
  10462. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  10463. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  10464. C  AND VM INHIBITS. (SETS TO 1).
  10465.     INTEGER*4 FH
  10466. C FILE HANDLE FOR CONSOLE I/O (RAW)
  10467. C    COMMON/CONSFH/FH
  10468.     CHARACTER*1 ARGSTR(52,4)
  10469. C    COMMON/ARGSTR/ARGSTR
  10470.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  10471.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  10472.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  10473.      3  IRCE2,FH,ARGSTR
  10474. C ***<<< XVXTCD COMMON END >>>***
  10475. CCC    InTeGer*4 IC1POS,IC2POS,MODFLG
  10476. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  10477. CCC    CHARACTER*1 OARRY(100)
  10478. CCC    InTeGer*4 OSWIT,OCNTR
  10479. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  10480. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  10481.     InTeGer*4 TYPE(1,2),VLEN(9)
  10482.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  10483.     Real*8 VAVBLS(3,27)
  10484.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  10485.     CHARACTER*1 FVLDTP
  10486.     REAL*8 XAC,ZAC
  10487.     EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
  10488.     REAL*8 XXAC,XYAC
  10489.     EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
  10490. CCC    InTeGer*4 NULAST,LFVD
  10491. CCC    COMMON/NULXXX/NULAST,LFVD
  10492. CCC    CHARACTER*1 ARGSTR(52,4)
  10493. CCC    COMMON/ARGSTR/ARGSTR
  10494. C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
  10495. C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
  10496. C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
  10497. C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
  10498. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
  10499. C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
  10500.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  10501.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  10502.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  10503. CCC    COMMON/KLVL/KLVL
  10504.     CHARACTER*1 DEFVB(12)
  10505. CCC    InTeGer*4 MODPUB,LIMODE
  10506. CCC    COMMON/MODPUB/MODPUB,LIMODE
  10507.     COMMON/DEFVBX/DEFVB
  10508. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  10509. CCC     1  IRCE1,IRCE2
  10510. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  10511. CCC     1  IRCE1,IRCE2
  10512. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  10513. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  10514. C  AND VM INHIBITS. (SETS TO 1).
  10515. C
  10516. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  10517. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  10518. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  10519. C DISPLAY ACTUALLY USED FOR SCREEN.
  10520.     Integer*4 CWids(JIDcl)
  10521. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  10522. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  10523. C AS 20 NOT 75.
  10524.     REAL*8 DVS(JIDcl,JIDrw)
  10525.     INTEGER*4 LDVS(2,JIDcl,JIDrw)
  10526.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  10527.     COMMON /FVLDC/FVLD
  10528. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  10529. C 10 CHARACTERS PER ENTRY.
  10530.     COMMON/DSPCMN/DVS,CWIDS
  10531. C THISRW,THISCL = CURRENT DISPLAYED LOCS.
  10532.     InTeGer*4 THISRW,THISCL
  10533. C    CHARACTER*1 IBITMP(2258)
  10534. C    COMMON/INITD/IBITMP
  10535. C FOLLOWING COMMON IS TO CONTROL "EXTERNAL" CALL OF XQTCMD
  10536. C TO ALLOW USE FROM INSIDE CELLS.
  10537. CCC    CHARACTER*1 XTNCMD(80)
  10538. CCC    InTeGer*4 XTCFG,XTNCNT,IPSET
  10539. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  10540.     CHARACTER*1 blanks
  10541.     character*1 defplt(24)
  10542.     dimension blanks(30)
  10543.     save blanks
  10544.     data defplt/'$',' ','E','X','E','C','U','T','E',
  10545.      1  ' ','D','K',':','P','L','T','F','I',
  10546.      1  'L','.','P','C','P',0/
  10547.     data blanks/30*' '/
  10548. C
  10549.     OSWIT=2
  10550. C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
  10551. C
  10552. C  COMMANDS INCLUDE:
  10553. C E = ENTER NUMBERS OR FORMULAS
  10554. C M = MOVE DIRECTION (1,2,3,4 = U,D,L,R)
  10555. C D = DISPLAY CHARACTERISTIC CHANGES
  10556. C
  10557. C DISPLAY ALTERING SUBCOMMANDS:
  10558. C  DL V1:V2 RN:M OR CN:M - DISPLAY VARIABLE RANGE V1:V2 AT DISPLAY
  10559. C  ROW OR COL N THRU M.
  10560. C  RN:M MEANS ACROSS A ROW ON DISPLAY STARTING AT DISPLAY COORD N,M
  10561. C  CN:M MEANS DOWN A DISPLAY COLUMN STARTING AT DISPLAY COORD N,M
  10562. C  DF V1:V2 FORMAT
  10563. C  SET FORMAT FOR DISPLAY OF V1 THRU V2 TO FORMAT (NOT INCL. )
  10564. C  A OR L DESIGNATOR SAYS SHOW TEXT IN FORMULA BUFFER. ELSE SHOW
  10565. C  NUMBER VALUE AT THAT LOC.
  10566. C  DT V1:V2 F OR I - SET NUMERIC TYPE OF V1 THRU V2 TO FLOAT OR INT.
  10567. C  DW N,M - SET WIDTH OF COL. N TO M CHARS WIDE.
  10568. C  DB MC,MR - SET MAX COLS TO MC, MAX ROWS TO MR.
  10569. C
  10570. C V = VIEWSCREEN UPDATE. REDISPLAY EVERYTHING FROM SCRATCH.
  10571. C VF = VIEW BUT DISPLAY FORMULAS ALL LOCS.
  10572. C VM = DISABLE REDRAWING SCREEN UNTIL A V IS SEEN.
  10573. C C = COPY NUMBERS/FORMULAS/DISPLAY STUFF(FORMAT)/ALL/RELOCATING
  10574. C 1,2,3,4 = MOVE CURSOR UP,DOWN,LEFT,RIGHT 1 ROW/COL
  10575. C (THESE DO NOT INVALIDATE CALCULATION SO RECALCULATION IS NOT
  10576. C DONE FOR THESE COMMANDS.)
  10577. C F FILENAME/NNN  FILL SCREEN (DISPLAYED PART ONLY) FROM FILENAME,
  10578. C    SKIPPING NNN RECORDS FIRST IF CALLED FOR. /NNN PART OPTIONAL.
  10579. C  (SPLITS STUFF READ IN ACROSS COLUMNS CURRENTLY DEFINED AND
  10580. C   SETS FVLD FOR DISPLAY OF TEXT, NOT #S.)
  10581. C AR/A n R/C ADDS/SUBTRACTS (INSERTS/DELETES) n ROWS OR COLUMNS
  10582. C   AT CURENT LOCATION. AR/AA SELECTS RELOCATING/ABSOLUTE.
  10583. C R = RECALCULATE SHEET. 17 = RECALCULATE MANUALLY ONLY (R RESETS)
  10584. C K = DROP INTO CALC CALCULATOR (*E RETURNS TO SHEET)
  10585. C L = LOCATE CURSOR (MOVE TO POSITION ON SHEET)
  10586. C (L VARIABLE IS THE COMMAND, AND IT LOCATES ORIGIN ON PHYSICAL
  10587. C SHEET. WILL ALSO MOVE CURSOR ON DISPLAY SHEET IF THAT CELL IS
  10588. C DISPLAYED, BUT OTHERWISE DOES NOT DISPLAY THE NUMBER.)
  10589. C Z = ZERO FORMULA/NUMBERS (OR ALL SHEET)
  10590. C  ZERO VARIABLE ZEROES THAT VARIABLE
  10591. C  ZERO VARIABLE1:VARIABLE2 ZEROES THAT RANGE (ROW OR COL)
  10592. C  ZERO * ZEROES ALL OF THE SHEET.
  10593. C X = EXIT (RETURNS TO OS)
  10594. C P = PUT NUMBERS TO FILE. ALWAYS GENERATES P#+nn#+mm forms based on
  10595. C current location.
  10596. C G = GET NUMBERS OUT OF FILE. USES CURRENT ORIGIN FROM L COMMAND OR 1,1
  10597. C TO ENTER NUMBERS (ALLOWS COMBINING DATA).
  10598. C W = WRITE SCREEN ON PRINTER (HARDCOPY FORMAT APPROX. AS DISPLAY.)
  10599. C OA VARIABLE = SET ORIGIN OF DISPLAY SHEET TO VARIABLE LOC IN
  10600. C  PHYSICAL SHEET (CLAMPED TO MAX. SIZE OF SHEET). STARTS AT R1,C1 OF
  10601. C  DISPLAY SHEET.
  10602. C OR VARIABLE = SET ORIGIN OF DISPLAY SHEET TO LOC'N OF VARIABLE IN
  10603. C  PHYSICAL SHEET. MODIFIES DISPLAY SHEET STARTING AT CURRENT DISPLAY
  10604. C  LOCATION RATHER THAN AT 1,1.
  10605. C
  10606. C NOTE THAT N-ARY FUNCTIONS ARE FNAMEARGS,ARGS,...
  10607. C AND RANGES ARE CELL1:CELLN. MULTIPLE COMMANDS IN FORMULA ARE
  10608. C DELIMITED BY \ CHARACTER.
  10609. C
  10610. C RETURN CODES:
  10611. C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
  10612. C THE ENTIRE SHEET.
  10613. C ICODE =-1 ==> REINITIALIZE DISPLAY DEFAULTS
  10614. C ICODE =2  ==> REDRAW WHOLE SCREEN
  10615. C ICODE =-2 ==> NEW SPREAD SHEET FILE SETUP.
  10616. C OTHER: ALL OK.
  10617. 498    CONTINUE
  10618.     KLVL=1
  10619.     ICODE=3
  10620. C DEFAULT RETURN CODE SAYING ALL WELL
  10621. C FIRST DISPLAY CURRENT CELL AGAIN IN NORMAL.
  10622.     THISRW=DROW
  10623.     THISCL=DCOL
  10624.     FORM(1)=char(0)
  10625. C GET IN THE CURRENT FORMAT WHEREVER WE ARE, EVEN IF NOT ON DISPLAY SHEET.
  10626. C    IRRX=(PCOL-1)*60+PROW
  10627.     CALL REFLEC(PCOL,PROW,IRRX)
  10628.     CALL WRKFIL(IRRX,FORM2,0)
  10629.     CALL CE2A(FORM2,FORM)
  10630. C    READ(7'IRRX)FORM
  10631.     IF(THISRW.LE.0.OR.THISCL.LE.0)GOTO 200
  10632.     N1=NRDSP(THISRW,THISCL)
  10633.     N2=NCDSP(THISRW,THISCL)
  10634.     IXLSTC=THISCL
  10635.     IXLSTR=THISRW
  10636.     IF(THISCL.GT.DCLV.OR.THISRW.GT.DRWV)GOTO 200
  10637. C REDRAW LAST DISPLAYED CELL IN NORMAL (I.E., NOT REVERSE) VIDEO.
  10638. C    IF(ICHAR(FVLD(N1,N2)).EQ.0)GOTO 200
  10639. C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
  10640.     J=8
  10641. C    IRRX=(N2-1)*60+N1
  10642.     CALL REFLEC(N2,N1,IRRX)
  10643. C ADD 6 COLS FOR LABELS
  10644.     DO 1 M1=1,DROW
  10645. C FIND DISPLAY COLUMN TO USE
  10646. 1    J=J+CWIDS(M1)
  10647.     J=J-CWIDS(DROW)
  10648. C USE THISCL+1 TO LET 1ST ROW BE LABELS.
  10649.     ICCC=THISCL+2
  10650. C 0 = 1 IF VT100, 0 IF VT52
  10651. C SAVE PHYS COORDS BEING DISPLAYED NEXT. FVLD CAN BE TESTED FOR NUMERICS
  10652. C DIRECTLY, IF UVT100 NEEDS THAT ACCESS.
  10653.     IC1POS=N1
  10654.     IC2POS=N2
  10655.     IF(PZAP.NE.0)GOTO 3607
  10656.     CALL UVT100(1,ICCC,J)
  10657. C SELECT ROW "THISCL", COL "J"
  10658.     CALL UVT100(13,7,0)
  10659.     CALL FVLDGT(N1,N2,FVLD(1,1))
  10660. C    IF(FVLD(1,1).EQ.0)WRITE(6,5538)
  10661. C5538    FORMAT('>-<')
  10662.     ivv=min0(30,cwids(DROW))
  10663. c reset blanks to be sure we write something even for vt52
  10664. ccc    blanks(1)='>'
  10665.     IF(ICHAR(FVLD(1,1)).EQ.0)CALL SWRT(BLANKS,IVV)
  10666. ccc    blanks(1)=32
  10667. cccccc no VT52's in PCs...
  10668. C5538    FORMAT(1H+,30(a1,'\'))
  10669. 3607    CONTINUE
  10670. C WE CAN BE SURE THE COLUMN IS 3 WIDE OR MORE...
  10671.     CALL FVLDGT(N1,N2,FVLDTP)
  10672.     IF(ICHAR(FVLDTP).EQ.0)GOTO 200
  10673. C    IRRX=(N2-1)*60+N1
  10674. C SELECT REVERSE VIDEO
  10675.     DO 5540 KKKK=1,100
  10676. 5540    CMDLIN(KKKK)=char(32)
  10677.     CALL WRKFIL(IRRX,FORM2,0)
  10678.     CALL CE2A(FORM2,FORM)
  10679. C    READ(7'IRRX)FORM
  10680. C    IF(JCHAR(FORM(120)).LE.0)GOTO 200
  10681.     IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
  10682.      1  WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
  10683. 8201    FORMAT(128A1)
  10684.     IF(FORMFG.NE.0)GOTO 4320
  10685.     DO 6301 KKK=1,9
  10686.     KKKK=ICHAR(FORM(KKK+119))
  10687. C    KKKK=DFMTS(KKK,THISRW,THISCL)
  10688. 6301    DFE(KKK+1)=CHAR(MAX0(32,KKKK))
  10689.     DFE(11)=CHAR(32)
  10690. C 32 = ASCII SPACE
  10691.     DFE(1)='('
  10692.     DFE(12)=' '
  10693.     DFE(13)=' '
  10694.     DFE(14)=')'
  10695.     CALL TYPGET(N1,N2,TYPE(1,1))
  10696.     IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
  10697.      1  WRITE(CMDLNA(1:127),DFE,ERR=4320)DVS(THISRW,THISCL)
  10698.     IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
  10699.      1   WRITE(CMDLNA(1:127),DFE,ERR=4320)LDVS(1,THISRW,THISCL)
  10700. C REDRAW THIS COL. WITH REVERSE VIDEO HERE.
  10701. 4320    IF(PZAP.EQ.0)CALL SWRT(CMDLIN,CWIDS(THISRW))
  10702. C9800    FORMAT('+',128(A,'\'))
  10703. 9000    FORMAT(128A1)
  10704.     IF(PZAP.EQ.0)CALL UVT100(13,0,0)
  10705. C NOTE THIS REDRAWS PREVIOUS COL. IN REVERSE VIDEO.
  10706. C NO CARRIAGE CTL
  10707. 200    CONTINUE
  10708.     IF(PZAP.NE.0)GOTO 3608
  10709.     KKKK=JCHAR(FVLDTP)
  10710. C SKIP LAST LINE UPDATE IF NOT NEEDED FOR SPEEDIER CURSOR
  10711. C POSITIONING.
  10712.     IF(NULAST.EQ.NCEL.AND.LFVD.EQ.0.AND.KKKK.EQ.0)GOTO 222
  10713.     CALL UVT100(1,LLDSP,1)
  10714.     CALL UVT100(12,2,0)
  10715.     IF(JCHAR(FORM(1)).LE.0)GOTO 222
  10716.     DO 1711 IVVVV=1,109
  10717.         IVV=110-IVVVV
  10718.     IF(JCHAR(FORM(IVV)).GT.32)GOTO 2711
  10719. 1711    CONTINUE
  10720. 2711    CONTINUE
  10721.     write(fwt(1:127),9092)ncel,(form(ii),ii=1,IVV)
  10722. 9092    FORMAT(1X,I5,' Used. Curr=',109A1)
  10723.     IVV=IVV+18
  10724.     call swrt(fwt(1:127),IVV)
  10725. C3608    CONTINUE
  10726. 222    CALL UVT100(1,LLCMD,1)
  10727.     NULAST=NCEL
  10728.     LFVD=KKKK
  10729.     CALL UVT100(12,2,0)
  10730. C NOTE PROW IS ACROSS TOP, PCOL IS DOWN SIDE
  10731. C PROW GOES AS ID1, ALPHAS
  10732. C PCOL GOES AS ID2, NUMERICS
  10733.     CALL IN2AS(PROW,FORM)
  10734. C NOTE PCOL STARTS AT 2 FOR NORMAL SHEET VARIABLES. PCOL=1 IS FOR ACCUMULATORS
  10735.     CALL UVT100(13,0,0)
  10736. C WRITE OUT LABEL WITH APPROPRIATE SIZE TO HOLD ROW NUMBER
  10737. C LET PROMPT END WITH > OR : DEPENDING ON OPERATING MODE.
  10738.     FVLDTP='>'
  10739.     IF(MODPUB.EQ.1)FVLDTP=':'
  10740.     IF(PCOL.GE.10000)GOTO 6401
  10741.     ii=pcol-1
  10742.     write(fwt(1:127),9001,err=3608)
  10743.      1   (form(i),i=1,4),ii,FVLDTP
  10744. C    FORM(9)=FVLDTP
  10745.     III=9
  10746.     GOTO 6402
  10747. 6401    CONTINUE
  10748.     ii=pcol-1
  10749.     write(fwt(1:127),9401,err=3608)
  10750.      1   (form(i),i=1,4),ii,FVLDTP
  10751. C    FORM(10)=FVLDTP
  10752.     III=10
  10753. 6402    CONTINUE
  10754.     CALL SWRT(fwt(1:127),III)
  10755. 9401    FORMAT(4A1,I5,1A1)
  10756. 9001    FORMAT(4A1,I4,1A1)
  10757. 3608    CONTINUE
  10758.     IF(XTCFG.NE.0)GOTO 3870
  10759.     Rewind 11
  10760.     IF(IOLVL.NE.11.or.FH.eq.0)READ(IOLVL,9002,END=510,ERR=510)CMDLIN
  10761. C FOR READING THE CONSOLE, WE NEED A QIO$ TO CAPTURE ESCAPE SEQUENCES.
  10762.     IF(IOLVL.EQ.11.and.FH.ne.0)CALL GETTTL(CMDLIN)
  10763.     CALL GTMUNG(CMDLIN)
  10764. C ALLOW CMD LANGUAGE TO LOOK MORE "STANDARD" VIA MUNGE OF INPUTS
  10765. C TO DO THE "EV" OR "ET" OR "EN" FOR USER AND TREAT / AS CMD
  10766. C PREFIX...
  10767.     GOTO 3871
  10768. 3870    CONTINUE
  10769.     XTCFG=0
  10770.     DO 3872 I=1,XTNCNT
  10771.     CMDLIN(I)=XTNCMD(I)
  10772. 3872    CONTINUE
  10773. C COPY IN EXTERNAL COMMAND AND LET IT BE EXECUTED. IT'S THE USER'S
  10774. C PROBLEM IF THE COMMAND REQUIRES STILL FURTHER INPUT...
  10775. C ALSO NULL OUT SOME DELIMITER CHARS AFTER THE COMMAND READ IN.
  10776.     CMDLIN(XTNCNT+1)=Char(0)
  10777.     CMDLIN(XTNCNT+2)=Char(0)
  10778. 3871    CONTINUE
  10779. 9002    FORMAT(64A1,64A1,32A1)
  10780.     CMDLIN(132)=Char(0)
  10781.     CMDLIN(131)=Char(0)
  10782.     CMDLIN(130)=Char(0)
  10783. C  SAVE CURRENT PHYS ROW, COL IN AC'S X AND Y
  10784.     XXAC=PROW
  10785.     XYAC=PCOL
  10786. C ZAP IN SPECIAL FUNCTION KEY REPLIES INTO NORMAL FORMS
  10787.     CALL CMDMUN(CMDLIN)
  10788.     DO 9048 I=1,129
  10789.     K=130-I
  10790. C START AT BACK OF LINE AND ZAP WHITESPACE BY NULL TERMINATOR
  10791.     IF(ICHAR(CMDLIN(K)).GT.32)GOTO 9049
  10792.     CMDLIN(K)=Char(0)
  10793. C ALSO GET RID OF POSSIBLE TRAILING CR, LF.
  10794. 9048    CONTINUE
  10795. 9049    CONTINUE
  10796. C
  10797. C THIS GETS COMMAND LINE IN. NOW ACTON IT.
  10798. C REPOS'N TO OLD LINE NOW.
  10799.     CALL UVT100(1,LLCMD,1)
  10800. C
  10801. C THE FOLLOWING SECTION IMPLEMENTS THE ADDITIONAL FUNCTION OF
  10802. C JOURNALING: (DONE ON VAX ONLY SINCE SPACE REQUIREMENTS FOR FILE
  10803. C OPERATIONS MAY BE A PROBLEM ON PDP11'S).
  10804. C    Command +J FILENAME will record all remaining
  10805. C    line inputs at this point in it. (Assumes JNLFLG=0 initially)
  10806. C    Command +N closes journal file.
  10807.     K=K+1
  10808.     IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'J'.AND.JNLFLG.NE.1)
  10809.      1   GOTO 4290
  10810.     IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'N')GOTO 4292
  10811.     IF(JNLFLG.EQ.1)WRITE(10,9002)(CMDLIN(IV),IV=1,K)
  10812.     GOTO 4291
  10813. 4292    CONTINUE
  10814.     CLOSE(10)
  10815.     JNLFLG=0
  10816.     GOTO 9990
  10817. 4290    CONTINUE
  10818.     JNLFLG=1
  10819. C    USE WHATEVER FILE NAME THE USER HAS SUPPLIED AFTER THE +J
  10820. C    FOR FILE TO JOURNAL ONTO. (NO MORE QUESTIONS NEEDED.)
  10821.     CALL WASSIG(10,CMDLIN(4))
  10822.     GOTO 9990
  10823. 4291    CONTINUE
  10824. C
  10825. C
  10826. C ALLOW COMMENTS IF LINE BEGINS WITH * (JUST LIKE CALC)
  10827.     IF(CMDLIN(1).NE.'*')GOTO 6002
  10828.     ICODE=1
  10829. C NO RECALC JUST FOR COMMENTS...
  10830.     GOTO 9990
  10831. 6002    CONTINUE
  10832. C
  10833. C * NEW ****************
  10834. C ADD PLACE TO PUT IN USER COMMANDS. DEFAULT IS NONE EXIST, DO NOTHING
  10835.     IGOTIT=0
  10836.     CALL USRCMD(CMDLIN,ICODE,IGOTIT)
  10837. C WHEN WE GET A COMMAND, SET IGOTIT TO 1 AND WE THEN PROCESS COMMAND NORMALLY
  10838.     IF(IGOTIT.EQ.1)GOTO 9990
  10839. C * NEW ****************
  10840. C
  10841. C COMMAND -PROMPT  WILL READ FROM LUN 5 TO ARGSTR
  10842. C TERMINATING WITH SPACES.
  10843.     IF(CMDLIN(1).NE.'-')GOTO 350
  10844.     ICODE=5
  10845.     CALL UVT100(1,LLCMD,1)
  10846.     CALL UVT100(12,2,0)
  10847.     CALL VWRT(CMDLIN(2),49)
  10848. C    WRITE(0,9800)(CMDLIN(IV),IV=2,50)
  10849.     call vget(form2,128)
  10850. c    READ(11,9000,END=510,ERR=510)FORM2
  10851.     II=1
  10852.     KK=1
  10853.     DO 351 KKK=1,128
  10854. C LOAD UP OUR ARGUMENTS IN ARGSTR(N,1) TO ARGSTR(N,4)
  10855.     ARGSTR(KK,II)=FORM2(KKK)
  10856.     KK=KK+1
  10857.     ARGSTR(KK,II)=char(0)
  10858.     IF(KK.LT.52)GOTO 352
  10859. 354    KK=1
  10860.     II=II+1
  10861.     IF(II.GT.4)GOTO 353
  10862. 352    CONTINUE
  10863.     IF(ICHAR(FORM2(KKK)).GT.32)GOTO 351
  10864. C ON SPACE, GO TO THE NEXT ARGUMENT. ALSO SPILL INTO
  10865. C THE NEXT ARGUMENT IF WE SEE NO SPACES AND JUST TRAIL ALONG.
  10866.     GOTO 354
  10867. 351    CONTINUE
  10868. 353    GOTO 9990
  10869. 350    CONTINUE
  10870. C
  10871. C CONTROL SCROLLING. PERMIT THE COMMAND "SC" TO TURN SCROLLING ON
  10872. C AND "NS" TO TURN IT BACK OFF.
  10873.     IVV=-1
  10874.     IF(CMDLIN(1).EQ.'S'.AND.CMDLIN(2).EQ.'C')IVV=1
  10875.     IF(CMDLIN(1).EQ.'N'.AND.CMDLIN(2).EQ.'S')IVV=0
  10876.     IF(IVV.GE.0)IDOL7=IVV
  10877.     IF(IVV.GE.0)ICODE=5
  10878.     IF(IVV.GE.0)GOTO 9990
  10879. C
  10880. C ALLOW PROGRAMMED "REWIND" OF INPUT COMMAND LINE ON
  10881. C COMMAND LINE BEGINNING WITH "<". MAKE IT CONDITIONAL
  10882. C BY SAYING THAT IF % IS NEGATIVE WE WON'T DO IT.
  10883.     IF(CMDLIN(1).NE.'<')GOTO 356
  10884.     ICODE=5
  10885.     IF(XAC.GT.0..AND.IOLVL.NE.11)REWIND IOLVL
  10886.     GOTO 9990
  10887. 356    CONTINUE
  10888. C
  10889. C HANDLE @FILE COMAND TO CHANGE TO INPUT OFF THAT FILE.
  10890.     IF(CMDLIN(1).NE.'@')GOTO 511
  10891. C WOW, A FILE. (OR AT LEAST SO WE HOPE).
  10892.     CALL RASSIG(3,CMDLIN(2),kkkk)
  10893.     if(kkkk.ne.0)goto 498
  10894. C USE FACT THAT WE JUST NULL TERMINATED THE FILENAME PART AND SET
  10895. C IT TO BE LUN 3.
  10896.     IOLVL=3
  10897. C NOW GO BACK FOR ANOTHER COMMAND...NO SENSE WASTING RECALC TIME SINCE
  10898. C NOTHING HAS REALLY HAPPENED YET.
  10899. C NOTE EVERY READ TO LUN 3 HAS EOF/ERROR CHECK TO GO TO 510 TO RESET
  10900. C TO LUN 5 INPUT AND CLOSE FILE WE OPENED ON 3.
  10901.     GOTO 498
  10902. 511    CONTINUE
  10903. C
  10904. C AA n R, AA n C, AR n R, AR n C COMMANDS
  10905. C
  10906.     IF(CMDLIN(1).NE.'O'.OR.CMDLIN(2).NE.'V')GOTO 6887
  10907. C OV + TURNS ON OVERRIDE
  10908. C OV - TURNS OFF OVERRIDE
  10909. C ALLOWS ONE TO OVERRIDE $ SIGN FORMS' ABSOLUTE NATURE
  10910.     IF(CMDLIN(3).EQ.'+'.OR.CMDLIN(4).EQ.'+')IDOL3=1
  10911.     IF(CMDLIN(3).EQ.'-'.OR.CMDLIN(4).EQ.'-')IDOL3=0
  10912.     GOTO 9990
  10913. 6887    CONTINUE
  10914.     IF(CMDLIN(1).NE.'A')GOTO 8845
  10915. C ADD ROWS OR COLUMNS (OR REMOVE THEM) AT THE CURRENT PHYSICAL LOCATION
  10916. C WHERE AA MEANS ADD ABSOLUTE (NO RELOCATION), AR MEANS ADD RELOCATING
  10917. C (RELOCATE ALL VARIABLES BELOW), AND R OR C SAYS TO ADD/SEBTRACT ROWS
  10918. C OR COLUMNS.
  10919. C
  10920. C FIRST COLLECT THE ARGUMENTS TO THE FUNCTION.
  10921.     KM1=3
  10922.     KM2=10
  10923.     CALL GN(KM1,KM2,ICNT,CMDLIN)
  10924. C GETS THE NUMBER. IF NO NUMBER SEEN OR ZERO, RETURNS 0. IGNORE THEN.
  10925.     IF(ICNT.EQ.0)GOTO 9990
  10926.     ICR=0
  10927. C LOOK FOR THE R OR C
  10928. C START AT CMDLIN(4) TO PASS THE AR/AA AND THE NUMBER IF ANY.
  10929.     DO 8844 KKK=4,50
  10930.     IF(CMDLIN(KKK).EQ.'R')ICR=1
  10931.     IF(CMDLIN(KKK).EQ.'C')ICR=2
  10932.     IF(ICR.NE.0)GOTO 8846
  10933. C SKIP OUT ON FIRST ROW OR COLUMN DESIGNATOR SEEN
  10934. 8844    CONTINUE
  10935. 8846    CONTINUE
  10936.     IF(ICR.EQ.0)GOTO 9990
  10937.     ICODE=2
  10938. C NOW WE HAVE ALL ARGUMENTS. SET UP FOR THE COPY AND PARASITE THE
  10939. C LOGIC USED FOR THE CA OR CR COMMANDS. (NOTE THAT 2ND CHARACTER
  10940. C IS A OR R IN CMDLIN ALREADY SO THOSE COMMANDS' LOGIC WILL BE OK.)
  10941.     JRTR=PROW
  10942.     JRTC=PCOL
  10943.     IF(ICR.EQ.2)JRTC=1
  10944.     IF(ICR.EQ.1)JRTR=1
  10945. C RELOC THESHOLD IS PHYSICAL CURRENT POSITION.
  10946.     IF(ICR.EQ.1)GOTO 8843
  10947. C INSERT OR DELETE COLUMNS
  10948. C FIRST FIGURE OUT HOW MANY COLUMNS MUST BE MOVED RIGHT
  10949.     KD=MCols-PROW-IABS(ICNT)+1
  10950. C LET THIS WORK ONLY ON PRIME SHEET. TOO HARD TO FIGURE IT OUT ON REFLECTED
  10951. C ONES AND IT'LL FOUL LOTS OF USERS UP.
  10952.     IF(KD.LE.0)GOTO 9990
  10953. C CAN'T MOVE 0 COLUMNS. DOESN'T MAKE SENSE.
  10954.     DO 8842 KR=1,KD
  10955.     IRA=MCols-KR+1
  10956. C IRA IS DESTINATION COLUMN IN EACH LOOP.
  10957.     IF(ICNT.LT.0)IRA=PROW-1+KR
  10958. C IRS IS SOURCE COLUMN
  10959.     IRS=MCols-KR+1-ICNT
  10960.     IF(ICNT.LT.0)IRS=PROW+KR-ICNT-1
  10961. C
  10962. C IF DELETING COLUMNS AND DESTINATION IS PAST CURRENT
  10963. C ACTIVE MAX, SKIP THE MOVE SINCE WE'RE NOT ACCOMPLISHING ANYTHING.
  10964.     IF(ICNT.LT.0.AND.IRA.GT.RRWACT)GOTO 8842
  10965. C IF ADDING COLUMNS AND SOURCE IS PAST CURRENT MAX ACTIVE THEN
  10966. C WE'RE DOING NOTHING, SO SKIP THE WORK
  10967.     IF(ICNT.GT.0.AND.IRS.GT.RRWACT)GOTO 8842
  10968.     JDELT=RCLACT
  10969. C    JDELT=301
  10970. C LOOP WE'LL CALL IS OVER ENTIRE ROWS, BUT ONLY DO ONE AT A TIME HERE
  10971.     JD1A=IRA
  10972.     JD1B=1
  10973.     ID1A=IRS
  10974.     ID2A=1
  10975.     I1IN=0
  10976.     I2IN=1
  10977.     JIN1=0
  10978.     JIN2=1
  10979.     ASSIGN 8840 TO KPYBAK
  10980. C CALL INTERNAL COPY-RANGE PROCEDURE INSIDE CA/CR LOGIC
  10981.     GOTO 8364
  10982. 8840    CONTINUE
  10983. 8842    CONTINUE
  10984. C
  10985. C NOW CLEAN UP THE REST OF FORMULAS IF THERE ARE ANY TO DO...
  10986. C MUST RELOCATE OTHER FORMULAE IF CMDLIN(2) IS R
  10987.     KX=PROW-1
  10988. C RELY ON RCLACT HAVING BEEN UPDATED TO REFLECT NEW
  10989. C ADDITIONS IF ANY
  10990.     KY=RCLACT
  10991. C    KY=301
  10992. C RELOCATE UPPER LEFT PART OF SHEET
  10993. C NOTE II1,II2,JJ1,JJ2,JRTR,JRTC ARE UNCHANGED FROM PRIOR CALL SO
  10994. C MAY BE USED... RELVBL ONLY CARES ABOUT RELATIVE MOTION ANYHOW...
  10995. 3600    CONTINUE
  10996.     IF(CMDLIN(2).NE.'R'.OR.KX.LE.0.OR.KY.LE.0)GOTO 9990
  10997.     DO 3601 KK=1,KX
  10998.     DO 3601 KK2=1,KY
  10999.     CALL FVLDGT(KK,KK2,FVLD(1,1))
  11000.     IF(ICHAR(FVLD(1,1)).NE.1)GOTO 3601
  11001. C ONLY RELOCATE FORMULAS, NOT TEXT OR NUMBERS (OR EMPTIES...)
  11002. C    IRX=(KK2-1)*60+KK
  11003.     CALL REFLEC(KK2,KK,IRX)
  11004.     CALL WRKFIL(IRX,FORM,0)
  11005. C    READ(7'IRX)FORM
  11006.     CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
  11007.     CALL WRKFIL(IRX,FORM2,1)
  11008. C    WRITE(7'IRX)FORM2
  11009. 3601    CONTINUE
  11010.     GOTO 9990
  11011. 8843    CONTINUE
  11012. C ROW INSERT/DELETE
  11013. C AGAIN FIND HOW MANY ROWS TO MOVE.
  11014.     KD=MRows-PCOL-IABS(ICNT)+1
  11015.     IF(KD.LE.0)GOTO 9990
  11016.     DO 8839 KC=1,KD
  11017. C ICA = DESTINATION AND ICS IS SOURCE
  11018.     ICA=MRows-KC+1
  11019.     ICS=MRows-KC+1-ICNT
  11020.     IF(ICNT.GT.0)GOTO 8838
  11021.     ICA=PCOL-1+KC
  11022.     ICS=PCOL+KC-1-ICNT
  11023. 8838    CONTINUE
  11024. C IF INSERTING ROWS AND SRC ROW IS BEYOND ACTIVE AREA, SKIP
  11025.     IF(ICNT.GT.0.AND.ICS.GT.RCLACT)GOTO 8839
  11026. C IF DELETING ROWS AND DST ROW IS BEYOND ACTIVE AREA, SKIP
  11027.     IF(ICNT.LT.0.AND.ICA.GT.RCLACT)GOTO 8839
  11028. C NOW CALL COPY LOOP AGAIN.
  11029.     JDELT=RRWACT
  11030. C    JDELT=60
  11031.     JD1A=1
  11032.     JD1B=ICA
  11033. C DEST
  11034.     ID1A=1
  11035.     ID2A=ICS
  11036. C SOURCE
  11037.     I1IN=1
  11038.     I2IN=0
  11039.     JIN1=1
  11040.     JIN2=0
  11041.     ASSIGN 8836 TO KPYBAK
  11042. C CALL INTERNAL RANGE COPY PROCEDURE TO COPY A ROW
  11043.     GOTO 8364
  11044. 8836    CONTINUE
  11045. 8839    CONTINUE
  11046.     KX=RRWACT
  11047. C    KX=60
  11048.     KY=PCOL-1
  11049.     GOTO 3600
  11050. 8845    CONTINUE
  11051. C OA AND OR COMMANDS. SET DISPLAY SHEET MAPPING TO ORIGIN AS FOUND BY
  11052. C  VARIABLE, STARTING AT 1,1 OR (DROW,DCOL) FOR OA AND OR RESPECTIVELY.
  11053.     IF(CMDLIN(1).NE.'O')GOTO 650
  11054. C PROCESS COMMAND...
  11055.     LRO=1
  11056.     LCO=1
  11057.     IF(CMDLIN(2).EQ.'R')LRO=MAX0(1,DROW)
  11058.     IF(CMDLIN(2).EQ.'R')LCO=MAX0(1,DCOL)
  11059. C OM will act like OR in that it will set the mapping of a
  11060. C display starting at the cursor, but unlike OR it will
  11061. C map multiple pages. When 3D actions are disabled it will
  11062. C do nothing.
  11063.     KORM=0
  11064.     IF(CMDLIN(3).NE.'M')GOTO 3944
  11065.     IF(K3DFG.LE.0)GOTO 3924
  11066. C OAMC/ORMC cell remaps display so that each display column is
  11067. C a column from the next lower sheet, so that, for example,
  11068. C a first column might be a1:a20, the next might be a1%1:a20%1,
  11069. C the next a1%2:a20%2 and so on.
  11070. C
  11071. C OAMR/ORMR cell remaps display so that each display row is a row
  11072. C from the next lower sheet, so that for example the first
  11073. C row might be a1:g1, the next a1%1:g1%1, the next a1%2:g1%2
  11074. C and so on. 
  11075. C
  11076. C  Thus the operation ORMC fills the 1st column with the current
  11077. C sheet, then the next with the offsets of the first plus the
  11078. C sheet offset, and so on. ORMR fills the 1st row with the
  11079. C current sheet, then sheet offsets down.
  11080.     IF(CMDLIN(4).EQ.'C')KORM=1
  11081.     IF(CMDLIN(4).EQ.'R')KORM=2
  11082.     IF(KORM.EQ.0)GOTO 3924
  11083. 3944    CONTINUE
  11084. c *** 20 by 75 display constants hardcoded here:
  11085.     LRO=MIN0(LRO,(JIDcl-1))
  11086.     LCO=MIN0(LCO,(JIDrw-1))
  11087. C    LRO=MIN0(LRO,(20-1))
  11088. C    LCO=MIN0(LCO,(75-1))
  11089. C NOW HAVE CORRECT ORIGIN IN DISPLAY SHEET TO USE SET UP.
  11090. C GRAB VARIABLE ID.
  11091.     LA=INDX(CMDLIN,32)
  11092.     IF(LA.GT.20)LA=3
  11093.     LE=40
  11094.     CALL VARSCN(CMDLIN,LA,LE,LSTCX,ID1,ID2,IVLD)
  11095.     IF(IVLD.EQ.0)GOTO 651
  11096. C NOW HAVE VARIABLE NAME AND LOCATION... CAN DO IT FINALLY.
  11097. C NOTE WE'RE GUARANTEED WE START OFF IN BOUNDS BUT MUST CHECK
  11098. C ALONG THE WAY TO BE SURE WE STAY THAT WAY.
  11099.     IQQ=0
  11100.     KKKK=0
  11101. C allow a D modifier (for whatever it's worth) after
  11102. C the ORMR/ORMC/OAMR/OAMC commands. It will be as close to
  11103. C the normal OAD/ORD as practical under the circumstances of
  11104. C a totally different mapping scheme.
  11105.     IF(KORM.NE.0.and.CMDLIN(5).eq.'D')KKKK=1
  11106.     IF(CMDLIN(3).NE.'D')GOTO 6712
  11107. c allow ORA or ORD commands to leave window displacements
  11108. c alone. Fix up so this is default mode for scrolling (making
  11109. c program behavior easier to understand.)
  11110. 7112    CONTINUE
  11111.     KKKK=1
  11112. 6712    CONTINUE
  11113.     KKKKK=NRDSP(LRO,LCO)
  11114.     KKKKKK=NCDSP(LRO,LCO)
  11115. 5711    CONTINUE
  11116. C TO ALLOW REFLECTIONS MUST ALLOW ALL SORTS OF ORIGINS.
  11117.     DO 652 IRO=LRO,DRWV
  11118.     DO 653 ICO=LCO,DCLV
  11119. C HERE CAN SET UP NRDSP AND NCDSP SUITABLY
  11120.     IVV=IRO-LRO
  11121.     IVVV=ICO-LCO
  11122.     IF(KKKK.EQ.0)GOTO 1653
  11123.     IVV=NRDSP(IRO,ICO)-KKKKK
  11124.     IVVV=NCDSP(IRO,ICO)-KKKKKK
  11125. 1653    CONTINUE
  11126.     if(korm.ne.1)goto 2653
  11127. C OMC column mode remap.
  11128. C Bump offsets by kcdelt/krdelt as iro grows BUT
  11129. C not as ico grows.
  11130.     IVV=(LRO-1)+(iro-lro)*kcdelt
  11131.     IVVV=IVVV+(iro-lro)*krdelt
  11132. 2653    Continue
  11133.     if(korm.ne.2)goto 2654
  11134. C OMR row mode remap.
  11135. C bump offsets by kcdelt/krdelt as ico grows BUT not as
  11136. C iro grows.
  11137.     IVV=IVV+(ico-lco)*kcdelt
  11138.     IVVV=(LCO-1)+(ico-lco)*krdelt
  11139. 2654    Continue
  11140.     NRDSP(IRO,ICO)=ID1+IVV
  11141.     NCDSP(IRO,ICO)=ID2+IVVV
  11142. 653    CONTINUE
  11143. 652    CONTINUE
  11144.     IF(DROW.LE.0.OR.DCOL.LE.0)GOTO 3924
  11145.     PROW=NRDSP(DROW,DCOL)
  11146.     PCOL=NCDSP(DROW,DCOL)
  11147. 3924    CONTINUE
  11148. C FORCE REDRAW OF WHOLE SHEET.
  11149.     ICODE=6
  11150.     IF(RCMODE.LE.0)GOTO 9990
  11151. C SKIP RECALC IF IN OLD MODE...
  11152.     ICODE=2
  11153. 651    GOTO 9990
  11154. 650    CONTINUE
  11155. C F FILENAME/NNN
  11156. C READ IN TEXT FROM FILE NAMED AND SPREAD ACROSS DISPLAY SCREEN. SET
  11157. C DISPLAYED SCREEN INTO FVLD(NN)=-1 TO SHOW TEXT ONLY.
  11158.     IF(CMDLIN(1).NE.'F')GOTO 1740
  11159.     LA=INDX(CMDLIN,32)
  11160. C PASS SPACE
  11161.     KKK=ICHAR('/')
  11162.     LB=INDX(CMDLIN(LA+1),KKK)
  11163.     LB=LB+LA
  11164. C LB= LOC OF / CHARACTER
  11165.     LB=MIN0(80,LB)
  11166.     IF(LB.LE.2)GOTO 1741
  11167.     IF((LB-LA).LE.1) GOTO 1741
  11168.     CMDLIN(LB)=char(0)
  11169.     CALL RASSIG(4,CMDLIN(LA+1),kkkk)
  11170.     if(kkkk.ne.0)goto 1742
  11171. C THIS OUGHT TO OPEN THE FILE IF IT EXISTS..
  11172. C NOW IF THERE'S A NUMBER THERE, EXTRACT IT.
  11173.     LSKP=0
  11174.     IF(LB.GT.78.OR.LB.LE.5)GOTO 1743
  11175.     LAA=LB+1
  11176.     LAAA=LB+7
  11177.     CALL GN(LAA,LAAA,LSKP,CMDLIN)
  11178. 1743    CONTINUE
  11179. C NOW SKIP THE LINES
  11180.     IF(LSKP.LE.0)GOTO 1744
  11181.     DO 1745 IV=1,LSKP
  11182.     READ(4,8201,END=1742,ERR=1742)FORM2
  11183. 1745    CONTINUE
  11184. 1744    CONTINUE
  11185. C NOW WE'RE READY TO READ IN THE STUFF.
  11186.     ICODE=2
  11187.     DO 1746 LA=1,DCLV
  11188.     DO 1751 IV=1,128
  11189. 1751    FORM2(IV)=Char(32)
  11190.     READ(4,8201,END=1742,ERR=1742)FORM2
  11191.     IXC=0
  11192.     DO 1747 LB=1,DRWV
  11193. C DRWV = # ACROSS TOP...
  11194. C DCLV=LENGTH
  11195.     ID1=NRDSP(LB,LA)
  11196.     ID2=NCDSP(LB,LA)
  11197. C GET PHYSICAL SHEET COORDINATES AS ID1,ID2
  11198. C MUST THEN COPY CWIDS(LB) CHARS ONTO FILE...
  11199.     CALL FVLDST(ID1,ID2,char(255))
  11200. C    FVLD(ID1,ID2)=-1
  11201. C    IRX=(ID2-1)*60+ID1
  11202.     CALL REFLEC(ID2,ID1,IRX)
  11203.  
  11204.     CALL WRKFIL(IRX,FORM,0)
  11205. C    READ(7'IRX)FORM
  11206.     FORM(119)=Char(255)
  11207.     DO 1749 IVV=1,110
  11208. 1749    FORM(IVV)=char(0)
  11209.     DO 1748 IVV=1,CWIDS(LB)
  11210.     IXC=IXC+1
  11211. 1748    FORM(IVV)=FORM2(IXC)
  11212.     CALL WRKFIL(IRX,FORM,1)
  11213. 1747    CONTINUE
  11214. 1746    CONTINUE
  11215. 1742    CLOSE(4)
  11216. 1741    GOTO 9990
  11217. 1740    CONTINUE
  11218.     IF(CMDLIN(1).NE.'E')GOTO 8000
  11219. C ENTER COMMAND
  11220. C EN expression. expression may be numbers/text.
  11221.     LA=INDX(CMDLIN,32)
  11222.     LA=LA+1
  11223. C SKIP SPACE AFTER "EN"
  11224.     IF(LA.GT.4)LA=4
  11225.     IF (LA.GE.100)GOTO 7901
  11226.     LE=132-LA
  11227.     LE=MIN0(110,LE)
  11228. C    IRX=(PCOL-1)*60+PROW
  11229.     CALL REFLEC(PCOL,PROW,IRX)
  11230. C FIND WHERE IN FILE TO STORE.
  11231.     CALL WRKFIL(IRX,FORM2,0)
  11232.     CALL CE2A(FORM2,FORM)
  11233. C    READ(7'IRX)FORM
  11234.     IF(CMDLIN(2).EQ.'D')
  11235.      1   CALL SED(CMDLIN(LA),FORM,FORM2,ARGSTR,ZAC,110)
  11236. C IF COMMAND IS "ED <DELIM>STRING1<DELIM>STRING2<DELIM>" THEN
  11237. C  SUBSTITUTE STRING2 FOR STRING1 IN FORMULA, RETURN IT TO THE
  11238. C  COMMAND LINE, AND REENTER IT.
  11239. C  NOTE THAT THE STRINGS MAY CONTAIN &n FORMS WHERE 1-4 MEAN
  11240. C  ENTERED ARGUMENTS 1-4, 5 TREATS XAC AS A NUMBER, AND 6
  11241. C  TREATS ZAC AS A SINGLE CHARACTER (ZAC IS VARIABLE Z).
  11242.     DO 5133 II=1,110
  11243. 5133    FORM(II)=char(0)
  11244.     NALF=0
  11245.     NSG=-1
  11246.     NXNUM=3
  11247.     KSG=0
  11248.     N=1
  11249.     IRCE1=PROW
  11250.     IRCE2=PCOL
  11251. C SAVE FOR RE, RI MODES
  11252.     IF(CMDLIN(2).EQ.'T'.OR.CMDLIN(2).EQ.'"')KSG=1
  11253. C "ET" FORMULA ENTERS TEXT ONLY
  11254. C "EV" FORMULA ENTERS NUMBER
  11255.     IF(CMDLIN(2).EQ.'V')NSG=1
  11256. 2097    CONTINUE
  11257.     IF(N.GT.LE)GOTO 7902
  11258. C    DO 7902 N=1,LE
  11259. C LOOK FOR ALPHAS. IF WE FIND ANY, FLAG NOT NUMERIC
  11260. C NOTE @ INCLUDED SINCE COULD HAVE A *@3 COMMAND TO CALL 3.CMD
  11261. C AND REFER TO OTHER CELLS.
  11262. C THIS IS A RESTRICTION: COMMANDS TO CMND NEED TO HAVE ALPHAS
  11263. C SOMEWHERE OR THIS WILL BE FOOLED.
  11264.     IF(CMDLIN(LA).EQ.'P'.AND.
  11265.      1  CMDLIN(LA+1).EQ.'#'.AND.
  11266.      2  CMDLIN(LA+2).EQ.'0'.AND.
  11267.      3  CMDLIN(LA+3).EQ.'#'.AND.
  11268.      4  CMDLIN(LA+4).EQ.'0') GOTO 3356
  11269.     IF(ICHAR(CMDLIN(LA)).GE.ICHAR('@').AND.ICHAR(CMDLIN(LA))
  11270.      1  .LE.ICHAR('Z'))NXNUM=1
  11271. 3356    CONTINUE
  11272.     IF(CMDLIN(LA).EQ.'+'.OR.CMDLIN(LA).EQ.'-')NSG=1
  11273.     IF(CMDLIN(LA).EQ.'['.OR.CMDLIN(LA).EQ.'.')NSG=1
  11274.     IF(CMDLIN(LA).EQ.'(')NSG=1
  11275.     IF(CMDLIN(LA).EQ.'"')KSG=1
  11276. C ON SEEING THE _@V1,V2 CONSTRUCT, REPLACE WITH THE VARIABLE
  11277. C ADDRESSED BY V1,V2 (COL,ROW) BY NAME.
  11278. C ON SEEING THE _#V1 CONSTRUCT, UNPACK UP TO 8 CHARS OUT OF
  11279. C REAL*8 VARIABLE (PACKED BY MULTIPLYING BY 128 EARLIER).
  11280. C  IN EACH CASE, ADJUSTN AND LE TO CONTINUE APPROPRIATELY.
  11281.     IF(ICHAR(CMDLIN(LA)).GT.32)NALF=NALF+1
  11282.     IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'@')CALL
  11283.      1  SVBL(CMDLIN,LA,N,LE,FORM)
  11284.     IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'#')CALL
  11285.      1  SSTR(CMDLIN,LA,N,LE,FORM)
  11286.     FORM(N)=CMDLIN(LA)
  11287.     LA=LA+1
  11288. C FAKE OUT DO LOOP SINCE SVBL OR SSTR MAY MUNG INDICES INSIDE IT
  11289.     N=N+1
  11290.     GOTO 2097
  11291. 7902    CONTINUE
  11292.     IF(KSG.NE.0)NSG=-1
  11293.     FORM(110)=char(0)
  11294.     IF(ICHAR(FORM(119)).NE.0)GOTO 7903
  11295. C LEAVE DISPLAY INDICATOR ALONE IF SET BUT SET VBL OTHERWISE.
  11296.     IVVVV=NSG*NXNUM
  11297.     FORM(119)=CHAR(IVVVV)
  11298. C SET NEG FOR DISPLAY OF FORMULA, NOT NUMBER. ALLOWS TEXT ENTRY.
  11299. C ASSUME FORMULA IF WE SEE + OR -
  11300. 7903    CONTINUE
  11301. C FORCE FORM TO FOLLOW EDITS EVEN IF FORMAT/TYPE PRESET.
  11302.     IVVVV=JCHAR(FORM(119))
  11303.     IF(IVVVV.NE.0)FORM(119)=CHAR(ISGN(IVVVV)*NXNUM)
  11304.     IF(NALF.LE.0)GOTO 6221
  11305.     CALL FVLDST(PROW,PCOL,FORM(119))
  11306. C ENCODE CELL NAMES PRIOR TO STORING
  11307.     CALL CA2E(FORM,FORM2)
  11308.     CALL WRKFIL(IRX,FORM2,1)
  11309. 6221    CONTINUE
  11310.     ASSIGN 7904 TO NBK
  11311.     GOTO 7905
  11312. C LOOK UP PROW, PCOL, LEAVE DISPLAY COORDS IN LR,LC
  11313. 7905    CONTINUE
  11314.     DO 7906 LA1=1,DRWV
  11315.     LR=LA1
  11316.     DO 7906 LA2=1,DCLV
  11317.     LC=LA2
  11318.     IF(NRDSP(LA1,LA2).EQ.PROW.AND.NCDSP(LA1,LA2).EQ.PCOL)GOTO7907
  11319. 7906    CONTINUE
  11320. C IF WE FALL OUT OF THE LOOP, WE DIDN'T FIND THE LOC; FLAG BY PUTTING 0'S.
  11321.     LR=0
  11322.     LC=0
  11323.     GOTO 7908
  11324. 7907    CONTINUE
  11325. C ARRIVE HERE ON SUCCESS. LR, LC ALL SET UP.
  11326. 7908    CONTINUE
  11327.     GOTO NBK,(7904,8901,8957)
  11328. 7904    CONTINUE
  11329.     IF(LR.EQ.0.OR.LC.EQ.0)GOTO 7901
  11330.     THISRW=LR
  11331.     THISCL=LC
  11332. C    ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
  11333.     LRO=1
  11334.     LCO=1
  11335.     ID1=NRDSP(1,1)
  11336.     ID2=NCDSP(1,1)
  11337.     IF(.NOT.(JMVFG.EQ.51.AND.THISRW.EQ.1))GOTO 7110
  11338. C MUST SCROLL LEFT
  11339.     IF(IDOL7.EQ.0)GOTO 7110
  11340.     IF(ID1.LE.1)GOTO 7110
  11341.     ID1=MAX0(1,ID1-DRWV+2)
  11342.     DROW=MAX0(1,DRWV-2)
  11343.     IQQ=1
  11344.     GOTO 7112
  11345. 7110    CONTINUE
  11346.     IF(JMVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
  11347.     IF(.NOT.(JMVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 7116
  11348. C MUST SCROLL RIGHT
  11349.     IF(IDOL7.EQ.0)GOTO 7116
  11350.     DROW=3
  11351. C    ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
  11352.     ID1=ID1+DRWV-MIN0(DRWV,2)
  11353.     IQQ=1
  11354.     GOTO 7112
  11355. C 7112 FAKES OUT OA CALL TO SCROLL OVER.
  11356. 7116    CONTINUE
  11357.     IF(JMVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
  11358.     IF(.NOT.(JMVFG.EQ.49.AND.THISCL.EQ.1))GOTO 7117
  11359. C MUST SCROLL UP
  11360.     IF(IDOL7.EQ.0)GOTO 7117
  11361.     IF(ID2.LE.2)GOTO 7117
  11362.     DCOL=MAX0(1,DCLV-2)
  11363.     ID2=MAX0(2,ID2-DCLV+2)
  11364.     IQQ=1
  11365.     GOTO 7112
  11366. 7117    CONTINUE
  11367.     IF(JMVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
  11368.     IF(.NOT.(JMVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 7118
  11369. C MUST SCROLL DOWN
  11370.     IF(IDOL7.EQ.0)GOTO 7118
  11371.     DCOL=3
  11372. C    ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
  11373.     ID2=ID2+DCLV-MIN0(DCLV,2)
  11374.     IQQ=1
  11375.     GOTO 7112
  11376. 7118    CONTINUE
  11377.     IF(JMVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
  11378.     DROW=THISRW
  11379.     DCOL=THISCL
  11380.     PROW=NRDSP(DROW,DCOL)
  11381.     PCOL=NCDSP(DROW,DCOL)
  11382. C FORCE REDO OF BOTH LAST AND NEW COLUMN BY DISPLAYER.
  11383.     DVS(LR,LC)=DVS(LR,LC)+.0000000057
  11384.     DVS(DROW,DCOL)=DVS(DROW,DCOL)+.000000062
  11385. 7901    GOTO 9990
  11386. 8000    IF(CMDLIN(1).NE.'M')GOTO 8001
  11387.     ICODE=1
  11388. C MACROCELL COMMAND IF MH (HIDE) OR MS (SHOW)
  11389.     IF(CMDLIN(2).EQ.'S')IDOL4=1
  11390.     IF(CMDLIN(2).EQ.'H')IDOL4=0
  11391.     IF(CMDLIN(2).EQ.'S'.OR.CMDLIN(2).EQ.'H')GOTO 9990
  11392.     IF(CMDLIN(2).NE.'D')GOTO 4401
  11393. C MD MODE COMMAND.
  11394. C  MDD=DISABLE 3D AND DISALLOW 3D VBL NAMES
  11395. C  MDN=NO 3D BUT ALLOW 3D VBL NAMES
  11396. C  MDE=ENABLE 3D. DON'T TRANSLATE VARIABLE NAMES
  11397. C  MDF=FORCE 3D, TRANSLATING VARIABLE NAMES
  11398. C    ALL THESE ALLOW 2 NUMBERS TO FOLLOW, BEING COLUMN AND
  11399. C    ROW DELTAS TO THE NEXT "PLANE".
  11400.     K3DFG=0
  11401.     IF(CMDLIN(3).EQ.'D')K3DFG=-2
  11402.     IF(CMDLIN(3).EQ.'N')K3DFG=0
  11403.     IF(CMDLIN(3).EQ.'E')K3DFG=1
  11404.     IF(CMDLIN(3).EQ.'F')K3DFG=999
  11405. C NOW GRAB ARGS IF ANY.
  11406. C USE INTERNAL PROCEDURE TO DECODE 2 NUMBERS STARTING AT CMDLIN(4)
  11407. C SKIP IF NEXT CHAR IS NOT NUMERIC.
  11408.     If(cmdlin(4).eq.' ')goto 4404
  11409.     IF(Ichar(CMDLIN(4)).LE.47.OR.
  11410.      1   Ichar(CMDLIN(4)).GT.57)GOTO 9990
  11411. 4404    continue
  11412.     ASSIGN 4402 TO KBACK
  11413.     GOTO 8132
  11414. 4402    CONTINUE
  11415.     IF(NCL.GE.0.AND.NCL.LT.Mrows)KCDELT=NCL
  11416.     IF(LCWID.GE.0.AND.LCWID.LT.Mcols)KRDELT=LCWID
  11417.     GOTO 9990
  11418. 4401    CONTINUE
  11419. C MOVE COMMAND
  11420. C M1,M2,M3,M4 MOTION DIRECTION IS U,D,L,R
  11421.     IVVV=ICHAR(CMDLIN(2))
  11422. C ALLOW M0 TO MEAN RESTORE PRIOR STATE OF AUTOMOVE AND
  11423. C SAVE CURRENT STATE AS NEW PRIOR ONE. M1 THRU M5 MEAN SET
  11424. C AUTOMOVE TO 1-5 (5=NO MOTION) AND SAVE OLD STATE AS LAST
  11425. C STATE.
  11426.     IF(CMDLIN(2).EQ.'0')IVVV=JMVOLD
  11427.     JMVOLD=JMVFG
  11428.     JMVFG=IVVV
  11429. C    JMVFG=ICHAR(CMDLIN(2))
  11430. C STORE CHARACTER AS MOVE FLAG
  11431.     GOTO 9990
  11432. 8001    IF(CMDLIN(1).NE.'D')GOTO 8002
  11433. C DISPLAY COMMANDS
  11434. C
  11435. C DISPLAY SORT
  11436. C DSRA 1
  11437. C DS = CONSTANT KEYWORD
  11438. C R/C=ROW/COL (DISPLAY COORD #S)
  11439. C A/D=ASCENDING/DESCENDING ORDER
  11440. C NUMBER= DISPLAY COORD ROW/COL # TO SORT ON.
  11441. C SORTS NUMERIC FIELDS ONLY.
  11442.     IF(CMDLIN(2).NE.'S')GOTO 1752
  11443.     ICODE=2
  11444. C MUST REDRAW. WE DO WHOLESALE RELOCATIONS OF THINGS HERE.
  11445. C FIRST GET ARGUMENTS
  11446.     LAA=6
  11447.     LBB=15
  11448.     CALL GN(LAA,LBB,NBR,CMDLIN)
  11449. C THIS EXTRACTS THE NUMBER OF ROW/COL TO USE.
  11450. C DEFAULT IS PHYS, COL, ASCENDING
  11451.     IF(NBR.LE.0.OR.NBR.GT.MAX0(JIDcl,JIDrw))GOTO 9990
  11452. c    IF(NBR.LE.0.OR.NBR.GT.75)GOTO 9990
  11453.     SSIGN=1.
  11454.     IF(CMDLIN(4).EQ.'D')SSIGN=-1.
  11455. C SSIGN USED TO CONTROL ASCENDING/DESCENDING SORT (MULTIPLY BY IT)
  11456. C GET LENGTH TO GO THRU IN SORT
  11457.     IF(CMDLIN(3).EQ.'C')IDELTA=DCLV-1
  11458.     IF(CMDLIN(3).EQ.'R')IDELTA=DRWV-1
  11459.     I1IN=0
  11460.     I2IN=1
  11461. C GET PHYSICAL COORDINATES OF ROW/COL WE'RE SORTING ON.
  11462.     IF(CMDLIN(3).EQ.'R')GOTO 6222
  11463.     ID1=NRDSP(NBR,1)
  11464.     ID2=NCDSP(NBR,1)
  11465.     GOTO 1753
  11466. 6222    CONTINUE
  11467.     ID1=NRDSP(1,NBR)
  11468.     ID2=NCDSP(1,NBR)
  11469.     I1IN=1
  11470.     I2IN=0
  11471. C HACK TO HANDLE ROW/COL ALIKE
  11472. 1753    CONTINUE
  11473.     IFLIP=0
  11474. C IFLIP = BUBBLESORT FLAG WE CHANGED SOMETHING
  11475. C (USE SIMPLE MINDED SMALL SORT. TOO MUCH OVHD FOR BETTER ONE...NO ROOM)
  11476.     ID1A=ID1
  11477.     ID2A=ID2
  11478. C IGNORE CASE OF IDELTA=0... SHOULDN'T BE ANY WAY FOR THAT TO HAPPEN
  11479.     DO 1754 IV=1,IDELTA
  11480. C SORT HERE. IFLIP=1 IF WE INVERT ANYTHING.
  11481. C JUST COMPARE XVBLS...
  11482. C NOTE WE ASSUME A "NORMAL" TYPE DISPLAY, JUST RESET PHYSICAL STUFF.
  11483.     CALL XVBLGT(ID1A,ID2A,XAC)
  11484.     CALL XVBLGT(ID1A+I1IN,ID2A+I2IN,XVBLS(1,1))
  11485.     IF(XAC*SSIGN.LE.XVBLS(1,1)*SSIGN)GOTO 1755
  11486. C FLIP ASSIGNMENTS
  11487. C FLIP XVBLS NUMBERS TOO TO MAINTAIN SORT. WE RECOMPUTE ANYWAY..
  11488.     CALL XVBLST(ID1A+I1IN,ID2A+I2IN,XAC)
  11489.     CALL XVBLST(ID1A,ID2A,XVBLS(1,1))
  11490.     IFLIP=1
  11491. C SWAP ASSIGNMENTS OF DISPLAY STUFF IF IN RANGE
  11492. C OPERATES LIKE A SORTED OA COMMAND
  11493. C CURRENT PHYSICAL ROW IS ID2A (1...RCL LIMITS)
  11494. C AND PHYS COL IS ID1A.
  11495. C    LDELTA=DRW-1
  11496.     LDELTA=19
  11497. C FOR REASSIGNMENT, ROLE OF I1IN,I2IN CAN BE REVERSED...
  11498.     ID1B=1
  11499. C NOTE DISPLAY ID2 IS 1 LESS THAN PHYSICAL ONE. (AC'S)
  11500.     ID2B=ID2A-1
  11501.     IF(ID2B.LE.0)GOTO 1754
  11502.     IF(CMDLIN(3).NE.'R')GOTO 1756
  11503. C ROW...
  11504. C    LDELTA=DCL-1
  11505.     LDELTA=74
  11506. C ID1 SAME AS DISPLAY COORDS
  11507.     ID1B=ID1A
  11508.     ID2B=1
  11509. 1756    CONTINUE
  11510.     DO 1757 IVV=1,LDELTA
  11511. C FLIP THE ROW/COL 1 ENTRY AT A TIME. JUST CHANGES ASSIGNMENTS.
  11512.     JD1=NRDSP(ID1B,ID2B)
  11513.     JD2=NCDSP(ID1B,ID2B)
  11514.     NRDSP(ID1B,ID2B)=NRDSP(ID1B+I1IN,ID2B+I2IN)
  11515.     NCDSP(ID1B,ID2B)=NCDSP(ID1B+I1IN,ID2B+I2IN)
  11516.     NRDSP(ID1B+I1IN,ID2B+I2IN)=JD1
  11517.     NCDSP(ID1B+I1IN,ID2B+I2IN)=JD2
  11518.     ID1B=ID1B+I2IN
  11519.     ID2B=ID2B+I1IN
  11520. 1757    CONTINUE
  11521. C WE CAN ALWAYS FLIP SINCE WE STAY ON DISPLAY SHEET.
  11522. 1755    CONTINUE
  11523.     ID1A=ID1A+I1IN
  11524.     ID2A=ID2A+I2IN
  11525. 1754    CONTINUE
  11526. C DONE 1 PASS. IF ANYTHING CHANGED, TRY AGAIN.
  11527.     IF(IFLIP.NE.0)GOTO 1753
  11528. C DONE SORT AT END
  11529.     GOTO 9990
  11530. 1752    CONTINUE
  11531. C
  11532.     IF(CMDLIN(2).NE.'L')GOTO 8101
  11533. C DL = DISPLAY LOCATE V1:V2 N:M
  11534.     ASSIGN 8103 TO IBACK
  11535.     GOTO 8104
  11536. C STRIP VARIABLE NAMES OFF CMD LINE STARTING AT POSITION 3
  11537. 8104    LA=3
  11538.     LE=98
  11539.     L1=0
  11540.     LPagmd=0
  11541.     LPag1=0
  11542.     LPag2=0
  11543.     CALL VARSCN(CMDLIN(1),LA,LE,LSTC,ID1A,ID2A,IVLD)
  11544.     L2=0
  11545. C L1,L2 = FLAGS VARIABLE 1,2 FOUND VALIDLY
  11546.     LA=LSTC+1
  11547.     LE=100-LA
  11548.     IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8102
  11549.     L1=1
  11550.     lpag1=kpag
  11551.     IF(CMDLIN(LSTC).eq.'}')Lpagmd=1
  11552.     IF((CMDLIN(LSTC).NE.':').and.(Cmdlin(Lstc).ne.'}'))
  11553.      1   GOTO 8102
  11554. C MUST SEE : BETWEEN NAMES. NO SPACES PERMITTED.
  11555.     CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1B,ID2B,IVLD)
  11556.     IF(IVLD.LE.0)GOTO 8102
  11557.     lpag2=kpag
  11558.     L2=1
  11559. 8102    CONTINUE
  11560. C NOTE THAT LSTC RETURNS AS CHARACTER AFTER VARIABLE LAST GRABBED IN INPUT LINE.
  11561.     GOTO IBACK,(8103,8112,8121,8301,8953,8900,7015)
  11562. C NOW PICK UP RN:M OR CN:M (R=ROW,C=COL)
  11563. 8103    CONTINUE
  11564.     IF(L1.LT.1)GOTO 8101
  11565. C INVALID UNLESS AT LEAST 1 VBL NAME SEEN.
  11566.     LA=LSTC+2
  11567.     RCF=0
  11568.     IF(CMDLIN(LSTC+1).EQ.'R')RCF=2
  11569.     IF(CMDLIN(LSTC+1).EQ.'C')RCF=1
  11570.     IF(RCF.EQ.0)GOTO 8101
  11571.     KM1=1
  11572.     CALL GN(KM1,LE,NUM1,CMDLIN(LA))
  11573.     IF(NUM1.EQ.0)GOTO 8101
  11574.     KKK=ICHAR(':')
  11575.     LE=INDX(CMDLIN(LA),KKK)
  11576.     NUM2=0
  11577.     IF(LE.GT.100)GOTO 8101
  11578.     LA=LA+LE
  11579.     KM1=1
  11580.     KM8=8
  11581.     CALL GN(KM1,KM8,NUM2,CMDLIN(LA))
  11582. C NOW NUM1,NUM2 ARE DESIRED ROW/COL RANGE. NOW SET UP DISPLAY.
  11583.     IF(NUM2.EQ.0.OR.NUM2.GT.JIDrw)GOTO 8101
  11584.     IF(NUM1.GT.JIDcl0)GOTO 8101
  11585. C ILLEGAL ROW/COL IS A NO-GO.
  11586. C R N:M MEANS STARTING AT COL N ROW M GOING L TO R.
  11587. C C N:M MEANS DOWN STARTING THERE. DISPLAY COORDS ASSUMED.
  11588.     IF(ID1A.NE.ID1B.AND.ID2A.NE.ID2B)GOTO 8101
  11589. C ONLY HANDLE ROWS OR COLS, NOT DIAGONALS.
  11590. C MUST BE A PHYS MTX ROW OR COL.
  11591.     LRINC=0
  11592.     LCINC=0
  11593.     IF(RCF.EQ.1)LRINC=1
  11594.     IF(RCF.EQ.2)LCINC=1
  11595.     ASSIGN 8108 TO JBACK
  11596.     GOTO 8109
  11597. C COPY DATA
  11598. 8109    CONTINUE
  11599.     ICODE=6
  11600.     IDELT=1
  11601.     IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B))+1
  11602.     I1IN=0
  11603.     I2IN=1
  11604.     IF(ID1A.EQ.ID1B)GOTO 8106
  11605.     I1IN=1
  11606.     I2IN=0
  11607. 8106    CONTINUE
  11608.     ID1=ID1A
  11609.     ID2=ID2A
  11610.     GOTO JBACK,(8108,8113,8122,8307,8954,7307)
  11611. 8108    CONTINUE
  11612.     ICODE=1
  11613.     IR=NUM1
  11614.     IC=NUM2
  11615. C 1 DIM COPY OF DATA, FOR IDELT ELEMENTS.
  11616.     DO 8105 NM=1,IDELT
  11617. C CLAMP TO MAX DISPLAY ARRAY
  11618.     IF(IR.GT.JIDcl.OR.IC.GT.JIDrw)GOTO 8105
  11619.     NRDSP(IR,IC)=ID1
  11620.     NCDSP(IR,IC)=ID2
  11621.     DVS(IR,IC)=DVS(IR,IC)-1.E-14
  11622. C    THISRW=IR
  11623. C    THISCL=IC
  11624. C    JRX=(ID2-1)*60+ID1
  11625.     CALL REFLEC(ID2,ID1,JRX)
  11626.     CALL WRKFIL(JRX,FORM2,0)
  11627. C    READ(7'JRX)FORM2
  11628. C    DO 7104 N7=1,9
  11629. C7104    DFMTS(N7,IR,IC)=FORM2(N7+119)
  11630. C    DFMTS(10,IR,IC)=0
  11631.     IR=IR+LCINC
  11632.     IC=IC+LRINC
  11633. C NOTE REVERSAL FOR DISPLAY.
  11634.     ID1=ID1+I1IN
  11635.     ID2=ID2+I2IN
  11636. 8105    CONTINUE
  11637. 8101    CONTINUE
  11638.     IF(CMDLIN(2).NE.'F')GOTO 8111
  11639. C DF STUFF - SET FORMAT.
  11640.     ASSIGN 8112 TO IBACK
  11641.     GOTO 8104
  11642. 8112    CONTINUE
  11643. C NOW HAVE VARIABLE ID'S SET UP
  11644.     IF(L1.LE.0)GOTO 8120
  11645. C MUST HAVE 1 OR MORE...
  11646.     ASSIGN 8113 TO JBACK
  11647.     GOTO 8109
  11648. C IDELT NOW SET UP. SET FORMATS UP NOW.
  11649. C FORMATS ARE IN [] BRACKETS. FIND THESE AND USE.
  11650. 8113    CONTINUE
  11651.     ICODE=1
  11652.     KKK=ICHAR('[')
  11653.     LA=INDX(CMDLIN,KKK)+1
  11654.     KKK=ICHAR(']')
  11655.     LB=INDX(CMDLIN,KKK)-1
  11656.     LDELT=LB-LA+1
  11657.     LDELT=MIN0(LDELT,9)
  11658.     DO 8114 LN=1,IDELT
  11659. C IDELT IS OVER VRBL LIST GIVEN. MAY BE 1 ONLY.
  11660. C    IRRX=(ID2-1)*60+ID1
  11661.     CALL REFLEC(ID2,ID1,IRRX)
  11662.     CALL WRKFIL(IRRX,FORM,0)
  11663. C    READ(7'IRRX)FORM
  11664.     IF(CMDLIN(LA).EQ.'*')GOTO 7115
  11665.     IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')GOTO 7115
  11666. C KEEP EXISTING FORMAT IF [*] IS USED.
  11667.     DO 7989 KKKK=1,9
  11668. 7989    FORM(119+KKKK)=Char(0)
  11669.     DO 8115 LNA=1,LDELT
  11670.     FORM(LNA+119)=CMDLIN(LA-1+LNA)
  11671.     IF(LNA.LT.9)FORM(LNA+120)=char(0)
  11672. 8115    CONTINUE
  11673. 7115    CONTINUE
  11674. C    FORM(128)=0
  11675.     CALL FVLDGT(ID1,ID2,FVWRK)
  11676.     IVVVV=JCHAR(FVWRK)
  11677.     IF(IVVVV.EQ.0)IVVVV=3
  11678. C SET UP DEFAULT AS NUMERIC.
  11679. C    IVVVV=FVLD(ID1,ID2)
  11680. C    FVLD(ID1,ID2)=MAX0(1,IABS(IVVVV))
  11681.     IVVVV=MAX0(1,IABS(IVVVV))
  11682.     IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')IVVVV=
  11683.      1  MIN0(-1,-IABS(IVVVV))
  11684.     CALL FVLDST(ID1,ID2,CHAR(IVVVV))
  11685.     IF(CMDLIN(LA).EQ.'I')CALL TYPSET(ID1,ID2,4)
  11686.     IF(CMDLIN(LA).EQ.'F'.OR.CMDLIN(LA).EQ.'E')
  11687.      1   CALL TYPSET(ID1,ID2,2)
  11688.     FORM(119)=CHAR(IVVVV)
  11689. C
  11690. C TO BE SURE WE DON'T FOUL UP THE FILE, TRY AN ENCODE ON THIS FORMAT
  11691. C PRIOR TO THE WRITE. THAT WAY IF WE BOMB, THE FILE WE HAVE DIRECT ACCESS
  11692. C DATA ON IS NOT CLOBBERED.
  11693.     IF(IVVVV.LE.0)GOTO 7990
  11694.     DO 7988 KKK=1,9
  11695.     KKKK=ICHAR(FORM(119+KKK))
  11696. 7988    DFE(KKK+1)=CHAR(MAX0(32,KKKK))
  11697.     DFE(1)='('
  11698.     DFE(12)=' '
  11699.     DFE(13)=' '
  11700.     DFE(14)=')'
  11701.     CALL TYPGET(N1,N2,TYPE(1,1))
  11702.     CALL FVLDGT(N1,N2,FVLD(1,1))
  11703.     IF(JCHAR(FVLD(1,1)).LE.0)GOTO 7990
  11704.     IF(TYPE(1,1).NE.2)GOTO 6223
  11705.     WRITE(WRKCHR(1:127),DFE,ERR=4302)DVS(THISRW,THISCL)
  11706.     GOTO 7990
  11707. 6223    CONTINUE
  11708.         WRITE(WRKCHR(1:127),DFE,ERR=4302)LDVS(1,THISRW,THISCL)
  11709. 7990    CONTINUE
  11710.     CALL WRKFIL(IRRX,FORM,1)
  11711.     DO 8116 NX1=1,JIDcl
  11712.     DO 8116 NX2=1,JIDrw
  11713. C LOCATE DISPLAY CELL IF ANY
  11714.     IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8117
  11715. 8116    CONTINUE
  11716.     GOTO 8118
  11717. 8117    CONTINUE
  11718.     DVS(NX1,NX2)=DVS(NX1,NX2)-1.23E-12
  11719. 8118    CONTINUE
  11720.     ID1=ID1+I1IN
  11721.     ID2=ID2+I2IN
  11722. 8114    CONTINUE
  11723. 8111    CONTINUE
  11724.     IF(CMDLIN(2).NE.'T')GOTO 8120
  11725. C DT DISPLAY TYPE
  11726.     ASSIGN 8121 TO IBACK
  11727.     GOTO 8104
  11728. C GET VBL NAMES
  11729. 8121    ASSIGN 8122 TO JBACK
  11730.     GOTO 8109
  11731. 8122    LA=LSTC+1
  11732.     IF(L1.LE.0)GOTO 8120
  11733.     KTYP=2
  11734.     IF(CMDLIN(LA).EQ.'I')KTYP=4
  11735.     ICODE=1
  11736.     DO 8123 LNA=1,IDELT
  11737.     CALL TYPSET(ID1,ID2,KTYP)
  11738. C    TYPE(ID1,ID2)=KTYP
  11739.     DO 8126 NX1=1,DRWV
  11740.     DO 8126 NX2=1,DCLV
  11741.     IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8127
  11742. C FIND DISPLAY LOC IF ANY AND SET IT UP FOR REDRAW
  11743. 8126    CONTINUE
  11744.     GOTO 8128
  11745. 8127    CONTINUE
  11746.     DVS(NX1,NX2)=DVS(NX1,NX2)-1.211E-16
  11747. 8128    CONTINUE
  11748.     ID1=ID1+I1IN
  11749.     ID2=ID2+I2IN
  11750. 8123    CONTINUE
  11751. 8120    CONTINUE
  11752.     IF(CMDLIN(2).NE.'W')GOTO 8130
  11753. C DW SETS COL WIDTH
  11754.     ASSIGN 8131 TO KBACK
  11755.     GOTO 8132
  11756. C GET 2 NUMBERS STARTING AT CMDLIN(4)
  11757. 8132    CONTINUE
  11758.     KM1=1
  11759.     KM6=6
  11760.     CALL GN(KM1,KM6,NCL,CMDLIN(4))
  11761.     KKK=ICHAR(',')
  11762.     LA=INDX(CMDLIN(4),KKK)
  11763. C COMMA MUST BE SEPARATOR
  11764.     LCWID=7
  11765.     IF(LA.GT.100)GOTO 8138
  11766.     KM1=1
  11767.     CALL GN(KM1,KM6,LCWID,CMDLIN(LA+4))
  11768. 8138    GOTO KBACK,(8131,8141,4402)
  11769. 8131    CONTINUE
  11770.     ICODE=6
  11771.     NCL=MAX0(1,NCL)
  11772.     NCL=MIN0(NCL,JIDcl)
  11773.     LCWID=MAX0(1,LCWID)
  11774.     LCWID=MIN0(LCWID,110)
  11775. C COL WIDTH IS 3 TO 110 CHARS.
  11776.     IF(NCL.GT.0)CWIDS(NCL)=LCWID
  11777. 8133    CONTINUE
  11778. 8130    CONTINUE
  11779.     IF(CMDLIN(2).NE.'B')GOTO 8140
  11780. C DB = BOUNDS ON ROW,COL
  11781.     ASSIGN 8141 TO KBACK
  11782.     GOTO 8132
  11783. C PARASITE OTHER CODE TO GET DIGITS
  11784. 8141    MC=NCL
  11785.     MR=LCWID
  11786.     MC=MIN0(MC,JIDcl)
  11787.     MR=MIN0(MR,JIDrw)
  11788. C CLAMP RANGE TO LEGAL
  11789.     IF(MC.GT.0)DRWV=MC
  11790.     IF(MR.GT.0)DCLV=MR
  11791.     ICODE=2
  11792. C REDRAW SCREEN WHEN BOUNDS CHANGE.
  11793. 8140    CONTINUE
  11794.     GOTO 9990
  11795. 8002    IF(CMDLIN(1).NE.'V')GOTO 8003
  11796. C VIEW REDRAW COMMAND
  11797.     IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')CALL SWSET(0)
  11798.     IF(CMDLIN(2).EQ.'I')CALL SWSET(1)
  11799.     IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')MODFLG=0
  11800.     IF(CMDLIN(2).EQ.'I')MODFLG=1
  11801. C VI MEANS VIEW IBM MODE, USING BIOS CALLS FOR DIRECT SCREEN OUTPUT.
  11802.     IF(CMDLIN(2).EQ.'C')CALL UVT100(20,0,0)
  11803.     IF(CMDLIN(2).EQ.'B')CALL UVT100(21,0,0)
  11804. C VC SETS VIEW COLOR MODE
  11805. C VB SETS VIEW B+W MODE
  11806. C REQUIRES UVTGEN MODULE...
  11807.     IF(CMDLIN(2).EQ.'H')GOTO 8320
  11808. 8324    CONTINUE
  11809.     PZAP=0
  11810.     FORMFG=0
  11811.     IF(CMDLIN(2).EQ.'F')FORMFG=1
  11812.     IF(CMDLIN(2).EQ.'M')PZAP=1
  11813.     ICODE=6
  11814.     IF(CMDLIN(2).EQ.'E')ICODE=1
  11815. C VE JUST TURNS ON VIEW MODE, DOESN'T REPAINT ALL.
  11816.     GOTO 9990
  11817. 8320    CONTINUE
  11818.     IF(CMDLIN(3).NE.'+'.AND.CMDLIN(3).NE.'-')GOTO 8324
  11819. C VH+ OR VH-, FLIP VIEW HACK TO SHOW PROGRESS
  11820. C DYMANICALLY
  11821.     IDOL8=1
  11822.     IF(CMDLIN(3).EQ.'-')IDOL8=0
  11823. C IDOL8 = 1 MEANS DO THE DISPLAY, 0 MEANS DON'T.
  11824.     ICODE=3
  11825.     GOTO 9990
  11826. 8003    IF(CMDLIN(1).NE.'C'.AND.CMDLIN(1).NE.'I')GOTO 8004
  11827. C COPY NUMBERS COMMAND
  11828. C COPY (NUMBERS,FORMAT,DISPLAY,ALL)
  11829. C CV=COPY VALUE, CD=COPY DISPLAY FMT, CF=COPY FORMULA, CA=COPY ALL
  11830. C Ca V1:V2 V3:V4 COPIES FIRST RANGE TO SECOND.
  11831. C IR RANGES DOES INPLACE RELOCATION...
  11832. C
  11833. C COLLECT ARGS
  11834.     ASSIGN 8301 TO IBACK
  11835.     GOTO 8104
  11836. 8301    CONTINUE
  11837. C NOW L1,L2 SAY IF VBLS(ID1A,ID2A) AND (ID1B,ID2B) EXIST
  11838. C also Lpagmd says if the first range is page range and
  11839. C Lpag1 and Lpag2 have page ranges.
  11840. C COLLECT JD2A,JD2B. USE SIMILAR INTERNAL PROCEDURE CODE.
  11841.     IF(L1.LE.0)GOTO 8399
  11842.     ASSIGN 8302 TO MBACK
  11843.     GOTO 8303
  11844. 8303    CONTINUE
  11845. C COLLECT 2 VARS STARTING AT LSTC+3
  11846. C SKIPS LSTC DELIMITER.
  11847.     LJ1=0
  11848.     LJ2=0
  11849.     LA=LSTC+1
  11850.     LE=110-LA
  11851.     KPagmd=0
  11852.     KPag1=0
  11853.     KPag2=0
  11854.     IF(LE.LE.0)GOTO 8304
  11855.     CALL VARSCN(CMDLIN,LA,LE,LSTC,JD1A,JD1B,IVLD)
  11856.     LA=LSTC+1
  11857.     LE=110-LA
  11858.     IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8304
  11859.     KPag1=kpag
  11860.     LJ1=1
  11861. C allow } to indicate DEPTH oriented ranges but flag it.
  11862.     If(Cmdlin(lstc).eq.'}')KPagmd=1
  11863.     IF((CMDLIN(LSTC).NE.':').and.(Cmdlin(Lstc).ne.'}'))
  11864.      1    GOTO 8304
  11865.     CALL VARSCN(CMDLIN,LA,LE,LSTC,JD2A,JD2B,IVLD)
  11866.     IF(IVLD.LE.0)GOTO 8304
  11867.     KPag2=kpag
  11868.     LJ2=1
  11869. 8304    GOTO MBACK,(8302,7017)
  11870. 8302    CONTINUE
  11871.     IF(LJ1.LE.0)GOTO 8399
  11872.     IDELT=1
  11873.     IPDL=0
  11874.     If(LPagmd.ne.0.and.Lpag2.gt.LPag1)ipdl=Lpag2-Lpag1
  11875.     If(K3Dfg.le.0)ipdl=0
  11876.     IF(Lpagmd.eq.0.and.
  11877.      1  L2.NE.0.AND.(ID1A.NE.ID1B.AND.ID2A.NE.ID2B))GOTO 8305
  11878.     IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B),
  11879.      1   IPDL)+1
  11880.     if(k3dfg.gt.0.and.lpagmd.ne.0.and.ipdl.gt.0)
  11881.      1  idelt=ipdl+1
  11882.     IKDelt=IDelt
  11883. 8305    CONTINUE
  11884.     JDELT=1
  11885.     JPDL=0
  11886.     If(KPagmd.ne.0.and.Kpag2.gt.KPag1)JPDL=KPag2-KPag1
  11887.     If(K3Dfg.le.0)jpdl=0
  11888.     IF(kpagmd.ne.0.or.LJ2.EQ.0)GOTO 8306
  11889.     IF(JD1A.NE.JD2A.AND.JD1B.NE.JD2B)GOTO 8306
  11890.     JDELT=MAX0(IABS(JD1A-JD2A),IABS(JD1B-JD2B),
  11891.      1    JPDL)+1
  11892. 8306    IF(L2.NE.0)JDELT=MIN0(IDELT,JDELT)
  11893. C For page mode, difference is depth, not row or cols.
  11894.     if(k3dfg.gt.0.and.kpagmd.ne.0.and.jpdl.gt.0)
  11895.      1  jdelt=jpdl+1
  11896. C CHANGE FOR REPLICATE :  JDELT CAN BE JUST JDELT IF L2=0
  11897.     ASSIGN 8307 TO JBACK
  11898. C 8109 IS WHERE WE SET UP I1IN AND I2IN ASSUMING THAT THE VARIABLES
  11899. C ARE SET PROPERLY. HANDLED AS AN INTERNAL PROCEDURE.
  11900.     GOTO 8109
  11901. 8307    CONTINUE
  11902. C 8109 procedure also resets IDELT
  11903.     If(k3dfg.gt.0)IDelt=IKDelt
  11904.     JIN1=1
  11905.     JIN2=0
  11906.     IF(JD1B.EQ.JD2B)GOTO 8308
  11907.     JIN1=0
  11908.     JIN2=1
  11909. 8308    CONTINUE
  11910. C
  11911. C Change for 3D depth ranges:
  11912. C Reset I1IN and I2IN to KRDELT and KCDELT if depth mode and
  11913. C 3D stuff enabled. Reset JIN1 and JIN2 likewise if depth
  11914. C mode there.
  11915. C This has the advantage that it allows cells to be copied
  11916. C from any one dimensional range to any other, even if one
  11917. C or both 1-D ranges are in depth. A certain amount of hacking
  11918. C can allow cells possibly to be copied in overlapping pages
  11919. C also (for stuff like matrix traces).
  11920.     If(K3DFG.LE.0)goto 8610
  11921.     If(LPagmd.le.0)goto 8611
  11922.     I1IN=KCDELT
  11923.     I2IN=KRDELT
  11924. 8611    Continue
  11925.     If(KPagmd.le.0)goto 8610
  11926.     JIN1=KCDELT
  11927.     JIN2=KRDELT
  11928. 8610    Continue
  11929. C CHANGE FOR REPLICATE: IF L2 IS 0 (NO 2ND SRC VARIABLE), NO BUMPS
  11930. C PAST THE SINGLE VARIABLE SPECIFIED.
  11931.     IF(L2.EQ.0)I1IN=0
  11932.     IF(L2.EQ.0)I2IN=0
  11933. C FOR PCC-PC DO RECALC ALWAYS TO ALLOW DISPLAY TO LOOK OK
  11934.     ICODE=3
  11935. C    ICODE=1
  11936. C FORCE RECALC IF ONLY 1 SOURCE VARIABLE.
  11937. C    IF(L2.EQ.0)ICODE=3
  11938.     JRTR=PROW
  11939.     JRTC=PCOL
  11940. C JRTR AND JRTC = RELOCATION THRESHOLDS
  11941. C CELLS ABOVE OR LEFT OF JRTR,JRTC WILL NOT BE RELOCATED IN A CR
  11942. C OPERATION. THIS WILL GENERALLY BE THE PHYSICAL COLUMN OR ROW
  11943. C OF THE CURRENT POSITION. CELLS LOWER OR EQUAL, OR TO THE RIGHT
  11944. C OF THE CURRENT LOCATION OR EQUAL, WILL BE RELOCATED. (VARIABLE
  11945. C NAMES GET EDITED)
  11946.     ASSIGN 8365 TO KPYBAK
  11947.     GOTO 8364
  11948. C 8364 BEGINS COPY PROCEDURE SECTION
  11949. C GOES FOR JDELT CELLS WITH I1IN AND I2IN BEING SOURCE INCREMENTS FOR
  11950. C RRW DIMENSION, RCL DIMENSION, AND JIN1,2 BEING INCREMENTS FOR
  11951. C DESTINATION RRW,RCL DIMENSIONS RESPECTIVELY. USES CMDLIN(2) TO
  11952. C FLAG WHETHER TO HANDLE ALL, JUST FORMAT, RELOCATE, ETC.
  11953. C  ALSO ID1A,ID2A ARE START SOURCE LOCATION
  11954. C  JD1A,JD1B = DEST START LOCATION.
  11955. C
  11956. C COPIES 1 ROW OR COLUMN AT A TIME.
  11957. 8364    CONTINUE
  11958. C    ICODE=1
  11959. C SET DISPLAY UPDATE ON COPIED CELLS
  11960. CCD    DO 3620 JV=1,BRRCL
  11961. CCD3620    IBITMP(JV)=0
  11962.     DO 8309 JV=1,JDELT
  11963.     DO 8380 NX1=1,DRWV
  11964.     DO 8380 NX2=1,DCLV
  11965. C LOCATE DISPLAY CELL IF ANY
  11966.     IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8387
  11967. 8380    CONTINUE
  11968.     GOTO 8388
  11969. 8387    CONTINUE
  11970.     DVS(NX1,NX2)=DVS(NX1,NX2)+1.245E-14
  11971. 8388    CONTINUE
  11972. C    JRXX=(JD1B-1)*60+JD1A
  11973. C    IRXX=(ID2A-1)*60+ID1A
  11974.     CALL REFLEC(JD1B,JD1A,JRXX)
  11975.     CALL REFLEC(ID2A,ID1A,IRXX)
  11976.     CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
  11977.     KKKKK=JCHAR(FVLD(1,1))
  11978.     CALL FVLDGT(JD1A,JD1B,FVLD(1,1))
  11979.     IF(KKKKK.EQ.0.AND.ICHAR(FVLD(1,1)).EQ.0)GOTO 8314
  11980. C    IF(FVLD(ID1A,ID2A).EQ.0.AND.FVLD(JD1A,JD1B).EQ.0)GOTO 8314
  11981.     CALL WRKFIL(IRXX,FORM,0)
  11982.     CALL WRKFIL(JRXX,FORM2,0)
  11983.     IF(KKKKK.EQ.-2)CALL FVLDST(ID1A,ID2A,CHAR(253))
  11984.     IF(KKKKK.EQ.2)CALL FVLDST(ID1A,ID2A,CHAR(3))
  11985.     IF(jchar(FORM (119)).EQ. 2)FORM (119)=Char(3)
  11986.     IF(jchar(FORM (119)).EQ.-2)FORM (119)=Char(253)
  11987.     IF(jchar(FORM2(119)).EQ. 2)FORM2(119)=Char(3)
  11988.     IF(jchar(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  11989.     IF(CMDLIN(2).NE.'R'.AND.CMDLIN(2).NE.'A')GOTO 8310
  11990.     IF(CMDLIN(2).NE.'R')GOTO 8366
  11991. C RELOCATE, THEN WRITE NEW CELL
  11992.     II1=ID1A
  11993.     II2=ID2A
  11994.     JJ1=JD1A
  11995.     JJ2=JD1B
  11996.     CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
  11997. C THE ABOVE WILL RELOCATE FORM INTO FORM2 WHICH WE NOW EMIT.
  11998. C ALLOW IR COMMAND TO DO INPLACE RELOCATION.
  11999.     IF(CMDLIN(1).NE.'I')GOTO 6224
  12000.     CALL WRKFIL(IRXX,FORM2,1)
  12001.     GOTO 9222
  12002. 6224    CONTINUE
  12003.     CALL WRKFIL(JRXX,FORM2,1)
  12004.     GOTO 8367
  12005. 8366    CONTINUE
  12006.     CALL WRKFIL(JRXX,FORM,1)
  12007. C    WRITE(7'JRXX)FORM
  12008. 8367    CONTINUE
  12009.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  12010.     CALL TYPSET(JD1A,JD1B,TYPE(1,1))
  12011. C    TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
  12012.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  12013.     CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
  12014. C    XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
  12015.     CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
  12016.     CALL FVLDST(JD1A,JD1B,FVLD(1,1))
  12017. C    FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
  12018. 9222    ID1A=ID1A+I1IN
  12019.     ID2A=ID2A+I2IN
  12020.     JD1A=JD1A+JIN1
  12021.     JD1B=JD1B+JIN2
  12022.     GOTO 8309
  12023. 8310    CONTINUE
  12024.     IF(CMDLIN(2).NE.'V')GOTO 8312
  12025.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  12026.     CALL TYPSET(JD1A,JD1B,TYPE(1,1))
  12027. C    TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
  12028.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  12029.     CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
  12030. C    XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
  12031. 8312    IF(CMDLIN(2).NE.'D')GOTO 8313
  12032.     CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
  12033.     CALL FVLDST(JD1A,JD1B,FVLD(1,1))
  12034. C    FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
  12035.     DO 8315 LXQ=1,10
  12036. 8315    FORM2(118+LXQ)=FORM(118+LXQ)
  12037.     CALL WRKFIL(JRXX,FORM2,1)
  12038. C    WRITE(7'JRXX)FORM2
  12039. 8313    IF(CMDLIN(2).NE.'F')GOTO 8314
  12040.     DO 8316 LXQ=1,110
  12041. 8316    FORM2(LXQ)=FORM(LXQ)
  12042.     CALL WRKFIL(JRXX,FORM2,1)
  12043. 8314    CONTINUE
  12044.     ID1A=ID1A+I1IN
  12045.     ID2A=ID2A+I2IN
  12046.     JD1A=JD1A+JIN1
  12047.     JD1B=JD1B+JIN2
  12048. 8309    CONTINUE
  12049. C RETURN POINT FROM COPY LOOP IN NORMAL COPY
  12050.     GOTO KPYBAK,(8840,8836,8365)
  12051. 8365    CONTINUE
  12052. 8399    GOTO 9990
  12053. 8004    IF(CMDLIN(1).LT.'1'.OR.CMDLIN(1).GT.'4')GOTO 8005
  12054. C 1,2,3,4 POSITIONING COMMANDS
  12055. C USE LLT AND LGT LEXICAL ORDERING TESTS, NOT ARITHMETIC ONES...
  12056.     ICODE=5
  12057. C    IF(CMDLIN(1).EQ.'3')THISRW=MAX0(1,(THISRW-1))
  12058. C    IF(CMDLIN(1).EQ.'4')THISRW=MIN0((THISRW+1),DRWV)
  12059. C    IF(CMDLIN(1).EQ.'1')THISCL=MAX0(1,(THISCL-1))
  12060. C    IF(CMDLIN(1).EQ.'2')THISCL=MIN0((THISCL+1),DCLV)
  12061. C COULD ADD SCROLLING HERE IF DESIRED.
  12062. C    ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
  12063.     MVFG=ICHAR(CMDLIN(1))
  12064.     LRO=1
  12065.     LCO=1
  12066.     ID1=NRDSP(1,1)
  12067.     ID2=NCDSP(1,1)
  12068.     IF(.NOT.(MVFG.EQ.51.AND.THISRW.EQ.1))GOTO 2110
  12069. C MUST SCROLL LEFT
  12070.     IF(IDOL7.EQ.0)GOTO 2110
  12071.     IF(ID1.LE.1)GOTO 2110
  12072.     ID1=MAX0(1,ID1-DRWV+2)
  12073.     DROW=MAX0(1,DRWV-2)
  12074.     IQQ=1
  12075.     GOTO 7112
  12076. 2110    IF(MVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
  12077.     IF(.NOT.(MVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 2116
  12078. C MUST SCROLL RIGHT
  12079.     IF(IDOL7.EQ.0)GOTO 2116
  12080.     DROW=3
  12081. C    ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
  12082.     ID1=ID1+DRWV-MIN0(DRWV,2)
  12083.     IQQ=1
  12084.     GOTO 7112
  12085. C 7112 FAKES OUT OA CALL TO SCROLL OVER.
  12086. 2116    IF(MVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
  12087.     IF(.NOT.(MVFG.EQ.49.AND.THISCL.EQ.1))GOTO 2117
  12088. C MUST SCROLL UP
  12089.     IF(IDOL7.EQ.0)GOTO 2117
  12090.     IF(ID2.LE.2)GOTO 2117
  12091.     DCOL=MAX0(1,DCLV-2)
  12092.     ID2=MAX0(2,ID2-DCLV+2)
  12093.     IQQ=1
  12094.     GOTO 7112
  12095. 2117    IF(MVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
  12096.     IF(.NOT.(MVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 2118
  12097. C MUST SCROLL DOWN
  12098.     IF(IDOL7.EQ.0)GOTO 2118
  12099.     DCOL=3
  12100. C    ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
  12101.     ID2=ID2+DCLV-MIN0(DCLV,2)
  12102.     IQQ=1
  12103.     GOTO 7112
  12104. 2118    IF(MVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
  12105.     PROW=NRDSP(THISRW,THISCL)
  12106.     PCOL=NCDSP(THISRW,THISCL)
  12107.     DROW=THISRW
  12108.     DCOL=THISCL
  12109.     GOTO 9990
  12110. 8005    CONTINUE
  12111. 8007    IF(CMDLIN(1).NE.'R')GOTO 8008
  12112.     IF(CMDLIN(2).NE.'B')GOTO 7333
  12113. C RB VAR SETS RELOCATE BOUNDARY TO VAR COORDS
  12114.     IF(CMDLIN(3).EQ.'*')GOTO 7332
  12115. C NORMAL RB COMMAND
  12116. C RB VAR USES VAR NAME TO RESET BDY
  12117.     LO=3
  12118.     KKKK=20
  12119.     CALL VARSCN(CMDLIN,LO,KKKK,IV,ID1,ID2,IVALID)
  12120.     IF(IVALID.LE.0)GOTO 9990
  12121. C IGNORE ERRORS
  12122.     IDOL5=ID1
  12123.     IDOL6=ID2
  12124.     GOTO 9990
  12125. 7332    IDOL5=20000
  12126.     IDOL6=20000
  12127. C RB* RESETS RELOCATE BDY TO END OF SHEET
  12128.     GOTO 9990
  12129. 7333    CONTINUE
  12130. C RECOMPUTE SHEET.
  12131. C RM COMMAND SETS MANUAL FLAG.
  12132.     RCFGX=0
  12133. c
  12134.     RCONE=0
  12135.     IF(CMDLIN(2).NE.'S')GOTO 5114
  12136.     RRWACT=MCols
  12137.     RCLACT=MRows
  12138. 5114    CONTINUE
  12139. C RCFGX NONZERO INHIBITS RECALCULATION.
  12140. C RCONE SET 1 TO FORCE RECALC OF ALL.
  12141. C CHANGE FROM OTHER SYNTAX: RF FORCES RECALC, R DOES NOT.
  12142.     IF(CMDLIN(2).EQ.'F'.OR.CMDLIN(2).EQ.'R')RCONE=1
  12143. C NOTE RXF (X=ANY CHAR BUT F) ACTS LIKE OLD VERSION RXF.
  12144. C BARE R COMMAND HOWEVER JUST REDOES CALC. F NOW MEANS "FORCE"
  12145. C AND SEEMS A BIT MORE MNEMONIC THIS WAY. ALLOW RR COMMAND
  12146. C TO WORK AS WELL AS RF.
  12147.     IF(CMDLIN(2).NE.'R')RCMODE=0
  12148.     IF(CMDLIN(2).EQ.'E')RCMODE=1
  12149.     IF(CMDLIN(2).EQ.'I')RCMODE=2
  12150. C RE, RI MODE CONTROLS... ALSO RR ACTS LIKE RF BUT STAYS IN
  12151. C RE OR RI MODE... RECALC ENTRY OR INCREMENTAL...
  12152.     IF(CMDLIN(2).EQ.'M')RCFGX=1
  12153.     ICODE=3
  12154. C 3rd char I Inhibits recalc this time but sets modes...
  12155.     IF(CMDLIN(3).EQ.'I')ICODE=1
  12156.     GOTO 9990
  12157. 8008    IF(CMDLIN(1).NE.'K')GOTO 8009
  12158. C DROP INTO CALC BARE.
  12159.     IF(IPSET.NE.0)GOTO 9990
  12160. C CAN'T CALL CALC RECURSIVELY
  12161.     OSWIT=0
  12162.     ILNFG=0
  12163. C    ICODE=-1
  12164. C CLOSE UNIT 1 JUST IN CASE...
  12165.     CLOSE(1)
  12166.     CALL UVT100(11,2,0)
  12167. C ERASE DSPLY
  12168.     KLVL=1
  12169.     ILNCT=0
  12170. C ICODE SET TO 420 SPECIAL CODE TO TELL MAIN PGM TO CALL INTERACTIVE
  12171. C CALCULATOR FCN.
  12172.     ICODE=420
  12173.     GOTO 9990
  12174. 8009    IF(CMDLIN(1).NE.'L')GOTO 8010
  12175. C LOCATE CURSOR ORIGIN
  12176. C FORMAT IS L VARIABLE
  12177. C ONLY 1 VARIABLE NAME TO BE ENTERED.
  12178.     LA=2
  12179.     LE=30
  12180.     CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1A,ID2A,IVLD)
  12181.     L1=IVLD
  12182. C    ASSIGN 8900 TO IBACK
  12183. C    GOTO 8104
  12184. 8900    IF(L1.LT.1)GOTO 9990
  12185. 3800    PROW=ID1A
  12186.     PCOL=ID2A
  12187. C LOOK UP DISPLAY COORDS IF ANY
  12188.     ASSIGN 8901 TO NBK
  12189.     GOTO 7905
  12190. 8901    CONTINUE
  12191.     DROW=LR
  12192.     DCOL=LC
  12193.     THISRW=LR
  12194.     THISCL=LC
  12195. 3801    ICODE=1
  12196.     GOTO 9990
  12197. 8010    CONTINUE
  12198.     IF(CMDLIN(1).NE.'>')GOTO 3802
  12199. C >STRING SEARCHES FORMULAE FOR STRING
  12200.     LA=MIN0(IDOL5,RRWACT)
  12201.     LB=MIN0(IDOL6,RCLACT)
  12202. C NO ACTION UNLESS VALID SEARCH REGION (CURRENT TO RELOC BDY)
  12203. C EXISTS.
  12204.     IF(LA.LT.PROW.OR.LB.LT.PCOL)GOTO 3801
  12205.     DO 3803 ID1=PROW,LA
  12206.     DO 3803 ID2=PCOL,LB
  12207.     ID1A=ID1
  12208.     ID2A=ID2
  12209.     CALL FVLDGT(ID1,ID2,FVLD(1,1))
  12210.     IF(JCHAR(FVLD(1,1)).EQ.0)GOTO 3803
  12211. C HAVE VALID CELL HERE, SO GRAB ITS FORMULA AND COMPARE FOR THE ONE
  12212. C WE'RE LOOKING FOR. IF CMD LINE STARTS WITH >> ANCHOR THE SEARCH AT 1ST
  12213. C COL.
  12214.     LMX=50
  12215.     LMN=2
  12216.     IF(CMDLIN(2).NE.'>')GOTO 3805
  12217.     LMX=1
  12218.     LMN=3
  12219. 3805    CONTINUE
  12220. C    IRX=(ID2-1)*60+ID1
  12221.     CALL REFLEC(ID2,ID1,IRX)
  12222.     CALL WRKFIL(IRX,FORM,0)
  12223.     CALL CE2A(FORM,FORM2)
  12224.     DO 3804 IV=1,LMX
  12225.     KKKK=109-IV
  12226. C COMPARE FORMULA TEXT. USE EXISTING SCMP ROUTINE.
  12227.     CALL SCMP(CMDLIN(LMN),FORM2(IV),KKKK,KKK)
  12228.     IF(KKK.EQ.1.AND.JCHAR(FORM2(IV)).GT.0)GOTO 3800
  12229.     IF(JCHAR(FORM2(IV)).LE.0)GOTO 3803
  12230. 3804    CONTINUE
  12231. 3803    CONTINUE
  12232. C IF WE FALL THROUGH, WE FAILED TO FIND FORMULA SO FORGET IT.
  12233.     GOTO 3801
  12234. 3802    CONTINUE
  12235.     IF(CMDLIN(1).NE.'Z')GOTO 8011
  12236. C ZERO COMMAND
  12237. C ZA OR ZE V1:V2
  12238.     IF(CMDLIN(2).NE.'A')GOTO 8950
  12239. C ZA = ZERO ALL. BE SURE HE MEANS IT.
  12240.     CALL UVT100(1,LLDSP,1)
  12241. c    WRITE(0,8951)
  12242. c8951    FORMAT('Really Zero All of sheet [Y/N]?\')
  12243.     call Vwrt('Really Zero ALL of sheet [Y/N]?',31)
  12244.     III=IOLVL
  12245. C    IF(III.EQ.5)III=0
  12246.     if(iii.ne.11)READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
  12247.     if(iii.eq.11)call vget(form2,4)
  12248. 8952    FORMAT(4A1)
  12249.     ICODE=6
  12250.     IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
  12251.     CALL UVT100(11,2,0)
  12252.     ICODE=-4
  12253.     GOTO 9990
  12254. 8950    IF(CMDLIN(2).NE.'E')GOTO 9990
  12255.     ASSIGN 8953 TO IBACK
  12256.     GOTO 8104
  12257. C GET NAMES
  12258. 8953    IF(L1.LE.0)GOTO 9990
  12259.     ASSIGN 8954 TO JBACK
  12260.     GOTO 8109
  12261. 8954    CONTINUE
  12262.     DO 8955 NI=1,128
  12263. 8955    FORM2(NI)=char(0)
  12264.     FORM2(118)=Char(15)
  12265.     DO 8823 NI=1,9
  12266. 8823    FORM2(119+NI)=DEFVB(1+NI)
  12267.     DO 8956 NI=1,IDELT
  12268. C    IRX=(ID2-1)*60+ID1
  12269.     CALL REFLEC(ID2,ID1,IRX)
  12270.     CALL WRKFIL(IRX,FORM2,1)
  12271.     CALL FVLDST(ID1,ID2,CHAR(0))
  12272.     CALL XVBLST(ID1,ID2,0.0D0)
  12273.     IPRS=PROW
  12274.     IPCS=PCOL
  12275.     PROW=ID1
  12276.     PCOL=ID2
  12277.     ASSIGN 8957 TO NBK
  12278. C FIND DISPLAY LOC IF ANY
  12279.     GOTO 7905
  12280. 8957    PROW=IPRS
  12281.     PCOL=IPCS
  12282.     IF(LR.EQ.0.OR.LC.EQ.0)GOTO 8958
  12283.     DVS(LR,LC)=DVS(LR,LC)+1.E-11
  12284. 8958    CONTINUE
  12285.     ID1=ID1+I1IN
  12286.     ID2=ID2+I2IN
  12287. 8956    CONTINUE
  12288.     GOTO 9990
  12289. 8011    IF(CMDLIN(1).NE.'X')GOTO 8012
  12290. C EXIT TO OS
  12291. C SINCE THERE'S NO WORKFILE HERE, MAKE SURE HE MEANS IT...
  12292.     IF(IPSET.NE.0)GOTO 9990
  12293.     ICODE=2
  12294.     CALL UVT100(1,LLDSP,1)
  12295.         call 
  12296.      1 swrt('Exit now may lose data unless sheet has been saved'
  12297.      2 ,50)
  12298.     CALL UVT100(1,LLCMD,1)
  12299.     call Vwrt('Confirm Exit Request [Y/N]:',27)
  12300.     III=IOLVL
  12301. C    IF(IOLVL.EQ.5)III=0
  12302.     if(iii.ne.11)READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
  12303.     if(iii.eq.11)call vget(form2,4)
  12304.     IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
  12305. C END CALL TO GET OUT OF HERE
  12306. c    Close(unit=11)
  12307.     Close(unit=3)
  12308.     Call TTYDEI
  12309. c    call standard_arithmetic()
  12310. C close any open RIM databases, just in case...
  12311.     CALL RMCLOS
  12312.         STOP "Thanks for using AnalytiCalc ...exiting."
  12313. C    CALL EXIT
  12314. 8012    IF(CMDLIN(1).NE.'S')GOTO 8013
  12315. C SAVE SHEET TO DISK (NEW SET OF DATA)
  12316. C NOW JUST PERMITS RESTART...
  12317.     ICODE=-2
  12318.     ISTAT=-2
  12319.     CALL UVT100(11,2,0)
  12320.     GOTO 9990
  12321. 8013    IF(CMDLIN(1).NE.'P')GOTO 8014
  12322.     If(CmdLin(2).eq.'L')GoTo 7014
  12323.     IRTN=0
  12324.     CALL PGET(CMDLIN,ICODE,IRTN)
  12325.     IF(IRTN.EQ.1)GOTO 510
  12326.     GOTO 9990
  12327. 7014    Continue
  12328. c plot v1:v2[,v3:v4];cmdfile to plot a range or two ranges (either y only or x,y pairs)
  12329. c by calling gnuplot as an external routine. Emits a file and fires up the
  12330. c command file in the cmd line (or dk:pltfil.pcp if none)
  12331. c This way different command files can fire up gnuplot for different types of
  12332. c plots, colors, devices, etc. with only ONE primitive here!
  12333. c first collect args
  12334.     assign 7015 to iback
  12335.     goto 8104   
  12336. 7015    continue
  12337. c should now have v1,v2 in (id1a,id2a) and (id1b,id2b) respectively
  12338.     if(l1.eq.0.or.l2.eq.0)goto 9990
  12339. c skip out if we don't have both args valid
  12340.     kivvv=0
  12341.     if(cmdlin(lstc).ne.',')goto 7017
  12342.     kivvv=1
  12343.     assign 7017 to mback
  12344.     goto 8303
  12345. 7017    continue
  12346.     if(kivvv.eq.1.and.(lj1.eq.0.or.lj2.eq.0))goto 9990
  12347. c skip unless both args of second range are legal
  12348. c have v3,v4 in (jd1a,jd1b) and (jd2a,jd2b) now.
  12349. c we also know they are valid and if kivvv is 1 we know a second
  12350. c range was specified.
  12351. c collect cmd file name now.
  12352.     lhich=0
  12353.     if(cmdlin(lstc).ne.';')goto 7018
  12354. c skip looking if delimiter wrong
  12355.     lochr=lstc+1
  12356.     do 7019 n=lochr,70
  12357.     kkk=n
  12358.     if(ichar(cmdlin(n)).le.32)goto 7020
  12359. 7019    continue
  12360.     goto 7018
  12361. c skip if we fall thru...looks illegal
  12362. 7020    continue
  12363. c check we actually saw at least one char
  12364.     if(kkk.eq.lochr)goto 7018
  12365. c saw a char so record
  12366.     lhich=kkk
  12367. 7018    continue
  12368. c now can use lhich as flag
  12369.     open(16,file='pccplt.dat',status='unknown')
  12370. c use sequential file on unit 16 for scratch...now grab values and
  12371. c shove 'em out...
  12372. c Now set up for loop over the ranges given, one of which may be x
  12373. c and the other of which may be y, or the first and only one of
  12374. c which may be y.
  12375. c &&&&&
  12376.     IDELT=1
  12377.     IPDL=0
  12378.     If(LPagmd.ne.0.and.Lpag2.gt.LPag1)ipdl=Lpag2-Lpag1
  12379.     If(K3Dfg.le.0)ipdl=0
  12380.     IF(Lpagmd.eq.0.and.
  12381.      1  L2.NE.0.AND.(ID1A.NE.ID1B.AND.ID2A.NE.ID2B))GOTO 7305
  12382.     IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B),
  12383.      1   IPDL)+1
  12384.     if(k3dfg.gt.0.and.lpagmd.ne.0.and.ipdl.gt.0)
  12385.      1  idelt=ipdl+1
  12386.     IKDelt=IDelt
  12387. 7305    CONTINUE
  12388.     JDELT=idelt
  12389.     JPDL=0
  12390.     If(KPagmd.ne.0.and.Kpag2.gt.KPag1)JPDL=KPag2-KPag1
  12391.     If(K3Dfg.le.0)jpdl=0
  12392. c skip second deltas if only one range
  12393.     if(kivvv.eq.0)goto 7021
  12394.     IF(kpagmd.eq.0.and.
  12395.      1  JD1A.NE.JD2A.AND.JD1B.NE.JD2B)GOTO 7306
  12396.     JDELT=MAX0(IABS(JD1A-JD2A),IABS(JD1B-JD2B),
  12397.      1    JPDL)+1
  12398. 7306    JDELT=MIN0(IDELT,JDELT)
  12399. C For page mode, difference is depth, not row or cols.
  12400.     if(k3dfg.gt.0.and.kpagmd.ne.0.and.jpdl.gt.0)
  12401.      1  jdelt=jpdl+1
  12402. 7021    continue
  12403.     ASSIGN 7307 TO JBACK
  12404. C 8HERE WE SET UP I1IN AND I2IN ASSUMING THAT THE VARIABLES
  12405. C ARE SET PROPERLY. HANDLED AS AN INTERNAL PROCEDURE.
  12406.     GOTO 8109
  12407. 7307    CONTINUE
  12408. C 8edure also resets IDELT
  12409.     if(kivvv.eq.0)goto 7308
  12410.     If(k3dfg.gt.0)IDelt=IKDelt
  12411.     JIN1=1
  12412.     JIN2=0
  12413.     IF(JD1B.EQ.JD2B)GOTO 7308
  12414.     JIN1=0
  12415.     JIN2=1
  12416. 7308    CONTINUE
  12417. C
  12418. C Change for 3D depth ranges:
  12419. C Reset I1IN and I2IN to KRDELT and KCDELT if depth mode and
  12420. C 3D stuff enabled. Reset JIN1 and JIN2 likewise if depth
  12421. C mode there.
  12422. C This has the advantage that it allows cells to be plotted
  12423. C with any one dimensional range and any other, even if one
  12424. C or both 1-D ranges are in depth.
  12425.     If(K3DFG.LE.0)goto 7610
  12426.        If(LPagmd.le.0)goto 7611
  12427.     I1IN=KCDELT
  12428.     I2IN=KRDELT
  12429. 7611    Continue
  12430.     if(kivvv.eq.0)goto 7610
  12431.        If(KPagmd.le.0)goto 7610
  12432.     JIN1=KCDELT
  12433.     JIN2=KRDELT
  12434. 7610    continue
  12435. c******
  12436. C here we just do the opens of cells and write their values out.
  12437.     DO 7309 JV=1,JDELT
  12438. c    CALL REFLEC(JD1B,JD1A,JRXX)
  12439. c    CALL REFLEC(ID2A,ID1A,IRXX)
  12440. C don't care if the cells are invalid...they just return 0 if so.
  12441.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  12442.     xx1=xvbls(1,1)
  12443.     if(kivvv.ne.0)CALL XVBLGT(JD1A,JD1B,XVBLS(1,1))
  12444.     xx2=xvbls(1,1)
  12445.     if(kivvv.eq.0)write(16,7310)xx1
  12446.     if(kivvv.ne.0)write(16,7310)xx1,xx2
  12447. 7310    Format(1pe15.9,2x,1pe15.9)
  12448.     ID1A=ID1A+I1IN
  12449.     ID2A=ID2A+I2IN
  12450.     JD1A=JD1A+JIN1
  12451.     JD1B=JD1B+JIN2
  12452. 7309    CONTINUE
  12453. C RETURN POINT FROM COPY LOOP IN NORMAL COPY
  12454.     close(unit=16)
  12455. c spawn the command now
  12456.     open(16,file='titleinfo.txt',status='unknown')
  12457.     call wrkfil(24,form2,0)
  12458. c get X accumulator and load its' title in
  12459.     write(16,7313)(form2(iv),iv=1,80)
  12460. 7313    format(80a1)
  12461.     call wrkfil(25,form2,0)
  12462.     write(16,7313)(form2(iv),iv=1,80)
  12463. c this puts the contents of the X and Y accumulators in the file.
  12464. C add the Z accumulator also
  12465.     call wrkfil(26,form2,0)
  12466.     write(16,7313)(form2(iv),iv=1,80)
  12467.     close(unit=16)
  12468.     if(lhich.eq.0)goto 7311
  12469.     cmdlin(lhich+1)=char(0)
  12470. c hack for amiga...stick "$" at start of cmd so it'll do the endcli
  12471. c for us automatically.
  12472.     lochr=lochr-1
  12473.     cmdlin(lochr)='$'
  12474.     call xsystem(cmdlin(lochr))
  12475.     goto 9990
  12476. 7311    continue
  12477.     defplt(24)=char(0)
  12478.     call xsystem(defplt(1))
  12479.     goto 9990
  12480. 8014    CONTINUE
  12481. 8015    IF(CMDLIN(1).NE.'G')GOTO 8016
  12482. C GET INPUT NUMBERS OFF SEQUENTIAL FILE. USE CURRENT ORIGIN
  12483.     ICODE=2
  12484.     IRTN=0
  12485.     CALL PGGET(CMDLIN,ICODE,IRTN)
  12486.     IF(IRTN.EQ.1)GOTO 510
  12487. C FLAG WE NEED AT LEAST ONE FULL CALC BEFORE GOING TO PARTIALS...
  12488. C (OK TOO IF IN OLD RCMODE=0 MODE)
  12489.     RCMODE=-IABS(RCMODE)
  12490.     GOTO 9990
  12491. 8016    IF(CMDLIN(1).NE.'W')GOTO 8017
  12492. C WRITE (PRINT) SCREEN OUT TO FILE (MAY BE PRINTER)
  12493. C    CALL DSPSHT(10)
  12494. C    ICODE=1
  12495.     ICODE=400
  12496. C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
  12497.     GOTO 9990
  12498. 8017    CONTINUE
  12499.     IF(CMDLIN(1).NE.'H')GOTO 5019
  12500.     IF(IPSET.NE.0)GOTO 9990
  12501.     IVVV=0
  12502.     IVVVV=ICHAR(CMDLIN(2))
  12503.     ivvx=ICHAR(cmdlin(3))
  12504. 9308    CONTINUE
  12505.     IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
  12506.     if(ivvx.lt.48.or.ivvx.gt.57)goto 9381
  12507. c implement 2 digit help code.
  12508.     ivvvx=ivvx-48
  12509.     ivvv=(ivvv*10)+ivvvx
  12510.     ivvv=min0(ivvv,99)
  12511. 9381    continue
  12512. C SELECT HELP LEVEL 0-9 IF SPECIFIED.
  12513.     ICODE=30+IVVV
  12514.     GOTO 9990
  12515. 5019    CONTINUE
  12516. C *** ALLOW EVALUATION OF A CELL TO PERMIT INTERACTIVE COMMAND FILES TO
  12517. C *** BE CONTROLLED RATIONALLY. KEYWORD IS "TEST"
  12518.     IF(CMDLIN(1).NE.'T'.OR.CMDLIN(2).NE.'E')GOTO 4302
  12519. C TEST EXPRESSION IS SYNTAX.
  12520. C COPY CMDLIN INTO XTNCMD AND FLAG VIA ICODE=430
  12521.     XTNCNT=0
  12522.     ICODE=430
  12523.     DO 4307 N=1,80
  12524. 4307    XTNCMD(N)=Char(0)
  12525. C FIRST ZERO OUT EXTERNAL CMD LINE, THEN FILL IN WHAT'S NEEDED.
  12526.     DO 4303 N=1,79
  12527.     XTNCMD(N)=CMDLIN(3+N)
  12528. C ALLOW "TE <ANY EXPRESSION>" WITH OPTIONAL SPACE. JUST RETURNS VALUE IN
  12529. C % VARIABLE.
  12530.     IF(ICHAR(XTNCMD(N)).LT.32)GOTO 4304
  12531.     XTNCNT=N
  12532. 4303    CONTINUE
  12533. 4304    CONTINUE
  12534.     XTNCMD(XTNCNT+1)=Char(0)
  12535.     GOTO 9990
  12536. 4302    CONTINUE
  12537. C LET DOUBLE DOT (..) INDICATE TO GO BACK TO CONSOLE, CLOSING INPUT FILE
  12538.     IF (CMDLIN(1).EQ.'.'.AND.CMDLIN(2).EQ.'.')GOTO 510
  12539. C ELSE PRINT MESSAGE THAT WE DON'T UNDERSTAND THAT ONE & GO ON
  12540. C PRINT INVALID CMD MSG IF NOT JUST A SPACE OR C.R.
  12541.     IF(ICHAR(CMDLIN(1)).GT.32)CALL SWRT('Invalid Command.',16)
  12542.     GOTO 200
  12543. C ERROR ON READIN ADDRESS. REWIND TERMINAL IF USER
  12544. C TYPES CTRL Z (EOF), ELSE LEAVE INDIRECT FILES.
  12545. 510    CONTINUE
  12546. C    IF(IOLVL.EQ.5)REWIND 5
  12547.     CLOSE(3)
  12548. c    CLOSE(11)
  12549. c    Rewind 11
  12550. c    OPEN(11,FILE='CON:0/0/100/100/Analy Command')
  12551.     IOLVL=11
  12552.     GOTO 498
  12553. 9990    CONTINUE
  12554. C HERE CLEAN UP AND RETURN
  12555. C FIRST DISPLAY LAST CURRENT COL IN NORMAL VIDEO
  12556.     IF(IXLSTR.LE.0.OR.IXLSTC.LE.0)GOTO 2000
  12557.     N1=NRDSP(IXLSTR,IXLSTC)
  12558.     N2=NCDSP(IXLSTR,IXLSTC)
  12559. C    IRRX=(N2-1)*60+N1
  12560.     CALL REFLEC(N2,N1,IRRX)
  12561. C REWRITE LAST LOCATION WITH NO REVERSE VIDEO.
  12562. C    IF(FVLD(N1,N2).EQ.0)GOTO 2000
  12563.     IF(IXLSTC.GT.DCLV.OR.IXLSTR.GT.DRWV)GOTO 2000
  12564. C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
  12565.     IF(ICODE.LT.0.OR.ICODE.EQ.2)GOTO 2000
  12566. C NO SENSE REDRAWING IF WE'RE ABOUT TO ERASE DISPLAY ANYWAY.
  12567.     IF(ICODE.GT.30)GOTO 2000
  12568.     J=8
  12569. C ADD 6 COLS FOR LABELS
  12570. C DROW,DCOL IS CURRENT DISPLAY LOC.
  12571.     DO 3301 M1=1,IXLSTR
  12572. C FIND DISPLAY COLUMN TO USE
  12573. 3301    J=J+CWIDS(M1)
  12574.     J=J-CWIDS(IXLSTR)
  12575. C USE THISCL+1 TO LET 1ST ROW BE LABELS.
  12576.     ICCC=IXLSTC+2
  12577. C JVTINC = 1 IF VT100, 0 IF VT52
  12578. C JVTINC NEEDED SINCE UVT100 FOR VT100 DOES BACKSPACE AT THE SGR ENTRY
  12579. C AND THUS WE NEED TO CORRECT FOR IT. THIS WAS FIXED IN THE UVT52
  12580. C VERSION AND ITS DESCENDANTS.
  12581.     IC1POS=N1
  12582.     IC2POS=N2
  12583.     IF(PZAP.NE.0)GOTO 2000
  12584.     CALL UVT100(1,ICCC,J)
  12585. C SELECT ROW "IXLSTC", COL "J"
  12586.     CALL UVT100(13,0,0)
  12587. C DESELECT REVERSE VIDEO
  12588.     CALL FVLDGT(N1,N2,FVLDTP)
  12589.     ivv=min0(30,cwids(IXLSTR))
  12590.     IF(ICHAR(FVLDTP).EQ.0)CALL SWRT(BLANKS,IVV)
  12591.     IF(ICHAR(FVLDTP).EQ.0)GOTO 2000
  12592.     CALL WRKFIL(IRRX,FORM2,0)
  12593.     CALL CE2A(FORM2,FORM)
  12594. C    READ(7'IRRX)FORM
  12595.     DO 5546 KKKK=1,100
  12596.     IV=ICHAR(FORM(KKKK))
  12597.     IV=MAX0(IV,32)
  12598. 5546    FORM(KKKK)=Char(IV)
  12599.     IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
  12600.      1  WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
  12601. C FILL IN TEXT FOR FORMULA IF FVLD < 0 HERE; BELOW, FILL IN VALUE TEXT IF FVLD
  12602. C > 0.
  12603.     IF(FORMFG.NE.0)GOTO 4324
  12604. C ALWAYS DO FORMULAS IF FORMFG SET (VF MODE).
  12605.     DO 6302 KKK=1,9
  12606.     KKKK=ICHAR(FORM(KKK+119))
  12607. C    KKKK=DFMTS(KKK,IXLSTR,IXLSTC)
  12608. 6302    DFE(KKK+1)=CHAR(MAX0(32,KKKK))
  12609.     DFE(11)=char(32)
  12610. C 32 = ASCII SPACE
  12611.     DFE(1)='('
  12612. C REMEMBER: NO \ EDITING IN INTERNAL WRITES!
  12613.     DFE(12)=' '
  12614.     DFE(13)=' '
  12615.     DFE(14)=')'
  12616.     CALL TYPGET(N1,N2,TYPE(1,1))
  12617.     IF(JCHAR(FVLDTP).LE.0)GOTO 4324
  12618.     IF(TYPE(1,1).NE.2)GOTO 6226
  12619.         WRITE(CMDLNA(1:127),DFE,ERR=4324)DVS(IXLSTR,IXLSTC)
  12620.     GOTO 4324
  12621. 6226    CONTINUE
  12622.     WRITE(CMDLNA(1:127),DFE,ERR=4324)LDVS(1,IXLSTR,IXLSTC)
  12623. C REDRAW THIS COL. WITHOUT REVERSE VIDEO HERE.
  12624. 4324    CALL SWRT(CMDLIN,CWIDS(IXLSTR))
  12625. C NOTE THIS REDRAWS PREVIOUS COL. IN NORMAL VIDEO.
  12626. C NO CARRIAGE CTL
  12627. 2000    CONTINUE
  12628. C NOW COMPLETE ANY CLEANUP.
  12629. C SET CMDLIN TO 0 AT START TO INHIBIT ANY MISINTERPRETATION.
  12630. C WE USE CMDLIN AS A BUFFER IN REDRAWIND DSPLY SO DON'T LET IT GET
  12631. C CLOBBERED.
  12632.     DO 945 K=1,132
  12633. 945    CMDLIN(K)=Char(0)
  12634.     RETURN
  12635.     END
  12636.  
  12637. C *************** AnalyNS.Ftn #####################################
  12638. c -h- nextel.fms    Tue Sep  2 10:58:55 1986    
  12639.     SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
  12640. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  12641. C ALL RIGHTS RESERVED
  12642.     Include aparms.inc
  12643. C
  12644. C  SCANS LINE(80) FROM NONBLK+1 AND RETURNS THE NEXT ELEMENT.
  12645. C  THIS ELEMENT COULD BE A CONSTANT, VALUE OF A VARIABLE, A
  12646. C  BINARY FUNCTION CODE, OR A UNARY FUNCTION CODE. UPON RETURN,
  12647. C  NONBLK POINTS TO LAST CHARACTER OF NEXT ELEMENT.
  12648. C
  12649. C  RETCD  =    1  IF OPERAND (VALUE IN RETVAL(100)
  12650. C        2  IF OPERATOR (VALUE IN RETTYP)
  12651. C        3  NO MORE ELEMENTS
  12652. C        4  IF ERROR
  12653. C
  12654. C  RETVAL  HOLDS VALUE OF OPERAND FOUND (EITHER CONSTANT OR IF
  12655. C       A VARIABLE (A-Z,%), THE VALUE OF THAT VARIABLE)
  12656. C
  12657. C  RETTYP  IS THE TYPE CODE
  12658. C NEXTEL CALLS
  12659. C
  12660. C ERRMSG     PRINTS OUT ERROR MESSAGES
  12661. C FLIP       REVERSES THE NON-LEADING ZERO DIGITS IN A VECTOR
  12662. C GETNNB     GETS THE NEXT NON-BLANK FROM LINE(80)
  12663. C
  12664. C NEXTEL IS CALLED BY INPOST
  12665. C
  12666. C
  12667. C    VARIABLE    USE
  12668. C    ---------   ----------------------------------
  12669. C
  12670. C    ALPHA(27)   HOLDS LEGAL VARIABLE NAMES.
  12671. C
  12672. C    ARROW       '^'
  12673. C
  12674. C    B10         SWITCH SET WHEN CONSTANT IS NOT OCTAL (MAY BE
  12675. C                DECIMAL OR HEX BECAUSE THE DIGIT 8 OR 9 WAS FOUND).
  12676. C
  12677. C    B16         SWITCH SET WHEN CONSTANT IS HEXADECIMAL BECAUSE
  12678. C                DIGIT A, B, C, D, E, OR F WAS FOUND.
  12679. C
  12680. C    BASE        HOLDS BASE OF CONSTANT.
  12681. C
  12682. C    CHAR1       HOLDS A SINGLE CHARACTER FROM LINE.
  12683. C
  12684. C    DEFBAS      THE DEFAULT BASE SPECIFIED.
  12685. C
  12686. C    DIGITS(16,3) HOLDS ASCII CHARACTERS FOR THE DIGITS OF BASES
  12687. C                 8, 10, AND 16.
  12688. C
  12689. C    DOT          '.'
  12690. C
  12691. C    EQ           '='
  12692. C
  12693. C    EXCODE       CODE FOR EXPONENTIATION.
  12694. C
  12695. C    FCNT         NUMBER OF UNARY FUNCTIONS DEFINED BY VECTOR FUNCT
  12696. C
  12697. C    FUNCT (NAME,INDXX) HOLDS FUNCTION NAMES.
  12698. C
  12699. C    FUNVAL(I,J)
  12700. C     IF I=1, THE VALUE IS THE NUMBER OF CHARACTERS IN THE J-TH
  12701. C             FUNCTION WHOSE NAME IS THE FUNCT(K,J) WHERE K=1,2,3...10
  12702. C     IF I=2, THE VALUE IS THE STACK ELEMENT CODE FOR THE J-TH
  12703. C             FUNCTION WHOSE NAME IS IN FUNCT(K,J), K=1,2,3...10
  12704. C
  12705. C
  12706. C    I,J,K,L  HOLDS TEMPORARY VALUES
  12707. C
  12708. C    I1,I2    HOLD VALUE OF DIGITS IN E OR D SPECIFICATION.
  12709. C
  12710. C    IALPHA   INDEX INTO ALPHA OF THE FIRST NON-BLANK CHARACTER FOUND.
  12711. C
  12712. C    IHOLD    HOLDS TEMPORARY VALUES
  12713. C
  12714. C    INT      PICKS UP INTEGER*4 VALUES.
  12715. C
  12716. C    IPT      POINTER TO ELEMENTS IN LINE(80).
  12717. C
  12718. C    IPT2     POINTER TO ELEMENTS IN LINE(80).
  12719. C
  12720. C    LASTOP  USED TO HOLD VALUE OF LAST OPERATOR SO THAT UNARY OPERATORS
  12721. C            CAN BE IDENTIFIED IN CASES LIKE A*-B AND A/(-3).
  12722. C
  12723. C    MINUS   '-'
  12724. C
  12725. C    OPER(9) HOLDS LEGAL ONE CHARACTER OPERATORS LIKE '+' AND '*'.
  12726. C
  12727. C    PLUS    '+'
  12728. C
  12729. C    QUOTE   "'"
  12730. C
  12731. C    RB      HOLDS NEGATIVE POWERS OF 10.(BASE 10)
  12732. C
  12733. C    REAL    PICKS UP REAL*8 CONSTANTS.
  12734. C
  12735. C    RETCD   RETURN CODE:
  12736. C              1 IF OPERAND (VALUE IN RETVAL(100))
  12737. C              2 IF OPERATOR (VALUE IN RETTYP)
  12738. C              3 NO MORE ELEMENTS.
  12739. C              4 IF ERROR.
  12740. C
  12741. C    RETCD2  RETURN CODE WHEN CALLING GETNNB.
  12742. C
  12743. C    RETPT   INDEXES DIGITS PICKED UP FOR A CONSTANT.
  12744. C
  12745. C    RETTYP  THE TYPE CODE OF THE RETURNED ELEMENT.
  12746. C
  12747. C    TYPE    TYPE CODE FOR EACH VARIABLE.
  12748. C
  12749. C    VBLS    HOLDS VALUE OF VARIABLES.
  12750. C
  12751. C    VLEN    GIVES LENGTH IN BYTES FOR EACH DATA TYPE.
  12752. C
  12753. C LASTOP MUST BE SET TO ZERO AT START OF EXPRESSION
  12754. C
  12755. C
  12756.     REAL*8 REAL,RB,ACX,XAC
  12757.     INTEGER*4 INT
  12758.     EXTERNAL INDX,DFLOAT
  12759.     REAL*8 DFLOAT
  12760. c    InTeGer*4 INDXX
  12761.     InTeGer*4 LEVEL,NONBLK,LEND
  12762.     InTeGer*4 LASTOP
  12763.     InTeGer*4 VIEWSW,BASED,VLEN(9),DEFBAS
  12764.     InTeGer*4 TYPE(1,2)
  12765.     InTeGer*4 RETCD,RETCD2,RETTYP,EXCODE
  12766.     InTeGer*4 B10,B16,RETPT,BASE
  12767.     InTeGer*4 FCNT
  12768.     InTeGer*4 I,J,K,L,IALPHA,IHOLD,IPT,IPT2,I1,I2
  12769. C
  12770.     CHARACTER*1 CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
  12771.     CHARACTER*1 RETVAL(20)
  12772.     integer*4 RVLF(5)
  12773.     real*8 frvlf
  12774.     character*1 crvlf(20)
  12775.     equivalence(frvlf,rvlf(1),crvlf(1))
  12776. c    EQUIVALENCE (RVLF(1),RETVAL(1))
  12777.     CHARACTER*1 FUNCT(10,40)
  12778.     InTeGer*4   FUNVAL(2,40)
  12779.     CHARACTER*1 AVBLS(24,27)
  12780.     Real*8 VAVBLS(3,27)
  12781.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  12782.     EQUIVALENCE(XAC,AVBLS(1,27))
  12783.     CHARACTER*1 VBLS(8,1,1)
  12784.     CHARACTER*1 OPER(9),DIGITS(16,3)
  12785.     CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  12786.     CHARACTER*1 FOUR(4),EIGHT(8)
  12787. C
  12788.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  12789.     COMMON /DIGV/ DIGITS
  12790.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  12791.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  12792. C ***<<< KLSTO COMMON START >>>***
  12793.     InTeGer*4 DLFG
  12794. C    COMMON/DLFG/DLFG
  12795.     InTeGer*4 KDRW,KDCL
  12796. C    COMMON/DOT/KDRW,KDCL
  12797.     InTeGer*4 DTRENA
  12798. C    COMMON/DTRCMN/DTRENA
  12799.     REAL*8 EP,PV,FV
  12800.     DIMENSION EP(20)
  12801.     INTEGER*4 KIRR
  12802. C    COMMON/ERNPER/EP,PV,FV,KIRR
  12803. c    InTeGer*4 LASTOP
  12804. C    COMMON/ERROR/LASTOP
  12805.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  12806. C    COMMON/FMTBFR/FMTDAT
  12807.     CHARACTER*1 EDNAM(16)
  12808. C    COMMON/EDNAM/EDNAM
  12809.     InTeGer*4 MFID(2),MFMOD(2)
  12810. C    COMMON/FRM/MFID,MFMOD
  12811.     InTeGer*4 JMVFG,JMVOLD
  12812. C    COMMON/FUBAR/JMVFG,JMVOLD
  12813.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  12814.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  12815. C ***<<< KLSTO COMMON END >>>***
  12816. CCC    COMMON /ERROR/ LASTOP
  12817. C
  12818.     EQUIVALENCE (REAL,EIGHT),(FOUR,INT)
  12819. C
  12820.     save dot,arrow,quote,star,minus,plus,oper,funct,funval
  12821.     save excode,fcnt
  12822.     DATA DOT/'.'/,ARROW/'^'/,QUOTE/''''/,STAR/'*'/
  12823.     DATA MINUS/'-'/,PLUS/'+'/
  12824.     DATA OPER/'(','-','!','*','/','+','-',')','='/
  12825. C
  12826. C  NUMBER OF FUNCTIONS
  12827.     DATA FCNT/30/
  12828. C
  12829.     DATA FUNCT/'A','B','S',' ',' ',' ',' ',' ',' ', ' ',
  12830.      1             'D','A','B','S',' ',' ',' ',' ',' ',' ',
  12831.      2             'I','A','B','S',' ',' ',' ',' ',' ',' ',
  12832.      3             'F','L','O','A','T',5*' ','I','F','I','X',6*' ',
  12833.      5             'A','I','N','T',6*' ','I','N','T',7*' ',
  12834.      7             'I','D','I','N','T',5*' ','E','X','P',7*' ',
  12835.      9             'D','E','X','P',6*' ','A','L','O','G','1','0',4*' ',
  12836.      2             'D','L','O','G','1','0',4*' ','A','L','O','G',6*' ',
  12837.      4             'D','L','O','G',6*' ','S','Q','R','T',6*' ',
  12838.      6             'D','S','Q','R','T',5*' ','S','I','N',7*' ',
  12839.      8             'D','S','I','N',6*' ','C','O','S',7*' ',
  12840.      1             'D','C','O','S',6*' ','T','A','N','H',6*' ',
  12841.      2             'D','T','A','N','H',5*' ','A','T','A','N',6*' ',
  12842.      3             'D','A','T','A','N',5*' ',
  12843.      1             'A','S','I','N',6*' ','D','A','S','I','N',5*' ',
  12844.      2             'A','C','O','S',6*' ','D','A','C','O','S',5*' ',
  12845.      3             'T','A','N',' ',6*' ','D','T','A','N',106*' '/
  12846.     DATA EXCODE/112/
  12847.        DATA FUNVAL/3,31,4,31,4,32,5,33,4,34,4,35,3,36,5,36,3,37,4,37,
  12848.      1 6,39,6,39,4,38,4,38,4,40,5,40,3,41,4,41,3,42,4,42,4,43,5,43,
  12849.      2       4,44,5,44,4,45,5,45,4,46,5,46,3,47,4,47,20*0/
  12850. C
  12851. 10    CONTINUE
  12852.     CALL GETNNB(IPT,RETCD2)
  12853.     IF (RETCD2.EQ.1) GOTO 50
  12854. C
  12855. C  NO MORE ELEMENTS
  12856.     LASTOP=0
  12857.     RETCD=3
  12858.     RETURN
  12859. C
  12860. C
  12861. C  INITIALIZE VARIABLES
  12862. 50    CONTINUE
  12863.     B10=0
  12864.     B16=0
  12865.     RETTYP=0
  12866.     RETPT=0
  12867.     REAL=0.D0
  12868.     RETCD=1
  12869.     DEFBAS=BASED
  12870. C    RVLF=0.0D0
  12871. C COMMENT OUT DO LOOP OVER 20 BYTES FOR SPEED.
  12872. C (INSTEAD JUST ZERO 8 BYTES WE WILL LIKELY USE)
  12873.     DO 60 I=1,8
  12874. C    DO 60 I=1,20
  12875. 60    RETVAL(I)=char(0)
  12876. c    Rvlf(1)=0
  12877. c    Rvlf(2)=0
  12878. C
  12879. 70    CHAR1=LINE(IPT)
  12880.     NONBLK=IPT
  12881. C
  12882. C
  12883. C  SEE IF ALPHABETIC OR %
  12884. C SHORTCUT IF IT'S A CELL NAME .. GO JUST EVALUATE IT.
  12885. C ALSO WORKS FOR ENCODED FUNCT NAMES.
  12886.     IF(ICHAR(CHAR1).GE.255)GOTO 12000
  12887. C SEPARATE OUT FUNCTION CALLS FOR FASTER EXECUTION...SKIP TRYING FUNCT. NAME
  12888. C FIRST AS VARIABLE NAME (WHICH CAN TAKE LONG TIME TO CONVERT BEFORE WE DISCOVER
  12889. C IT ISN'T NEEDED...)
  12890. C
  12891.     IF(ICHAR(CHAR1).GE.230)GOTO 13201
  12892. C ADD COUPLE MORE SHORTCUTS... DON'T JUST LOOP TO SEE IF WE HAVE
  12893. C AN ALPHA CHARACTER...
  12894.     IF(CHAR1.NE.ALPHA(27))GOTO 78
  12895.     I=27
  12896.     GOTO 10000
  12897. 78    CONTINUE
  12898.     IF(CHAR1.LT.'A'.OR.CHAR1.GT.'Z')GOTO 79
  12899. C TRY TO AVOID LOTS OF EXTRA FUNCTION CALLS...
  12900. C COMPARE CHARS AS CHARACTER VALUES... SHOULD STILL BE OK.
  12901. CCC    IF(ICHAR(CHAR1).LT.ICHAR(ALPHA(1))
  12902. CCC     1  .OR.ICHAR(CHAR1).GT.ICHAR(ALPHA(26)))GOTO 79
  12903. C USE FACT THAT ASCII CHARACTER CODES ARE IN A CONTINUOUS RANGE
  12904. CCC    I=ICHAR(CHAR1)-ICHAR(ALPHA(1))
  12905.     I=ICHAR(CHAR1)-65
  12906. C 65 IS ASCII VALUE FOR 'A' CHARACTER.
  12907. C (HARDCODE FOR SPEED...)
  12908.     GOTO 10000
  12909. 79    CONTINUE
  12910. C DELETE 3 LINES FOLLOWING:
  12911. C    DO 80 I=1,27
  12912. C    IF (CHAR1.EQ.ALPHA(I)) GOTO 10000
  12913. C80    CONTINUE
  12914. C
  12915. C
  12916. C  NOT ALPHA SO SEE IF AN OPERATOR
  12917.     DO 100 I=1,9
  12918.     IF (CHAR1.EQ.OPER(I)) GOTO 20000
  12919. 100    CONTINUE
  12920. C
  12921. C
  12922. C SEE IF AN OPERAND
  12923. C *** EVIDENTLY SHORT LOOP RUNS AS FAST AS A COUPLE DECISIONS AND SOME
  12924. C MATH; LEAVE IN.
  12925. 140    DO 150 I=1,16
  12926.     IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
  12927. 150    CONTINUE
  12928. C
  12929. C
  12930. C
  12931.     IF (CHAR1.EQ.DOT) GOTO 40000
  12932. C
  12933. C
  12934. C
  12935.     IF (CHAR1.EQ.ARROW) GOTO 300
  12936. C
  12937. C
  12938. C
  12939.     IF (CHAR1.EQ.QUOTE) GOTO 200
  12940. C
  12941. C
  12942. C  ADDITIONAL CONSTANT OPERATOR WOULD GO HERE
  12943. C
  12944. C
  12945. C *** ERROR *** ILLEGAL CHARACTER ENCOUNTERED
  12946. 190    CALL ERRMSG (20)
  12947.     GOTO 99000
  12948. C
  12949. C
  12950. C
  12951. C
  12952. C **************************************
  12953. C ****** ASCII CONSTANT SPECIFIED ******
  12954. C **************************************
  12955. 200    CONTINUE
  12956.     NONBLK=NONBLK+1
  12957.     RETVAL(1)=LINE(NONBLK)
  12958.     RETTYP=1
  12959.     GOTO 35100
  12960. C
  12961. C
  12962. C
  12963. C
  12964. C **************************************
  12965. C ****** IMMEDIATE BASE SPECIFIED ******
  12966. C **************************************
  12967. 300    CALL GETNNB(IPT,RETCD2)
  12968.     IF (RETCD2.EQ.1) GOTO 320
  12969. C
  12970. C
  12971. C *** ERROR *** ILLEGAL BASE SPECIFICATION
  12972. 310    CALL ERRMSG(19)
  12973.     GOTO 99000
  12974. C
  12975. C
  12976. C  IMMEDIATE BASE SPECIFICATION
  12977. 320    CHAR1=LINE(IPT)
  12978.     NONBLK=IPT
  12979.     IF (CHAR1.EQ.DIGITS(8,3)) GOTO 360
  12980.     IF (CHAR1.NE.DIGITS(1,3)) GOTO 310
  12981. C
  12982. C
  12983. C FIRST DIGIT IS 1 SO IMMEDIATE BASE MIGHT BE 10 OR 16
  12984.     CALL GETNNB (IPT,RETCD2)
  12985.     IF (RETCD2.EQ.2) GOTO 310
  12986.     CHAR1=LINE(IPT)
  12987.     NONBLK=IPT
  12988.     IF (CHAR1.EQ.DIGITS(10,1)) GOTO 365
  12989.     IF (CHAR1.NE.DIGITS(6,1)) GOTO 310
  12990. C
  12991. C
  12992. C IMMEDIATE BASE IS 16
  12993.     DEFBAS=16
  12994.     GOTO 370
  12995. C
  12996. C
  12997. C IMMEDIATE BASE IS 8
  12998. 360    DEFBAS=8
  12999.     GOTO 370
  13000. C
  13001. C
  13002. C IMMEDIATE BASE IS 10
  13003. 365    DEFBAS=10
  13004. C
  13005. C
  13006. C
  13007. 370    CALL GETNNB(IPT,RETCD2)
  13008.     IF (RETCD2.EQ.2) GOTO 310
  13009.     CHAR1=LINE(IPT)
  13010.     NONBLK=IPT
  13011. C
  13012. C
  13013. C GO FIND OUT WHAT NUMBER HAS THAT DEFAULT BASE
  13014.     GOTO 140
  13015. C
  13016. C
  13017. C
  13018. C
  13019. C ****************************************************
  13020. C ****** SEARCH TO SEE IF A UNARY FUNCTION NAME ******
  13021. C ****************************************************
  13022. 10000    CONTINUE
  13023.     IALPHA=I
  13024.     IHOLD=NONBLK
  13025. C
  13026. C
  13027. C SCAN EACH OF THE FUNCTION NAMES.
  13028.     DO 10060 I=1,FCNT
  13029. C
  13030. C K HOLDS NUMBER OF NON-BLANK CHARACTERS IN THE FUNCTION NAME.
  13031.     K=FUNVAL(1,I)
  13032.     IPT2=IHOLD
  13033.     NONBLK=IHOLD
  13034.     IF (K.EQ.0) GOTO 10060
  13035. C
  13036. C
  13037. C SCAN EACH LETTER OF THE FUNCTION'S NAME
  13038.     DO 10050 J=1,K
  13039.     IF (LINE(IPT2).NE.FUNCT(J,I)) GOTO 10060
  13040.     IF (J.EQ.K) GOTO 10100
  13041.     CALL GETNNB (IPT2,RETCD2)
  13042.     IF (RETCD2.EQ.2) GOTO 10060
  13043.     NONBLK=IPT2
  13044. 10050    CONTINUE
  13045.     STOP 10050
  13046. C
  13047. 10060    CONTINUE
  13048. 10070    NONBLK=IHOLD
  13049.     GOTO 12000
  13050. C
  13051. C
  13052. C  FUNCTION FOUND (LEAVES NONBLK POINTING AT LAST CHARACTER)
  13053. 10100    CONTINUE
  13054. C
  13055. C
  13056. C
  13057. C
  13058. C **********************************
  13059. C ****** UNARY FUNCTION FOUND ******
  13060. C **********************************
  13061.     RETTYP=ICHAR(CHAR(FUNVAL(2,I)))
  13062.     LASTOP=RETTYP
  13063.     RETCD=2
  13064.     GOTO 99099
  13065. C
  13066. C
  13067. C
  13068. C
  13069. C
  13070. C ********************************
  13071. C ****** VARIABLE SPECIFIED ******
  13072. C ********************************
  13073. 12000    CONTINUE
  13074. C
  13075. C
  13076. C  IALPHA HOLDS INDEX INTO ALPHA OF NAME
  13077. C ******&&&&&& REMOVE BLK OF CODE STARTING HERE...
  13078. C    CALL GETNNB (IPT,RETCD2)
  13079. C    IF (RETCD2.EQ.2) GOTO 12060
  13080. CC
  13081. CC
  13082. CC MAKE SURE NEXT CHARACTER IS NOT ALPHA
  13083. C    DO 12050 I=1,27
  13084. C    IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
  13085. C12050    CONTINUE
  13086. C *****&&&&& ...ENDING HERE
  13087. C ADD BELOW...
  13088.     LLB=IPT
  13089.     LRB=LEND
  13090.     CALL VARSCN(LINE,LLB,LRB,LSTCHR,ID1,ID2,IVALID)
  13091. C    IF(IVALID.EQ.0)GOTO 12200
  13092. C    IPT=LSTCHR
  13093. C leave the following "60" in place. It's only roughly right
  13094. C (probably should be more like 30) but will do since funct.
  13095. C names are 3 chars...
  13096.     IF(IVALID.NE.0.AND.ID2.LE.1.AND.ID1.GT.60)GOTO 13201
  13097.     IF(IVALID.NE.0)GOTO 12201
  13098. C NOT VALID VARIABLE. SEE IF A 2 + ARGUMENT FUNCTION...
  13099. C
  13100. C COME HERE DIRECT FOR FUNCTIONS ENCODED...
  13101. 13201    CONTINUE
  13102.     I=IPT+9
  13103.     CALL FNAME(LINE(IPT),I,INDEXF)
  13104.     IF(INDEXF.EQ.6.OR.INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 12202
  13105. C NOW KNOW THERE IS A FUNCTION THERE, SO HANDLE IT.
  13106.     LLAST=LEND-IPT+1
  13107.     I=INDX(LINE(IPT),ICHAR(']'))
  13108.     IF(I.LE.0.OR.I.GT.LLAST)GOTO 12202
  13109.     LRB=I
  13110.     LLB=INDX(LINE(IPT),ICHAR('['))
  13111.     IF(LLB.LE.0.OR.LLB.GT.LLAST)GOTO 12202
  13112.     CALL DOMFCN(LINE(IPT),LLB,LRB,INDEXF,ACX)
  13113.     XAC=ACX
  13114.     TYPE(1,1)=2
  13115.     CALL TYPSET(1,27,TYPE(1,1))
  13116. C    TYPE(27,1)=2
  13117.     ID1=27
  13118.     ID2=1
  13119.     LSTCHR=LRB+IPT
  13120. C GO AND MERGE AS THOUGH WE JUST GOT A VARIABLE % AND HAD TO
  13121. C RETURN ITS VALUE.
  13122.     GOTO 12201
  13123. C IF NOT VALID FUNCTION REPORT AN ERROR.
  13124. 12202    GOTO 12200
  13125. 12201    IPT=LSTCHR
  13126.     IF(LSTCHR.LT.LEND)IPT=IPT-1
  13127.     NONBLK=IPT
  13128. C RESET NONBLK ALST SO WE RESET GETNNB TOO...
  13129. C WAS IPT=LSTCHR+1
  13130. C IPT POINTS AFTER VARIABLE NAME...
  13131. C ENSURE NON ALPHA AFTER VARIABLE NAME
  13132.     CALL GETNNB(IPT,RETCD2)
  13133.     IF(RETCD2.EQ.2) GOTO 12060
  13134. C
  13135. C IF THE NEXT CHARACTER IS AN = SIGN DON'T RETURN VALUE
  13136. C OF VARIABLE, JUST PUT INDEX INTO VBLS INTO LOWER BYTE
  13137. C OF RETVAL.
  13138.     IF (LINE(IPT).EQ.EQ) GOTO 12100
  13139. C
  13140. C
  13141. C ************************************************
  13142. C ****** RETURN VALUE OF VARIABLE SPECIFIED ******
  13143. C ************************************************
  13144. 12060    CALL TYPGET(ID1,ID2,RETTYP)
  13145. C12060    RETTYP=TYPE(ID1,ID2)
  13146. C *****&&&&&
  13147. C MUST CLAMP TYPES SO EXTENDED VARIABLES CAN'T BE MULT PRCN VRBLS.
  13148.     IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12061
  13149.     IF (RETTYP.EQ.5)RETTYP=4
  13150.     IF (RETTYP.EQ.6)RETTYP=8
  13151.     IF (RETTYP.EQ.7)RETTYP=3
  13152. 12061    CONTINUE
  13153.     IF(RETTYP.LE.0)GO TO 12080
  13154.     K=VLEN(RETTYP)
  13155.     if(id1.le.27.and.id2.eq.1)goto 12063
  13156.     call xvblgt(id1,id2,frvlf)
  13157. 12093    do 12064 kqkq=1,8
  13158.     retval(kqkq)=crvlf(kqkq)
  13159. 12064    continue
  13160.     goto 12080
  13161. 12063    continue
  13162.     DO 12070 I=1,K
  13163. C    CALL VBLGET(I,ID1,ID2,RETVAL(I))
  13164. C    RETVAL(I)=VBLS(I,ID1,ID2)
  13165. c    GOTO 12070
  13166. 12068    RETVAL(I)=AVBLS(I,ID1)
  13167. 12070    CONTINUE
  13168. C
  13169. 12080    LASTOP=RETTYP
  13170.     GOTO 99099
  13171. C
  13172. C
  13173. C
  13174. C *******************************************************
  13175. C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
  13176. C *******************************************************
  13177. 12100    CONTINUE
  13178. C    RETVAL(1)=IALPHA
  13179. C    RETTYP=TYPE(IALPHA)
  13180.     CALL TYPGET(ID1,ID2,TYPE(1,1))
  13181.     CALL RVBOO(RETVAL,ID1,ID2)
  13182. C RVBOO JUST STUFFS ID1,ID2 INTO RETVAL ARRAY
  13183. C AS 2 INTEGERS.
  13184.     RETTYP=TYPE(1,1)
  13185. c for unix or vms versions we may need to use
  13186. c    call rvboo(rvlf,id1,id2)
  13187. c    goto 12093
  13188. c 
  13189. c for absoft compiler we can however get away with just
  13190. c storing into retval direct.
  13191.     GOTO 12080
  13192. C
  13193. C
  13194. C
  13195. C *** ERROR *** UNIDENTIFIED FUNCTION
  13196. 12200    CALL ERRMSG(18)
  13197.     GOTO 99000
  13198. C
  13199. C
  13200. C
  13201. C
  13202. C
  13203. C **********************
  13204. C ****** OPERATOR ******
  13205. C **********************
  13206. C
  13207. C  I IS INDEX INTO OPER TO TELL WHAT OPERATOR IT IS
  13208. 20000    CONTINUE
  13209.     RETCD=2
  13210.     IF(I.NE.4)GO TO 20050
  13211. C
  13212. C
  13213. C IF AN ASTERISK IS FOUND THE NEXT CHARACTER MUST BE EXAMINED
  13214. C TO SEE IF '**' WAS SPECIFIED FOR EXPONENTIATION.
  13215.     CALL GETNNB (IPT,RETCD2)
  13216.     IF(RETCD2.NE.1)GO TO 99000
  13217.     IF (LINE(IPT).NE.STAR) GOTO 20050
  13218. C
  13219. C
  13220. C '**' SPECIFIED (EXPONENTIATION)
  13221.     RETTYP=EXCODE
  13222.     NONBLK=IPT
  13223.     GO TO 12080
  13224. C
  13225. C
  13226. C
  13227. C  SET DEFAULT RETTYP FOR OPERATORS
  13228. 20050    RETTYP=109+I
  13229. C
  13230. C
  13231. C  CHECK OUT POSSIBLE UNARY OPERATOR "-"
  13232.     IF (RETTYP.NE.111) GOTO 20080
  13233. C
  13234. C
  13235. C IF A MINUS IS ENCOUNTERED AND THERE WAS NO PREVIOUS ELEMENT OR
  13236. C IF PREVIOUS ELEMENT WAS AN OPERATOR OR = SIGN THEN OPERATOR
  13237. C IS UNARY.
  13238.     IF (LASTOP.EQ.0.OR.(LASTOP.GE.110.AND.LASTOP.LE.116).OR.
  13239.      ;      LASTOP.EQ.200) GOTO 20090
  13240. C
  13241. C
  13242. C  BINARY SUBTRACTION OPERATOR
  13243.     RETTYP=116
  13244.     GOTO 12080
  13245. C
  13246. C
  13247. C
  13248. C SEE IF A '+' SIGN
  13249. 20080    IF(RETTYP.NE.115)GO TO 20085
  13250. C
  13251. C
  13252. C DETERMINE IF IT IS A UNARY PLUS
  13253.     IF(LASTOP.NE.0.AND.LASTOP.LE.100)GO TO 20085
  13254. C
  13255. C
  13256. C SEE IF LAST OPERATOR WAS ')'
  13257.     IF(LASTOP.EQ.117)GO TO 20085
  13258. C
  13259. C
  13260. C UNARY '+' FOUND.
  13261.     RETCD=1
  13262.     GO TO 10
  13263. C
  13264. C
  13265. C
  13266. C RESET LASTOP TO 0 IF LEFT PARENTHESIS IS FOUND (CODE 110)
  13267. C IF RETTYP IS FOR =, SET TO PROPER CODE
  13268. 20085    IF(RETTYP.EQ.110)GO TO 20090
  13269.     IF(RETTYP.EQ.118)RETTYP=200
  13270.     GO TO 12080
  13271. C
  13272. C
  13273. C UNARY -
  13274. 20090    CONTINUE
  13275.     GOTO 99097
  13276. C
  13277. C
  13278. C
  13279. C
  13280. C
  13281. C
  13282. C *************************
  13283. C ****** NON-DECIMAL ******
  13284. C *************************
  13285. C
  13286. 30000    RETPT=RETPT+1
  13287.     IF (RETPT.LE.19) GOTO 30020
  13288. C
  13289. C
  13290. C *** ERROR *** MULTIPLE PRECISION IS LIMITED TO 19 DIGITS
  13291. C (ACTUALLY, NO LONGER PRESENT...)
  13292.     CALL ERRMSG(22)
  13293.     GOTO 99000
  13294. C
  13295. C
  13296. C  I HOLDS INDEX INTO DIGITS THAT WAS A MATCH.
  13297. C  SEE IF VALUE OF DIGIT IMPLIES A HIGHER BASE.
  13298. 30020    IF (I.NE.16) GOTO 30030
  13299.     I=0
  13300.     GOTO 30050
  13301. 30030    IF (I.EQ.8.OR.I.EQ.9) B10=1
  13302.     IF(I.GT.9) B16=1
  13303. 30050    RETVAL(RETPT)=CHAR(I)
  13304. C
  13305. C
  13306. C GET NEXT CHARACTER
  13307.     CALL GETNNB (IPT,RETCD2)
  13308.     IF (RETCD2.NE.1) GOTO 30100
  13309.     NONBLK=IPT
  13310.     CHAR1=LINE(IPT)
  13311.     DO 30070 I=1,16
  13312.     IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
  13313. 30070    CONTINUE
  13314.     IF (CHAR1.EQ.DOT) GOTO 40000
  13315.     NONBLK=NONBLK-1
  13316. 30100    CONTINUE
  13317. C
  13318.     IF (DEFBAS.EQ.16.OR.B16.EQ.1) GOTO 30200
  13319.     IF (DEFBAS.EQ.10.OR.B10.EQ.1) GOTO 30300
  13320. C
  13321. c add code here to check for non -calc mode and goto 40000 if so
  13322. c if defbas.ne.8 and if we're working on a floating number
  13323. C
  13324. C *****************************
  13325. C ****** BASE 8 CONSTANT ******
  13326. C *****************************
  13327.     BASE=8
  13328. C
  13329. C
  13330. C IF MORE THAN 10 DIGITS IT IS MULTIPLE PRECISION
  13331.     IF (RETPT.GT.10) GOTO 30170
  13332.     RETTYP=8
  13333. C
  13334. C
  13335. C  CONVERT TO OCTAL, HEX OR INTEGER
  13336. 30110    INT=0
  13337. 30130    DO 30132 L=1,7
  13338.     IF (ICHAR(RETVAL(L)).NE.0) GOTO 30140
  13339. 30132    CONTINUE
  13340. 30140    DO 30150 I=L,RETPT
  13341.     INT=INT*BASE+ICHAR(RETVAL(I))
  13342.     RETVAL(I)=char(0)
  13343. 30150    CONTINUE
  13344.     RETVAL(20)=char(0)
  13345. 30155    DO 30160 I=1,4
  13346. 30160    RETVAL(I)=FOUR(I)
  13347.     GOTO 35100
  13348. C
  13349. C
  13350. C ************************************************
  13351. C ****** MULTIPLE PRECISION BASE 8 CONSTANT ******
  13352. C ************************************************
  13353. 30170    RETTYP=6
  13354. 30180    CALL FLIP (RETVAL,8,RETPT)
  13355. c was 20 above, not 8 but we shortened stack arrays so shorten this
  13356.     GOTO 35100
  13357. C
  13358. C
  13359. C
  13360. C *********************
  13361. C ****** BASE 16 ******
  13362. C *********************
  13363. 30200    BASE=16
  13364. C
  13365. C
  13366. C IF MORE THAN 7 DIGITS IT IS MULTIPLE PRECISION.
  13367.     IF (RETPT.GT.7) GOTO 30270
  13368. C
  13369. C
  13370. C
  13371. C  HEXADECIMAL
  13372.     RETTYP=3
  13373.     GOTO 30110
  13374. C
  13375. C
  13376. C
  13377. C
  13378. C ****************************************
  13379. C ****** MULTIPLE PRECISION BASE 16 ******
  13380. C ****************************************
  13381. 30270    RETTYP=7
  13382.     GOTO 30180
  13383. C
  13384. C
  13385. C *********************
  13386. C ****** BASE 10 ******
  13387. C *********************
  13388. 30300    BASE=10
  13389. C
  13390. C
  13391. C IF MORE THAN 9 DIGITS IT IS MULTIPLE PRECISION.
  13392.     IF (RETPT.GT.9) GOTO 30370
  13393. C
  13394. C
  13395. C  INTEGER
  13396.     RETTYP=4
  13397.     GOTO 30110
  13398. C
  13399. C
  13400. C ****************************************
  13401. C ****** MULTIPLE PRECISION BASE 10 ******
  13402. C ****************************************
  13403. 30370    RETTYP=5
  13404.     GOTO 30180
  13405. C
  13406. C
  13407. C
  13408. C
  13409. C
  13410. C SET LASTOP AND EXIT
  13411. 35100    LASTOP=RETTYP
  13412.     GOTO 99099
  13413. C
  13414. C
  13415. C *****************************
  13416. C ****** REAL OR DECIMAL ******
  13417. C *****************************
  13418. 40000    IF (B16.NE.1) GOTO 40020
  13419. C
  13420. C
  13421. C *** ERROR ***  '.' MAY ONLY BE USED WITH BASE 10
  13422.     CALL ERRMSG(21)
  13423.     GOTO 99000
  13424. C
  13425. C
  13426. C
  13427. 40020    IF (RETPT.EQ.0) GOTO 40200
  13428. C
  13429. C
  13430. C IGNORE LEADING ZEROES
  13431.     DO 40022 L=1,19
  13432.     IF (ICHAR(RETVAL(L)).NE.0) GOTO 40030
  13433. 40022    CONTINUE
  13434. C
  13435. C IF ALL ZEROES THE LAST ONE COUNTS!
  13436.     L=19
  13437. C
  13438. C
  13439. C CONVERT TO A REAL*8 NUMBER
  13440. 40030    CONTINUE
  13441.     REAL=0.D0
  13442.     DO 40060 I=L,RETPT
  13443.     REAL=REAL*10.D0+ICHAR(RETVAL(I))
  13444.     RETVAL(I)=char(0)
  13445. 40060    CONTINUE
  13446. C
  13447. C
  13448. C  PICK UP FRACTIONAL PART OF REAL (DECIMAL)
  13449. 40200    CONTINUE
  13450.     RB=1.0D0
  13451.     RETTYP=2
  13452. 40205    CALL GETNNB (IPT,RETCD2)
  13453.     IF (RETCD2.EQ.1) GOTO 40300
  13454. C
  13455. C IF NO MORE, YOU GOT IT ALL SO GO PLACE VALUE IN RETVAL.
  13456.     GOTO 40537
  13457. C
  13458. C
  13459. C
  13460. 40300    NONBLK=IPT
  13461.     CHAR1=LINE(IPT)
  13462.     DO 40320 I=1,10
  13463.     IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40330
  13464. 40320    CONTINUE
  13465.     GOTO 40350
  13466. 40330    IF (I.EQ.10) I=0
  13467.     RB=0.1D0*RB
  13468.     REAL=REAL+DFLOAT(I)*RB
  13469.     GOTO 40205
  13470. C
  13471. C
  13472. C CHECK TO SEE IF E OR D EXPONENT SPECIFICATION IS USED.
  13473. 40350    IF (CHAR1.EQ.DIGITS(13,3).OR.CHAR1.EQ.DIGITS(14,3)) GOTO 40360
  13474.     NONBLK=NONBLK-1
  13475.     GO TO 40537
  13476. C
  13477. C
  13478. C *********************************************
  13479. C ****** E AND D EXPONENT SPECIFICATIONS ******
  13480. C *********************************************
  13481. 40360    CONTINUE
  13482.     CALL GETNNB(IPT,RETCD2)
  13483.     IF (RETCD2.EQ.1) GOTO 40370
  13484. C
  13485. C
  13486. C *** ERROR *** ILLEGAL REAL EXPONENT FIELD SPECIFIED
  13487. 40365    CALL ERRMSG (24)
  13488.     GOTO 99000
  13489. C
  13490. C
  13491. 40370    CHAR1=LINE(IPT)
  13492.     IF (CHAR1.EQ.MINUS) GOTO 40380
  13493.     RB=10.D0
  13494.     IF (CHAR1.NE.PLUS) GOTO 40400
  13495.     GOTO 40390
  13496. 40380    RB=0.1D0
  13497. C
  13498. C
  13499. C
  13500. 40390    NONBLK=IPT
  13501.     CALL GETNNB (IPT,RETCD2)
  13502. 40400    IF (RETCD2.GE.2) GOTO 40365
  13503.     NONBLK=IPT
  13504.     CHAR1=LINE(IPT)
  13505.     DO 40450 I=1,10
  13506.     IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40480
  13507. 40450    CONTINUE
  13508.     GOTO 40365
  13509. 40480    IF (I.EQ.10) I=0
  13510. C
  13511. C
  13512. C I1 HOLDS 1ST DIGIT OF EXPONENT SPECIFICATION
  13513.     I1=I
  13514.     CALL GETNNB (IPT,RETCD2)
  13515.     IF (RETCD2.GE.2) GOTO 40550
  13516.     CHAR1=LINE(IPT)
  13517.     NONBLK=IPT
  13518.     DO 40500 I=1,10
  13519.     IF(CHAR1.EQ.DIGITS(I,1)) GO TO 40520
  13520. 40500    CONTINUE
  13521.     NONBLK=NONBLK-1
  13522.     GOTO 40550
  13523. C
  13524. C
  13525. C I2 HOLDS SECOND DIGIT OF EXPONENT SPECIFICATION.
  13526. 40520    IF (I.EQ.10) I=0
  13527.     I2=I
  13528. C
  13529. C
  13530. 40530    RETTYP=9
  13531.     REAL=REAL*RB**(I1*10+I2)
  13532. C
  13533. C
  13534. C
  13535. C ***************************************************
  13536. C ****** COPY REAL*8 INTO RETURN VECTOR RETVAL ******
  13537. C ***************************************************
  13538. 40537    DO 40540 I=1,8
  13539. 40540    RETVAL(I)=EIGHT(I)
  13540.     GOTO 35100
  13541. C
  13542. C
  13543. C
  13544. 40550    I2=I1
  13545.     I1=0
  13546.     GOTO 40530
  13547. C
  13548. C
  13549. C
  13550. C ********************************
  13551. C ******* ERROR PROCESSING *******
  13552. C ********************************
  13553. 99000    CONTINUE
  13554.     IV=LEND-NONBLK+1
  13555.     CALL VWRT(LINE(NONBLK),IV)
  13556. C    WRITE (0,99010) (LINE(I),I=NONBLK,LEND)
  13557. C99010    FORMAT (1X,80(A1,\))
  13558.     RETCD=4
  13559. 99097    LASTOP=0
  13560. 99099    RETURN
  13561.     END
  13562. c -h- pget.for    Tue Sep  2 10:58:55 1986    
  13563.     SUBROUTINE PGET(CMDLIN,ICODE,IRTN)
  13564.     Include aparms.inc
  13565. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  13566. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  13567. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  13568. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  13569. C FROM THE DISK BASED FILE HERE.
  13570.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  13571. c    INTEGER*4 VNLT
  13572.         Integer*4 IDRO,IDCL
  13573.     CHARACTER*1 FORM2(128),FORM3(110),NMSH(80)
  13574.         Character*127 Form2c
  13575.         Equivalence(Form2(1),Form2c)
  13576.         REAL*8 R8S
  13577.     Integer*4 i4s
  13578.     equivalence(r8s,form3(1))
  13579.     equivalence(i4s,form3(1))
  13580.         INTEGER*4 IBIN
  13581.     COMMON/NMSH/NMSH
  13582.     REAL*8 XVBLS(1,1)
  13583. c    INTEGER KPYBAK
  13584. C ***<<<< RDD COMMON START >>>***
  13585.     InTeGer*4 RRWACT,RCLACT
  13586. C    COMMON/RCLACT/RRWACT,RCLACT
  13587.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  13588.      1  IDOL7,IDOL8
  13589. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  13590. C     1  IDOL7,IDOL8
  13591.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  13592. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  13593.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  13594. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  13595. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  13596. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  13597.     InTeGer*4 KLVL
  13598. C    COMMON/KLVL/KLVL
  13599.     InTeGer*4 IOLVL,IGOLD
  13600. C    COMMON/IOLVL/IOLVL
  13601. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  13602. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  13603.     integer*4 idsptp,idol9,k3dfg,kcdelt,krdelt,kpag
  13604.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  13605.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  13606.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,idol9,
  13607.      3  k3dfg,kcdelt,krdelt,kpag
  13608. C ***<<< RDD COMMON END >>>***
  13609. CCC    InTeGer*4 IOLVL
  13610.     INTEGER*4 JVBLS(2,1,1)
  13611. CCC    COMMON/IOLVL/IOLVL
  13612. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  13613. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  13614.     DIMENSION FORM(128),FVLD(1,1)
  13615. c    CHARACTER*1 FVWRK,FVWRK2
  13616. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  13617. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  13618. C SO INITIALLY IGNORE.
  13619. C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
  13620. C
  13621. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  13622.  
  13623. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  13624. c    CHARACTER*1 LETA
  13625. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  13626. CCC    InTeGer*4 LLCMD,LLDSP
  13627. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  13628.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  13629.     COMMON/D2R/NRDSP,NCDSP
  13630.     InTeGer*4 TYPE(1,2),VLEN(9)
  13631.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  13632.     Real*8 VAVBLS(3,27)
  13633.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  13634.     REAL*8 XAC,ZAC
  13635.     EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
  13636.     REAL*8 XXAC,XYAC
  13637.     EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
  13638. C ***<<< XVXTCD COMMON START >>>***
  13639.     CHARACTER*1 OARRY(100)
  13640.     InTeGer*4 OSWIT,OCNTR
  13641. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  13642. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  13643.     InTeGer*4 IPS1,IPS2,MODFLG
  13644. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  13645.        InTeGer*4 XTCFG,IPSET,XTNCNT
  13646.        CHARACTER*1 XTNCMD(80)
  13647. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  13648. C VARY FLAG ITERATION COUNT
  13649.     INTEGER KALKIT
  13650. C    COMMON/VARYIT/KALKIT
  13651.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  13652.     InTeGer*4 RCMODE,IRCE1,IRCE2
  13653. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  13654. C     1  IRCE2
  13655. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  13656. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  13657. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  13658. C RCFGX ON.
  13659. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  13660. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  13661. C  AND VM INHIBITS. (SETS TO 1).
  13662.     INTEGER*4 FH
  13663. C FILE HANDLE FOR CONSOLE I/O (RAW)
  13664. C    COMMON/CONSFH/FH
  13665.     CHARACTER*1 ARGSTR(52,4)
  13666. C    COMMON/ARGSTR/ARGSTR
  13667.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  13668.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  13669.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  13670.      3  IRCE2,FH,ARGSTR
  13671. C ***<<< XVXTCD COMMON END >>>***
  13672. CCC    CHARACTER*1 ARGSTR(52,4)
  13673. CCC    COMMON/ARGSTR/ARGSTR
  13674. C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
  13675. C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
  13676. C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
  13677. C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
  13678. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
  13679. C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
  13680.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  13681.     INTEGER*4 IIRO,IICO,INUMEM
  13682. C NEED SOME BIG VARIABLES FOR SAVING THE MAPPINGS
  13683.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  13684.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  13685. CCC    COMMON/KLVL/KLVL
  13686.     CHARACTER*1 DEFVB(12)
  13687.     COMMON/DEFVBX/DEFVB
  13688. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  13689. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  13690. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  13691. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  13692. C  AND VM INHIBITS. (SETS TO 1).
  13693. C
  13694. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  13695. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  13696. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  13697. C DISPLAY ACTUALLY USED FOR SCREEN.
  13698.     Integer*4 CWids(JIDcl)
  13699. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  13700. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  13701. C AS 20 NOT 75.
  13702.     REAL*8 DVS(JIDcl,JIDrw)
  13703.     INTEGER*4 LDVS(2,JIDcl,JIDrw)
  13704.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  13705.     CHARACTER*76 CFORM
  13706.     EQUIVALENCE(CFORM(1:1),FORM(1))
  13707.     COMMON /FVLDC/FVLD
  13708. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  13709. C 10 CHARACTERS PER ENTRY.
  13710.     COMMON/DSPCMN/DVS,CWIDS
  13711. C ***<<< NULETC COMMON START >>>***
  13712.     InTeGer*4 ICREF,IRREF
  13713. C    COMMON/MIRROR/ICREF,IRREF
  13714.     InTeGer*4 MODPUB,LIMODE
  13715. C    COMMON/MODPUB/MODPUB,LIMODE
  13716.     InTeGer*4 KLKC,KLKR
  13717.     REAL*8 AACP,AACQ
  13718. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  13719.     InTeGer*4 NCEL,NXINI
  13720. C    COMMON/NCEL/NCEL,NXINI
  13721.     CHARACTER*1 NAMARY(20,MRows)
  13722. C    COMMON/NMNMNM/NAMARY
  13723.     InTeGer*4 NULAST,LFVD
  13724. C    COMMON/NULXXX/NULAST,LFVD
  13725.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  13726.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  13727. C ***<<< NULETC COMMON END >>>***
  13728.     Character*1 Letr
  13729. CCC    InTeGer*4 ICREF,IRREF
  13730. CCC    COMMON/MIRROR/ICREF,IRREF
  13731. C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
  13732. C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
  13733. C
  13734. C PUT NUMBERS OUT TO FILE
  13735. C USES RELATIVE FORMS TO CURRENT POS.
  13736. C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
  13737. C ONLY WRITES PHYSICALLY PRESENT DATA.
  13738. C P/D RRR,CCC,FORMULA,VALID,FORMAT
  13739. C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
  13740.     ICODE=1
  13741.     CLOSE(4)
  13742. 7954    CALL UVT100(1,LLCMD,1)
  13743.     CALL UVT100(12,2,0)
  13744. C ASK FOR FILE NAME
  13745.     CALL VWRT('Enter Filename:',15)
  13746.     III=IOLVL
  13747. C    IF(III.EQ.5)III=0
  13748.     if(iii.ne.11)READ(III,7953,END=510,ERR=510)FORM2
  13749.     if(iii.eq.11)call vget(form2,128)
  13750. c7952    FORMAT(' Enter filename>\')
  13751. 7953    FORMAT(128A1)
  13752.     DO 6940 II=1,128
  13753.     ILN=129-II
  13754.     IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
  13755.     FORM2(ILN)=char(0)
  13756. 6940    CONTINUE
  13757. 6941    CONTINUE
  13758. C ILN IS LENGTH OFLINE NOW.
  13759.     ILN=MIN0(ILN,127)
  13760.     FORM2(ILN+1)=char(0)
  13761.         IBIN=0
  13762.         IF(CMDLIN(2).EQ.'B'.OR.CMDLIN(2).EQ.'b')IBIN=1
  13763.     IF(IBIN.EQ.0)CALL WASSIG(4,FORM2)
  13764. C block=-1 is Absoft-specific Amiga hack to get record lengths encoded
  13765. C to allow variable length records to make sense.
  13766.         IF(IBIN.EQ.1)OPEN(UNIT=4,FILE=FORM2c,FORM='UNFORMATTED',
  13767.      1  ACCESS='SEQUENTIAL',STATUS='NEW',block=-1)
  13768. c use recl=128 instead of block=-1 for unix flavors
  13769. C NOW ENCODE COL WIDTHS AND ICREF/IRREF
  13770. C SO SAVE/RESTORE OF EXTENDED SHEETS DOESN'T GET
  13771. C MESSED UP.
  13772.     If(Ibin.eq.0)
  13773.      1  WRITE(CFORM(1:76),8850,ERR=8851)ICREF,IRREF,(CWIDS(III),
  13774.      1  III=1,20),DRWV,DCLV
  13775. 8850    FORMAT(24I3)
  13776.     DO 8855 III=1,80
  13777.     II=ICHAR(NMSH(III))
  13778.     IF(II.LT.32)II=32
  13779. 8855    NMSH(III)=CHAR(II)
  13780. 8851    CONTINUE
  13781.     IF(IBIN.EQ.0)WRITE(4,6951)NMSH,(FORM(II),II=1,76)
  13782.         IF(IBIN.EQ.1)WRITE(4,err=448)NMSH,ICREF,IRREF,
  13783.      1  (CWIDS(III),III=1,20),DRWV,DCLV
  13784. 6951    FORMAT(80A1,76A1)
  13785. C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
  13786.     CALL UVT100(1,LLCMD,1)
  13787.     CALL UVT100(12,2,0)
  13788.         MDXM=12000
  13789.         LDXM=12000
  13790.         IF(IBIN.EQ.1)GOTO 448
  13791.     CALL VWRT('Enter max. displ down to save or 0 for all>',43)
  13792.     III=IOLVL
  13793. C    IF(III.EQ.5)III=0
  13794.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)LDXM
  13795.     if(iii.eq.11)call vgeti(ldxm)
  13796. 6950    FORMAT(80A1)
  13797. 7978    FORMAT(I7)
  13798.     CALL UVT100(1,LLCMD,1)
  13799.     CALL UVT100(12,2,0)
  13800.     CALL VWRT('Enter max. displcmt right to save or 0 for all>',47)
  13801.     III=IOLVL
  13802. C    IF(III.EQ.5)III=0
  13803.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)MDXM
  13804.     if(iii.eq.11)call vgeti(mdxm)
  13805.     IF(MDXM.LE.0)MDXM=12000
  13806.     IF(LDXM.LE.0)LDXM=12000
  13807. 448     CONTINUE
  13808. C 12000 IS "AN ARBITRARILY LARGE NUMBER TO ASSURE THAT ALL VALID
  13809. C RANGES ARE SAVED". IT MUST BE SMALL ENOUGH TO ASSURE WE DON'T OVERFLOW AN
  13810. C INTEGER THOUGH.
  13811.     IF(CMDLIN(2).NE.'P'.and.CMDLIN(2).GT.' '.AND.IBIN.EQ.0)
  13812.      1   GOTO 7950
  13813. C TREAT "P" BY ITSELF AS A SAVE PP TYPE COMMAND (PUT PHYS)
  13814. C Could speed this by saving only what's been filled.
  13815. C RCLACT can be up to 301, RRWACT can be up to MCols
  13816. C since current cell may be outside this area, use scratch vbls
  13817. C to ensure all's well
  13818.     If(K3dfg.lt.0)Goto 8601
  13819. C write out special "flag" record to preserve 3D mapping
  13820. C information IF mapping is not disabled.
  13821.     Letr='F'
  13822.     if(ibin.eq.1)goto 8602
  13823.     WRITE(4,5403)LETR,k3dfg,KCDelt,KRDelt
  13824.     Goto 8603
  13825. 8602    Continue
  13826.     i4s=KRDelt
  13827.     WRITE(4)LETR,K3Dfg,KCDelt,
  13828.      1  (form3(ivv),ivv=1,110)
  13829. 8603    Continue
  13830. C fill in other rubbish as second part of record. 253 is byte for -3 next...
  13831.     Type(1,1)=(2)
  13832.     Form2(119)=char(253)
  13833.     If(Ibin.eq.0)
  13834.      1  WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1)
  13835.     If(Ibin.eq.1)
  13836.      1  WRITE(4)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1)
  13837. C
  13838. 8601    Continue
  13839.     Irrw=max0(PCOL,RCLACT)
  13840.     Ircl=max0(PROW,RRWACT)
  13841. c    DO 7951 ICO=PCOL,301
  13842. c    DO 7951 IRO=PROW,60
  13843.     DO 7951 ICO=PCOL,Irrw
  13844.     DO 7951 IRO=PROW,Ircl
  13845. C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY.
  13846. C    IRX=(ICO-1)*60+IRO
  13847.     CALL REFLEC(ICO,IRO,IRX)
  13848.     IDRO=IRO-PROW+1
  13849.     IDCL=ICO-PCOL+1
  13850.     IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951
  13851. C FORM DISPLACEMENT LOCATORS
  13852.     CALL FVLDGT(IRO,ICO,FVLD(1,1))
  13853.     IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7951
  13854.     CALL WRKFIL(IRX,FORM,0)
  13855.     CALL CE2A(FORM,FORM2)
  13856.     IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
  13857.     IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  13858.     CALL TYPGET(IRO,ICO,TYPE(1,1))
  13859.     IF(CMDLIN(3).NE.'N')GOTO 5402
  13860.     IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5402
  13861. C ALWAYS WRITE TEXT OUT EVEN IF SAVING NUMERICALLY
  13862. C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
  13863. C INTERNAL PROC TO PRINT NUMERIC VALUES AT 6400
  13864.     LETR='P'
  13865.     ASSIGN 5405 TO INUMEM
  13866. C    GOTO 6400
  13867. 6400    CONTINUE
  13868. C ASSUME LETR IS SET TO GOOD PREFIX LETTER ASCII VALUE
  13869.     CALL XVBLGT(IRO,ICO,XVBLS(1,1))
  13870.         IF(IBIN.EQ.1)GOTO 449
  13871.     IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5403)LETR,IDRO,IDCL,
  13872.      1  JVBLS(1,1,1)
  13873. 5403    FORMAT(1A1,I5,',',I5,',',I15)
  13874.     IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5404)LETR,IDRO,IDCL,
  13875.      1  XVBLS(1,1)
  13876.         GOTO 450
  13877. 449     CONTINUE
  13878.         R8S=XVBLS(1,1)
  13879.     WRITE(4,err=450)LETR,IDRO,IDCL,FORM3
  13880. 450     CONTINUE
  13881. 5404    FORMAT(1A1,I5,',',I5,',',D30.19)
  13882.     GOTO INUMEM,(5405,6406)
  13883. 5402    CONTINUE
  13884. C FIND END OF TEXT IN ARRAY
  13885.     IVVV=110
  13886.         If(Ibin.eq.1)goto 4331
  13887. C skip this truncation for binary saves
  13888.     DO 4330 IV=2,110
  13889.     IVVV=113-IV
  13890.     IF(ICHAR(FORM2(IVVV)).GT.32)GOTO 4331
  13891. 4330    CONTINUE
  13892. 4331    CONTINUE
  13893. C SAVE ON PPX IN EFFICIENT FORM.
  13894. C DON'T WRITE OUT TRAILING NULLS.
  13895. C ENSURE FORMAT HAS NO NULLS IN IT.
  13896.     DO 358 IV=120,128
  13897. 358    IF(ICHAR(FORM2(IV)).LT.32)FORM2(IV)=Char(32)
  13898.     IF(CMDLIN(3).EQ.'F')GOTO 6404
  13899. C PPF WILL SAVE FORMULAS ONLY
  13900. C PPA WILL SAVE FORMULAS AND VALUES (AS WILL PPc WHERE c IS
  13901. C ANY CHARACTER EXCEPT N.
  13902.     LETR='p'
  13903. C FLAG NUMERIC SAVE VIA LOWERCASE P HERE
  13904.     ASSIGN 6406 TO INUMEM
  13905. C GO WRITE FIRST LINE NUMERICALLY
  13906.     GOTO 6400
  13907. 6406    CONTINUE
  13908. C NOW HAVE NUMERIC LINE WRITTEN. WRITE THE SECOND LINE OF THE
  13909. C GROUP TO, SO AS NOT TO CONFUSE GRAPHICS PROGRAMS AND THE
  13910. C LIKE.
  13911.     III=JCHAR(FORM2(119))
  13912.     IF(IBIN.EQ.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
  13913.      1   TYPE(1,1)
  13914.     IF(IBIN.EQ.1)WRITE(4,err=6404)III,(FORM2(IV),IV=120,128),
  13915.      1   TYPE(1,1)
  13916. 6404    CONTINUE
  13917. C NOW WRITE OUT FORMULA RECORD.
  13918.     If(Ibin.eq.0)WRITE(4,7955)IDRO,IDCL,
  13919.      1   (FORM2(IV),IV=1,IVVV)
  13920.         Letr=char(80)
  13921.         If(Ibin.eq.1)Write(4,err=5405)Letr,idro,idcl,
  13922.      1   (form2(iv),iv=1,ivvv)
  13923. 5405    CONTINUE
  13924. C DUMP TO SERIAL FILE IN OUR OWN FORMAT, BUT ALL IN ASCII.
  13925. 7955    FORMAT('P',I5,',',I5,',',128A1)
  13926. C NOTE LONG RECORDS.
  13927.     III=JCHAR(FORM2(119))
  13928.     If(ibin.eq.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
  13929.      1  TYPE(1,1)
  13930.     If(Ibin.eq.1)WRITE(4,err=7951)III,(FORM2(IV),IV=120,128),
  13931.      1  TYPE(1,1)
  13932. 7956    FORMAT(I3,',',9A1,',',I5)
  13933. 7951    CONTINUE
  13934. 2751    CONTINUE
  13935. C
  13936. C NOW SAVE NRDSP AND NCDSP MAPPINGS TOO
  13937. C ONLY SAVE MAPPINGS IF 4TH COMMAND CHARACTER IS "M".
  13938. C ... THEY TAKE A LOT OF ROOM.
  13939.     IF (CMDLIN(4).NE.'M') GOTO 6541
  13940.     DO 6540 IRO=DROW,JIDcl
  13941.     DO 6540 ICO=DCOL,JIDrw
  13942.     IIRO=64000
  13943.     IICO=IIRO
  13944.     IIRO=IIRO+IRO
  13945.     IICO=IICO+ICO
  13946. C NOTE WE MAKE THESE NUMBERS LARGE SO GRAPHING PROGRAMS WON'T TRY
  13947. C TO READ THEM.
  13948. 6955    FORMAT('M',I5,',',I5,',',2I7)
  13949.         Letr='M'
  13950.         If(Ibin.eq.0)
  13951.      1   WRITE(4,6955,ERR=6541)IIRO,IICO,
  13952.      1   NRDSP(IRO,ICO),NCDSP(IRO,ICO)
  13953.         If(Ibin.eq.1)
  13954.      1   WRITE(4,ERR=6541)Letr,IIRO,IICO,
  13955.      1   NRDSP(IRO,ICO),NCDSP(IRO,ICO)
  13956. C WRITE A SPECIAL RECORD, FLAGGED BY 'M', TO SAVE A MAPPING CELL
  13957. C NEED A 2ND RECORD TOO; JUST SEND LAST ONE AGAIN.
  13958.     If(ibin.eq.0)WRITE(4,7956)III,(FORM2(IV),IV=120,128),
  13959.      1  TYPE(1,1)
  13960.     If(Ibin.eq.1)WRITE(4,err=6541)III,(FORM2(IV),IV=120,128),
  13961.      1  TYPE(1,1)
  13962. 6540    CONTINUE
  13963. 6541    CONTINUE
  13964.     CLOSE(4)
  13965.     GOTO 9990
  13966. 7950    IF(CMDLIN(2).NE.'D')GOTO 9990
  13967.     DO 7957 ICO=DCOL,JIDrw
  13968.     DO 7957 IRO=DROW,JIDcl
  13969.     IDRO=IRO-DROW+1
  13970.     IDCL=ICO-DCOL+1
  13971.     IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7957
  13972.     NR=NRDSP(IRO,ICO)
  13973.     NC=NCDSP(IRO,ICO)
  13974. C    IRX=(NC-1)*60+NR
  13975.     CALL REFLEC(NC,NR,IRX)
  13976.     CALL FVLDGT(NR,NC,FVLD(1,1))
  13977.     IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7957
  13978.     CALL WRKFIL(IRX,FORM,0)
  13979.     CALL CE2A(FORM,FORM2)
  13980.     IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
  13981.     IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  13982.     IF(CMDLIN(3).NE.'N')GOTO 5412
  13983. C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
  13984.     IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5412
  13985. C WRITE LABELS EVEN IF NUMERIC SAVE
  13986.     CALL TYPGET(NR,NC,TYPE(1,1))
  13987.     CALL XVBLGT(NR,NC,XVBLS(1,1))
  13988.     IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,1,1)
  13989. 5413    FORMAT('P',I5,',',I5,',',I15)
  13990.     IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(1,1)
  13991. 5414    FORMAT('P',I5,',',I5,',',D30.19)
  13992.     GOTO 5415
  13993. 5412    CONTINUE
  13994.     WRITE(4,7958)IDRO,IDCL,(FORM2(IV),IV=1,110)
  13995. 5415    CONTINUE
  13996. 7958    FORMAT('D',I5,',',I5,',',128A1)
  13997.     DO 359 IV=120,128
  13998. 359    IF(FORM2(IV).LT.' ')FORM2(IV)=Char(32)
  13999.     III=JCHAR(FORM2(119))
  14000.     WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
  14001. 7957    CONTINUE
  14002. C ALLOW SAVE AS NEEDED OF MAPPING
  14003.     GOTO 2751
  14004. C    CLOSE(4)
  14005. 9990    RETURN
  14006. 510    CONTINUE
  14007.     IRTN=1
  14008.     CLOSE(IOLVL)
  14009. c    CLOSE(11)
  14010. c    OPEN(11,FILE='CON:0/0/100/100/Analy Command')
  14011.     RETURN
  14012.     END
  14013. c -h- pgget.for    Tue Sep  2 10:58:55 1986    
  14014.     SUBROUTINE PGGET(CMDLIN,ICODE,IRTN)
  14015.     Include aparms.inc
  14016. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  14017. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  14018. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  14019. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  14020. C FROM THE DISK BASED FILE HERE.
  14021.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  14022. c    INTEGER*4 VNLT
  14023.     CHARACTER*1 LET1,FORM2(128),NMSH(80)
  14024.         Real*8 R8s
  14025.         Integer*4 I4s,I4t,i4ttt
  14026.     character*1 i4ttc(4)
  14027.     equivalence(i4ttt,i4ttc(1))
  14028.         Equivalence(R8s,form2(1)),(I4s,form2(1))
  14029. c        Equivalence (I4t,form2(3))
  14030.         Character*127 Form2c
  14031.         Equivalence(Form2(1),Form2c)
  14032.     COMMON/NMSH/NMSH
  14033.     REAL*8 XVBLS(1,1)
  14034. c    INTEGER KPYBAK
  14035. C ***<<<< RDD COMMON START >>>***
  14036.     InTeGer*4 RRWACT,RCLACT
  14037. C    COMMON/RCLACT/RRWACT,RCLACT
  14038.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  14039.      1  IDOL7,IDOL8
  14040. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  14041. C     1  IDOL7,IDOL8
  14042.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  14043. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14044.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14045. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14046. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  14047. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  14048.     InTeGer*4 KLVL
  14049. C    COMMON/KLVL/KLVL
  14050.     InTeGer*4 IOLVL,IGOLD
  14051. C    COMMON/IOLVL/IOLVL
  14052. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  14053. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  14054.     Integer*4 idsptp,idol9,k3dfg,kcdelt,krdelt,kpag
  14055.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  14056.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  14057.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,Idol9,
  14058.      3  K3dfg,kcdelt,krdelt,kpag
  14059. C ***<<< RDD COMMON END >>>***
  14060. CCC    InTeGer*4 IOLVL
  14061.     INTEGER*4 JVBLS(2,1,1)
  14062.     REAL*8 R8WK
  14063. CCC    COMMON/IOLVL/IOLVL
  14064. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  14065. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  14066.     DIMENSION FORM(128),FVLD(1,1)
  14067.     INTEGER*4 IRRW,ICCL
  14068. C USE BIG NUMBERS SO WE CAN SUBTRACT 64000 AND STILL NOT GET WRAPAROUND.
  14069. C (FOR SAVE/RESTORE OF MAP)
  14070.     CHARACTER*76 CFORM
  14071.     CHARACTER*35 CFORM2
  14072.     EQUIVALENCE(CFORM2(1:1),FORM2(1))
  14073.     EQUIVALENCE(CFORM(1:1),FORM(1))
  14074.     InTeGer*4 NDUM(24)
  14075. C ***<<< NULETC COMMON START >>>***
  14076.     InTeGer*4 ICREF,IRREF
  14077. C    COMMON/MIRROR/ICREF,IRREF
  14078.     InTeGer*4 MODPUB,LIMODE
  14079. C    COMMON/MODPUB/MODPUB,LIMODE
  14080.     InTeGer*4 KLKC,KLKR
  14081.     REAL*8 AACP,AACQ
  14082. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  14083.     InTeGer*4 NCEL,NXINI
  14084. C    COMMON/NCEL/NCEL,NXINI
  14085.     CHARACTER*1 NAMARY(20,MRows)
  14086. C    COMMON/NMNMNM/NAMARY
  14087.     InTeGer*4 NULAST,LFVD
  14088. C    COMMON/NULXXX/NULAST,LFVD
  14089.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  14090.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  14091. C ***<<< NULETC COMMON END >>>***
  14092. CCC    COMMON/MIRROR/ICREF,IRREF
  14093. c    CHARACTER*1 FVWRK,FVWRK2
  14094. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  14095. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  14096. C SO INITIALLY IGNORE.
  14097. C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
  14098. C
  14099. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  14100. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  14101. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14102. CCC    InTeGer*4 LLCMD,LLDSP
  14103. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  14104.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  14105.     EXTERNAL INDX
  14106.     COMMON/D2R/NRDSP,NCDSP
  14107.     InTeGer*4 TYPE(1,2),VLEN(9)
  14108.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  14109.     Real*8 VAVBLS(3,27)
  14110.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  14111.     REAL*8 XAC,ZAC
  14112.     EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
  14113.     REAL*8 XXAC,XYAC
  14114.     EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
  14115. C ***<<< XVXTCD COMMON START >>>***
  14116.     CHARACTER*1 OARRY(100)
  14117.     InTeGer*4 OSWIT,OCNTR
  14118. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  14119. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  14120.     InTeGer*4 IPS1,IPS2,MODFLG
  14121. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  14122.        InTeGer*4 XTCFG,IPSET,XTNCNT
  14123.        CHARACTER*1 XTNCMD(80)
  14124. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  14125. C VARY FLAG ITERATION COUNT
  14126.     INTEGER KALKIT
  14127. C    COMMON/VARYIT/KALKIT
  14128.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  14129.     InTeGer*4 RCMODE,IRCE1,IRCE2
  14130. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14131. C     1  IRCE2
  14132. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  14133. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  14134. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  14135. C RCFGX ON.
  14136. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  14137. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  14138. C  AND VM INHIBITS. (SETS TO 1).
  14139.     INTEGER*4 FH
  14140. C FILE HANDLE FOR CONSOLE I/O (RAW)
  14141. C    COMMON/CONSFH/FH
  14142.     CHARACTER*1 ARGSTR(52,4)
  14143. C    COMMON/ARGSTR/ARGSTR
  14144.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  14145.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  14146.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14147.      3  IRCE2,FH,ARGSTR
  14148. C ***<<< XVXTCD COMMON END >>>***
  14149. CCC    CHARACTER*1 ARGSTR(52,4)
  14150. CCC    COMMON/ARGSTR/ARGSTR
  14151. C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
  14152. C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
  14153. C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
  14154. C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
  14155. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
  14156. C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
  14157.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  14158.     EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
  14159.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  14160. CCC    COMMON/KLVL/KLVL
  14161.     CHARACTER*1 DEFVB(12)
  14162.     COMMON/DEFVBX/DEFVB
  14163. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  14164. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  14165. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  14166. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  14167. C  AND VM INHIBITS. (SETS TO 1).
  14168. C
  14169. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  14170. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  14171. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  14172. C DISPLAY ACTUALLY USED FOR SCREEN.
  14173.     Integer*4 CWids(JIDcl)
  14174. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  14175. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  14176. C AS 20 NOT 75.
  14177.     REAL*8 DVS(JIDcl,JIDrw)
  14178.     INTEGER*4 LDVS(2,JIDcl,JIDrw)
  14179.     EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
  14180.     COMMON /FVLDC/FVLD
  14181. CCC    InTeGer*4 NCEL,NXINI
  14182. CCC    COMMON/NCEL/NCEL,NXINI
  14183. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  14184. C 10 CHARACTERS PER ENTRY.
  14185.     COMMON/DSPCMN/DVS,CWIDS
  14186. C
  14187. c7952    FORMAT(' Enter filename>\')
  14188. 7953    FORMAT(128A1)
  14189. 6950    FORMAT(80A1)
  14190. 7978    FORMAT(I7)
  14191. 7956    FORMAT(I3,1X,9A1,1X,I5)
  14192.     CLOSE(4)
  14193. 7960    CALL UVT100(1,LLCMD,1)
  14194.     CALL UVT100(12,2,0)
  14195. C GET FILE NAME
  14196.     call Vwrt('Enter Filename:',15)
  14197.     III=IOLVL
  14198. C    IF(III.EQ.5)III=0
  14199.     if(iii.ne.11)READ(III,7953,END=510,ERR=510)FORM2
  14200.     if(iii.eq.11)call vget(form2,128)
  14201.     DO 6940 II=1,128
  14202.     ILN=129-II
  14203.     IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
  14204.     FORM2(ILN)=Char(0)
  14205. 6940    CONTINUE
  14206. 6941    CONTINUE
  14207. C ILN IS LENGTH OFLINE NOW.
  14208.     ILN=MIN0(127,ILN)
  14209.     FORM2(ILN+1)=Char(0)
  14210. C SPECIAL "FAST READ" MODE TO SET UP DATA AREAS ON GETTING OLD SHEETS...
  14211.     NXINI=1
  14212.     LDXM=INDX(FORM2,ICHAR('/'))
  14213. C IF FILE IS FILENAME/M WE WON'T DO IT FAST...
  14214.     IF(LDXM.LE.0.OR.LDXM.GE.ILN)GOTO 8400
  14215.     FORM2(LDXM)=Char(0)
  14216. C TERMINATE AFTER THE / AND SET NXINI TO 0 AGAIN
  14217.     NXINI=0
  14218. 8400    CONTINUE
  14219.         Ibin=0
  14220.         If(Cmdlin(2).eq.'B'.OR.cmdlin(2).eq.'b')Ibin=1
  14221.     If(Ibin.eq.0)CALL RASSIG(4,FORM2,kkkk)
  14222.     if(kkkk.ne.0)goto 7964
  14223. C BLOCK=-1 IS HACK TO READ ABSOFT UNFORMATTED BIN RECS AS VBL LEN
  14224.         If(Ibin.eq.1)Open(unit=4,file=form2c,form='Unformatted',
  14225.      1  access='SEQUENTIAL',status='OLD',block=-1)
  14226. c     1  access='SEQUENTIAL',status='OLD',recl=512)
  14227.         If(Ibin.eq.0)
  14228.      1  READ(4,6951,END=7964,ERR=7964)NMSH,FORM
  14229.         If(Ibin.eq.1)
  14230.      1  READ(4,END=7964,ERR=7107)NMSH,Ndum
  14231. 7107    Continue
  14232. 6951    FORMAT(80A1,76A1,56A1)
  14233. 6952    FORMAT(24I3)
  14234. C TRY TO DECODE ICREF,IRREF, CWIDS, AND DRWV,DCLV
  14235.     If(Ibin.eq.0)READ(CFORM(1:76),6952,ERR=6953)NDUM
  14236. C IF HERE, THE READ WAS OK (APPARENTLY)
  14237. C FILL IN DEFAULTS IF NOTHING BUT ZEROES REALLY WAS SEEN
  14238. C (OR JUST ALL SPACES)
  14239.     ICREF=NDUM(1)
  14240.     IF(ICREF.LE.0.OR.ICREF.GT.MCols)ICREF=10
  14241.     IRREF=NDUM(2)
  14242.     IF(IRREF.LE.0.OR.IRREF.GT.(MRows-1))IRREF=50
  14243. C SET UP CWIDS BUT DEFAULT TO 10 IF NO REAL INFO THERE
  14244. C leave 20 as number widths to save for standardizing format
  14245. C of output
  14246.     DO 6954 III=1,20
  14247.     IIVV=NDUM(III+2)
  14248.     IF(IIVV.LT.1.OR.IIVV.GT.100)IIVV=10
  14249.     CWIDS(III)=IIVV
  14250. 6954    CONTINUE
  14251. C RESTORE NUMBER ROWS AND COLS BEING DISPLAYED
  14252. C NOTE WE DO NOT RESTORE THE COMPLETE DISPLAY
  14253. C MAPPING; JUST THE WIDTHS AND NUMBERS OF DISPLAY
  14254. C COLUMNS, AND WE RESTORE THE EXTENDED MAP SO THAT
  14255. C SAVED SHEETS WILL NORMALLY GET BACK THE SAME EXTENDED
  14256. C ADDRESSING THAT HAD BEEN SET UP.
  14257.     DRWV=NDUM(23)
  14258.     IF(DRWV.LT.1.OR.DRWV.GT.JIDcl)DRWV=7
  14259.     DCLV=NDUM(24)
  14260.     IF(DCLV.LT.1.OR.DCLV.GT.JIDrw)DCLV=20
  14261. 6953    CONTINUE
  14262. C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
  14263.     CALL UVT100(1,LLCMD,1)
  14264.     CALL UVT100(12,2,0)
  14265.         mdxm=12000
  14266.         ldxm=12000
  14267.         mmdxm=1
  14268.         lldxm=1
  14269.         If(ibin.eq.1)Goto 662
  14270.     CALL VWRT('Enter max. displc. down to restore or 0 for all>',48)
  14271.     III=IOLVL
  14272. C    IF(III.EQ.5)III=0
  14273.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)MDXM
  14274.     if(iii.eq.11)call vgeti(mdxm)
  14275.     CALL UVT100(1,LLCMD,1)
  14276.     CALL UVT100(12,2,0)
  14277.     CALL VWRT('Enter max. displc. right to restore or 0 for all>',
  14278.      1  49)
  14279.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)LDXM
  14280.     if(iii.eq.11)call vgeti(ldxm)
  14281.     CALL UVT100(1,LLCMD,1)
  14282.     CALL UVT100(12,2,0)
  14283.     CALL VWRT('Enter min. displ. down (1 or more)>',35)
  14284.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)MMDXM
  14285.     if(iii.eq.11)call vgeti(mmdxm)
  14286.     CALL UVT100(1,LLCMD,1)
  14287.     CALL UVT100(12,2,0)
  14288.     CALL VWRT('Enter min displ. right (1 or more)>',35)
  14289.     if(iii.ne.11)READ(III,7978,END=510,ERR=510)LLDXM
  14290.     if(iii.eq.11)call vgeti(lldxm)
  14291. 662     Continue
  14292.     IF(MDXM.LE.0)MDXM=12000
  14293.     LLDXM=MAX0(1,LLDXM)
  14294.     MMDXM=MAX0(1,MMDXM)
  14295.     IF(LDXM.LE.0)LDXM=12000
  14296.     IF(CMDLIN(4).EQ.'+'.OR.CMDLIN(4).EQ.'-')RCFGX=1
  14297. C ENTER RECALC MANUAL MODE IF ADDING NUMBERS OR SUBT.
  14298. C FROM SAVED SHEET
  14299. C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER.
  14300. 7961    CONTINUE
  14301.         If(Ibin.eq.0)
  14302.      1  READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV),
  14303.      1  IV=1,110)
  14304.         If(Ibin.eq.1)
  14305.      1  READ(4,END=7964,ERR=7108)LET1,IRRW,ICCL,(FORM2(IV),
  14306.      1  IV=1,110)
  14307. 7962    FORMAT(A1,I5,1X,I5,1X,128A1)
  14308. 7108    Continue
  14309.         ivv=110
  14310.         If(Ibin.eq.1)Goto 4496
  14311.     DO 4497 IV=1,110
  14312.     IVV=111-IV
  14313.     IF(FORM2(IVV).GT.' ')GOTO 4496
  14314.     FORM2(IVV)=Char(0)
  14315. 4497    CONTINUE
  14316. 4496    CONTINUE
  14317. C ABOVE LOOP ENSURES THAT EXTRA PARTS OF BUFFER NOT IN SAVE FILE ARE
  14318. C ZEROED ON READIN.
  14319.         If(Ibin.eq.0)
  14320.      1  READ(4,7956,END=7964,ERR=7964)III,(FORM2(IV),IV=120,128),
  14321.      1  KKTYP
  14322.         If(Ibin.eq.1)
  14323.      1  READ(4,END=7964,ERR=7109)III,(FORM2(IV),IV=120,128),
  14324.      1  KKTYP
  14325. 7109    Continue
  14326.     FORM2(119)=Char(III)
  14327.     If(k3dfg.lt.0)goto 8602
  14328. C Handle F records (flags)
  14329.     If(Let1.ne.'F')goto 8602
  14330.     if(ibin.ne.0)goto 8603
  14331.     Read(form2c(1:15),8604,err=7961)I4S
  14332. c    DECODE(15,8604,FORM2(1),ERR=7961)I4S
  14333. 8604    FORMAT(I15)
  14334. 8603    Continue
  14335. C set all values together so if decode error occurs things will
  14336. C remain consistent.
  14337.     krdelt=i4s
  14338.     k3dfg=irrw
  14339.     kcdelt=iccl
  14340. C No further processing of flag records.
  14341.     GoTo 7961
  14342. 8602    Continue
  14343.     IF(LET1.EQ.'M')GOTO 6500
  14344. C M CODE MEANS WE'RE READING THE DISPLAY-TO-PHYSICAL MAP.
  14345. C GO HANDLE IT SPECIALLY, THEN RETURN. FLAGS RECORDS BY
  14346. C ADDING 64000 TO ROW AND COL NUMBERS TO AVOID GETTING
  14347. C GRAPHICS PROGRAMS MESSED UP.
  14348. C  NOTE THAT SAVING THE MAP WAS OPTIONAL AND IS NOT THE
  14349. C DO-NOTHING DEFAULT.
  14350.     IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
  14351.     IF(JCHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
  14352.     IF(IRRW.LE.0.OR.ICCL.LE.0)GOTO 9990
  14353.     IF(IRRW.GT.LDXM.OR.ICCL.GT.MDXM)GOTO 7961
  14354.     IF(IRRW.LT.LLDXM.OR.ICCL.LT.MMDXM) GOTO 7961
  14355. C PRODUCE NEW ADDRESSES IN PHYSICAL SHEET USING SAVED FILE'S ONES
  14356. C AND CURSOR LOCATION (SINCE WE SAVE/RESTORE RELATIVE TO CURSOR).
  14357. C THIS PROVIDES A SHEET PARTIAL SAVE / MERGE CAPABILITY.
  14358.     NR=IRRW+PROW-LLDXM
  14359.     NC=ICCL+PCOL-MMDXM
  14360.     IF(CMDLIN(2).NE.'D'.AND.LET1.NE.char(68))GOTO 7963
  14361.     IF(CMDLIN(2).EQ.'P'.or.ibin.eq.1)GOTO 7963
  14362. C GET DISPLAY VERSION...
  14363.     LRR=IRRW+DROW-LLDXM
  14364.     LCC=ICCL+DCOL-MMDXM
  14365.     LRR=MAX0(1,LRR)
  14366.     LCC=MAX0(1,LCC)
  14367.     IF(LRR.GT.DRWV.OR.LCC.GT.DCLV)GOTO 7961
  14368.     NR=NRDSP(LRR,LCC)
  14369.     NC=NCDSP(LRR,LCC)
  14370. 7963    CONTINUE
  14371. C LET1='p'WILL COME HERE TOO. HANDLE IT SINCE IT'S NUMERIC STUFF.
  14372. C    IRX=(NC-1)*60+NR
  14373.     CALL REFLEC(NC,NR,IRX)
  14374.     IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961
  14375.     FORM2(118)=CHAR(15)
  14376.     DO 7113 IVV=1,128
  14377. 7113    FORM(IVV)=FORM2(IVV)
  14378.     INRW=PROW
  14379.     INCL=PCOL
  14380.     JOUTR=1
  14381.     JOUTC=2
  14382. C A1 = OUT LOCATION FOR INPUT CELL NAMES
  14383.     JRTR=1
  14384.     JRTC=1
  14385.     IF(CMDLIN(3).EQ.'R')CALL RELVBL(FORM,FORM2,JOUTR,JOUTC,
  14386.      1  INRW,INCL,JRTR,JRTC)
  14387. C ALLOW RELOCATION ON LOADING SAVED SHEET IF DESIRED.
  14388.     CALL FVLDST(NR,NC,FORM2(119))
  14389. C    FVLD(NR,NC)=FORM2(119)
  14390.     CALL TYPSET(NR,NC,KKTYP)
  14391. C    TYPE(NR,NC)=KKTYP
  14392.     CALL CA2E(FORM2,FORM)
  14393.     IF(LET1.NE.'p')CALL WRKFIL(IRX,FORM,1)
  14394. C    WRITE(7'IRX)FORM2
  14395.     IF(LET1.NE.'p')GOTO 7961
  14396. C HAVE LOWERCASE 'p' NOW AS NUMERIC SAVE FLAG FOR THIS RECORD.
  14397.         if(Ibin.eq.1)xvbls(1,1)=r8s
  14398.         If(Ibin.eq.0)
  14399.      1  READ(CFORM2(1:35),6408,ERR=7961)XVBLS(1,1)
  14400. 6408    FORMAT(BN,D30.19)
  14401.         If(Cmdlin(4).ne.'-'.And.Cmdlin(4).ne.'+')Goto 982
  14402.     CALL XVBLGT(NR,NC,R8WK)
  14403.     IF(CMDLIN(4).EQ.'+')XVBLS(1,1)=XVBLS(1,1)+R8WK
  14404.     IF(CMDLIN(4).EQ.'-')XVBLS(1,1)=R8WK-XVBLS(1,1)
  14405. C IMPLEMENT ADDING AND SUBTRACTING SAVED SHEETS FROM CURRENT.
  14406. C GOES TO RECALC MANUAL MODE SINCE RECALC WOULD MESS UP
  14407. C VALUES; FORMULAS GET UPDATED FROM LAST-READ SHEET NORMALLY.
  14408. 982     Continue
  14409.     CALL XVBLST(NR,NC,XVBLS(1,1))
  14410.     GOTO 7961
  14411. 6500    CONTINUE
  14412. C HERE READ MAPPINGS
  14413.     IRRW=IRRW-64000
  14414.     ICCL=ICCL-64000
  14415. C RESTORE OFFSETS TO NORMAL RANGE
  14416.         If(Ibin.eq.0)
  14417.      1  READ(CFORM2(1:35),6501,ERR=7961)II,III
  14418.         If(Ibin.eq.1)ii=i4s
  14419.     if(Ibin.ne.1)goto 9510
  14420. c overcome alignment restrictions on sun etc...
  14421.     i4ttc(1)=form2(3)
  14422.     i4ttc(2)=form2(4)
  14423.     i4ttc(3)=form2(5)
  14424.     i4ttc(4)=form2(6)
  14425.     i4t=i4ttt
  14426. 9510    continue
  14427.         If(Ibin.eq.1)iii=i4t
  14428. 6501    FORMAT(2I7)
  14429.     NRDSP(IRRW,ICCL)=II
  14430.     NCDSP(IRRW,ICCL)=III
  14431. C GO BACK FOR MORE. INEFFICIENT STORAGE OF MAP BUT IT'S COMPACT
  14432. C CODE...
  14433.     GOTO 7961
  14434. 7964    CONTINUE
  14435.     CLOSE(4)
  14436. 9990    NXINI=0
  14437.     RETURN
  14438. 510    CONTINUE
  14439.     IRTN=1
  14440.     NXINI=0
  14441.     CLOSE(IOLVL)
  14442. c    CLOSE(11)
  14443. c    OPEN(5,FILE='CON:0/0/100/100/Analy Command')
  14444.     RETURN
  14445.     END
  14446. c -h- pmtx2.for    Tue Sep  2 10:58:55 1986    
  14447.     SUBROUTINE PMTX2(IRTCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  14448.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  14449.     CHARACTER*1 LINE(80)
  14450.     CALL GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
  14451.      1  ID2B,RETCD)
  14452. C GET LOC OF MATRIX A (MUST BE SQUARE)
  14453.     IBGN=LSTCHR+1
  14454.     IF(RETCD.NE.0.OR.IMXX.LE.1)GOTO 1000
  14455.     IF(LINE(LSTCHR).NE.',')GOTO 300
  14456.     CALL GMTX(LINE,IBGN,LSTCHR,IDXA,IDXB,IDYA,
  14457.      1  IDYB,RETCD)
  14458. C GET LOC OF MATRIX X (RESULT).
  14459.     IBGN=LSTCHR+1
  14460.     IF(RETCD.NE.0.OR.IMXX.LE.2)GOTO 1000
  14461.     IF(LINE(LSTCHR).NE.',')GOTO 300
  14462.     CALL GMTX(LINE,IBGN,LSTCHR,IDBA,IDBB,IDCA,
  14463.      1  IDCB,RETCD)
  14464.     IBGN=LSTCHR+1
  14465. C GET LOC OF MATRIX B (AX=B), THE OTHER HALF OF OUR GIVENS
  14466. C IF WE FALL TO HERE, ALL LOOKS OK, SO LEAVE RETCD ALONE.
  14467. C HOWEVER IF ANY ERRS HAVE OCCURRED, RETCD IS ALREADY SET TO 3
  14468. C FOR ERROR...
  14469. 1000    RETURN
  14470. 300    CONTINUE
  14471.     RETCD=3
  14472.     RETURN
  14473.     END
  14474. c -h- postvl.for    Tue Sep  2 10:58:55 1986    
  14475.     SUBROUTINE POSTVL (RETCD)
  14476. C COPYRIGHT (C) 1983 GLENN EVERHART
  14477. C ALL RIGHTS RESERVED
  14478. C 60=MAX REAL ROWS
  14479. C 301=MAX REAL COLS
  14480. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  14481. C VBLS AND TYPE DIMENSIONED 60,301
  14482. C **************************************************
  14483. C *                                                *
  14484.  
  14485. C *      SUBROUTINE  POSTVL (RETCD)                *
  14486. C *                                                *
  14487. C **************************************************
  14488. C
  14489. C
  14490. C  CONVERTS POSTFIX EXPRESSIONS IN STACK 1 TO A VALUE
  14491. C
  14492. C
  14493. C    RETCD    MEANING
  14494. C
  14495. C    1    O.K.
  14496. C    2    ERROR
  14497. C
  14498. C POSTVL CALLS
  14499. C
  14500. C CALBIN    CALCULATES BINARY OPERATIONS
  14501. C CALUN     CALCULATES UNARY OPERATIONS
  14502. C ERRMSG    PRINTS OUT ERROR MESSAGES
  14503. C VAROUT    OUTPUTS THE VALUE OF A VARIABLE
  14504. C
  14505. C
  14506. C
  14507. C
  14508. C POSTVL IS CALLED BY CALC
  14509. C
  14510. C
  14511. C
  14512. C
  14513. C VARIABLE    USE
  14514. C _________ ___________________________
  14515. C
  14516. C    I,K     TEMPORARY VALUES
  14517. C
  14518. C    PT1     POINTS TO TOP ELEMENT IN STACK1
  14519. C
  14520. C    RETCD   RETURN CODE: 1=O.K., 2=ERROR
  14521. C
  14522. C    RETCD2  USED TO HOLD RETURN CODE WHEN CALLS TO
  14523. C            OTHER ROUTINES ARE MADE.
  14524. C
  14525. C    ST1PT   STACK 1 POINTER.
  14526. C
  14527. C    ST2PT   STACK 2 POINTER.
  14528. C
  14529. C    ST1TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 1
  14530. C
  14531. C    ST2TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 2
  14532. C
  14533. C    STACK1  HOLDS ORIGINAL POSTFIX EXPRESSION.
  14534. C
  14535. C    STACK2  USED TO EVALUATE EXPRESSION IN STACK1.
  14536. C
  14537. C    TYPE(27) HOLDS THE DATA TYPE FOR EACH OF THE VARIABLES.
  14538. C
  14539. C    AVBLS(100,27) HOLDS VALUES OF VARIABLES.
  14540. C    VBLS(8,60,301) HOLDS VALUE OF COMPLEXLY-NAMED VARIABLES. 1ST 27 ELEMENTS
  14541. C    ARE PLACE HOLDERS FOR AVBLS; ROUTINES THAT GENERATE DIMENSIONS ID1,ID2
  14542. C    FOR VBLS RETURN DIMENSIONS 1-27,1 FOR A-Z,%. THESE RESULT IN AVBLS
  14543. C    ARRAY BEING USED. VBLS ARRAY (MAX LENGTH 8 BYTES/VARIABLE) IS USED
  14544. C    FOR OTHER VARIABLES WHOSE NAMES ARE <ALPHA><ALPHA><NUM><NUM>
  14545. C    (WITH OPTION FOR ANY REASONABLE # OF ALPHAS AND NUMERICS BUT CLAMPED
  14546. C    AT 60,301 VALUES TO WORK CORRECTLY.)
  14547. C
  14548. C    VIEWSW   VIEW SWITCH:
  14549. C                0 = OFF
  14550. C                1 = DISPLAY COMMANDS
  14551. C                2 = DISPLAY VALUE OF EXPRESSIONS
  14552. C                3 = DISPLAY ALL
  14553. C
  14554. C
  14555. C
  14556. C    SUBROUTINE POSTVL (RETCD)
  14557. C
  14558.     InTeGer*4 LEVEL,NONBLK,LEND
  14559.     InTeGer*4 PT1
  14560.     InTeGer*4 VIEWSW,BASED
  14561.     InTeGer*4 RETCD,RETCD2,VLEN(9)
  14562.     InTeGer*4 TYPE(1,2)
  14563.     InTeGer*4 ST1TYP(40),ST2TYP(40)
  14564.     InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
  14565.     InTeGer*4 I,K
  14566. C
  14567.     CHARACTER*1 LINE(80)
  14568.     CHARACTER*1 STACK1(8,40), STACK2(8,40),AVBLS(24,27)
  14569.     Real*8 rstack1(40),rstack2(40)
  14570.     equivalence(rstack1(1),stack1(1,1))
  14571.     equivalence(rstack2(1),stack2(1,1))
  14572.     Real*8 VAVBLS(3,27)
  14573.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  14574.     CHARACTER*1 VBLS(8,1,1)
  14575. C
  14576.     COMMON /STACKx/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  14577.      ;           ST1LIM,ST2LIM
  14578.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  14579.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  14580. C
  14581. C
  14582.     RETCD=1
  14583. C
  14584. C
  14585. C IF THERE IS ONE ELEMENT IN STACK1 AND IT IS NOT
  14586. C A NUMBER, THE EXPRESSION IS ILLEGAL (GO TO 95).
  14587.     IF(ST1PT.EQ.2.AND.ST1TYP(1).GT.30)GO TO 95
  14588. C
  14589. C
  14590. 10    IF (ST1PT.GT.2) GOTO 40
  14591.     IF (ST1PT.EQ.1) GOTO 95
  14592. C
  14593. C
  14594. C ***************************************
  14595. C ****** ONLY 1 ELEMENT ON STACK 1 ******
  14596. C ***************************************
  14597.     K=VLEN(ST1TYP(ST1PT-1))
  14598. C
  14599. C
  14600. C COPY INTO VARIABLE %
  14601.     if(k.ne.8)goto 3223
  14602.     vavbls(1,27)=rstack1(1)
  14603.     goto 3222
  14604. c special case for real*8 since that's the most common
  14605. 3223    continue
  14606.     DO 20 I=1,K
  14607. 20    AVBLS(I,27)=STACK1(I,1)
  14608. 3222    continue
  14609.     CALL TYPSET(27,1,ST1TYP(1))
  14610. C    TYPE(27,1)=ST1TYP(1)
  14611. C
  14612. C
  14613. C OUTPUT VALUE OF %
  14614.     IF (VIEWSW.GT.1) CALL VAROUT(27,1)
  14615.     RETURN
  14616. C
  14617. C
  14618. C  MORE THAN ONE ELEMENT ON STACK1
  14619. 40    CONTINUE
  14620.     IF (ST1TYP(ST1PT-1).LE.30) GOTO 90
  14621.     IF (ST2PT.LE.ST2LIM) GOTO 45
  14622. C
  14623. C
  14624. C *** ERROR *** STACK 2 OVERFLOW
  14625.     CALL ERRMSG(9)
  14626. 43    RETCD=2
  14627.     RETURN
  14628. C
  14629. C
  14630. C
  14631. C
  14632. C ****************************************
  14633. C ****** OPERATOR SO PUT ON STACK 2 ******
  14634. C ****************************************
  14635. 45    ST2TYP(ST2PT)=ST1TYP(ST1PT-1)
  14636.     ST2PT=ST2PT+1
  14637.     ST1PT=ST1PT-1
  14638.     IF(ST1PT.EQ.1)GO TO 95
  14639.     GOTO 40
  14640. C
  14641. C
  14642. C
  14643. C
  14644. C
  14645. C *********************
  14646. C ****** OPERAND ******
  14647. C *********************
  14648. C
  14649. C FIRST BE SURE THAT THERE IS AN OPERATOR INVOLVED ON STACK 2
  14650. C (IF ONLY ONE ELEMENT IN STACK 1 YOU SHOULD NOT BE HERE).
  14651. 90    IF(ST2PT.NE.1)GO TO 110
  14652. C
  14653. C
  14654. C *** ERROR *** ILLLEGAL EXPRESSION
  14655. 95    CALL ERRMSG(8)
  14656.     GO TO 43
  14657. C
  14658. C
  14659. C
  14660. C
  14661. C ENTER HERE AFTER APPLYING AN OPERATOR TO A NUMBER
  14662. 100    IF (ST2PT.EQ.1) GOTO 10
  14663. 110    K=ST2TYP(ST2PT-1)
  14664. C
  14665. C IF A UNARY OPERATOR, GO TO 190
  14666.     IF ((K.GT.30.AND.K.LE.47).OR.K.EQ.111) GOTO 190
  14667. C
  14668. C
  14669. C IF A BINARY OPERATOR, GO TO 170
  14670.     IF (K.GE.110.AND.K.LE.117) GOTO 170
  14671.     IF(K.EQ.200)GO TO 170
  14672. C
  14673. C IF ELEMENT ON STACK2 AT ST2PT-1 IS AN OPERAND, APPLY CALBIN AGAIN
  14674.     IF(K.LE.30) GO TO 180
  14675.     STOP 110
  14676. C
  14677. C
  14678. C
  14679. C
  14680. C ***************************************************************
  14681. C ****** CALBIN CALCULATES THE BINARY VALUE OF AN OPERATOR ******
  14682. C ***************************************************************
  14683. C  UPON ENTRANCE:
  14684. C    OPERAND 1 IS IN STACK 1
  14685. C    OPERAND 2 IS IN STACK 2
  14686. C    OPERATOR IS BELOW OPERAND 2
  14687. C  UPON EXIT RESULT IS ON STACK 1
  14688. C
  14689. C    RETURN CODE    MEANING
  14690. C
  14691. C    1        O.K.
  14692. C    2        OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  14693. C    3        ERROR ENCOUNTERED
  14694. C
  14695. C
  14696. 170    CONTINUE
  14697. C
  14698. C
  14699. C FIRST PUT OPERAND 2 ONTO STACK 2
  14700.     PT1=ST1PT-1
  14701.     ST2TYP(ST2PT)=ST1TYP(PT1)
  14702.     K=VLEN(ST2TYP(ST2PT))
  14703.     DO 175 I=1,K
  14704. 175    STACK2(I,ST2PT)=STACK1(I,PT1)
  14705.     ST1PT=ST1PT-1
  14706.     IF(ST1PT.EQ.1)GO TO 95
  14707.     ST2PT=ST2PT+1
  14708. C
  14709. C
  14710. C IF OPERAND 1 IS AN OPERATOR, PUT IT ON STACK 2 (GO TO 45)
  14711.     IF(ST1TYP(ST1PT-1).GT.30) GO TO 45
  14712. 180    CALL CALBIN (RETCD2)
  14713.     GOTO (100,1000,43), RETCD2
  14714.     STOP 180
  14715. C
  14716. C
  14717. C
  14718. C
  14719. C
  14720. C ********************************************************************
  14721. C ****** CALL CALUN TO CALCULATE THE VALUE OF A UNARY OPERATION ******
  14722. C ********************************************************************
  14723. C    OPERATOR IS IN STACK 2
  14724. C    OPERAND IS IN STACK 1
  14725. C    UPON EXIT, OPERATOR IS POPPED OFF STACK 2
  14726. C
  14727. C    RETURN CODE    MEANING
  14728. C
  14729. C    1        O.K.
  14730. C    2        OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  14731. C    3        ERROR ENCOUNTERED
  14732. C
  14733. C
  14734. 190    CALL CALUN (RETCD2)
  14735.     GOTO(100,43),RETCD2
  14736.     STOP 190
  14737. C
  14738. C
  14739. 1000    RETURN
  14740.     END
  14741. c -h- prtcon.for    Tue Sep  2 10:58:55 1986    
  14742. C **********************************
  14743. C *                                *
  14744. C *    INTERNAL FUNCTION PRTCON    *
  14745. C *                                *
  14746. C **********************************
  14747. C CALLED BY MOUT ONLY
  14748. C CONVERTS 0 TO APPROPRIATE NUMBER FOR PRINTING WITH VECTOR DIGITS
  14749.     FUNCTION PRTCON(L1,IBASE)
  14750.     InTeGer*4 BASE(3)
  14751.     InTeGer*4 IBASE,K
  14752.     CHARACTER*1 L1,PRTCON,DIGITS(16,3)
  14753.     COMMON /DIGV/ DIGITS
  14754.     save base
  14755.     DATA BASE /10,8,16/
  14756.     PRTCON=L1
  14757.     IF(L1.EQ.char(0))PRTCON=CHAR(BASE(IBASE))
  14758.     K=ICHAR(PRTCON)
  14759.     PRTCON=DIGITS(K,IBASE)
  14760.     RETURN
  14761.     END
  14762. c -h- rassig.for    Tue Sep  2 10:58:55 1986    
  14763.     SUBROUTINE RASSIG(IUNIT,NAME,ierr)
  14764. C
  14765. C
  14766.     CHARACTER*1 NAME(50)
  14767.     InTeGer*4 IUNIT,ierr
  14768. C &&&& MS FTN 3.2
  14769.     LOGICAL LEXIST
  14770. C &&&&
  14771.     CHARACTER*20 WK
  14772.     CHARACTER*1 WK1(20)
  14773.     EQUIVALENCE(WK(1:1),WK1(1))
  14774. C JUST TRY AND NULL FILL A NAME TO USE.
  14775.     ierr=0
  14776.     DO 1 N=1,20
  14777.     WK1(N)=' '
  14778. 1    CONTINUE
  14779.     DO 2 N=1,20
  14780.     II=ICHAR(NAME(N))
  14781.     IF(II.LT.32)GOTO 3
  14782.     WK1(N)=CHAR(II)
  14783. C1    CONTINUE
  14784. 2    CONTINUE
  14785. 3    CONTINUE
  14786. C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
  14787. C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
  14788. C AVOID CRASHES IF THE FILE ISN'T THERE...
  14789. C MSDOS FORTRAN 3.2 AND LATER FEATURE...
  14790. C &&&&
  14791. C
  14792. C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
  14793. C
  14794.     INQUIRE(FILE=WK(1:20),EXIST=LEXIST)
  14795.     IF(LEXIST)GOTO 100
  14796. C FILE DOES NOT EXIST, SO CREATE IT HERE.
  14797. C IF CREATE FAILS WE LOSE TOO...
  14798. c    CALL UVT100(1,1,1)
  14799. c    CALL SWRT('File not found. Attempting to create.',37)
  14800. c    OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
  14801. c     1  FORM='FORMATTED')
  14802. c    CLOSE(IUNIT)
  14803. c
  14804. c On failure to open a file, create a window instead which
  14805. c can be its surrogate...
  14806.     ierr=1
  14807. c flag error if no file to read
  14808. c
  14809. c    Open(Iunit,file='con:200/100/400/60/RdErr' // wk,
  14810. c     1  Access='Sequential',form='Formatted')
  14811. cccc    Open(Iunit,file='/dev/tty',
  14812. cccc     1  Access='Sequential',form='Formatted')
  14813. C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
  14814. C WILL GET EOF ON START, BUT THAT'S TOO BAD...
  14815.     Goto 77
  14816. 100    CONTINUE
  14817. C &&&&
  14818. C IF JUST CALL ASSIGN, ASSUME FOR READ.
  14819.     OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
  14820.      1  FORM='FORMATTED')
  14821. 77    CONTINUE
  14822. C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
  14823. C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
  14824.     RETURN
  14825.     END
  14826. c -h- recalc.f40    Tue Sep  2 10:58:55 1986    
  14827.     SUBROUTINE RECALC
  14828. C COPYRIGHT (C) 1983,1984,1985,1986 GLENN EVERHART
  14829. C ALL RIGHTS RESERVED
  14830. C RECALCULATE COMMAND
  14831. C RECOMPUTE ALL ELEMENTS OF SPREADSHEET WHERE VALID.
  14832. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  14833. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  14834. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  14835. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  14836. C FROM THE DISK BASED FILE HERE.
  14837.     Include aparms.inc
  14838.     CHARACTER*1 FORM,FVLD
  14839. c    INTEGER*4 VNLT
  14840. C ***<<< XVXTCD COMMON START >>>***
  14841.     CHARACTER*1 OARRY(100)
  14842.     InTeGer*4 OSWIT,OCNTR
  14843. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  14844. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  14845.     InTeGer*4 IPS1,IPS2,MODFLG
  14846. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  14847.        InTeGer*4 XTCFG,IPSET,XTNCNT
  14848.        CHARACTER*1 XTNCMD(80)
  14849. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  14850. C VARY FLAG ITERATION COUNT
  14851.     INTEGER KALKIT
  14852. C    COMMON/VARYIT/KALKIT
  14853.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  14854.     InTeGer*4 RCMODE,IRCE1,IRCE2
  14855. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14856. C     1  IRCE2
  14857. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  14858. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  14859. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  14860. C RCFGX ON.
  14861. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  14862. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  14863. C  AND VM INHIBITS. (SETS TO 1).
  14864.     INTEGER*4 FH
  14865. C FILE HANDLE FOR CONSOLE I/O (RAW)
  14866. C    COMMON/CONSFH/FH
  14867.     CHARACTER*1 ARGSTR(52,4)
  14868. C    COMMON/ARGSTR/ARGSTR
  14869.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  14870.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  14871.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  14872.      3  IRCE2,FH,ARGSTR
  14873. C ***<<< XVXTCD COMMON END >>>***
  14874. CCCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  14875. CCCC     1  IRCE1,IRCE2
  14876. CCCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  14877. CCCC     1  IRCE1,IRCE2
  14878. C ***<<< KLSTO COMMON START >>>***
  14879.     InTeGer*4 DLFG
  14880. C    COMMON/DLFG/DLFG
  14881.     InTeGer*4 KDRW,KDCL
  14882. C    COMMON/DOT/KDRW,KDCL
  14883.     InTeGer*4 DTRENA
  14884. C    COMMON/DTRCMN/DTRENA
  14885.     REAL*8 EP,PV,FV
  14886.     DIMENSION EP(20)
  14887.     INTEGER*4 KIRR
  14888. C    COMMON/ERNPER/EP,PV,FV,KIRR
  14889.     InTeGer*4 LASTOP
  14890. C    COMMON/ERROR/LASTOP
  14891.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  14892. C    COMMON/FMTBFR/FMTDAT
  14893.     CHARACTER*1 EDNAM(16)
  14894. C    COMMON/EDNAM/EDNAM
  14895.     InTeGer*4 MFID(2),MFMOD(2)
  14896. C    COMMON/FRM/MFID,MFMOD
  14897.     InTeGer*4 JMVFG,JMVOLD
  14898. C    COMMON/FUBAR/JMVFG,JMVOLD
  14899.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  14900.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  14901. C ***<<< KLSTO COMMON END >>>***
  14902. CCC    InTeGer*4 DLFG
  14903. CCC    COMMON/DLFG/DLFG
  14904. C DLFG=1 IF D## FORMS HAVE BEEN SEEN, ELSE 0
  14905.     DIMENSION FORM(128),FVLD(1,1)
  14906.     COMMON/FVLDC/FVLD
  14907. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  14908. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  14909. C SO INITIALLY IGNORE.
  14910. C FVLD=-2 OR -3 = DISPLAY FORMULA
  14911. C FVLD=3 NUMERIC, COMPUTE ONCE THEN SET FVLD TO 2
  14912. C FVLD=2 NUMERIC CONSTANT, ALREADY COMPUTED... DO NOT RECOMPUTE.
  14913. C
  14914. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  14915. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  14916. C ***<<<< RDD COMMON START >>>***
  14917.     InTeGer*4 RRWACT,RCLACT
  14918. C    COMMON/RCLACT/RRWACT,RCLACT
  14919.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  14920.      1  IDOL7,IDOL8
  14921. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  14922. C     1  IDOL7,IDOL8
  14923.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  14924. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14925.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14926. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  14927. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  14928. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  14929.     InTeGer*4 KLVL
  14930. C    COMMON/KLVL/KLVL
  14931.     InTeGer*4 IOLVL,IGOLD
  14932. C    COMMON/IOLVL/IOLVL
  14933. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  14934. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  14935.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  14936.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  14937.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  14938.      3  k3dfg,kcdelt,krdelt,kpag
  14939. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  14940. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  14941. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  14942. C ***<<< RDD COMMON END >>>***
  14943. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14944. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  14945.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  14946.     COMMON/D2R/NRDSP,NCDSP
  14947.     InTeGer*4 TYPE(1,2),VLEN(9)
  14948.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  14949.     Real*8 VAVBLS(3,27)
  14950.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  14951. CCC    InTeGer*4 RRWACT,RCLACT
  14952. CCC    COMMON/RCLACT/RRWACT,RCLACT
  14953. CCC    InTeGer*4 KDRW,KDCL
  14954. CCC    COMMON /DOT/KDRW,KDCL
  14955.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  14956.     InTeGer*4 PRS,PCS,DRS,DCS
  14957.     Character*6 cwrk6
  14958.     PRS=PROW
  14959.     PCS=PCOL
  14960.     DRS=DROW
  14961.     DCS=DCOL
  14962.     IF(RCMODE.EQ.2)GOTO 5500
  14963. C THE FOLLOWING 2 LOOPS DEFINE ORDER OF CALCULATION.
  14964. C HERE THIS IS: OUTER LOOP ON ROWS (ACROSS), INNER LOOP ON COLUMNS (DOWN).
  14965. C NOTE THAT N2 DEFINES THE SHEET. SINCE 1 IS THE ACCUMULATORS, JUST GO THRU
  14966. C FOR THE SHEET, NOT THE AC'S.
  14967.     DO 1 N2=2,RCLACT
  14968.     IF(IDOL8.EQ.0)GOTO 8220
  14969. C VIEW HACK HERE
  14970. C DISPLAY ROW NUMBER FOLLOWED BY BARE CR DURING RECALC
  14971.     KKKK=13
  14972. C 13 IS ASCII CARRIAGE RETURN
  14973.     write(cwrk6,8221)n2
  14974.     call uvt100(1,llcmd,60)
  14975.     call vwrt(cwrk6,5)
  14976. c    REWIND 11
  14977. c    WRITE(11,8221)N2,KKKK
  14978. c    REWIND 11
  14979. 8221    FORMAT(I5,1A1)
  14980. 8220    CONTINUE
  14981.     N1=1
  14982. 220    CONTINUE
  14983. C    DO 2 N1=1,60
  14984. C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
  14985. C FASTER THAN STANDARD LOOP METHOD.
  14986. C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
  14987. C OF FVLDGT AND FVPEEK.
  14988. C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
  14989. C 
  14990. CCCC COMMENT 2 LINES OUT WHEN FAST FVLDGT IS IN TO SPEED UP MORE...
  14991. CCCC EXTRA LOGIC IN FVPEEK DOESN'T USUALLY PAY FOR ITSELF...
  14992. CCC    CALL FVPEEK(N1,N2,NN1)
  14993. CCC    N1=NN1
  14994.     CALL FVLDGT(N1,N2,FVLD(1,1))
  14995.     IIFV=JCHAR(FVLD(1,1))
  14996.     IF (IIFV.LE.0) GOTO 2
  14997.     IRRX=(N2-1)*MCols+N1
  14998. C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
  14999. C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
  15000.     IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 2
  15001.     KDRW=N1
  15002.     KDCL=N2
  15003.     PROW=N1
  15004.     PCOL=N2
  15005. C SEE IF THIS PHYS COL HAS A DISPLAY COL. AND IF SO SET THAT UP.
  15006. C ONLY SET TO DISPLAYED LOCS HERE TO MINIMIZE SEARCH TIME.
  15007. C NEED THIS TO HANDLE D## FORMS...
  15008.     IF (DLFG.EQ.0)GOTO 95
  15009. C IF NEVER HAD A D## FORM FORGET LOOKING FOR DISPLAY LOCS.
  15010.     DO 20 M2=1,DCLV
  15011.     DO 10 M1=1,DRWV
  15012.     M1X=M1
  15013.     M2X=M2
  15014. C LOOK FOR DISPLAY COORDS EVEN IF IN HYPERSPACE
  15015. C WE FIND ONE IF INDEX FROM REFLECT IS SAME AS WHAT
  15016. C WE'RE LOOKING FOR...
  15017.     IF(NRDSP(M1,M2).EQ.N1.AND.NCDSP(M1,M2).EQ.N2)GOTO 9
  15018. 10    CONTINUE
  15019. 20    CONTINUE
  15020. 95    CONTINUE
  15021. C HERE IF CELL NOT DISPLAYED... SEE IF NEEDS DOING IN RI, RE MODES
  15022.     IF(RCMODE.LE.0)GOTO 9
  15023.     IF(PROW.NE.IRCE1.OR.PCOL.NE.IRCE2)GOTO 2
  15024. C SKIP UNLESS ENTER CELL.
  15025. 9    CONTINUE
  15026. C IF NO DISPLAY ROW, LEAVE AT LOW RIGHT...
  15027. C USE SAVED VALUES SO WE DON'T RELY ON DO LOOP INDEX AFTER LOOP END.
  15028.     DROW=M1X
  15029.     DCOL=M2X
  15030.     CALL WRKFIL(IRRX,FORM,0)
  15031. C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
  15032.     LFST=1
  15033. C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
  15034. C THEM UP A BIT.
  15035.     DO 56 N=1,109
  15036.     LLST=111-N
  15037.     IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 57
  15038.     FORM(LLST)=Char(0)
  15039. 56    CONTINUE
  15040. 57    CONTINUE
  15041.     FORM(LLST)=Char(0)
  15042.     FORM(111)=Char(0)
  15043. C    IF(ICHAR(FORM(118)).NE.15)GOTO 2
  15044. c ****&&&& experimental...
  15045. c &&&&&**** replace llst by llst-1
  15046. c    llst=max0(1,llst-1)
  15047.     CALL DOENTR(FORM,LFST,LLST)
  15048. C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
  15049. C    CALL FVLDGT(N1,N2,FVLD(1,1))
  15050.     IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
  15051. 2    CONTINUE
  15052.     N1=N1+1
  15053.     IF(N1.LE.RRWACT)GOTO 220
  15054. 1    CONTINUE
  15055.     GOTO 5600
  15056. 5500    CONTINUE
  15057. C RCMODE=2 AND NOT RM MODE
  15058. C (IN RM MODE, RECALC IS NOT CALLED...)
  15059.     DO 1701 M2=1,DCLV
  15060.     IF(IDOL8.EQ.0)GOTO 8222
  15061. C VIEW HACK HERE
  15062. C DISPLAY ROW NUMBER FOLLOWED BY BARE CR DURING RECALC
  15063.     KKKK=13
  15064. C 13 IS ASCII CARRIAGE RETURN
  15065.     write(cwrk6,8221)n2
  15066.     call uvt100(1,llcmd,60)
  15067.     call vwrt(cwrk6,5)
  15068. C 13 IS ASCII CARRIAGE RETURN
  15069. c    REWIND 11
  15070. c    WRITE(11,8221)M2,KKKK
  15071. c    REWIND 11
  15072. 8222    CONTINUE
  15073.     KDRW=1
  15074.     KDCL=2
  15075.     DO 1702 M1=1,DRWV
  15076. C TO HANDLE DISPLAY WHEREVER IT MAY BE, FIND ID OF PHYS CELL AND
  15077. C CONVERT TO PHYS ROW, COL AGAIN REGARDLESS OF ALIAS...
  15078. C (NOTE CALC ORDER IS THEREFORE DISPLAY ORDER, NOT SHEET ORDER...)
  15079.     K=NRDSP(M1,M2)
  15080.     KK=NCDSP(M1,M2)
  15081.     CALL REFLEC(KK,K,IV1)
  15082.     NRC=IV1-1
  15083.     N1=MOD(NRC,MCols)+1
  15084.     N2=((NRC-N1+1)/MCols)+1
  15085. C COMPUTE PHYS ROW, COL FROM DISPLAY COORDINATES.
  15086. C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
  15087. C FASTER THAN STANDARD LOOP METHOD.
  15088. C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
  15089. C OF FVLDGT AND FVPEEK.
  15090. C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
  15091.     If (N1.gt.RRWACT.or.N2.Gt.RCLACT) GOTO 1702
  15092.     CALL FVLDGT(N1,N2,FVLD(1,1))
  15093.     IIFV=JCHAR(FVLD(1,1))
  15094.     IF (IIFV.LE.0) GOTO 1702
  15095. C FORGET THIS CELL IF NOT A COMPUTABLE ONE...
  15096.     IRRX=IV1
  15097. C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
  15098. C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
  15099.     IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 1702
  15100.     KDRW=N1
  15101.     KDCL=N2
  15102.     PROW=N1
  15103.     PCOL=N2
  15104.     DROW=M1
  15105.     DCOL=M2
  15106.     CALL WRKFIL(IRRX,FORM,0)
  15107. C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
  15108.     LFST=1
  15109. C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
  15110. C THEM UP A BIT.
  15111. C (ALSO GUARANTEE WE HAVE LOTS OF NULLS AT END TO TERMINATE INDEX ROUTINES)
  15112.     DO 756 N=1,109
  15113.     LLST=111-N
  15114.     IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 757
  15115.     FORM(LLST)=Char(0)
  15116. 756    CONTINUE
  15117. 757    CONTINUE
  15118.     FORM(LLST)=Char(0)
  15119.     FORM(111)=Char(0)
  15120. C CALL DOENTR TO DO THE ACTUAL COMPUTATION WORK...
  15121.     CALL DOENTR(FORM,LFST,LLST)
  15122. C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
  15123.     IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
  15124. 1702    CONTINUE
  15125. 1701    CONTINUE
  15126. C END OF COMPUTATION OVER DISPLAYS
  15127. C    GOTO 5600
  15128. 5600    CONTINUE
  15129.     PROW=PRS
  15130.     PCOL=PCS
  15131.     DROW=DRS
  15132.     DCOL=DCOL
  15133. C FORCE FUNCTION WORKS ONCE ONLY.
  15134.     RCONE=0
  15135.     RCMODE=IABS(RCMODE)
  15136. C SET FOR TEMP. RECALC-ALL MODES TO RETURN TO NORMAL.
  15137.     IRCE1=0
  15138.     IRCE2=0
  15139.     RETURN
  15140.     END
  15141. c -h- reflect.f40    Tue Sep  2 10:58:55 1986    
  15142.     SUBROUTINE REFLEC(ID1,ID2,ID)
  15143. C FORM ID OUT OF ID1,ID2 BUT USING REFLECTED VALUES SO THAT
  15144. C RESULT ID IS ALWAYS IN PRIME AREA.
  15145.     Include aparms.inc
  15146.     InTeGer*4 ID,ID1,ID2,IDD1,IDD2
  15147. C ***<<< NULETC COMMON START >>>***
  15148.     InTeGer*4 ICREF,IRREF
  15149. C    COMMON/MIRROR/ICREF,IRREF
  15150.     InTeGer*4 MODPUB,LIMODE
  15151. C    COMMON/MODPUB/MODPUB,LIMODE
  15152.     InTeGer*4 KLKC,KLKR
  15153.     REAL*8 AACP,AACQ
  15154. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  15155.     InTeGer*4 NCEL,NXINI
  15156. C    COMMON/NCEL/NCEL,NXINI
  15157.     CHARACTER*1 NAMARY(20,MRows)
  15158. C    COMMON/NMNMNM/NAMARY
  15159.     InTeGer*4 NULAST,LFVD
  15160. C    COMMON/NULXXX/NULAST,LFVD
  15161.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  15162.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  15163. C ***<<< NULETC COMMON END >>>***
  15164. CCC    COMMON/MIRROR/ICREF,IRREF
  15165. C IN RECALC WE MOVE OVER PRIME AREA ONLY AND SEARCH FOR CELLS IN
  15166. C DISPLAY AREA THERE. THIS IMPLIES THAT WE DON'T FIND DISPLAY
  15167. C COORDS OF CELLS IN EXTENDED AREAS THERE.  THEREFORE THE RI AND RE
  15168. C MODES FAIL COMPLETELY THERE. SINCE WE WANT THE SYSTEM TO WORK IN
  15169. C A PREDICTABLE WAY, FORCE RECALC MODE (I.E., R OR RM MODES) THERE TO
  15170. C ALLOW CELLS TO BE COMPUTED.
  15171. C NOTE THAT IF WE ARE IN THE PRIME AREA AND ISSUE AN RE OR RI COMMAND,
  15172. C THAT MODE SHOULD STAY SET SO LONG AS WE STAY THERE SINCE THE RE OR
  15173. C RI MODES WILL INHIBIT COMPUTING OUTSIDE THAT AREA (AS LONG AS NOTHING
  15174. C REFLECTS INTO IT) SO THERE WILL BE NO REASON FOR THIS TO BE CALLED
  15175. C TO REFLECT SOMETHING BACK TO PRIME AREA UNTIL A R COMMAND IS GIVEN
  15176. C OR THE DISPLAY MOVES OFF THE EDGE OF THE PRIME 60 BY 301 AREA.
  15177. C
  15178. C ***<<< XVXTCD COMMON START >>>***
  15179.     CHARACTER*1 OARRY(100)
  15180.     InTeGer*4 OSWIT,OCNTR
  15181. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  15182. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  15183.     InTeGer*4 IPS1,IPS2,MODFLG
  15184. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  15185.        InTeGer*4 XTCFG,IPSET,XTNCNT
  15186.        CHARACTER*1 XTNCMD(80)
  15187. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  15188. C VARY FLAG ITERATION COUNT
  15189.     INTEGER KALKIT
  15190. C    COMMON/VARYIT/KALKIT
  15191.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  15192.     InTeGer*4 RCMODE,IRCE1,IRCE2
  15193. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  15194. C     1  IRCE2
  15195. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  15196. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  15197. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  15198. C RCFGX ON.
  15199. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  15200. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  15201. C  AND VM INHIBITS. (SETS TO 1).
  15202.     INTEGER*4 FH
  15203. C FILE HANDLE FOR CONSOLE I/O (RAW)
  15204. C    COMMON/CONSFH/FH
  15205.     CHARACTER*1 ARGSTR(52,4)
  15206. C    COMMON/ARGSTR/ARGSTR
  15207.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  15208.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  15209.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  15210.      3  IRCE2,FH,ARGSTR
  15211. C ***<<< XVXTCD COMMON END >>>***
  15212. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE
  15213. CCC    InTeGer*4 IRCE1,IRCE2
  15214. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,IRCE2
  15215.     IDD1=MAX0(ID1,1)
  15216.     IDD2=ID2
  15217. C ACCEPT TRICK CALLS WITH ID1=0 AS FROM GMSUBS, MTXEQU,
  15218. C AND MDST
  15219.     IF(ID1.LT.1)GOTO 2000
  15220. 4000    CONTINUE
  15221.     IF(IDD2.LE.MCols)GOTO 1000
  15222.     IDD2=IDD2-MCols
  15223.     IDD1=IDD1+IRREF
  15224. c    RCMODE=0
  15225. C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
  15226.     GOTO 4000
  15227. 1000    CONTINUE
  15228.     IF(IDD1.LE.MRows)GOTO 2000
  15229.     IDD1=IDD1-MRows+1
  15230.     IDD2=IDD2+ICREF
  15231. c    RCMODE=0
  15232. C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
  15233.     GOTO 4000
  15234. 2000    CONTINUE
  15235.     ID=(IDD1-1)*MCols+IDD2
  15236.     RETURN
  15237.     END
  15238. c -h- relvbl.for    Tue Sep  2 10:58:55 1986    
  15239.     SUBROUTINE RELVBL(LNIN,LNOUT,INRW,INCL,JOUTR,JOUTC,JRTR,JRTC)
  15240. C RELOCATE VARIABLES BELOW/RIGHT OF JRTR,JRTC INTO LNOUT FROM LNIN
  15241. C    PARAMETER CUP=1,ED=11,EL=12
  15242.     Include aparms.inc
  15243.     CHARACTER*1 NAME(4),NUMBER(6)
  15244.     CHARACTER*1 LNIN,LNOUT
  15245.     CHARACTER*6 NUMBR6
  15246.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  15247.     DIMENSION LNIN(128),LNOUT(128)
  15248. C ***<<<< RDD COMMON START >>>***
  15249.     InTeGer*4 RRWACT,RCLACT
  15250. C    COMMON/RCLACT/RRWACT,RCLACT
  15251.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  15252.      1  IDOL7,IDOL8
  15253. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  15254. C     1  IDOL7,IDOL8
  15255.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  15256. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  15257.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15258. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  15259. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  15260. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  15261.     InTeGer*4 KLVL
  15262. C    COMMON/KLVL/KLVL
  15263.     InTeGer*4 IOLVL,IGOLD
  15264. C    COMMON/IOLVL/IOLVL
  15265. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  15266.     Integer*4 K3dfg,kcdelt,krdelt,kpag,idol9,idsptp
  15267. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  15268.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  15269.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  15270.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,Idsptp,Idol9,
  15271.      3  k3dfg,kcdelt,krdelt,kpag
  15272. C ***<<< RDD COMMON END >>>***
  15273. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  15274. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  15275. C    LOGICAL*2 L63,L192,L255,L127,L128
  15276.     LOGICAL*4 L1,L2
  15277. C    InTeGer*4 I63,I192,I255,I127,I128
  15278.     InTeGer*4 I63,I192,I127
  15279.     InTeGer*4 I1,I2
  15280. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  15281.     EQUIVALENCE (I1,L1),(I2,L2)
  15282. C    EQUIVALENCE (L127,I127),(L128,I128)
  15283.     save i63,i192,i127
  15284. C    DATA I63/63/,I192/192/,I255/255/,I127/127/,I128/128/
  15285.     DATA I63/63/,I192/192/,I127/127/
  15286.     LI=1
  15287.     LO=1
  15288. C LI = INPUT LOCATION
  15289. C LO=OUTPUT LOCATION
  15290. 100    CONTINUE
  15291.     KSheet=0
  15292. C    IF(LNIN(LI).LT.'A'.OR.LNIN(LI).GT.'Z')GOTO 200
  15293.     LCC=ICHAR(LNIN(LI))
  15294. C IF WE HAVE 255,CODE,CODE THEN RELOCATE IN BINARY...
  15295.     IF(LCC.EQ.255)GOTO 500
  15296.     IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
  15297. C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
  15298.     IL1=LI
  15299.     LE=110
  15300.     LSTC=LE
  15301.     CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
  15302. C AVOID MESSING UP FUNCTION NAMES
  15303.     IF(ID2.EQ.1)IVLD=0
  15304. C    IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0
  15305.     IF(IVLD.EQ.0)GOTO 200
  15306. C FOUND VARIABLE. NOW GENERATE ASCII ANDSTUFF INTO OUTPUT.
  15307. C FIRST DON'T RELOCATE P## AND D## FORMS.
  15308.     IF(LNIN(LI+1).EQ.'#')GOTO 250
  15309. C RELOCATE NORMAL VARIABLE HERE.
  15310. C
  15311. C THE NEW VARIABLE IS TO BE DIFFERENT ONLY IF (ID1,ID2) HAS
  15312. C ID1.GT.JRTR AND ID2.GT.JRTC
  15313.     IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 210
  15314.     IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 210
  15315. C OK, KNOW NOW THAT WE HAVE TO RELOCATE ALL.
  15316. C THEREFORE ADD THE DIFFERENCE BETWEEN DEST AND SRC TO BOTH
  15317. C AND CLAMP TO VALID DIMENSIONS.
  15318.     IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
  15319.     IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
  15320. 906    ID1=MAX0(ID1,1)
  15321.     ID2=MAX0(ID2,1)
  15322. C CAN UNPACK THIS STUFF ALL RIGHT IN EXTENDED WAYS.
  15323.     ID1=MIN0(MRC,ID1)
  15324.     ID2=MIN0(MRC,ID2)
  15325. 210    CONTINUE
  15326.     KSHEET=0
  15327.     IF(K3DFG.LE.2)GOTO 2221
  15328. C RENAME CELLS BY 3D NAMES. (NOTE FLAG TO DO THIS; USE FOR DISPLAYS)
  15329. C ID1 GETS REDUCED BY COL. DELTA AND ID2 BY ROW DELTA
  15330. C UNTIL ONE OR BOTH ARE LESS THAN THE DELTAS. THEN THE %NNNN IS TACKED ON
  15331. C THE END. THIS PERMITS USERS TO DECIDE WHETHER THEY WANT THINGS TRANSLATED
  15332. C TO SHEET NUMBER FORMAT OR NOT.
  15333.     IF(KCDELT.LE.0.AND.KRDELT.LE.0)GOTO 2221
  15334.     KRR1=MRC
  15335.     KCC1=MRC
  15336.     IF(KCDELT.GT.0)KCC1=(ID1-1)/KCDELT
  15337.     IF(KRDELT.GT.0)KRR1=(ID2-2)/KRDELT
  15338.     KSH=MIN0(KRR1,KCC1)
  15339.     IF(KSH.GE.(MRC-100))GOTO 2221
  15340. C IF BOTH DELTAS ARE ZERO DON'T TOUCH ANYTHING.
  15341.     KSHEET=MAX0(KSH,0)
  15342. C KSHEET NONZERO FLAGS WE MAKE THE MOD
  15343.     IF(ID1.LT.KSHEET*KCDELT)GOTO 2220
  15344.     IF((ID2-1).LT.KSHEET*KRDELT)GOTO 2220
  15345.     ID1=ID1-KSHEET*KCDELT
  15346.     ID2=ID2-KSHEET*KRDELT
  15347. c222    CONTINUE
  15348.     GOTO 2221
  15349. 2220    CONTINUE
  15350.     KSHEET=0
  15351. 2221    CONTINUE
  15352.     CALL IN2AS(ID1,NAME)
  15353. C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
  15354.     IL2=ID2-1
  15355.     WRITE(NUMBR6(1:6),1000)IL2
  15356. C    ENCODE(6,1000,NUMBER)IL2
  15357. 1000    FORMAT(I6)
  15358. C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
  15359. C THROW OUT SPACES AND COPY THE REST.
  15360.     LI=LSTC
  15361.     DO 202 N=1,4
  15362.     IF(Ichar(NAME(N)).LE.32)GOTO 202
  15363.     LNOUT(LO)=NAME(N)
  15364.     LO=LO+1
  15365.     IF(LO.GT.110)GOTO 300
  15366. 202    CONTINUE
  15367.     IF(IDOL1.GT.0)LNOUT(LO)=char(36)
  15368.     IF(IDOL1.GT.0.AND.LO.LE.109)LO=LO+1
  15369.     DO 203 N=1,6
  15370.     IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
  15371. C IF 32 ISN'T SPACE, LOSE
  15372.     LNOUT(LO)=NUMBER(N)
  15373.     LO=LO+1
  15374.     IF(LO.GT.110)GOTO 300
  15375. 203    CONTINUE
  15376.     IF(IDOL2.EQ.0)GOTO 275
  15377.     LNOUT(LO)=Char(36)
  15378.     IF(LO.LE.109)LO=LO+1
  15379. 275    Continue
  15380.     IF(KSHEET.EQ.0)GOTO 300
  15381. C ADD SHEET NUMBER CRUFT IF CALLED FOR.
  15382.     LNOUT(LO)=Char(37)
  15383. C 37 IS % SIGN
  15384.     IF(LO.LE.109)LO=LO+1
  15385.     NUMBR6(1:6)='      '
  15386.     WRITE(NUMBR6(1:6),1000)KSHEET
  15387. C    ENCODE(6,1000,NUMBER)KSHEET
  15388.     DO 1203 N=1,6
  15389.     IF(Ichar(NUMBER(N)).LE.32)GOTO 1203
  15390. C IF 32 ISN'T ASCII SPACE, LOSE.
  15391.     LNOUT(LO)=NUMBER(N)
  15392.     LO=LO+1
  15393.     IF(LO.GT.110)GOTO 300
  15394. 1203    CONTINUE
  15395. C NOW HAVE THE FULL VALUE ENCODED, INCLUDING SHEET NUMBER IF APPROPRIATE.
  15396. c    IF(LO.LE.109)LO=LO+1
  15397.     GOTO 300
  15398. 250    CONTINUE
  15399. C JUST COPY DISPLAY FORMS.
  15400.     IL1=LSTC-1
  15401.     DO 251 N=LI,IL1
  15402.     LNOUT(LO)=LNIN(N)
  15403.     LO=LO+1
  15404.     IF(LO.GT.110)GOTO 300
  15405. 251    CONTINUE
  15406.     LI=LSTC
  15407. C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
  15408.     GOTO 300
  15409. 200    LNOUT(LO)=LNIN(LI)
  15410.     LO=LO+1
  15411.     LI=LI+1
  15412. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  15413. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  15414.     LO=MIN0(LO,110)
  15415.     DO 400 N=LO,110
  15416. 400    LNOUT(N)=char(0)
  15417.     DO 1 N=111,128
  15418. 1    LNOUT(N)=LNIN(N)
  15419. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  15420.     RETURN
  15421. 500    CONTINUE
  15422. C DECODE BY HAND...
  15423.     LNOUT(LO)=LNIN(LI)
  15424.     I1=ICHAR(LNIN(LI+1))
  15425.     I2=IMASK(I1,I192)
  15426. C    L2=L1.AND.L192
  15427.     I1=IMASK(I1,I63)
  15428. C    L1=L1.AND.L63
  15429. C DO MASKING TO GET BINARY COORDS
  15430.     ID1=I1
  15431.     I1=ICHAR(LNIN(LI+2))
  15432.     I1=IMASK(I1,I127)
  15433. C    L1=L1.AND.L127
  15434.     ID2=I2*2+I1
  15435. C NOW RELOCATE AND PUT BACK
  15436.     IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 510
  15437.     IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 510
  15438.     IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
  15439.     IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
  15440. C CLAMP RESULT TO MAX RANGES
  15441.     ID1=MAX0(ID1,1)
  15442.     ID2=MAX0(ID2,1)
  15443. C DO GENERAL REPACK IF ID1 OR ID2 ARE EXTENDED RANGE.
  15444.     IF(ID1.GT.60.OR.ID2.GT.301)GOTO 905
  15445. C leave 60, 301 literals here since this controls repacking
  15446. C    ID1=MIN0(60,ID1)
  15447. C    ID2=MIN0(301,ID2)
  15448. 510    CONTINUE
  15449. C RELOCATED, NOW REPACK AS NEW BINARY PATTERNS
  15450.     I1=ID1
  15451. C    L1=L1.AND.L63
  15452.     I1=IMASK(I1,I63)
  15453.     I2=ID2/2
  15454.     I2=IMASK(I2,I192)
  15455. C    L2=L2.AND.L192
  15456. C    L1=L1.OR.L2
  15457.     I1=I1+I2
  15458.     LNOUT(LO+1)=CHAR(I1)
  15459.     I2=ID2
  15460.     I2=IMASK(I2,I127)+128
  15461. C    L2=L2.AND.L127
  15462. C    L2=L2.OR.L128
  15463. C BE SURE AT LEAST 1 BIT IS SET
  15464.     LNOUT(LO+2)=CHAR(I2)
  15465.     LI=MIN0(109,LI+3)
  15466.     LO=MIN0(109,LO+3)    
  15467. C GO LOOK FOR MORE TO DECODE
  15468.     GOTO 300
  15469. 905    CONTINUE
  15470. C HERE SET UP FOR REENTRY INTO "NORMAL" DECODE
  15471.     LSTC=MIN0(109,LI+3)
  15472.     GOTO 906
  15473.     END
  15474. c -h- rnd.for    Tue Sep  2 10:58:55 1986    
  15475.     FUNCTION RND(DUM)
  15476. C GENERATE RANDOM NUMBER BY LINEAR CONGRUENCE IN BIG
  15477. C INTEGERS.
  15478.     REAL*4 R
  15479.     INTEGER*4 DUM
  15480.     INTEGER*4 I,II
  15481.     LOGICAL*4 L,LMSK
  15482.     REAL*8 XX
  15483.     EQUIVALENCE(I,L),(II,LMSK)
  15484.     I=DUM
  15485.     XX=I
  15486.     XX=XX*214013.0D0+2531011.0D0
  15487.     IF(XX.LT.0.)XX=1.0D0-XX
  15488.     XX=DMOD(XX,16777216.0D0)
  15489.     I=IDINT(XX)
  15490. C    I=I*214013+2531011
  15491. C USE MASKING TO ZOT THIS INTO NORMAL RANGE
  15492. C JUST USE MODULO...
  15493.     IF(I.LT.0)I=1-I
  15494.     IF(I.LT.0)I=0
  15495.     I=MOD(I,16777215)
  15496.     DUM=I
  15497. C RETURN RANDOM BETWEEN 0 AND 1.0
  15498. C PERIOD OF 2**24 MAX
  15499.     XX=I
  15500.     XX=XX/16777216.0
  15501.     R=SNGL(XX)
  15502.     RND=R
  15503.     RETURN
  15504.     END
  15505. c -h- rvboo.for    Tue Sep  2 10:58:55 1986    
  15506.     SUBROUTINE RVBOO(RETV,ID1,ID2)
  15507. C THIS ROUTINE ONLY COPIES ID1,ID2 INTO RETV ARRAY TO AVOID SOME
  15508. C BYTE-INTEGER CONVERSION PROBLEMS. THIS PACKING IS USED TO
  15509. C ACCESS VARIABLE LOCATION LATER.
  15510. c    character*8 retvl,rxx
  15511.     InTeGer*4 RETV,ID1,ID2
  15512.     DIMENSION RETV(2)
  15513. c    equivalence(rxx,retv(1))
  15514. c    rxx=retvl
  15515.     RETV(1)=ID1
  15516.     RETV(2)=ID2
  15517.     RETURN
  15518.     END
  15519. c -h- scmp.for    Tue Sep  2 10:58:55 1986    
  15520.     SUBROUTINE SCMP(LINA,LINB,LENM,ICODE)
  15521.     DIMENSION LINA(1),LINB(1)
  15522.     CHARACTER*1 LINA,LINB
  15523.     ICODE=1
  15524.     lenmm=lenm
  15525.     if(lenm.le.0.or.lenm.gt.255)lenmm=255
  15526.     DO 1 N=1,LENMM
  15527.     IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
  15528. C ALLOW _ TO BE A WILDCARD.
  15529.     IF(LINA(N).EQ.'_'.OR.LINB(N).EQ.'_')GOTO 1
  15530.     IF(LINA(N).NE.LINB(N))ICODE=0
  15531.     IF(ICODE.NE.1)GOTO 2
  15532. 1    CONTINUE
  15533. 2    CONTINUE
  15534.     RETURN
  15535.     END
  15536. c -h- sed.for    Tue Sep  2 10:58:55 1986    
  15537.     SUBROUTINE SED(LCMD,LIN,LWRK,ARGSTR,XAC,LENGTH)
  15538.     CHARACTER*1 LIN(1),LWRK(1),ARGSTR(52,4)
  15539.     CHARACTER*1 LCMD(1),LSU(10)
  15540.     EXTERNAL INDX
  15541.     CHARACTER*10 LSU10
  15542.     EQUIVALENCE (LSU10(1:10),LSU(1))
  15543.     INTEGER*4 III
  15544.     REAL*8 XAC
  15545. C
  15546. C OPERATION:
  15547. C EDIT LIN TO LWRK, WITH LENGTH VARIABLE HOLDING INPUT
  15548. C LENGTH IN CHARACTERS. LCMD HOLDS COMMAND LINE, WHICH
  15549. C ULTIMATELY GETS EDITED STRING COPIED BACK INTO IT.
  15550. C
  15551. C EDITS:
  15552. C  CHARACTER AT IDELIM IS DELIMITER. REPLACE STRING IN 1ST
  15553. C INTERVAL BETWEEN DELIMITERS WITH SECOND.
  15554. C  HOWEVER:
  15555. C  &1 TO &4 GET CONTENTS (UP TO NULL) OF ARGSTR(X,1) TO (X,4)
  15556. C
  15557. C  &5 RETURNS XAC VALUE CONVERTED TO DECIMAL INTEGER AND
  15558. C  PRINTED.
  15559. C  &6 RETURNS XAC VALUE CONVERTED TO ASCII CODE (1 BYTE) AND
  15560. C  INSERTED.
  15561. C XAC ENTERS WITH CONTENTS OF ACCUMULATOR Z (TO AVOID TOO MUCH
  15562. C DIFFICULTY IN USING IT OWING TO THE UBIQUITY OF USE OF %).
  15563. C    WE ENTER JUST POINTING AT THE COMMAND LINE AFTER THE ENTER
  15564. C AND ITS SPACE. ASSUME 1ST CHARACTER IS OUR DELIMITER.
  15565.     DO 335 IV=1,80
  15566. 335    LWRK(IV)=Char(0)
  15567.     IDELIM=ICHAR(LCMD(1))
  15568.     ID2=INDX(LCMD(2),IDELIM)
  15569.     IF(ID2.GE.LENGTH)GOTO 100
  15570. C NOW HAVE 1ST STRING, OF NONZERO LENGTH
  15571. C FIND SECOND STRING NOW. EITHER MAY BE OF 0 LENGTH BUT
  15572. C BOTH MUST BE DEFINED BY A DELIMITER.
  15573.     ID3=INDX(LCMD(2+ID2),IDELIM)
  15574.     IF(ID3.GE.LENGTH)GOTO 100
  15575. C WELL, WE GOT IT SOMEHOW. NOW TRY AND EDIT THE JUNK IN.
  15576. C (NOTE WE WANT TO FILL ALL OF LENGTH)
  15577.     INLIN=1
  15578.     INWRK=1
  15579.     IVV=ID3+ID2+2
  15580.     DO 336 IV=IVV,LENGTH
  15581. 336    LCMD(IV)=Char(0)
  15582.     LSA=ID2-1
  15583.     LSB=ID3-1
  15584.     LSSB=2+ID2
  15585.     LZR=0
  15586.     DO 1 N=1,LENGTH
  15587.     IF(LSA.GT.0)GOTO 350
  15588. C ZERO LENGTH INITIAL STRING, SO ASSUME HE WANTS TO APPEND TO
  15589. C EXISTING STRING AT THE END.
  15590. C (HANDY FOR ADDING TO FORMULAE OR THE LIKE.)
  15591.     IF(Ichar(LIN(N)).EQ.0)GOTO 351
  15592. C JUST COPY THE INPUT FIRST AND GO OFF
  15593.     GOTO 2
  15594. 351    CONTINUE
  15595. C HERE WE HAVE THE TERMINAL NULL
  15596.     LZR=LZR+1
  15597. C ALLOW US TO PRETEND FOR ONCE THAT WE GOT A MATCH
  15598.     IF(LZR.EQ.1)GOTO 222
  15599.     GOTO 1
  15600. 350    CONTINUE
  15601.     IF(Ichar(LIN(INLIN)).EQ.0)GOTO 1
  15602.     CALL SSCMP(LIN(INLIN),LCMD(2),LSA,ICOD)
  15603.     IF(ICOD.EQ.0)GOTO 2
  15604. C HERE HAVE TO SUBSTITUTE
  15605. C PASS STRING TO SUBSTITUTE ON INPUT LINE FIRST.
  15606. 222    CONTINUE
  15607.     INLIN=INLIN+LSA
  15608. C ALLOW ZERO LENGTH SUBSTITUTE CHARACTER
  15609.     IF(LSB.LE.0)GOTO 1
  15610. C    DO 6 M=1,LSB
  15611.     M=1
  15612. 106    CONTINUE
  15613.     IF(LCMD(LSSB+M-1).EQ.'&')GOTO 7
  15614. 8    CONTINUE
  15615. C JUST COPY ONE CHARACTER OF THE SUBSTITUTE STRING IN HERE.
  15616.     LWRK(INWRK)=LCMD(LSSB+M-1)
  15617.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15618.     GOTO 6
  15619. 7    CONTINUE
  15620. C HANDLE & FORMS
  15621.     IF(LCMD(LSSB+M).LT.'1'.OR.LCMD(LSSB+M).GT.'6')GOTO 8
  15622. C REQUIRE ALL FORMS TO BE &1 THRU &6 TO BE DEALT WITH HERE.
  15623.     M=M+1
  15624.     IF(LCMD(LSSB+M-1).GT.'4')GOTO 10
  15625. C HERE JUST HANDLE ARGSTR SUBSTITUTIONS.
  15626.     II=ICHAR(LCMD(LSSB+M-1))
  15627.     II=II-48
  15628. C II IS NOW THE INDEX.
  15629.     DO 11 MM=1,52
  15630.     LWRK(INWRK)=ARGSTR(MM,II)
  15631.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15632.     IF(ARGSTR(MM,II).EQ.char(0))GOTO 12
  15633. 11    CONTINUE
  15634. 12    CONTINUE
  15635.     M=M+1
  15636. C PASS THE NUMBER OF THE &NUMBER FORM
  15637.     GOTO 6
  15638. 10    CONTINUE
  15639. C HANDLE ZAC FORMS
  15640.     M=M+1
  15641. C PASS THE DIGIT
  15642.     IF(LCMD(LSSB+M-2).EQ.'5')GOTO 14
  15643. C FILL IN ZAC AS AN INTEGER
  15644.     II=32
  15645.     IF(XAC.GE.1.AND.XAC.LT.256.)II=XAC
  15646. C ONLY HANDLE CONVERSION IF LEGAL
  15647.     LWRK(INWRK)=CHAR(II)
  15648.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15649.     GOTO 6
  15650. 14    CONTINUE
  15651. C HANDLE NUMERIC CONVERSION HERE
  15652.     LSU(1)=char(0)
  15653.     III=0
  15654.     IF(DABS(XAC).LT.9999999.)III=IDINT(XAC)
  15655.     WRITE(LSU10(1:10),15,ERR=22)III
  15656. C    ENCODE(10,15,LSU,ERR=22)III
  15657. 15    FORMAT(I9)
  15658. 22    DO 16 MK=1,10
  15659.     IF(Ichar(LSU(MK)).EQ.0)GOTO 6
  15660.     IF(LSU(MK).EQ.' ')GOTO 16
  15661.     LWRK(INWRK)=LSU(MK)
  15662.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15663. 16    CONTINUE
  15664. 6    CONTINUE
  15665.     M=M+1
  15666.     IF(M.LE.LSB)GOTO 106
  15667.     GOTO 1
  15668. 2    CONTINUE
  15669. C HERE JUST ANOTHER CHARACTER TO MOVE, DO THE MOVE.
  15670.     LWRK(INWRK)=LIN(INLIN)
  15671.     IF(INLIN.LT.LENGTH)INLIN=INLIN+1
  15672.     IF(INWRK.LT.LENGTH)INWRK=INWRK+1
  15673. 1    CONTINUE
  15674. C COPY BACK OUT TO CMDLIN AFTER FIXUP
  15675.     IF(INWRK.GE.LENGTH)GOTO 3
  15676.     DO 4 N=INWRK,LENGTH
  15677. 4    LWRK(N)=char(0)
  15678. 3    CONTINUE
  15679. C REPLACE COMMAND LINE WITH EDITED STRING FOR ENTRY NOW.
  15680.     DO 5 N=1,LENGTH
  15681. 5    LCMD(N)=LWRK(N)
  15682. 100    CONTINUE
  15683.     RETURN
  15684.     END
  15685. c -h- sign.for    Tue Sep  2 10:58:55 1986    
  15686.     REAL *8 FUNCTION SIGN(VAR)
  15687.     REAL*8 VAR
  15688. C ALWAYS RETURN 1. OR -1. FOR THIS PROGRAM ... NEVER 0.
  15689.     SIGN=1.
  15690.     IF(VAR.LT.0.)SIGN=-1.
  15691.     RETURN
  15692.     END
  15693. c -h- slend.for    Tue Sep  2 10:58:55 1986    
  15694.     SUBROUTINE SLEND(RETCD)
  15695. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  15696. C ALL RIGHTS RESERVED
  15697. C 60=MAX REAL ROWS
  15698. C 301=MAX REAL COLS
  15699. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  15700. C VBLS AND TYPE DIMENSIONED 60,301
  15701. C **************************************************
  15702. C *                                                *
  15703. C *         SUBROUTINE   SLEND(RETCD)              *
  15704. C *                                                *
  15705. C **************************************************
  15706. C
  15707. C
  15708. C
  15709. C SETS VALUE OF LEND, POINTER TO LAST NON-BLANK CHARACTER
  15710. C IN LINE(80)
  15711. C
  15712. C
  15713. C
  15714. C
  15715. C RETCD VALUE       MEANING
  15716. C
  15717. C    1            NORMAL RETURN
  15718. C    2            ALL BLANKS
  15719. C
  15720. C
  15721. C
  15722. C   SLEND IS CALLED BY CALC
  15723. C
  15724. C VARIABLE    USE
  15725. C
  15726. C  BLANK      ' '
  15727. C    I        INDEXES CHARACTERS IN LINE(80).
  15728. C  LEND       UPON EXIT, POINTS TO THE LAST NON-
  15729. C             BLANK IN LINE(80).
  15730. C  LINE(80)   HOLDS COMMAND LINE.
  15731. C  RETCD      RETURN CODE.  1=NORMAL, 2=ALL BLANKS
  15732. C
  15733. C
  15734. C
  15735. C    SUBROUTINE SLEND(RETCD)
  15736.     InTeGer*4 LEVEL,NONBLK,LEND
  15737.     InTeGer*4 VIEWSW,BASED,RETCD
  15738. C
  15739.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  15740.     CHARACTER*1 LINE(80)
  15741. C
  15742.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  15743.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  15744. C
  15745. C
  15746. C
  15747. C
  15748.     RETCD=1
  15749.     DO 100 I=1,80
  15750.     IF(LINE(81-I).NE.BLANK)GO TO 200
  15751. 100    CONTINUE
  15752.     RETCD=2
  15753.     RETURN
  15754. 200    LEND=81-I
  15755.     RETURN
  15756.     END
  15757. c -h- sscmp.for    Tue Sep  2 10:58:55 1986    
  15758.     SUBROUTINE SSCMP(LINA,LINB,LENM,ICODE)
  15759.     DIMENSION LINA(1),LINB(1)
  15760.     CHARACTER*1 LINA,LINB
  15761.     ICODE=1
  15762.     DO 1 N=1,LENM
  15763. c    IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
  15764.     IF(ICHAR(LINA(N)).NE.ICHAR(LINB(N)))ICODE=0
  15765.     IF(ICODE.NE.1)GOTO 2
  15766. 1    CONTINUE
  15767. 2    CONTINUE
  15768.     RETURN
  15769.     END
  15770. c -h- sstr.for    Tue Sep  2 10:58:55 1986    
  15771.     SUBROUTINE SSTR(CMDLIN,LA,N,LE,FORM)
  15772.     CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
  15773.     InTeGer*4 LA,N,LE
  15774.     InTeGer*4 VLEN(9),TYPE(1,2)
  15775.     CHARACTER*1 AVBLS(24,27)
  15776.     Real*8 VAVBLS(3,27)
  15777.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  15778.     REAL*8 XVBLS(1,1),XX,VP,TMP
  15779.     COMMON/V/TYPE,AVBLS,XVBLS,VLEN
  15780.     NI=N
  15781. C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
  15782. C MUST PASS _@ CHARS TO GET VARIABLE
  15783.     LAA=LA+2
  15784.     LEE=LE
  15785.     CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
  15786.     IF(IVLD.LE.0)GOTO 990
  15787. C    XX=XVBLS(I1,I2)
  15788.     CALL XVBLGT(I1,I2,XX)
  15789.     VP=128.D0**7
  15790.     DO 1 NN=1,8
  15791.     TMP=DINT(XX/VP)
  15792.     NBF(NN)=CHAR(IDINT(TMP))
  15793.     XX=XX-(VP*TMP)
  15794.     VP=DINT(VP/128.D0)
  15795.     IF(VP.EQ.0.0D0)VP=1.0D0
  15796. 1    CONTINUE
  15797. C NOW NBF HAS 8 BYTES OF DATA CORRESPONDING TO DE-HASHED
  15798. C STRING. COPY TO FORM.
  15799.     NL=NI
  15800.     DO 2 NN=1,8
  15801.     FORM(NL)=NBF(NN)
  15802.     IF(ICHAR(NBF(NN)).GE.32)NL=NL+1
  15803. 2    CONTINUE
  15804. C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
  15805. C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
  15806. C AND LSTC IS NEXT CHAR AFTER VARIABLE ON CMDLIN
  15807. C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
  15808. C AND MOVE CMDLIN DOWN.
  15809.     N=NL-1
  15810.     LA=LSTC-1
  15811.     CMDLIN(LA)=FORM(N)
  15812. C HOPE ALL'S WELL NOW...
  15813.     RETURN
  15814. 990    FORM(N)=CMDLIN(N)
  15815.     RETURN
  15816.     END
  15817. c -h- strcmp.for    Tue Sep  2 10:58:55 1986    
  15818.     SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
  15819. C COPYRIGHT (C) 1983 GLENN EVERHART
  15820. C ALL RIGHTS RESERVED
  15821. C 60=MAX REAL ROWS
  15822. C 301=MAX REAL COLS
  15823. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  15824. C VBLS AND TYPE DIMENSIONED 60,301
  15825. C **************************************************
  15826. C *                                                *
  15827. C *   SUBROUTINE STRCMP(NAME,LENGTH,RETCD)         *
  15828. C *                                                *
  15829. C **************************************************
  15830. C
  15831. C
  15832. C  STRCMP LOOKS PAST BLANKS FOR THE NAME HELD BY NAME(1),...,NAME(LENGTH)
  15833. C  THE RETURN CODE RETCD INDICATES SUCCESS OR FAILURE:
  15834. C
  15835. C    1=MATCH
  15836. C    2=FAILURE
  15837. C
  15838. C  UPON EXIT, COMMON VARIABLE NONBLK
  15839. C         IF SUCCESSFUL, POINTS TO ONE BEYOND THE LAST CHARACTER SCANNED
  15840. C                 FOR MATCH
  15841. C         IF FAILURE, UNCHANGED
  15842. C
  15843. C
  15844. C
  15845. C  MODIFICATION CLASSES: M2
  15846. C
  15847. C
  15848. C
  15849. C  STRCMP CALLS GETNNB TO GET THE NEXT NON-BLANK FROM LINE(80)
  15850. C
  15851. C  STRCMP IS CALLED BY CMND
  15852. C
  15853. C
  15854. C
  15855. C
  15856. C VARIABLE       USE
  15857. C
  15858. C   I2        INDEXES NAME(LENGTH).
  15859. C   IS        HOLDS VALUE OF NONBLANK IN CASE AN ERROR OCCURS
  15860. C             AND IT IS NECESSARY TO RESTORE THE VALUE.
  15861. C   LENGTH    HOLDS THE LENGTH OF VECTOR NAME.
  15862. C   NONBLK    POINTER FOR COMMAND LINE HELD BY LINE(80).
  15863. C   RETCD     HOLDS RETURN CODE.  1=MATCH,  2=FAILURE
  15864. C
  15865. C
  15866. C
  15867. C
  15868. C    SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
  15869.     InTeGer*4 LENGTH
  15870.     InTeGer*4 LEVEL,NONBLK,LEND
  15871.     InTeGer*4  RETCD,VIEWSW,BASED
  15872. C
  15873.     CHARACTER*1  LINE(80),NAME(LENGTH)
  15874.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  15875. C
  15876.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  15877.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  15878. C
  15879. C UPON ENTRANCE, NONBLK POINTS TO THE FIRST CHARACTER
  15880. C IN NAME, COMPARE LOOKS PAST THIS TO THE NEXT CHARACTER
  15881. C SINCE CMND HAS ALREADY IDENTIFIED THAT FIRST CHARACTER
  15882. C IN THE COMMAND NAME (AFTER THE ASTERISK).
  15883.     IS=NONBLK
  15884.     CALL GETNNB(IPT,RETCD)
  15885.     GO TO (10,999),RETCD
  15886. C ON EXIT NONBLK POINTS TO LAST CHARACTER IN NAME
  15887. C
  15888. C
  15889. 10    DO 100 I2=1,LENGTH
  15890.     CALL GETNNB(IPT,RETCD)
  15891.     GO TO (20,999),RETCD
  15892.     STOP 20
  15893. 20    NONBLK=IPT
  15894.     IF(NAME(I2).NE.LINE(NONBLK))GOTO 999
  15895. 100    CONTINUE
  15896.     RETCD=1
  15897.     RETURN
  15898. C
  15899. C
  15900. C NO MATCH
  15901. 999    RETCD=2
  15902. C IF ERROR, RESTORE VALUE OF NONBLK
  15903.     NONBLK=IS
  15904.     RETURN
  15905.     END
  15906. c -h- svbl.for    Tue Sep  2 10:58:55 1986    
  15907.     SUBROUTINE SVBL(CMDLIN,LA,N,LE,FORM)
  15908.     Include aparms.inc
  15909.     InTeGer*4 VLEN(9),TYPE(1,2)
  15910.     CHARACTER*1 AVBLS(24,27)
  15911.     Real*8 VAVBLS(3,27)
  15912.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  15913.     REAL*8 XVBLS(1,1),XX,XY,xmr,xmc
  15914.     COMMON/V/TYPE,AVBLS,XVBLS,VLEN
  15915.     CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
  15916.     CHARACTER*3 NBF3
  15917.     EQUIVALENCE(NBF3(1:1),NBF(5))
  15918.     InTeGer*4 LA,N,LE,I1,I2,J1,J2
  15919.     NI=N
  15920.     xmr=Mrows
  15921.     xmc=Mcols
  15922. C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
  15923.     LAA=LA+2
  15924. C MUST PASS _# CHARS
  15925.     LEE=LE
  15926.     CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
  15927.     IF(IVLD.LE.0)GOTO 990
  15928.     LAA=LSTC+1
  15929. C ACCEPT ANY DELIMITER
  15930.     LEE=LE
  15931.     CALL VARSCN(CMDLIN,LAA,LEE,LSTC,J1,J2,IVLD)
  15932.     IF(IVLD.LE.0)GOTO 990
  15933. C    XX=XVBLS(I1,I2)
  15934.     CALL XVBLGT(I1,I2,XX)
  15935. C XX IS COL #
  15936. C    XY=XVBLS(J1,J2)-1.0
  15937.     CALL XVBLGT(J1,J2,XY)
  15938.     IF(XX.LE.(0.9D0).OR.XX.GT.XMR)GOTO 990
  15939.     IF(XY.LE.(0.9D0).OR.XY.GT.XMC)GOTO 990
  15940.     IC=XX
  15941.     CALL IN2AS(IC,NBF)
  15942.     IR=XY
  15943.     WRITE(NBF3(1:3),300)IR
  15944. C    ENCODE(3,300,NBF(5))IR
  15945. 300    FORMAT(I3)
  15946.     NL=NI
  15947. C FILL IN DECODED VARIABLE NAME, ZOTTING OUT EXTRA SPACES.
  15948.     DO 400 NN=1,7
  15949. C 47 IS ASCII VALUE FOR 0 CHARACTER
  15950. C ALPHAS ARE ALSO ALL HIGHER.
  15951.     IF(ICHAR(NBF(NN)).LE.40)GOTO 400
  15952.     FORM(NL)=NBF(NN)
  15953.     NL=NL+1
  15954. 400    CONTINUE
  15955. C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
  15956. C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
  15957. C AND LSTC IS NEXT CHAR AFTER 2ND VARIABLE ON CMDLIN
  15958. C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
  15959. C AND MOVE CMDLIN DOWN.
  15960.     N=NL
  15961.     LE=LE-LSTC+NL
  15962.     LA=LSTC
  15963. C    DO 401 M=N,LE
  15964. C    CMDLIN(M)=CMDLIN(M+LSTC-NL)
  15965. C401    CONTINUE
  15966. C HOPE ALL'S WELL NOW...
  15967.     RETURN
  15968. 990    CONTINUE
  15969.     FORM(N)=CMDLIN(N)
  15970.     RETURN
  15971.     END
  15972. c -h- swrt.for    Tue Sep  2 10:58:55 1986    
  15973. C
  15974. C SWRT - WRITE VARIABLE LENGTH STRING TO SCREEN WITHOUT
  15975. C RECORD TERMINATION.
  15976. C COPYRIGHT GLENN C EVERHART 1984
  15977. C ALL RIGHTS RESERVED
  15978. C *** Don't use for normal Amiga stuff, but have available in case
  15979. C *** it should be handy someplace...
  15980. C
  15981. C
  15982. ccc    SUBROUTINE SWRT(STRING,LENGTH)
  15983. ccc    CHARACTER*1 STRING(127)
  15984. ccc    INTEGER LENGTH
  15985. cccC DUMP OUT ALL WE CAN..
  15986. ccc    CHARACTER*9 SFM
  15987. ccc    CHARACTER*1 SFMX(9)
  15988. ccc    CHARACTER*3 SNM
  15989. ccc    EQUIVALENCE(SNM,SFMX(2))
  15990. ccc    EQUIVALENCE (SFMX(1),SFM)
  15991. cccC HERE ARE THE BUILT IN FORMATS. NOTE WE FILL IN THE
  15992. cccC REPEAT COUNT AT RUNTIME FOR THE TEXT TO BE WRITTEN.
  15993. cccC NOTE ALSO THAT THE 1ST CHAR IS A # SIGN TO SHOW UP PROBLEMS.
  15994. cccC FORMATS ARE (nnnA1,\)
  15995. cccC COMPRISING 13 CHARACTERS IN ALL.
  15996. ccc    DATA SFM/'(001A1,\)'/
  15997. cccC NOTE WE JUST FILL IN THE LENGTH AND WRITE TO SCREEN USING
  15998. cccC SFM AS A RUNTIME FORMAT.
  15999. cccC
  16000. ccc    IF(LENGTH.LE.0)RETURN
  16001. ccc    WRITE(SNM,1)LENGTH
  16002. ccc1    FORMAT(BZ,I3)
  16003. cccC WRITE ON UNIT 6 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
  16004. cccC (VIA EXPLICIT OPEN IN MAIN PROGRAM)
  16005. ccc    WRITE(11,SFM)(STRING(II),II=1,LENGTH)
  16006. ccc    RETURN
  16007. ccc    END
  16008.     subroutine vget(buf,len)
  16009.     character*1 buf(132),cbf(132)
  16010.     integer*4 len,ii,i
  16011. C Read buf up to len from console
  16012.     do 2 i=1,128
  16013.     cbf(i)=char(0)
  16014. 2    continue
  16015.     call getttl(cbf)
  16016. c    call cmdmun(cbf)
  16017.     ii=min0(len,132)
  16018.     ii=max0(len,1)
  16019. C reads console into large buffer, returns n chars of it.
  16020.     do 1 i=1,ii
  16021.     buf(i)=cbf(i)
  16022. 1    Continue
  16023.     return
  16024.     end
  16025.     subroutine vgeti(iii)
  16026. C get integer from command line
  16027.     integer*4 iii
  16028.     character*132 buf
  16029.     call vget(buf,20)
  16030.     read(buf,1000,err=999)iii
  16031. 1000    format(i7)
  16032.     return
  16033. 999    Continue
  16034.     iii=0
  16035.     return
  16036.     end
  16037.     SUBROUTINE VWRT(STRING,LENGTH)
  16038. C ***<<<< RDD COMMON START >>>***
  16039.     InTeGer*4 RRWACT,RCLACT
  16040. C    COMMON/RCLACT/RRWACT,RCLACT
  16041.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16042.      1  IDOL7,IDOL8
  16043. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16044. C     1  IDOL7,IDOL8
  16045.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  16046. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16047.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16048. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16049. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16050. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16051.     InTeGer*4 KLVL
  16052. C    COMMON/KLVL/KLVL
  16053.     InTeGer*4 IOLVL,IGOLD
  16054. C    COMMON/IOLVL/IOLVL
  16055. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16056. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16057.     Integer*4 IDSPTP,Idol9
  16058.     integer*4 k3dfg,kcdelt,krdelt,kpag
  16059.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16060.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16061.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  16062.      3  k3dfg,kcdelt,krdelt,kpag
  16063. C ***<<< RDD COMMON END >>>***
  16064. C VWRT is like SWRT but writes to lun 11 window instead.
  16065.     CHARACTER*1 STRING(127)
  16066.     INTEGER LENGTH
  16067. C DUMP OUT ALL WE CAN..
  16068.     IF(LENGTH.LE.0)RETURN
  16069. C WRITE ON UNIT 11 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
  16070. C (VIA EXPLICIT OPEN IN MAIN PROGRAM)
  16071. c    REWIND 11
  16072. c    call uvt100(1,LLDSP,1)
  16073.     call swrt(string,length)
  16074. c    WRITE(11,777)(STRING(II),II=1,LENGTH)
  16075. c    REWIND 11
  16076. 777    format(1X,127A1)
  16077.     RETURN
  16078.     END
  16079.  
  16080. C *************** AnalyO.Ftn ##########################################
  16081. c -h- acini1.fnw    Fri Aug 22 12:55:08 1986    
  16082. C PORTACALC MAIN PROGRAM
  16083. C SPREAD SHEET DRIVER PROGRAM
  16084. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  16085. C ALL RIGHTS RESERVED
  16086. C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
  16087. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  16088. C SCREEN.
  16089.     SUBROUTINE INITA1(KMAP,KWID,ICODE)
  16090. C
  16091.     Include aparms.inc
  16092.     InTeGer*4 PRL(6)
  16093. c        CHARACTER*1 NOWRAP ( 2 )
  16094.     CHARACTER*1 FORM,FVLD
  16095. c    INTEGER*4 VNLT
  16096. c    EXTERNAL LCWRQQ
  16097.     DIMENSION FORM(128),FVLD(1,1)
  16098. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  16099. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  16100. C SO INITIALLY IGNORE.
  16101. C ***<<<< RDD COMMON START >>>***
  16102.     InTeGer*4 RRWACT,RCLACT
  16103. C    COMMON/RCLACT/RRWACT,RCLACT
  16104.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16105.      1  IDOL7,IDOL8
  16106. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16107. C     1  IDOL7,IDOL8
  16108.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  16109. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16110.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16111. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16112. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16113. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16114.     InTeGer*4 KLVL
  16115. C    COMMON/KLVL/KLVL
  16116.     InTeGer*4 IOLVL,IGOLD
  16117. C    COMMON/IOLVL/IOLVL
  16118. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16119. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16120.     Integer*4 IDSPTP,Idol9
  16121.     integer*4 k3dfg,kcdelt,krdelt,kpag
  16122.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16123.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16124.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  16125.      3  k3dfg,kcdelt,krdelt,kpag
  16126. C ***<<< RDD COMMON END >>>***
  16127. CCC    InTeGer*4 RRWACT,RCLACT
  16128. CCC    COMMON/RCLACT/RRWACT,RCLACT
  16129. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16130. CCC     1  IDOL7,IDOL8
  16131. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16132. CCC     1  IDOL7,IDOL8
  16133. CCC    InTeGer*4 LLCMD,LLDSP
  16134. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16135. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  16136.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  16137.     COMMON/D2R/NRDSP,NCDSP
  16138. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16139. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16140. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16141. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16142. c    CHARACTER*1 FORM2(4)
  16143. C ***<<< XVXTCD COMMON START >>>***
  16144.     CHARACTER*1 OARRY(100)
  16145.     InTeGer*4 OSWIT,OCNTR
  16146. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  16147. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16148.     InTeGer*4 IPS1,IPS2,MODFLG
  16149. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16150.        InTeGer*4 XTCFG,IPSET,XTNCNT
  16151.        CHARACTER*1 XTNCMD(80)
  16152. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16153. C VARY FLAG ITERATION COUNT
  16154.     INTEGER KALKIT
  16155. C    COMMON/VARYIT/KALKIT
  16156.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  16157.     InTeGer*4 RCMODE,IRCE1,IRCE2
  16158. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16159. C     1  IRCE2
  16160. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16161. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16162. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16163. C RCFGX ON.
  16164. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16165. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16166. C  AND VM INHIBITS. (SETS TO 1).
  16167.     INTEGER*4 FH
  16168. C FILE HANDLE FOR CONSOLE I/O (RAW)
  16169. C    COMMON/CONSFH/FH
  16170.     CHARACTER*1 ARGSTR(52,4)
  16171. C    COMMON/ARGSTR/ARGSTR
  16172.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  16173.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  16174.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16175.      3  IRCE2,FH,ARGSTR
  16176. C ***<<< XVXTCD COMMON END >>>***
  16177. CCC    InTeGer*4 OSWIT,OCNTR
  16178. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  16179. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16180.     InTeGer*4 TYPE(1,2),VLEN(9)
  16181. CCC    InTeGer*4 KLVL
  16182. CCC    COMMON/KLVL/KLVL
  16183. CCC    InTeGer*4 IOLVL
  16184. CCC    COMMON/IOLVL/IOLVL
  16185. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16186. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16187.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  16188.     Real*8 VAVBLS(3,27)
  16189.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  16190.     REAL*8 XXV(1,1)
  16191.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  16192.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  16193. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  16194.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  16195.     CHARACTER*12 CDVFMT
  16196.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  16197.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  16198.     COMMON/DEFVBX/DVFMT
  16199.     CHARACTER*1 NMSH(80)
  16200.     CHARACTER*80 NMSH80
  16201.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  16202.     COMMON/NMSH/NMSH
  16203. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  16204. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16205. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  16206. CCC       CHARACTER*1 XTNCMD(80)
  16207. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16208. C VARY FLAG ITERATION COUNT
  16209. CCC    INTEGER KALKIT
  16210. CCC    COMMON/VARYIT/KALKIT
  16211. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  16212. CCC    InTeGer*4 RCONE,RCMODE,IRCE1,IRCE2
  16213. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
  16214. CCC     1  IRCE1,IRCE2
  16215. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16216. C RCFGX FLAGS WHETHER TO DO AUTO RECALC
  16217. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED
  16218.     Integer*4 CWids(JIDcl)
  16219. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY.
  16220. c    INTEGER*4 I4TMP
  16221. C ***<<< NULETC COMMON START >>>***
  16222.     InTeGer*4 ICREF,IRREF
  16223. C    COMMON/MIRROR/ICREF,IRREF
  16224.     InTeGer*4 MODPUB,LIMODE
  16225. C    COMMON/MODPUB/MODPUB,LIMODE
  16226.     InTeGer*4 KLKC,KLKR
  16227.     REAL*8 AACP,AACQ
  16228. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  16229.     InTeGer*4 NCEL,NXINI
  16230. C    COMMON/NCEL/NCEL,NXINI
  16231.     CHARACTER*1 NAMARY(20,MRows)
  16232. C    COMMON/NMNMNM/NAMARY
  16233.     InTeGer*4 NULAST,LFVD
  16234. C    COMMON/NULXXX/NULAST,LFVD
  16235.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  16236.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  16237. C ***<<< NULETC COMMON END >>>***
  16238.     external cgetsz !$pragma C(cgetsz)
  16239.     integer*4 curszx,curszy,kbdin
  16240.     common/curspr/curszx,curszy,kbdin
  16241. CCC    InTeGer*4 ICREF,IRREF
  16242. CCC    COMMON/MIRROR/ICREF,IRREF
  16243. C SETS NUMBER OF COLS TO ADD ON ROW OVERFLOW, ROWS TO ADD ON COL OVERFLOW
  16244. C FOR CELL ALIASING.
  16245.     REAL*8 DVS(JIDcl,JIDrw)
  16246.     COMMON /FVLDC/FVLD
  16247. C FOLLOWING SUPPORT VVARY OVERLAY:
  16248.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  16249.     LOGICAL*4 LEXIST
  16250.     InTeGer*4 QCAC(2),QCENT(8),ACV(8)
  16251.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  16252.     COMMON/DSPCMN/DVS,CWIDS
  16253.     CHARACTER*1 CHR
  16254.     character*20 fwt
  16255.     EQUIVALENCE(FWT(1:1),CHR)
  16256. C DISABLE FLOATING EXCEPTIONS
  16257. C    CALL LCWRQQ(IFCW)
  16258. C (MOVED LCWRQQ CALL TO MAIN)
  16259.     IDOL7=1
  16260. C ENABLE SCROLLING INITIALLY
  16261. c    call block2
  16262. C ZERO "SAVED DISPLAY VALUES" FIRST...
  16263.     DO 35 N=1,JIDrw
  16264.     DO 35 NN=1,JIDcl
  16265. 35    DVS(NN,N)=0.
  16266.     MODFLG=1
  16267.     CALL TTYINI
  16268. C INITIALLY IN NON ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
  16269. C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
  16270. C SETUP INITIAL DISPLAY LIMITS ACTUALLY USED.
  16271.     RRWACT=1
  16272.     K3DFG=0
  16273.     KCDELT=0
  16274.     KRDELT=0
  16275.     RCLACT=1
  16276.     IOLVL=11
  16277. c Set rather small sheet to allow for use on non-interlace screen
  16278. c initially
  16279.     DRWV=7
  16280.     DCLV=17
  16281.     LLCMD=20
  16282.     LLDSP=21
  16283.     If(Idsptp.ne.1)goto 4866
  16284.     DRWV=7
  16285.     DCLV=42
  16286.     LLCMD=45
  16287.     LLDSP=46
  16288. c Interlace dimensions for main window display
  16289. 4866    Continue
  16290. c set up according to window size (curses version)
  16291. c ttyini should get the size of actual screen window from initscr adn newwin(0,0,0,0)
  16292. c to create a new window. The initial curscr window gives size of the initial window.
  16293. c These routines should also set keypad, cbreak mode, etc. to ensure that chars coming
  16294. c in as function keys get returned in kbdin variable so they can be interpreted.
  16295. c    call cgetsz(icck,irrk)
  16296. c    curszx=icck
  16297. c    curszy=irrk-4
  16298. c    dclv=curszy-4
  16299. c    if(dclv.lt.6)dclv=6
  16300. c    llcmd=dclv+3
  16301. c    lldsp=llcmd+1
  16302. c    drwv=(curszx/10)-1
  16303. c set up at 10 charts/col
  16304. c    if(drwv.lt.1)drwv=1
  16305.     ICREF=10
  16306.     IRREF=50
  16307. C SET INCREMENTS TO 1/6 OF TOTAL FOR STARTERS.
  16308.     KLVL=1
  16309.     KALKIT=0
  16310.     IRCE1=0
  16311.     IRCE2=0
  16312.     RCMODE=2
  16313.     ICODE=0
  16314.     idol3=0
  16315.     idol4=0
  16316.     idol5=20000
  16317.     idol6=20000
  16318.     Idol8=1
  16319.     RCFGX=0
  16320.     FORMFG=0
  16321. C      CALL GETADR ( PRL, NOWRAP )
  16322.       PRL ( 2 ) = 2
  16323. c    OPEN(6,FILE='CON:',STATUS='NEW',FORM='FORMATTED')
  16324.     If(Idsptp.eq.1)goto 4867
  16325. c Non interlace (640 x 200) screen
  16326. c    OPEN(11,FILE='CON:20/169/550/30/Analy Command Inputs',
  16327. c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  16328.     Goto 4868
  16329. 4867    Continue
  16330. c Interlace
  16331. c    OPEN(11,FILE='CON:20/369/550/30/Analy Command Inputs',
  16332. c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  16333. 4868    Continue
  16334. c    OPEN(18,FILE='CON:20/210/450/30/Analy Cmd Prompts',
  16335. c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
  16336. C LOOK FOR 'ACINIT.PRM' INITIALIZER FILE. IF ONE FOUND, READ IT.
  16337. C IF NOT, ASK AT CONSOLE FOR SINGLE/DBL PRECISION AND INITIAL VIDEO MODE
  16338.     IVV=11
  16339. C SET UP AS THOUGH WE HAD AN @ACINIT.PRM AT STARTUP AND
  16340. C ALLOW IT TO GO THRU NORMALLY...
  16341.     INQUIRE(FILE='ACINIT.PRM',EXIST=LEXIST)
  16342.     IF(.NOT.LEXIST)GOTO 6003
  16343.     OPEN(3,FILE='ACINIT.PRM',STATUS='OLD',FORM='FORMATTED')
  16344. C    CALL RASSIG(3,'ACINIT.PRM')
  16345.     IVV=3
  16346.     IOLVL=3
  16347. c    GOTO 6403
  16348. 6003    CONTINUE
  16349. C    OPEN(5,FILE='CON:',STATUS='OLD',FORM='FORMATTED')
  16350. C OPEN EITHER CONSOLE OR INIT FILE AT FIRST...
  16351. 6403    CONTINUE
  16352. 6005    FORMAT(80A1)
  16353. C For AMIGA always use "BIOS MODE" so we can have special windowing
  16354. C code in place of the Fortran I/O. Fortran console I/O will be done
  16355. C using LUN 11 in a CON: window, but most normal spreadsheet
  16356. C operations will take place in a special window over which we will have
  16357. C finer grained control...
  16358. C
  16359.     CALL SWSET(1)
  16360.     MODFLG=1
  16361. 6008    CONTINUE
  16362. C SETS UP FOR USING ROM BIOS DIRECTLY FOR EVERYTHING...
  16363. C COULD THEN USE E.G. NEWKEY TO DO KEYBOARD CMDS.
  16364.     GOTO 6002
  16365. 6006    CONTINUE
  16366. C ERROR ON INPUT HERE... JUST FORGET IT.
  16367.     CLOSE(3)
  16368.     IOLVL=11
  16369. 6002    Continue
  16370.     call uvt100(18,0,0)
  16371. C
  16372. C SET UP THE SCREEN (ERASE, ETC.)
  16373. c erase screen first
  16374.     CALL UVT100(1,5,10)
  16375.     CALL UVT100(11,2,0)
  16376. c position cursor to r5c10
  16377.     CALL UVT100(1,5,12)
  16378. C ZERO THE VARIABLES TO START OFF WITH.
  16379.     DO 2070 KK=1,24
  16380.     DO 2070 KKK=1,27
  16381. 2070    AVBLS(KK,KKK)=char(0)
  16382. C SET UP WORK ARRAY BITMAP
  16383.     CALL WRKFIL(1,FORM,2)
  16384. c set reverse video title
  16385.     CALL UVT100(13,7,0)
  16386.     CALL SWRT('AnalytiCalc/RIM-Amiga',22)
  16387.     CALL UVT100(1,6,14)
  16388.     CALL SWRT('V27-03C',7)
  16389.     CALL UVT100(13,0,0)
  16390.     CALL UVT100(1,8,8)
  16391.     CALL SWRT(' ...The Analyst`s Tool',22)
  16392.     CALL UVT100(1,9,5)
  16393. C original name was VisiKluge, then ViziKluge, then PortaCalc, then 
  16394. C AnalyCalc, then AnalytiCalc.
  16395.     CALL SWRT('Copyright (C) 1982-1991 Glenn & Mary Everhart',45)
  16396.     CALL UVT100(1,11,1)
  16397.     call swrt('Donation of $10.00 asked if you use this program',
  16398.      1  48)
  16399. C NOW GET ON WITH USEFUL WORK.
  16400.       PRL ( 2 ) = 1
  16401.       PRL ( 3 ) = 0
  16402. c set ansi mode...
  16403.       CALL UVT100 ( 18 ,0,0)
  16404.     Call uvt100(1,13,1)
  16405.     KWID=10
  16406.     KMAP=1
  16407.     RETURN
  16408.     END
  16409. c -h- acini2.for    Fri Aug 22 12:55:25 1986    
  16410. C PORTACALC MAIN PROGRAM
  16411. C SPREAD SHEET DRIVER PROGRAM
  16412. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  16413. C ALL RIGHTS RESERVED
  16414. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  16415. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  16416. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  16417. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  16418. C FROM THE DISK BASED FILE HERE.
  16419.     SUBROUTINE INITA2(KMAP,KWID,ICODE,IKONS)
  16420. C
  16421.     Include aparms.inc
  16422. c        CHARACTER*1 NOWRAP ( 2 )
  16423.     CHARACTER*1 FORM,FVLD
  16424. c    INTEGER*4 VNLT
  16425. c    INTEGER IFCW
  16426. C    EXTERNAL LCWRQQ
  16427.     DIMENSION FORM(128),FVLD(1,1)
  16428. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  16429. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  16430. C SO INITIALLY IGNORE.
  16431. C
  16432. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  16433. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  16434. C ***<<<< RDD COMMON START >>>***
  16435.     InTeGer*4 RRWACT,RCLACT
  16436. C    COMMON/RCLACT/RRWACT,RCLACT
  16437.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16438.      1  IDOL7,IDOL8
  16439. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16440. C     1  IDOL7,IDOL8
  16441.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  16442. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16443.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16444. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16445. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16446. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16447.     InTeGer*4 KLVL
  16448. C    COMMON/KLVL/KLVL
  16449.     InTeGer*4 IOLVL,IGOLD
  16450. C    COMMON/IOLVL/IOLVL
  16451. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16452. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16453.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16454.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16455.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  16456.      3  k3dfg,kcdelt,krdelt,kpag
  16457. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16458. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16459. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  16460. C ***<<< RDD COMMON END >>>***
  16461. CCC    InTeGer*4 RRWACT,RCLACT
  16462. CCC    COMMON/RCLACT/RRWACT,RCLACT
  16463. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16464. CCC     1  IDOL7,IDOL8
  16465. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16466. CCC     1  IDOL7,IDOL8
  16467. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16468. CCC    InTeGer*4 LLCMD,LLDSP
  16469. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  16470.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  16471.     COMMON/D2R/NRDSP,NCDSP
  16472. C ***<<< NULETC COMMON START >>>***
  16473.     InTeGer*4 ICREF,IRREF
  16474. C    COMMON/MIRROR/ICREF,IRREF
  16475.     InTeGer*4 MODPUB,LIMODE
  16476. C    COMMON/MODPUB/MODPUB,LIMODE
  16477.     InTeGer*4 KLKC,KLKR
  16478.     REAL*8 AACP,AACQ
  16479. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  16480.     InTeGer*4 NCEL,NXINI
  16481. C    COMMON/NCEL/NCEL,NXINI
  16482.     CHARACTER*1 NAMARY(20,MRows)
  16483. C    COMMON/NMNMNM/NAMARY
  16484.     InTeGer*4 NULAST,LFVD
  16485. C    COMMON/NULXXX/NULAST,LFVD
  16486.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  16487.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  16488. C ***<<< NULETC COMMON END >>>***
  16489. CCC    InTeGer*4 ICREF,IRREF
  16490. CCC    COMMON/MIRROR/ICREF,IRREF
  16491. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16492. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16493. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16494. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16495. c    CHARACTER*1 FORM2(4)
  16496. C ***<<< XVXTCD COMMON START >>>***
  16497.     CHARACTER*1 OARRY(100)
  16498.     InTeGer*4 OSWIT,OCNTR
  16499. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  16500. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16501.     InTeGer*4 IPS1,IPS2,MODFLG
  16502. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16503.        InTeGer*4 XTCFG,IPSET,XTNCNT
  16504.        CHARACTER*1 XTNCMD(80)
  16505. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16506. C VARY FLAG ITERATION COUNT
  16507.     INTEGER KALKIT
  16508. C    COMMON/VARYIT/KALKIT
  16509.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  16510.     InTeGer*4 RCMODE,IRCE1,IRCE2
  16511. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16512. C     1  IRCE2
  16513. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16514. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16515. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16516. C RCFGX ON.
  16517. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16518. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16519. C  AND VM INHIBITS. (SETS TO 1).
  16520.     INTEGER*4 FH
  16521. C FILE HANDLE FOR CONSOLE I/O (RAW)
  16522. C    COMMON/CONSFH/FH
  16523.     CHARACTER*1 ARGSTR(52,4)
  16524. C    COMMON/ARGSTR/ARGSTR
  16525.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  16526.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  16527.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16528.      3  IRCE2,FH,ARGSTR
  16529. C ***<<< XVXTCD COMMON END >>>***
  16530. CCC    InTeGer*4 OSWIT,OCNTR
  16531. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  16532. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16533.     InTeGer*4 TYPE(1,2),VLEN(9)
  16534. CCC    InTeGer*4 KLVL
  16535. CCC    COMMON/KLVL/KLVL
  16536. CCC    InTeGer*4 IOLVL
  16537. CCC    COMMON/IOLVL/IOLVL
  16538. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16539. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16540.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  16541.     Real*8 VAVBLS(3,27)
  16542.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  16543.     REAL*8 XXV(1,1)
  16544.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  16545.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  16546. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  16547.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  16548.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  16549.     CHARACTER*12 CDVFMT
  16550.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  16551.     COMMON/DEFVBX/DVFMT
  16552.     CHARACTER*1 NMSH(80)
  16553.     CHARACTER*80 NMSH80
  16554.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  16555.     COMMON/NMSH/NMSH
  16556. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  16557. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16558. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  16559. CCC       CHARACTER*1 XTNCMD(80)
  16560. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16561. C VARY FLAG ITERATION COUNT
  16562. CCC    INTEGER KALKIT
  16563. CCC    COMMON/VARYIT/KALKIT
  16564. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  16565. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
  16566. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16567. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16568. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16569. C RCFGX ON.
  16570. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16571. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16572. C  AND VM INHIBITS. (SETS TO 1).
  16573. C
  16574. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  16575. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  16576. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  16577. C DISPLAY ACTUALLY USED FOR SCREEN.
  16578.     Integer*4 CWids(JIDcl)
  16579. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  16580. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  16581. C AS 20 NOT 75.
  16582. c    INTEGER*4 I4TMP
  16583.     REAL*8 DVS(JIDcl,JIDrw)
  16584.     COMMON /FVLDC/FVLD
  16585. C FOLLOWING SUPPORT VVARY OVERLAY:
  16586.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  16587.     InTeGer*4 QCAC(2),QCENT(8),ACV(8)
  16588.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  16589. C BITMAP
  16590. C    CHARACTER*1 IBITMP
  16591. C    DIMENSION IBITMP(2258)
  16592. C    COMMON/INITD/IBITMP
  16593. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  16594. C 10 CHARACTERS PER ENTRY.
  16595.     COMMON/DSPCMN/DVS,CWIDS
  16596. c    character*35 fwt
  16597. C ***<<< KLSTO COMMON START >>>***
  16598.     InTeGer*4 DLFG
  16599. C    COMMON/DLFG/DLFG
  16600.     InTeGer*4 KDRW,KDCL
  16601. C    COMMON/DOT/KDRW,KDCL
  16602.     InTeGer*4 DTRENA
  16603. C    COMMON/DTRCMN/DTRENA
  16604.     REAL*8 EP,PV,FV
  16605.     DIMENSION EP(20)
  16606.     INTEGER*4 KIRR
  16607. C    COMMON/ERNPER/EP,PV,FV,KIRR
  16608.     InTeGer*4 LASTOP
  16609. C    COMMON/ERROR/LASTOP
  16610.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  16611. C    COMMON/FMTBFR/FMTDAT
  16612.     CHARACTER*1 EDNAM(16)
  16613. C    COMMON/EDNAM/EDNAM
  16614.     InTeGer*4 MFID(2),MFMOD(2)
  16615. C    COMMON/FRM/MFID,MFMOD
  16616.     InTeGer*4 JMVFG,JMVOLD
  16617. C    COMMON/FUBAR/JMVFG,JMVOLD
  16618.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  16619.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  16620. C ***<<< KLSTO COMMON END >>>***
  16621. CCC    CHARACTER*1 EDNAM(16)
  16622. CCC    COMMON/EDNAM/EDNAM
  16623.     CHARACTER*1 EDNINI(4)
  16624.     save ednini
  16625.     DATA EDNINI/'E','D','I','T'/
  16626. C    DATA NOWRAP / "24,0 /
  16627. C
  16628.     DO 2900 III=1,16
  16629. 2900    EDNAM(III)=' '
  16630.     DO 2901 III=1,4
  16631. 2901    EDNAM(III)=EDNINI(III)
  16632.     IF(IKONS.EQ.0)GOTO 3000
  16633. 3002    CONTINUE
  16634.     CALL UVT100(1,1,1)
  16635.     CALL VWRT('Alter Widths or Mapping Y/N:',28)
  16636.     ILL=IOLVL
  16637. C    IF(ILL.EQ.5)ILL=0
  16638.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16639.     if(ill.eq.11)call vget(form,4)
  16640.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3000
  16641.     CALL VWRT('Enter NEW Global Column Width 1-120:',36)
  16642. C ALTER MAPPING DESIRED
  16643.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)KWID
  16644.     if(ill.eq.11)call vgeti(kwid)
  16645. 3004    FORMAT(I3)
  16646.     IF(KWID.LT.1.OR.KWID.GT.120)KWID=10
  16647.     CALL VWRT('Enter length of display in lines (nominally 24):',48)
  16648.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)III
  16649.     if(ill.eq.11)call vgeti(iii)
  16650.     IF(III.LE.4.OR.III.GT.999)III=24
  16651. C RESET DISPLAY SIZE IN S COMMAND QUESTIONS AS NEEDED.
  16652.     LLDSP=III
  16653.     LLCMD=III-1
  16654.     CALL VWRT('Change annotate editor from "EDIT" [Y/N]:',41)
  16655.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16656.     if(ill.eq.11)call vget(form,4)
  16657.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3031
  16658.     CALL VWRT('Give desired edit command:',26)
  16659.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)EDNAM
  16660.     if(ill.eq.11)call vget(ednam,16)
  16661.     EDNAM(16)=' '
  16662. C ENSURE THERE'S A SPACE AT END OF EDITOR NAME
  16663. 3031    CONTINUE
  16664.     CALL VWRT('Modify Extended Area Remap Y/N: ',31)
  16665.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16666.     if(ill.eq.11)call vget(form,4)
  16667.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3502
  16668.     CALL VWRT('# cols to move over on row overflow:',36)
  16669.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)ICREF
  16670.     if(ill.eq.11)call vgeti(icref)
  16671.     IF(ICREF.GT.MCols)ICREF=10
  16672.     IF(ICREF.LT.0)ICREF=10
  16673.     CALL VWRT('# rows to move down on col overflow:',34)
  16674.     if(ill.ne.11)READ(ILL,3004,END=5600,ERR=5600)IRREF
  16675.     if(ill.eq.11)call vgeti(irref)
  16676.     IF(IRREF.GT.(MRows-1))IRREF=50
  16677.     IF(IRREF.LT.0)IRREF=50
  16678. C FORCE THE RESULTS TO MAKE SENSE. 0 TO 60 ON COLS, 0-300 ON ROWS.
  16679. C IF USER BOTHERS TO READ MANUALS THIS WILL BE EXPLAINED.
  16680. 3502    CONTINUE
  16681.     CALL VWRT('Reset Display to Upper Left of Sheet Y/N:',40)
  16682.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16683.     if(ill.eq.11)call vget(form,4)
  16684.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')KMAP=0
  16685. 3006    FORMAT(80A1,50A1)
  16686. 3000    CONTINUE
  16687.     RETURN
  16688. 5600    CONTINUE
  16689.     IOLVL=11
  16690.     CLOSE(3)
  16691. c    Rewind 11
  16692. c    CLOSE(11)
  16693. c    OPEN(11,FILE='CON:0/0/100/100/Analy Command',
  16694. c     1  STATUS='OLD',FORM='FORMATTED')
  16695.     RETURN
  16696.     END
  16697. c -h- acini3.for    Fri Aug 22 12:55:39 1986    
  16698. C PORTACALC MAIN PROGRAM
  16699. C SPREAD SHEET DRIVER PROGRAM
  16700. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  16701. C ALL RIGHTS RESERVED
  16702. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  16703. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  16704. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  16705. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  16706. C FROM THE DISK BASED FILE HERE.
  16707.     SUBROUTINE INITB(KMAP,KWID,ICODE)
  16708. C
  16709.     Include aparms.inc
  16710. c        CHARACTER*1 NOWRAP ( 2 )
  16711.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  16712. c    INTEGER*4 VNLT
  16713. c    INTEGER IFCW
  16714. C    EXTERNAL LCWRQQ
  16715.     DIMENSION FORM(128),FVLD(1,1)
  16716. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  16717. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  16718. C SO INITIALLY IGNORE.
  16719. C
  16720. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  16721. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  16722. C ***<<<< RDD COMMON START >>>***
  16723.     InTeGer*4 RRWACT,RCLACT
  16724. C    COMMON/RCLACT/RRWACT,RCLACT
  16725.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16726.      1  IDOL7,IDOL8
  16727. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16728. C     1  IDOL7,IDOL8
  16729.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  16730. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16731.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16732. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16733. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16734. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16735.     InTeGer*4 KLVL
  16736. C    COMMON/KLVL/KLVL
  16737.     InTeGer*4 IOLVL,IGOLD
  16738. C    COMMON/IOLVL/IOLVL
  16739. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16740. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16741.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16742.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16743.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  16744.      3  k3dfg,kcdelt,krdelt,kpag
  16745. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  16746. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  16747. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  16748. C ***<<< RDD COMMON END >>>***
  16749. CCC    InTeGer*4 RRWACT,RCLACT
  16750. CCC    COMMON/RCLACT/RRWACT,RCLACT
  16751. CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  16752. CCC     1  IDOL7,IDOL8
  16753. CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  16754. CCC     1  IDOL7,IDOL8
  16755. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16756. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  16757.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  16758.     COMMON/D2R/NRDSP,NCDSP
  16759. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16760. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  16761. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  16762. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  16763. c    CHARACTER*1 FORM2(4)
  16764. C ***<<< XVXTCD COMMON START >>>***
  16765.     CHARACTER*1 OARRY(100)
  16766.     InTeGer*4 OSWIT,OCNTR
  16767. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  16768. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16769.     InTeGer*4 IPS1,IPS2,MODFLG
  16770. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16771.        InTeGer*4 XTCFG,IPSET,XTNCNT
  16772.        CHARACTER*1 XTNCMD(80)
  16773. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16774. C VARY FLAG ITERATION COUNT
  16775.     INTEGER KALKIT
  16776. C    COMMON/VARYIT/KALKIT
  16777.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  16778.     InTeGer*4 RCMODE,IRCE1,IRCE2
  16779. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16780. C     1  IRCE2
  16781. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16782. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16783. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16784. C RCFGX ON.
  16785. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16786. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16787. C  AND VM INHIBITS. (SETS TO 1).
  16788.     INTEGER*4 FH
  16789. C FILE HANDLE FOR CONSOLE I/O (RAW)
  16790. C    COMMON/CONSFH/FH
  16791.     CHARACTER*1 ARGSTR(52,4)
  16792. C    COMMON/ARGSTR/ARGSTR
  16793.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  16794.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  16795.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  16796.      3  IRCE2,FH,ARGSTR
  16797. C ***<<< XVXTCD COMMON END >>>***
  16798. CCC    InTeGer*4 OSWIT,OCNTR
  16799.  
  16800. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  16801. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  16802.     InTeGer*4 TYPE(1,2),VLEN(9)
  16803. CCC    InTeGer*4 KLVL
  16804. CCC    COMMON/KLVL/KLVL
  16805. CCC    InTeGer*4 IOLVL
  16806. CCC    COMMON/IOLVL/IOLVL
  16807. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  16808. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  16809.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  16810.     Real*8 VAVBLS(3,27)
  16811.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  16812.     REAL*8 XXV(1,1)
  16813.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  16814.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  16815. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  16816.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  16817.     CHARACTER*12 CDVFMT
  16818.     EQUIVALENCE(DEFFMT(1),DVFMT(2))
  16819.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  16820.     COMMON/DEFVBX/DVFMT
  16821.     CHARACTER*1 NMSH(80)
  16822.     CHARACTER*80 NMSH80
  16823.     EQUIVALENCE(NMSH80(1:1),FORM(1))
  16824.     COMMON/NMSH/NMSH
  16825. CCC    InTeGer*4 IPS1,IPS2,MODFLG
  16826. CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
  16827. CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
  16828. CCC       CHARACTER*1 XTNCMD(80)
  16829. CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  16830. C VARY FLAG ITERATION COUNT
  16831. CCC    INTEGER KALKIT
  16832. CCC    COMMON/VARYIT/KALKIT
  16833. CCC    InTeGer*4 FORMFG,RCFGX,PZAP
  16834. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
  16835. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  16836. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  16837. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  16838. C RCFGX ON.
  16839. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  16840. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  16841. C  AND VM INHIBITS. (SETS TO 1).
  16842. C
  16843. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  16844. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  16845. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  16846. C DISPLAY ACTUALLY USED FOR SCREEN.
  16847.     Integer*4 CWids(JIDcl)
  16848. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  16849. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  16850. C AS 20 NOT 75.
  16851. c    INTEGER*4 I4TMP
  16852.     REAL*8 DVS(JIDcl,JIDrw)
  16853.     COMMON /FVLDC/FVLD
  16854. C FOLLOWING SUPPORT VVARY OVERLAY:
  16855.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  16856.     InTeGer*4 QCAC(2),QCENT(8),ACV(8)
  16857.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  16858. C BITMAP
  16859. C    CHARACTER*1 IBITMP
  16860. C    DIMENSION IBITMP(2258)
  16861. C    COMMON/INITD/IBITMP
  16862. C    CHARACTER*1 DFMTS(10,JIDcl,JIDrw)
  16863. C 10 CHARACTERS PER ENTRY.
  16864.     COMMON/DSPCMN/DVS,CWIDS
  16865.     character*35 fwt
  16866. C    DATA NOWRAP / "24,0 /
  16867. C
  16868.     idol5=20000
  16869.     idol6=20000
  16870. C INITIALLY SET JRCL TO 301 = NO. OF ROWS TO BE IN WORK FILE
  16871.     JRCL=MRows
  16872.     PZAP=0
  16873.     XTCFG=0
  16874.     IPSET=0
  16875. C ZERO BITMAP
  16876. C    DO 36 N1=1,2258
  16877. C36    IBITMP(N1)=0
  16878. c    LINIZZ=0
  16879.     kswmem=0
  16880.     CALL UVT100(1,14,1)
  16881.     CALL VWRT('Enter NEW floating format default Y/N:',38)
  16882.     ILL=IOLVL
  16883. C    IF(ILL.EQ.5)ILL=0
  16884.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16885.     if(ill.eq.11)call vget(form,4)
  16886.     IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3589
  16887. C ENTER NEW DEFAULT.
  16888. 6888    CALL UVT100(1,14,1)
  16889.     CALL UVT100(12,2,0)
  16890. C LINE NOW ERASED... GET NEW FORMAT
  16891.     CALL VWRT('Enter new format. Suggest F10.2>',32)
  16892.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16893.     if(ill.eq.11)call vget(form,16)
  16894. C NOW HAVE HIS DESIRED FORMAT. COPY INTO THE DEFAULT ARRAY.
  16895. C DEFFMT IS THAT.
  16896.     DO 3591 N1=1,10
  16897.     KKK=ICHAR(FORM(N1))
  16898.     KKK=MAX0(32,KKK)
  16899. C ASSUME NMSH COMPLETELY INIT'D
  16900. 3591    DEFFMT(N1)=Char(KKK)
  16901. c    dvfmt(1)='('
  16902. c    dvfmt(12)=')'
  16903. C CHECK ITS LEGALITY BY TRYING TO USE IT ONCE.
  16904.     XX=3.14159
  16905.     WRITE(NMSH80(1:80),DVFMT,ERR=6888)XX
  16906. C    ENCODE(78,DVFMT,NMSH,ERR=6888)XX
  16907. C IF IT FAILS, PROGRAM WILL CRASH AND FILE WON'T GET CLOBBERED.
  16908. 3589    CONTINUE
  16909.     CALL UVT100(1,15,1)
  16910.     CALL VWRT('Title for Spreadsheet {` to ask sizes}:',39)
  16911.     ILL=IOLVL
  16912. C    IF(ILL.EQ.5)ILL=0
  16913.     if(ill.ne.11)READ(ILL,3006,END=5600,ERR=5600)FORM
  16914.     if(ill.eq.11)call vget(form,120)
  16915. 3006    FORMAT(80A1,50A1)
  16916. c If title starts with ` ask for sizes and reprompt title. Else set
  16917. c defaults up.
  16918.     if(form(1).ne.'`')goto 5306
  16919.     kswmem=1
  16920.     call uvt100(1,19,1)
  16921.     call vwrt('Software virtual memory sizes will be asked',43)
  16922.     goto 3589
  16923. 5306    continue
  16924.     IF(ICHAR(FORM(1)).LE.32.AND.ICHAR(FORM(2)).LE.32) GOTO 3008
  16925. C COPY TITLE UNLESS IT'S OLD
  16926.     DO 3007 KKK=1,80
  16927. 3007    NMSH(KKK)=FORM(KKK)
  16928. C THAT WAY JUST C.R. LEAVES IN OLD TITLE.
  16929. 3008    CONTINUE
  16930. C ****** IF S OPTION GIVEN THEN ICODE=-2
  16931. C THEREFORE, DON'T ASK DISK SIZE ETC, BUT ALLOW RESET OF TITLE
  16932. C AND DEFAULT FORMATS.
  16933.     IF(ICODE.EQ.-2) GOTO 7831
  16934. C ******
  16935.     kr=40
  16936.     kc=22
  16937.     ipgmod=0
  16938.     lpgmod=0
  16939.     ipgmax=1
  16940.     lpgmxf=1
  16941.     if(kswmem.eq.0) goto 5307
  16942.     CALL UVT100(1,16,1)
  16943.     CALL VWRT('Give Max Rows to be used:',25)
  16944.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)KR
  16945.     if(ill.eq.11)call vgeti(kr)
  16946.     IF(KR.LE.0)KR=MRows
  16947.     CALL UVT100(1,17,1)
  16948.     CALL VWRT('Give Max Cols to be used:',25)
  16949.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)KC
  16950.     if(ill.eq.11)call vgeti(kc)
  16951.     IF(KC.LE.0)KC=MCols
  16952. C    KKK=(KR-1)*60+KC
  16953. C ALLOW REPLIES IN ANY RANGE AND REFLECT BACK TO PRIME RANGE
  16954. C NOTE WE WANT A CELL ADDRESS HERE FOR THE END CELL...
  16955.     CALL REFLEC(KR,KC,KKK)
  16956.     XKKKK=KR*KC
  16957.     XKDF=XKKKK/64.
  16958.     XKDN=XKKKK/100.
  16959. C COMPUTED ABOVE THE MIN # OF K FOR DISK FILES
  16960.     CALL UVT100(1,18,1)
  16961.     write(fwt(1:12),2058)xkdn
  16962. 2058    format(F9.0)
  16963.     CALL SWRT('Min=',4)
  16964.     call swrt(fwt(1:12),9)
  16965.     write(fwt,2058)xkdf
  16966.     call swrt(' K Value file ',14)
  16967.     CALL SWRT(fwt(1:12),9)
  16968.     CALL SWRT(' K Formula file',15)
  16969. c    WRITE(0,2058)XKDN,XKDF
  16970. c2058    FORMAT(' Mins=',F9.0' K Value file, ',F9.0,' K Formula file',\)
  16971. C KKK IS MAX INDEX TO BE USED HERE.
  16972.     CALL UVT100(1,21,1)
  16973.     CALL VWRT('Give Value File size, K:',24)
  16974.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)IPGMAX
  16975.     if(ill.eq.11)call vgeti(ipgmax)
  16976. 7202    FORMAT(I6)
  16977.     IPGMOD=KKK
  16978.     IF(IPGMAX.LT.0)IPGMOD=0
  16979.     IPGMAX=IABS(IPGMAX)
  16980.     IF(IPGMAX.GT.2512)IPGMAX=1
  16981.     CALL UVT100(1,22,1)
  16982.     CALL VWRT('Give Formula File size, K:',26)
  16983.     if(ill.ne.11)READ(ILL,7202,END=5600,ERR=5600)LPGMXF
  16984.     if(ill.eq.11)call vgeti(lpgmxf)
  16985.     LPGMOD=KKK
  16986.     IF(LPGMXF.LT.0)LPGMOD=0
  16987.     LPGMXF=IABS(LPGMXF)
  16988. C IF NUMBERS ARE ENTERED NEGATIVE, SET MODE TO "SLOW, FILE-SPACE
  16989. C CONSERVING" PACKING, SCATTERING PAGES ACROSS FILE.
  16990.     IF(LPGMXF.GT.4096)LPGMXF=(IPGMAX*3)/2
  16991. 5307    Continue
  16992. C NULL TERMINATE ALL FORMAT STRINGS.
  16993. C SET MAX WIDTH FOR PRINT TO DIMENSION OF THE BUFFER. NOTE THIS IS THE
  16994. C USUAL HARDWARE MAXIMUM SO WE DON'T WORRY TOO MUCH ABOUT IT. NOTE
  16995. C BILL TABOR'S PROGRAM TO PRINT PASTE-ABLE VERSIONS OF THE SHEET FROM
  16996. C SAVE FILES EXISTS, SO WE NEEDN'T WORRY TOO MUCH EITHER ABOUT USING
  16997. C DISPLAY FOR DOUBLE DUTY.
  16998.     MXL=132
  16999. C INITIALIZE WORK STORAGE FOR FORMULAS AND VARIABLES
  17000.     CALL WSSET
  17001. 7831    CONTINUE
  17002. C SET DEFAULT WIDTHS OF COLUMNS TO 10. MAY BE ALTERED BELOW FOR DIFFERENT
  17003. C DEFAULT IF DESIRED.
  17004.     DO 16 N1=1,JIDcl
  17005.     CWIDS(N1)=KWID
  17006. 16    CONTINUE
  17007. C
  17008. C NOW SET UP NRDSP, NCDSP
  17009.     IF(KMAP.EQ.0)GOTO 3009
  17010. C SET UP MAPPING NOW FOR INITIALLY UPPER LEFT CORNER OF PHYS SHEET IN DISPLAY SHT.
  17011.     DO 5 N1=1,JIDcl
  17012.     DO 5 N2=1,JIDrw
  17013. C INITIALLY WE DISPLAY THE UPPER LEFT PART OF THE SYSTEM.
  17014. C ESTABLISH ASSOCIATION INITIALLY THEREFORE OF DISPLAY TO UPPER
  17015. C LEFT OF PHYSICAL SHEET.
  17016.     NRDSP(N1,N2)=N1
  17017.     NCDSP(N1,N2)=N2+1
  17018.     DVS(N1,N2)=.00000031
  17019. 5    CONTINUE
  17020. C FOR S OPTION USE SECRET -4 CODE TO RESET SHEET. STILL NEEDS WORK
  17021. C IN PORTACALC PC.
  17022.     IF(ICODE.EQ.-4)CALL WRKFIL(1,FORM,2)
  17023. 3009    IF(ICODE.EQ.-4)GOTO 1
  17024. C43    CALL UVT100(1,21,1)
  17025.     KZPPD=0
  17026.     CMDLIN(1)=Char(0)
  17027.     IOLDFL=0
  17028. C3017    FORMAT(Q,80A1,80A1)
  17029.     MXL=1
  17030.     CMDLIN(MXL+1)=Char(0)
  17031. 3572    FORMAT(I6)
  17032.     CALL UVT100(13,0,0)
  17033. C  SET UP RANDOM FILE AS NEEDED FOR SHEET
  17034. C EACH RECORD HAS:
  17035. C CHARS 1-110    FORMULAS
  17036. C CHARS 120-128    DISPLAY FORMAT (INITIALLY F9.2)
  17037. C CHAR 119    VALID FLAG (ALLOWS HANDLING READS.)
  17038. C    values: -3, -2: Numeric-only text (or special chars)
  17039. C         -1    : Alphanumeric text
  17040. C          0    : Uninitialized
  17041. C          1    : Alphanumeric formula
  17042. C         +2    : Number or pure numeric formula with value calculated
  17043. C         +3    : Number or pure numeric formula, value not yet computed
  17044. C CHAR 118    MAGIC NUMBER 15 (CHECKS ALL WELL)
  17045. C READ A RECORD, IF ERROR, CREATE EMPTY FILE.
  17046. C    IF(IOLDFL.EQ.0)GOTO 1
  17047. CC IF IOLDFL NONZERO IT MEANS USER CLAIMS THERE EXISTS A FILE. IF 0 IT'S NEW.
  17048. CC HERE IT'S OLD SO LET'S BE SURE IT REALLY IS OK.
  17049. 1    CONTINUE
  17050. C HIT EOF OR ERROR. MUST BE A NEW FILE. THEREFORE ZERO IT TO OUR NEEDS.
  17051. C AT THIS POINT WE ARE CREATING A NEW FILE AND NEED TO ZERO IT.
  17052. C
  17053.     DO 3 N=1,128
  17054.     FORM(N)=Char(0)
  17055. 3    CONTINUE
  17056.     DO 3592 N=1,9
  17057. C SET UP DEFAULT FORMAT
  17058. 3592    FORM(119+N)=DEFFMT(N)
  17059.     FORM(118)=CHAR(15)
  17060.     FORM(1)='0'
  17061.     FORM(2)='.'
  17062. C CREATE NULL FILE INITIALLY BY RESETTING ALL.
  17063.     JRRCL=MCols*JRCL
  17064.     KZPPD=1
  17065. C
  17066. 2    CONTINUE
  17067. C COMMON POINT WITH FILE PREPARED.
  17068.     PCOL=2
  17069.     PROW=1
  17070.     DCOL=1
  17071.     DROW=1
  17072.     RETURN
  17073. 5600    CONTINUE
  17074. C ERROR ON READ FROM IOLVL HANDLED HERE.
  17075. C    REWIND 5
  17076.     Rewind 11
  17077. c    CLOSE(11)
  17078. c    OPEN(11,FILE='CON:0/150/500/49/Analy Command',
  17079. c     1  STATUS='OLD',FORM='FORMATTED')
  17080.     CLOSE(3)
  17081.     IOLVL=11
  17082.     RETURN
  17083.     END
  17084. c -h- block.for    Fri Aug 22 12:58:14 1986    
  17085.     SUBROUTINE BLOCK
  17086. C    BLOCK DATA
  17087. C COPYRIGHT (C) 1983 GLENN EVERHART
  17088. C ALL RIGHTS RESERVED
  17089. C 18060 = 60*301
  17090. C 18033=18060-27
  17091. C 60=MAX REAL ROWS
  17092. C 301=MAX REAL COLS
  17093. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  17094. C VBLS AND TYPE DIMENSIONED 60,301
  17095.     Include aparms.inc
  17096. C   ++++++++++++++++++++++++++++++++++++++++++++++++++
  17097. C   +                                                +
  17098. C   +            CALC    VERSION  X01-06             +
  17099. C   +                                                +
  17100. C   ++++++++++++++++++++++++++++++++++++++++++++++++++
  17101. C
  17102. C
  17103. C *******************************************************
  17104. C *                                                     *
  17105. C *            BLOCK  DATA  MODULE                      *
  17106. C *                                                     *
  17107. C *******************************************************
  17108. C
  17109. C
  17110. C COMMON AREAS ARE INITIALIZED BY THIS MODULE.
  17111. C FAKEUP FOR MICROSOFT WHICH HAS NO BLOCK DATA.
  17112. C DO IT ALL VIA LOOPS...
  17113. C
  17114. C
  17115. C MODIFIED 18-MAY-1981 P.B. SET % TO VERSION 6
  17116. C
  17117. C
  17118. C
  17119. C   VARIABLE      USE
  17120. C
  17121. C  ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC CHARACTERS
  17122. C               OR THE CHARACTER %.
  17123. C  BASED     HOLDS DEFAULT BASE.
  17124. C  BLANK        ' '
  17125. C  COMMA        ','
  17126. C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
  17127. C               SECOND SUBSCRIPT IS
  17128. C                     1 FOR DECIMAL
  17129. C                     2 FOR OCTAL
  17130. C                     3 FOR HEXADECIMAL
  17131. C  DTBL1(9,9,8) CONTROLS THE DECISION PROCESS WHEN EVALUATING A
  17132. C               BINARY OPERATION. SEE BELOW FOR DETAILS.
  17133. C  EQ           '='
  17134. C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
  17135. C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
  17136. C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
  17137. C               USED TO CONTROL ITERATION.
  17138. C  LINE(80)     COMMAND INPUT LINE
  17139. C  LPAR         '('
  17140. C  RPAR         ')'
  17141. C  ST1LIM       HOLDS THE SIZE OF STACK 1 (ALWAYS CONSTANT)
  17142. C  ST2LIM       HOLDS THE SIZE OF STACK 2 (ALWAYS CONSTANT)
  17143. C  ST1PT        POINTS TO THE TOP OF STACK 1 (CHANGES AS STACK IS USED)
  17144. C  ST2PT        POINTS TO THE TOP OF STACK 2 (CHANGES AS STACK IS USED)
  17145. C  ST1TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 1
  17146. C  ST2TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 2
  17147. C  STACK1(20,40)   UTILITY STACKS USED WHEN EVALUATING EXPRESSIONS. THE FIRST
  17148. C  STACK2(20,40)   SUBSCRIPT CONTROLS INDEXING ACROSS THE BYTES OF A SINGLE
  17149. C                   VARIABLE. THE SECOND SUBSCRIPT CONTROLS STACK ELEMENTS.
  17150. C  TYPE(27)         HOLDS THE DATA TYPES FOR EACH OF THE 27 VARIABLES. SEE
  17151. C                   CODES.FTN FOR THE POSSIBLE VALUES.
  17152. C  VIEWSW           VIEW SWITCH
  17153. C                    0 = OUTPUT ERROR MESSAGES
  17154. C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
  17155. C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
  17156. C                        EVALUATED.
  17157. C                    3 = OUTPUT EVERYTHING
  17158. C  VLEN(9)      INDEXED BY DATA TYPE. GIVES THE NUMBER OF BYTES USED
  17159. C               BY THAT DATA TYPE.
  17160. C  AVBLS(20,27)      HOLDS THE VALUES OF THE 27 LEGAL VARIABLES.(ACCUMULATORS)
  17161. C  VBLS(8,60,301)    HOLDS VALUES OF ALL VARIABLES
  17162. C
  17163. C
  17164. C
  17165. C    CONSTANTS ARE STORED IN VBLS ACCORDING TO THEIR TYPE:
  17166. C
  17167. C
  17168. C
  17169. C <----------- MULTIPLE PRECISION (M10, M8, M16) ------------------------->
  17170. C !                        <------------- DECIMAL AND REAL --------------->
  17171. C !                        !                      <-- INTEGER HEX OCTAL -->
  17172. C !                                               !             ---> ASCII <---
  17173. C !                        !                      !                        !
  17174. C
  17175. C -------------     -------------------------------------------------------
  17176. C !     !     !     !     !     !     !     !     !     !     !     !     !
  17177. C ! 20  !  19 ! ... !  9  !  8  !  7  !  6  !  5  !  4  !  3  !  2  !  1  !
  17178. C !     !     !     !     !     !     !     !     !     !     !     !     !
  17179. C -------------     -------------------------------------------------------
  17180. C
  17181. C
  17182. C NOTE: BYTE 20 HOLDS THE SIGN FOR MULTIPLE PRECISION NUMBERS.
  17183. C       0 = POSITIVE, 1 = NEGATIVE
  17184. C
  17185. C
  17186. C
  17187. C
  17188. C
  17189. C    BLOCK DATA
  17190.     InTeGer*4 LEVEL,NONBLK,LEND
  17191.     InTeGer*4 LASTOP
  17192.     InTeGer*4 ST1TYP(40),ST2TYP(40)
  17193.     InTeGer*4 TYPE(1,2)
  17194.     InTeGer*4 VIEWSW,BASED,VLEN(9),BVLEN(9)
  17195.     InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
  17196.     InTeGer*4 ITCNTV(6)
  17197. C
  17198.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ,LINE(80)
  17199.     CHARACTER*1 BOMMA,BBLANK,BRPAR,BLPAR,BEQ
  17200.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  17201.     CHARACTER*1 AVBLS(24,27),BLPHA(27)
  17202.     Real*8 VAVBLS(3,27)
  17203.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  17204.     CHARACTER*1 VBLS(8,1,1)
  17205. C ***<<< XVXTCD COMMON START >>>***
  17206.     CHARACTER*1 OARRY(100)
  17207.     InTeGer*4 OSWIT,OCNTR
  17208. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  17209. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  17210.     InTeGer*4 IC1POS,IC2POS,MODFLG
  17211. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  17212.        InTeGer*4 XTCFG,IPSET,XTNCNT
  17213.        CHARACTER*1 XTNCMD(80)
  17214. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  17215. C VARY FLAG ITERATION COUNT
  17216.     INTEGER KALKIT
  17217. C    COMMON/VARYIT/KALKIT
  17218.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  17219.     InTeGer*4 RCMODE,IRCE1,IRCE2
  17220. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17221. C     1  IRCE2
  17222. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  17223. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  17224. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  17225. C RCFGX ON.
  17226. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  17227. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  17228. C  AND VM INHIBITS. (SETS TO 1).
  17229.     INTEGER*4 FH
  17230. C FILE HANDLE FOR CONSOLE I/O (RAW)
  17231. C    COMMON/CONSFH/FH
  17232.     CHARACTER*1 ARGSTR(52,4)
  17233. C    COMMON/ARGSTR/ARGSTR
  17234.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  17235.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  17236.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17237.      3  IRCE2,FH,ARGSTR
  17238. C ***<<< XVXTCD COMMON END >>>***
  17239. CCC    InTeGer*4 IC1POS,IC2POS
  17240. CCC    COMMON/ICPOS/IC1POS,IC2POS
  17241.     CHARACTER*1 DTBL1(9,9,8)
  17242. CC BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  17243. C MOVED TABLE TO WRKFIL WHERE IT IS OVERLAIN BY A BUFFER DURING OPERATION
  17244. C AND JUST INITIALIZES DTBL1 AT STARTUP. THIS SHOULD ESSENTIALLY REMOVE DATA
  17245. C SPACE PENALTY FOR THIS HUGE ARRAY. NOTE IT'D BE SMALLER IF THERE WEREN'T
  17246. C SO MANY SUPPORTED DATA TYPES IN CALC.
  17247. C    InTeGer*4 BTBL(9,9,8)
  17248. C    InTeGer*4 BTBL1(9,9)
  17249. C    InTeGer*4 BTBL2(9,9),BTBL3(9,9),BTBL4(9,9),BTBL5(9,9)
  17250. C    InTeGer*4 BTBL6(9,9),BTBL7(9,9),BTBL8(9,9)
  17251. C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  17252. C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  17253. C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  17254. C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  17255.     CHARACTER*1 DIGITS(16,3),BIGITS(16,3)
  17256. C
  17257. C OARRY WILL BE USED TO HOLD OUTPUT VARIABLE IF OSWIT IS NONZERO
  17258. CCC    InTeGer*4 OSWIT
  17259. C OCNTR MAY HOLD BYTES VALID IN OARRY (UP TO 100, NO MORE...)
  17260. CCC    InTeGer*4 OCNTR
  17261. CCC    CHARACTER*1 OARRY(100)
  17262. C
  17263. C ILINE IS PROGRAMMABLE LINE INPUT (I.E., NOT FROM CONSOLE)
  17264.     CHARACTER*1 ILINE(106)
  17265.     InTeGer*4 ILNFG
  17266.     InTeGer*4 ILNCT
  17267.     COMMON /ILN/ILNFG,ILNCT,ILINE
  17268. C ILINE IS PRESENT IF ILNFG <> 0 AND ILNCT HAS # BYTES IN IT.
  17269. CCC    COMMON /OAR/OSWIT,OCNTR,OARRY
  17270.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  17271.     COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  17272.     COMMON /STACKx/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  17273.      ;         ST1LIM,ST2LIM
  17274.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  17275.     COMMON /DECIDE/ DTBL1
  17276.     COMMON /DIGV/ DIGITS
  17277. C ***<<< KLSTO COMMON START >>>***
  17278.     InTeGer*4 DLFG
  17279. C    COMMON/DLFG/DLFG
  17280.     InTeGer*4 KDRW,KDCL
  17281. C    COMMON/DOT/KDRW,KDCL
  17282.     InTeGer*4 DTRENA
  17283. C    COMMON/DTRCMN/DTRENA
  17284.     REAL*8 EP,PV,FV
  17285.     DIMENSION EP(20)
  17286.     INTEGER*4 KIRR
  17287. C    COMMON/ERNPER/EP,PV,FV,KIRR
  17288. c    InTeGer*4 LASTOP
  17289. C    COMMON/ERROR/LASTOP
  17290.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  17291. C    COMMON/FMTBFR/FMTDAT
  17292.     CHARACTER*1 EDNAM(16)
  17293. C    COMMON/EDNAM/EDNAM
  17294.     InTeGer*4 MFID(2),MFMOD(2)
  17295. C    COMMON/FRM/MFID,MFMOD
  17296.     InTeGer*4 JMVFG,JMVOLD
  17297. C    COMMON/FUBAR/JMVFG,JMVOLD
  17298.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  17299.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  17300. C ***<<< KLSTO COMMON END >>>***
  17301. CCC    COMMON /ERROR/ LASTOP
  17302.     COMMON/ITERA/ ITCNTV
  17303.     CHARACTER*1 DVFMT(12),BVFMT(12)
  17304.     COMMON/DEFVBX/DVFMT
  17305. C SUPPORT VVARY OVERLAY WITH INITIAL VARY DATA:
  17306.     REAL*8 QAC(26),QDERIV(8),QDEL(8),QOLDVV,oldx,olda
  17307.     InTeGer*4 QCAC(2),QCENT(8),ACV(8)
  17308.     COMMON/VRYDAT/QAC,QDERIV,QDEL,QCAC,QCENT,QOLDVV,oldx,olda,ACV
  17309. C INITIAL DEFAULT FORMAT FOR NUMERICS
  17310.     DATA BVFMT/'(','F','9','.','2',' ',
  17311.      1  ' ',' ',' ',' ',' ',')'/
  17312. C
  17313. C    DATA BIEWSW/2/
  17314. C    DATA ITCNTV/6*0/
  17315.     DATA BLPHA/'A','B','C','D','E','F','G','H','I','J','K','L','M',
  17316.      ;       'N','O','P','Q','R','S','T','U','V','W','X','Y','Z','%'/
  17317.     DATA BIGITS/'1','2','3','4','5','6','7','8','9',
  17318.      1  '0','0','0','0','0','0','0',
  17319.      ;       '1','2','3','4','5','6','7',
  17320.      1  '0','0','0','0','0','0','0','0','0',
  17321.      ;  '1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','0'/
  17322.     DATA BOMMA/','/,BBLANK/' '/,BRPAR/')'/,BLPAR/'('/,BEQ/'='/
  17323. C
  17324. C
  17325. C DEFAULT BASE IS 10
  17326. C    DATA BASED/10/
  17327. C
  17328. C
  17329. C STACKS ARE CURRENTLY SET AT 40 ELEMENTS DEEP
  17330. C    DATA ST1LIM/40/, ST2LIM/40/
  17331. C
  17332. C
  17333. C
  17334. C    DEFAULT TYPES
  17335. C    A,B,C,D,E,F,G,H  =  DECIMAL
  17336. C    I,J,K,L,M,N      =  INTEGER (BASE10)
  17337. C    O,P,Q,R,S,T,U,V,W,X,Y,Z  =  DECIMAL
  17338. C
  17339. C  % AS INTEGER TO HOLD CALC VERSION NUMBER
  17340. C
  17341. C    DATA TYPE/8*2,6*4,12*2,4,1*2/
  17342. c modify type array so ac's i-n are reals
  17343. C    DATA TYPE/8*2,6*2,12*2,2,1*2/
  17344. C
  17345. C
  17346. C GIVE VERSION # BY VALUE IN %
  17347. C
  17348. c don't bother with this; by the time user gets into calc,
  17349. c % already is clobbered most times, so no need for it.
  17350. c    DATA AVBLS(1,27)/6/
  17351. c    DATA AVBLS(2,27)/0/,AVBLS(3,27)/0/,AVBLS(4,27)/0/
  17352. C
  17353. C
  17354. C
  17355. C
  17356. C SPECIFY THE LENGTH USED BY EACH DATA TYPE
  17357.     DATA BVLEN/1,8,4,4,8,8,8,4,8/
  17358. C
  17359. C NOTE ALL LENGTHS 8 OR LESS SINCE MULTIPLE PRECISION THINGS SNIPPED OUT
  17360. C
  17361. C  DECISION TABLE FOR PERFORMING BINARY OPERATIONS
  17362. C
  17363. C  DTBL1(OPERAND2,OPERAND1,INDEX)
  17364. C
  17365. C  WHERE:                    OPERATOR:
  17366. C  INDEX=1    MODIFY CODE FOR OPERAND 1    */+-
  17367. C     2    MODIFY CODE FOR OPERAND 2    */+-
  17368. C     3    FUNCTION VALUE TYPE        */+-
  17369. C     4    OPERATOR CLASS            */+-
  17370. C
  17371. C     5    MODIFY CODE FOR OPERAND 1    **
  17372. C     6    MODIFY CODE FOR OPERAND 2    **
  17373. C     7    FUNCTION VALUE TYPE        **
  17374. C     8    OPERATOR CLASS            **
  17375. C
  17376. C
  17377. C  WHERE TYPE CODES (MODIFY CODES) ARE:
  17378. C    0    NO CHANGE
  17379. C    1    CONVERT TO ASCII
  17380. C    2    CONVERT TO DECIMAL
  17381. C    3    CONVERT TO HEXADECIMAL
  17382. C    4    CONVERT TO INTEGER
  17383. C    5    CONVERT TO M10
  17384. C    6    CONVERT TO M8
  17385. C    7    CONVERT TO M16
  17386. C    8    CONVERT TO OCTAL
  17387. C    9    CONVERT TO REAL
  17388. C
  17389. C  FOR */+- FUNCTION VALUE TYPES AND OPERATOR CLASS ARE PRESENTLY
  17390. C  IDENTICAL
  17391. C
  17392. C  FOR **  OPERATOR CLASSES FOLLOW:
  17393. C
  17394. C     CODE    OPERATOR CLASS
  17395. C    1    REAL**REAL
  17396. C    2    REAL**INTEGER
  17397. C    3    INTEGER**REAL
  17398. C    4    INTEGER**REAL
  17399. C    5    M8**INTEGER
  17400. C    6    M10**INTEGER
  17401. C    7    M16**INTEGER
  17402. C
  17403. C
  17404. C
  17405. C    DATA BTBL1 /4,2,3,4,5,6,7,8,9,
  17406. C     1  9*0,0,2,0,0,3*7,0,9,0,2,0,0,5,5,7,0,9,0,2,7,0,0,0,7,0,9,
  17407. C     2  0,2,7,5,5,0,7,0,9,0,2,6*0,9,0,2,3,0,5,6,7,0,9,0,2,7*0/
  17408. C    DATA BTBL2/
  17409. C     3  4,8*0,2,0,6*2,0,3,3*0,7,7,3*0,4,4*0,5,3*0,5,0,7,5,0,5,0,5,0,
  17410. C     4  6,0,7,5,3*0,6,0,7,2,4*7,0,7,0,8,8*0,9,0,6*9,0/
  17411. C    DATA BTBL3/4,2,3,4,5,6,7,8,9,
  17412. C     5  9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,5,2,7,3*5,7,5,9,
  17413. C     6  6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,9,2,7*9/
  17414. C    DATA BTBL4/
  17415. C     7  4,2,3,4,5,6,7,8,9,9*2,3,2,3,3,3*7,3,9,4,2,3,4,5,5,7,4,9,
  17416. C     8  5,2,7,5,5,5,7,5,9,6,2,7,5,5,6,7,6,9,7,2,6*7,9,8,2,3,4,5,6,7,8,9,
  17417. C     9  9,2,7*9/
  17418. C    DATA BTBL5/4,2,3,6*4,9*0,9*0,9*0,0,9,6*0,9,0,9,6*0,9,0,9,6*0,9,
  17419. C     1  9*0,9*0/
  17420. C    DATA BTBL6/4,3*0,3*9,4,0,4,3*0,3*9,0,0,4,3*0,3*9,2*0,4,3*0,3*9,
  17421. C     2  2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*4,2*0,4,3*0,3*9,2*0,
  17422. C     3  4,3*0,3*9,2*0/
  17423. C        DATA BTBL7/4,2,3,6*4,9*2,9*3,9*4,5,9,6*5,9,6,9,6,6,5,6,7,6,9,
  17424. C     4  7,9,6*7,9,9*8,9*9/
  17425. C    DATA BTBL8/4,1,4,4,3,3,3,4,3,2,1,2,2,3*1,2,1,4,3,4,4,3*3,
  17426. C     5  4,3,4,3,4,4,3*3,4,3,6,1,6*6,1,5,1,6*5,1,7,1,6*7,1,4,3,4,4,3*3,
  17427. C     6  4,3,2,1,2,2,3*1,2,1/
  17428. C
  17429. C HERE COPY LOCAL DATA INTO THE COMMONS.
  17430. C SINCE MOST ARRAYS AND THINGS ARE SMALL, WE JUST DO IT WITH REGULAR FORTRAN.
  17431. C THE BTBL ARRAY IS HANDLED IN WRKFIL WHERE THERE'S A BIG ENOUGH ARRAY FOR
  17432. C SCRATCH SPACE TO HOLD THE INITIAL DATA; WRKFIL IS CALLED BY WSSET WITH
  17433. C "SECRET CODE" TO INIT DTBL1 FROM THE ARRAY AND DOES SO ONCE ONLY.
  17434.     VIEWSW=0
  17435.     LEVEL=1
  17436.     LASTOP=0
  17437.     BASED=10
  17438.     COMMA=BOMMA
  17439.     BLANK=BBLANK
  17440.     RPAR=BRPAR
  17441.     LPAR=BLPAR
  17442.     EQ=BEQ
  17443.     DO 1 N=1,6
  17444.     ITCNTV(N)=0
  17445. 1    CONTINUE
  17446.     DO 2 N=1,27
  17447.     DO 12 NN=1,20
  17448. 12    AVBLS(NN,N)=Char(0)
  17449. 2    ALPHA(N)=BLPHA(N)
  17450.     ST1LIM=40
  17451.     ST2LIM=40
  17452. C THIS IS DONE IN WRKFIL SINCE THERE'S A BIG LOCAL ARRAY THERE
  17453. C WE CAN KEEP EQUIVALENCED TO THIS ONE...
  17454. C    DO 3 N2=1,9
  17455. C    DO 3 N1=1,9
  17456. C    DTBL1(N1,N2,2)=BTBL2(N1,N2)
  17457. C    DTBL1(N1,N2,3)=BTBL3(N1,N2)
  17458. C    DTBL1(N1,N2,4)=BTBL4(N1,N2)
  17459. C    DTBL1(N1,N2,5)=BTBL5(N1,N2)
  17460. C    DTBL1(N1,N2,6)=BTBL6(N1,N2)
  17461. C    DTBL1(N1,N2,7)=BTBL7(N1,N2)
  17462. C    DTBL1(N1,N2,8)=BTBL8(N1,N2)
  17463. C3    DTBL1(N1,N2,1)=BTBL1(N1,N2)
  17464.     DO 4 N=1,9
  17465.     VLEN(N)=BVLEN(N)
  17466. 4    CONTINUE
  17467.     DO 5 N2=1,3
  17468.     DO 5 N1=1,16
  17469.     DIGITS(N1,N2)=BIGITS(N1,N2)
  17470. 5    CONTINUE
  17471. C SET UP DEFAULT DISPLAY FORMAT (INCLUDES "(" AND ")" CHARS WHICH
  17472. C ***MUST*** BE THERE FOR MAIN PGM TO WORK).
  17473.     DO 17 N=1,12
  17474.     DVFMT(N)=BVFMT(N)
  17475. 17    Continue
  17476.     DO 15 N=1,26
  17477.     QAC(N)=0.
  17478. 15    CONTINUE
  17479.     DO 18 N=1,8
  17480.     QDERIV(N)=1.
  17481.     ACV(N)=0
  17482.     QDEL(N)=0.
  17483.     QCENT(N)=0
  17484. 18    CONTINUE
  17485.     QOLDVV=1.
  17486.     QCAC(1)=1
  17487.     OSWIT=0
  17488.     OCNTR=0
  17489.     ILNFG=0
  17490.     ILNCT=0
  17491.     IC1POS=0
  17492.     IC2POS=0
  17493.     RETURN
  17494.     END
  17495. c -h- dtrcmd.for    Fri Aug 22 13:04:33 1986    
  17496. C DATATRIEVE INTERFACE FUNCTIONS
  17497. C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
  17498. C
  17499. C THIS IS THE NON-DTR VERSION with dummy entry points for
  17500. C the DTR functions BUT supplying the new non-DTR functions
  17501. c completely.
  17502.     SUBROUTINE DTRCMD(LINE)
  17503.     Include aparms.inc
  17504.     CHARACTER*1 LINE(80)
  17505.     CHARACTER*70 LINEC
  17506. C    EQUIVALENCE(LINEC(1:1),LINE(1))
  17507. C    INCLUDE VKLUGPRM.FTN''
  17508. C COPYRIGHT (C) 1983 GLENN EVERHART
  17509.     INTEGER RETCD
  17510. C
  17511. C DEFINE FILE AREAS FOR MAPPING FILES...
  17512. C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE
  17513. C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND
  17514. C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE
  17515. C INPUT - ONLY OR READ/WRITE.
  17516. C
  17517. C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
  17518. C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
  17519. C
  17520. C MFIOPN =    0    IF NOT OPEN
  17521. C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
  17522. C        2    IF OPEN READ ONLY, RANDOM
  17523. C        3    IF OPEN READ/WRITE, RANDOM.
  17524. C
  17525. C MFOOPN =    0    IF NOT OPEN
  17526. C        1    IF OPEN WRITE SEQUENTIAL
  17527. C        2    IF OPEN WRITE RANDOM
  17528. C
  17529. C OTHER OPTIONS DON'T MAKE SENSE.
  17530. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
  17531. C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
  17532. C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
  17533. C MFILUN,MFOLUN ARE LOGICAL UNITS.
  17534.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  17535.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  17536.  
  17537.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  17538.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  17539.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  17540. C
  17541. C
  17542.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  17543.     Real*8 VAVBLS(3,27)
  17544.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  17545.     InTeGer*4 TYPE(1,2),VLEN(9)
  17546.     REAL*8 XAC,XVBLS(1,1)
  17547.     REAL*8 TAC,UAC,VAC,WAC,YAC
  17548.     REAL*8 TMP
  17549.     INTEGER*4 JVBLS(2,1,1)
  17550.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  17551.     EQUIVALENCE(XAC,AVBLS(1,27))
  17552.     EQUIVALENCE(TAC,AVBLS(1,20))
  17553.     EQUIVALENCE(UAC,AVBLS(1,21))
  17554.     EQUIVALENCE(VAC,AVBLS(1,22))
  17555.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  17556.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  17557.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  17558. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  17559. CCC    CHARACTER*1 XTNCMD(80)
  17560. C ***<<<< RDD COMMON START >>>***
  17561.     InTeGer*4 RRWACT,RCLACT
  17562. C    COMMON/RCLACT/RRWACT,RCLACT
  17563.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  17564.      1  IDOL7,IDOL8
  17565. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  17566. C     1  IDOL7,IDOL8
  17567.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  17568. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17569.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  17570. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  17571. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  17572. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  17573.     InTeGer*4 KLVL
  17574. C    COMMON/KLVL/KLVL
  17575.     InTeGer*4 IOLVL,IGOLD
  17576. C    COMMON/IOLVL/IOLVL
  17577. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  17578. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  17579.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  17580.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  17581.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  17582.      3  k3dfg,kcdelt,krdelt,kpag
  17583. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  17584. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  17585. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  17586. C ***<<< RDD COMMON END >>>***
  17587. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  17588. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  17589. CCC    InTeGer*4 RRWACT,RCLACT
  17590. CCC    COMMON/RCLACT/RRWACT,RCLACT
  17591. C ***<<< XVXTCD COMMON START >>>***
  17592.     CHARACTER*1 OARRY(100)
  17593.     InTeGer*4 OSWIT,OCNTR
  17594. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  17595. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  17596.     InTeGer*4 IPS1,IPS2,MODFLG
  17597. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  17598.        InTeGer*4 XTCFG,IPSET,XTNCNT
  17599.        CHARACTER*1 XTNCMD(80)
  17600. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  17601. C VARY FLAG ITERATION COUNT
  17602.     INTEGER KALKIT
  17603. C    COMMON/VARYIT/KALKIT
  17604.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  17605.     InTeGer*4 RCMODE,IRCE1,IRCE2
  17606. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17607. C     1  IRCE2
  17608. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  17609. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  17610. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  17611. C RCFGX ON.
  17612. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  17613. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  17614. C  AND VM INHIBITS. (SETS TO 1).
  17615.     INTEGER*4 FH
  17616. C FILE HANDLE FOR CONSOLE I/O (RAW)
  17617. C    COMMON/CONSFH/FH
  17618.     CHARACTER*1 ARGSTR(52,4)
  17619. C    COMMON/ARGSTR/ARGSTR
  17620.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  17621.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  17622.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  17623.      3  IRCE2,FH,ARGSTR
  17624. C ***<<< XVXTCD COMMON END >>>***
  17625. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  17626. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  17627. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  17628. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  17629. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  17630. C (IMPLEMENT FOR VAX ONLY)
  17631. CCC    INTEGER KALKIT
  17632. CCC    COMMON/VARYIT/KALKIT
  17633. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  17634. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  17635. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17636. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  17637.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  17638.     COMMON/D2R/NRDSP,NCDSP
  17639. C ***<<< KLSTO COMMON START >>>***
  17640.     InTeGer*4 DLFG
  17641. C    COMMON/DLFG/DLFG
  17642.     InTeGer*4 KDRW,KDCL
  17643. C    COMMON/DOT/KDRW,KDCL
  17644.     InTeGer*4 DTRENA
  17645. C    COMMON/DTRCMN/DTRENA
  17646.     REAL*8 EP,PV,FV
  17647.     DIMENSION EP(20)
  17648.     INTEGER*4 KIRR
  17649. C    COMMON/ERNPER/EP,PV,FV,KIRR
  17650.     InTeGer*4 LASTOP
  17651. C    COMMON/ERROR/LASTOP
  17652.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  17653. C    COMMON/FMTBFR/FMTDAT
  17654.     CHARACTER*1 EDNAM(16)
  17655. C    COMMON/EDNAM/EDNAM
  17656.     InTeGer*4 MFID(2),MFMOD(2)
  17657. C    COMMON/FRM/MFID,MFMOD
  17658.     InTeGer*4 JMVFG,JMVOLD
  17659. C    COMMON/FUBAR/JMVFG,JMVOLD
  17660.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  17661.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  17662. C ***<<< KLSTO COMMON END >>>***
  17663. CCC    InTeGer*4 DTRENA
  17664. CCC    COMMON/DTRCMN/DTRENA
  17665.     CHARACTER *1 LINECL(82)
  17666. C    CHARACTER*70 LINEC
  17667.     EQUIVALENCE(LINEC(1:1),LINECL(1))
  17668. C    CHARACTER*80 SCRBUF
  17669.     CHARACTER*1 LBUF(128)
  17670.     CHARACTER*1 MBUF(128)
  17671.     CHARACTER*110 CLBUF,CMBUF
  17672.     CHARACTER*50 CCLBUF,CCMBUF
  17673.     CHARACTER*11 C11LBF
  17674. C    EQUIVALENCE(C11LBF(1:1),CLBUF(1:1))
  17675.     EQUIVALENCE(CLBUF(1:1),CCLBUF(1:1),LBUF(1),C11LBF(1:1)),
  17676.      1  (CMBUF(1:1),CCMBUF(1:1),MBUF(1))
  17677. C    EQUIVALENCE(CLBUF,LBUF(1)),(CMBUF,MBUF(1))
  17678. C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
  17679.     CHARACTER*9 FMTB
  17680.     EQUIVALENCE (FMTB(1:1),LBUF(120))
  17681. c    CHARACTER*11 FMTBF
  17682. c    CHARACTER*1 IFVLD
  17683. C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
  17684. ccc    DO 3332 N=1,80
  17685. ccc    NN=81-N
  17686. ccc    IF(ICHAR(LINE(NN)).GT.32)GOTO 3333
  17687. ccc    LINE(NN)=CHAR(0)
  17688. ccc3332    CONTINUE
  17689. ccc3333    CONTINUE
  17690. C SPACE FILL ENTIRE ARRAY
  17691.     DO 3334 N=1,82
  17692. 3334    LINECL(N)=CHAR(32)
  17693.     RETCD=1
  17694. C HANDLE DTRCMD FUNCTIONS. LINE ARRAY PASSED IN HERE
  17695. C STARTS AFTER THE "DTR" SO WE CAN DECODE IT.
  17696. C EXECUTE DTR COMMAND
  17697. C  DTRCMD (COMMAND) GIVES DTR COMMAND FACILITY AT COMMAND
  17698. C LEVEL.
  17699. C ALLOW DTRIMM COMMAND TO USE DTR IMMEDIATE TERMINAL
  17700. C INTERFACE. THE REST CAN USE SAME COMMAND NAMES AS AFTER
  17701. C THE "DB" IN *U DBXXXX COMMANDS.
  17702. 500    CONTINUE
  17703. C ENABLE/DISABLE FOR DTR FUNCTIONS
  17704. C SETTING DTRENA TO -1 IMPLIES DISABLE FUNCTIONS
  17705.     CALL SCMP(LINE,'ENA',3,ICODE)
  17706.     IF(ICODE.NE.1)GOTO 600
  17707.     DTRENA=1
  17708.     GOTO 9999
  17709. 600    CONTINUE
  17710.     CALL SCMP(LINE,'DIS',3,ICODE)
  17711.     IF(ICODE.NE.1)GOTO 700
  17712.     DTRENA=-1
  17713.     GOTO 9999
  17714. 700    CONTINUE
  17715.     CALL SCMP(LINE,'OPINS',5,ICODE)
  17716. C OPEN INPUT SEQUENTIAL
  17717.     IF(ICODE.NE.1)GOTO 3800
  17718. C DTROPINS RANGE FILENAME
  17719.     IBGN=6
  17720.     IVLD=0
  17721.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  17722.     IF(IVLD.EQ.3)GOTO 9990
  17723.     LINE(LSTCH+25)=CHAR(0)
  17724.     OPEN(UNIT=MFILUN,FILE=LINE(LSTCH),ACCESS='SEQUENTIAL',
  17725.      1  STATUS='OLD',IOSTAT=IVVV)
  17726.     IF(IVVV.NE.0)GOTO 9990
  17727.     MFIOPN=1
  17728.     GOTO 9999
  17729. 3800    CONTINUE
  17730.     CALL SCMP(LINE,'OPINRR',6,ICODE)
  17731. C OPEN IN RANDOM READ
  17732.     IF(ICODE.NE.1)GOTO 3900
  17733.     KK=2
  17734.     GOTO 3910
  17735. 3900    CONTINUE
  17736.     CALL SCMP(LINE,'OPINRU',6,ICODE)
  17737. C OPEN IN RANDOM UPDATE
  17738.     IF(ICODE.NE.1)GOTO 3950
  17739.     KK=3
  17740. 3910    CONTINUE
  17741. C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
  17742.     IBGN=7
  17743.     IVLD=0
  17744.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  17745.     IF(IVLD.EQ.3)GOTO 9990
  17746. C *******
  17747. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  17748.     DO 5601 NN=1,50
  17749. 5601    MBUF(NN)=' '
  17750.     DO 5602 NN=1,25
  17751. 5602    MBUF(NN)=LINE(LSTCH+NN-1)
  17752. C    LINE(LSTCH+25)=0
  17753. C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
  17754. C    OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='BINARY',
  17755. C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='OLD',
  17756. C     1  RECL=128,BLOCKSIZE=128,ERR=9990)
  17757.     OPEN(UNIT=MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  17758.      1  STATUS='OLD',FORM='UNFORMATTED',RECL=128,
  17759.      1  IOSTAT=IVVV)
  17760.     IF(IVVV.NE.0)GOTO 9990
  17761.     MFIOPN=KK
  17762.     GOTO 9999
  17763. 3950    CONTINUE
  17764.     CALL SCMP(LINE,'OPOUTS',6,ICODE)
  17765. C OPEN OUTPUT SEQUENTIAL
  17766.     IF(ICODE.NE.1)GOTO 4000
  17767.     IBGN=7
  17768.     IVLD=0
  17769.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  17770.     IF(IVLD.EQ.3)GOTO 9990
  17771. C *******
  17772. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  17773. C    LINE(LSTCH+25)=0
  17774.     DO 5603 NN=1,50
  17775. 5603    MBUF(NN)=' '
  17776.     DO 5604 NN=1,25
  17777. 5604    MBUF(NN)=LINE(LSTCH+NN-1)
  17778.     OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='SEQUENTIAL',
  17779.      1  STATUS='NEW',IOSTAT=IVVV,recl=512)
  17780.     IF(IVVV.NE.0)GOTO 9990
  17781.     MFOOPN=1
  17782.     GOTO 9999
  17783. 4000    CONTINUE
  17784.     CALL SCMP(LINE,'OPOUTR',6,ICODE)
  17785. C OPEN OUTPUT RANDOM
  17786.     IF(ICODE.NE.1)GOTO 4100
  17787.     IBGN=7
  17788.     IVLD=0
  17789.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  17790.     IF(IVLD.EQ.3)GOTO 9990
  17791. C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
  17792. C *******
  17793. C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
  17794.     DO 5605 NN=1,50
  17795. 5605    MBUF(NN)=' '
  17796.     DO 5606 NN=1,25
  17797. 5606    MBUF(NN)=LINE(LSTCH+NN-1)
  17798. C    LINE(LSTCH+25)=0
  17799. C    OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  17800. C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='NEW',
  17801. C     1  RECL=128,ERR=9990)
  17802.     OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='DIRECT',
  17803.      1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
  17804.      2  IOSTAT=IVVV)
  17805.     IF(IVVV.NE.0)GOTO 9990
  17806.     MFOOPN=2
  17807.     GOTO 9999
  17808. 4100    CONTINUE
  17809.     CALL SCMP(LINE,'CLSOUT',6,ICODE)
  17810. C CLOSE OUTPUT 
  17811.     IF(ICODE.NE.1)GOTO 4200
  17812.     CLOSE(UNIT=MFOLUN)
  17813.     MFOOPN=0
  17814.     GOTO 9999
  17815. 4200    CONTINUE
  17816.     CALL SCMP(LINE,'CLSINP',6,ICODE)
  17817. C CLOSE INPUT 
  17818.     IF(ICODE.NE.1)GOTO 4300
  17819.     CLOSE(UNIT=MFILUN)
  17820.     MFIOPN=0
  17821.     GOTO 9999
  17822. 4300    CONTINUE
  17823.     CALL SCMP(LINE,'ENAOUT',6,ICODE)
  17824. C ENABLE OUTPUT 
  17825.     IF(ICODE.NE.1)GOTO 4400
  17826.     MFOFLG=1
  17827.     GOTO 9999
  17828. 4400    CONTINUE
  17829.     CALL SCMP(LINE,'ENAINP',6,ICODE)
  17830. C ENABLE INPUT 
  17831.     IF(ICODE.NE.1)GOTO 4500
  17832.     MFIFLG=1
  17833.     GOTO 9999
  17834. 4500    CONTINUE
  17835.     CALL SCMP(LINE,'DISINP',6,ICODE)
  17836. C DISABLE INPUT 
  17837.     IF(ICODE.NE.1)GOTO 4510
  17838.     MFIFLG=0
  17839.     GOTO 9999
  17840. 4510    CONTINUE
  17841.     CALL SCMP(LINE,'DISOUT',6,ICODE)
  17842. C DISABLE OUTPUT
  17843.     IF(ICODE.NE.1)GOTO 4520
  17844.     MFOFLG=0
  17845.     GOTO 9999
  17846. 4520    CONTINUE
  17847.     CALL SCMP(LINE,'EDTINP',6,ICODE)
  17848. C ENABLE INPUT FORCE
  17849. C COMMAND
  17850. C DTREDTINP RANGE
  17851. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  17852. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  17853. C IT OUT AGAIN.
  17854.     IF(ICODE.NE.1)GOTO 4600
  17855. C FORCE ENABLE OF READIN DURING THIS
  17856.     MFIFLG=1
  17857.     MFOFLG=1
  17858. C ENABLE OUTPUT TOO.
  17859.     IBGN=7
  17860.     IVLD=0
  17861.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17862.     IF(IVLD.EQ.3)GOTO 9990
  17863.     DO 4550 N1=IXRL,IXRH
  17864.     DO 4550 N2=IXCL,IXCH
  17865.     CALL REFLEC(N2,N1,IRX)
  17866. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  17867.     CALL FVLDST(N1,N2,Char(255))
  17868.     CALL WRKFIL(IRX,LBUF,0)
  17869.     CALL WRKFIL(IRX,LBUF,1)
  17870. 4550    CONTINUE
  17871.     MFIFLG=0
  17872.     MFOFLG=0
  17873.     GOTO 9999
  17874. 4600    CONTINUE
  17875.     CALL SCMP(LINE,'FMTOUT',6,ICODE)
  17876. C FORMAT/WRITE OUTPUT
  17877. C COMMAND
  17878. C DTRFMTOUT RANGE
  17879. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  17880. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  17881. C IT OUT AGAIN.
  17882.     IF(ICODE.NE.1)GOTO 4630
  17883.     IVLFG=1
  17884.     GOTO 4740
  17885. 4630    CONTINUE
  17886.     CALL SCMP(LINE,'VALOUT',6,ICODE)
  17887.     IF(ICODE.NE.1)GOTO 4700
  17888. C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
  17889.     IVFLG=2
  17890. C    GOTO 4740
  17891. 4740    CONTINUE
  17892. C FORCE ENABLE OF READIN DURING THIS
  17893.     MFIFLG=1
  17894.     MFOFLG=1
  17895. C ENABLE OUTPUT TOO.
  17896.     IBGN=7
  17897.     IVLD=0
  17898.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17899.     IF(IVLD.EQ.3)GOTO 9990
  17900.     DO 4650 N1=IXRL,IXRH
  17901.     DO 4650 N2=IXCL,IXCH
  17902. C FIND INDEX FOR WRKFIL
  17903.     CALL REFLEC(N2,N1,IRX)
  17904. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  17905.     CALL XVBLGT(N1,N2,TMP)
  17906. C TMP IS REAL*8 SCRATCH
  17907.     CALL FVLDST(N1,N2,Char(255))
  17908.     CALL WRKFIL(IRX,LBUF,0)
  17909. C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
  17910. C NOW GRAB THE VALUE AND SAVE IT...
  17911. C FIRST MOVE THE FORMAT DOWN
  17912. C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
  17913.     DO 4651 N=1,9
  17914.     LBUF(N+1)=LBUF(N+119)
  17915. 4651    CONTINUE
  17916.     LBUF(1)='('
  17917.     LBUF(11)=')'
  17918. c    LBUF(12)=CHAR(0)
  17919. C CHANGE TO USE CHAR VERSION OF LBUF
  17920. C *******
  17921. C FORMAT NOW LIVES IN LOW PART OF LBUF
  17922. C D25.17 FORMAT WOULD DO FOR WRITE
  17923. c    IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF(1:11),ERR=4652)TMP
  17924.     IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF,ERR=4652)TMP
  17925.     IF(IVLFG.EQ.2)WRITE(LINEC(1:70),4658,ERR=4652)TMP
  17926. 4658    FORMAT(D25.17)
  17927. C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
  17928. C USE DISPLAY FORMAT.
  17929. 4652    CONTINUE
  17930.     KK=1
  17931.     DO 4653 N=1,110
  17932. 4653    LBUF(N)=CHAR(0)
  17933.     DO 4654 N=1,60
  17934. C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
  17935.     KKK=JCHAR(LINECL(N))
  17936.     IF(KKK.LE.32)GOTO 4654
  17937.     LBUF(KK)=LINECL(N)
  17938.     KK=KK+1
  17939. 4654    CONTINUE
  17940.     CALL WRKFIL(IRX,LBUF,1)
  17941. 4650    CONTINUE
  17942.     MFIFLG=0
  17943.     MFOFLG=0
  17944.     GOTO 9999
  17945. 4700    CONTINUE
  17946.     CALL SCMP(LINE,'CMPFRM',6,ICODE)
  17947.     IF(ICODE.NE.1)GOTO 4800
  17948. C DBCMPFRM V1:V2
  17949. C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
  17950.     IBGN=7
  17951.     IVLD=0
  17952. C USE GMTX TO GET CELL ADDRESSES.
  17953.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  17954.     IF(IVLD.EQ.3)GOTO 9990
  17955. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  17956.     CALL REFLEC(IXCL,IXRL,IRXL)
  17957.     CALL REFLEC(IXCH,IXRH,IRXH)
  17958.     IF(LINE(LSTCH).NE.',')GOTO 4780
  17959.     IBGN=LSTCH+1
  17960.     IVLD=0
  17961.     CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
  17962.     IF(IVLD.EQ.3)GOTO 4780
  17963. C GET THE LENGTHS NOW
  17964.     CALL XVBLGT(IYRL,IYCL,TMP)
  17965.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  17966.     LBUFL=TMP
  17967.     CALL XVBLGT(IYRH,IYCH,TMP)
  17968.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  17969.     MBUFL=TMP
  17970. C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
  17971. C COMPARISONS BASED ON THAT.
  17972.     GOTO 4770
  17973. 4780    CONTINUE
  17974. C GET INDEX OF EACH ELEMENT...
  17975.     CALL WRKFIL(IRXL,LBUF,0)
  17976.     CALL WRKFIL(IRXH,MBUF,0)
  17977. C LOAD THE 2 FORMULAS.
  17978. C NOW FIND THE ENDS...
  17979.     DO 4750 N=1,110
  17980.     NN=111-N
  17981.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
  17982. 4750    CONTINUE
  17983. 4751    LBUFL=NN
  17984.     DO 4760 N=1,110
  17985.     NN=111-N
  17986.     IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
  17987. 4760    CONTINUE
  17988. 4761    MBUFL=NN
  17989. 4770    CONTINUE
  17990. c find index pos'n by hand...
  17991.     KK=LBUFL-MBUFL+1
  17992.     DO 4776 NN=1,KK
  17993.     IF(LBUF(NN).NE.MBUF(1))GOTO 4776
  17994.     NNN=MBUFL-1
  17995.     DO 4777 N=1,NNN
  17996.     IVVV=NN+N
  17997.     IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
  17998. 4777    CONTINUE
  17999. C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
  18000. C SINCE NN IS WHAT WE NEED, GO USE IT.
  18001.     GOTO 4779
  18002. 4778    CONTINUE
  18003. 4776    CONTINUE
  18004. C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
  18005. C
  18006.     NN=0
  18007. 4779    CONTINUE
  18008. C NN IS LOCATION OF SUBSTRING NOW
  18009. C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
  18010. C NN IS LOCATION OF SUBSTRING NOW
  18011.     XAC=NN
  18012. C RETURN RESULT IN % ACCUMULATOR.
  18013.     WAC=0.
  18014.     IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
  18015.     IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
  18016. C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
  18017. C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
  18018. C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
  18019.     GOTO 9999
  18020. 4800    CONTINUE
  18021.     CALL SCMP(LINE,'LENFRM',6,ICODE)
  18022.     IF(ICODE.NE.1)GOTO 4900
  18023. C DBLENFRM V1:V2
  18024. C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
  18025.     IBGN=7
  18026.     IVLD=0
  18027. C USE GMTX TO GET CELL ADDRESSES.
  18028.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  18029.     IF(IVLD.EQ.3)GOTO 9990
  18030. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  18031.     CALL REFLEC(IXCL,IXRL,IRXL)
  18032. C GET INDEX OF EACH ELEMENT...
  18033.     CALL WRKFIL(IRXL,LBUF,0)
  18034. C LOAD THE FORMULA.
  18035. C NOW FIND THE END...
  18036.     DO 4850 N=1,110
  18037.     NN=111-N
  18038.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
  18039. 4850    CONTINUE
  18040. 4851    LBUFL=NN
  18041.     TMP=LBUFL
  18042.     XAC=TMP
  18043. C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
  18044.     NN=0
  18045. C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
  18046.     CALL FVLDGT(IXRH,IXCH,NN)
  18047.     IF(NN.EQ.0)GOTO 9999
  18048.     CALL XVBLST(IXRH,IXCH,TMP)
  18049.     GOTO 9999
  18050. 4900    CONTINUE
  18051.     CALL SCMP(LINE,'TRMFRM',6,ICODE)
  18052.     IF(ICODE.NE.1)GOTO 5000
  18053. C TRIM FORMULA
  18054. C DTRTRMFRM INCELL:OUTCELL,START:END
  18055. C RETURNS TRIMMED FORMULA TO CELL.
  18056.     IBGN=7
  18057.     IVLD=0
  18058. C USE GMTX TO GET CELL ADDRESSES.
  18059.     CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
  18060.     IF(IVLD.EQ.3)GOTO 9990
  18061. C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
  18062.     CALL REFLEC(IXCL,IXRL,IRXL)
  18063. C GET INDEX OF EACH ELEMENT...
  18064.     CALL REFLEC(IXCH,IXRH,IRXH)
  18065.     CALL WRKFIL(IRXL,LBUF,0)
  18066.     LO=LSTCHR+1
  18067.     LHI=LSTCHR+21
  18068.     LSTCHR=LHI
  18069.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  18070.     IF(IVLD.EQ.0)GOTO 9990
  18071.     CALL XVBLGT(JD1,JD2,TMP)
  18072.     LOCHR=1
  18073.     IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
  18074. C LOCHR = START CHAR
  18075.     LO=LSTCHR+1
  18076.     LHI=LSTCHR+21
  18077.     LSTCHR=LHI
  18078.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  18079.     IF(IVLD.EQ.0)GOTO 9990
  18080.     CALL XVBLGT(JD1,JD2,TMP)
  18081.     LHICHR=110
  18082.     IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
  18083. C LHICHR IS END CHARACTER
  18084. C NOW ALL ARGS ARE COLLECTED.
  18085. C (IGNORE WHAT WAS DELIMITER...)
  18086. C COPY DESIRED STUFF TO MBUF
  18087.     N=1
  18088.     DO 4910 NN=1,110
  18089.     MBUF(NN)=CHAR(0)
  18090.     IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
  18091.     MBUF(N)=LBUF(NN)
  18092.     N=N+1
  18093. C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
  18094. 4910    CONTINUE
  18095.     DO 4911 NN=111,128
  18096. 4911    MBUF(NN)=LBUF(NN)
  18097.     CALL WRKFIL(IRXH,MBUF,1)
  18098. C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
  18099. C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
  18100.     GOTO 9999
  18101. 5000    CONTINUE
  18102.     GOTO 9999
  18103. 9990    RETCD=3
  18104. C ERROR RETURN
  18105. 9999    RETURN
  18106.     END
  18107. c -h- dtrfct.for    Fri Aug 22 13:05:02 1986    
  18108. C DATATRIEVE INTERFACE FUNCTIONS
  18109. C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
  18110. C COPYRIGHT 1986 GCE
  18111.     SUBROUTINE DTRFCT(LINE,RETCD)
  18112.     InTeGer*4 RETCD
  18113.     Include aparms.inc
  18114.     CHARACTER*1 LINE(80)
  18115.     CHARACTER *1 LINECL(82)
  18116.     CHARACTER*62 LINEC
  18117.     EQUIVALENCE(LINEC(1:1),LINECL(1))
  18118. C
  18119. C
  18120. C DEFINE FILE AREAS FOR MAPPING FILES...
  18121. C
  18122. C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
  18123. C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
  18124. C
  18125. C MFIOPN =    0    IF NOT OPEN
  18126. C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
  18127. C        2    IF OPEN READ ONLY, RANDOM
  18128. C        3    IF OPEN READ/WRITE, RANDOM.
  18129. C
  18130. C MFOOPN =    0    IF NOT OPEN
  18131. C        1    IF OPEN WRITE SEQUENTIAL
  18132. C        2    IF OPEN WRITE RANDOM
  18133. C
  18134. C OTHER OPTIONS DON'T MAKE SENSE.
  18135. C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
  18136. C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
  18137. C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
  18138. C MFILUN,MFOLUN ARE LOGICAL UNITS.
  18139.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  18140.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  18141.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  18142.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  18143.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  18144. C
  18145. C
  18146. C    INCLUDE VKLUGPRM.FTN''
  18147. C COPYRIGHT (C) 1983 GLENN EVERHART
  18148. C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
  18149. C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
  18150.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  18151.     Real*8 VAVBLS(3,27)
  18152.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  18153.     InTeGer*4 TYPE(1,2),VLEN(9)
  18154.     REAL*8 XAC,XVBLS(1,1)
  18155.     REAL*8 TAC,UAC,VAC,WAC,YAC
  18156.     REAL*8 TMP
  18157.     INTEGER*4 JVBLS(2,1,1)
  18158.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  18159.     EQUIVALENCE(XAC,AVBLS(1,27))
  18160.     EQUIVALENCE(TAC,AVBLS(1,20))
  18161.     EQUIVALENCE(UAC,AVBLS(1,21))
  18162.     EQUIVALENCE(VAC,AVBLS(1,22))
  18163.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  18164.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  18165.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  18166. C ***<<<< RDD COMMON START >>>***
  18167.     InTeGer*4 RRWACT,RCLACT
  18168. C    COMMON/RCLACT/RRWACT,RCLACT
  18169.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  18170.      1  IDOL7,IDOL8
  18171. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  18172. C     1  IDOL7,IDOL8
  18173.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  18174. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  18175.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  18176. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  18177. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  18178. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  18179.     InTeGer*4 KLVL
  18180. C    COMMON/KLVL/KLVL
  18181.     InTeGer*4 IOLVL,IGOLD
  18182. C    COMMON/IOLVL/IOLVL
  18183. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  18184. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  18185.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  18186.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  18187.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  18188.      3  k3dfg,kcdelt,krdelt,kpag
  18189. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  18190. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  18191. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  18192. C ***<<< RDD COMMON END >>>***
  18193. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  18194. CCC    CHARACTER*1 XTNCMD(80)
  18195. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  18196. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  18197. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  18198. CCC    InTeGer*4 RRWACT,RCLACT
  18199. CCC    COMMON/RCLACT/RRWACT,RCLACT
  18200. C ***<<< XVXTCD COMMON START >>>***
  18201.     CHARACTER*1 OARRY(100)
  18202.     InTeGer*4 OSWIT,OCNTR
  18203. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  18204. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  18205.     InTeGer*4 IPS1,IPS2,MODFLG
  18206. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  18207.        InTeGer*4 XTCFG,IPSET,XTNCNT
  18208.        CHARACTER*1 XTNCMD(80)
  18209. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  18210. C VARY FLAG ITERATION COUNT
  18211.     INTEGER KALKIT
  18212. C    COMMON/VARYIT/KALKIT
  18213.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  18214.     InTeGer*4 RCMODE,IRCE1,IRCE2
  18215. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  18216. C     1  IRCE2
  18217. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  18218. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  18219. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  18220. C RCFGX ON.
  18221. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  18222. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  18223. C  AND VM INHIBITS. (SETS TO 1).
  18224.     INTEGER*4 FH
  18225. C FILE HANDLE FOR CONSOLE I/O (RAW)
  18226. C    COMMON/CONSFH/FH
  18227.     CHARACTER*1 ARGSTR(52,4)
  18228. C    COMMON/ARGSTR/ARGSTR
  18229.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  18230.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  18231.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  18232.      3  IRCE2,FH,ARGSTR
  18233. C ***<<< XVXTCD COMMON END >>>***
  18234. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  18235. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  18236. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  18237. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  18238. C (IMPLEMENT FOR VAX ONLY)
  18239.     INTEGER IVVV
  18240. CCC    COMMON/VARYIT/KALKIT
  18241. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  18242. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  18243. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  18244. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  18245.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  18246.     COMMON/D2R/NRDSP,NCDSP
  18247. C ***<<< KLSTO COMMON START >>>***
  18248.     InTeGer*4 DLFG
  18249. C    COMMON/DLFG/DLFG
  18250.     InTeGer*4 KDRW,KDCL
  18251. C    COMMON/DOT/KDRW,KDCL
  18252.     InTeGer*4 DTRENA
  18253. C    COMMON/DTRCMN/DTRENA
  18254.     REAL*8 EP,PV,FV
  18255.     DIMENSION EP(20)
  18256.     INTEGER*4 KIRR
  18257. C    COMMON/ERNPER/EP,PV,FV,KIRR
  18258.     InTeGer*4 LASTOP
  18259. C    COMMON/ERROR/LASTOP
  18260.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  18261. C    COMMON/FMTBFR/FMTDAT
  18262.     CHARACTER*1 EDNAM(16)
  18263. C    COMMON/EDNAM/EDNAM
  18264.     InTeGer*4 MFID(2),MFMOD(2)
  18265. C    COMMON/FRM/MFID,MFMOD
  18266.     InTeGer*4 JMVFG,JMVOLD
  18267. C    COMMON/FUBAR/JMVFG,JMVOLD
  18268.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  18269.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  18270. C ***<<< KLSTO COMMON END >>>***
  18271. CCC    InTeGer*4 DTRENA
  18272. CCC    COMMON/DTRCMN/DTRENA
  18273. C    CHARACTER*70 LINEC
  18274.     CHARACTER*1 LBUF(128)
  18275.     CHARACTER*1 MBUF(128)
  18276.     CHARACTER*110 CLBUF,CMBUF
  18277. C    EQUIVALENCE(CLBUF(1:1),LBUF(1)),(CMBUF(1:1),MBUF(1))
  18278.     CHARACTER*50 CCMBUF
  18279.     CHARACTER*11 C11LBF
  18280.     EQUIVALENCE(CCMBUF(1:1),CMBUF(1:1),MBUF(1)),
  18281.      1  (C11LBF(1:1),CLBUF(1:1),LBUF(1))
  18282. C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
  18283. c    CHARACTER*1 IFVLD
  18284.     RETCD=1
  18285.     IF(DTRENA.LT.0)GOTO 9999
  18286. C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
  18287. ccc    DO 3332 N=1,76
  18288. ccc    NN=77-N
  18289. ccc    IF(JCHAR(LINE(NN)).GT.32)GOTO 3333
  18290. ccc    LINE(NN)=CHAR(0)
  18291. ccc3332    CONTINUE
  18292. ccc3333    CONTINUE
  18293. C SPACE FILL ENTIRE ARRAY
  18294.     DO 3334 N=1,82
  18295. 3334    LINECL(N)=CHAR(32)
  18296.     RETCD=1
  18297. C HANDLE *U DBXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
  18298. C STARTS AFTER THE "DB" SO WE CAN DECODE IT.
  18299. C *U DBCMD (COMMAND) PASSES COMMAND TO DTR FOR ACTION
  18300. C  HOWEVER THIS DOES NOT RETURN A VALUE. USE FOR
  18301. C  SETUP PURPOSES ONLY.
  18302. C
  18303. C NO NEED TO INCLUDE ABILITY TO STORE COMMANDS IN CELLS
  18304. C FOR EDITING SINCE {CELL CONSTRUCT PROVIDES THIS ALREADY.
  18305. C (AND AT COMMAND LEVEL THE __{CELL CONSTRUCT DOES ALSO.)
  18306. 500    CONTINUE
  18307.     CALL SCMP(LINE,'OPINS',5,ICODE)
  18308. C OPEN INPUT SEQUENTIAL
  18309.     IF(ICODE.NE.1)GOTO 3800
  18310. C DTROPINS RANGE FILENAME
  18311.     IBGN=6
  18312.     IVLD=0
  18313.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  18314.     IF(IVLD.EQ.3)GOTO 9990
  18315. C    LINE(LSTCH+25)=CHAR(0)
  18316.     DO 5601 NN=1,50
  18317. 5601    MBUF(NN)=' '
  18318.     DO 5602 NN=1,25
  18319. 5602    MBUF(NN)=LINE(LSTCH+NN-1)
  18320.     OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
  18321.      1  STATUS='OLD',IOSTAT=IVVV,recl=512)
  18322.     IF(IVVV.NE.0)GOTO 9990
  18323.     MFIOPN=1
  18324.     GOTO 9999
  18325. 3800    CONTINUE
  18326.     CALL SCMP(LINE,'OPINRR',6,ICODE)
  18327. C OPEN IN RANDOM READ
  18328.     IF(ICODE.NE.1)GOTO 3900
  18329.     KK=2
  18330.     GOTO 3910
  18331. 3900    CONTINUE
  18332.     CALL SCMP(LINE,'OPINRU',6,ICODE)
  18333. C OPEN IN RANDOM UPDATE
  18334.     IF(ICODE.NE.1)GOTO 3950
  18335.     KK=3
  18336. 3910    CONTINUE
  18337. C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
  18338.  
  18339.     IBGN=7
  18340.     IVLD=0
  18341.     CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
  18342.     IF(IVLD.EQ.3)GOTO 9990
  18343. C    LINE(LSTCH+25)=0
  18344.     DO 5603 NN=1,50
  18345. 5603    MBUF(NN)=' '
  18346.     DO 5604 NN=1,25
  18347. 5604    MBUF(NN)=LINE(LSTCH+NN-1)
  18348. C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
  18349.     OPEN(MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  18350.      1  FORM='UNFORMATTED',RECL=128
  18351.      2  ,STATUS='OLD',IOSTAT=IVVV)
  18352.     IF(IVVV.NE.0)GOTO 9990
  18353.     MFIOPN=KK
  18354.     GOTO 9999
  18355. 3950    CONTINUE
  18356.     CALL SCMP(LINE,'OPOUTS',6,ICODE)
  18357. C OPEN OUTPUT SEQUENTIAL
  18358.     IF(ICODE.NE.1)GOTO 4000
  18359.     IBGN=7
  18360.     IVLD=0
  18361.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  18362.     IF(IVLD.EQ.3)GOTO 9990
  18363.     DO 5605 NN=1,50
  18364. 5605    MBUF(NN)=' '
  18365.     DO 5606 NN=1,25
  18366. 5606    MBUF(NN)=LINE(LSTCH+NN-1)
  18367.     OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
  18368.      1  recl=512,STATUS='NEW',IOSTAT=IVVV)
  18369.     IF(IVVV.NE.0)GOTO 9990
  18370.     MFOOPN=1
  18371.     GOTO 9999
  18372. 4000    CONTINUE
  18373.     CALL SCMP(LINE,'OPOUTR',6,ICODE)
  18374. C OPEN OUTPUT RANDOM
  18375.     IF(ICODE.NE.1)GOTO 4100
  18376.     IBGN=7
  18377.     IVLD=0
  18378.     CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
  18379.     IF(IVLD.EQ.3)GOTO 9990
  18380. C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
  18381. C    LINE(LSTCH+25)=0
  18382.     DO 5607 NN=1,50
  18383. 5607    MBUF(NN)=' '
  18384.     DO 5608 NN=1,25
  18385. 5608    MBUF(NN)=LINE(LSTCH+NN-1)
  18386.     OPEN(MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
  18387.      1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
  18388.      2  IOSTAT=IVVV)
  18389.     IF(IVVV.NE.0)GOTO 9990
  18390.     MFOOPN=2
  18391.     GOTO 9999
  18392. 4100    CONTINUE
  18393.     CALL SCMP(LINE,'CLSOUT',6,ICODE)
  18394. C CLOSE OUTPUT 
  18395.     IF(ICODE.NE.1)GOTO 4200
  18396.     CLOSE(UNIT=MFOLUN)
  18397.     MFOOPN=0
  18398.     GOTO 9999
  18399. 4200    CONTINUE
  18400.     CALL SCMP(LINE,'CLSINP',6,ICODE)
  18401. C CLOSE INPUT 
  18402.     IF(ICODE.NE.1)GOTO 4300
  18403.     CLOSE(UNIT=MFILUN)
  18404.     MFIOPN=0
  18405.     GOTO 9999
  18406. 4300    CONTINUE
  18407.     CALL SCMP(LINE,'ENAOUT',6,ICODE)
  18408. C ENABLE OUTPUT 
  18409.     IF(ICODE.NE.1)GOTO 4400
  18410.     MFOFLG=1
  18411.     GOTO 9999
  18412. 4400    CONTINUE
  18413.     CALL SCMP(LINE,'ENAINP',6,ICODE)
  18414. C ENABLE INPUT 
  18415.     IF(ICODE.NE.1)GOTO 4500
  18416.     MFIFLG=1
  18417.     GOTO 9999
  18418. 4500    CONTINUE
  18419.     CALL SCMP(LINE,'DISINP',6,ICODE)
  18420. C DISABLE INPUT 
  18421.     IF(ICODE.NE.1)GOTO 4510
  18422.     MFIFLG=0
  18423.     GOTO 9999
  18424. 4510    CONTINUE
  18425.     CALL SCMP(LINE,'DISOUT',6,ICODE)
  18426. C DISABLE OUTPUT
  18427.     IF(ICODE.NE.1)GOTO 4520
  18428.     MFOFLG=0
  18429.     GOTO 9999
  18430. 4520    CONTINUE
  18431.     CALL SCMP(LINE,'EDTINP',6,ICODE)
  18432. C ENABLE INPUT FORCE
  18433. C COMMAND
  18434. C DTREDTINP RANGE
  18435. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  18436. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  18437. C IT OUT AGAIN.
  18438.     IF(ICODE.NE.1)GOTO 4600
  18439. C FORCE ENABLE OF READIN DURING THIS
  18440.     MFIFLG=1
  18441.     MFOFLG=1
  18442. C ENABLE OUTPUT TOO.
  18443.     IBGN=7
  18444.     IVLD=0
  18445.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  18446.     IF(IVLD.EQ.3)GOTO 9990
  18447.     DO 4550 N1=IXRL,IXRH
  18448.     DO 4550 N2=IXCL,IXCH
  18449.     CALL REFLEC(N2,N1,IRX)
  18450. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  18451.     CALL FVLDST(N1,N2,Char(255))
  18452.     CALL WRKFIL(IRX,LBUF,0)
  18453.     CALL WRKFIL(IRX,LBUF,1)
  18454. 4550    CONTINUE
  18455.     MFIFLG=0
  18456.     MFOFLG=0
  18457.     GOTO 9999
  18458. 4600    CONTINUE
  18459.     CALL SCMP(LINE,'FMTOUT',6,ICODE)
  18460. C FORMAT/WRITE OUTPUT
  18461. C COMMAND
  18462. C DTRFMTOUT RANGE
  18463. C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
  18464. C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
  18465. C IT OUT AGAIN.
  18466.     IF(ICODE.NE.1)GOTO 4630
  18467.     IVLFG=1
  18468.     GOTO 4740
  18469. 4630    CONTINUE
  18470.     CALL SCMP(LINE,'VALOUT',6,ICODE)
  18471.     IF(ICODE.NE.1)GOTO 4700
  18472. C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
  18473.     IVFLG=2
  18474. C    GOTO 4740
  18475. 4740    CONTINUE
  18476. C FORCE ENABLE OF READIN DURING THIS
  18477.     MFIFLG=1
  18478.     MFOFLG=1
  18479. C ENABLE OUTPUT TOO.
  18480.     IBGN=7
  18481.     IVLD=0
  18482.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  18483.     IF(IVLD.EQ.3)GOTO 9990
  18484.     DO 4650 N1=IXRL,IXRH
  18485.     DO 4650 N2=IXCL,IXCH
  18486. C FIND INDEX FOR WRKFIL
  18487.     CALL REFLEC(N2,N1,IRX)
  18488. C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
  18489.     CALL XVBLGT(N1,N2,TMP)
  18490. C TMP IS REAL*8 SCRATCH
  18491.     CALL FVLDST(N1,N2,Char(255))
  18492.     CALL WRKFIL(IRX,LBUF,0)
  18493. C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
  18494. C NOW GRAB THE VALUE AND SAVE IT...
  18495. C FIRST MOVE THE FORMAT DOWN
  18496. C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
  18497.     DO 4651 N=1,9
  18498.     LBUF(N+1)=LBUF(N+119)
  18499. 4651    CONTINUE
  18500.     LBUF(1)='('
  18501.     LBUF(11)=')'
  18502. c    LBUF(12)=0
  18503. C FORMAT NOW LIVES IN LOW PART OF LBUF
  18504. C D25.17 FORMAT WOULD DO FOR WRITE
  18505. C NEED CHAR VBL FOR FORMAT EQUIV'D TO LOW 12 CHARS OF LBUF
  18506. c    IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF(1:11),ERR=4652)TMP
  18507.     IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF,ERR=4652)TMP
  18508.     IF(IVLFG.EQ.2)WRITE(LINEC(1:62),4658,ERR=4652)TMP
  18509. 4658    FORMAT(D25.17)
  18510. C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
  18511. C USE DISPLAY FORMAT.
  18512. 4652    CONTINUE
  18513.     KK=1
  18514.     DO 4653 N=1,110
  18515. 4653    LBUF(N)=CHAR(0)
  18516.     DO 4654 N=1,60
  18517. C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
  18518.     KKK=JCHAR(LINECL(N))
  18519.     IF(KKK.LE.32)GOTO 4654
  18520.     LBUF(KK)=LINECL(N)
  18521.     KK=KK+1
  18522. 4654    CONTINUE
  18523.     CALL WRKFIL(IRX,LBUF,1)
  18524. 4650    CONTINUE
  18525.     MFIFLG=0
  18526.     MFOFLG=0
  18527.     GOTO 9999
  18528. 4700    CONTINUE
  18529.     CALL SCMP(LINE,'CMPFRM',6,ICODE)
  18530.     IF(ICODE.NE.1)GOTO 4800
  18531. C DBCMPFRM V1:V2
  18532. C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
  18533.     IBGN=7
  18534.     IVLD=0
  18535.     LSTCH=78
  18536. C USE GMTX TO GET CELL ADDRESSES.
  18537.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  18538.     IF(IVLD.EQ.3)GOTO 9990
  18539. C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
  18540.     CALL REFLEC(IXCL,IXRL,IRXL)
  18541.     CALL REFLEC(IXCH,IXRH,IRXH)
  18542.     IF(LINE(LSTCH).NE.',')GOTO 4780
  18543.     IBGN=LSTCH+1
  18544.     IVLD=0
  18545.     CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
  18546.     IF(IVLD.EQ.3)GOTO 4780
  18547. C GET THE LENGTHS NOW
  18548.     CALL XVBLGT(IYRL,IYCL,TMP)
  18549.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  18550.     LBUFL=TMP
  18551.     CALL XVBLGT(IYRH,IYCH,TMP)
  18552.     IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
  18553.     MBUFL=TMP
  18554. C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
  18555. C COMPARISONS BASED ON THAT.
  18556.     GOTO 4770
  18557. 4780    CONTINUE
  18558. C GET INDEX OF EACH ELEMENT...
  18559.     CALL WRKFIL(IRXL,LBUF,0)
  18560.     CALL WRKFIL(IRXH,MBUF,0)
  18561. C LOAD THE 2 FORMULAS.
  18562. C NOW FIND THE ENDS...
  18563.     DO 4750 N=1,110
  18564.     NN=111-N
  18565.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
  18566. 4750    CONTINUE
  18567. 4751    LBUFL=NN
  18568.     DO 4760 N=1,110
  18569.     NN=111-N
  18570.     IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
  18571. 4760    CONTINUE
  18572. 4761    MBUFL=NN
  18573. 4770    CONTINUE
  18574. c find index pos'n by hand...
  18575.     KK=LBUFL-MBUFL+1
  18576.     DO 4776 NN=1,KK
  18577.     IF(LBUF(NN).NE.MBUF(1))GOTO 4776
  18578.     NNN=MBUFL-1
  18579.     DO 4777 N=1,NNN
  18580.     IVVV=NN+N
  18581.     IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
  18582. 4777    CONTINUE
  18583. C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
  18584. C SINCE NN IS WHAT WE NEED, GO USE IT.
  18585.     GOTO 4779
  18586. 4778    CONTINUE
  18587. 4776    CONTINUE
  18588. C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
  18589. C
  18590.     NN=0
  18591. 4779    CONTINUE
  18592. C NN IS LOCATION OF SUBSTRING NOW
  18593. C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
  18594.     XAC=NN
  18595. C RETURN RESULT IN % ACCUMULATOR.
  18596.     WAC=0.
  18597.     IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
  18598.     IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
  18599. C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
  18600. C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
  18601. C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
  18602.     GOTO 9999
  18603. 4800    CONTINUE
  18604.     CALL SCMP(LINE,'LENFRM',6,ICODE)
  18605.     IF(ICODE.NE.1)GOTO 4900
  18606. C DBLENFRM V1:V2
  18607. C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
  18608.     IBGN=7
  18609.     IVLD=0
  18610. C USE GMTX TO GET CELL ADDRESSES.
  18611.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  18612.     IF(IVLD.EQ.3)GOTO 9990
  18613.     CALL REFLEC(IXCL,IXRL,IRXL)
  18614. C GET INDEX OF EACH ELEMENT...
  18615.     CALL WRKFIL(IRXL,LBUF,0)
  18616. C LOAD THE FORMULA.
  18617. C NOW FIND THE END...
  18618.     DO 4850 N=1,110
  18619.     NN=111-N
  18620.     IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
  18621. 4850    CONTINUE
  18622. 4851    LBUFL=NN
  18623.     TMP=LBUFL
  18624.     XAC=TMP
  18625. C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
  18626.     NN=0
  18627. C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
  18628.     CALL FVLDGT(IXRH,IXCH,NN)
  18629.     IF(NN.EQ.0)GOTO 9999
  18630.     CALL XVBLST(IXRH,IXCH,TMP)
  18631.     GOTO 9999
  18632. 4900    CONTINUE
  18633.     CALL SCMP(LINE,'TRMFRM',6,ICODE)
  18634.     IF(ICODE.NE.1)GOTO 5000
  18635. C TRIM FORMULA
  18636. C DTRTRMFRM INCELL:OUTCELL,START:END
  18637. C RETURNS TRIMMED FORMULA TO CELL.
  18638.     IBGN=7
  18639.     IVLD=0
  18640. C USE GMTX TO GET CELL ADDRESSES.
  18641.     CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
  18642.     IF(IVLD.EQ.3)GOTO 9990
  18643. C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
  18644.     CALL REFLEC(IXCL,IXRL,IRXL)
  18645. C GET INDEX OF EACH ELEMENT...
  18646.     CALL REFLEC(IXCH,IXRH,IRXH)
  18647.     CALL WRKFIL(IRXL,LBUF,0)
  18648.     LO=LSTCHR+1
  18649.     LHI=LSTCHR+21
  18650.     LSTCHR=LHI
  18651.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  18652.     IF(IVLD.EQ.0)GOTO 9990
  18653.     CALL XVBLGT(JD1,JD2,TMP)
  18654.     LOCHR=1
  18655.     IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
  18656. C LOCHR = START CHAR
  18657.     LO=LSTCHR+1
  18658.     LHI=LSTCHR+21
  18659.     LSTCHR=LHI
  18660.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  18661.     IF(IVLD.EQ.0)GOTO 9990
  18662.     CALL XVBLGT(JD1,JD2,TMP)
  18663.     LHICHR=110
  18664.     IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
  18665. C LHICHR IS END CHARACTER
  18666. C NOW ALL ARGS ARE COLLECTED.
  18667. C (IGNORE WHAT WAS DELIMITER...)
  18668. C COPY DESIRED STUFF TO MBUF
  18669.     N=1
  18670.     DO 4910 NN=1,110
  18671.     MBUF(NN)=CHAR(0)
  18672.     IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
  18673.     MBUF(N)=LBUF(NN)
  18674.     N=N+1
  18675. C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
  18676. 4910    CONTINUE
  18677.     DO 4911 NN=111,128
  18678. 4911    MBUF(NN)=LBUF(NN)
  18679.     CALL WRKFIL(IRXH,MBUF,1)
  18680. C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
  18681. C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
  18682.     GOTO 9999
  18683. 5000    CONTINUE
  18684.     GOTO 9999
  18685. 9990    RETCD=3
  18686. C ERROR RETURN
  18687. 9999    RETURN
  18688.     END
  18689. c -h- fft.ftn    Fri Aug 22 13:08:56 1986    
  18690. C  
  18691. C-----------------------------------------------------------------------
  18692. C SUBROUTINE: FOUREA
  18693. C PERFORMS COOLEY-TUKEY FAST FOURIER TRANSFORM
  18694. C-----------------------------------------------------------------------
  18695. C  
  18696.       SUBROUTINE FOUREA(ID1,ID2,IC,IR,IVN,ISI)
  18697. C ID1,ID2 = COORDS OF FIRST CELL. IC AND IR ARE 0, OR 1
  18698. C ONLY ONE OF IC, IR MAY BE NONZERO. (FLAGS HORIZ/VERTICAL
  18699. C DATA AREA)
  18700. C  
  18701. C THE COOLEY-TUKEY FAST FOURIER TRANSFORM IN ANSI FORTRAN
  18702. C  
  18703. C DATA IS A ONE-DIMENSIONAL COMPLEX ARRAY WHOSE LENGTH, N, IS A
  18704. C POWER OF TWO.  ISI IS +1 FOR AN INVERSE TRANSFORM AND -1 FOR A
  18705. C FORWARD TRANSFORM.  TRANSFORM VALUES ARE RETURNED IN THE INPUT
  18706. C ARRAY, REPLACING THE INPUT.
  18707. C TRANSFORM(J)=SUM(DATA(I)*W**((I-1)*(J-1))), WHERE I AND J RUN
  18708. C FROM 1 TO N AND W = EXP (ISI*2*PI*SQRT(-1)/N).  PROGRAM ALSO
  18709. C COMPUTES INVERSE TRANSFORM, FOR WHICH THE DEFINING EXPRESSION
  18710. C IS INVTR(J)=(1/N)*SUM(DATA(I)*W**((I-1)*(J-1))).
  18711. C RUNNING TIME IS PROPORTIONAL TO N*LOG2(N), RATHER THAN TO THE
  18712. C CLASSICAL N**2.
  18713. C AFTER PROGRAM BY BRENNER, JUNE 1967. THIS IS A VERY SHORT VERSION
  18714. C OF THE FFT AND IS INTENDED MAINLY FOR DEMONSTRATION. PROGRAMS
  18715. C ARE AVAILABLE IN THIS COLLECTION WHICH RUN FASTER AND ARE NOT
  18716. C RESTRICTED TO POWERS OF 2 OR TO ONE-DIMENSIONAL ARRAYS.
  18717. C SEE -- IEEE TRANS AUDIO (JUNE 1967), SPECIAL ISSUE ON FFT.
  18718. C  
  18719. C ASSUMES THAT FIRST N/2 ELEMENTS ARE REAL, SECOND COMPLEX...
  18720. C STORES DATA THAT WAY ALSO...
  18721. C
  18722. C      COMPLEX DATA(1)
  18723. C      COMPLEX TEMP, W
  18724. C MAKE THIS A REAL FFT, NOT COMPLEX...
  18725.     REAL*8 DATA(1),TEMP,W,TEMP2,TEMPI,WI
  18726.     InTeGer*4 ID1,ID2,IC,IR,IVN,N
  18727. C SET UP STMT FUNCTIONS...
  18728.     ID1F(K)=ID1+IC*(K-1)
  18729.     ID2F(K)=ID2+IR*(K-1)
  18730.     N=IVN
  18731. C  
  18732. C CHECK FOR POWER OF TWO UP TO 14
  18733. C  
  18734. C INITIALLY SAY ALL OK
  18735.       NN = 1
  18736.       DO 10 I=1,14
  18737.         M = I
  18738.         NN = NN*2
  18739.         IF (NN.EQ.N) GO TO 20
  18740.     IF(NN.GT.N)GOTO 11
  18741.   10  CONTINUE
  18742. 11    CONTINUE
  18743.     N=NN/2
  18744. C USE NEXT SMALLER POWER OF 2 ARRAY...
  18745. C    RETURN
  18746. C HERE BEGINNETH ACTUAL WORK.
  18747. C SET UP DATA COORDS ON THE FLY. NORMALLY I,J RUN IN RANGE 1 TO N
  18748. C SO WHERE K=(I OR J) (I.E., ONE OF THE TWO) WE USE A RELATION
  18749. C ID1V=ID1+IC*(K-1) AND ID2V=ID2+IR*(K-1). WE USE STMT FUNCTIONS
  18750. C ID1F AND ID2F FOR THIS.
  18751.   20  CONTINUE
  18752.     NOV2=N/2
  18753. C  
  18754. C      PI = 4.*ATAN(1.)
  18755.     PI=3.14159265358979323846264
  18756.       FN = NOV2
  18757. C  
  18758. C THIS SECTION PUTS DATA IN BIT-REVERSED ORDER
  18759. C  
  18760.       J = 1
  18761.       DO 80 I=1,NOV2
  18762. C  
  18763. C AT THIS POINT, I AND J ARE A BIT REVERSED PAIR (EXCEPT FOR THE
  18764. C DISPLACEMENT OF +1)
  18765. C  
  18766.     IF(I.GE.J)GOTO 40
  18767. C  
  18768. C EXCHANGE DATA(I) WITH DATA(J) IF I.LT.J.
  18769. C  
  18770.  30    CONTINUE
  18771. C EXCHANGE DATA(J), DATA(I)
  18772.     CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
  18773.     CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
  18774.     CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
  18775.     CALL XVBLST(ID1F(I),ID2F(I),TEMP)
  18776. C FLIP BOTH REAL AND COMPLEX PARTS OF DATA
  18777.     CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMP)
  18778.     CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
  18779.     CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
  18780.     CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP)
  18781. C  30    TEMP = DATA(J)
  18782. C        DATA(J) = DATA(I)
  18783. C        DATA(I) = TEMP
  18784. C  
  18785. C IMPLEMENT J=J+1, BIT-REVERSED COUNTER
  18786. C  
  18787.   40    M = NOV2/2
  18788.   50    IF (J.LE.M) GOTO 70
  18789.   60    J = J - M
  18790.         M = (M+1)/2
  18791.         GO TO 50
  18792.   70    J = J + M
  18793.   80  CONTINUE
  18794. C  
  18795. C NOW COMPUTE THE BUTTERFLIES
  18796. C  
  18797.       MMAX = 1
  18798.   90  IF (MMAX.GE.NOV2)GOTO 130
  18799.  100  ISTEP = 2*MMAX
  18800.       DO 120 M=1,MMAX
  18801.         THETA = PI*FLOAT(ISI*(M-1))/FLOAT(MMAX)
  18802.      W = COS(THETA)
  18803.         WI = SIN(THETA)
  18804. C        W = CMPLX(COS(THETA),SIN(THETA))
  18805.         DO 110 I=M,NOV2,ISTEP
  18806.           J = I + MMAX
  18807. C GET REAL AND IMAG HALVES OF NUMBER...
  18808.       CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
  18809.       CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMPI)
  18810. C DO COMPLEX MULTIPLICATION BY HAND TO AVOID LARGE RUNTIME SYSTEM
  18811. C ROUTINE INCLUSION.
  18812.       TEMP2=W*TEMP-WI*TEMPI
  18813.       TEMPI=WI*TEMP+W*TEMPI
  18814.     TEMP=TEMP2
  18815. C          TEMP = W*DATA(J)
  18816. C          DATA(J) = DATA(I) - TEMP
  18817. C          DATA(I) = DATA(I) + TEMP
  18818.        CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
  18819.        TEMP2=DATA(1)+TEMP
  18820.        DATA(1)=DATA(1) - TEMP
  18821.        CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
  18822.        CALL XVBLST(ID1F(I),ID2F(I),TEMP2)
  18823. C COMPLEX PART
  18824.        CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
  18825.        TEMP2=DATA(1)+TEMPI
  18826.        DATA(1)=DATA(1) - TEMPI
  18827.        CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
  18828.        CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP2)
  18829.  110    CONTINUE
  18830.  120  CONTINUE
  18831.       MMAX = ISTEP
  18832.       GO TO 90
  18833.   130  IF (ISI.LT.0) GOTO 160
  18834. C  
  18835. C FOR INV TRANS -- ISI=1 -- MULTIPLY OUTPUT BY 1/N
  18836. C  
  18837.  140  DO 150 I=1,N
  18838. C        DATA(I) = DATA(I)/FN
  18839.     CALL XVBLGT(ID1F(I),ID2F(I),TEMP)
  18840.     TEMP=TEMP/FN
  18841.     CALL XVBLST(ID1F(I),ID2F(I),TEMP)
  18842.  150  CONTINUE
  18843.  160  RETURN
  18844.       END
  18845. c -h- help.for    Fri Aug 22 13:20:10 1986    
  18846.     SUBROUTINE HELP(LVL)
  18847. C PRINT HELP INFO ON SCREEN USING FIRST 22 LINES. ASSUME XQTCMD INVALIDATES
  18848. C THE DISPLAY.
  18849. C COPYRIGHT (C) 1983 GLENN AND MARY EVERHART
  18850.     CHARACTER*1 FORM(128)
  18851.     CALL UVT100(18,0,0)
  18852.     CALL UVT100(11,2,0)
  18853.     CALL UVT100(1,1,1)
  18854. C COPYRIGHT (C) 1983 GLENN and MARY EVERHART
  18855. C All Rights Reserved
  18856. C
  18857. C NEW PC HELP FILE
  18858. C DESIGNED TO BE SMALLER THAN OLD VERSION. READS FILES OFF DISK
  18859. C BY SKIPPING N*24 LINES AND DISPLAYING 24 LINES, WHERE N=LVL
  18860. C ASSUME HELP FILE ON DISK LOGGED CURRENTLY
  18861.     CLOSE(3)
  18862. c for now, assume help file lives on same disk as our default.
  18863.     IXXX=0
  18864.     OPEN(3,FILE='PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
  18865.      1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
  18866. C try on dk: if we can't find it in default.
  18867.     If(IXXX.LE.0)goto 2772
  18868.     Close(3)
  18869.     OPEN(3,FILE='DK:PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
  18870.      1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
  18871.     IF(IXXX.GT.0)RETURN
  18872. 2772    Continue
  18873. C RETURN IF HELP FILE IS MISSING...
  18874. C USE A FIXED HELP FILE FOR MULTISCREEN HELP. LOWER OVERHEAD,...
  18875.     NSKP=LVL*24
  18876. C NOW READ IN THE DATA, WRITE TO SCREEN.
  18877.     KKL=NSKP+1
  18878.     KKH=NSKP+23
  18879. C JUST GO DIRECTLY TO THE DESIRED SCREENFUL OF INFO.
  18880.     DO 7640 KKK=KKL,KKH
  18881.     READ(3,REC=KKK,ERR=7642)FORM
  18882. c use fortran writes here normally since we want the crlf stuff they imply
  18883. c always write 24 lines to scroll all else off...
  18884.     IVVV=78
  18885. C FIND END OF LINE AND ONLY EMIT CHARACTERS TO THAT; DON'T WASTE
  18886. C TIME DRAWING SPACES ON THE SCREEN.
  18887.     DO 772 IV=1,78
  18888.     IVVV=79-IV
  18889.     IF(ICHAR(FORM(IVVV)).GT.32)GOTO 773
  18890. 772    CONTINUE
  18891. 773    CONTINUE
  18892. c for curses must only emit LF since CR erases the text. Here emit
  18893. c both.
  18894.     FORM(IVVV+1)=Char(13)
  18895.     FORM(IVVV+2)=Char(10)
  18896.     IVVV=IVVV+2
  18897.     CALL SWRT(FORM,IVVV)
  18898. C    WRITE(11,7643)(FORM(IV),IV=1,IVVV)
  18899. C NOTE WE HAVE LUN 6 OPENED AS CON: IN THE MAIN PROGRAM TO GIVE AN
  18900. C INDEPENDENT TERMINAL OUTPUT CHANNEL. HOPEFULLY THIS PREVENTS SOME
  18901. C SCREWUPS DUE TO USING LUN 0 FOR BOTH CONSOLE INPUT AND OUTPUT; END OF
  18902. C RECORDS OUGHT TO BE INDEPENDENT THIS WAY (I HOPE).
  18903. C7643    FORMAT(1X,82A1,4A1)
  18904. 7640    CONTINUE
  18905. 7642    CONTINUE
  18906.     CLOSE(3)
  18907. c don't do this in unix vers since CR screws up output
  18908. c (curses assumes it means erase line)
  18909.     FORM(1)=char(13)
  18910.     CALL SWRT(FORM,1)
  18911.     RETURN
  18912.     END
  18913. c -h- linfit.for    Fri Aug 22 13:23:55 1986    
  18914. C LINE FITTING SUBROUTINE WITH ERROR MEASURE RETURN ALSO.
  18915.     SUBROUTINE LINFIT(ID1X,ID2X,IRCOL,ID1,ID2,N,A,B,DEL,RR)
  18916.     InTeGer*4 ID1X,ID2X,IRCOL,ID1,ID2,N
  18917.     REAL*8 A,B,DEL,XY,SX2,SX,SY,RR
  18918.     InTeGer*4 IC,IR,KK,KKK,I
  18919.     REAL*8 XI,YI,SY2,EN,WRK
  18920. C FIT LINE TO EQUALLY SPACED POINTS...
  18921. C Y=BX+A
  18922.     SY2=0.
  18923.     EN=N
  18924.     XY=0.
  18925.     SX2=0.
  18926.     SX=0.
  18927.     SY=0.
  18928.     IC=IRCOL
  18929.     IR=1-IRCOL
  18930. C IRCOL IS 0 OR 1 FOR ACROSS OR DOWN
  18931.     DO 10 I=1,N
  18932. C IF ID1X < 0 THEN FORM IT HERE AS ID1+I-1
  18933.     IF (ID1X.GT.0)GOTO 20
  18934. C FORM XI
  18935.     XI=I
  18936.     GOTO 30
  18937. 20    CONTINUE
  18938. C INPUT XI
  18939.     KK=ID1X+IC*(I-1)
  18940.     KKK=ID2X+IR*(I-1)
  18941.     CALL XVBLGT(KK,KKK,XI)
  18942. 30    CONTINUE
  18943. C GET YI IN ANY CASE...
  18944.     KK=ID1+IC*(I-1)
  18945.     KKK=ID2+IR*(I-1)
  18946.     CALL XVBLGT(KK,KKK,YI)
  18947.     XY=XY+XI*YI
  18948. C FORM SUMS NEEDED TO FIT LINE...
  18949.     SX2=SX2+XI*XI
  18950.     SX=SX+XI
  18951.     SY=SY+YI
  18952.     SY2=SY2+YI*YI
  18953. 10    CONTINUE
  18954. C NOW GET SLOPE
  18955.     WRK=((XY-(SX*SY)/EN)/(SX2-(SX*SX)/EN))
  18956.     B=WRK
  18957. C THEN INTERCEPT
  18958.     WRK=(SY/EN)-B*(SX/EN)
  18959.     A=WRK
  18960.     WRK=DSQRT((SY2-(A*SY+B*XY))/EN)
  18961.     DEL=WRK
  18962. C DEL = ERROR OF FIT
  18963.     RR=(EN*XY-SX*SY)/DSQRT((EN*SX2-SX*SX)*(EN*SY2-SY*SY))
  18964. C RR IS CORRELATION COEFFICIENT
  18965.     RETURN
  18966.     END
  18967. c -h- list.for    Fri Aug 22 13:24:14 1986    
  18968.     SUBROUTINE LIST
  18969. C COPYRIGHT (C) 1983 GLENN EVERHART
  18970. C ALL RIGHTS RESERVED
  18971. C 60=MAX REAL ROWS
  18972. C 301=MAX REAL COLS
  18973. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  18974. C VBLS AND TYPE DIMENSIONED 60,301
  18975. C **************************************************
  18976. C *                                                *
  18977. C *              SUBROUTINE  LIST                  *
  18978. C *                                                *
  18979. C **************************************************
  18980. C
  18981. C
  18982. C LISTS THE LEGAL CALC COMMANDS AND GIVES A BRIEF
  18983. C DESCRIPTION OF THEIR FUNCTION.
  18984. C
  18985. C LIST IS CALLED BY CALC
  18986. C
  18987. C    SUBROUTINE LIST
  18988. C
  18989. C
  18990. C NOTE WE USE FORTRAN WRITE HERE SINCE IT SHOULD ONLY HAPPEN IN CALC MODE.
  18991. c    rewind 11
  18992. c    WRITE (11,20)
  18993. c    WRITE (11,30)
  18994. c    rewind 11
  18995.     Call vwrt(char(13)//char(10),2)
  18996.     Call vwrt(
  18997.      1  'Cmds= @file-do file;*C-Comment;*E-exit;*R-Read con',50)
  18998.     Call vwrt(char(13)//char(10),2)
  18999.     Call Vwrt(
  19000.      1  '*S-stop;*V n(bet.0,3)-View Ctl - Higher=see more',48)
  19001.     RETURN
  19002. c20    FORMAT (' CMDS= @FILE-DO FILE;*C-COMMENT;*E-EXIT;*R-READ CON')
  19003. c30    FORMAT (' *S-STOP;*V n(bet.0,3)-VIEW CTL- HIGHER=SEE MORE')
  19004.     END
  19005. c -h- wsset.f40    Fri Aug 22 13:43:11 1986    
  19006.         SUBROUTINE WSSET
  19007. C WORK SHEET MANAGMENT ROUTINES
  19008. C HANDLE SPREADSHEET "IN MEMORY" STORAGE
  19009. C COPYRIGHT (C) GLENN AND MARY EVERHART 1983,1984
  19010. C
  19011. C ALL RIGHTS RESERVED
  19012. C
  19013. C WSSET - INITIALIZE STORAGE TO START CONDITIONS
  19014. C EXPECT IMPLEMENTATION TO USE A COMMON BITMAP AND PROVIDE A VARIABLE
  19015. C NCEL TO TELL HOW MANY CELLS ARE IN USE
  19016. C NEXT BITMAPS IMPLEMENT FVLD
  19017.     Include aparms.inc
  19018.         CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
  19019.     CHARACTER*1 FVXX(IMPS3)
  19020.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(IMP2S))
  19021.     EQUIVALENCE (FV4(1),FVXX(IMP3S))
  19022.         Common/FVLDM/FVXX
  19023. c        COMMON/FVLDM/FV1,FV2,FV4
  19024. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  19025. C TYPES OF AC'S STORAGE:
  19026.         CHARACTER*1 ITYP(IMP1S)
  19027.         InTeGer*4 IATYP(27),LINTGR
  19028.         COMMON/TYP/IATYP,ITYP,LINTGR
  19029.         CHARACTER*1 LBITS(8)
  19030.         COMMON/BITS/LBITS
  19031. C ***<<<< RDD COMMON START >>>***
  19032.     InTeGer*4 RRWACT,RCLACT
  19033. C    COMMON/RCLACT/RRWACT,RCLACT
  19034.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  19035.      1  IDOL7,IDOL8
  19036. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  19037. C     1  IDOL7,IDOL8
  19038.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19039. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  19040.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19041. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19042. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  19043. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  19044.     InTeGer*4 KLVL
  19045. C    COMMON/KLVL/KLVL
  19046.     InTeGer*4 IOLVL,IGOLD
  19047. C    COMMON/IOLVL/IOLVL
  19048. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  19049. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  19050.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19051.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19052.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  19053.      3  k3dfg,kcdelt,krdelt,kpag
  19054. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19055. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19056. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  19057. C ***<<< RDD COMMON END >>>***
  19058. CCC        InTeGer*4 IPGMAX,LPGMXF
  19059. CCC        COMMON/FILEMX/IPGMAX,LPGMXF
  19060. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  19061. C USE LUN 7 FOR FORMULAS, 9 FOR VALUES FILE IF NEEDED...
  19062. C
  19063. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  19064. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  19065. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  19066. C AREAS WITH DATA.
  19067. C ***<<< KLSTO COMMON START >>>***
  19068.     InTeGer*4 DLFG
  19069. C    COMMON/DLFG/DLFG
  19070.     InTeGer*4 KDRW,KDCL
  19071. C    COMMON/DOT/KDRW,KDCL
  19072.     InTeGer*4 DTRENA
  19073. C    COMMON/DTRCMN/DTRENA
  19074.     REAL*8 EP,PV,FV
  19075.     DIMENSION EP(20)
  19076.     INTEGER*4 KIRR
  19077. C    COMMON/ERNPER/EP,PV,FV,KIRR
  19078.     InTeGer*4 LASTOP
  19079. C    COMMON/ERROR/LASTOP
  19080.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  19081. C    COMMON/FMTBFR/FMTDAT
  19082.     CHARACTER*1 EDNAM(16)
  19083. C    COMMON/EDNAM/EDNAM
  19084.     InTeGer*4 MFID(2),MFMOD(2)
  19085. C    COMMON/FRM/MFID,MFMOD
  19086.     InTeGer*4 JMVFG,JMVOLD
  19087. C    COMMON/FUBAR/JMVFG,JMVOLD
  19088.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  19089.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  19090. C ***<<< KLSTO COMMON END >>>***
  19091. CCC        CHARACTER*1 FMTDAT(9,Ifmtbk)
  19092. CCC        COMMON/FMTBFR/FMTDAT
  19093.         CHARACTER*1 DVF(12),DFMT(10)
  19094.         EQUIVALENCE(DVF(2),DFMT(1))
  19095.         COMMON/DEFVBX/DVF
  19096. CCC    InTeGer*4 DLFG
  19097. CCC    COMMON/DLFG/DLFG
  19098. C DLFG IS NONZERO IF ANY D## FORMS HAVE BEEN SEEN
  19099.         InTeGer*4 MPAG(2),MPMOD
  19100.         InTeGer*2 LVALBF(5,MVal)
  19101.     DIMENSION MPMOD(2)
  19102.         COMMON/VB/MPAG,LVALBF,MPMOD
  19103.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  19104.     COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
  19105. CCC    InTeGer*4 MFID(2)
  19106. C        InTeGer*4 MFID,IFID(8,MFrm)
  19107. C        CHARACTER*1 LFID(16,MFrm)
  19108. C        EQUIVALENCE(IFID(1,1),LFID(1,1))
  19109. CCC        COMMON/FRM/MFID,MFMOD
  19110. C        COMMON/FRM/MFID,IFID
  19111. C
  19112. C ***<<< NULETC COMMON START >>>***
  19113.     InTeGer*4 ICREF,IRREF
  19114. C    COMMON/MIRROR/ICREF,IRREF
  19115.     InTeGer*4 MODPUB,LIMODE
  19116. C    COMMON/MODPUB/MODPUB,LIMODE
  19117.     InTeGer*4 KLKC,KLKR
  19118.     REAL*8 AACP,AACQ
  19119. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  19120.     InTeGer*4 NCEL,NXINI
  19121. C    COMMON/NCEL/NCEL,NXINI
  19122.     CHARACTER*1 NAMARY(20,MRows)
  19123. C    COMMON/NMNMNM/NAMARY
  19124.     InTeGer*4 NULAST,LFVD
  19125. C    COMMON/NULXXX/NULAST,LFVD
  19126.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  19127.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  19128. C ***<<< NULETC COMMON END >>>***
  19129. CCC        COMMON /NCEL/NCEL,NXINI
  19130.     LINTGR=0
  19131.     MPMOD(1)=0
  19132.     MPMOD(2)=0
  19133.     MFMOD(1)=0
  19134.     MFMOD(2)=0
  19135.     DLFG=0
  19136.         IBP=1
  19137. C INITIALIZE ADDRESSES FOR FVLDSG/FVLDGT
  19138. C    CALL FVGO(FV1,LBITS)
  19139.         DO 2 N=1,9
  19140. 2       FMTDAT(N,1)=DFMT(N)
  19141.         DO 3 N=2,IFmtbk
  19142.         DO 3 NN=1,9
  19143. 3       FMTDAT(NN,N)=CHAR(0)
  19144.         DO 1 N=1,8
  19145.     NN=128/IBP
  19146.         LBITS(N)=CHAR(NN)
  19147. 1       IBP=IBP+IBP
  19148.         DO 4 N=1,IMP1S
  19149. C CLEAR BITMAPS NOW
  19150.         FV1(N)=CHAR(0)
  19151.         FV2(N)=CHAR(0)
  19152.         FV4(N)=CHAR(0)
  19153. 4       ITYP(N)=CHAR(0)
  19154. C OPEN THE WORK FILES SO WE DON'T NEED TO LATER...
  19155. C LUN 7 IS FORMULAS; LUN 9 IS VALUES
  19156. C HOWEVER, IF IPGMAX IS LESS THAN 800/205 (INDICATING ENTIRE FILE
  19157. C FITS IN MEMORY) DON'T OPEN LUN 9 AND IF LPGMXF IS < 2048/64, LIKEWISE
  19158. C FOR LUN 7.
  19159. C INITIALLY CLOSE FILES IN CASE THEY WERE OPEN...
  19160.         CLOSE(7,STATUS='DELETE')
  19161.         CLOSE(13,STATUS='DELETE')
  19162. C NOW OPEN THEM AS RANDOM ACCESS FILES.
  19163.         NBK=IPGMAX*2
  19164. C KEEP VALUE PAGES IN 500 BYTE UNITS, NOT 512 BYTE UNITS, TO COME
  19165. C OUT EVEN...
  19166.         IF(IPGMAX.GT.(MVal/100))OPEN(13,
  19167.      1  ACCESS='DIRECT',FORM='UNFORMATTED',
  19168.      3  RECL=500,STATUS='NEW')
  19169.         NBK=LPGMXF*2
  19170.         IF(LPGMXF.GT.(MFro64))OPEN(7,
  19171.      1  ACCESS='DIRECT',FORM='UNFORMATTED',
  19172.      3  RECL=512,STATUS='NEW')
  19173. C SET NOTHING IN MEMORY YET
  19174.         MFID(1)=0
  19175.     MFID(2)=0
  19176.         MPAG(1)=0
  19177.     MPAG(2)=0
  19178. C MARK BUFFER 1 AS IN MEMORY AND AS LAST-ACCESSED (SO WE FIRST ATTEMPT TO
  19179. C OVERWRITE BUFFER 2 TO GET STARTED.)
  19180.     MFLAST=1
  19181.     MFBASE=0
  19182.     MVLAST=1
  19183.     MVBASE=0
  19184. C ZERO MEMORY BUFFER AND FILES
  19185. C ACTUALLY MARK WITH -1 SO THAT WE CAN TELL WHEN WE HIT A VIRGIN
  19186. C AREA.
  19187.     KKKKK=-1
  19188.     if(mvalx10.ge.mrcx8)kkkkk=0
  19189. c    if(mval*10.ge.mrc*8)kkkkk=0
  19190.         DO 9 N=1,MVal
  19191.         DO 9 M=1,5
  19192. 9       LVALBF(M,N)=KKKKK
  19193.         NPG=(IPGMAX*2)
  19194.         IF(IPGMAX.LE.(MVal/100))GOTO 11
  19195.         DO 10 N=1,NPG
  19196. 10      WRITE(13,REC=N,ERR=11)((LVALBF(K,KKK),K=1,5),KKK=1,50)
  19197. 11      CONTINUE
  19198.     CALL WRKFIL(0,0,50)
  19199. C        DO 12 N=1,2048
  19200. C        DO 12 M=1,8
  19201. C12      IFID(M,N)=0
  19202. C     NPG=LPGMXF*2
  19203. C        IF(LPGMXF.LE.(2048/64))GOTO 14
  19204. C        DO 13 N=1,NPG
  19205. C13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
  19206. 14      CONTINUE
  19207. C SET ALL AC'S TO TYPE FLOATING...
  19208.         DO 8 N=1,27
  19209. 8       IATYP(N)=2
  19210. C TYPE 2 IS REALS (DEFAULT)
  19211.         NCEL=0
  19212.     NXINI=0
  19213.         RETURN
  19214.         END
  19215. c -h- wtbini.f40    Fri Aug 22 13:43:29 1986    
  19216. C WORK FORMULA TABLE INITIALIZE FOR DTBL1 COMMON
  19217. C COPYRIGHT (C) GLENN AND MARY EVERHART 1985
  19218. C ALL RIGHTS RESERVED
  19219.     SUBROUTINE WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,
  19220.      1  BTBL6,BTBL7,BTBL8)
  19221.     Include aparms.inc
  19222.     CHARACTER*1 DTBL1(9,9,8)
  19223. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  19224.     Integer*4 LPGMXF
  19225. C    InTeGer*2 BTBL(6,6,8)
  19226. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  19227. C NO NEED TO WASTE IT.
  19228.     InTeGer*2 IFID(8,MFrm)
  19229. C    CHARACTER*1 LFID(16,MFrm)
  19230. C    EQUIVALENCE(LFID(1,1),IFID(1,1))
  19231. C    EQUIVALENCE(IFID(1,1),BTBL(1,1,1))
  19232.     InTeGer*2 BTBL1(6,6)
  19233.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  19234.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  19235. C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  19236. C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  19237. C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  19238. C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  19239.     COMMON /DECIDE/ DTBL1
  19240. C ZERO THE FILE NOW
  19241.     NPG=LPGMXF*2
  19242.         IF(LPGMXF.LE.(MFro64))GOTO 14
  19243.         DO 13 N=1,NPG
  19244. 13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
  19245. 14      CONTINUE
  19246.     RETURN
  19247.     END
  19248. c -h- wkdy.for    Fri Aug 22 13:44:33 1986    
  19249.     SUBROUTINE WKDY(JULLO,JULHI,NDAYS)
  19250. C GIVEN START AND END JULIAN DATE, FIGURE OUT HOW MANY WEEK DAYS
  19251. C THERE ARE BETWEEN THEM.
  19252.     JL=JULLO
  19253.     JH=JULHI
  19254.     IF(JL.LE.JH)GOTO 10
  19255.     JL=JULHI
  19256.     JH=JULLO
  19257. 10    CONTINUE
  19258.     IDL=(JH-JL)/7
  19259. C GET NUMBER OF WEEKS BETWEEN DAYS, 5 WORKDAYS PER WHOLE WEEK.
  19260.     IWDY=IDL*5
  19261. C ADD 3 SO THAT MODULO OF SUNDAY IS 0, NOT WED.
  19262.     IDOR=JH-JL-7*(IDL)
  19263.     IF(IDOR.NE.0)IDOR=5
  19264. C IDOR IS ORIGINAL # DAYS DIFFERENCE, CORRECTED FOR WHOLE
  19265. C WEEKS ALREADY ALLOWED.
  19266.     LD=JL+3
  19267.     LD=MOD(LD,7)
  19268.     LH=JH+3
  19269.     LH=MOD(LH,7)
  19270. C NOW HAVE DAY OF WEEK START,END. FIND WORK DAYS THAT WEEK (M-F ONLY)
  19271.     IKLU=0
  19272.     IK2=1
  19273.     IF(LD.LT.1)IK2=0
  19274.     IF(LD.LT.1)LD=1
  19275.     IF(LD.GT.5)LD=5
  19276. C FOR HIGH END OF RANGE IF THE END DATE IS SUNDAY SUBTRACT ONE DAY
  19277. C FROM THE DAYS SO WE OMIT THE MONDAY FROM THE RANGE...
  19278.     IF(LH.LT.1)IKLU=IK2
  19279.     IF(LH.LT.1)LH=1
  19280.     IF(LH.GT.5)LH=5
  19281. C LH = DAY ENDED ON, LD=START DAY, FORCED INTO WORK WEEK.
  19282.     IF (LH.GT.LD)IWDY=IWDY+LH-LD-IKLU
  19283.     IF (LH.LE.LD)IWDY=IWDY+IDOR-(LD-LH)-IKLU
  19284. C GIVES DAYS BETWEEN 2 DATES JUST LIKE JULIAN DATE SUBTRACTION FOR
  19285. C CALENDAR DATES.
  19286.     NDAYS=IWDY
  19287.     RETURN
  19288.     END
  19289. c -h- wrkint.for    Fri Aug 22 13:44:46 1986    
  19290.     SUBROUTINE WRKINT(JULLO,NWDY,JULHI)
  19291. C GETS JULLO = START DATE AND NWDY = NO. WORKDAYS (M-F) TO ADD AND
  19292. C FINDS JULHI = END JULIAN DATE, CONSTRAINED TO BE IN MONDAY TO
  19293. C FRIDAY RANGE.
  19294. C MUST ADD 3 BECAUSE THAT'S THE BIAS OF OUR JULIAN DATE BASE.
  19295.     IDJL=MOD(JULLO+3,7)
  19296. C IDJL = DAY CODE OF START DATE
  19297.     NWWK=NWDY/5
  19298.     JL=JULLO
  19299.     IF(IDJL.LT.1)JL=JL+1
  19300.     IF(IDJL.GT.5)JL=JL+2
  19301. C BUMP START INTERVAL...
  19302.     NWDD=NWDY-5*NWWK
  19303.     JL=JL+NWWK*7+NWDD
  19304.     IDJL=MOD(JL+3,7)
  19305.     IF(IDJL.LT.1)JL=JL+1
  19306.     IF(IDJL.GT.5)JL=JL+2
  19307. C FORCE OUTPUT DATE TO BE WITHIN WORKWEEK
  19308.     JULHI=JL
  19309.     RETURN
  19310.     END
  19311. C ****************** AnalyTZ.Ftn ########################################3
  19312. c -h- test.for    Fri Aug 22 13:35:58 1986    
  19313.     SUBROUTINE TEST(LOGTYP,FLAG,V1,V2)
  19314.     InTeGer*4 FLAG
  19315.     REAL*8 V1,V2
  19316.     FLAG=0
  19317.     IF(LOGTYP.EQ.1.AND.V1.GT.V2)FLAG=1
  19318.     IF(LOGTYP.EQ.2.AND.V1.LT.V2)FLAG=1
  19319.     IF(LOGTYP.EQ.3.AND.V1.EQ.V2)FLAG=1
  19320.     IF(LOGTYP.EQ.4.AND.V1.NE.V2)FLAG=1
  19321.     IF(LOGTYP.EQ.5.AND.V1.GE.V2)FLAG=1
  19322.     IF(LOGTYP.EQ.6.AND.V1.LE.V2)FLAG=1
  19323. C TEST LOGICAL RELATIONS FOR IF STATEMENT, FLAG=1 IF TRUE, 0 ELSE.
  19324.     RETURN
  19325.     END
  19326. c -h- ttydei.for    Fri Aug 22 13:35:58 1986    
  19327.     SUBROUTINE TTYDEI
  19328.     INCLUDE DOS.INC
  19329.     INTEGER *4 MODE
  19330.     integer*4 amiga
  19331.     external amiga
  19332. cc    Integer*4 cwrite
  19333. cc    external cmove,cattron,cread !$pragma C(cmove,cattron,cread)
  19334. cc    external ccleareol,cclear,crefresh !$pragma C(ccleareol,cclear,crefresh)
  19335. cc    external cattroff,cclose,copen !$pragma C(cattroff,cclose,copen)
  19336. cc    external cwrite !$pragma C(cwrite)
  19337. c    External cread,cwrite,cclose
  19338. C ***<<< XVXTCD COMMON START >>>***
  19339.     CHARACTER*1 OARRY(100)
  19340.     InTeGer*4 OSWIT,OCNTR
  19341. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  19342. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  19343.     InTeGer*4 IPS1,IPS2,MODFLG
  19344. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  19345.        InTeGer*4 XTCFG,IPSET,XTNCNT
  19346.        CHARACTER*1 XTNCMD(80)
  19347. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  19348. C VARY FLAG ITERATION COUNT
  19349.     INTEGER KALKIT
  19350. C    COMMON/VARYIT/KALKIT
  19351.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  19352.     InTeGer*4 RCMODE,IRCE1,IRCE2
  19353. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  19354. C     1  IRCE2
  19355. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  19356. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  19357. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  19358. C RCFGX ON.
  19359. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  19360. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  19361. C  AND VM INHIBITS. (SETS TO 1).
  19362.     INTEGER*4 FH
  19363. C FILE HANDLE FOR CONSOLE I/O (RAW)
  19364. C    COMMON/CONSFH/FH
  19365. cc    integer*4 curszx,curszy,kbdin
  19366. cc    common/curspr/curszx,curszy,kbdin
  19367.     CHARACTER*1 ARGSTR(52,4)
  19368. C    COMMON/ARGSTR/ARGSTR
  19369.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  19370.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  19371.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  19372.      3  IRCE2,FH,ARGSTR
  19373. C ***<<< XVXTCD COMMON END >>>***
  19374. CCC    COMMON/CONSFH/FH
  19375. ccc    If (FH.ne.0)Call cclose(FH)
  19376.     If(FH.ne.0)call Amiga(Close,FH)
  19377.     RETURN
  19378.     END
  19379. c -h- ttyini.for    Fri Aug 22 13:35:58 1986    
  19380.     SUBROUTINE TTYINI
  19381. C PERFORM INITS ON UNIT 5. NORMALLY EITHER DO NOTHING OR
  19382. C REPLACE WITH SOMETHING THAT WORKS FOR YOUR SYSTEM. TYPICAL
  19383. C ACTIONS:
  19384. C  SET THE TERMINAL NOT TO WRAP AROUND
  19385. C  ATTACH TERMINAL SO TYPE-AHEAD WORKS
  19386. C  SET UP TERMINAL TO MUNGE AROUND THE ESCAPE SEQUENCES TO ALLOW
  19387. C  SPECIAL FUNCTION AND/OR ARROW KEYS TO WORK.
  19388. C ULTIMATELY USE WRITE OF UNIT 0 TO DUMP OUT SOME USEFUL ESCAPE SEQS.
  19389. C TO DEFINE FUNCTION KEYS A LA VT100 (SORT OF).
  19390.     INCLUDE DOS.INC
  19391.     CHARACTER*40 NAME
  19392.     INTEGER *4 MODE
  19393.     Integer*4 Amiga
  19394.     External Amiga
  19395. cc    Integer*4 cwrite,copen,cclose
  19396. cc    external cmove,cattron,cread !$pragma C(cmove,cattron,cread)
  19397. cc    external ccleareol,cclear,crefresh !$pragma C(ccleareol,cclear,crefresh)
  19398. cc    external cattroff,cclose,copen !$pragma C(cattroff,cclose,copen)
  19399. cc    external cwrite !$pragma C(cwrite)
  19400. C ***<<< XVXTCD COMMON START >>>***
  19401.     integer*4 curszx,curszy,kbdin
  19402.     common/curspr/curszx,curszy,kbdin
  19403.     CHARACTER*1 OARRY(100)
  19404.     InTeGer*4 OSWIT,OCNTR
  19405. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  19406. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  19407.     InTeGer*4 IPS1,IPS2,MODFLG
  19408. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  19409.        InTeGer*4 XTCFG,IPSET,XTNCNT
  19410.        CHARACTER*1 XTNCMD(80)
  19411. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  19412. C VARY FLAG ITERATION COUNT
  19413.     INTEGER KALKIT
  19414. C    COMMON/VARYIT/KALKIT
  19415.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  19416.     InTeGer*4 RCMODE,IRCE1,IRCE2
  19417. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  19418. C     1  IRCE2
  19419. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  19420. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  19421. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  19422. C RCFGX ON.
  19423. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  19424. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  19425. C  AND VM INHIBITS. (SETS TO 1).
  19426.     INTEGER*4 FH
  19427. C FILE HANDLE FOR CONSOLE I/O (RAW)
  19428. C    COMMON/CONSFH/FH
  19429.     CHARACTER*1 ARGSTR(52,4)
  19430. C    COMMON/ARGSTR/ARGSTR
  19431.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  19432.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  19433.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  19434.      3  IRCE2,FH,ARGSTR
  19435. C ***<<< XVXTCD COMMON END >>>***
  19436. C ***<<<< RDD COMMON START >>>***
  19437.     InTeGer*4 RRWACT,RCLACT
  19438. C    COMMON/RCLACT/RRWACT,RCLACT
  19439.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  19440.      1  IDOL7,IDOL8
  19441. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  19442. C     1  IDOL7,IDOL8
  19443.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19444. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  19445.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19446. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19447. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  19448. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  19449.     InTeGer*4 KLVL
  19450. C    COMMON/KLVL/KLVL
  19451.     InTeGer*4 IOLVL,IGOLD
  19452. C    COMMON/IOLVL/IOLVL
  19453. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  19454. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  19455.     Integer*4 IDSPTP,Idol9
  19456.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19457.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19458.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  19459.      3  k3dfg,kcdelt,krdelt,kpag
  19460. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19461. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19462. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9
  19463. C ***<<< RDD COMMON END >>>***
  19464. CCC    COMMON/CONSFH/FH
  19465. c Resize initial windows so all fit on NON interlace screen
  19466.     If(IDSPTP.NE.1)NAME=
  19467.      1  "RAW:0/0/639/199/AnalytiCalc-AMIGA" // CHAR(0)
  19468.     IF(IDSPTP.EQ.1)NAME=
  19469.      1  "RAW:0/0/639/399/AnalytiCalc-AMIGA" // CHAR(0)
  19470. c        NAME=  'AnalytiCalc-Amiga' // CHAR(0)
  19471.     MODE=MODE_NEWFILE
  19472. c    FH=copen(%REF(NAME),%val(1),%ref(MODE))
  19473.     FH=AMIGA(Open,name,mode)
  19474.     RETURN
  19475.     END
  19476. c -h- typget.for    Fri Aug 22 13:35:58 1986    
  19477.         SUBROUTINE TYPGET(ID1,ID2,IVAL)
  19478.     Include aparms.inc
  19479. C
  19480. C TYPGET - GET TYPE(60,301) ARRAY WORDS BACK
  19481. C RETURN TYPE(ID1,ID2) IN IVAL, BUT NOT REALLY...
  19482. C NEXT BITMAPS IMPLEMENT FVLD
  19483.         CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
  19484.     CHARACTER*1 FVXX(IMPs3)
  19485.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  19486.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  19487.         Common/FVLDM/FVXX
  19488. c        COMMON/FVLDM/FV1,FV2,FV4
  19489.         CHARACTER*1 LBITS(8)
  19490.         COMMON/BITS/LBITS
  19491. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  19492. C TYPES OF AC'S STORAGE:
  19493.     LOGICAL*4 LB1,LB2
  19494.     InTeGer*4 KB1,KB2
  19495.     EQUIVALENCE(LB1,KB1),(LB2,KB2)
  19496.         CHARACTER*1 ITYP(IMP1S)
  19497.         InTeGer*4 IATYP(27),LINTGR
  19498.         COMMON/TYP/IATYP,ITYP,LINTGR
  19499. C ***<<< NULETC COMMON START >>>***
  19500.     InTeGer*4 ICREF,IRREF
  19501. C    COMMON/MIRROR/ICREF,IRREF
  19502.     InTeGer*4 MODPUB,LIMODE
  19503. C    COMMON/MODPUB/MODPUB,LIMODE
  19504.     InTeGer*4 KLKC,KLKR
  19505.     REAL*8 AACP,AACQ
  19506. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  19507.     InTeGer*4 NCEL,NXINI
  19508. C    COMMON/NCEL/NCEL,NXINI
  19509.     CHARACTER*1 NAMARY(20,MRows)
  19510. C    COMMON/NMNMNM/NAMARY
  19511.     InTeGer*4 NULAST,LFVD
  19512. C    COMMON/NULXXX/NULAST,LFVD
  19513.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  19514.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  19515. C ***<<< NULETC COMMON END >>>***
  19516. CCC    InTeGer*4 ICREF,IRREF
  19517. CCC    COMMON/MIRROR/ICREF,IRREF
  19518. C
  19519. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  19520. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  19521. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  19522. C AREAS WITH DATA.
  19523. C ***<<< KLSTO COMMON START >>>***
  19524.     InTeGer*4 DLFG
  19525. C    COMMON/DLFG/DLFG
  19526.     InTeGer*4 KDRW,KDCL
  19527. C    COMMON/DOT/KDRW,KDCL
  19528.     InTeGer*4 DTRENA
  19529. C    COMMON/DTRCMN/DTRENA
  19530.     REAL*8 EP,PV,FV
  19531.     DIMENSION EP(20)
  19532.     INTEGER*4 KIRR
  19533. C    COMMON/ERNPER/EP,PV,FV,KIRR
  19534.     InTeGer*4 LASTOP
  19535. C    COMMON/ERROR/LASTOP
  19536.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  19537. C    COMMON/FMTBFR/FMTDAT
  19538.     CHARACTER*1 EDNAM(16)
  19539. C    COMMON/EDNAM/EDNAM
  19540.     InTeGer*4 MFID(2),MFMOD(2)
  19541. C    COMMON/FRM/MFID,MFMOD
  19542.     InTeGer*4 JMVFG,JMVOLD
  19543. C    COMMON/FUBAR/JMVFG,JMVOLD
  19544.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  19545.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  19546. C ***<<< KLSTO COMMON END >>>***
  19547. CCC        CHARACTER*1 FMTDAT(9,Ifmtbk)
  19548. CCC        COMMON/FMTBFR/FMTDAT
  19549.         CHARACTER*1 ITST,ITST2
  19550.     LOGICAL*4 LTST,LTST2
  19551.     InTeGer*4 KTST,KTST2
  19552.     EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
  19553.     EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
  19554.         IF(ID1.LE.27.AND.ID2.LE.1)GOTO 1000
  19555.     IVAL=2
  19556.     IF(LINTGR.EQ.0)RETURN
  19557.     CALL FVLDGT(ID1,ID2,ITST)
  19558.     IF(ICHAR(ITST).EQ.0)GOTO 500
  19559. C        ID=(ID2-1)*60+ID1
  19560.     CALL REFLEC(ID2,ID1,ID)
  19561.         IBT=(ID-1)/8
  19562.     KB1=ID-1
  19563.     KB2=7
  19564.     LB1=LB1.AND.LB2
  19565.     IBIT=KB1+1
  19566. C        IBIT=((ID-1).AND.7)+1
  19567.     KTST=ICHAR(ITYP(IBT))
  19568.     KTST2=ICHAR(LBITS(IBIT))
  19569.     LTST=LTST.AND.LTST2
  19570. C        ITST=CHAR(ICHAR(ITYP(IBT)).AND.ICHAR(LBITS(IBIT)))
  19571. 500     IVAL=2
  19572.         IF(KTST.NE.0)IVAL=4
  19573.         RETURN
  19574. 1000    CONTINUE
  19575. C AN AC. RETURN FULL TYPE WORD
  19576.         IVAL=IATYP(ID1)
  19577.         RETURN
  19578.         END
  19579. c -h- typset.for    Fri Aug 22 13:35:58 1986    
  19580.         SUBROUTINE TYPSET(ID1,ID2,IVAL)
  19581. C
  19582. C TYPSET - STORE IVAL IN TYPE(60,301) ARRAY
  19583. C NEXT BITMAPS IMPLEMENT FVLD
  19584.     Include aparms.inc
  19585.         CHARACTER*1 FV1(IMP1S),FV2(IMP1S),FV4(IMP1S)
  19586.     CHARACTER*1 FVXX(Imps3)
  19587.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  19588.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  19589.         Common/FVLDM/FVXX
  19590. c        COMMON/FVLDM/FV1,FV2,FV4
  19591.         CHARACTER*1 LBITS(8)
  19592.         COMMON/BITS/LBITS
  19593. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  19594. C TYPES OF AC'S STORAGE:
  19595.     LOGICAL*4 LTST,LTST2,LTST3,LT1,LT2
  19596.     InTeGer*4 KTST,KTST2,KTST3,KT1,KT2
  19597.     EQUIVALENCE(LT1,KT1),(LT2,KT2)
  19598.         CHARACTER*1 ITYP(IMP1S)
  19599.         InTeGer*4 IATYP(27),LINTGR
  19600.         COMMON/TYP/IATYP,ITYP,LINTGR
  19601. C ***<<< NULETC COMMON START >>>***
  19602.     InTeGer*4 ICREF,IRREF
  19603. C    COMMON/MIRROR/ICREF,IRREF
  19604.     InTeGer*4 MODPUB,LIMODE
  19605. C    COMMON/MODPUB/MODPUB,LIMODE
  19606.     InTeGer*4 KLKC,KLKR
  19607.     REAL*8 AACP,AACQ
  19608. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  19609.     InTeGer*4 NCEL,NXINI
  19610. C    COMMON/NCEL/NCEL,NXINI
  19611.     CHARACTER*1 NAMARY(20,MRows)
  19612. C    COMMON/NMNMNM/NAMARY
  19613.     InTeGer*4 NULAST,LFVD
  19614. C    COMMON/NULXXX/NULAST,LFVD
  19615.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  19616.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  19617. C ***<<< NULETC COMMON END >>>***
  19618. CCC    InTeGer*4 ICREF,IRREF
  19619. CCC    COMMON/MIRROR/ICREF,IRREF
  19620. C
  19621. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  19622. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  19623. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  19624. C AREAS WITH DATA.
  19625. C ***<<< KLSTO COMMON START >>>***
  19626.     InTeGer*4 DLFG
  19627. C    COMMON/DLFG/DLFG
  19628.     InTeGer*4 KDRW,KDCL
  19629. C    COMMON/DOT/KDRW,KDCL
  19630.     InTeGer*4 DTRENA
  19631. C    COMMON/DTRCMN/DTRENA
  19632.     REAL*8 EP,PV,FV
  19633.     DIMENSION EP(20)
  19634.     INTEGER*4 KIRR
  19635. C    COMMON/ERNPER/EP,PV,FV,KIRR
  19636.     InTeGer*4 LASTOP
  19637. C    COMMON/ERROR/LASTOP
  19638.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  19639. C    COMMON/FMTBFR/FMTDAT
  19640.     CHARACTER*1 EDNAM(16)
  19641. C    COMMON/EDNAM/EDNAM
  19642.     InTeGer*4 MFID(2),MFMOD(2)
  19643. C    COMMON/FRM/MFID,MFMOD
  19644.     InTeGer*4 JMVFG,JMVOLD
  19645. C    COMMON/FUBAR/JMVFG,JMVOLD
  19646.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  19647.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  19648. C ***<<< KLSTO COMMON END >>>***
  19649. CCC        CHARACTER*1 FMTDAT(9,Ifmtbk)
  19650. CCC        COMMON/FMTBFR/FMTDAT
  19651.         CHARACTER*1 ITST,ITST2,ITST3
  19652.     EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
  19653.     EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
  19654.     EQUIVALENCE(KTST3,ITST3),(KTST3,LTST3)
  19655.     IF(ID2.EQ.1.AND.ID1.LE.27)GOTO 2000
  19656. C KEEP TRACK OF WHEN WE START TO SET INTEGER TYPE
  19657.     IF(LINTGR.EQ.0.AND.IABS(IVAL).EQ.2)RETURN
  19658. C FOR SIMPLICITY SET FLAG ON 1ST NONFLOATING TYPE AND
  19659. C START KEEPING EXACT TRACK THEN ONLY.
  19660.     LINTGR=1
  19661. C        ID=(ID2-1)*60+ID1
  19662.     CALL REFLEC(ID2,ID1,ID)
  19663.         IBT=(ID-1)/8
  19664.     KT1=ID-1
  19665.     KT2=7
  19666.     LT1=LT1.AND.LT2
  19667.     IBIT=KT1+1
  19668. C        IBIT=((ID-1).AND.7)+1
  19669.     KTST2=ICHAR(LBITS(IBIT))
  19670.     KTST3=KTST2
  19671.     LTST2=.NOT.LTST2
  19672. C        ITST2=.NOT.LBITS(IBIT)
  19673.     KTST=ICHAR(ITYP(IBT))
  19674.     LTST2=LTST.AND.LTST2
  19675. C        ITST2=ITYP(IBT).AND.ITST2
  19676.     LTST=LTST.OR.LTST3
  19677.     ITST=CHAR(KTST)
  19678.     ITST2=CHAR(KTST2)
  19679. C        ITST=ITYP(IBT).OR.LBITS(IBIT)
  19680.         ITYP(IBT)=ITST2
  19681.         IF(IVAL.NE.-2.AND.IVAL.NE.2)ITYP(IBT)=ITST
  19682.     RETURN
  19683. 2000    IATYP(ID1)=IVAL
  19684. C ACCUMULATORS JUST STORE NORMAL TYPE INTEGER.
  19685.         RETURN
  19686.         END
  19687. c -h- usrcmd.for    Fri Aug 22 13:36:30 1986    
  19688. c        interface to InTeGer*4 function system [c]
  19689. c     +          (string[reference])
  19690. c        character*1 string
  19691. c        end
  19692.     SUBROUTINE USRCMD(CMDLIN,ICODE,IGOTIT)
  19693. C --- FOR 320K AnalytiCalc only (to keep it able to fit on 256K
  19694. c     versions...)
  19695. c Add "annotation" commands via main force & awkwardness as follows:
  19696. c  1. ANN command will create a file named cell.ANN for the current
  19697. c     cell (or overwrite an old one) dynamically for up to 20 lines
  19698. c     of text, just firing up the command "EDIT namecell.ANN" so the user
  19699. c     gets to do full screen edits. THE "name" part of the files is
  19700. c     taken from the first 6 characters of the sheet name. If these
  19701. c     are not in the uppercase alpha range they will be ignored, however,
  19702. c     so it is a good idea for sheet titles to have recognizable initial
  19703. c     6 characters.
  19704. c  2. QUERY or ? command will display the name.ANN file if it exists
  19705. c     after setting cursor to top of screen and doing line erase
  19706. c     there.
  19707. c
  19708.     Include aparms.inc
  19709.     CHARACTER*81 CMDSTR
  19710.     CHARACTER*1 CMLN(80),CMLN2(84)
  19711. C    PARAMETER CUP=1,EL=12,ED=11,SGR=13
  19712.     InTeGer*4 IJUNK
  19713. c    InTeGer*4 SYSTEM
  19714. c    EXTERNAL SYSTEM
  19715.     EQUIVALENCE(CMLN2(5),CMLN(1),CMDSTR(1:1))
  19716. C    EQUIVALENCE(CMLN2(5),CMLN(1))
  19717. C DUMMY PLACE FOR USER COMMANDS TO PARSE CMDLIN AND HANDLE
  19718. C DEFINE VALUE AREA FOR SPREAD SHEET. MORE WILL BE NEEDED GENERALLY
  19719. C OUT OF COMMONS, BUT AT A MINIMUM, THIS WILL ALLOW SOME ACCESS TO
  19720. C USEFUL NUMBERS. LOOK IN XQTCMD FOR MORE...
  19721.     CHARACTER*1 AVBLS(24,27),WRK(128),VBLS(8,1,1)
  19722.     Real*8 VAVBLS(3,27)
  19723.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  19724.     InTeGer*4 TYPE(1,2),VLEN(9)
  19725.     LOGICAL*4 LEXIST
  19726.     CHARACTER*1 NMSH(80)
  19727.     COMMON/NMSH/NMSH
  19728. C ***<<<< RDD COMMON START >>>***
  19729.     InTeGer*4 RRWACT,RCLACT
  19730. C    COMMON/RCLACT/RRWACT,RCLACT
  19731.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  19732.      1  IDOL7,IDOL8
  19733. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  19734. C     1  IDOL7,IDOL8
  19735.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19736. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  19737.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19738. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  19739. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  19740. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  19741.     InTeGer*4 KLVL
  19742. C    COMMON/KLVL/KLVL
  19743.     InTeGer*4 IOLVL,IGOLD
  19744. C    COMMON/IOLVL/IOLVL
  19745. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  19746. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  19747.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19748.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19749.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  19750.      3  k3dfg,kcdelt,krdelt,kpag
  19751. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  19752. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  19753. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  19754. C ***<<< RDD COMMON END >>>***
  19755. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19756. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  19757.     REAL*8 XAC,XVBLS(1,1)
  19758.     REAL*8 TAC,UAC,VAC
  19759.     INTEGER*4 JVBLS(2,1,1)
  19760.     EQUIVALENCE(XAC,AVBLS(1,27))
  19761.     EQUIVALENCE(TAC,AVBLS(1,20))
  19762.     EQUIVALENCE(UAC,AVBLS(1,21))
  19763.     EQUIVALENCE(VAC,AVBLS(1,22))
  19764.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  19765.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  19766.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  19767. C    CHARACTER*1 FORM(4)
  19768.     CHARACTER*1 CELNAM(5)
  19769.     character*18 annam
  19770.     CHARACTER*1 annams(18)
  19771.     equivalence(annam(1:1),annams(1))
  19772.     CHARACTER*5 CELNM
  19773.     CHARACTER*5 CELRW
  19774.     EQUIVALENCE(CELNM(1:1),CELRW(1:1),CELNAM(1))
  19775. C    EQUIVALENCE(FORM(1),CELNAM(1))
  19776. C    EQUIVALENCE(CELRW,CELNAM(1))
  19777. C ***<<< KLSTO COMMON START >>>***
  19778.     InTeGer*4 DLFG
  19779. C    COMMON/DLFG/DLFG
  19780.     InTeGer*4 KDRW,KDCL
  19781. C    COMMON/DOT/KDRW,KDCL
  19782.     InTeGer*4 DTRENA
  19783. C    COMMON/DTRCMN/DTRENA
  19784.     REAL*8 EP,PV,FV
  19785.     DIMENSION EP(20)
  19786.     INTEGER*4 KIRR
  19787. C    COMMON/ERNPER/EP,PV,FV,KIRR
  19788.     InTeGer*4 LASTOP
  19789. C    COMMON/ERROR/LASTOP
  19790.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  19791. C    COMMON/FMTBFR/FMTDAT
  19792.     CHARACTER*1 EDNAM(16)
  19793. C    COMMON/EDNAM/EDNAM
  19794.     InTeGer*4 MFID(2),MFMOD(2)
  19795. C    COMMON/FRM/MFID,MFMOD
  19796.     InTeGer*4 JMVFG,JMVOLD
  19797. C    COMMON/FUBAR/JMVFG,JMVOLD
  19798.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  19799.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  19800. C ***<<< KLSTO COMMON END >>>***
  19801. CCC    CHARACTER*1 EDNAM(16)
  19802. CCC    common/ednam/ednam
  19803. c available parsing aid:
  19804. c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
  19805. c where line(ibgn... lend) is scanned. If variable found
  19806. c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
  19807. c variable found if any. lstchr is last char found+1...
  19808. C OTHER USEFUL ROUTINES IN THE SHEET:
  19809. C GN(LAST,LEND,NUMBER,LINE)
  19810. C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
  19811. C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
  19812. C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
  19813. C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
  19814. C  NUMERIC.
  19815. C INDEX(LINE,CHAR)
  19816. C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
  19817. C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
  19818. C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
  19819. C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
  19820. C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
  19821. C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
  19822. C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
  19823.     character*4 cijunk
  19824.     CHARACTER*1 CMDLIN(132)
  19825. C    INTEGER*4 ISTTS
  19826. C
  19827. C 16 MUST BE LENGTH OF EDNAM IN BYTES
  19828. C KEEP NAME "EDIT " IN DATA SO IT CAN BE BASHED IF NEEDED TO BE...
  19829. C INSERT CODE FOR ADDING A LIB$SPAWN CALL HERE TO PASS COMMANDS TO
  19830. C 75 IF THEY BEGIN WITH A $ CHARACTER.
  19831.     IGOTIT=0
  19832.     IF(CMDLIN(1).NE.'}'.AND.CMDLIN(1).NE.'$')GOTO 8990
  19833. C
  19834. CC HERE CALL EXECIT WITH THE COMMAND LINE AS AN ARGUMENT...
  19835.     DO 1000 NN=1,80
  19836. 1000    CMLN(NN)=CMDLIN(NN+1)
  19837.     CMLN(79)=Char(13)
  19838.     CMLN(80)=Char(0)
  19839.     DO 1002 NN=1,77
  19840.     N=78-NN
  19841.     IF(ICHAR(CMLN(N)).GT.32)GOTO 1004
  19842. 1002    CONTINUE
  19843. C FINDING END OF REAL STRING THIS WAY
  19844. 1004    CONTINUE
  19845.     CMLN(N+1)=char(0)
  19846. c was =13, not =0 above...
  19847. C ADD C.R., THEN NULL
  19848.     CMLN(N+2)=char(0)
  19849.     CMLN(N+3)=char(0)
  19850. C INSERT LENGTH COUNT AS 1ST BYTE OF CMD LENGTH
  19851. C PER DOS 2.0 MANUAL PG F-1
  19852. ccc    CMLN2(1)=CHAR(N+3)
  19853. ccc    CMLN2(2)='/'
  19854. ccc    CMLN2(3)='C'
  19855. ccc    CMLN2(4)=' '
  19856. CC ! ADD C.R. AFTER LINE
  19857. CC ABOVE, INSERT A CR AFTER CMD LINE
  19858. C USE SYSTEM CALL INSTEAD OF OLDER CALL WHICH USES NOW-UNSUPPORTED
  19859. C FORTRAN FEATURES IN MS-FORTRAN V3.3
  19860.     call xsystem(cmln2(5))
  19861. c    N=SYSTEM(CMLN2(5))
  19862. ccc    CALL EXECIT(CMLN2)
  19863. C ASSUME WE NEED A REDRAW AFTER THE SPAWN FINISHES
  19864. C EVENTUALLY FIGURE OUT HOW TO EXEC A ROUTINE THIS WAY, BUT JUST DUMMY OUT
  19865. C  AT FIRST.
  19866.     IF(CMDLIN(1).NE.'}')GOTO 2300
  19867. C IMPLEMENT WAIT ON } FORM...
  19868.     CALL UVT100(1,25,1)
  19869.     CALL VWRT('Push Return key to return to sheet>',35)
  19870.     call vget(cijunk,2)
  19871. c    READ(11,2400,END=2300,ERR=2300)IJUNK
  19872. 2400    FORMAT(2A1)
  19873. 2300    CONTINUE
  19874.     ICODE=2
  19875. C FLAG THE MAIN COMMAND PARSER WE HANDLED THE COMMAND
  19876.     IGOTIT=1
  19877. 8990    CONTINUE
  19878.     IF(CMDLIN(1).NE.'F'.OR.
  19879.      1     CMDLIN(2).NE.'I'.OR.
  19880.      2     CMDLIN(3).NE.'L') GOTO 9000
  19881.     IGOTIT=1
  19882.     ICODE=3
  19883.     CALL DTRCMD(CMDLIN(4))
  19884. C ALLOW EXTRA COMMANDS OUT OF VAX VERSION...
  19885. C
  19886. 9000    CONTINUE
  19887.     if(cmdlin(1).ne.'C'.or.
  19888.      1     cmdlin(2).ne.'M'.or.
  19889.      2     cmdlin(3).ne.'D') goto 9100
  19890.     igotit=1
  19891.     icode=6
  19892. C Allow anything beginning with CMD to activate the RIM interface
  19893. C via a separate routine, which is passed the rest of the command
  19894. C line.
  19895.         call rimcmd(cmdlin(4))
  19896.     goto 9300
  19897. 9100    continue
  19898.     IF(CMDLIN(1).NE.'A'.OR.CMDLIN(2).NE.'N')GOTO 9200
  19899. C ANNOTATE COMMAND SEEN
  19900.     IGOTIT=1
  19901.     ICODE=2
  19902.     DO 9001 N=1,80
  19903.     CMLN(N)=Char(32)
  19904. 9001    CONTINUE
  19905. C    CALL IN2AS(PROW,FORM)
  19906.     CALL REFLEC(PCOL,PROW,IRX)
  19907.     WRITE(CELRW(1:5),9002)IRX
  19908. 9002    FORMAT(I5.5)
  19909.     ICM=17
  19910.     DO 9040 N=1,3
  19911.     IXX=ICHAR(NMSH(N))
  19912.     IF(IXX.GT.96)IXX=IXX-32
  19913.     IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9040
  19914.     CMLN(ICM)=CHAR(IXX)
  19915.     ICM=ICM+1
  19916. 9040    CONTINUE
  19917.     ICM=ICM-1
  19918.     DO 9003 N=1,5
  19919.     CMLN(N+ICM)=CELNAM(N)
  19920. 9003    CONTINUE
  19921.     CMLN(ICM+6)='.'
  19922.     CMLN(ICM+7)='A'
  19923.     CMLN(ICM+8)='N'
  19924.     CMLN(ICM+9)='N'
  19925.     CMLN(ICM+10)=' '
  19926.     CMLN(80)=char(13)
  19927.     DO 9008 N=1,16
  19928.     CMLN(N)=EDNAM(N)
  19929. 9008    CONTINUE
  19930. C NOW HAVE "EDIT name.ANN"
  19931. c built... go fire it up for creation or modification of annotation...
  19932.     DO 9150 N=17,ICM+9
  19933.     IF(CMLN(N).EQ.' ')CMLN(N)='0'
  19934. 9150    CONTINUE
  19935.     DO 9162 NN=1,77
  19936.     N=78-NN
  19937.     IF(ICHAR(CMLN(N)).GT.32)GOTO 9164
  19938. 9162    CONTINUE
  19939. C FINDING END OF REAL STRING THIS WAY
  19940. 9164    CONTINUE
  19941.     CMLN(N+1)=Char(13)
  19942. C ADD C.R., THEN NULL
  19943.     CMLN(N+2)=Char(0)
  19944.     CMLN(N+3)=Char(0)
  19945.     call xSYSTEM(CMLN2(5))
  19946.     GOTO 9990
  19947. 9200    CONTINUE
  19948.     IF(CMDLIN(1).NE.'?'.AND.(CMDLIN(1).NE.'Q'.OR.CMDLIN(2)
  19949.      1  .NE.'U'.OR.CMDLIN(3).NE.'E')) GOTO 9300
  19950. C QUERY COMMAND SEEN
  19951.     IGOTIT=1
  19952.     ICODE=2
  19953.     DO 9237 N=1,18
  19954. 9237    ANNAMS(N)=CHAR(32)
  19955.     CALL REFLEC(PCOL,PROW,IRX)
  19956.     WRITE(CELRW(1:5),9002)IRX
  19957.     ICM=0
  19958.     do 9238 n=1,18
  19959.     annams(n)=char(32)
  19960. 9238    continue
  19961.     DO 9240 N=1,3
  19962. C NOTE ANNOTATION NAMES ARE DIFFERENT HERE FROM VAX...
  19963. C USE NAMnnnnn.ANN WHERE nnnnn IS CELL HASH AND "NAM" COMES
  19964. C FROM 1ST 3 CHARS OF SHEET TITLE.
  19965.     IXX=ICHAR(NMSH(N))
  19966.     IF(IXX.GT.96)IXX=IXX-32
  19967.     IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9240
  19968.     ICM=ICM+1
  19969.     ANNAMS(ICM)=CHAR(IXX)
  19970. 9240    CONTINUE
  19971.     DO 9241 N=1,5
  19972.     ANNAMS(ICM+N)=CELNAM(N)
  19973. 9241    CONTINUE
  19974.     ANNAMS(ICM+6)='.'
  19975.     ANNAMS(ICM+7)='A'
  19976.     ANNAMS(ICM+8)='N'
  19977.     ANNAMS(ICM+9)='N'
  19978.     DO 9250 N=1,18
  19979.     IF(ANNAMS(N).EQ.' ')ANNAMS(N)='0'
  19980. 9250    CONTINUE
  19981.     ANNAMS(ICM+10)=' '
  19982. C GO TO 9210 IF NO FILE
  19983.     INQUIRE (FILE=ANNAM,EXIST=LEXIST)
  19984.     IF(.NOT.LEXIST)GOTO 9210
  19985.     OPEN(UNIT=2,FILE=ANNAM,ACCESS='SEQUENTIAL',STATUS='OLD')
  19986.     DO 9030 N=1,20
  19987.     READ(2,9031,END=9032,ERR=9032)WRK
  19988. 9031    FORMAT(128A1)
  19989.     CALL UVT100(1,N+2,1)
  19990.     CALL UVT100(12,2,0)
  19991.     call swrt(wrk,79)
  19992. c    WRITE(6,9035)WRK
  19993. 9035    FORMAT(128A1)
  19994. 9030    CONTINUE
  19995. 9032    CONTINUE
  19996. C THIS DISPLAYS ALL THE ANNOTATION WE HAVE...
  19997.     CLOSE(UNIT=2)
  19998.     CALL UVT100(1,LLCMD,1)
  19999.     CALL UVT100(12,2,0)
  20000.     CALL VWRT('Push Return key to return to sheet>',35)
  20001.     call vget(cijunk,2)
  20002.     READ(11,2400,END=9990,ERR=9990)IJUNK
  20003.     GOTO 9990
  20004. 9210    CONTINUE
  20005.     ICODE=3
  20006.     CALL UVT100(1,LLDSP,1)
  20007.     call uvt100(12,2,0)
  20008.     CALL SWRT('No Annotation found on thic cell.',33)
  20009. c    WRITE(6,9211)
  20010. c9211    FORMAT(' No annotation found on this cell.')
  20011. 9300    CONTINUE
  20012. C
  20013. 9990    CONTINUE
  20014.     RETURN
  20015.     END
  20016. c -h- usrfct.for    Fri Aug 22 13:36:30 1986    
  20017. C USER FUNCTION ROUTINE
  20018. C GENERATES PARSING AND EXECUTION OF ROUTINE CALLS OF FORM
  20019. C  *U FNAME (ARGUMENTS)
  20020. C WHERE LINE (80 BYTES) CONTAINS COMMAND LINE AND ALL
  20021. C ARGUMENTS MAY BE PARSED.
  20022. C CALLED FROM CMND
  20023. C
  20024. C VAX VERSION: MOST MATRIX ROUTINES AVAILABLE
  20025. C BUT ASSUMES SUBSTANTIAL SPACE AVAILABLE.
  20026. C
  20027. c available parsing aid:
  20028. c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
  20029. c where line(ibgn... lend) is scanned. If variable found
  20030. c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
  20031. c variable found if any. lstchr is last char found+1...
  20032. C OTHER USEFUL ROUTINES IN THE SHEET:
  20033. C GN(LAST,LEND,NUMBER,LINE)
  20034. C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
  20035. C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
  20036. C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
  20037. C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
  20038. C  NUMERIC.
  20039. C INDEX(LINE,CHAR)
  20040. C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
  20041. C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
  20042. C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
  20043. C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
  20044. C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
  20045. C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
  20046. C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
  20047. C VARIABLE NAMES. SUPPLIED VERSION CALLS IDATE WHICH RETURNS
  20048. C SYSTEM DATE IN RSX OR VMS AS INTEGER DAY, MONTH, AND YEAR.
  20049. C  THIS RETURNS HERE IN AC T, U, AND V
  20050. C
  20051.     SUBROUTINE USRFCT(LINE,RETCD,WRK2)
  20052.     Include aparms.inc
  20053.     CHARACTER*1 LINE(80)
  20054.     INTEGER RETCD
  20055.     CHARACTER*1 AVBLS(24,27),WRK(128),VBLS(8,1,1)
  20056.     Real*8 VAVBLS(3,27)
  20057.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  20058.     CHARACTER*1 WRK2(128)
  20059.     InTeGer*4 TYPE(1,2),VLEN(9)
  20060.     EXTERNAL INDX
  20061.     REAL*8 XAC,XVBLS(1,1)
  20062.     REAL*8 TAC,UAC,VAC,WAC,YAC
  20063.     REAL*8 TMP,XXXX
  20064.     INTEGER*4 JVBLS(2,1,1)
  20065.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  20066.     EQUIVALENCE(XAC,AVBLS(1,27))
  20067.     EQUIVALENCE(TAC,AVBLS(1,20))
  20068.     EQUIVALENCE(UAC,AVBLS(1,21))
  20069.     EQUIVALENCE(VAC,AVBLS(1,22))
  20070.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  20071.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  20072.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  20073. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  20074. CCC    CHARACTER*1 XTNCMD(80)
  20075. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  20076. C ***<<<< RDD COMMON START >>>***
  20077.     InTeGer*4 RRWACT,RCLACT
  20078. C    COMMON/RCLACT/RRWACT,RCLACT
  20079.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  20080.      1  IDOL7,IDOL8
  20081. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  20082. C     1  IDOL7,IDOL8
  20083.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  20084. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  20085.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  20086. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  20087. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  20088. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  20089.     InTeGer*4 KLVL
  20090. C    COMMON/KLVL/KLVL
  20091.     InTeGer*4 IOLVL,IGOLD
  20092. C    COMMON/IOLVL/IOLVL
  20093. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  20094. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  20095.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  20096.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  20097.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  20098.      3  k3dfg,kcdelt,krdelt,kpag
  20099. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  20100. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  20101. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  20102. C ***<<< RDD COMMON END >>>***
  20103. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  20104. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  20105. CCC    InTeGer*4 RRWACT,RCLACT
  20106. CCC    COMMON/RCLACT/RRWACT,RCLACT
  20107. C ***<<< XVXTCD COMMON START >>>***
  20108.     CHARACTER*1 OARRY(100)
  20109.     InTeGer*4 OSWIT,OCNTR
  20110. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  20111. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  20112.     InTeGer*4 IPS1,IPS2,MODFLG
  20113. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  20114.        InTeGer*4 XTCFG,IPSET,XTNCNT
  20115.        CHARACTER*1 XTNCMD(80)
  20116. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  20117. C VARY FLAG ITERATION COUNT
  20118.     INTEGER KALKIT
  20119. C    COMMON/VARYIT/KALKIT
  20120.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  20121.     InTeGer*4 RCMODE,IRCE1,IRCE2
  20122.  
  20123. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  20124. C     1  IRCE2
  20125. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  20126. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  20127. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  20128. C RCFGX ON.
  20129. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  20130. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  20131. C  AND VM INHIBITS. (SETS TO 1).
  20132.     INTEGER*4 FH
  20133. C FILE HANDLE FOR CONSOLE I/O (RAW)
  20134. C    COMMON/CONSFH/FH
  20135.     CHARACTER*1 ARGSTR(52,4)
  20136. C    COMMON/ARGSTR/ARGSTR
  20137.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  20138.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  20139.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  20140.      3  IRCE2,FH,ARGSTR
  20141. C ***<<< XVXTCD COMMON END >>>***
  20142. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  20143. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  20144. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  20145. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  20146. C (IMPLEMENT FOR VAX ONLY)
  20147. CCC    INTEGER KALKIT
  20148. CCC    COMMON/VARYIT/KALKIT
  20149. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  20150. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  20151. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  20152. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  20153.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  20154.     COMMON/D2R/NRDSP,NCDSP
  20155.     CHARACTER*1 FNAMS(6,24)
  20156. C FNAMS IS NAME OF FUNCTION CALLED.
  20157.     save fnams
  20158.     DATA FNAMS /'I','D','A','T','E','0',
  20159.      1  'M','T','X','E','Q','0',
  20160.      2  'M','O','V','E','V','0',
  20161.      3  'M','D','E','T','0','0',
  20162.      4  'M','P','R','O','D','0',
  20163.      5  'M','A','D','D','V','0','M','S','U','B','V','0',
  20164.      7  'M','M','P','Y','T','0','M','M','P','Y','C','0',
  20165.      9  'V','A','R','Y','0','0','X','Q','T','C','M','0',
  20166.      2  'S','T','R','V','L','0','H','E','R','E','0','0',
  20167.      4  'Y','R','M','O','D','0','J','D','A','T','E','0',
  20168.      6  'J','T','O','C','H','0','D','A','T','E','0','0',
  20169.      1  'W','K','D','Y','S','0','W','K','D','I','N','0',
  20170.      2  'F','F','T','F','W','0','F','F','T','R','V','0',
  20171.      3  'L','I','N','E','F','0','D','B','0','0','0','0',
  20172.      4  'S','T','0','0','0','0'/
  20173. C NULL TERMINATE ANY NAMES (ALLOWS 5 CHARACTERS)
  20174. C START LOOKING PAST THE *U
  20175. C  GET FUNCTION NAME AND GO TO PROCESS EACH FUNCTION SEPARATELY
  20176. C GET NONBLANK CHAR FOR FUNCTION NAME START
  20177. C NO-OP THE XQTCM FUNCTION FOR PDP11-OVERLAIN VERSIONS BY ZAPPING
  20178. C THE NAME SO IT CAN'T EVER BE CALLED.
  20179.     K=3
  20180. 30    IF(LINE(K).NE.' ')GOTO 40
  20181.     K=K+1
  20182.     IF(K.LT.60)GOTO 30
  20183. 40    CONTINUE
  20184. C UNCOMMENT THE DO 100 STMT IF DIM 2 OF FNAMS > 1
  20185.     N=1
  20186. C **** BE SURE THE 2ND BOUND ON N IS THE SAME AS THE DIMENSION OF
  20187. C ****  FNAMS   **************************
  20188. C    DO 7771 N=1,24
  20189. C    DO 7771 NN=1,6
  20190. C    IF(FNAMS(NN,N).EQ.'0')FNAMS(NN,N)=0
  20191. C7771    CONTINUE
  20192.     DO 100 N=1,24
  20193.     KF=N
  20194.     DO 110 NN=1,6
  20195. C CHECK FOR '0' IN FUNCTION NAME AND SKIP ON THAT... 48 IS ASCII /0/
  20196.     IF(LINE(K+NN-1).NE.FNAMS(NN,N).AND.ICHAR(FNAMS(NN,N)).NE.48)
  20197.      1  GOTO 100
  20198. 110    CONTINUE
  20199.     GOTO 200
  20200. 100    CONTINUE
  20201. C UNRECOGNIZED FUNCTION... IGNORE
  20202. 300    RETCD=3
  20203.     RETURN
  20204. 200    CONTINUE
  20205. C NOW HAVE FOUND FUNCTION IDENTIFIED BY KF. CALL IT AND ALLOW TO WORK
  20206.     GOTO (1100,1200,1300,1400,1500,1600,1700,1800,
  20207.      1  1900,2000,2100,2200,2300,2400,2500,2600,2700,
  20208.      2  2900,3000,3100,3200,3300,3400,3500),KF
  20209.     GOTO 300
  20210. 1100    CONTINUE
  20211. C IDATE FUNCTION
  20212. C RETURNS MONTH, DAY, YEAR IN AC'S T,U,V
  20213. C RETURN 4/1/85 (APRIL FOOLS DAY)
  20214. C    IDA=1
  20215. C    IMO=4
  20216. C    IYR=85
  20217. c    CALL IDATE(IMO,IDA,IYR)
  20218.     CALL DATE(IYR,IMO,IDA)
  20219. C CALL supplied GET-DATE FUNCTION AND HOPE IT'S OK
  20220.     TAC=IMO
  20221.     UAC=IDA
  20222.     IYR=IYR-1900
  20223.     VAC=IYR
  20224. C RETURN A FLOATING VALUE OF DATE FORM AS YYMMDD SO IT CAN BE
  20225. C USED FOR SORTING AND SIMILAR APPLICATIONS. COULD BE USED ALSO
  20226. C FOR INTERVALS IF A JULIAN DATE WERE RETURNED, BUT THIS WILL DO
  20227. C FOR COMPARISONS AND ORDERING.
  20228.     XAC=JULMDY(IYR,IMO,IDA)
  20229. C    XAC=VAC*10000.+TAC*100.+UAC
  20230.     RETURN
  20231. 1200    CONTINUE
  20232. C MATRIX EQUATION. NOTE WE MUST NOW START SCAN FOR ARGUMENTS...
  20233. C K+5 IS START OF ARG LIST. START AT K+6 TO ALLOW ( TO BE THERE...
  20234. C FORMAT DESIRED:
  20235. C  *U MTXEQ(A1:A2,X1:X2,B1:B2) GENERATING SOLUTION MATRIX X1:X2
  20236. C  FROM MATRICES A,B AND SOLVING EQUATION AX=B WHERE A IS AN N BY
  20237. C  N SQUARE MATRIX, AND X AND B ARE N BY M MATRICES.
  20238.     RETCD=1
  20239. C COLLECT ARGUMENTS. NOTE THAT VARSCN AND GN TRASH POINTERS PASSED
  20240. C TO THEM IN IBGN, LEND, SO MAKE UP EVERY TIME. USE VARSCN TO
  20241. C COLLECT POINTERS TO THE SHEET ARRAY FIRST OFF COMMAND LINE,
  20242. C THEN PROCESS IN OUR MAGICAL MYSTICAL ROUTINE...
  20243.     IBGN=K+6
  20244.     LEND=IBGN+20
  20245. C GET LOCATIONS OF MATRICES A, X, AND B (FOR AX=B EQN)
  20246. C A MUST BER N BY N, SQUARE. X,B ARE N BY M.
  20247.     CALL PMTX2(RETCD,3,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  20248.      1   IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  20249.     N=IABS(ID1B-ID1A)+1
  20250. C CHECK THAT MATRIX A IS SQUARE
  20251.     IF(N.NE.(IABS(ID2B-ID2A)+1))GOTO 300
  20252. C CHECK THAT MATRIX X AND B HAVE THE SAME DIMENSIONS
  20253.     IF((IDYA-IDXA).NE.(IDCA-IDBA))GOTO 300
  20254.     IF((IDYB-IDXB).NE.(IDCB-IDBB))GOTO 300
  20255.     M=IABS(IDYA-IDXA)+1
  20256. C CHECK THAT THE X AND B MATRIX DIMENSIONS ARE N BY M
  20257. C WHERE THE N IS THE SAME AS FOR THE A MATRIX
  20258.     NN=IABS(IDYB-IDXB)+1
  20259.     IF(NN.NE.N)GOTO 300
  20260. C NOW HAVE DIMENSIONS FOR ALL THIS STUFF...
  20261. C SINCE MTXEQU TRASHES ITS' B MATRIX, COPY IT INTO X MATRIX
  20262. C AND THEN CALL...
  20263.     DO 1210 NN=IDBA,IDCA
  20264.     DO 1210 MM=IDBB,IDCB
  20265.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  20266.     CALL XVBLST(NN-IDBA+IDXA,MM-IDBB+IDXB,XVBLS(1,1))
  20267. C    XVBLS(NN-IDBA+IDXA,MM-IDBB+IDXB)=XVBLS(NN,MM)
  20268. 1210    CONTINUE
  20269. C NOW ALL THE ARGUMENTS ARE SET UP... GO DO THE WORK.
  20270. C CALL UTILITY ROUTINE, THEN DONE...
  20271.     CALL MTXEQU(ID1A,ID2A,IDXA,IDXB,N,M,XAC)
  20272.     RETURN
  20273. 1300    CONTINUE
  20274. C MOVEV  MTX1 MTX2  MOVE MTX1 VALUES TO MTX2
  20275.     RETCD=1
  20276.     IBGN=K+6
  20277.     CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
  20278.      1  IR2B,IC2B,KK,KK,KK,KK)
  20279. C CHECK FOR SAME SIZE MATRICES
  20280.     IF((IC1T-IC1B).NE.(IC2T-IC2B))GOTO 300
  20281.     IF((IR1T-IR1B).NE.(IR2T-IR2B))GOTO 300
  20282. C DO THE COPY HERE (EASIER THAN CALLING SOMETHING...)
  20283.     DO 1301 NN=IR1T,IR1B
  20284.     DO 1301 MM=IC1T,IC1B
  20285.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  20286.     CALL XVBLST(NN-IR1T+IR2T,MM-IC1T+IC2T,XVBLS(1,1))
  20287. C    XVBLS(NN-IR1T+IR2T,MM-IC1T+IC2T)=XVBLS(NN,MM)
  20288. 1301    CONTINUE
  20289.     RETURN
  20290. 1400    CONTINUE
  20291. C MDET  - DETERMINANT OF SQUARE MATRIX
  20292. C  1 ARGUMENT, VIZ., MATRIX COORDS
  20293.     RETCD=1
  20294. C ACCOUNT FOR "MDET" BEING 4 CHARS NOT 5
  20295.     IBGN=K+5
  20296.     CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
  20297.      1  IV,IV,IV,IV,IV,IV,IV,IV)
  20298. C CALL A DETERMINANT ROUTINE TO DO THE WORK
  20299. C NOTE IT CHECKS FOR SQUARE MATRIX INTERNALLY AND RETURNS 0 IF NOT
  20300. C SQUARE...
  20301.     CALL MDET(XVBLS,IR1T,IC1T,IR1B,IC1B,XAC)
  20302.     RETURN
  20303. 1500    CONTINUE
  20304. C MPROD A,B,C  C=A*B MATRIX WISE
  20305.     IBGN=K+6
  20306.     RETCD=1
  20307.     IMXX=3
  20308.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  20309.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  20310. C A=N BY M
  20311. C B=M BY L
  20312. C C=N BY L
  20313.     N=1+ID1B-ID1A
  20314.     M=1+ID2B-ID2A
  20315. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  20316.     L=1+IDYA-IDXA
  20317. C    IF(N.NE.(1+IDCB-IDBB))GOTO 300
  20318. C    IF(L.NE.(1+IDCA-IDBA))GOTO 300
  20319. C DIMENSIONS LOOK OK NOW SO DO THE WORK
  20320. C USE SLIGHTLY MODIFIED GMPRD
  20321.     CALL GMPRD(ID1A,ID2A,IDXA,IDXB,
  20322.      1  IDBA,IDBB,N,M,L)
  20323.     RETURN
  20324. 1600    CONTINUE
  20325. C MADDV A,B,C  C=A+B
  20326.     IMXX=3
  20327.     IBGN=K+6
  20328.     RETCD=1
  20329.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  20330.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  20331.     N=1+ID1B-ID1A
  20332.     M=1+ID2B-ID2A
  20333. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  20334. C    IF(N.NE.(1+IDCA-IDBA))GOTO 300
  20335. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  20336. C    IF(M.NE.(1+IDCB-IDBB))GOTO 300
  20337. C USE MODIFIED GMADD
  20338.     CALL GMADD(ID1A,ID2A,IDXA,IDXB,
  20339.      1  IDBA,IDBB,M,N)
  20340.     RETURN
  20341. 1700    CONTINUE
  20342. C MSUBV A,B,C  C=A-B
  20343.     IMXX=3
  20344.     IBGN=K+6
  20345.     RETCD=1
  20346.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  20347.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  20348.     N=1+ID1B-ID1A
  20349.     M=1+ID2B-ID2A
  20350. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  20351. C    IF(N.NE.(1+IDCA-IDBA))GOTO 300
  20352. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  20353. C    IF(M.NE.(1+IDCB-IDBB))GOTO 300
  20354.     CALL GMSUB(ID1A,ID2A,IDXA,IDXB,
  20355.      1  IDBA,IDBB,M,N)
  20356.     RETURN
  20357. 1800    CONTINUE
  20358. C MMPYT A,B,C  C=AT*B
  20359. C GET 3 MATRICES
  20360.     IMXX=3
  20361.     IBGN=K+6
  20362.     RETCD=1
  20363.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  20364.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  20365. C TRANSPOSE DIMENSIONS OF A...
  20366.     M=1+ID1B-ID1A
  20367.     N=1+ID2B-ID2A
  20368. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  20369.     L=1+IDYA-IDXA
  20370. C    IF(N.NE.(1+IDCB-IDBB))GOTO 300
  20371. C    IF(L.NE.(1+IDCA-IDBA))GOTO 300
  20372.     CALL GTPRD(ID1A,ID2A,IDXA,IDXB,
  20373.      1  IDBA,IDBB,N,M,L)
  20374.     RETURN
  20375. 1900    CONTINUE
  20376. C MMPYC A,B,K  B=A*K (K=CONSTANT)
  20377. C FOR MPY BY CONSTANT WE GET MATRICES IN ORDER A,C, THEN AC WITH CONST
  20378. C IN IT LAST...
  20379.     IBGN=K+6
  20380.     RETCD=1
  20381.     IMXX=2
  20382.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  20383.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  20384.     IF(LINE(IBGN-1).NE.',')GOTO 300
  20385.     LEND=IBGN+20
  20386.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,IDCA,IDCB,IVALID)
  20387.     IF(IVALID.EQ.0)GOTO 300
  20388. C NOW HAVE EVERYTHING OF ARGS... CHECK DIMENSIONS OF MATRICES....
  20389.     N=1+ID1B-ID1A
  20390.     M=1+ID2B-ID2A
  20391. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  20392. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  20393.     CALL XVBLGT(IDCA,IDCB,XXXX)
  20394.     DO 1901 NN=ID1A,ID1B
  20395.     DO 1901 MM=ID2A,ID2B
  20396.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  20397.     XVBLS(1,1)=XVBLS(1,1)*XXXX
  20398.     CALL XVBLST(NN-ID1A+IDXA,MM-ID2A+IDXB,XVBLS(1,1))
  20399. C    XVBLS(NN-ID1A+IDXA,MM-ID2A+IDXB)=XVBLS(NN,MM)
  20400. C     1    *XVBLS(IDCA,IDCB)
  20401. 1901    CONTINUE
  20402.     RETURN
  20403. C *U VARY X,A,W,I,P;Q;R;S;T
  20404. C  REPEATEDLY COMPUTE SHEET FOR I ITERATIONS (DEFAULTS TO 1
  20405. C  IF NONE GIVEN) AND VARY AC P,Q,R,S, T (POSITIONAL...WHATEVER
  20406. C  IS NAMED) UNTIL CONDITION THAT AC X (WHATEVER IS NAMED THERE)
  20407. C  IS MADE EQUAL TO AC A AS CLOSELY AS POSSIBLE. DOES MULTI-DIMENSIONAL
  20408. C  STEPPING SEARCH SAVING AC'S AND MODIFYING. ACTUALLY WILL HANDLE ANY
  20409. C  CELL. UP TO 8 DIMENSIONS PERMITTED (ARBITRARY LIMIT).
  20410. C  NOTE THAT RECALCULATE SPECIAL VARY FLAG WILL BE SET HERE IF
  20411. C  VARYING MORE THAN ONCE...
  20412. C  WILL VARY ONE OF THE AC'S IN THE LIST P,Q,R,S,T... BY INITIAL
  20413. C  FRACTION W (AN ARBITRARY "STEP SIZE" FRACTION) AND COMPUTE THE
  20414. C  GRADIENT OF (X-A) WRT THAT AC, THEN WILL REPLACE ALL AC'S AND
  20415. C  VARY THAT AC BY W * THE GRADIENT, MEANING THAT AS THE GRADIENT
  20416. C  DECREASES, THE VARIANCE DOES ALSO. LAST GRADIENTS ARE SAVED AND
  20417. C  USED AS INITIAL VARIANCES, SO THAT THE W FRACTION IS AN INITIAL
  20418. C  GUESS. HOWEVER IT ALSO IS A LIMIT SO NO STEP VARIES AN AC BY
  20419. C  MORE FRACTIONALLY THAN W.
  20420. C   ONCE THIS IS DONE ANOTHER ONE OF THE P,Q,R,S,T,... LIST IS
  20421. C  CHOSEN CIRCULARLY AND THE PROCESS REPEATS. THIS MAY CONTINUE
  20422. C  INDEFINITELY TO LOOK FOR CONVERGENCE.
  20423. C   NOTE THAT X AND A MAY BE ANY CELL AND NEED NOT BE ACCUMULATORS.
  20424. C  HOWEVER ALL OTHER CELLS TO VARY MUST BE AC'S AND MUST BE THE
  20425. C  INDEPENDENT VARIABLES. CALCULATIONS ELSEWHERE ON THE SHEET
  20426. C  (PERHAPS LATER IN THE SAME CELL...)MUST ESTABLISH DEPENDENT
  20427. C  VARIABLES OR BOUNDARY OR NORMALIZATION CONDITIONS.
  20428. 2000    CONTINUE
  20429.     RETCD=1
  20430. C SPLIT OFF THESE FUNCTIONS INTO A COMMON SUBROUTINE
  20431.     CALL VVARY(LINE,RETCD,K)
  20432.     RETURN
  20433. 2100    CONTINUE
  20434. C EXECUTE COMMAND. FILL IN COMMAND FROM GIVEN FUNCTION AND
  20435. C CALL XQTCMD TO DO IT. SETS UP NECESSARY VARIABLES FIRST.
  20436. C ASSUME THE COMMAND LINE MUST BE ALONE ON LINE AFTER THIS CALL...
  20437.     KK=1
  20438.     KKK=K+6
  20439.     DO 2101 NN=KKK,80
  20440.     XTNCMD(KK)=LINE(NN)
  20441.     IF(ICHAR(XTNCMD(KK)).LE.0)GOTO 2102
  20442.     KK=KK+1
  20443. 2101    CONTINUE
  20444. 2102    CONTINUE
  20445.     XTNCMD(KK+1)=char(0)
  20446.     XTNCMD(KK+2)=char(0)
  20447.     XTNCNT=KK
  20448.     XTCFG=1
  20449.     IPSET=1
  20450.     CALL XQTCMD(ICODE)
  20451.     RETURN
  20452. 2200    CONTINUE
  20453. C RETURN PACKED FORMULA STRING TO EXTRACT UP TO 8 CHARS OF
  20454. C FORMULA.
  20455. C START AT K+6
  20456.     XAC=0.
  20457.     IBGN=K+6
  20458.     IEND=IBGN+20
  20459.     CALL VARSCN(LINE,IBGN,IEND,LSTC,I1,I2,IVLD)
  20460.     IF(IVLD.LE.0)RETURN
  20461. C GET START, LENGTH NOW IN FORMULA...
  20462.     IBGN=LSTC+1
  20463.     IEND=IBGN+20
  20464.     CALL GN(IBGN,IEND,ISTART,LINE)
  20465.     IBGN=INDX(LINE,ICHAR(';'))
  20466. C LOOK FOR ';' CHAR AS START OF 2ND NUMBER
  20467.     IF(IBGN.GT.50.OR.ISTART.LE.0.OR.ISTART.GT.80)RETURN
  20468. C BUMP IBGN PAST THE ; CHAR
  20469.     IBGN=IBGN+1
  20470.     IEND=80
  20471.     CALL GN(IBGN,IEND,ILN,LINE)
  20472.     ILN=MIN0(ILN,8)
  20473.     IF(ILN.LE.0)RETURN
  20474. C READ IN FORMULA INTO WRK ARRAY
  20475. C    IRX=(I2-1)*60+I1
  20476.     CALL REFLEC(I2,I1,IRX)
  20477.     CALL WRKFIL(IRX,WRK2,0)
  20478.     CALL CE2A(WRK2,WRK)
  20479.     KZ=0
  20480.     DO 991 NN=1,ILN
  20481.     K=ICHAR(WRK(ISTART+NN-1))
  20482. C    K=K.AND.127
  20483.     IF(K.EQ.0)KZ=1
  20484.     IF(KZ.EQ.1)K=0
  20485. C STOP THE ENCODE ON SEEING ANY NULLS
  20486.     TMP=K
  20487.     XAC=XAC*128.D0+TMP
  20488. 991    CONTINUE
  20489. C XAC RETURNS WITH ENCODED VALUE.
  20490.     RETURN
  20491. 2300    CONTINUE
  20492. C RETURN PRESENT LOCATION IN THE MATRIX.
  20493.     TAC=PROW
  20494.     UAC=PCOL
  20495.     XAC=(PCOL-1)*MCols+PROW
  20496.     VAC=4*FORMFG+2*RCFGX+RCONE
  20497. C    VAC=(DROW-1)*20+DCOL
  20498. C RESULT IN % IS PHYS SHEET HASHCODE
  20499. C RESULT IN V ACCUMULATOR IS DISPLAY SHEET LOC HASHCODE
  20500. C T AND U ACCUMULATORS GET PHYS COL, ROW OFFSET.
  20501.     WAC=RRWACT
  20502.     YAC=RCLACT
  20503. C W AND Y GET LIMITS CURRENTLY USED
  20504.     RETURN
  20505. 2400    CONTINUE
  20506. C YRMOD
  20507.     RETCD=1
  20508.     IBGN=K+6
  20509.     LEND=IBGN+20
  20510.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20511.     IF(IVALID.EQ.0)GOTO 9300
  20512.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20513.     IBGN=LSTCHR+1
  20514.     LEND=IBGN+20
  20515.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20516.     IF(IVALID.EQ.0)GOTO 9300
  20517.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20518.     IBGN=LSTCHR+1
  20519.     LEND=IBGN+20
  20520.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
  20521.     IF(IVALID.EQ.0)GOTO 9300
  20522. C
  20523. C V1, V2, V3 ARE YR, MONTH, DAY FOR RETURN OF JULIAN DATE
  20524. C
  20525.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20526.     IYR=XVBLS(1,1)
  20527.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  20528.     IMO=XVBLS(1,1)
  20529.     CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
  20530.     IDA=XVBLS(1,1)
  20531. C RETURN JULIAN DATE FROM Y, M, D GIVEN
  20532.     XAC=JULMDY(IYR,IMO,IDA)
  20533.     RETURN
  20534. 2500    CONTINUE
  20535. C JDATE
  20536.     RETCD=1
  20537.     IBGN=K+6
  20538.     LEND=IBGN+20
  20539. C GET V1 WHICH HAS VARIABLE WITH THE STRING IN IT
  20540.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20541.     IF(IVALID.EQ.0)GOTO 9300
  20542. C RETURN JULIAN DATE NOW AFTER FETCHING FORMULA.
  20543. C    IRX=(ID2A-1)*60+ID1A
  20544.     CALL REFLEC(ID2A,ID1A,IRX)
  20545.     CALL WRKFIL(IRX,WRK,0)
  20546.     XAC=JULIAN(WRK)
  20547.     RETURN
  20548. 2600    CONTINUE
  20549. C JTOCH
  20550.     RETCD=1
  20551.     IBGN=K+6
  20552.     LEND=IBGN+20
  20553. C V1 = JULIAN DATE
  20554. C V2 IS WHERE TO STORE ASCII DATE STRING AS FORMULA.
  20555.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20556.     IF(IVALID.EQ.0)GOTO 9300
  20557.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20558.     IBGN=LSTCHR+1
  20559.     LEND=IBGN+20
  20560.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20561.     IF(IVALID.EQ.0)GOTO 9300
  20562.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20563.     IJUL=XVBLS(1,1)
  20564. C    IRX=(ID2B-1)*60+ID1B
  20565.     CALL REFLEC(ID2B,ID1B,IRX)
  20566.     CALL WRKFIL(IRX,WRK,0)
  20567.     DO 2502 N=1,110
  20568. 2502    WRK(N)=char(0)
  20569.     CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
  20570.     CALL WRKFIL(IRX,WRK,1)
  20571. C WRITE THE FORMULA BACK OUT
  20572.     TAC=IMO
  20573.     UAC=IDA
  20574.     VAC=IYR
  20575. C RETURN T,U,V AS M,D,Y ALSO
  20576.     RETURN
  20577. 2700    CONTINUE
  20578. C DATE
  20579.     RETCD=1
  20580.     IBGN=K+5
  20581.     LEND=IBGN+20
  20582.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20583.     IF(IVALID.EQ.0)GOTO 9300
  20584.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20585.     IBGN=LSTCHR+1
  20586.     LEND=IBGN+20
  20587.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20588.     IF(IVALID.EQ.0)GOTO 9300
  20589.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20590.     IBGN=LSTCHR+1
  20591.     LEND=IBGN+20
  20592.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
  20593.     IF(IVALID.EQ.0)GOTO 9300
  20594.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20595.     IBGN=LSTCHR+1
  20596.     LEND=IBGN+20
  20597.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1D,ID2D,IVALID)
  20598.     IF(IVALID.EQ.0)GOTO 9300
  20599.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20600.     IYR=XVBLS(1,1)
  20601.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  20602.     IMO=XVBLS(1,1)
  20603.     CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
  20604.     IDA=XVBLS(1,1)
  20605. C    IRX=(ID2D-1)*60+ID1D
  20606.     CALL REFLEC(ID2D,ID1D,IRX)
  20607.     CALL WRKFIL(IRX,WRK,0)
  20608.     DO 2702 N=1,110
  20609. 2702    WRK(N)=char(0)
  20610.     IJUL=JULMDY(IYR,IMO,IDA)
  20611.     CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
  20612.     CALL WRKFIL(IRX,WRK,1)
  20613.     GOTO 9300
  20614. 2900    CONTINUE
  20615.     RETCD=1
  20616. C WKDYS - GIVE WEEKDAYS (M-F) BETWEEN 2 JULIAN DATES THAT MUST
  20617. C BE IN CELLS.
  20618.     IBGN=K+6
  20619.     LEND=IBGN+20
  20620.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20621.     IF(IVALID.EQ.0)GOTO 9300
  20622.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20623.     IBGN=LSTCHR+1
  20624.     LEND=IBGN+20
  20625.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20626.     IF(IVALID.EQ.0)GOTO 9300
  20627.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20628.     IYR=XVBLS(1,1)
  20629.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  20630.     IMO=XVBLS(1,1)
  20631. C IYR HOLDS START JULIAN DATE, IMO HOLDS END ONE
  20632.     CALL WKDY(IYR,IMO,IDA)
  20633. C IDA = NUMBER WORK DAYS BETWEEN THE DATES
  20634.     XAC=IDA
  20635. C RETURN DAYS
  20636.     GOTO 9300
  20637. 3000    CONTINUE
  20638.     RETCD=1
  20639. C WKDIN - GIVEN A JULIAN DATE AND A NUMBER WORKDAYS, RETURN THE
  20640. C ENDING JULIAN DATE AFTER THAT NUMBER JULIAN DAYS.
  20641.     IBGN=K+6
  20642.     LEND=IBGN+20
  20643.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20644.     IF(IVALID.EQ.0)GOTO 9300
  20645.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  20646.     IBGN=LSTCHR+1
  20647.     LEND=IBGN+20
  20648.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20649.     IF(IVALID.EQ.0)GOTO 9300
  20650.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  20651.     IYR=XVBLS(1,1)
  20652.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  20653.     IMO=XVBLS(1,1)
  20654. C IYR = START DATE, JULIAN. IMO = NUMBER DAYS. RETURN END DATE JULIAN.
  20655.     CALL WRKINT(IYR,IMO,IDA)
  20656. C IDA = RETURN JULIAN DATE
  20657.     XAC=IDA
  20658.     GOTO 9300
  20659. 3100    CONTINUE
  20660. C FFTFW
  20661.     ISI=1
  20662.     GOTO 3210
  20663. 3200    CONTINUE
  20664. C FFTRV
  20665.     ISI=-1
  20666. 3210    CONTINUE
  20667.     RETCD=1
  20668. C MERGED FFT CODE
  20669. C *U FFTFW V1:V2 DOES FFT OF RANGE GIVEN (1-DIM)
  20670. C DITTO FFTRV BUT ONE IS REVERSE AND ONE IS FORWARD FFT
  20671. C REAL*8 FFT ROUTINE USED.
  20672.     IBGN=K+6
  20673.     CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
  20674.      1  IV,IV,IV,IV,IV,IV,IV,IV)
  20675.     IC=0
  20676.     IR=1
  20677.     IF(IR1T.EQ.IR1B)GOTO 3220
  20678.     IC=1
  20679.     IR=0
  20680. 3220    CONTINUE
  20681.     KK=IABS(IR1T-IR1B)+1
  20682.     KKK=IABS(IC1T-IC1B)+1
  20683.     IV=MAX0(KK,KKK)
  20684. C IV = NO. POINTS.
  20685.     CALL FOUREA(IR1T,IC1T,IC,IR,IV,ISI)
  20686. C THAT'S ALL FOR FFT. REPLACES CELLS IN PLACE...
  20687.     GOTO 9300
  20688. 3300    CONTINUE
  20689. C LINEF
  20690. C *U LINEF VY1:VY2[,VX1:VX2]
  20691. C WHERE X COORDS CAN BE SKIPPED...
  20692.     IBGN=K+6
  20693.     RETCD=1
  20694. C JUST GET 2 MATRICES' VALUES. IF RETCD=3 ON RETURN, 2ND MATRIX MUST HAVE
  20695. C BEEN MISSING SO FLAG IT THAT WAY.
  20696.     CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
  20697.      1  IR2B,IC2B,KK,KK,KK,KK)
  20698.     IF(RETCD.NE.1)IR2T=-1
  20699.     RETCD=1
  20700.     KK=IABS(IR1T-IR1B)+1
  20701.     KKK=IABS(IC1T-IC1B)+1
  20702.     IV=MAX0(KK,KKK)
  20703.     KK=0
  20704.     IF(IR1T.EQ.IR1B)GOTO 3320
  20705.     KK=1
  20706. 3320    CONTINUE
  20707.     CALL LINFIT(IR2T,IC2T,KK,IR1T,IC1T,IV,TAC,UAC,XAC,WAC)
  20708. C RETURN A VALUE IN T, B VALUE IN U, AND DEL VALUE IN %.
  20709. C FOR Y = A + BX
  20710. C W AC RETURNS CORRELATION COEFFICIENT.
  20711.     GOTO 9300
  20712. 3400    CONTINUE
  20713. C *U DBxxxx FUNCTIONS PARSED EXTERNALLY
  20714. C (SAVES MUCH SPACE AND EASES MODIFICATION...)
  20715.     RETCD=1
  20716.     CALL DTRFCT(LINE(K+2),RETCD)
  20717.     GOTO 9300
  20718. 3500    CONTINUE
  20719. C *U STxxxx FUNCTIONS
  20720.     RETCD=1
  20721. C K SHOULD BE SUBSCRIPT OF THE 'S' OF "ST" SO SKIP BY THE
  20722. C "ST" PART AND JUST PASS THE REST OF THE FUNCTION NAME AT THE
  20723. C START OF THE STRING...
  20724.     CALL SCIFCT(LINE(K+2),RETCD)
  20725. C HANDLE ALL *U STXXXX FUNCTIONS IN SEPARATE ROUTINE FOR EASE OF
  20726. C MOVING IT AROUND. (MIGHT EVEN GO BACK TO PDP11!)
  20727. C    GOTO 9300
  20728. 9300    RETURN
  20729.     END
  20730. c -h- scifct.fam
  20731. C SCIENTIFIC FUNCTION CALLER
  20732. C This version is a dummy placeholder.
  20733. C The SCIFCT subroutine exists to allow AnalytiCalc to call just
  20734. C about *ANY* Fortran callable routine.
  20735. C   The operation is to use a formula in AnalytiCalc which includes
  20736. c a call of form:
  20737. c  *U STxxxxxx range;range;range;range;range;...;range>outrange;outrange;outrange
  20738. c so that the "xxxxxx" part is the function name to be called.
  20739. c  input ranges are the parts of the sheet for input to the function; these
  20740. c are internally copied to a large array (defined here) which is a normal
  20741. c Fortran array. They are converted to integer*4 as needed if the function
  20742. c being called needs this. Once all conversion is done, the subroutine is
  20743. c called using an argument list built up by this call list. At the end,
  20744. c the output ranges are filled in from the internal Fortran array.
  20745. c   Because Fortran callable subroutines (e.g. those in the SSP) may pass
  20746. c their return arguments in ANY of their arguments, seeing a ; will increment
  20747. c the output range counter.
  20748. c
  20749. c To add more:
  20750. c  * Select desired sizes for work area (must be big enough to hold ALL
  20751. c  arguments used), max number of arguments per function, etc.
  20752. c  * Add new function name and characteristics to tables. Note that the
  20753. c  name, integer/float stuff for all args, which arg is first OUTPUT arg,
  20754. c  and map of output args, all are needed. Don't make first output arg
  20755. c  bigger than the max. number of args.
  20756. c  * Add another call and element in the computed GOTO for each function
  20757. c  desired.
  20758. c  * Build and enjoy.
  20759. c
  20760. c   Internally we need tables of
  20761. c      * Function names (up to 6 characters long per classical Fortran rules)
  20762. c      * Number of arguments needed per function
  20763. c      * Integer/real flags for arguments' data types
  20764. c      * First output argument number (user convenience and less error
  20765. c           prone than having to have a bunch of ;;;;'s to force the
  20766. c           outputrange to come from the right area
  20767. c      * Length of the Fortran array used for each input argument
  20768. c Note: Provision is made for "scratch array" arguments, but is a bit
  20769. c  crude. However, if extra space is needed, user can specify a larger
  20770. c  input area and the larger chunk of scratch space will be present.
  20771. c  Unused argument areas will generally be zeroed on each call.
  20772. c   It is perfectly reasonable to have input-only functions (e.g. plots)
  20773. c   or several subroutines called in sequence for a function.
  20774. c
  20775.     SUBROUTINE SCIFCT(LINE,RETCD)
  20776.     Integer BigSpc
  20777.     Parameter (BigSpc=256)
  20778.     Parameter (MaxArgs=10)
  20779.     Parameter (NFCT=3)
  20780. c NFCT is number of functions included in the list. Update the parameter
  20781. c and the tables together (please!)
  20782.     INTEGER RETCD
  20783.     Character*1 LINE(80)
  20784.     Real*8 ArgAry(BigSpc)
  20785.     INTEGER*4 IARGAR(2,BIGSPC)
  20786.     EQUIVALENCE(IARGAR(1,1),ARGARY(1))
  20787.     Integer*4 ArgCtr,IntPar
  20788.     Integer*4 ArgPtr(MaxArgs)
  20789.     Integer*4 NARGin(NFct)
  20790. c nargin is number input args needed.
  20791.     Integer*4 OutArg(MaxArgs,NFct)
  20792.     Integer*4 OutBgn(NFct)
  20793. c OutArg is 0 for no output, 1 for output area
  20794.     Integer*4 RevStr(MaxArgs,NFct)
  20795. c RevStr will be nonzero to reverse storage of arrays
  20796. c from normal row-first to column-first order.
  20797.     Integer*4 IsReal(MaxArgs,NFCT)
  20798. c
  20799. C Since there are some subs that need dummy argument scratch
  20800. c areas, encode IsReal as follows:
  20801. c  0 = Real
  20802. c  -1 = Integer
  20803. c  +nn = Use argument nn's VALUE (after grabbing it) for
  20804. c        size of area to allocate. Always allocate floats
  20805. c        since they're longer.
  20806. c
  20807. c Note: Due to the way the program allocates scratch array, the
  20808. c  arguments with size info for dummy arrays must be present
  20809. c  ahead of the scratch space arguments.
  20810. c
  20811. C Argument coordinate lists
  20812.     Integer*4 InCord(4,MaxArgs)
  20813. c    Integer*4 InType(MaxArgs)
  20814.     Integer*4 OutCor(4,MaxArgs)
  20815.     REAL*8 R8WRK
  20816.     INTEGER*4 I4WRK
  20817. c    Integer*4 OutTyp(MaxArgs)
  20818. c
  20819.     Character*6 WrkFnm
  20820.     Character*1 WFNm(6)
  20821.     Equivalence(WFNm(1),WrkFnm)
  20822. c    Integer*4 IniOut(NFCT)
  20823.     Integer*4 AryPtr
  20824.     Character*6 FName(NFCT)
  20825.     Character*1 FNameB(6,NFCT)
  20826.     Equivalence(Fname(1),FNameB(1,1))
  20827. c allows access of function names by byte, but data stmts to set up
  20828. c as full names...
  20829. c    This example has only 2 functions:
  20830. c  *U STDLLSQ   and
  20831. c  *U STCHISQ
  20832. c        from the Scientific Subroutine Package library...
  20833.     save fnameb,isreal,outbgn,outarg,nargin,revstr
  20834.     Data FnameB/
  20835.      1  'D','L','L','S','Q',0,
  20836.      2  'C','H','I','S','Q',0,
  20837.      3  'V','E','C','N','O','R' /
  20838.     DATA IsReal/
  20839.      1  0,0,-1,-1,-1,0,5,0,-1,0,
  20840.      2  0,-1,-1,0,-1,-1,2,3,0,0,
  20841.      3  0,-1,0,0,0,0,0,0,0,0  /
  20842.     DATA OutBgn/
  20843.      1  6,4,3 /
  20844.     DATA OutArg/
  20845.      1  0,0,0,0,0,1,0,0,1,1,
  20846.      2  0,0,0,1,1,1,0,0,0,0,
  20847.      3  0,0,1,0,0,0,0,0,0,0 /
  20848. c Note OutArg is just which output arguments are really
  20849. c output data. 1 means they are, 0 means they're not.
  20850. c
  20851. C NARGIN is min number input arguments that must be present.
  20852.     Data NARGin/10,8,3/
  20853.     Data RevStr/
  20854.      1  0,0,0,0,0,0,0,0,0,0,
  20855.      2  0,0,0,0,0,0,0,0,0,0,
  20856.      3  0,0,0,0,0,0,0,0,0,0/
  20857. C
  20858. C FIRST, before we spend a lot of effort grabbing arguments, make
  20859. c  sure we know about the function to be called. If we don't, just
  20860. c  return an error.
  20861.     KK=0
  20862.     DO 101 N=1,NFCT
  20863.     DO 110 NN=1,6
  20864.     IF(Ichar(FNAMEB(NN,N)).LE.0)GOTO 110
  20865.     IF(LINE(NN).NE.FNAMEB(NN,N)) GOTO 112
  20866. 110    CONTINUE
  20867. C WE FELL THRU AND FOUND THE NAME. SAVE ITS' INDEX.
  20868.     KK=N
  20869. 112    CONTINUE
  20870. 101    CONTINUE
  20871.     IF(KK.GT.0)GOTO 115
  20872. 114    RETCD=3
  20873.     RETURN
  20874. 115    CONTINUE
  20875.     NFUNCT=KK
  20876. c A little setup...
  20877.     ArgCtr=1
  20878.     IntPar=1
  20879. c integer "parity", used to pack integer args in work array
  20880.     Aryptr=1
  20881.     Do 1 n=1,MaxArgs
  20882.     Argptr(n)=1
  20883.     Do 11 nn=1,4
  20884.     InCord(nn,n)=0
  20885.     OutCor(nn,n)=0
  20886. 11    Continue
  20887. 1    CONTINUE
  20888.     DO 2 N=1,BigSpc
  20889.     ArgAry(N)=0.0D0
  20890. 2    Continue
  20891. C arrange for all uninitialized numbers to contain zeroes
  20892.     RETCD=1
  20893. C HANDLE *U STXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
  20894. C STARTS AFTER THE "ST" SO WE CAN DECODE IT.
  20895. c if we can't get the function, return RETCD=3...
  20896. c
  20897. c Now grab the arguments and store them in InCord, Intype, OutCor, OutTyp
  20898.     K=INDXQ(LINE,32)
  20899. C FIND STUFF AFTER SPACE
  20900.     K=K+1
  20901.     NArg=1
  20902.     IBGN=1
  20903. 100    Continue
  20904.     LEND=IBGN+20
  20905. C GET LOC OF MATRIX A (MUST BE SQUARE)
  20906.     ID1B=0
  20907.     ID2B=0
  20908.     ID1A=0
  20909.     ID2A=0
  20910.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20911.     IF(IVALID.EQ.0)GOTO 300
  20912.     IF(LINE(K+LSTCHR-1).NE.':')GOTO 1000
  20913.     IBGN=LSTCHR+1
  20914.     LEND=IBGN+20
  20915.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20916.     IF(IVALID.EQ.0)GOTO 300
  20917. 1000    CONTINUE
  20918. C GMTX GETS ARGS FOR ONE RANGE
  20919.     InCord(1,NArg)=ID1A
  20920.     InCord(2,NArg)=ID2A
  20921.     INCord(3,NARG)=ID1B
  20922.     INCORD(4,NARG)=ID2B
  20923.     IBGN=LSTCHR+1
  20924.     NARG=NARG+1
  20925.     IF(LINE(K+LSTCHR-1).EQ.';')GOTO 100
  20926. C
  20927. 300    CONTINUE
  20928. C NOW HAVE ALL ARGS FOR INPUT COLLECTED
  20929.     INARGS=NARG
  20930.     If(INargs.lt.NARGin(NFunct)) GOTO 114
  20931. c Flag error if not enough input args presented.
  20932.     K=INDXQ(LINE,62)
  20933. C FIND STUFF AFTER > CHARACTER
  20934.     IF(K.EQ.0.OR.K.GT.70)GOTO 500
  20935. C MUST HAVE A > OR no outputs are present.
  20936. C This is perfectly legal; outputs like graphs or auxiliary
  20937. C files (unknown to rest of program) are possible too.
  20938.     K=K+1
  20939.     NArg=1
  20940.     IBGN=1
  20941. 400    Continue
  20942.     LEND=IBGN+20
  20943. C GET LOC OF MATRIX A (MUST BE SQUARE)
  20944.     ID1B=0
  20945.     ID2B=0
  20946.     ID1A=0
  20947.     ID2A=0
  20948. C TEST FOR NULL ARGUMENT (;; PAIR)
  20949.     IF(LINE(K+IBGN-1).EQ.';')GOTO 450
  20950.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  20951.     IF(IVALID.EQ.0)GOTO 500
  20952.     IF(LINE(K+LSTCHR-1).NE.':')GOTO 1500
  20953.     IBGN=LSTCHR+1
  20954.     LEND=IBGN+20
  20955.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  20956.     IF(IVALID.EQ.0)GOTO 500
  20957. 1500    CONTINUE
  20958.     IBGN=LSTCHR+1
  20959.     GOTO 455
  20960. 450    CONTINUE
  20961.     IBGN=IBGN+1
  20962.     LSTCHR=IBGN
  20963. C PASS ;
  20964. 455    CONTINUE
  20965. C GMTX GETS ARGS FOR ONE RANGE
  20966.     OUTCor(1,NArg)=ID1A
  20967.     OUTCor(2,NArg)=ID2A
  20968.     OUTCor(3,NARG)=ID1B
  20969.     OUTCor(4,NARG)=ID2B
  20970.     NARG=NARG+1
  20971.     IF(LINE(K+LSTCHR-1).EQ.';')GOTO 400
  20972. C    GOTO 500
  20973. C
  20974. 500    CONTINUE
  20975. C NOW HAVE OUTPUT ARGUMENT LIST COLLECTED
  20976. C BEGIN COLLECTING DATA
  20977.     NARG=1
  20978.     IntPar=1
  20979. 2000    CONTINUE
  20980.     IACNTR=ARGCTR
  20981. C  GET INPUT DATA INTO OUR BIG ARRAY
  20982.     IF(INCORD(1,NARG).LE.0)GOTO 3000
  20983.     ARGPTR(NARG)=ARGCTR
  20984.     IF(INCORD(3,NARG).NE.0)GOTO 2011
  20985. C SINGLE ARGUMENT; GRAB IT
  20986.     nn=incord(1,narg)
  20987.     mm=incord(2,narg)
  20988.     call typget(nn,mm,itype)
  20989.     If(Itype.ne.4) then
  20990.       CALL XVBLGT(NN,MM,R8WRK)
  20991.     Else
  20992.       Call JVBLGT(NN,MM,I4wrk)
  20993.       R8WRK=I4WRK
  20994.     End If
  20995. c    CALL XVBLGT(INCORD(1,NARG),INCORD(2,NARG),R8WRK)
  20996.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  20997.       INTPAR=1
  20998.       I4WRK=R8WRK
  20999.       IARGAR(IntPar,ARGCTR)=I4WRK
  21000.     ELSE
  21001.       If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21002.       IntPar=1
  21003. C if we last packed the second word of an integer, bump to next
  21004.       ARGARY(ARGCTR)=R8WRK
  21005.     END IF
  21006.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21007.     NARG=NARG+1
  21008.     GOTO 2000
  21009. 2011    CONTINUE
  21010. C 2-D AREA
  21011.     IntPar=1
  21012.     DO 2020 LNN=INCORD(1,NARG),INCORD(3,NARG)
  21013.     DO 2020 LMM=INCORD(2,NARG),INCORD(4,NARG)
  21014.     NN=LNN
  21015.     IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
  21016.     MM=LMM
  21017.     IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
  21018.     call typget(nn,mm,itype)
  21019.     If(Itype.ne.4) then
  21020.       CALL XVBLGT(NN,MM,R8WRK)
  21021.     Else
  21022.       Call JVBLGT(1,NN,MM,I4wrk)
  21023.       R8WRK=I4WRK
  21024.     End If
  21025.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  21026.       I4WRK=R8WRK
  21027.       IARGAR(IntPar,ARGCTR)=I4WRK
  21028.       IntPar=3-IntPar
  21029. c if IntPar is 1 make it 2; if it's 2, make it 1
  21030.     ELSE
  21031.       If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21032.       IntPar=1
  21033. C if we last packed the second word of an integer, bump to next
  21034.       ARGARY(ARGCTR)=R8WRK
  21035.     END IF
  21036.     If(IntPar.eq.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21037. 2020    CONTINUE
  21038.     NARG=NARG+1
  21039.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21040.     IntPar=1
  21041. C
  21042. C FIX UP DUMMY ARGUMENTS
  21043. C
  21044.     IF(ISREAL(NARG,NFUNCT).GT.0.AND.ISREAL(NARG,NFUNCT)
  21045.      1  .LE.MAXARGS) THEN
  21046. c If user allocated more space than the dummy calc, use bigger
  21047. c allocation. However, add a little more and check for array
  21048. c overflow.
  21049.       ARGCTR=MAX0(ARGCTR,IACNTR+IARGAR(1,ISREAL(NARG,NFUNCT)))
  21050.       ARGCTR=ARGCTR+30
  21051.       ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21052. C ADD A LITTLE FOR GOOD LUCK
  21053.     END IF
  21054.     GOTO 2000
  21055. 3000    CONTINUE
  21056. C NOW SHOULD BE READY TO CALL THIS STUFF...
  21057. C GENERATE CALLS LIKE THE TEMPLATES BELOW. NO NEED TO MODIFY
  21058. C THE FUNCTIONS, BUT WE DO NEED TO MESS WITH THIS STUFF BECAUSE
  21059. C I DON'T KNOW OFFHAND HOW TO DO A DYNAMIC CALLING LIST IN FORTRAN
  21060. C THAT'LL WORK ON STACK IMPLEMENTATIONS.
  21061. c
  21062. c Add more numbers to the list here to get more function calls.
  21063. c
  21064.     GOTO (4001,4002,4003),NFUNCT
  21065.     RETCD=3
  21066.     RETURN
  21067. c *************** BEGINNING OF CALLS ****************
  21068. 4001    CONTINUE
  21069. C DLLSQ FUNCTION.... 10 ARGS
  21070.     CALL DLLSQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  21071.      1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
  21072.      2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)),
  21073.      3  ARGARY(ARGPTR(9)),ARGARY(ARGPTR(10)))
  21074.     GOTO 5000
  21075. 4002    CONTINUE
  21076. C CHISQ FUNCTION.... 8 ARGS
  21077.     CALL CHISQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  21078.      1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
  21079.      2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)))
  21080.     GOTO 5000
  21081. 4003    CONTINUE
  21082. C Vector Norm function
  21083.     CALL VECNOR(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  21084.      1  ARGARY(ARGPTR(3)))
  21085. C Use this for debugging too...
  21086. c
  21087. c insert more function calls here... they all look alike except for
  21088. c function name.
  21089. c
  21090. c  It's also completely permissible to call several Fortran subroutines
  21091. c  in sequence here if it makes sense; it's up to the user. This code
  21092. c  just gives a way to call unmodified Fortran callable code and have
  21093. c  it make sense in the AnalytiCalc context. ANY Fortran callable code
  21094. c  is OK.
  21095. c
  21096. c *****************end of calls *****************
  21097. c
  21098. 5000    CONTINUE
  21099. C NOW GET ARGUMENTS BACK TO DUMP TO SHEET
  21100.     KARG=0
  21101.     DO 5100 NARG=OUTBGN(NFUNCT),MAXARGS
  21102.     KARG=KARG+1
  21103.     IF(OUTARG(NARG,NFUNCT).LE.0)GOTO 5100
  21104.     IF(OUTCOR(1,KARG).EQ.0)GOTO 5100
  21105. C +++
  21106.     ARGCTR=ARGPTR(NARG)
  21107.     IF(OUTCOR(3,KARG).NE.0)GOTO 6014
  21108. C SINGLE ARGUMENT; GRAB IT
  21109.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  21110.       I4WRK=IARGAR(1,ARGCTR)
  21111.       R8WRK=I4WRK
  21112.     ELSE
  21113.       R8WRK=ARGARY(ARGCTR)
  21114.     END IF
  21115.     nn=outcor(1,karg)
  21116.     mm=outcor(2,karg)
  21117.     Call typget(nn,mm,itype)
  21118.     If (Itype.ne.4) then
  21119.       CALL XVBLST(NN,MM,R8WRK)
  21120.     Else
  21121.       I4WRK=R8WRK
  21122.       CALL JVBLST(1,nn,mm,I4WRK)
  21123.     End If
  21124.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21125.     GOTO 5100
  21126. 6014    CONTINUE
  21127. C 2-D AREA
  21128.     DO 6020 LNN=OUTCOR(1,KARG),OUTCOR(3,KARG)
  21129.     DO 6020 LMM=OUTCOR(2,KARG),OUTCOR(4,KARG)
  21130.     NN=LNN
  21131.     IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
  21132.     MM=LMM
  21133.     IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
  21134.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  21135.       I4WRK=IARGAR(1,ARGCTR)
  21136.       R8WRK=I4WRK
  21137.     ELSE
  21138.       R8WRK=ARGARY(ARGCTR)
  21139.     END IF
  21140.     Call typget(nn,mm,itype)
  21141.     If (Itype.ne.4) then
  21142.       CALL XVBLST(NN,MM,R8WRK)
  21143.     Else
  21144.       I4WRK=R8WRK
  21145.       CALL JVBLST(1,nn,mm,I4WRK)
  21146.     End If
  21147. c    CALL XVBLST(NN,MM,R8WRK)
  21148.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  21149. 6020    CONTINUE
  21150. C +++
  21151. 5100    CONTINUE
  21152. C AT LAST, DONE
  21153.     RETURN
  21154.     END
  21155.     Subroutine VecNor(InRng,NVEC,Val)
  21156. C test subroutine
  21157. c Computes norm of input range, where NVEC is number of
  21158. c elements in the INRNG array.
  21159.     REAL*8 InRng
  21160.     Dimension InRng(1)
  21161.     Integer*4 NVEC
  21162.     Real*8 Val,X
  21163. C    VAL=0.0d0
  21164.     If(NVEC.LE.0)val=-1.0
  21165.     If(NVEC.LE.0)return
  21166. c return -1 if bad dimensions.
  21167.     X=0.0D0
  21168.     Do 1 n=1,nvec
  21169.     x=x+InRng(n)*InRng(n)
  21170. 1    Continue
  21171.     x=dsqrt(x)
  21172.     Val=X
  21173.     Return
  21174.     End
  21175. c -h- JunkDum.for
  21176. c completely dummy versions of dllsq and chisq
  21177. C REMOVE these if you want to use the real ones (from
  21178. c the SSP library)
  21179.     Subroutine DLLSQ(A,B,C,D,E,F,G,H,I,J)
  21180.     RETURN
  21181.     END
  21182.     SUBROUTINE CHISQ(A,B,C,D,E,F,G,H)
  21183.     RETURN
  21184.     END
  21185. c -h- uvtgen.for    Fri Aug 22 13:36:30 1986    
  21186. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  21187. C ALL RIGHTS RESERVED
  21188. C
  21189. C    VT100 VIDEO DISPLAY COMMAND PROGRAM. CALLING SEQUENCE IS
  21190. C    CALL UVT100(CMD,N1,N2THE MANDS IN
  21191. C    THE PARAMETER LIST BELOW, AND N1 AND N2 ARE OPTIONAL PARAMETERS
  21192. C    DEPENDING UPON CMD. SEE THE UVT100 USER'S MANUAL FOR MORE DETAILS.
  21193. C
  21194. C
  21195. C BLACK AND WHITE SCREEN MODULE FOR ANSI TERMINALS
  21196. C ALSO COLOR SCREEN MODULE.
  21197. C COMMANDS 20 AND 21 SWITCH: 20 SETS B+W, 21 SETS COLOR MODE
  21198. C
  21199. C THIS VERSION MODIFIED FOR USE WITH AnalytiCalc.
  21200. C  ENTRIES NOT USED ARE DELETED, AND ALSO CODE ADDED TO SUPPORT COLOR
  21201. C  CRT'S THAT ARE BASICALLY VT100-LIKE WITH EXTENSIONS, OR VT100'S OR
  21202. C  EMULATORS WITH AVO OPTION.
  21203. C
  21204. C  OPERATION:
  21205. C    ON B+W VT100'S (WITH ADVANCED VIDEO), THE SET GRAPHICS CODES
  21206. C WILL BE USED AS FOLLOWS:
  21207. C  ALTERNATE ROWS WILL BE DISPLAYED IN BOLD
  21208. C  (ROW 3 TO 22 ONLY HOWEVER; THE REST IS NOT MATH AREA)
  21209. C COMMAND AND DISPLAY ROWS (23 AND 24 NORMALLY) WILL BE BOLDED ALWAYS.
  21210. C
  21211. C  IN COLOR MODE:
  21212. C    ON ED, SET BACKGROUND COLOR TO DARK BLUE
  21213. C    ALTERNATE ROWS WILL BE SET TO YELLOW OR GREEN
  21214. C  COLUMN LABEL ROW, LABEL ROW, AND ROW LABELS, AND COMMAND PROMPTS,
  21215. C  IN A DIFFERENT COLOR FOR EACH. DETERMINED AND SET AT TIME OF
  21216. C  CALL TO CURSOR POSITION.
  21217. C
  21218. C    AUTHOR:    GLENN EVERHART
  21219. C
  21220.       SUBROUTINE UVT100 ( CMD, N1, N2 )
  21221.       IMPLICIT INTEGER ( A - Z )
  21222. c    Include aparms.inc
  21223. c      DIMENSION PRL ( 6 )
  21224. C NOTE WE DECLARE THESE VARIABLES USED IN PORTACALC. THEY ARE ALL IN
  21225. C COMMONS, SO WE ADD NOTHING TO LENGTH OF THIS PROGRAM BY ADDING THEM.
  21226.     CHARACTER*1 FVLD
  21227. cc    external cmove,cattron,cread !$pragma C(cmove,cattron,cread)
  21228. cc    external ccleareol,cclear,crefresh !$pragma C(ccleareol,cclear,crefresh)
  21229. cc    external cattroff,cclose,copen !$pragma C(cattroff,cclose,copen)
  21230. cc    external cwrite !$pragma C(cwrite)
  21231.     DIMENSION FVLD(1,1)
  21232.     COMMON /FVLDC/FVLD
  21233. C ***<<<< RDD COMMON START >>>***
  21234.     InTeGer*4 RRWACT,RCLACT
  21235. C    COMMON/RCLACT/RRWACT,RCLACT
  21236.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  21237.      1  IDOL7,IDOL8
  21238. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  21239. C     1  IDOL7,IDOL8
  21240.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  21241. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  21242.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21243. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21244. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  21245. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  21246.     InTeGer*4 KLVL
  21247. C    COMMON/KLVL/KLVL
  21248.     InTeGer*4 IOLVL,IGOLD
  21249. C    COMMON/IOLVL/IOLVL
  21250. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  21251. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  21252.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21253.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21254.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  21255.      3  k3dfg,kcdelt,krdelt,kpag
  21256. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21257. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21258. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  21259. C ***<<< RDD COMMON END >>>***
  21260. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  21261. CCC    InTeGer*4 LLCMD,LLDSP
  21262. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  21263.     InTeGer*4 TYPE(1,2),VLEN(9)
  21264.     REAL*8 XVBLS(1,1)
  21265.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  21266.     Real*8 VAVBLS(3,27)
  21267.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  21268.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  21269.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  21270. C ICPOS COMMON HAS PHYS COORDS BEING DISPLAYED. MUST QUERY FVLD TO
  21271. C SEE WHETHER TO INTENSIFY THE FIELD FOR NEGATIVE...
  21272. C ***<<< XVXTCD COMMON START >>>***
  21273.     CHARACTER*1 OARRY(100)
  21274.     InTeGer*4 OSWIT,OCNTR
  21275. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  21276. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  21277.     InTeGer*4 IC1POS,IC2POS,MODFLG
  21278. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  21279.        InTeGer*4 XTCFG,IPSET,XTNCNT
  21280.        CHARACTER*1 XTNCMD(80)
  21281. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  21282. C VARY FLAG ITERATION COUNT
  21283.     INTEGER KALKIT
  21284. C    COMMON/VARYIT/KALKIT
  21285.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  21286.     InTeGer*4 RCMODE,IRCE1,IRCE2
  21287. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  21288. C     1  IRCE2
  21289. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  21290. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  21291. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  21292. C RCFGX ON.
  21293. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  21294. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  21295. C  AND VM INHIBITS. (SETS TO 1).
  21296.     INTEGER*4 FH
  21297. C FILE HANDLE FOR CONSOLE I/O (RAW)
  21298. C    COMMON/CONSFH/FH
  21299.     CHARACTER*1 ARGSTR(52,4)
  21300. C    COMMON/ARGSTR/ARGSTR
  21301.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  21302.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  21303.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  21304.      3  IRCE2,FH,ARGSTR
  21305. C ***<<< XVXTCD COMMON END >>>***
  21306. CCC    InTeGer*4 IC1POS,IC2POS,MODFLG
  21307. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  21308. C CONTROLS TO SET VARIOUS VISUAL ATTRIBUTES
  21309. C NORMAL, BOLD
  21310. cc    Integer*4 lasty,lastx
  21311. cc    common/lasts/lasty,lastx
  21312.     InTeGer*4 N222
  21313. c    CHARACTER*1 CLSV(8)
  21314. c        CHARACTER*1 ULIT(8)
  21315. c    CHARACTER*1 NORMIT(4)
  21316.     CHARACTER*1 OUTBUF(16)
  21317. C    CHARACTER*1 NORMIT(4),BOLDIT(8),OUTBUF(16),BOLDUL(10)
  21318.     CHARACTER*2 OBF3
  21319.     CHARACTER*3 OBF6
  21320.     EQUIVALENCE (OBF3,OUTBUF(3)),(OBF6,OUTBUF(6))
  21321.     InTeGer*4 COLSW
  21322. C COLOR SCHEME CODED DATA ABOVE...
  21323.     save n222,colsw
  21324.     DATA N222/0/
  21325.     DATA COLSW/0/
  21326. C LEAVE IN THE BOLDING FOR NEGATIVE NUMBERS
  21327. c    DATA NORMIT/'','[','0','m'/
  21328. c fill in initial escape character (27 decimal)
  21329. c for the unix version, we will assume that FH is a pointer to
  21330. c a window data structure set up in the C language routines that`
  21331. c do actual curses() handling. However, routine UVT100 will know
  21332. c some more curses since it handles text attributes and cursor
  21333. c positioning and the like.
  21334.       OUTBUF ( 1 ) = Char(27)
  21335.       DO 20000  I = 2, 16
  21336. c fill in spaces in out buffer (32 decimal = ascii space)
  21337.       OUTBUF ( I ) = Char(32)
  21338. 20000 CONTINUE
  21339. 20001 CONTINUE
  21340. C CMD 20 TURNS COLOR ON, 21 TURNS IT OFF.
  21341.       IF ( CMD .NE. 1) GOTO 20002
  21342. C CURSOR POSITION.
  21343. C SHIP OUT APPROPRIATE CHARACTERISTICS.
  21344.  
  21345. 7701    CONTINUE
  21346. 1754    CONTINUE
  21347. 1500    CONTINUE
  21348. 7711    CONTINUE
  21349.       OUTBUF ( 2 ) = '['
  21350.       IF (.NOT.( N1 .GT. 0 . AND . N1 .LE. (LLDSP+1) )) GOTO 20004
  21351. c Move the cursor to row N1 and column N2. Forget about column max
  21352. c checks; we might have a HUGE window.
  21353. ccc    lasty=n1-1
  21354. ccc    lastx=n2-1
  21355. c n1,n2 start as based at 1,1. unix uses zero based numbers so
  21356. c adjust here.
  21357. ccc       call cmove(FH,lasty,lastx)
  21358.        WRITE(OBF3(1:2),10,ERR=20004)N1
  21359. C      ENCODE ( 2, 10, OUTBUF ( 3 ) ) N1
  21360. 20004 CONTINUE
  21361.       OUTBUF ( 5 ) = ';'
  21362. C ALLOW WIDE DISPLAYS FOR MACHINES LIKE THE RAINBOW...
  21363. C NOTE: USES MSDOS FORTRAN V3.2 FEATURE OF  I3.3 FORMAT...
  21364.       IF (.NOT.( N2 .GT. 0 . AND . N2 .LT. 233)) GOTO 20006
  21365.        WRITE(OBF6(1:3),105,ERR=20006)N2
  21366. C      ENCODE ( 3, 105, OUTBUF ( 6 ) ) N2
  21367. C FIX THE ABOVE FOR 132 COLUMN MAX ON RAINBOW. NO NEED TO LIMIT TO 80 COLS ON
  21368. C MACHINES THAT CAN HANDLE 132 OR MORE, BUT IBM MAY GOOF UP UNLESS LIMIT IS
  21369. C IN EFFECT. (LOSE LOSE)
  21370.     IF(OUTBUF(4).EQ.' ')OUTBUF(4)='0'
  21371.     IF(OUTBUF(7).EQ.' ')OUTBUF(7)='0'
  21372.     IF(OUTBUF(3).EQ.' ')OUTBUF(3)='0'
  21373.     IF(OUTBUF(6).EQ.' ')OUTBUF(6)='0'
  21374. 20006 CONTINUE
  21375.       OUTBUF ( 9 ) = 'H'
  21376.       LEN = 9
  21377.       GOTO 20003
  21378. 20002 CONTINUE
  21379.       IF ( CMD .NE. 11 ) GOTO 20036
  21380. C ERASE DISPLAY
  21381. C ALWSAYS ERASE WHOLE DISPLAY HERE.
  21382.     OUTBUF(1)=27
  21383.     call swrt(outbuf,1)
  21384.     call swrt('[0;0H',5)
  21385.     call swrt(outbuf,1)
  21386.     call swrt('[2J',3)
  21387. ccc    call cclear(FH)
  21388.     RETURN
  21389. 20036 CONTINUE
  21390.       IF ( CMD .NE. 12 ) GOTO 20042
  21391. C ERASE LINE
  21392. C EITHER ERASE WHOLE LINE BY DOING CR FIRST, OR JUST END OF LINE
  21393. C IF HE USED CODE 2.
  21394. C CAN'T HANDLE ERASING START ONLY, BUT ANALYTICALC NEVER TRIES THIS.
  21395. C DO C.R. FIRST IF CALLED FOR
  21396. 22001    CONTINUE
  21397.     if(n1.EQ.2)goto 20044
  21398. cc just emit line
  21399.     outbuf(2)='['
  21400.     outbuf(3)='K'
  21401.     len=3
  21402. ccc    call ccleareol(FH)
  21403.     goto 20003
  21404. C ERASE ALL BY RETURN, ERASE SEQ
  21405. 20044    continue
  21406. c use lasty saved from any prior positioning call to position to correct row
  21407. ccc    call cmove(FH,lasty,0)
  21408. ccc    call ccleareol(FH)
  21409.     outbuf(1)=char(13)
  21410.     outbuf(2)=char(27)
  21411.     outbuf(3)='['
  21412.     outbuf(4)='K'
  21413.       LEN = 4
  21414.       GOTO 20003
  21415. 20042 CONTINUE
  21416.       IF ( CMD .NE. 13 ) GOTO 20048
  21417. C SET GRAPHICS RENDITION (7=REVERSE VIDEO, 0=NORMAL,4=UNDERSCORE,1=BOLD
  21418. C  5=BLINK) (PORTACALC CALLS WITH 0 OR 7 (VT100 W/O AVO))
  21419. C    IF(MODFLG.NE.1)GOTO 22002
  21420. 22002    CONTINUE
  21421.     OUTBUF(1)=27
  21422.     call swrt(outbuf,1)
  21423. c Set either reverse or normal video
  21424. ccc    IF(N1.EQ.7)CALL cattron(fh)
  21425. ccc    if(n1.ne.7)call cattroff(fh)
  21426. cccc always these use A_STANDOUT attribute or A_REVERSE to highlight.
  21427.     IF(N1.EQ.7)CALL SWRT('[7m',3)
  21428.     if(n1.ne.7)call swrt('[0m',3)
  21429.     return
  21430. 20048 CONTINUE
  21431. c      IF (.NOT.( CMD .EQ. 15 )) GOTO 20054
  21432. C SCS. IGNORE THIS ... NEVER REALLY USED.
  21433.     RETURN
  21434. 20003 CONTINUE
  21435. 20073 CONTINUE
  21436. C USE A FORTRAN WRITE SO THIS WILL WORK ON VAX OR PDP11 (OR WHATEVER...)
  21437. C  UNIT 6 MUST BE THE TERMINAL...
  21438. c After each operation, refresh the screen
  21439. ccc    call crefresh(FH)
  21440.     CALL SWRT(OUTBUF,LEN)
  21441. 10    FORMAT ( I2 )
  21442. 105    FORMAT(I3.3)
  21443.       RETURN
  21444.       END
  21445. c -h- varout.for    Fri Aug 22 13:37:17 1986    
  21446.     SUBROUTINE VAROUT (INDXX,IX2)
  21447. C COPYRIGHT (C) 1983 GLENN EVERHART
  21448. C ALL RIGHTS RESERVED
  21449. C 60=MAX REAL ROWS
  21450. C 301=MAX REAL COLS
  21451. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  21452. C VBLS AND TYPE DIMENSIONED 60,301
  21453. C
  21454. C **************************************************
  21455. C *                                                *
  21456. C *       SUBROUTINE   VAROUT                      *
  21457. C *                                                *
  21458. C **************************************************
  21459. C
  21460. C
  21461. C
  21462. C  OUTPUTS THE VALUE OF THE VARIABLE POINTED TO BY INDXX.
  21463. c modified version - multiple precision calls diked out - gce
  21464. C
  21465. C  ASCII     A1 FORMAT UNLESS THE ASCII VALUE IS LESS THAN 32.
  21466. C            IN SUCH CASES, 32 IS ADDED TO THE VALUE AND THE
  21467. C            CHARACTER IS OUTPUT  SO THAT IT IS PRECEDED BY THE
  21468. C            CHARACTER '^'.
  21469. C
  21470. C  DECIMAL   A COMPUTED F FORMAT.
  21471. C
  21472. C  HEXADECIMAL  LEADING ZEROES, "BASE 16" QUE.
  21473. C
  21474. C  INTEGER   I12 FORMAT
  21475. C
  21476. C  OCTAL     LEADING ZEROES, "BASE 8" QUE
  21477. C
  21478. C  REAL      D25.18 FORMAT
  21479. C
  21480. C
  21481. C  VAROUT CALLS
  21482. C
  21483. C ERRMSG   PRINTS OUT ERROR MESSAGES
  21484. C MOUT     OUTPUTS MULTIPLE PRECISION NUMBERS
  21485. C
  21486. C
  21487. C
  21488. C
  21489. C
  21490. C VAROUT IS CALLED BY CALC AND POSTVL
  21491. C
  21492. C
  21493. C
  21494. C  VARIABLE   USE
  21495. C
  21496. C  DEC        HOLDS NUMBER OF DIGITS TO THE RIGHT OF THE
  21497. C             DECIMAL POINT IN F FORMAT SPECIFICATION.
  21498. C  DFORM(11)  HOLDS FORMAT SPECIFICATION FOR F FORMAT
  21499. C             (OUTPUTTING VALUE OF VARIABLES WITH DECIMAL DATA TYPE).
  21500. C  DIGITS     HOLDS THE ASCII CHARACTERS FOR VARIOUS DIGITS.
  21501. C  EIGHT(8)   USED TO PICK OFF REAL*8 'S FROM VBLS.
  21502. C             ALSO HOLDS HEXADECIMAL DIGITS IF # IS DATA TYPE HEX.
  21503. C  FOUR(4)    USED TO PICK OFF INTEGER*4'S FROM VBLS.
  21504. C  I,K        HOLDS TEMPORARY VALUES.
  21505. C  I1         HOLDS THE FIRST DIGIT IN CREATING AN F FORMAT SPECIFICATION.
  21506. C  I2         HOLDS THE SECOND DIGIT IN CREATING AN F FORMAT SPEC.
  21507. C  INDXX      POINTS TO VARIABLE BEING OUTPUT.
  21508. C  IPT        POINTER FOR DFORM.
  21509. C  ISV        POINTER FOR VECTOR SIGN(2).
  21510. C  ITWO       TWO IS USED TO PICK OFF A BYTE OF THE INTEGER
  21511. C  TWO(2)     REPRESENTATION. THEN ITWO IS USED AS
  21512. C             THE VALUE. THIS IS DONE BECAUSE OTHERWISE
  21513. C             SOME COMPILERS WOULD FORCE A SIGN EXTEND.
  21514. C  L          TEMPORARY VALUES. POINTER FOR EIGHT(8).
  21515. C  LEVIN(11)  HOLDS PRINTABLE ASCII CHARACTERS WHICH REPRESENT
  21516. C             AN OCTAL NUMBER. EQUIVALENCED WITH EIGHT(8).
  21517. C  M1         HOLDS HIGH ORDER HEXADECIMAL DIGIT.
  21518. C  M2         HOLDS LOW ORDER HEXADECIMAL DIGIT.
  21519. C  MAG        HOLDS THE MAGNITUDE OF A REAL*8 NUMBER
  21520. C  P10        REAL*8 THAT HOLDS POWERS OF 10. (DECIMAL)
  21521. C  RETCD      HOLDS RETURN CODE FROM CALL TO MOUT.
  21522. C  RPAR       ')'
  21523. C  SIGN(2)    HOLDS PRINTABLE ASCII CHARACTERS FOR OUTPUTTING THE
  21524. C             SIGN OF A NUMBER.
  21525. C  STAR1      HOLDS A SINGLE CHARACTER.
  21526. C  VBLS(100,27)  HOLDS VALUE FOR EACH VARIABLE.
  21527. C  WIDTH      WIDTH SPECIFICATION FOR F FORMAT.
  21528. C
  21529. C
  21530. C
  21531. C    SUBROUTINE VAROUT (INDXX,IX2)
  21532. C
  21533. C NOTE THAT VAROUT IS USED TO DUMP ONLY VALUES FROM AVBLS, NOT
  21534. C VBLS (IX2=1 ALWAYS AT CALLS). THUS DON'T BOTHER TO PICK UP
  21535. C ANY FURTHER INFO FROM VBLS HERE.
  21536.     REAL*8 REAL,MAG,P10
  21537. C
  21538.     INTEGER*4 INT,L,K
  21539. C
  21540.     InTeGer*4 ITWO,INDXX
  21541.     InTeGer*4 TYPE(1,2),WIDTH,DEC,VLEN(9)
  21542. C
  21543.     CHARACTER*1 AVBLS(24,27),STAR1,EIGHT(8),FOUR(4)
  21544.     Real*8 VAVBLS(3,27)
  21545.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  21546.     CHARACTER*1 VBLS(8,1,1)
  21547.     CHARACTER*1 TWO(2)
  21548.     CHARACTER*1 DFORM(11),DIGITS(16,3),LEVIN(11)
  21549.     CHARACTER*11 DFORM1
  21550.     EQUIVALENCE(DFORM1(1:1),DFORM(1))
  21551.     CHARACTER*1 SIGN(2)
  21552.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  21553. C ***<<< XVXTCD COMMON START >>>***
  21554.     CHARACTER*1 OARRY(100)
  21555.     InTeGer*4 OSWIT,OCNTR
  21556. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  21557. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  21558.     InTeGer*4 IPS1,IPS2,MODFLG
  21559. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  21560.        InTeGer*4 XTCFG,IPSET,XTNCNT
  21561.        CHARACTER*1 XTNCMD(80)
  21562. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  21563. C VARY FLAG ITERATION COUNT
  21564.     INTEGER KALKIT
  21565. C    COMMON/VARYIT/KALKIT
  21566.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  21567.     InTeGer*4 RCMODE,IRCE1,IRCE2
  21568. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  21569. C     1  IRCE2
  21570. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  21571. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  21572. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  21573. C RCFGX ON.
  21574. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  21575. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  21576. C  AND VM INHIBITS. (SETS TO 1).
  21577.     INTEGER*4 FH
  21578. C FILE HANDLE FOR CONSOLE I/O (RAW)
  21579. C    COMMON/CONSFH/FH
  21580.     CHARACTER*1 ARGSTR(52,4)
  21581. C    COMMON/ARGSTR/ARGSTR
  21582.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  21583.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  21584.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  21585.      3  IRCE2,FH,ARGSTR
  21586. C ***<<< XVXTCD COMMON END >>>***
  21587. CCC    InTeGer*4 OSWIT,OCNTR
  21588. C NOTE: OSWIT NONZERO MEANS OUTPUT TO OARRY.
  21589. C OSWIT=2 MEANS NO ZEROING OF OARRY; NOTHING MUCH COMES OUT.
  21590. CCC    CHARACTER*1 OARRY(100)
  21591. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  21592. C
  21593.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  21594.     COMMON /DIGV/ DIGITS
  21595.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  21596.     Character*127 cwrk
  21597.     Character*2 crlf
  21598. C
  21599.     EQUIVALENCE (TWO,ITWO)
  21600.     EQUIVALENCE (REAL,EIGHT),(INT,FOUR),(EIGHT,LEVIN)
  21601. C
  21602.     save sign,dform,itwo
  21603.     DATA SIGN/' ','-'/
  21604.     DATA DFORM /'(', '1', 'X', ',', 'F', ' ', ' ', '.', ' ', ' ',
  21605.      ;  ')'/
  21606.     DATA ITWO/0/
  21607. C
  21608. C
  21609. C
  21610.     crlf=char(13)//char(10)
  21611.     CALL TYPGET(INDXX,IX2,K)
  21612. C    K=TYPE(INDXX,IX2)
  21613.     IF (K.GT.0) GOTO 10
  21614. C MODIFY TO ELIMINATE CALL TO ERRMSG HERE. JUST COMPLAIN LOCALLY.
  21615.     CALL SWRT('Invalid type argument',21)
  21616.     oarry(1)=char(13)
  21617.     oarry(2)=char(10)
  21618.     call swrt(oarry,2)
  21619. C    CALL ERRMSG (16)
  21620.     GOTO 10000
  21621. 10    GOTO (100,200,300,400,500,600,700,800,900),K
  21622.     STOP 10
  21623. C
  21624. C
  21625. C
  21626. C
  21627. C **************************************************
  21628. C **************        ASCII        ***************
  21629. C **************************************************
  21630. 100    STAR1=AVBLS(1,INDXX)
  21631.     IF(OSWIT.NE.0)GOTO 6006
  21632.     IF (ICHAR(STAR1).LT.32) GOTO 110
  21633. 102    Continue
  21634. c    Rewind 11
  21635.     call vwrt(star1,1)
  21636. c    WRITE (11,103) STAR1
  21637. c    Rewind 11
  21638. 103    FORMAT (1X,A1)
  21639.     RETURN
  21640. 110    STAR1=CHAR(ICHAR(STAR1)+32)
  21641. c    Rewind 11
  21642.     Call vwrt('^' // star1,2)
  21643. c    WRITE (11,112) STAR1
  21644. c    Rewind 11
  21645. 112    FORMAT (1X,'^',A1)
  21646.     RETURN
  21647. 6006    OARRY(1)=STAR1
  21648.     OCNTR=1
  21649.     RETURN
  21650. C
  21651. C
  21652. C
  21653. C
  21654. C
  21655. C **************************************************
  21656. C ****************  DECIMAL   **********************
  21657. C **************************************************
  21658. 200    CONTINUE
  21659. c    DO 208 I=1,8
  21660. c208    EIGHT(I)=AVBLS(I,INDXX)
  21661.     Real=vavbls(1,indxx)
  21662.     MAG=DABS(REAL)
  21663.     IF (MAG.LT.1.D0) GOTO 240
  21664. C
  21665. C
  21666. C COUNT THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
  21667.     P10=1.D0
  21668.     DO 210 I=1,38
  21669.     P10=10.D0*P10
  21670.     IF (P10.GT.MAG) GOTO 212
  21671. 210    CONTINUE
  21672. C
  21673. C I COUNTS THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
  21674.     I=39
  21675. 212    DEC=0
  21676.     WIDTH=17
  21677.     IF(I.GT.15)WIDTH=I+2
  21678.     IF(I.LE.15)DEC=15-I
  21679. C
  21680. C
  21681. C  CREATE PROPER FORMAT STATEMENT
  21682. 215    I1=WIDTH/10
  21683.     I2=WIDTH-I1*10
  21684.     IF (I2.EQ.0) I2=10
  21685.     DFORM(6)=DIGITS(I1,1)
  21686.     DFORM(7)=DIGITS(I2,1)
  21687.     I1=DEC/10
  21688.     I2=DEC-I1*10
  21689.     IF (I1.EQ.0) I1=10
  21690.     IF (I2.EQ.0) I2=10
  21691.     IPT=9
  21692.     IF (I1.EQ.0) GOTO 220
  21693.     DFORM(9)=DIGITS(I1,1)
  21694.     IPT=IPT+1
  21695. 220    DFORM(IPT)=DIGITS(I2,1)
  21696.     DFORM(IPT+1)=RPAR
  21697.     nnn=ipt+2
  21698.     if(nnn.ge.11)goto 223
  21699.     do 224 nnnn=nnn,11
  21700. 224    dform(nnnn)=' '
  21701. 223    continue
  21702. C
  21703. C
  21704. C
  21705. C
  21706. C  OUTPUT REAL USING NEWLY CREATED
  21707. C  FORMAT STATEMENT HELD BY DFORM
  21708.     IF(OSWIT.NE.0)GOTO 6009
  21709. c    Rewind 11
  21710.     write(cwrk,dform,err=10000)real
  21711.     call vwrt(crlf,2)
  21712.     call vwrt(cwrk,len(cwrk))
  21713. c    WRITE (11,DFORM,ERR=10000) REAL
  21714. c    Rewind 11
  21715.     GOTO 10000
  21716. 6009    CONTINUE
  21717.     IF(OSWIT.EQ.2) GOTO 6101
  21718.     IF(OSWIT.GT.3)GOTO 7101
  21719.     DO 6010 OCNTR=1,106
  21720. 6010    OARRY(OCNTR)=char(0)
  21721. 6101    CONTINUE
  21722. C FORGET THE ENCODE ... NEVER USED
  21723. C6101    ENCODE(100,DFORM,OARRY)REAL
  21724. 7101    OCNTR=100
  21725.     GOTO 10000
  21726. C
  21727. C
  21728. C  REAL LESS THAN 1.D0
  21729. 240    P10=1.D0
  21730.     DO 245 I=1,38
  21731.     P10=P10*.1D0
  21732.     IF (MAG.GE.P10) GOTO 250
  21733. 245    CONTINUE
  21734.     I=0
  21735. C
  21736. C I-1 REPRESENTS THE NUMBER OF LEADING ZEROS
  21737. 250    DEC=14+I
  21738.     WIDTH=DEC+3
  21739.     GOTO 215
  21740. C
  21741. C
  21742. C **************************************************
  21743. C *************  HEXADECIMAL  **********************
  21744. C **************************************************
  21745. C  HEXADECIMAL
  21746. 300    CONTINUE
  21747.     DO 302 I=1,4
  21748. 302    FOUR(I)=AVBLS(I,INDXX)
  21749.     ISV=1
  21750.     IF (INT.LT.0) ISV=2
  21751.     INT=IABS(INT)
  21752.     L=8
  21753.     DO 304 I=1,4
  21754. C PICK UP A VALUE, THEN USE InTeGer*4 EQUIVALENT
  21755. C TO WORK WITH SO SIGN DOESN'T GET EXTENED.
  21756.     TWO(1)=(FOUR(I))
  21757.     M1=ITWO/16
  21758.     M2=ITWO-M1*16
  21759.     IF(M1.EQ.0)M1=16
  21760.     IF(M2.EQ.0)M2=16
  21761.     EIGHT(L)=DIGITS(M2,3)
  21762.     L=L-1
  21763.     EIGHT(L)=DIGITS(M1,3)
  21764.     L=L-1
  21765. 304    CONTINUE
  21766.     IF(OSWIT.NE.0)GOTO 6011
  21767. c    Rewind 11
  21768.     write(cwrk,310,err=10000)sign(isv),eight
  21769.     call vwrt(crlf,2)
  21770.     Call vwrt(cwrk,len(cwrk))
  21771. c    WRITE (11,310,ERR=10000) SIGN(ISV), EIGHT
  21772. c    Rewind 11
  21773. 310    FORMAT (1X,1A1,8A1,2X,'(BASE 16)')
  21774.     GOTO 10000
  21775. 6011    CONTINUE
  21776.     IF(OSWIT.EQ.2)GOTO 6102
  21777.     IF(OSWIT.GT.3)GOTO 7102
  21778.     DO 6013 OCNTR=1,106
  21779. 6013    OARRY(OCNTR)=char(0)
  21780. 6102    CONTINUE
  21781. C FORGET UNUSED ENCODE
  21782. C6102    ENCODE(8,6012,OARRY)SIGN(ISV),EIGHT
  21783. 6012    FORMAT(A1,8A1)
  21784. 7102    OCNTR=9
  21785.     GOTO 10000
  21786. C
  21787. C
  21788. C **************************************************
  21789. C ***************   INTEGER   **********************
  21790. C **************************************************
  21791. 400    DO 404 I=1,4
  21792. 404    FOUR(I)=AVBLS(I,INDXX)
  21793.     IF(OSWIT.NE.0)GOTO 6014
  21794. c    Rewind 11
  21795.     Write(cwrk,410,err=10000)int
  21796.     call vwrt(crlf,2)
  21797.     call vwrt(cwrk,len(cwrk))
  21798. c    WRITE (11,410,ERR=10000) INT
  21799. c    Rewind 11
  21800. 410    FORMAT (1X,I12)
  21801.     GOTO 10000
  21802. 6014    CONTINUE
  21803.     IF(OSWIT.EQ.2)GOTO 6103
  21804.     IF(OSWIT.GT.3)GOTO 7104
  21805.     DO 6015 OCNTR=1,106
  21806. 6015    OARRY(OCNTR)=char(0)
  21807. 6103    CONTINUE
  21808. C6103    ENCODE(12,410,OARRY)INT
  21809. 7104    OCNTR=12
  21810.     GOTO 10000
  21811. C
  21812. C
  21813. C **************************************************
  21814. C ***********    MULTIPLE PRECISION   **************
  21815. C **************************************************
  21816. C  MULTIPLE PRECISION
  21817. C  M10
  21818. 500    CONTINUE
  21819. C
  21820. C  M8
  21821. 600    CONTINUE
  21822. C
  21823. C  M16
  21824. 700    continue
  21825. c700    CALL MOUT (INDXX,RETCD)
  21826.     GOTO 10000
  21827. C
  21828. C
  21829. C **************************************************
  21830. C ****************   OCTAL   ***********************
  21831. C **************************************************
  21832. C  OCTAL
  21833. 800    DO 804 I=1,4
  21834. 804    FOUR(I)=AVBLS(I,INDXX)
  21835.     ISV=1
  21836.     IF (INT.LT.0) ISV=2
  21837.     K=IABS(INT)
  21838.     DO 810 I=1,11
  21839.     L=K-K/8*8
  21840. C TAKE ABSOLUTE VALUE IN CASE FIRST IABS DIDN'T WORK ON -2**31
  21841.     L=IABS(L)
  21842.     IF(L.EQ.0)L=9
  21843.     LEVIN (12-I)=DIGITS(L,2)
  21844.     K=K/8
  21845. 810    CONTINUE
  21846.     IF(OSWIT.NE.0)GOTO 6016
  21847. c    Rewind 11
  21848.     write(cwrk,820,err=10000)sign(isv),levin
  21849.     call vwrt(crlf,2)
  21850.     call vwrt(cwrk,len(cwrk))
  21851. c    WRITE (11,820,ERR=10000) SIGN(ISV), LEVIN
  21852. c    Rewind 11
  21853. 820    FORMAT (1X,1A1,11A1,2X,'(BASE 8)')
  21854.     GOTO 10000
  21855. 6016    CONTINUE
  21856.     IF(OSWIT.EQ.2)GOTO 6100
  21857.     IF(OSWIT.GT.3)GOTO 7105
  21858.     DO 6018 OCNTR=1,106
  21859. 6018    OARRY(OCNTR)=char(0)
  21860. 6100    CONTINUE
  21861. C6100    ENCODE(12,6017,OARRY)SIGN(ISV),LEVIN
  21862. 6017    FORMAT(12A1)
  21863. 7105    OCNTR=12
  21864.     GOTO 10000
  21865. C
  21866. C
  21867. C
  21868. C
  21869. C
  21870. C **************************************************
  21871. C ***************    REAL    ***********************
  21872. C **************************************************
  21873. 900    Continue
  21874. c    DO 904 I=1,8
  21875. c904    EIGHT(I)=AVBLS(I,INDXX)
  21876.     Real=vavbls(1,indxx)
  21877.     IF(OSWIT.NE.0)GOTO 6019
  21878. c    Rewind 11
  21879.     write(cwrk,910,err=10000)real
  21880.     call vwrt(crlf,2)
  21881.     call vwrt(cwrk,len(cwrk))
  21882. c    WRITE (11,910,ERR=10000) REAL
  21883. c    Rewind 11
  21884. 910    FORMAT (1X,D25.18)
  21885.     GOTO 10000
  21886. 6019    CONTINUE
  21887.     IF (OSWIT.EQ.2)GOTO 6020
  21888.     IF(OSWIT.GT.3)GOTO 7106
  21889.     DO 6321 OCNTR=1,106
  21890. 6321    OARRY(OCNTR)=Char(0)
  21891. 6020    CONTINUE
  21892. C    ENCODE(28,6021,OARRY)REAL
  21893. 6021    FORMAT(D25.18)
  21894. 7106    OCNTR=28
  21895. 10000    RETURN
  21896.     END
  21897. c -h- vblget.for    Fri Aug 22 13:37:17 1986    
  21898.         SUBROUTINE VBLGET(ID1,ID2,ID3,IVAL)
  21899. C
  21900. C VBLGET - GET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
  21901. C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLGT TO GET
  21902. C  CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE
  21903.         InTeGer*4 ID1,ID2,ID3
  21904.         CHARACTER*1 IVAL,LL(8)
  21905.         REAL*8 XX
  21906.         EQUIVALENCE(LL(1),XX)
  21907.         CALL XVBLGT(ID2,ID3,XX)
  21908.         IVAL=LL(ID1)
  21909.         RETURN
  21910.         END
  21911. c -h- vblset.for    Fri Aug 22 13:37:17 1986    
  21912.         SUBROUTINE VBLSET(ID1,ID2,ID3,IVAL)
  21913. C VBLSET - SET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
  21914. C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLST TO GET
  21915. C  CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE
  21916.         InTeGer*4 ID1,ID2,ID3
  21917.         CHARACTER*1 IVAL,LL(8)
  21918.         REAL*8 XX
  21919.         EQUIVALENCE(LL(1),XX)
  21920. C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONE WE WANT. THEN...
  21921.         CALL XVBLGT(ID2,ID3,XX)
  21922.         LL(ID1)=IVAL
  21923. C PUT BACK THE 8 BYTES.
  21924.         CALL XVBLST(ID2,ID3,XX)
  21925.         RETURN
  21926.         END
  21927. c -h- wassig.fdd    Fri Aug 22 13:44:20 1986    
  21928.     SUBROUTINE WASSIG(IUNIT,NAME)
  21929. C
  21930. C
  21931.     CHARACTER*1 NAME(50)
  21932.     InTeGer*4 IUNIT
  21933.     CHARACTER*20 WK
  21934.     CHARACTER*1 WK1(20)
  21935.     EQUIVALENCE(WK(1:1),WK1(1))
  21936. C JUST TRY AND NULL FILL A NAME TO USE.
  21937.     DO 1 N=1,20
  21938.     WK1(N)=' '
  21939. 1    CONTINUE
  21940.     DO 2 N=1,20
  21941.     II=ICHAR(NAME(N))
  21942.     IF(II.LT.32)GOTO 3
  21943.     WK1(N)=CHAR(II)
  21944. C1    CONTINUE
  21945. 2    CONTINUE
  21946. 3    OPEN(IUNIT,FILE=WK(1:20),STATUS='NEW',recl=512,
  21947.      1  ACCESS='SEQUENTIAL',FORM='FORMATTED')
  21948.     RETURN
  21949.     END
  21950. c -h- wrkfil.f40    Fri Aug 22 13:44:46 1986    
  21951.     SUBROUTINE WRKFIL(NREC,ARRAY,IFUNC)
  21952. C COPYRIGHT 1983 GLENN C.EVERHART
  21953. C ALL RIGHTS RESERVED
  21954. C WORKFILE PSEUDO-MAINTAINER
  21955. C
  21956. C THIS ROUTINE IS INTENDED TO PERMIT THE SCRATCH FILE OF
  21957. C PORTACALC TO BE DISPENSED WITH BY USING A LARGE IN-MEMORY
  21958. C ARRAY. A BITMAP WILL SET UP WHEN THE ELEMENT IS INIT'ED AND
  21959. C THE DEFAULT ELEMENT WILL BE COMPUTED AND RETURNED
  21960. C IF AN UNINITIALIZED ELEMENT IS USED.
  21961. C
  21962. c nrc was i*4. make it i*2 here
  21963.     Include aparms.inc
  21964.     INTEGER NRC
  21965. C    InTeGer*4 NRC2(2)
  21966. C    EQUIVALENCE(NRC2(1),NRC)
  21967. C RECORD NUMBER TO ACCESS
  21968.     INTEGER NREC
  21969.     CHARACTER*1 ARRAY(128)
  21970.     INTEGER IFUNC
  21971. C ***<<<< RDD COMMON START >>>***
  21972.     InTeGer*4 RRWACT,RCLACT
  21973. C    COMMON/RCLACT/RRWACT,RCLACT
  21974.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  21975.      1  IDOL7,IDOL8
  21976. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  21977. C     1  IDOL7,IDOL8
  21978.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  21979. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  21980.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21981. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21982. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  21983. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  21984.     InTeGer*4 KLVL
  21985. C    COMMON/KLVL/KLVL
  21986.     InTeGer*4 IOLVL,IGOLD
  21987. C    COMMON/IOLVL/IOLVL
  21988. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  21989. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  21990.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21991.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21992.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  21993.      3  k3dfg,kcdelt,krdelt,kpag
  21994. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  21995. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  21996. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  21997. C ***<<< RDD COMMON END >>>***
  21998. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  21999. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22000. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  22001. C
  22002. C ***<<< NULETC COMMON START >>>***
  22003.     InTeGer*4 ICREF,IRREF
  22004. C    COMMON/MIRROR/ICREF,IRREF
  22005.     InTeGer*4 MODPUB,LIMODE
  22006. C    COMMON/MODPUB/MODPUB,LIMODE
  22007.     InTeGer*4 KLKC,KLKR
  22008.     REAL*8 AACP,AACQ
  22009. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  22010.     InTeGer*4 NCEL,NXINI
  22011. C    COMMON/NCEL/NCEL,NXINI
  22012.     CHARACTER*1 NAMARY(20,MRows)
  22013. C    COMMON/NMNMNM/NAMARY
  22014.     InTeGer*4 NULAST,LFVD
  22015. C    COMMON/NULXXX/NULAST,LFVD
  22016.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  22017.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  22018. C ***<<< NULETC COMMON END >>>***
  22019. CCC    InTeGer*4 NCEL,NXINI
  22020. CCC    COMMON/NCEL/NCEL,NXINI
  22021.     InTeGer*4 MFID(2),MFMOD(2)
  22022.     InTeGer*2 IFID(8,MFrm)
  22023.     COMMON/IFIDC/IFID
  22024. CCC    InTeGer*4 RRWACT,RCLACT
  22025. C MFLAST = 1 OR 2 FOR LAST BUFFER USED. MFBASE IS HOLDER FOR "BASE ADDR"
  22026. C IN ARRAY TO USE IN SCANS.
  22027.     InTeGer*4 MFLAST,MFBASE,MVBASE
  22028.     COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
  22029. CCC    COMMON/RCLACT/RRWACT,RCLACT
  22030.     CHARACTER*1 LFID(16,MFrm)
  22031.     EQUIVALENCE(IFID(1,1),LFID(1,1))
  22032. C ***<<< KLSTO COMMON START >>>***
  22033.     InTeGer*4 DLFG
  22034. C    COMMON/DLFG/DLFG
  22035.     InTeGer*4 KDRW,KDCL
  22036. C    COMMON/DOT/KDRW,KDCL
  22037.     InTeGer*4 DTRENA
  22038. C    COMMON/DTRCMN/DTRENA
  22039.     REAL*8 EP,PV,FV
  22040.     DIMENSION EP(20)
  22041.     INTEGER*4 KIRR
  22042. C    COMMON/ERNPER/EP,PV,FV,KIRR
  22043.     InTeGer*4 LASTOP
  22044. C    COMMON/ERROR/LASTOP
  22045.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  22046. C    COMMON/FMTBFR/FMTDAT
  22047.     CHARACTER*1 EDNAM(16)
  22048. C    COMMON/EDNAM/EDNAM
  22049. c    InTeGer*4 MFID(2),MFMOD(2)
  22050. C    COMMON/FRM/MFID,MFMOD
  22051.     InTeGer*4 JMVFG,JMVOLD
  22052. C    COMMON/FUBAR/JMVFG,JMVOLD
  22053.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  22054.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  22055. C ***<<< KLSTO COMMON END >>>***
  22056. CCC    COMMON/FRM/MFID,MFMOD
  22057.     CHARACTER*1 LI,IBYTE
  22058. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  22059.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  22060.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  22061.     COMMON/DEFVBX/DVFMT
  22062. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  22063. C AREAS WITH DATA.)
  22064. CCC    CHARACTER*1 FMTDAT(9,Ifmtbk)
  22065. CCC    COMMON/FMTBFR/FMTDAT
  22066. C
  22067. C IFUNC SPECIFIES WHAT TO DO:
  22068. C    =0    READ INTO ARRAY
  22069. C    =1    WRITE FROM ARRAY INTO WRKARY
  22070. C    =2    INITIALIZE (JUST CLEARS BITMAP HERE)(OPEN)
  22071. C    =3    CLOSE (CLEARS BITMAP HERE)
  22072.     CHARACTER*1 DTBL1(9,9,8)
  22073. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  22074.     InTeGer*2 BTBL(6,6,8)
  22075. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  22076. C NO NEED TO WASTE IT.
  22077.     INTEGER DTBLIN
  22078. C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
  22079.     EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
  22080.     InTeGer*2 BTBL1(6,6)
  22081.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  22082.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  22083.     EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  22084.     EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  22085.     EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  22086.     EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  22087.     COMMON /DECIDE/ DTBL1
  22088.     save dtblin
  22089.     DATA DTBLIN/0/
  22090.     IF(IFUNC.NE.50)GOTO 34
  22091.     IF(DTBLIN.NE.0)RETURN
  22092.     DTBLIN=1
  22093. C FLAG WE DID THIS INITIALIZATION ONCE. SINCE BUFFER IS CLEARED WE MUST
  22094. C *** NOT *** DO IT AGAIN.
  22095. C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
  22096. C TYPES (WHICH ARE NOT SUPPORTED HERE)
  22097. C CALL SEPARATE ROUTINE TO CLEAR OUT THIS STUFF ONE-TIME. OVERLAY SAME.
  22098. C NOTE LOTS OF SILLY ARGUMENTS TO SUBROUTINE SINCE MS FORTRAN DISALLOWS
  22099. C EQUIVALENCES TO DUMMY ARGUMENTS.
  22100. C note dtbl1 inits now in block2 routine
  22101.     CALL WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,BTBL6,
  22102.      1  BTBL7,BTBL8)
  22103. C
  22104. C14      CONTINUE
  22105. CC FILE IS NOW CLEARED
  22106.     RETURN
  22107. 34    IF(IFUNC.LT.0.OR.IFUNC.GT.3)RETURN
  22108.     JFUN=IFUNC+1
  22109.     GOTO (1000,2000,3000,4000),JFUN
  22110. 1000    CONTINUE
  22111. C READ
  22112.     CALL FVLDGT(NREC,1,IBYTE)
  22113.     IF(ICHAR(IBYTE).NE.0)GOTO 1001
  22114. C UNINITIALIZED ARRAY ELEMENT: SET IT UP.
  22115. C JUST LEAVES DUMMY CELL CONTENTS WHERE NOTHING IS REALLY INIT'D.
  22116.     DO 1003 N=1,128
  22117. 1003    ARRAY(N)=char(0)
  22118.     ARRAY(1)='P'
  22119.     ARRAY(2)='#'
  22120.     ARRAY(3)='0'
  22121.     ARRAY(5)='0'
  22122.     ARRAY(4)='#'
  22123.     ARRAY(118)=CHAR(15)
  22124. C NOTE ARRAY(119) (WHICH BECOMES FVLD) IS 0 TOO.
  22125.     DO 1004 N=1,9
  22126. 1004    ARRAY(N+119)=DEFFMT(N)
  22127. C RETURN THE DEFAULT FORMAT NOW.
  22128.     RETURN
  22129. 1001    CONTINUE
  22130. C HERE HAVE TO GET THE WHOLE THING REALLY
  22131.     DO 1053 N=1,128
  22132. 1053    ARRAY(N)=char(0)
  22133.     ARRAY(119)=IBYTE
  22134.     ARRAY(118)=CHAR(15)
  22135.     ARRAY(1)=char(48)
  22136. C LET ARRAY INITIALLY BE SET SENSIBLY..
  22137.     DO 1054 N=1,9
  22138. 1054    ARRAY(N+119)=DEFFMT(N)
  22139. C WE MAY MODIFY FORMAT LATER TOO...
  22140. C NOW HAVE A NON-DEFAULT ELEMENT TO READ... GO THROUGH SYMBOL TBL LOGIC
  22141. C FOR THESE, WE USE 16-BYTE "CELLS" WHICH HAVE THE FOLLOWING FORMAT:
  22142. C    ID    2 BYTES (CELL ADDRESS, MUST BE 1 OR MORE FOR VALID)
  22143. C    FLAG    1 BYTE  (TYPE OF CELL:
  22144. C                0 = UNUSED
  22145. C                1 = 1 OF 1 CELLS
  22146. C                2 = NONTERMINAL OF MORE THAN 1 CELL
  22147. C                3 = LAST OF >1 CELLS
  22148. C    FORMAT    1 BYTE  (INDEX OF FORMAT STRING FOR THIS CELL; FORMATS
  22149. C                ARE STORED RESIDENT, UP TO 76 OF THEM,
  22150. C                SET BY DF COMMAND.)
  22151. C    FORMULA    12 BYTES  (FORMULA TEXT)
  22152. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  22153. C    IPM=(LPGMXF*64/2048)+1
  22154. C    IBF=64
  22155. CC    IBF=(2048+31)/32
  22156. C IBF IS NO. OF ENTRIES IN A BUFFER. OF 512 BYTES
  22157. C    IBF=32
  22158.     IBF=(MFrm+31)/64
  22159. C    LLL=(LPGMXF)/IBF
  22160. C    LLL=LPGMXF
  22161. C IPM IS NO. PAGES MAX IN FILS
  22162. C 1024 bytes holds 64 entries at 16 bytes each
  22163. C (user specifies file in K)
  22164. C handle in 1024 units since we have 2 buffers
  22165.     IPM=LPGMXF*64/(MFrmo2)
  22166. C EACH BUFFER HAS 16KB (if mfrm=2048) SO MAX PAGES IS (FILE LENGTH)/16
  22167. C    IPM=LLL
  22168.     IF(IPM.LT.2)IPM=2
  22169. C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
  22170.     IHASH=NREC*9
  22171. C space out the entries. Was ihash=nrec but this is much faster
  22172. C for most sheets
  22173. C    JHASH=IMASK(IHASH,(MFrm-1))
  22174.     JHASH=MOD(IHASH,(MFrmo2))
  22175. C    JHASH=IMASK(IHASH,1023)
  22176. C    JHASH=MOD(IHASH,2048)
  22177.     IF(LPGMOD.NE.0)GOTO 5305
  22178. C    IPAG=(IHASH/2048)+1
  22179.     IPAG=(IHASH/(MFrmo2))+1
  22180.     IPAG=MOD(IPAG,IPM)+1
  22181.     GOTO 5306
  22182. 5305    CONTINUE
  22183. C SPEED OPTIMAL PACK
  22184.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
  22185.     IPAG=FPG
  22186.     IPAG=MOD(IPAG,IPM)
  22187.     IPAG=IPAG+1
  22188. C    IPAG=1+(IHASH*IPM)/18060
  22189. 5306    CONTINUE
  22190. C HERE DECIDED IF PAGE IS WHAT WE NEED.
  22191. C
  22192. C    IF(IPAG.LE.0)IPAG=1
  22193. C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
  22194.     IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 853
  22195.     IF(MFID(1).NE.0)GOTO 852
  22196.     MFID(1)=IPAG
  22197.     GOTO 853
  22198. 852    IF(MFID(2).EQ.0)MFID(2)=IPAG
  22199. 853    CONTINUE
  22200.     IF(MFID(1).EQ.IPAG) GOTO 850
  22201.     IF(MFID(2).EQ.IPAG)GOTO 851
  22202.     GOTO 854
  22203. 850    CONTINUE
  22204. C PAGE 1 IS THE ONE WE NEED.
  22205.     MFLAST=1
  22206.     MFBASE=0
  22207.     GOTO 1400
  22208. 851    CONTINUE
  22209. C NEED SECOND PAGE
  22210.     MFLAST=2
  22211.     MFBASE=(MFrmo2)
  22212. C BASE IS HASFWAY ALONG FILE...
  22213.     GOTO 1400
  22214. 854    CONTINUE
  22215. C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
  22216. C MFLAST will be either 1 or 2; following logic swaps them.
  22217.     MFLAST=3-MFLAST
  22218.     MFBASE=(MFrmo2)-MFBASE
  22219. C SIMILAR LOGIC SAYS MFBAS4E IS EITHER 0 OR MFrmo2. INITIALIZED IN
  22220. C WSSET TO 0.
  22221. C NOTE THAT IF MFLAST=1,MBFN=1 AND IF MFLAST=2,NEW MFLAST=1
  22222. C THIS GIVES BUFFER TO REPLACE... (LRU)
  22223. C
  22224. C IF MFLAST=2 REPLACE BUFFER 1, ELSE REPLACE BUFFER 0
  22225. C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
  22226. C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
  22227. C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
  22228. C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
  22229. C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
  22230. C WIN.....
  22231.     IF(LPGMXF.LE.(MFro64))GOTO 1400
  22232. C    IF(LPGMXF.LE.(2048/64))GOTO 1400
  22233. C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
  22234. C    IBF=32
  22235. CC    IBF=(1024+31)/32
  22236. C    IF(IBF.LT.1)IBF=1
  22237. C IBF IS BLK FACTOR FOR ONE WRITE
  22238. C WRITE 512 BYTES AT A TIME.
  22239.     L=1+MFBASE
  22240.     LLBK=(MFID(MFLAST)-1)*IBF+1
  22241.     LHBK=MFID(MFLAST)*IBF
  22242.     DO 1170 N=LLBK,LHBK
  22243.     IF(MFMOD(MFLAST).EQ.0)GOTO 1170
  22244.     LL=L+(MFro64)-1
  22245.     WRITE(7,REC=N,ERR=1170)((IFID(K,KK),K=1,8),KK=L,LL)
  22246.     L=L+(MFro64)
  22247. 1170    CONTINUE
  22248. C NOW READ IN THE DATA
  22249.     MFMOD(MFLAST)=0
  22250. C MARK PAGE UNTOUCHED. READING DOES NOT ALTER DATA SO NO NEED
  22251. C TO WRITE OUT UNLESS MODIFIED.
  22252.     MFID(MFLAST)=IPAG
  22253.     L=1+MFBASE
  22254.     LLBK=(MFID(MFLAST)-1)*IBF+1
  22255.     LHBK=MFID(MFLAST)*IBF
  22256.     DO 1171 N=LLBK,LHBK
  22257.     LL=L+(MFro64)-1
  22258.     READ(7,REC=N,ERR=1171)((IFID(K,KK),K=1,8),KK=L,LL)
  22259.     L=L+(MFro64)
  22260. 1171    CONTINUE
  22261. C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
  22262. 1400    CONTINUE
  22263. C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
  22264. C BUFFER.
  22265.     IARSUB=1
  22266. C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
  22267. C FROM START...
  22268.     IFLAG=0
  22269.     IFMT=0
  22270.     DO 2500 NN=1,(MFrmo2)
  22271. c    N=MOD((NN+JHASH-1),(MFrmo2))
  22272.     N=MOD((NN+JHASH),(MFrmo2))
  22273.     N=N+1+MFBASE
  22274. C    N=IMASK((NN+JHASH-1),1023)+1+MFBASE
  22275.     KKKKK=IFID(1,N)
  22276.     IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 2505
  22277.     IF(KKKKK.NE.NREC)GOTO 2500
  22278.     IFLAG=ICHAR(LFID(3,N))
  22279.     IF(IFMT.EQ.0)IFMT=ICHAR(LFID(4,N))
  22280. C for the moment leave this in. LAter remove and change to 10
  22281. C bytes formula, 4 bytes cell ID.
  22282.     DO 2502 K=1,12
  22283.     LI=LFID(K+4,N)
  22284. C COPY FORMULA TEXT INTO ARRAY. END ON NULLS...
  22285.     IF(ICHAR(LI).LE.0)GOTO 2505
  22286.     ARRAY(IARSUB)=LI
  22287. c null out following characters since -1's could be misinterpreted as data
  22288.     array(iarsub+1)=char(0)
  22289.     array(iarsub+2)=char(0)
  22290.     IARSUB=IARSUB+1
  22291. 2502    CONTINUE
  22292.     IF(IFLAG.EQ.1.OR.IFLAG.EQ.3)GOTO 2505
  22293. 2500    CONTINUE
  22294. 2505    CONTINUE
  22295. C GET FORMAT NOW...
  22296.     IF(IFMT.LE.0)RETURN
  22297.     DO 2510 N=1,9
  22298. 2510    ARRAY(119+N)=FMTDAT(N,IFMT)
  22299.     GOTO 5000
  22300. 2000    CONTINUE
  22301. C WRITE
  22302. C NOW SET INIT'D BIT; WRITE ARRAY ELEMENT OUT.
  22303. C FIRST FIND FORMAT AREA OR SET IT UP.
  22304.     IFMT=0
  22305.     LFF=0
  22306. C FAKE OUT THE SAVING OF FVLD INFO IN THIS ARRAY TOO.
  22307. C THIS IS INCOMPLETE AND NO LITTLE OF A KLUDGE BUT THE CODE WILL
  22308. C GENERALLY SET THEM TOGETHER, AND THIS GUARANTEES THAT IF
  22309. C FURTHER SETS TRY TO SET FVLD TO ARRAY(119), THEY'LL WORK AS
  22310. C THEY SHOULD.
  22311. C HERE SET MAX ARRAY ELEMENTS USED
  22312. C EXPECT (ID2-1)*60+ID1
  22313. C ID1 IS 60 DIM, ID2 IS 301 DIM
  22314. C    NRC2(2)=0
  22315. C    NRC2(1)=NREC
  22316. C JUST EQUATE NRC TO NREC
  22317. C ALLOW LATER FOR OVER 32768 ELEMENTS... NO NEED TO JUST YET
  22318. C WHEN WE DO, REPLACE NRC2 STUFF (WHOSE PURPOSE IS TO AVOID
  22319. C SIGN EXTENSIONS).
  22320. C NEXT KEEP TRACK OF LOWER RIGHT CORNER OF AREA IN USE.
  22321.     NRC=NREC-1
  22322.     IRUSED=MOD(NRC,MCols)+1
  22323.     ICUSED=((NRC-IRUSED+1)/MCols)+1
  22324.     IF(ICUSED.GT.RCLACT)RCLACT=ICUSED
  22325.     IF(IRUSED.GT.RRWACT)RRWACT=IRUSED
  22326. C SET RRWACT, RCLACT
  22327.     IF(ICHAR(ARRAY(119)).NE.0)CALL FVLDST(NREC,1,ARRAY(119))
  22328.     DO 2011 N=1,Ifmtbk
  22329.     IF(ICHAR(FMTDAT(1,N)).LE.0.AND.LFF.EQ.0)LFF=N
  22330. C SAVE FIRST FREE FORMAT AREA IN CASE THIS IS A NEW FORMAT...
  22331.     DO 2010 M=1,9
  22332.     IF(ARRAY(M+119).NE.FMTDAT(M,N))GOTO 2011
  22333. 2010    CONTINUE
  22334.     IFMT=N
  22335.     GOTO 2012
  22336. 2011    CONTINUE
  22337. C ON FALL THROUGH, WE FOUND NOTHING FOR IT...
  22338. C USE HIS FORMAT UNLESS WE HAVE NO ROOM, IN WHICH CASE USE LAST AREA
  22339.     IF(LFF.EQ.0)LFF=Ifmtbk
  22340.     IFMT=LFF
  22341.     DO 2013 N=1,9
  22342. 2013    FMTDAT(N,LFF)=ARRAY(119+N)
  22343. C SAVE FORMAT DATA WE NOW POINT TO...
  22344. 2012    CONTINUE
  22345. C NOW THE HARDER PART... MUST WRITE THE ARRAY'S FORMULA TOO...
  22346. C    IPM=(LPGMXF*64/2048)+1
  22347.     IBF=(MFro64)
  22348. C    IBF=(2048+31)/32/2
  22349. C    LLL=(LPGMXF*2)/IBF
  22350. C    IPM=LLL
  22351.     IPM=LPGMXF*64/MFrmo2
  22352. C IPM = NO. PAGES IN FILE. LPGMXF/(LENGTH OF ONE MEM BUFFER IN K).
  22353.     IF(IPM.LT.2)IPM=2
  22354. C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
  22355.     IHASH=NREC*9
  22356. C space out entries to speed up work by reducing collisions in hash
  22357. C table. Generally speeds things up, though it will increase paging
  22358. C in paging mode. Paging mode is very rare however.
  22359. C    JHASH=IMASK(IHASH,1023)
  22360.     JHASH=MOD(IHASH,(MFrmo2))
  22361.     IF(LPGMOD.NE.0)GOTO 5307
  22362.     IPAG=(IHASH/(MFrmo2))+1
  22363.     IPAG=MOD(IPAG,IPM)+1
  22364.     GOTO 5308
  22365. 5307    CONTINUE
  22366. C SPEED OPTIMAL PACK
  22367.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
  22368.     IPAG=FPG
  22369.     IPAG=MOD(IPAG,IPM)
  22370.     IPAG=IPAG+1
  22371. C    IPAG=1+(IHASH*IPM)/18060
  22372. 5308    CONTINUE
  22373. C ***
  22374. C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
  22375.     IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 953
  22376.     IF(MFID(1).NE.0)GOTO 952
  22377.     MFID(1)=IPAG
  22378.     GOTO 953
  22379. 952    IF(MFID(2).EQ.0)MFID(2)=IPAG
  22380. 953    CONTINUE
  22381.     IF(MFID(2).EQ.IPAG)GOTO 951
  22382.     IF(MFID(1).NE.IPAG) GOTO 954
  22383. 950    CONTINUE
  22384. C PAGE 1 IS THE ONE WE NEED.
  22385.     MFLAST=1
  22386.     MFBASE=0
  22387.     GOTO 2400
  22388. 951    CONTINUE
  22389. C NEED SECOND PAGE
  22390.     MFLAST=2
  22391.     MFBASE=(MFrmo2)
  22392. C BASE IS HASFWAY ALONG FILE...
  22393.     GOTO 2400
  22394. 954    CONTINUE
  22395. C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
  22396.     MFLAST=3-MFLAST
  22397.     MFBASE=(MFrmo2)-MFBASE
  22398. C ***
  22399. C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
  22400. C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
  22401. C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
  22402. C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
  22403. C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
  22404. C WIN.....
  22405.     IF(LPGMXF.LE.(MFro64))GOTO 2400
  22406. C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
  22407. C    IBF=(1024+31)/32
  22408. C    IBF=32
  22409. C IBF IS BLK FACTOR
  22410.     L=1+MFBASE
  22411.     LLBK=(MFID(MFLAST)-1)*IBF+1
  22412.     LHBK=MFID(MFLAST)*IBF
  22413.     DO 2170 N=LLBK,LHBK
  22414.     IF(MFMOD(MFLAST).EQ.0)GOTO 2170
  22415.     LL=L+(MFro64)-1
  22416.     WRITE(7,REC=N,ERR=2170)((IFID(K,KK),K=1,8),KK=L,LL)
  22417.     L=L+(MFro64)
  22418. 2170    CONTINUE
  22419. C NOW READ IN THE DATA
  22420. C MARK NEW PAGE TOUCHED SINCE WE WILL DO SO HERE
  22421. C    MFMOD=1
  22422.     MFID(MFLAST)=IPAG
  22423.     L=1+MFBASE
  22424.     LLBK=(MFID(MFLAST)-1)*IBF+1
  22425.     LHBK=MFID(MFLAST)*IBF
  22426.     DO 2171 N=LLBK,LHBK
  22427.     LL=L+(MFro64)-1
  22428.     READ(7,REC=N,ERR=2171)((IFID(K,KK),K=1,8),KK=L,LL)
  22429.     L=L+(MFro64)
  22430. 2171    CONTINUE
  22431. C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
  22432. 2400    CONTINUE
  22433. C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
  22434. C BUFFER.
  22435.     MFMOD(MFLAST)=1
  22436.     IARSUB=1
  22437. C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
  22438. C FROM START...
  22439. C OMIT THE ZEROING WHEN READING IN FROM FILE EXCEPT IN /MERGE MODE
  22440.     IF(NXINI.NE.0)GOTO 6233
  22441.     DO 1490 NN=1,(MFrmo2)
  22442.     N=MOD((NN+JHASH),(MFrmo2))+1+MFBASE
  22443. C    N=IMASK((NN+JHASH),1023)+1+MFBASE
  22444.     KKKKK=IFID(1,N)
  22445.     IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 6233
  22446. C SKIP ZEROING ONCE WE ENCOUNTER A VIRGIN CELL SINCE WE WOULD ALWAYS
  22447. C CLEAR TO NONVIRGIN STATUS AFTERWARDS.
  22448.     IF(KKKKK.NE.NREC)GOTO 1490
  22449. C ZERO OLD RECORDS OF THIS ONE...
  22450.     NCEL=NCEL-1
  22451.     IF(NCEL.LT.0)NCEL=0
  22452.     DO 1498 KK=1,8
  22453. 1498    IFID(KK,N)=0
  22454. 1490    CONTINUE
  22455. 6233    CONTINUE
  22456.     IFLAG=0
  22457.     DO 1500 NN=1,(MFrmo2)
  22458.     N=MOD((NN+JHASH),(MFrmo2))+1+MFBASE
  22459. C    N=IMASK((NN+JHASH),1023)+1+MFBASE
  22460.     KKKKK=IFID(1,N)
  22461.     IF(KKKKK.NE.-1.AND.KKKKK.NE.0
  22462.      1     .AND.KKKKK.NE.NREC)GOTO 1500
  22463. C FOUND A NULL NODE...
  22464. C FILL IT IN NOW.
  22465.     NCEL=NCEL+1
  22466.     IFID(1,N)=NREC
  22467.     IFLAG=1
  22468.     LFID(4,N)=CHAR(IFMT)
  22469.     LFID(3,N)=CHAR(IFLAG)
  22470. c zero new elements to ensure no extra -1's get handled as
  22471. c data. Important because they could be mistaken for cell codings now.
  22472.     do 4502 k=1,12
  22473. 4502    lfid(k+4,n)=CHAR(0)
  22474.     DO 1502 K=1,12
  22475.     LI=ARRAY(IARSUB)
  22476.     IF(ICHAR(LI).LE.0)GOTO 1505
  22477. C CHOP IT OFF AT 109 ALSO...
  22478.     IF(IARSUB.GT.109)GOTO 1560
  22479.     LFID(K+4,N)=LI
  22480.     IARSUB=IARSUB+1
  22481. 1502    CONTINUE
  22482. C NONTERMINAL COPY...NEED ANOTHER CELL. FIRST TEST FOR EXACT FIT,
  22483. C HOWEVER.
  22484.     IF(ICHAR(ARRAY(IARSUB)).LE.0)GOTO 1560
  22485.     IFLAG=2
  22486.     LFID(3,N)=CHAR(IFLAG)
  22487. C NOW GO GET MORE SPACE FOR NEXT NODE.
  22488. C NOTE IT COULD RUN OUT, BUT JUST PUNT THAT.
  22489.     GOTO 1500
  22490. 1560    CONTINUE
  22491.     IF(IFLAG.EQ.1)IFLAG=3
  22492.     LFID(3,N)=CHAR(IFLAG)
  22493. C SETS UP EITHER 1 OR 3 FOR TERMINAL NODES
  22494.     GOTO 1505
  22495. C ESCAPE FROM LOOP ON ENDS...
  22496. 1500    CONTINUE
  22497. C HERE WE RAN OUT OF ROOM. TOO BAD...CAN'T REALLY HELP IT OR
  22498. C DO MUCH. JUST FORGET IT.
  22499. C HOWEVER, PRINT A MESSAGE ON SCREEN AT LEAST...
  22500.     CALL UVT100(1,1,1)
  22501.     CALL SWRT('Formula file overflowed. Try larger file.',41)
  22502. 1505    CONTINUE
  22503. C DONE NOW.
  22504.     GOTO 5000
  22505. 3000    CONTINUE
  22506. C OPEN (CLR BITMAP)
  22507.     MFID(1)=0
  22508.     MFID(2)=0
  22509.     MFBASE=0
  22510.     MFLAST=1
  22511.     GOTO 5000
  22512. 4000    CONTINUE
  22513. C CLOSE (CLR BITMAP)
  22514.     CLOSE(7,STATUS='DELETE')
  22515.     MFBASE=0
  22516.     MFLAST=1
  22517.     MFID(1)=0
  22518.     MFID(2)=0
  22519. 5000    RETURN
  22520.     END
  22521. c -h- xvblgt.f40    Fri Aug 22 13:45:23 1986    
  22522.         SUBROUTINE XVBLGT(ID1,ID2,XX)
  22523. C
  22524. C XVBLGT - LOAD 8 BYTES GIVEN DIMENSIONS FOR GETTING THEM
  22525. C 2 DIM ARRAY, DIM'D (60,301)
  22526.     Include aparms.inc
  22527.         InTeGer*4 ID1,ID2
  22528.         REAL*8 XX
  22529.     InTeGer*4 TYPE(1,2),VLEN(9)
  22530.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1),VT(8)
  22531.     Real*8 VAVBLS(3,27)
  22532.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  22533.     REAL*8 XXV(1,1),XVT
  22534.     EQUIVALENCE(XVT,VT(1))
  22535.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  22536.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  22537.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  22538.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  22539. C ***<<<< RDD COMMON START >>>***
  22540.     InTeGer*4 RRWACT,RCLACT
  22541. C    COMMON/RCLACT/RRWACT,RCLACT
  22542.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  22543.      1  IDOL7,IDOL8
  22544. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  22545. C     1  IDOL7,IDOL8
  22546.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  22547. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  22548.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22549. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22550. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  22551. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  22552.     InTeGer*4 KLVL
  22553. C    COMMON/KLVL/KLVL
  22554.     InTeGer*4 IOLVL,IGOLD
  22555. C    COMMON/IOLVL/IOLVL
  22556. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  22557. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  22558.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  22559.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  22560.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  22561.      3  k3dfg,kcdelt,krdelt,kpag
  22562. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  22563. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  22564. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  22565. C ***<<< RDD COMMON END >>>***
  22566. CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22567. CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22568. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  22569. C NEXT BITMAPS IMPLEMENT FVLD
  22570.         CHARACTER*1 FV1(IMP1S),FV2(Imp1s),FV4(Imp1s)
  22571.     CHARACTER*1 FVXX(Imps3)
  22572.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  22573.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  22574.         Common/FVLDM/FVXX
  22575. c        COMMON/FVLDM/FV1,FV2,FV4
  22576.         CHARACTER*1 LBITS(8)
  22577.         COMMON/BITS/LBITS
  22578. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  22579. C TYPES OF AC'S STORAGE:
  22580.         CHARACTER*1 ITYP(Imp1s),LWK
  22581.         InTeGer*4 IATYP(27),iqnjq
  22582.     INTEGER*2 LL(4)
  22583.     REAL*8 XA
  22584.     EQUIVALENCE(LL(1),XA)
  22585.         COMMON/TYP/IATYP,ITYP,iqnjq
  22586. C ***<<< NULETC COMMON START >>>***
  22587.     InTeGer*4 ICREF,IRREF
  22588. C    COMMON/MIRROR/ICREF,IRREF
  22589.     InTeGer*4 MODPUB,LIMODE
  22590. C    COMMON/MODPUB/MODPUB,LIMODE
  22591.     InTeGer*4 KLKC,KLKR
  22592.     REAL*8 AACP,AACQ
  22593. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  22594.     InTeGer*4 NCEL,NXINI
  22595. C    COMMON/NCEL/NCEL,NXINI
  22596.     CHARACTER*1 NAMARY(20,MRows)
  22597. C    COMMON/NMNMNM/NAMARY
  22598.     InTeGer*4 NULAST,LFVD
  22599. C    COMMON/NULXXX/NULAST,LFVD
  22600.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  22601.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  22602. C ***<<< NULETC COMMON END >>>***
  22603. CCC    InTeGer*4 ICREF,IRREF
  22604. CCC    COMMON/MIRROR/ICREF,IRREF
  22605.         InTeGer*2 LVALBF(5,MVal)
  22606. C allow a real*8 array to be used if there is space enough in the
  22607. C lvalbf array to hold all cells.
  22608.     Real*8 xvls(1)
  22609.     Equivalence(xvls(1),lvalbf(1,1))
  22610.         InTeGer*4 MPAG(2),MPMOD(2)
  22611.         COMMON/VB/MPAG,LVALBF,MPMOD
  22612. C
  22613. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  22614. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  22615. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  22616. C AREAS WITH DATA.
  22617. C ***<<< KLSTO COMMON START >>>***
  22618.     InTeGer*4 DLFG
  22619. C    COMMON/DLFG/DLFG
  22620.     InTeGer*4 KDRW,KDCL
  22621. C    COMMON/DOT/KDRW,KDCL
  22622.     InTeGer*4 DTRENA
  22623. C    COMMON/DTRCMN/DTRENA
  22624.     REAL*8 EP,PV,FV
  22625.     DIMENSION EP(20)
  22626.     INTEGER*4 KIRR
  22627. C    COMMON/ERNPER/EP,PV,FV,KIRR
  22628.     InTeGer*4 LASTOP
  22629. C    COMMON/ERROR/LASTOP
  22630.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  22631. C    COMMON/FMTBFR/FMTDAT
  22632.     CHARACTER*1 EDNAM(16)
  22633. C    COMMON/EDNAM/EDNAM
  22634.     InTeGer*4 MFID(2),MFMOD(2)
  22635. C    COMMON/FRM/MFID,MFMOD
  22636.     InTeGer*4 JMVFG,JMVOLD
  22637. C    COMMON/FUBAR/JMVFG,JMVOLD
  22638.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  22639.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  22640. C ***<<< KLSTO COMMON END >>>***
  22641. CCC        CHARACTER*1 FMTDAT(9,Ifmtbk)
  22642. CCC        COMMON/FMTBFR/FMTDAT
  22643.     IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
  22644. C AN ACCUMULATOR. GET IT.
  22645.     xvt=vavbls(1,id1)
  22646. c    DO 7801 IV=1,8
  22647. c7801    VT(IV)=AVBLS(IV,ID1)
  22648.     XX=XVT
  22649.     RETURN
  22650. 7800    CONTINUE
  22651. C FILTER OUT TOO-LARGE ID1, ID2 THAT ARE "REFLECTED" UP
  22652. C        ID=(ID2-1)*60+ID1
  22653.     CALL REFLEC(ID2,ID1,ID)
  22654.         XX=0.
  22655. C NOTE THAT HERE IF FVLD IS 0, THIS MEANS RESULT IS 0 REGARDLESS OF
  22656. C OTHER STUFF...RETURN 0 IMMEDIATELY.
  22657. C NOTE TRICK CALL WHICH SIGNALS ANY INITIALIZATION GETS EVALUATED.
  22658.     If(mvalx10.lt.mrcx8)goto 6802
  22659. c    if(mval*10.lt.mrc*8)goto 6802
  22660. C at this point we know the array is large enough to store ALL cells
  22661. c so use it that way for speed.
  22662.     XX=xvls(ID)
  22663.     Return
  22664. 6802    Continue
  22665.     CALL FVLDGT(ID,0,LWK)
  22666.     IF(ICHAR(LWK).EQ.0)RETURN
  22667. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  22668.     IBF=(MVal/100)
  22669. C ibf = blk factor
  22670. C    IBF=(800+49)/50/2
  22671. C    IF(IBF.LT.1)IBF=1
  22672. C
  22673.     LLL=(IPGMAX*2)/IBF
  22674.     IPM=LLL
  22675.     IF(IPM.LE.2)IPM=2
  22676.     IHASH=ID
  22677.         JHASH=MOD(IHASH,(MVlov2))+1
  22678.     IF(IPGMOD.NE.0)GOTO 3402
  22679.         IPAG=(IHASH/(MVlov2))+1
  22680.         IPAG=MOD(IPAG,IPM)+1
  22681.     GOTO 3403
  22682. 3402    CONTINUE
  22683. C SPEED-OPTIMIZING PACKING
  22684.     FPG=IPGMOD
  22685. C    IF(FPG.LE.0)FPG=FPG+65536.
  22686.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
  22687.     IPAG=FPG
  22688.     IPAG=MOD(IPAG,IPM)
  22689.     IPAG=IPAG+1
  22690. C    IPAG=1+(IHASH*IPM)/18060
  22691. 3403    CONTINUE
  22692. C        IF(IPAG.LE.0)IPAG=1
  22693. C TAKE CARE OF EMPTY INITIAL BUFFER...
  22694.     IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 851
  22695.     IF(MPAG(1).NE.0)GOTO 850
  22696.     MPAG(1)=IPAG
  22697.     GOTO 851
  22698. 850    IF(MPAG(2).EQ.0)MPAG(2)=IPAG
  22699. 851    CONTINUE
  22700.     IF(MPAG(1).EQ.IPAG)GOTO 852
  22701.     IF(MPAG(2).NE.IPAG)GOTO 853
  22702. C MPAG(2)=IPAG
  22703.     MVLAST=2
  22704.     MVBASE=(MVlov2)
  22705.     GOTO 1000
  22706. 852    CONTINUE
  22707.     MVLAST=1
  22708.     MVBASE=0
  22709.     GOTO 1000
  22710. 853    CONTINUE
  22711. C SWITCH BUFFER USED LEAST RECENTLY
  22712.     MVLAST=3-MVLAST
  22713.     MVBASE=MVlov2-MVBASE
  22714. C
  22715. C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM
  22716. C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY
  22717. C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE
  22718. C COMPILER AND MACHINE ALLOW.
  22719.     IF(IPGMAX.LE.(MVal/100))GOTO 1000
  22720. C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE
  22721. C TO DISK AND BRING IN THE ONE DESIRED.
  22722. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE.
  22723.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  22724.         IRCHI=MPAG(MVLAST)*IBF
  22725.         L=1+MVBASE
  22726.         DO 500 N=IRCLO,IRCHI
  22727.     IF(MPMOD(MVLAST).EQ.0)GOTO 500
  22728.         LLL=L+(MVlo16)-1
  22729.         WRITE(13,REC=N,ERR=500)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
  22730.         L=L+(MVlo16)
  22731. 500     CONTINUE
  22732.     MPMOD(MVLAST)=0
  22733. C MARK NEW PAGE UNMODIFIED IN THIS READ PROGRAM
  22734.         MPAG(MVLAST)=IPAG
  22735. C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG
  22736.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  22737.         IRCHI=MPAG(MVLAST)*IBF
  22738.         L=1+MVBASE
  22739.         DO 501 N=IRCLO,IRCHI
  22740.         LLL=L+(MVlo16)-1
  22741.         READ(13,REC=N,ERR=501)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
  22742.         L=L+(MVlo16)
  22743. 501     CONTINUE
  22744. 1000    CONTINUE
  22745. C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG)
  22746. C SET THE VALUE INTO IT AS REQUIRED...
  22747. C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS
  22748.         IH1=JHASH-1
  22749.         DO 2 MMN=JHASH,(MVlov2)
  22750.     N=MMN+MVBASE
  22751.     NN=N
  22752. C SKIP OUT IF WE SEE VIRGIN CELLS, LEAVING XX=0.
  22753.     KKKKK=LVALBF(1,N)
  22754.     IF(KKKKK.EQ.-1)GOTO 3332
  22755.         IF(KKKKK.EQ.ID)GOTO 4
  22756. 2       CONTINUE
  22757.         IF(IH1.LT.1)RETURN
  22758.         DO 3 MMN=1,IH1
  22759.     N=MMN+MVBASE
  22760. C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT.
  22761.     NN=N
  22762.     KKKKK=LVALBF(1,N)
  22763.     IF(KKKKK.EQ.-1)GOTO 3332
  22764.         IF(KKKKK.EQ.ID)GOTO 4
  22765. 3       CONTINUE
  22766. 3332    XX=0.0
  22767.         RETURN
  22768. C RETURN IF CAN'T FIND VALUE...TOO BAD
  22769. 4       CONTINUE
  22770. C GET VALUE AS 4 16-BIT WORDS
  22771.         DO 5 M=1,4
  22772. 5       LL(M)=LVALBF(M+1,NN)
  22773.         XX=XA
  22774.         RETURN
  22775.         END
  22776. c -h- xvblst.f40    Fri Aug 22 13:45:23 1986    
  22777.         SUBROUTINE XVBLST(ID1,ID2,XX)
  22778. C
  22779. C XVBLST - STORE 8 BYTES IN VARIABLES ARRAY
  22780. C GIVEN DIMENSIONS FOR LOCATING THEM
  22781.     Include aparms.inc
  22782.         InTeGer*4 ID1,ID2
  22783.     InTeGer*4 TYPE(1,2),VLEN(9)
  22784.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1),VT(8)
  22785.     Real*8 VAVBLS(3,27)
  22786.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  22787.     REAL*8 XVT
  22788.     EQUIVALENCE(VT(1),XVT)
  22789.     REAL*8 XXV(1,1)
  22790.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  22791.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  22792.         REAL*8 XX
  22793. C ***<<<< RDD COMMON START >>>***
  22794.     InTeGer*4 RRWACT,RCLACT
  22795. C    COMMON/RCLACT/RRWACT,RCLACT
  22796.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  22797.      1  IDOL7,IDOL8
  22798. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  22799. C     1  IDOL7,IDOL8
  22800.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  22801. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  22802.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22803. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22804. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  22805. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  22806.     InTeGer*4 KLVL
  22807. C    COMMON/KLVL/KLVL
  22808.     InTeGer*4 IOLVL,IGOLD
  22809. C    COMMON/IOLVL/IOLVL
  22810. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  22811. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  22812.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  22813.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  22814.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  22815.      3  k3dfg,kcdelt,krdelt,kpag
  22816. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  22817. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  22818. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  22819. C ***<<< RDD COMMON END >>>***
  22820. CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22821. CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  22822. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  22823. C NEXT BITMAPS IMPLEMENT FVLD
  22824.         CHARACTER*1 FV1(Imp1s),FV2(Imp1s),FV4(Imp1s)
  22825.     CHARACTER*1 FVXX(IMPS3)
  22826.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(Imp2s))
  22827.     EQUIVALENCE (FV4(1),FVXX(Imp3s))
  22828.         Common/FVLDM/FVXX
  22829. c        COMMON/FVLDM/FV1,FV2,FV4
  22830.         CHARACTER*1 LBITS(8)
  22831.         COMMON/BITS/LBITS
  22832. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  22833. C TYPES OF AC'S STORAGE:
  22834.         CHARACTER*1 ITYP(Imp1s)
  22835. C ***<<< NULETC COMMON START >>>***
  22836.     InTeGer*4 ICREF,IRREF
  22837. C    COMMON/MIRROR/ICREF,IRREF
  22838.     InTeGer*4 MODPUB,LIMODE
  22839. C    COMMON/MODPUB/MODPUB,LIMODE
  22840.     InTeGer*4 KLKC,KLKR
  22841.     REAL*8 AACP,AACQ
  22842. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  22843.     InTeGer*4 NCEL,NXINI
  22844. C    COMMON/NCEL/NCEL,NXINI
  22845.     CHARACTER*1 NAMARY(20,MRows)
  22846. C    COMMON/NMNMNM/NAMARY
  22847.     InTeGer*4 NULAST,LFVD
  22848. C    COMMON/NULXXX/NULAST,LFVD
  22849.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  22850.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  22851. C ***<<< NULETC COMMON END >>>***
  22852. CCC    InTeGer*4 ICREF,IRREF
  22853. CCC    COMMON/MIRROR/ICREF,IRREF
  22854.         InTeGer*4 IATYP(27),iqnjq
  22855.         COMMON/TYP/IATYP,ITYP,iqnjq
  22856. C
  22857. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  22858. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  22859. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  22860. C AREAS WITH DATA.
  22861.         CHARACTER*1 LLTST
  22862. C ***<<< KLSTO COMMON START >>>***
  22863.     InTeGer*4 DLFG
  22864. C    COMMON/DLFG/DLFG
  22865.     InTeGer*4 KDRW,KDCL
  22866. C    COMMON/DOT/KDRW,KDCL
  22867.     InTeGer*4 DTRENA
  22868. C    COMMON/DTRCMN/DTRENA
  22869.     REAL*8 EP,PV,FV
  22870.     DIMENSION EP(20)
  22871.     INTEGER*4 KIRR
  22872. C    COMMON/ERNPER/EP,PV,FV,KIRR
  22873.     InTeGer*4 LASTOP
  22874. C    COMMON/ERROR/LASTOP
  22875.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  22876. C    COMMON/FMTBFR/FMTDAT
  22877.     CHARACTER*1 EDNAM(16)
  22878. C    COMMON/EDNAM/EDNAM
  22879.     InTeGer*4 MFID(2),MFMOD(2)
  22880. C    COMMON/FRM/MFID,MFMOD
  22881.     InTeGer*4 JMVFG,JMVOLD
  22882. C    COMMON/FUBAR/JMVFG,JMVOLD
  22883.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  22884.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  22885. C ***<<< KLSTO COMMON END >>>***
  22886. CCC        COMMON/FMTBFR/FMTDAT
  22887.         InTeGer*2 LVALBF(5,MVal)
  22888.     Real*8 xvls(1)
  22889.     Equivalence(xvls(1),LValbf(1,1))
  22890.         InTeGer*4 MPAG(2),MPMOD(2)
  22891.         COMMON/VB/MPAG,LVALBF,MPMOD
  22892.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  22893.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  22894.         InTeGer*2 LL(4)
  22895.         REAL*8 XA
  22896.         EQUIVALENCE(XA,LL(1))
  22897. CCC    InTeGer*4 NCEL,NXINI
  22898. CCC    COMMON/NCEL/NCEL,NXINI
  22899.     IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
  22900. C AN ACCUMULATOR. SET IT.
  22901.     XVT=XX
  22902.     vavbls(1,id1)=xvt
  22903. c    DO 7801 IV=1,8
  22904. c7801    AVBLS(IV,ID1)=VT(IV)
  22905.     RETURN
  22906. 7800    CONTINUE
  22907. C        ID=(ID2-1)*60+ID1
  22908.     CALL REFLEC(ID2,ID1,ID)
  22909.     If(mvalx10.lt.mrcx8)goto 6803
  22910. c    if(mval*10.lt.mrc*8)goto 6803
  22911. C we have enough storage to hold all cells in memory so do so.
  22912.     xvls(ID)=XX
  22913.     Return
  22914. 6803    Continue
  22915. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  22916. C       IPM=(IPGMAX*200/800)
  22917.     IF(ID.LE.0)RETURN
  22918. C CALL FVLDGT TO TELL IF ANYTHING IS SET FOR THE CELL...
  22919.     CALL FVLDGT(ID1,ID2,LLTST)
  22920.     IF(ICHAR(LLTST).NE.0)GOTO 3419
  22921.     CALL FVLDST(ID1,ID2,Char(252))
  22922. c 252 = -4 to 8 bits
  22923. C TRICK ... SET UP SIGN BIT IN FVLD SO XVBLGT CAN FIND OUT IF
  22924. C VARIABLE HAS EVER BEEN WRITTEN AND EXIT IF NOT. INDEPENDENT OF
  22925. C USUAL SETTING OF FVLD SINCE IT USES "SIGN" BIT ONLY.
  22926. 3419    CONTINUE
  22927.     IBF=(MVal+99)/100
  22928. C    IBF=(800+49)/50/2
  22929. C    IF(IBF.LT.1)IBF=1
  22930.     LLL=IPGMAX*2/ibf
  22931. C 4000 BYTES PER BUFFER (400 CELLS AT 10 PER CELL)
  22932. C    LLL=(IPGMAX*2)/IBF
  22933.     IPM=LLL
  22934.     IF(IPM.LE.2)IPM=2
  22935.     IHASH=ID
  22936.         JHASH=MOD(IHASH,(MVlov2))+1
  22937.     IF(IPGMOD.NE.0)GOTO 3400
  22938. C SPACE-OPTIMIZING PACKING
  22939.         IPAG=(IHASH/(MVlov2))+1
  22940.         IPAG=MOD(IPAG,IPM)+1
  22941.     GOTO 3401
  22942. 3400    CONTINUE
  22943. C SPEED-OPTIMIZING PACKING
  22944.     FPG=FLOAT(IPGMOD)
  22945. C    IF(FPG.LE.0.)FPG=FPG+65536.
  22946.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
  22947.     IPAG=FPG
  22948.     IPAG=MOD(IPAG,IPM)
  22949.     IPAG=IPAG+1
  22950. C    IPAG=1+(IHASH*IPM)/18060
  22951. 3401    CONTINUE
  22952. C        IF(IPAG.LE.0)IPAG=1
  22953.     IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 850
  22954.     IF(MPAG(1).NE.0)GOTO 851
  22955.     MPAG(1)=IPAG
  22956.     GOTO 850
  22957. 851    IF(MPAG(2).EQ.0)MPAG(2)=IPAG
  22958. 850    CONTINUE
  22959.     IF(MPAG(1).EQ.IPAG)GOTO 852
  22960.     IF(MPAG(2).NE.IPAG)GOTO 853
  22961. C MPAG(2) = IPAG
  22962.     MVLAST=2
  22963.     MVBASE=(MVlov2)
  22964.     GOTO 1000
  22965. 852    CONTINUE
  22966.     MVLAST=1
  22967.     MVBASE=0
  22968.     GOTO 1000
  22969. 853    CONTINUE
  22970. C NEED NEW PAGE. FIX TO USE LEAST RECENTLY USED PAGE FOR SWAPOUT.
  22971.     MVLAST=3-MVLAST
  22972. C MVLAST = 1 OR 2
  22973.     MVBASE=MVlov2-MVBASE
  22974. C MVBASE = 0 OR 400. INITIALLY 0.
  22975. C        IF(MPAG.EQ.0)MPAG=IPAG
  22976. C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM
  22977. C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY
  22978. C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE
  22979. C COMPILER AND MACHINE ALLOW.
  22980. c
  22981.     IF(IPGMAX.LE.IBF)GOTO 1000
  22982. c
  22983. C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE
  22984. C TO DISK AND BRING IN THE ONE DESIRED.
  22985. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE.
  22986.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  22987.         IRCHI=MPAG(MVLAST)*IBF
  22988.         L=1+MVBASE
  22989.         DO 500 N=IRCLO,IRCHI
  22990.     IF(MPMOD(MVLAST).EQ.0)GOTO 500
  22991.         LLL=L+(MVlo16)-1
  22992.         WRITE(13,REC=N,ERR=500)((LVALBF(KK,K),KK=1,5),K=L,LLL)
  22993.         L=L+(MVlo16)
  22994. 500     CONTINUE
  22995. C MARK NEW PAGE MODIFIED SINCE WE WILL TOUCH IT HERE
  22996.     MPMOD(MVLAST)=1
  22997.         MPAG(MVLAST)=IPAG
  22998. C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG
  22999.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  23000.         IRCHI=MPAG(MVLAST)*IBF
  23001.         L=1+MVBASE
  23002.         DO 501 N=IRCLO,IRCHI
  23003.         LLL=L+(MVlo16)-1
  23004.         READ(13,REC=N,ERR=501)((LVALBF(KK,K),KK=1,5),K=L,LLL)
  23005.         L=L+(MVlo16)
  23006. 501     CONTINUE
  23007. 1000    CONTINUE
  23008. C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG)
  23009. C SET THE VALUE INTO IT AS REQUIRED...
  23010. C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS
  23011.     MPMOD(MVLAST)=1
  23012.     IF(NXINI.NE.0)GOTO 111
  23013.         IH1=JHASH-1
  23014.         DO 1 MMN=JHASH,(MVlov2)
  23015.     N=MMN+MVBASE
  23016. C WHILE ZEROING THE ARRAY, START AT THE HASH ADDRESS AND STOP THE ZEROING
  23017. C ONCE WE ENCOUNTER A VIRGIN RECORD. THIS WILL HOPEFULLY REDUCE OVERALL
  23018. C TIME MOST TIMES FOR ZEROING THE ARRAY.
  23019.     KKKKK=LVALBF(1,N)
  23020.     IF(KKKKK.EQ.-1)GOTO 111
  23021.         IF(KKKKK.NE.ID)GOTO 1
  23022. C ZERO ALL REFS TO THIS CELL WE'RE ABOUT TO WRITE.
  23023. C **** THIS IS QUITE TIME CONSUMING... OMIT IF POSSIBLE...
  23024.         LVALBF(1,N)=0
  23025. 1       CONTINUE
  23026.         IF(IH1.LT.1)RETURN
  23027.         DO 33 MMN=1,IH1
  23028.     N=MMN+MVBASE
  23029.     NN=N
  23030.     KKKKK=LVALBF(1,N)
  23031.     IF(KKKKK.EQ.-1)GOTO 111
  23032.         IF(KKKKK.NE.ID)GOTO 33
  23033.     LVALBF(1,N)=0
  23034. 33    CONTINUE
  23035. 111    CONTINUE
  23036. C SINCE ZERO VALUES ARE RETURNED BY DEFAULT, DON'T BOTHER STORING THEM
  23037.     IF(XX.EQ.0.0D0)RETURN
  23038.         IH1=JHASH-1
  23039.         DO 2 MMN=JHASH,(MVlov2)
  23040.     N=MMN+MVBASE
  23041.     NN=N
  23042.     KKKKK=LVALBF(1,N)
  23043.     IF(KKKKK.EQ.-1)GOTO 4
  23044.         IF(KKKKK.EQ.0)GOTO 4
  23045.     IF(KKKKK.EQ.ID)GOTO 4
  23046. 2       CONTINUE
  23047.         IF(IH1.LT.1)RETURN
  23048.         DO 3 MMN=1,IH1
  23049.     N=MMN+MVBASE
  23050.     NN=N
  23051. C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT.
  23052.     KKKKK=LVALBF(1,N)
  23053.     IF(KKKKK.EQ.-1)GOTO 4
  23054.         IF(KKKKK.EQ.0)GOTO 4
  23055.     IF(KKKKK.EQ.ID)GOTO 4
  23056. 3       CONTINUE
  23057. C TELL USER VALUE AREA OVERFLOWED, USING ROW 1 END
  23058.     CALL UVT100(1,1,1)
  23059.     CALL SWRT('Value Table Storage overflowed. Try larger file.',48)
  23060.         RETURN
  23061. C RETURN IF CAN'T FIND VALUE...TOO BAD
  23062.  
  23063. 4       CONTINUE
  23064. C SAVE VALUE AS 4 16-BIT WORDS
  23065.         XA=XX
  23066. C SAVE ID AND VALUE IN CELL...
  23067.     LVALBF(1,NN)=ID
  23068.         DO 5 M=1,4
  23069. 5       LVALBF(M+1,NN)=LL(M)
  23070.         RETURN
  23071.         END
  23072. c -h- zero.for    Fri Aug 22 13:46:23 1986    
  23073.     SUBROUTINE ZERO
  23074. C COPYRIGHT (C) 1983 GLENN EVERHART
  23075. C ALL RIGHTS RESERVED
  23076. C 60=MAX REAL ROWS
  23077. C 301=MAX REAL COLS
  23078. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  23079. C VBLS AND TYPE DIMENSIONED 60,301
  23080. C **************************************************
  23081. C *                                                *
  23082. C *         SUBROUTINE  ZERO                       *
  23083. C *                                                *
  23084. C **************************************************
  23085. C
  23086. C
  23087. C
  23088. C  ZEROS OUT ALL VARIABLES EXCEPT %
  23089. C
  23090. C
  23091. C ZERO CALLS IABS
  23092. C
  23093. C
  23094. C ZERO IS CALLED BY CMND
  23095. C
  23096. C
  23097. C
  23098. C   VARIABLE    USE
  23099. C
  23100. C      I      POINTS TO VARIABLE
  23101. C      J      INDEXES DOWN ELEMENTS OF A VARIABLE
  23102. C
  23103. C
  23104. C
  23105. C    SUBROUTINE ZERO
  23106. C
  23107.     InTeGer*4  TYPE(1,2),VLEN(9)
  23108. C
  23109.     CHARACTER*1  AVBLS(24,27)
  23110.     Real*8 VAVBLS(3,27)
  23111.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  23112.     CHARACTER*1 VBLS(8,1,1)
  23113. C
  23114.     COMMON  /V/TYPE,AVBLS,VBLS,VLEN
  23115. C
  23116. C
  23117. C
  23118. C JUST ZERO THE ACCUMULATORS HERE ... LEAVE REGULAR SHEET STUFF ALONE.
  23119. C    TYPE(1,1)=IABS(TYPE(1,1))
  23120.     VBLS(1,1,1)=Char(0)
  23121. C ZERO OUT ACCUMULATORS
  23122.     DO 1 I=1,27
  23123.     DO 1 J=1,20
  23124. 1    AVBLS(J,I)=Char(0)
  23125.     RETURN
  23126.     END
  23127. c -h- zneg.for    Fri Aug 22 13:46:23 1986    
  23128.     INTEGER FUNCTION ZNEG(INDXX)
  23129. C COPYRIGHT (C) 1983 GLENN EVERHART
  23130. C ALL RIGHTS RESERVED
  23131. C 60=MAX REAL ROWS
  23132. C 301=MAX REAL COLS
  23133. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  23134. C VBLS AND TYPE DIMENSIONED 60,301
  23135. C **************************************************
  23136. C *                                                *
  23137. C *        InTeGer*4 FUNCTION ZNEG(INDXX)          *
  23138. C *                                                *
  23139. C **************************************************
  23140. C
  23141. C DETERMINES IF VARIABLE POINTED TO BY INDXX IS ZERO OR NEGATIVE
  23142. C OR UNDEFINED AS OPPOSED TO BEING DEFINED AND POSITIVE
  23143. C
  23144. C     RETURNS      1   IF TRUE (ZERO OR NEGATIVE OR UNDEFINED)
  23145. C                  0   IF FALSE (POSITIVE)
  23146. C
  23147. C ZNEG CALLS ERRMSG TO PRINT ERROR MESSAGES.
  23148. C
  23149. C ZNEG IS CALLED BY CALC AND CMND.
  23150. C
  23151. C   VARIABLE       USE
  23152. C
  23153. C     INDXX      POINTER TO VARIABLE BEING TESTED
  23154. C     I,K        HOLDS TEMPORARY VALUES
  23155. C     ZNEG       RETURN VALUE
  23156. C     INT        HOLD INTEGER*4 VALUES
  23157. C     REAL       HOLD REAL*8 VALUES
  23158. C
  23159. C
  23160. C
  23161. C    INTEGER FUNCTION ZNEG*4(INDXX)
  23162.     REAL*8 REAL
  23163. C
  23164.     INTEGER*4 INT
  23165. C
  23166.     InTeGer*4 TYPE(1,2),VLEN(9),INDXX
  23167. C
  23168.     CHARACTER*1 AVBLS(24,27),FOUR(4),EIGHT(8)
  23169.     Real*8 VAVBLS(3,27)
  23170.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  23171.     CHARACTER*1 VBLS(8,1,1)
  23172. C
  23173.     EQUIVALENCE (EIGHT,REAL),(FOUR,INT)
  23174. C
  23175.     COMMON/V/ TYPE,AVBLS,VBLS,VLEN
  23176. C
  23177. C DEFAULT SETTING OF TRUE
  23178.     ZNEG=1
  23179.     CALL TYPGET(INDXX,1,K)
  23180. C    K=TYPE(INDXX,1)
  23181.     IF(K.GT.0)GO TO 50
  23182. C
  23183. C VARIABLE UNDEFINED
  23184.     CALL UVT100(1,1,1)
  23185.     CALL SWRT('Undefined Vbl',13)
  23186. C    CALL ERRMSG(16)
  23187.     GO TO 10000
  23188. C
  23189. 50    GOTO(100,200,300,300,400,400,400,300,200),K
  23190.     STOP 50
  23191. C
  23192. C ASCII
  23193. 100    IF(AVBLS(1,INDXX).LE.Char(0))GO TO 10000
  23194.     GO TO 9998
  23195. C
  23196. C DECIMAL AND REAL
  23197. 200    DO 210 I=1,8
  23198. 210    EIGHT(I)=AVBLS(I,INDXX)
  23199.     IF(REAL.LE.0.0D0)GO TO 10000
  23200.     GO TO 9998
  23201. C
  23202. C INTEGER, HEX, AND OCTAL
  23203. 300    DO 310 I=1,4
  23204. 310    FOUR(I)=AVBLS(I,INDXX)
  23205.     IF(INT.LE.0)GO TO 10000
  23206.     GO TO 9998
  23207. C
  23208. C MULTIPLE PRECISION
  23209. 400    IF(ICHAR(AVBLS(20,INDXX)).NE.0) GOTO 10000
  23210.     GO TO 9998
  23211. C
  23212. 9998    ZNEG=0
  23213. 10000    RETURN
  23214.     END
  23215. c -h- rimcmd.for    Fri Aug 22 13:04:33 1986    
  23216. C RIM-V INTERFACE FUNCTIONS
  23217. C
  23218.     SUBROUTINE RIMCMD(LINE)
  23219.     CHARACTER*1 LINE(80)
  23220.     CHARACTER*62 LINEC
  23221. C    EQUIVALENCE(LINEC(1:1),LINE(1))
  23222. C    INCLUDE VKLUGPRM.FTN''
  23223. C COPYRIGHT (C) 1983 GLENN EVERHART
  23224.     Include aparms.inc
  23225.     INTEGER RETCD
  23226. C
  23227. C DEFINE FILE AREAS FOR MAPPING FILES...
  23228. C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE
  23229. C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND
  23230. C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE
  23231. C INPUT - ONLY OR READ/WRITE.
  23232. C
  23233.     integer rmstat
  23234.     common/rimcom/rmstat
  23235. c rmstat returns 0 on success,  >0 for error, <0 for end of data
  23236. C
  23237.     CHARACTER*1 AVBLS(24,27),VBLS(8,1,1)
  23238.     Real*8 VAVBLS(3,27)
  23239.     Equivalence (VAVBLS(1,1),AVBLS(1,1))
  23240.     InTeGer*4 TYPE(1,2),VLEN(9)
  23241.     REAL*8 XAC,XVBLS(1,1)
  23242.     REAL*8 TAC,UAC,VAC,WAC,YAC
  23243.     REAL*8 TMP
  23244.     INTEGER*4 JVBLS(2,1,1)
  23245.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  23246.     EQUIVALENCE(XAC,AVBLS(1,27))
  23247.     EQUIVALENCE(TAC,AVBLS(1,20))
  23248.     EQUIVALENCE(UAC,AVBLS(1,21))
  23249.     EQUIVALENCE(VAC,AVBLS(1,22))
  23250.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  23251.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  23252.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  23253. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  23254. CCC    CHARACTER*1 XTNCMD(80)
  23255. C ***<<<< RDD COMMON START >>>***
  23256.     InTeGer*4 RRWACT,RCLACT
  23257. C    COMMON/RCLACT/RRWACT,RCLACT
  23258.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  23259.      1  IDOL7,IDOL8
  23260. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  23261. C     1  IDOL7,IDOL8
  23262.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  23263. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  23264.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  23265. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  23266. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  23267. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  23268.     InTeGer*4 KLVL
  23269. C    COMMON/KLVL/KLVL
  23270.     InTeGer*4 IOLVL,IGOLD
  23271. C    COMMON/IOLVL/IOLVL
  23272. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  23273. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  23274.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  23275.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  23276.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  23277.      3  k3dfg,kcdelt,krdelt,kpag
  23278. c    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  23279. c     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  23280. c     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  23281. C ***<<< RDD COMMON END >>>***
  23282. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  23283. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  23284. CCC    InTeGer*4 RRWACT,RCLACT
  23285. CCC    COMMON/RCLACT/RRWACT,RCLACT
  23286. C ***<<< XVXTCD COMMON START >>>***
  23287.     CHARACTER*1 OARRY(100)
  23288.     InTeGer*4 OSWIT,OCNTR
  23289. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  23290. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  23291.     InTeGer*4 IPS1,IPS2,MODFLG
  23292. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  23293.        InTeGer*4 XTCFG,IPSET,XTNCNT
  23294.        CHARACTER*1 XTNCMD(80)
  23295. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  23296. C VARY FLAG ITERATION COUNT
  23297.     INTEGER KALKIT
  23298. C    COMMON/VARYIT/KALKIT
  23299.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  23300.     InTeGer*4 RCMODE,IRCE1,IRCE2
  23301. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  23302. C     1  IRCE2
  23303. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  23304. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  23305. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  23306. C RCFGX ON.
  23307. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  23308. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  23309. C  AND VM INHIBITS. (SETS TO 1).
  23310.     INTEGER*4 FH
  23311. C FILE HANDLE FOR CONSOLE I/O (RAW)
  23312. C    COMMON/CONSFH/FH
  23313.     CHARACTER*1 ARGSTR(52,4)
  23314. C    COMMON/ARGSTR/ARGSTR
  23315.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  23316.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  23317.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  23318.      3  IRCE2,FH,ARGSTR
  23319. C ***<<< XVXTCD COMMON END >>>***
  23320. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  23321. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  23322. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  23323. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  23324. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  23325. C (IMPLEMENT FOR VAX ONLY)
  23326. CCC    INTEGER KALKIT
  23327. CCC    COMMON/VARYIT/KALKIT
  23328. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  23329. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  23330. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  23331. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  23332.     DIMENSION NRDSP(JIDcl,JIDrw),NCDSP(JIDcl,JIDrw)
  23333.     COMMON/D2R/NRDSP,NCDSP
  23334. C ***<<< KLSTO COMMON START >>>***
  23335.     InTeGer*4 DLFG
  23336. C    COMMON/DLFG/DLFG
  23337.     InTeGer*4 KDRW,KDCL
  23338. C    COMMON/DOT/KDRW,KDCL
  23339.     InTeGer*4 DTRENA
  23340.     Integer*4 rimopn
  23341. C    COMMON/DTRCMN/DTRENA
  23342.     REAL*8 EP,PV,FV
  23343.     DIMENSION EP(20)
  23344.     INTEGER*4 KIRR
  23345. C    COMMON/ERNPER/EP,PV,FV,KIRR
  23346.     InTeGer*4 LASTOP
  23347. C    COMMON/ERROR/LASTOP
  23348.     CHARACTER*1 FMTDAT(9,Ifmtbk)
  23349. C    COMMON/FMTBFR/FMTDAT
  23350.     CHARACTER*1 EDNAM(16)
  23351. C    COMMON/EDNAM/EDNAM
  23352.     InTeGer*4 MFID(2),MFMOD(2)
  23353. C    COMMON/FRM/MFID,MFMOD
  23354.     InTeGer*4 JMVFG,JMVOLD
  23355. C    COMMON/FUBAR/JMVFG,JMVOLD
  23356.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  23357.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  23358. C ***<<< KLSTO COMMON END >>>***
  23359. CCC    InTeGer*4 DTRENA
  23360. CCC    COMMON/DTRCMN/DTRENA
  23361.     CHARACTER *1 LINECL(82)
  23362. C    CHARACTER*70 LINEC
  23363.     EQUIVALENCE(LINEC(1:1),LINECL(1))
  23364. C    CHARACTER*80 SCRBUF
  23365.     CHARACTER*1 LBUF(128)
  23366.     CHARACTER*1 MBUF(128)
  23367.     CHARACTER*110 CLBUF,CMBUF
  23368.     CHARACTER*50 CCLBUF,CCMBUF
  23369.     CHARACTER*11 C11LBF
  23370.     real*4 real4(2)
  23371.     integer*4 int4r(2)
  23372.     real*8 real8
  23373.     equivalence(real8,real4(1))
  23374.     equivalence(int4r(1),real4(1))
  23375.     integer*4 ivalue(1430)
  23376.     real*4 value(1430)
  23377.     equivalence(value(1),ivalue(1))
  23378.     character*4 cvalue(1430)
  23379.     equivalence (cvalue(1),ivalue(1))
  23380.     real*8 dvalue(715)
  23381.     equivalence (dvalue(1),value(1))
  23382.     character*8 char8
  23383.     character*4 char4
  23384.     integer*4 ichar8(2),ichar4
  23385. c use these to long-align arguments
  23386.     equivalence(char8,ichar8(1)),(char4,ichar4)
  23387. C    EQUIVALENCE(C11LBF(1:1),CLBUF(1:1))
  23388.     logical lkey,lvar
  23389.     EQUIVALENCE(CLBUF(1:1),CCLBUF(1:1),LBUF(1),C11LBF(1:1)),
  23390.      1  (CMBUF(1:1),CCMBUF(1:1),MBUF(1))
  23391. C    EQUIVALENCE(CLBUF,LBUF(1)),(CMBUF,MBUF(1))
  23392. C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
  23393.     CHARACTER*9 FMTB
  23394.     EQUIVALENCE (FMTB(1:1),LBUF(120))
  23395. c    CHARACTER*11 FMTBF
  23396. c    CHARACTER*1 IFVLD
  23397.     integer*4 isvl1,isvl2,isvh1,isvh2,isvfg,jsv1,jsv2
  23398.     common/isv/isvl1,isvl2,isvh1,isvh2,isvfg,jsv1,jsv2
  23399.     character*132 inmsg
  23400.     integer inmsgf
  23401.     common/rinmsg/inmsgf,inmsg
  23402.     integer klug
  23403.     save klug
  23404.     data klug/0/
  23405. C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
  23406.     DO 3332 N=1,80
  23407.     NN=81-N
  23408.     IF(ICHAR(LINE(NN)).GT.32)GOTO 3333
  23409.     LINE(NN)=CHAR(0)
  23410. 3332    CONTINUE
  23411. 3333    CONTINUE
  23412. C SPACE FILL ENTIRE ARRAY
  23413.     DO 3334 N=1,82
  23414. 3334    LINECL(N)=CHAR(32)
  23415.     RETCD=1
  23416. C HANDLE RIMCMD FUNCTIONS. LINE ARRAY PASSED IN HERE
  23417. C STARTS AFTER THE "CMD" SO WE CAN DECODE IT.
  23418. C EXECUTE RIM COMMAND
  23419. C  DTRCMD (COMMAND) GIVES DTR COMMAND FACILITY AT COMMAND
  23420. C LEVEL.
  23421. 500    CONTINUE
  23422. C ENABLE/DISABLE FOR DTR FUNCTIONS
  23423. C SETTING CMDENA TO -1 IMPLIES DISABLE FUNCTIONS
  23424. 600    CONTINUE
  23425. C cmdklon enables attempt to recognize RIM phony "DOUB"
  23426. C values. cmdklof disables so dbl can be used with analy
  23427. C correctly.
  23428.     CALL SCMP(LINE,'KLON',4,ICODE)
  23429.     IF(ICODE.NE.1)GOTO 641
  23430.     klug=1
  23431. 641    continue
  23432.     CALL SCMP(LINE,'KLOF',4,ICODE)
  23433.     IF(ICODE.NE.1)GOTO 643
  23434.     klug=0
  23435. 643    continue
  23436. C cmdopen dbname - open database (must exist!)
  23437.     CALL SCMP(LINE,'OPEN',4,ICODE)
  23438.     IF(ICODE.NE.1)GOTO 700
  23439.     char8='        '
  23440.     do 601 n=1,8
  23441.         if(ichar(line(n+5)).lt.32)goto 601
  23442.     char8(n:n)=line(n+5)
  23443. 601    continue
  23444.     call RMOPEN(ichar8)
  23445.     if(rmstat.eq.0.or.rmstat.eq.16)call RMLREL
  23446.     if(rmstat.eq.0)rimopn=1
  23447.     if(rmstat.eq.0.or.rmstat.eq.16.or.rmstat.eq.90)goto 9999
  23448.     call uvt100(1,1,1)
  23449. c position to top
  23450.     call vwrt('Error on opening database',25)
  23451.     GOTO 9999
  23452. 700    CONTINUE
  23453.     CALL SCMP(LINE,'USER',4,ICODE)
  23454. C Set user password
  23455.     IF(ICODE.NE.1)GOTO 3800
  23456.         char8='        '
  23457.     do 701 n=1,8
  23458.         if(ichar(line(n+5)).lt.32)goto 701
  23459.     char8(n:n)=line(n+5)
  23460. 701    continue
  23461.     call RMUSER(ichar8)
  23462.     call RMLREL
  23463.     if(rmstat.eq.0)rimopn=1
  23464.     GOTO 9999
  23465. 3800    CONTINUE
  23466. c    GOTO 9999
  23467. 4100    CONTINUE
  23468.     CALL SCMP(LINE,'CLOSE',5,ICODE)
  23469. C CLOSE OUTPUT 
  23470.     IF(ICODE.NE.1)GOTO 4200
  23471.     call RMCLOS
  23472.     rimopn=0
  23473.     GOTO 9999
  23474. 4200    CONTINUE
  23475.     CALL SCMP(LINE,'GETATT',6,ICODE)
  23476.     IF(ICODE.NE.1)GOTO 4600
  23477. C Gets attributes of a relation (= column labels) and stores in formula of cells.
  23478. C We assume that a start cell is given and we fill in cells across from this cell
  23479. C until we are done. The command format is
  23480. C CMDGETATT relname, startcell:endcell (in a row!)
  23481. C Result is saved as aname (8 chars). In addition the numerical value
  23482. C of the 1st cell is the # rows in the relation.
  23483.         char8='        '
  23484.     do 801 n=1,8
  23485.     if(line(n+7).eq.',')goto 802
  23486.         if(ichar(line(n+7)).lt.32)goto 801
  23487.     char8(n:n)=line(n+7)
  23488. 801    continue
  23489. 802    continue
  23490. c char8 is now relname
  23491.     call rmgrel(char8,lrpw,lmpw,lastmod,numatt,numrows)
  23492.     if(rmstat.ne.0)goto 9999
  23493. C get here if we got a relation as specified.
  23494. c Now try and decode the cell name
  23495.     icomma=indx(line,44)
  23496. C LOCHR = START CHAR
  23497.     IBGN=icomma+1
  23498.     IVLD=0
  23499.     CALL GMTX(LINE,IBGN,LSTCH,JD1,JD2,IXRH,IXCH,IVLD)
  23500.     IF(IVLD.EQ.3)GOTO 9990
  23501.     maxcol=max(ixrh-jd1,ixch-jd2)
  23502. C now we have space user wants to allow
  23503.     if(maxcol.le.0)goto 9999
  23504.     tmp=numrows
  23505. C set value of cell numerically to number of rows
  23506.     CALL XVBLST(JD1,JD2,TMP)
  23507.     call fvldst(jd1,jd2,char(255))
  23508. C sets the cell as a text cell, but with desired numerical value.
  23509.     CALL REFLEC(jd2,jd1,IRXL)
  23510. C Read the cell (to get format data etc.)
  23511.     CALL WRKFIL(IRXL,LBUF,0)
  23512. C NOW zero all but what we need
  23513.     DO 4850 N=1,110
  23514.     lbuf(n)=char(32)
  23515.     if(n.le.8)lbuf(n)=char8(n:n)
  23516. 4850    CONTINUE
  23517.     lbuf(110)=char(0)
  23518. C now we have set up the cell initially with the relation name
  23519.     write(clbuf(11:16),4849)numatt
  23520. 4849    format(i6)
  23521.     lbuf(119)=char(255)
  23522.     call wrkfil(irxl,lbuf,1)
  23523. c encode the number of attributes in this relation also.
  23524. c now go across by 1 cell
  23525.     jd1=jd1+1
  23526.     call rmlatt(char8)
  23527. c the above initializes attribute seeks
  23528.     if(rmstat.ne.0)goto 9999
  23529. c now commence save of attribute names etc. in  cells.
  23530. c encoding as follows:
  23531. c  aname - 8 characters   col 1-8
  23532. c  type  - 4 characters   col 20-23 +30 cols for all...
  23533. c  matvec - 4 chars - 'mat ', 'vec ', or '    ' col 24-27
  23534. c  len1  - 8 chars - length  col 28-35
  23535. c  len2  - 8 chars - length 2 col 36-43
  23536. c  column - 8 chars col 44-51
  23537. c  keyed - 1 char col 52 (T/F)
  23538. c  var - 1 char, col 53 (t/f)
  23539.     if(numatt.gt.2000)numatt=Mrows*4
  23540.     numatt=min0(numatt,maxcol)
  23541. C ensure we only bash what user wanted (or a reasonable max for size of
  23542. C compiled spreadsheet)
  23543.     do 4860 n=1,numatt
  23544.     call rmgatt(char8,ityp,imat,lvar,ilen1,ilen2,icol,lkey)
  23545.     if(rmstat.ne.0)goto 4861
  23546. c note we limit this to mrows*4 rows. If need more, need a bigger compile... 
  23547.     CALL REFLEC(jd2,jd1,IRXL)
  23548. C Read the cell (to get format data etc.)
  23549.     CALL WRKFIL(IRXL,LBUF,0)
  23550. C NOW zero all but what we need
  23551.     DO 4870 kN=1,109
  23552.     lbuf(kn)=char(32)
  23553.     if(kn.le.8)lbuf(kn)=char8(kn:kn)
  23554. 4870    CONTINUE
  23555.     lbuf(110)=char(0)
  23556. c mark as text cell
  23557.     call fvldst(jd1,jd2,char(255))
  23558.     lbuf(119)=char(255)
  23559.     write(clbuf(50:83),4871)ityp,imat,ilen1,ilen2,icol,ikey,lvar
  23560. 4871    format(a4,a4,i8,i8,i8,l1,l1)
  23561.     call wrkfil(irxl,lbuf,1)
  23562. c Go to next cell over now.
  23563.     jd1=jd1+1
  23564. 4860    continue
  23565. 4861    continue
  23566. C note this format is chosen so that attribute names can be displayed as column
  23567. c labels. As long as only 50 chars are displayed, the extra info will not
  23568. c be visible. It is likely that any wider fields would need a different
  23569. C front end anyway.
  23570.     GOTO 9999
  23571. 4600    CONTINUE
  23572.     call scmp(line,'FIND',4,ICODE)
  23573. c RMFIND call
  23574.     if(icode.ne.1)goto 4800
  23575. c CMDFIND dbname
  23576.         char8='        '
  23577.     do 901 n=1,8
  23578.         if(ichar(line(n+5)).lt.32)goto 901
  23579.     char8(n:n)=line(n+5)
  23580. 901    continue
  23581.     call rmfind(0,ichar8)
  23582.     goto 9999
  23583. 4800    continue
  23584.     call scmp(line,'WHERE',5,icode)
  23585.     if(icode.ne.1)goto 4855
  23586. C rmwher call
  23587. C if command would be WHERE attribute oper value, use cmd
  23588. C cmdwhere attcell:valuecell,oper
  23589. C attcell will be a cell where the attribute name and other info has been
  23590. C stored via a call to CMDGETATT and valuecell will be where the value is.
  23591. C If the select is on text, the formula in the cell will be used. If
  23592. C the select is on a numeric, the value will.
  23593. C limit this to very simple where clauses (for now, at least)
  23594. c first gather the arguments while we may...
  23595.     IBGN=6
  23596.     IVLD=0
  23597.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  23598.     IF(IVLD.EQ.3)GOTO 9990
  23599.     char4='    '
  23600.     ic1=indx(line,44)
  23601.     nn=0
  23602.     ic1=ic1+1
  23603.     ic2=ic1+4
  23604.     do 904 n=ic1,ic2
  23605.     nn=nn+1
  23606.     char4(nn:nn)=line(n)
  23607. 904    continue
  23608.     ioper=ichar4
  23609.     ic1=icm2+1
  23610. c get attr cell to get attr name and type info
  23611.     call reflec(ixcl,ixrl,irx)
  23612.     call wrkfil(irx,lbuf,0)
  23613.     char8=clbuf(1:8)
  23614. c char8 is now attribute name
  23615. c cols 50-53 hold type info for this attribute
  23616.     char4=clbuf(50:53)
  23617. c char4 is now the type.
  23618.     do 903 n=1,30
  23619. 903    ivalue(n)=0
  23620.     if(char4.eq.'TEXT'.or.ioper.eq.'EQA ') goto 910
  23621. C a numerical type datum. Tread as int or float
  23622. C Find out if it's an integer or not; assume INT is integer and everything else
  23623. C is float...
  23624. C first however get spreadsheet value. Assume that this is floating point (most
  23625. C such values are).
  23626.     call xvblgt(ixrh,ixch,tmp)
  23627.     dvalue(1)=0.0d0
  23628.     if(char4.ne.'INT ')goto 905
  23629.     ivalue(1)=tmp
  23630.     goto 915
  23631. 905    continue
  23632.     if (char4.ne.'REAL')goto 906
  23633.     value(1)=tmp
  23634.     goto 915
  23635. 906    continue
  23636.     if (char4.ne.'DOUB')goto 907
  23637.     call fpfin(tmp)
  23638.     dvalue(1)=tmp
  23639.     goto 915
  23640. 907    continue
  23641. c mat or vec. punt...can't really handle this...
  23642.     ivalue(1)=1
  23643.     ivalue(2)=0
  23644.     dvalue(2)=tmp
  23645.     goto 915
  23646. 910    Continue
  23647.     call reflec(ixch,ixrh,irx)
  23648.     call wrkfil(irx,lbuf,0)
  23649. c read in value cell to get formula to use
  23650.     if(ioper.eq.'EQA ')lbuf(9)=char(0)
  23651. c if this is attribute comparison, stop the character scan after attribute name.
  23652.     do 911 n=1,110
  23653.     k=n-1
  23654.     if(ichar(lbuf(n)).eq.0)goto 912
  23655. 911    continue
  23656. 912    continue
  23657. c k is length of formula now.
  23658.     ivalue(1)=k
  23659.     ivalue(2)=0
  23660.     kk=1
  23661.     do 913 n=1,28
  23662.     cvalue(n+2)=clbuf(kk:kk+3)
  23663.     kk=kk+4
  23664. c we just copy the whole buffer into our array, but pass the correct count.
  23665. 913    continue
  23666. 915    Continue
  23667.     kk=0
  23668.     call rmwher(0,char8,ioper,value,1,kk,1)
  23669. 4855    continue
  23670.     CALL SCMP(LINE,'SORT',4,ICODE)
  23671.     IF(ICODE.NE.1)GOTO 4630
  23672. C CMDSORT - implements rmsort call.
  23673. C This too is simplified: call is
  23674. C cmdsort attcell:typcell
  23675. C where typcell contains a letter A or D for sort type of each attribute
  23676. C in attcell. (Only 1st 50 columns of attcell are used). This
  23677. C controls sort directions. Anything not an A is assumed to be a D.
  23678.     IBGN=5
  23679.     IVLD=0
  23680.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  23681.     IF(IVLD.EQ.3)GOTO 9990
  23682. c now must get the attcell.
  23683.     call reflec(ixcl,ixrl,irx)
  23684.     call wrkfil(irx,mbuf,0)
  23685.     mbuf(49)=char(0)
  23686.     call reflec(ixch,ixrh,irx)
  23687.     call wrkfil(irx,lbuf,0)
  23688.     numsort=0
  23689.     do 4852 n=1,6
  23690.     if (lbuf(n).ne.'D'.and.lbuf(n).ne.'A')goto 4852
  23691.     ii=1+(n-1)*8
  23692.     if(ichar(mbuf(ii)).lt.65)goto 4852
  23693.     numsort=numsort+1
  23694. c relations start with alphas...
  23695.     ivalue(n)=1
  23696.     if(lbuf(n).eq.'D')ivalue(n)=-1
  23697. 4852    continue
  23698.     call rmsort(0,mbuf,numsort,ivalue)
  23699. c this does the "sorted by" clause...
  23700.     GOTO 9999
  23701. 4630    CONTINUE
  23702.     CALL SCMP(LINE,'GET',3,ICOD)
  23703.     IF(ICOD.NE.1)GOTO 4700
  23704. C CMDGET titlecell,ulcell:lrcell gets data into area
  23705.     LO=4
  23706.     LHI=21
  23707.     LSTCHR=LHI
  23708.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  23709.     IF(IVLD.EQ.0)GOTO 9990
  23710. c now have relation title line cell ID
  23711. C next get the area to be filled in. We use the "value" array again
  23712. C since there's no lower limit on size of what can come in...one gets
  23713. C an entire row at a time.
  23714.     IBGN=lstchr+1
  23715.     IVLD=0
  23716.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  23717.     IF(IVLD.EQ.3)GOTO 9990
  23718. C now have pointers to the area to be filled in.
  23719. C first decode number of attributes from relation name cell
  23720.     call reflec(jd2,jd1,irx)
  23721.     call wrkfil(irx,mbuf,0)
  23722.     read(cmbuf(11:16),4849,err=9999)numatt
  23723.     if(numatt.le.0.or.numatt.gt.200)goto 9990
  23724.     jd1=jd1+1
  23725. c pass "relation name" cell
  23726.     jd1sav=jd1
  23727.     do 4636 n36=ixcl,ixch
  23728. c load a row of relation
  23729.     call rmget(0,value)
  23730.     if(rmstat.ne.0)goto 4640
  23731.     inptr=1
  23732. c inptr is pointer into value array
  23733.     jd1=jd1sav
  23734.     call reflec(jd2,jd1,irx)
  23735.     call wrkfil(irx,mbuf,0)
  23736. c read in guide cell to get type info
  23737.     do 4635 n35=ixrl,ixrh
  23738.     if((n35-ixrl+1).gt.numatt)goto 4635
  23739. C make some assumptions which in general are false but which will usually
  23740. c be true:
  23741. C no matrices or vecs
  23742. C ints are 4 bytes long
  23743. C reals are 4 bytes long
  23744. C doubs are 8 bytes long
  23745. c text is always variable length
  23746. c fill in value only for all types except text; for these
  23747. c fill in formula (to max we can accept)
  23748.     if (cmbuf(50:53).eq.'TEXT')goto 4660
  23749. c numeric type, assume it is fixed size
  23750.     tmp=ivalue(inptr)
  23751.     if (cmbuf(50:53).eq.'REAL')tmp=value(inptr)
  23752.     if (cmbuf(50:53).ne.'DOUB')goto 4663
  23753.     int4r(1)=ivalue(inptr)
  23754.     inptr=inptr+1
  23755.     int4r(2)=ivalue(inptr)
  23756.     tmp=real8
  23757.     call fpfout(tmp)
  23758. c kludge because rim doesn't really store dbl precision.
  23759. c this lets one read it anyway but won't work correctly for
  23760. c data storage. The answer seems to be that the DOUB
  23761. c attribute is not supported correctly. You can use it
  23762. c from AnalytiCalc only and it will work right, but interactive
  23763. C rim will screw up.
  23764.     if(klug.ne.0.and.int4r(2).eq.0)tmp=real4(1)
  23765. 4663    continue
  23766.     call fvldst(n35,n36,char(3))
  23767.     call xvblst(n35,n36,tmp)
  23768. c store value and set valid cell up.
  23769.     call reflec(n36,n35,irxx)
  23770.     call wrkfil(irxx,lbuf,0)
  23771.     write(clbuf(1:30),4664)tmp
  23772. 4664    format(d30.22)
  23773.     lbuf(31)=char(0)
  23774.     call wrkfil(irxx,lbuf,1)
  23775.     goto 4661
  23776. 4660    continue
  23777. c text value.
  23778.     n=ivalue(inptr)
  23779.     if(n.le.0.or.n.gt.1030)goto 9999
  23780.     nchr=ivalue(n)
  23781. c get data starting at n+1
  23782.     nov4=(nchr+3)/4
  23783. c nov4 is no. 4 byte char cells to move
  23784. c max 26
  23785.     if(nov4.gt.26)nov4=26
  23786.     if(nov4.le.0)goto 4661
  23787. c badly formed array ==> get out fast!
  23788.     call reflec(n36,n35,irxx)
  23789.     call fvldst(n35,n36,char(255))
  23790.     call wrkfil(irxx,lbuf,0)
  23791. c read in current cell contents
  23792.     kk67=1
  23793.     do 4667 n67=1,nov4
  23794.     k67=kk67+3
  23795.     clbuf(kk67:k67)=cvalue(n+n67+1)
  23796.     kk67=kk67+4
  23797. 4667    continue
  23798.     call wrkfil(irxx,lbuf,1)
  23799. c writes out the data
  23800. c    inptr=inptr+nov4+1
  23801. c pass the text
  23802. 4661    continue
  23803.     inptr=inptr+1
  23804. C go to next guide cell
  23805.     jd1=jd1+1
  23806.     call reflec(jd2,jd1,irx)
  23807.     call wrkfil(irx,mbuf,0)
  23808. 4635    continue
  23809. 4636    continue
  23810. 4640    continue
  23811. 4700    CONTINUE
  23812.     CALL SCMP(LINE,'DEL',3,ICODE)
  23813.     IF(ICODE.NE.1)GOTO 4830
  23814. C rmdel interface
  23815. C just deletes N rows
  23816. C cmddel vardel
  23817. C where value of vardel says how many rows to delete
  23818.     LO=4
  23819.     LHI=21
  23820.     LSTCHR=LHI
  23821.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  23822.     IF(IVLD.EQ.0)GOTO 9990
  23823.     call xvblgt(jd1,jd2,tmp)
  23824.     ndel=tmp
  23825.     if(ndel.le.0.or.ndel.gt.10000)goto 9990
  23826.     do 4780 n=1,ndel
  23827.     call rmdel(0)
  23828.     if(rmstat.ne.0)goto 9990
  23829. 4780    continue
  23830.     goto 9990
  23831. 4830    continue
  23832. C rmput call. Just assume user has positioned via rmget already.
  23833. C cmdput titlecell,valuerowcelllo:valuerowcellhi
  23834.     iputlod=0
  23835.     CALL SCMP(LINE,'PUT',3,ICODe)
  23836.     IF(ICODE.eq.1)iputlod=1
  23837.     call scmp(LINE,'LOD',3,ICODe)
  23838.     if(icode.eq.1)iputlod=2
  23839. c make it easier...allow cmdloa or cmdlod (SYNONYMS)
  23840.     call scmp(LINE,'LOA',3,ICODe)
  23841.     if(icode.eq.1)iputlod=2
  23842.     if(iputlod.eq.0)goto 4900
  23843. C CMDGET titlecell,ulcell:lrcell gets data into area
  23844.     LO=4
  23845.     LHI=21
  23846.     LSTCHR=LHI
  23847.     CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
  23848.     IF(IVLD.EQ.0)GOTO 9990
  23849. c now have relation title line cell ID
  23850. C next get the area to be filled in. We use the "value" array again
  23851. C since there's no lower limit on size of what can come in...one gets
  23852. C an entire row at a time.
  23853.     IBGN=lstchr+1
  23854.     IVLD=0
  23855.     CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
  23856.     IF(IVLD.EQ.3)GOTO 9990
  23857. C now have pointers to the area to be filled in.
  23858. C first decode number of attributes from relation name cell
  23859.     call reflec(jd2,jd1,irx)
  23860.     call wrkfil(irx,mbuf,0)
  23861.     read(cmbuf(11:16),4849,err=9999)numatt
  23862.     if(numatt.le.0.or.numatt.gt.200)goto 9990
  23863.     jd1=jd1+1
  23864.     jd1sav=jd1
  23865.     do 4736 n36=ixcl,ixch
  23866. c load a row of relation
  23867.     if(iputlod.eq.2.and.n35.ne.ixrl)goto 4835
  23868.     call rmget(0,value)
  23869.     if(rmstat.ne.0)goto 4640
  23870. 4835    continue
  23871.     inptr=1
  23872. c inptr is pointer into value array
  23873.     jd1=jd1sav
  23874.     call reflec(jd2,jd1,irx)
  23875.     call wrkfil(irx,mbuf,0)
  23876. c read in guide cell to get type info
  23877.     locatt=numatt*2+1
  23878.     do 4735 n35=ixrl,ixrh
  23879.     if((n35-ixrl+1).gt.numatt)goto 4735
  23880. C make some assumptions which in general are false but which will usually
  23881. c be true:
  23882. C no matrices or vecs
  23883. C ints are 4 bytes long
  23884. C reals are 4 bytes long
  23885. C doubs are 8 bytes long
  23886. c text is always variable length
  23887. c fill in value only for all types except text; for these
  23888. c fill in formula (to max we can accept)
  23889. c    call fvldst(n35,n36,char(3))
  23890.     call xvblgt(n35,n36,tmp)
  23891. c store value and set valid cell up.
  23892.     call reflec(n36,n35,irxx)
  23893.     call wrkfil(irxx,lbuf,0)
  23894.     if (cmbuf(50:53).eq.'TEXT')goto 4760
  23895. c numeric type, assume it is fixed size
  23896.     ivalue(inptr)=tmp
  23897.     if (cmbuf(50:53).eq.'REAL')value(inptr)=tmp
  23898.     if (cmbuf(50:53).ne.'DOUB')goto 4763
  23899.     call fpfin(tmp)
  23900.     real8=tmp    
  23901.     ivalue(inptr)=int4r(1)
  23902.     inptr=inptr+1
  23903.     ivalue(inptr)=int4r(2)
  23904. c    if(ivalue(inptr).eq.0)value(inptr-1)=tmp
  23905. 4763    continue
  23906. c    call fvldst(n35,n36,char(3))
  23907.     goto 4761
  23908. 4760    continue
  23909. c text value.
  23910.     ivalue(inptr)=locatt
  23911.     n=locatt
  23912.     locatt=locatt+2
  23913.     if(n.le.0.or.n.gt.1030)goto 9999
  23914. c get data starting at n+1
  23915.     call reflec(n36,n35,irxx)
  23916.     call wrkfil(irxx,lbuf,0)
  23917. c read in current cell contents
  23918. c get text size
  23919.     do 4745 n45=1,109
  23920.     nchr=n45 - 1
  23921.     if(ichar(lbuf(n45)).eq.0)goto 4746
  23922. 4745    continue
  23923. 4746    continue
  23924.     ivalue(n)=nchr
  23925. c null 2nd dim
  23926.     ivalue(n+1)=0
  23927.     nov4=(nchr+3)/4
  23928. c nov4 is no. 4 byte char cells to move
  23929. c max 26
  23930.     if(nov4.gt.26)nov4=26
  23931.     if(nov4.le.0)goto 9999
  23932. c badly formed array ==> get out fast!
  23933.     kk67=1
  23934.     do 4767 n67=1,nov4
  23935.     k67=kk67+3
  23936.     cvalue(n+n67+1)=clbuf(kk67:k67)
  23937.     kk67=kk67+4
  23938. 4767    continue
  23939.     locatt=locatt+nov4
  23940. c adjust pointer to skip data
  23941. 4761    continue
  23942.     inptr=inptr+1
  23943.     jd1=jd1+1
  23944.     call reflec(jd2,jd1,irx)
  23945.     call wrkfil(irx,mbuf,0)
  23946. 4735    continue
  23947.     if(iputlod.eq.2)goto 4862
  23948.     call rmput(0,value)
  23949.     goto 4863
  23950. 4862    continue
  23951.     call rmload(0,value)
  23952. 4863    continue
  23953. C write out the records over the ones last there
  23954. C go to next guide cell
  23955. 4736    continue
  23956. 4740    continue
  23957. 4900    continue
  23958.     CALL SCMP(LINE,'RIM',3,ICODE)
  23959.     IF(ICODE.NE.1)GOTO 5000
  23960. C CMDRIM interface...Begin RIM command
  23961. C mode where, until we see a RETURN command, RIM just handles all text input
  23962. C and output (via our subroutines). 
  23963.     inmsgf=0
  23964.     call rmmain
  23965.     GOTO 9999
  23966. 5000    CONTINUE
  23967.     CALL SCMP(LINE,'IRIM',4,ICODE)
  23968.     IF(ICODE.NE.1)GOTO 5100
  23969. C irim... CMDIRIM works like CMDRIM except it feeds rest of line to RIM
  23970. C followed by a RETURN command (via a little magic in atxti)
  23971.     do 5002 n=1,76
  23972.     inmsg(n:n)=line(n+4)
  23973. 5002    continue
  23974.     inmsgf=1
  23975.     call rmmain
  23976.     goto 9999
  23977. 5100    continue
  23978.     CALL SCMP(LINE,'SAV',3,ICODE)
  23979.     IF(ICODE.NE.1)GOTO 5200
  23980. C Cmdsav cell:cell saves text output
  23981.     IBGN=5
  23982.     IVLD=0
  23983. C cmdsav v1:v2 saves text output from rim into cells v1:v2 treated
  23984. C as a 2-d area
  23985. C cmdsav without an argument stops this saving.
  23986. C also it stops when all cells are full.
  23987.     isvfg=0
  23988.     CALL GMTX(LINE,IBGN,LSTCH,isvl1,isvl2,isvh1,isvh2,IVLD)
  23989.     IF(IVLD.EQ.3)GOTO 9990
  23990. c now must get the attcell.
  23991.     jsv1=isvl1
  23992.     jsv2=isvl2
  23993.     isvfg=1
  23994.     goto 9999
  23995. 5200    continue
  23996.     GOTO 9999
  23997. 9990    RETCD=3
  23998. C ERROR RETURN
  23999. 9999    RETURN
  24000.     END
  24001. C subroutines fpfin and fpfout convert sun->vax fp and vax->sun fp
  24002. C respectively...or at least handle format diffs
  24003. C to some extent since real has 8 bit exponent and doub has 11
  24004. C bit exponent on sun. On most machines these routines just return
  24005. C and do nothing.
  24006.     subroutine fpfin(tmp)
  24007. c get sun double in, output "vax" double with all mantissa
  24008. c etc. info and exp. in same format single and double
  24009.     real*8 tmp
  24010.     integer*4 t(2)
  24011.     real*4 r44(2)
  24012.     character*1 c8(8)
  24013.     real*8 f
  24014.     real*4 r4
  24015.     integer*4 ii
  24016.     equivalence (ii,r4)
  24017.     equivalence(f,t(1))
  24018.     equivalence(f,c8(1))
  24019.     equivalence(r44(1),f)
  24020. c kludge version initially
  24021. c    r4=rmp
  24022. c    iexpn=ishft(ii,-23)
  24023. c    ii=ishft(iexpn,23)
  24024. cc gets exponent, bashes mantissa
  24025. c    f=tmp
  24026. c    imnthi=and(t(1),1048575)
  24027. c    imnthi=lshift(imnthi,3)
  24028. c    imntlo=rshift(t(2),29)
  24029. c    imnthi=imnthi+and(imntlo,7)
  24030. c    imntlo=lshift(t(2),3)
  24031. c    t(1)=or(ii,imnthi)
  24032. c    t(2)=imntlo
  24033. c    tmp=f
  24034. cc shoves mantissa around so we save all but 3 bits of it in result
  24035. cccc    r44(1)=tmp
  24036. cccc    t(2)=0
  24037. cccc    tmp=f
  24038.     return
  24039.     end
  24040.     subroutine fpfout(tmp)
  24041. c get "Vax" double in, i.e. 1st word in sun real format
  24042. C output sun double
  24043.     real*8 tmp
  24044.     integer*4 t(2)
  24045.     real*4 r44(2)
  24046.     character*1 c8(8)
  24047.     real*8 f,ggg
  24048.     integer*4 gg(2)
  24049.     equivalence(gg(1),ggg)
  24050.     real*4 r4
  24051.     equivalence(f,t(1))
  24052.     equivalence(f,c8(1))
  24053.     equivalence(r44(1),f)
  24054. c    ggg=r44(1)
  24055. cc this gets a usable exponent...now fix up mantissas
  24056. c    iexpn=rshift(gg(1),20)
  24057. c    iexpn=lshift(iexpn,20)
  24058. c    imnthi=and(t(1),8388607)
  24059. c    jmnthi=rshift(imnthi,3)
  24060. c    gg(1)=or(iexpn,jmnthi)
  24061. c    jmnthi=and(imnthi,7)
  24062. c    imntlo=rshift(t(2),3)
  24063. c    jmnthi=lshift(jmnthi,29)
  24064. c    imntlo=or(jmnthi,imntlo)
  24065. c    gg(2)=imntlo
  24066. c    tmp=ggg
  24067. cccc    f=tmp
  24068. cccc    tmp=r44(1)
  24069.     return
  24070.     end
  24071.     subroutine atxto
  24072. C analyticalc text output to screen routine
  24073. C ***<<< XVXTCD COMMON START >>>***
  24074.     CHARACTER*1 OARRY(100)
  24075.     InTeGer*4 OSWIT,OCNTR
  24076. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  24077. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  24078.     InTeGer*4 IPS1,IPS2,MODFLG
  24079. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  24080.        InTeGer*4 XTCFG,IPSET,XTNCNT
  24081.        CHARACTER*1 XTNCMD(80)
  24082. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  24083. C VARY FLAG ITERATION COUNT
  24084.     INTEGER KALKIT
  24085. C    COMMON/VARYIT/KALKIT
  24086.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  24087.     InTeGer*4 RCMODE,IRCE1,IRCE2
  24088. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  24089. C     1  IRCE2
  24090. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  24091. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  24092. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  24093. C RCFGX ON.
  24094. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  24095. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  24096. C  AND VM INHIBITS. (SETS TO 1).
  24097.     INTEGER*4 FH
  24098. C FILE HANDLE FOR CONSOLE I/O (RAW)
  24099. C    COMMON/CONSFH/FH
  24100.     character*208 cargst
  24101.     CHARACTER*1 ARGSTR(52,4)
  24102.     equivalence(cargst,argstr(1,1))
  24103. C    COMMON/ARGSTR/ARGSTR
  24104.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  24105.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  24106.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  24107.      3  IRCE2,FH,ARGSTR
  24108. C ***<<< XVXTCD COMMON END >>>***
  24109.     integer*4 isvl1,isvl2,isvh1,isvh2,isvfg,jsv1,jsv2
  24110.     common/isv/isvl1,isvl2,isvh1,isvh2,isvfg,jsv1,jsv2
  24111.     include FILES.BLK
  24112.     character*2 crlf
  24113.     character*1 fvd
  24114.     character*128 cmbuf
  24115.     crlf(1:1)=char(13)
  24116.     crlf(2:2)=char(10)
  24117. c MUST revise CRLF definition for end of line as needed in different
  24118. C systems. This one just emits newline...
  24119. C dumps text found in variable c128wk to screen.
  24120.     do 1 n=1,128
  24121. c search for end of actual data and only emit what is really there
  24122.     nn=129-n
  24123.     if(ichar(c128wk(nn:nn)).gt.32)goto 2
  24124. 1    continue
  24125.     return
  24126. 2    continue
  24127. c only emit txt if anything was found over a space
  24128.     call vwrt(c128wk,nn)
  24129. c one could save the text in an accumulator also...
  24130. c put text into argstr however for retrieval if needed.
  24131. c this imposes no particular performance penalty and helps make
  24132. c the data available as needed.
  24133.     cargst=c128wk
  24134. C if we are storing text in a cell range, now store it...
  24135.     if(isvfg.eq.0)goto 3000
  24136. C have to store text...
  24137. C jsv1,jsv2 is cell to use for this. Update it after storage and
  24138. C when at last cell, clear isvfg
  24139.     call reflec(jsv2,jsv1,irx)
  24140. c    call fvldgt(jsv1,jsv2,fvd)
  24141. c    if (ichar(fvd).ne.0)goto 2001
  24142.     fvd=char(255)
  24143.     call fvldst(jsv1,jsv2,fvd)
  24144. c2001    continue
  24145.     call wrkfil(irx,cmbuf,0)
  24146.     cmbuf(1:109)=c128wk(1:109)
  24147.     cmbuf(110:110)=char(0)
  24148.     call wrkfil(irx,cmbuf,1)
  24149. c store the text
  24150.     if(jsv1.eq.isvh1.and.jsv2.eq.isvh2)isvfg=0
  24151. c update the storage address next
  24152.     jsv2=jsv2+1
  24153.     if(jsv2.le.isvh2)goto 2101
  24154. c inner loop bump
  24155.     jsv2=isvh1
  24156.     jsv1=jsv1+1
  24157.     if(jsv1.le.isvh1)goto 2101
  24158. c outer loop bump
  24159.     jsv1=isvl1
  24160.     isvfg=0
  24161. 2101    continue
  24162. 3000    continue
  24163.     call vwrt(crlf,2)
  24164.     do 3 n=1,128
  24165. 3    c128wk(n:n)=char(0)
  24166. c zero array for next use
  24167.     return
  24168.     end
  24169.     subroutine atxti
  24170. C analyticalc text read routine
  24171. C returns with text in c128rd area
  24172. C ***<<<< RDD COMMON START >>>***
  24173.     InTeGer*4 RRWACT,RCLACT
  24174. C    COMMON/RCLACT/RRWACT,RCLACT
  24175.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  24176.      1  IDOL7,IDOL8
  24177. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  24178. C     1  IDOL7,IDOL8
  24179.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  24180. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  24181.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  24182. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  24183. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  24184. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  24185.     InTeGer*4 KLVL,k3dfg,kcdelt,krdelt,kpag
  24186. C    COMMON/KLVL/KLVL
  24187.     InTeGer*4 IOLVL,igold
  24188. C    COMMON/IOLVL/IOLVL
  24189. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  24190. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  24191.     Integer*4 Idsptp,Idol9
  24192.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  24193.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  24194.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD,IDSPTP,IDOL9,
  24195.      3  k3dfg,kcdelt,krdelt,kpag
  24196. C ***<<< RDD COMMON END >>>***
  24197.     include FILES.BLK
  24198.     character*1 cr,lf
  24199.     character*132 inmsg
  24200.     integer inmsgf
  24201.     common/rinmsg/inmsgf,inmsg
  24202. c Hackery here to pass commands to RIM one at a time and return...
  24203.     if(inmsgf.eq.0)goto 1000
  24204.     if(inmsgf.lt.0)goto 1001
  24205. c inmsg > 90: initial pass. Put in the given command.
  24206.     c128rd=inmsg
  24207.     cr = char(13)
  24208.     lf=char(10)
  24209.     inmsgf= -1
  24210.     goto 2000
  24211. 1001    continue
  24212.     inmsgf = 0
  24213.     c128rd='RETURN                      '
  24214.     goto 2000
  24215. 1000    continue
  24216.     IF(IOLVL.NE.11)READ(IOLVL,9002,END=9999,ERR=9999)c128rd
  24217. 9002    FORMAT(a102,a102)
  24218. C FOR READING THE CONSOLE, WE NEED A QIO$ TO CAPTURE ESCAPE SEQUENCES.
  24219.     IF(IOLVL.EQ.11)CALL GETTTL(c128rd)
  24220. 2000    c128rd(132:132)=char(0)
  24221.     CALL GTMUNG(C128rd)
  24222.     icrfg=0
  24223.         do 8000 n=1,132
  24224.     nn=133-n
  24225.     if(ichar(c128rd(nn:nn)).gt.32)goto 8001
  24226.     if(ichar(c128rd(nn:nn)).eq.13)icrfg=1
  24227.     if(ichar(c128rd(nn:nn)).eq.10)icrfg=1
  24228.     c128rd(nn:nn)=char(32)
  24229. 8000    continue
  24230. 8001    continue
  24231. c above guarantees we don't get a lot of extra spaces after the data
  24232.     if(icrfg.ne.0)call swrt(lf,1)
  24233.     if(icrfg.ne.0)call swrt(cr,1)
  24234.     return
  24235. 9999    continue
  24236.     close(iolvl)
  24237.     iolvl=11
  24238.     c128rd(1:1)=char(26)
  24239. c end of file returns explicit control Z in position 1
  24240.     return
  24241.     end
  24242. C RimLib ...
  24243.