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

Text File | 1988-04-11 | 95KB | 3,157 lines

c -h- acini1.fnw    Fri Aug 22 12:55:08 1986
C PORTACALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN.
    SUBROUTINE INITA1(KMAP,KWID,ICODE)
C
    InTeGer*4 PRL(6)
        CHARACTER*1 NOWRAP ( 2 )
    CHARACTER*1 FORM,FVLD,CMDLIN(132)
    INTEGER*4 VNLT
    INTEGER IFCW
c    EXTERNAL LCWRQQ
    DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 RRWACT,RCLACT
CCC    COMMON/RCLACT/RRWACT,RCLACT
CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC    InTeGer*4 LLCMD,LLDSP
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    COMMON/D2R/NRDSP,NCDSP
CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    CHARACTER*1 FORM2(4)
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    InTeGer*4 OSWIT,OCNTR
CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 TYPE(1,1),VLEN(9)
CCC    InTeGer*4 KLVL
CCC    COMMON/KLVL/KLVL
CCC    InTeGer*4 IOLVL
CCC    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
    REAL*8 XXV(1,1)
    EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
    CHARACTER*1 DVFMT(12),DEFFMT(10)
    CHARACTER*12 CDVFMT
    EQUIVALENCE(DVFMT(2),DEFFMT(1))
    EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
    COMMON/DEFVBX/DVFMT
    CHARACTER*1 NMSH(80)
    CHARACTER*80 NMSH80
    EQUIVALENCE(NMSH80(1:1),NMSH(1))
    COMMON/NMSH/NMSH
CCC    InTeGer*4 IPS1,IPS2,MODFLG
CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
CCC       CHARACTER*1 XTNCMD(80)
CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
CCC    INTEGER KALKIT
CCC    COMMON/VARYIT/KALKIT
CCC    InTeGer*4 FORMFG,RCFGX,PZAP
CCC    InTeGer*4 RCONE,RCMODE,IRCE1,IRCE2
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCC     1  IRCE1,IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALC
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED
    InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY.
    INTEGER*4 I4TMP
C ***<<< NULETC COMMON START >>>***
    InTeGer*4 ICREF,IRREF
C    COMMON/MIRROR/ICREF,IRREF
    InTeGer*4 MODPUB,LIMODE
C    COMMON/MODPUB/MODPUB,LIMODE
    InTeGer*4 KLKC,KLKR
    REAL*8 AACP,AACQ
C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
    InTeGer*4 NCEL,NXINI
C    COMMON/NCEL/NCEL,NXINI
    CHARACTER*1 NAMARY(20,301)
C    COMMON/NMNMNM/NAMARY
    InTeGer*4 NULAST,LFVD
C    COMMON/NULXXX/NULAST,LFVD
    COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC    InTeGer*4 ICREF,IRREF
CCC    COMMON/MIRROR/ICREF,IRREF
C SETS NUMBER OF COLS TO ADD ON ROW OVERFLOW, ROWS TO ADD ON COL OVERFLOW
C FOR CELL ALIASING.
    REAL*8 DVS(20,75)
    COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
    REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
    LOGICAL*4 LEXIST
    InTeGer*4 QCAC,QCENT(8),ACV(8)
    COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
    COMMON/DSPCMN/DVS,CWIDS
    CHARACTER*1 CHR
    character*20 fwt
    EQUIVALENCE(FWT(1:1),CHR)
C DISABLE FLOATING EXCEPTIONS
C    CALL LCWRQQ(IFCW)
C (MOVED LCWRQQ CALL TO MAIN)
    IDOL7=1
C ENABLE SCROLLING INITIALLY
C ZERO "SAVED DISPLAY VALUES" FIRST...
    DO 35 N=1,75
    DO 35 NN=1,20
35    DVS(NN,N)=0.
    MODFLG=1
C INITIALLY IN NON ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
C SETUP INITIAL DISPLAY LIMITS ACTUALLY USED.
    RRWACT=1
    RCLACT=1
    IOLVL=11
    DRWV=7
    DCLV=19
    LLCMD=22
    LLDSP=23
    ICREF=10
    IRREF=50
C SET INCREMENTS TO 1/6 OF TOTAL FOR STARTERS.
    KLVL=1
    KALKIT=0
    IRCE1=0
    IRCE2=0
    RCMODE=2
    ICODE=0
    idol3=0
    idol4=0
    idol5=20000
    idol6=20000
    RCFGX=0
    FORMFG=0
C      CALL GETADR ( PRL, NOWRAP )
      PRL ( 2 ) = 2
c    OPEN(6,FILE='CON:',STATUS='NEW',FORM='FORMATTED')
    OPEN(11,FILE='CON:20/210/450/30/Analy Command Inputs',
     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
c    OPEN(18,FILE='CON:20/210/450/30/Analy Cmd Prompts',
c     1  ACTION='BOTH',ACCESS='SEQUENTIAL',FORM='FORMATTED')
C LOOK FOR 'ACINIT.PRM' INITIALIZER FILE. IF ONE FOUND, READ IT.
C IF NOT, ASK AT CONSOLE FOR SINGLE/DBL PRECISION AND INITIAL VIDEO MODE
    IVV=11
C SET UP AS THOUGH WE HAD AN @ACINIT.PRM AT STARTUP AND
C ALLOW IT TO GO THRU NORMALLY...
    INQUIRE(FILE='ACINIT.PRM',EXIST=LEXIST)
    IF(.NOT.LEXIST)GOTO 6003
    OPEN(3,FILE='ACINIT.PRM',STATUS='OLD',FORM='FORMATTED')
C    CALL RASSIG(3,'ACINIT.PRM')
    IVV=3
    IOLVL=3
    GOTO 6403
6003    CONTINUE
C    OPEN(5,FILE='CON:',STATUS='OLD',FORM='FORMATTED')
C OPEN EITHER CONSOLE OR INIT FILE AT FIRST...
6403    CONTINUE
6005    FORMAT(80A1)
C For AMIGA always use "BIOS MODE" so we can have special windowing
C code in place of the Fortran I/O. Fortran console I/O will be done
C using LUN 11 in a CON: window, but most normal spreadsheet
C operations will take place in a special window over which we will have
C finer grained control...
C
    CALL SWSET(1)
    MODFLG=1
6008    CONTINUE
C SETS UP FOR USING ROM BIOS DIRECTLY FOR EVERYTHING...
C COULD THEN USE E.G. NEWKEY TO DO KEYBOARD CMDS.
    GOTO 6002
6006    CONTINUE
C ERROR ON INPUT HERE... JUST FORGET IT.
    CLOSE(3)
    IOLVL=11
C MAKE SURE LUN 5 HAS A CONSOLE FILE OPEN.
    CLOSE(11)
    OPEN(11,FILE='CON:0/50/200/60/Analy Command',
     1  STATUS='OLD',FORM='FORMATTED')
6002    CALL UVT100(18,0,0)
C PERFORM SYSTEM DEPENDENT INITIALIZATION for terminal. (none here really)
c may later read + write auxkpd.txt to set up escape seqs.
    CALL TTYINI
C
C SET UP THE SCREEN (ERASE, ETC.)
c erase screen first
    CALL UVT100(1,5,10)
    CALL UVT100(11,2,0)
c position cursor to r5c10
    CALL UVT100(1,5,10)
C ZERO THE VARIABLES TO START OFF WITH.
    DO 2070 KK=1,20
    DO 2070 KKK=1,27
2070    AVBLS(KK,KKK)=0
C SET UP WORK ARRAY BITMAP
    CALL WRKFIL(1,FORM,2)
c set reverse video title
    CALL UVT100(13,7,0)
    CALL SWRT('AnalytiCalc-68K',15)
    CALL UVT100(1,6,12)
    CALL SWRT('V22-03D',7)
    CALL UVT100(13,0,0)
    CALL UVT100(1,8,3)
    CALL SWRT(' ...The Analyst`s Tool',22)
    CALL UVT100(1,9,5)
    CALL SWRT('Copyright (C) 1988 Glenn & Mary Everhart',40)
    CALL UVT100(1,10,1)
C ALLOW SPACE FOR ASKING FOR MONEY LATER VIA PATCH IF DESIRED.
    CALL SWRT('If you use this program please send $10.00 payment',
     1  50)
    CALL UVT100(1,11,1)
    CALL SWRT('to Glenn Everhart, 25 Sleigh Ride, Glen Mills PA. ',
     1  50)
    CALL UVT100(1,12,1)
    CALL SWRT('19342 to register. May be copied for evaluation   ',
     1  50)
    Call UVT100(1,13,1)
    CALL SWRT(' purposes by recipient for others. ',35)
C NOW GET ON WITH USEFUL WORK.
      PRL ( 2 ) = 1
      PRL ( 3 ) = 0
c set ansi mode...
      CALL UVT100 ( 18 ,0,0)
    KWID=10
    KMAP=1
    RETURN
    END
c -h- acini2.for    Fri Aug 22 12:55:25 1986
C PORTACALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
C PARAMETER 18060=60*301
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
    SUBROUTINE INITA2(KMAP,KWID,ICODE,IKONS)
C
    InTeGer*4 PRL(6)
        CHARACTER*1 NOWRAP ( 2 )
    CHARACTER*1 FORM,FVLD,CMDLIN(132)
    INTEGER*4 VNLT
    INTEGER IFCW
C    EXTERNAL LCWRQQ
    DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 RRWACT,RCLACT
CCC    COMMON/RCLACT/RRWACT,RCLACT
CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    InTeGer*4 LLCMD,LLDSP
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    COMMON/D2R/NRDSP,NCDSP
C ***<<< NULETC COMMON START >>>***
    InTeGer*4 ICREF,IRREF
C    COMMON/MIRROR/ICREF,IRREF
    InTeGer*4 MODPUB,LIMODE
C    COMMON/MODPUB/MODPUB,LIMODE
    InTeGer*4 KLKC,KLKR
    REAL*8 AACP,AACQ
C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
    InTeGer*4 NCEL,NXINI
C    COMMON/NCEL/NCEL,NXINI
    CHARACTER*1 NAMARY(20,301)
C    COMMON/NMNMNM/NAMARY
    InTeGer*4 NULAST,LFVD
C    COMMON/NULXXX/NULAST,LFVD
    COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC    InTeGer*4 ICREF,IRREF
CCC    COMMON/MIRROR/ICREF,IRREF
CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    CHARACTER*1 FORM2(4)
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    InTeGer*4 OSWIT,OCNTR
CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 TYPE(1,1),VLEN(9)
CCC    InTeGer*4 KLVL
CCC    COMMON/KLVL/KLVL
CCC    InTeGer*4 IOLVL
CCC    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
    REAL*8 XXV(1,1)
    EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
    CHARACTER*1 DVFMT(12),DEFFMT(10)
    EQUIVALENCE(DVFMT(2),DEFFMT(1))
    CHARACTER*12 CDVFMT
    EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
    COMMON/DEFVBX/DVFMT
    CHARACTER*1 NMSH(80)
    CHARACTER*80 NMSH80
    EQUIVALENCE(NMSH80(1:1),NMSH(1))
    COMMON/NMSH/NMSH
CCC    InTeGer*4 IPS1,IPS2,MODFLG
CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
CCC       CHARACTER*1 XTNCMD(80)
CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
CCC    INTEGER KALKIT
CCC    COMMON/VARYIT/KALKIT
CCC    InTeGer*4 FORMFG,RCFGX,PZAP
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
    InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
    INTEGER*4 I4TMP
    REAL*8 DVS(20,75)
    COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
    REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
    InTeGer*4 QCAC,QCENT(8),ACV(8)
    COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
C BITMAP
C    CHARACTER*1 IBITMP
C    DIMENSION IBITMP(2258)
C    COMMON/INITD/IBITMP
C    CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
    COMMON/DSPCMN/DVS,CWIDS
    character*35 fwt
C ***<<< KLSTO COMMON START >>>***
    InTeGer*4 DLFG
C    COMMON/DLFG/DLFG
    InTeGer*4 KDRW,KDCL
C    COMMON/DOT/KDRW,KDCL
    InTeGer*4 DTRENA
C    COMMON/DTRCMN/DTRENA
    REAL*8 EP,PV,FV
    DIMENSION EP(20)
    INTEGER*4 KIRR
C    COMMON/ERNPER/EP,PV,FV,KIRR
    InTeGer*4 LASTOP
C    COMMON/ERROR/LASTOP
    CHARACTER*1 FMTDAT(9,76)
C    COMMON/FMTBFR/FMTDAT
    CHARACTER*1 EDNAM(16)
C    COMMON/EDNAM/EDNAM
    InTeGer*4 MFID(2),MFMOD(2)
C    COMMON/FRM/MFID,MFMOD
    InTeGer*4 JMVFG,JMVOLD
C    COMMON/FUBAR/JMVFG,JMVOLD
    COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC    CHARACTER*1 EDNAM(16)
CCC    COMMON/EDNAM/EDNAM
    CHARACTER*1 EDNINI(4)
    DATA EDNINI/'E','D','I','T'/
C    DATA NOWRAP / "24,0 /
C
    DO 2900 III=1,16
2900    EDNAM(III)=' '
    DO 2901 III=1,4
2901    EDNAM(III)=EDNINI(III)
    IF(IKONS.EQ.0)GOTO 3000
3002    CONTINUE
    CALL UVT100(1,1,1)
    CALL VWRT('Alter Widths or Mapping Y/N:',28)
    ILL=IOLVL
C    IF(ILL.EQ.5)ILL=0
    READ(ILL,3006,END=5600,ERR=5600)FORM
    IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3000
    CALL VWRT('Enter NEW Global Column Width 1-120:',36)
C ALTER MAPPING DESIRED
    READ(ILL,3004,END=5600,ERR=5600)KWID
3004    FORMAT(I3)
    IF(KWID.LT.1.OR.KWID.GT.120)KWID=10
    CALL VWRT('Enter length of display in lines (nominally 24):',48)
    READ(ILL,3004,END=5600,ERR=5600)III
    IF(III.LE.4.OR.III.GT.999)III=24
C RESET DISPLAY SIZE IN S COMMAND QUESTIONS AS NEEDED.
    LLDSP=III
    LLCMD=III-1
    CALL VWRT('Change annotate editor from "EDIT" [Y/N]:',41)
    READ(ILL,3006,END=5600,ERR=5600)FORM
    IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3031
    CALL VWRT('Give desired edit command:',26)
    READ(ILL,3006,END=5600,ERR=5600)EDNAM
    EDNAM(16)=' '
C ENSURE THERE'S A SPACE AT END OF EDITOR NAME
3031    CONTINUE
    CALL VWRT('Modify Extended Area Remap Y/N: ',31)
    READ(ILL,3006,END=5600,ERR=5600)FORM
    IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3502
    CALL VWRT('# cols to move over on row overflow:',36)
    READ(ILL,3004,END=5600,ERR=5600)ICREF
    IF(ICREF.GT.60)ICREF=10
    IF(ICREF.LT.0)ICREF=10
    CALL VWRT('# rows to move down on col overflow:',34)
    READ(ILL,3004,END=5600,ERR=5600)IRREF
    IF(IRREF.GT.300)IRREF=50
    IF(IRREF.LT.0)IRREF=50
C FORCE THE RESULTS TO MAKE SENSE. 0 TO 60 ON COLS, 0-300 ON ROWS.
C IF USER BOTHERS TO READ MANUALS THIS WILL BE EXPLAINED.
3502    CONTINUE
    CALL VWRT('Reset Display to Upper Left of Sheet Y/N:',40)
    READ(ILL,3006,END=5600,ERR=5600)FORM
    IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')KMAP=0
3006    FORMAT(80A1,50A1)
3000    CONTINUE
    RETURN
5600    CONTINUE
    IOLVL=11
    CLOSE(3)
    Rewind 11
c    CLOSE(11)
c    OPEN(11,FILE='CON:0/0/100/100/Analy Command',
c     1  STATUS='OLD',FORM='FORMATTED')
    RETURN
    END
c -h- acini3.for    Fri Aug 22 12:55:39 1986
C PORTACALC MAIN PROGRAM
C SPREAD SHEET DRIVER PROGRAM
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
C PARAMETER 18060=60*301
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
    SUBROUTINE INITB(KMAP,KWID,ICODE)
C
    InTeGer*4 PRL(6)
        CHARACTER*1 NOWRAP ( 2 )
    CHARACTER*1 FORM,FVLD,CMDLIN(132)
    INTEGER*4 VNLT
    INTEGER IFCW
C    EXTERNAL LCWRQQ
    DIMENSION FORM(128),FVLD(1,1)
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 RRWACT,RCLACT
CCC    COMMON/RCLACT/RRWACT,RCLACT
CCC    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
CCC     1  IDOL7,IDOL8
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    COMMON/D2R/NRDSP,NCDSP
CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    CHARACTER*1 FORM2(4)
d    Integer*4 ill
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    InTeGer*4 OSWIT,OCNTR

CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 TYPE(1,1),VLEN(9)
CCC    InTeGer*4 KLVL
CCC    COMMON/KLVL/KLVL
CCC    InTeGer*4 IOLVL
CCC    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
    REAL*8 XXV(1,1)
    EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
    CHARACTER*1 DVFMT(12),DEFFMT(10)
    CHARACTER*12 CDVFMT
    EQUIVALENCE(DEFFMT(1),DVFMT(2))
    EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
    COMMON/DEFVBX/DVFMT
    CHARACTER*1 NMSH(80)
    CHARACTER*80 NMSH80
    EQUIVALENCE(NMSH80(1:1),FORM(1))
    COMMON/NMSH/NMSH
CCC    InTeGer*4 IPS1,IPS2,MODFLG
CCC    COMMON/ICPOS/IPS1,IPS2,MODFLG
CCC       InTeGer*4 XTCFG,IPSET,XTNCNT
CCC       CHARACTER*1 XTNCMD(80)
CCC       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
CCC    INTEGER KALKIT
CCC    COMMON/VARYIT/KALKIT
CCC    InTeGer*4 FORMFG,RCFGX,PZAP
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
    InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
    INTEGER*4 I4TMP
    REAL*8 DVS(20,75)
    COMMON /FVLDC/FVLD
C FOLLOWING SUPPORT VVARY OVERLAY:
    REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
    InTeGer*4 QCAC,QCENT(8),ACV(8)
    COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
C BITMAP
C    CHARACTER*1 IBITMP
C    DIMENSION IBITMP(2258)
C    COMMON/INITD/IBITMP
C    CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
    COMMON/DSPCMN/DVS,CWIDS
    character*35 fwt
d       Integer*4 ifubar
d    Dimension ifubar(12)
C    DATA NOWRAP / "24,0 /
C
    idol5=20000
    idol6=20000
C INITIALLY SET JRCL TO 301 = NO. OF ROWS TO BE IN WORK FILE
    JRCL=301
    PZAP=0
    XTCFG=0
    IPSET=0
C ZERO BITMAP
C    DO 36 N1=1,2258
C36    IBITMP(N1)=0
c    LINIZZ=0
    CALL UVT100(1,14,1)
    CALL VWRT('Enter NEW floating format default Y/N:',38)
    ILL=IOLVL
C    IF(ILL.EQ.5)ILL=0
    READ(ILL,3006,END=5600,ERR=5600)FORM
    IF(FORM(1).NE.'Y'.AND.FORM(1).NE.'y')GOTO 3589
C ENTER NEW DEFAULT.
6888    CALL UVT100(1,14,1)
    CALL UVT100(12,2,0)
C LINE NOW ERASED... GET NEW FORMAT
    CALL VWRT('Enter new format. Suggest F10.2>',32)
    READ(ILL,3006,END=5600,ERR=5600)FORM
C NOW HAVE HIS DESIRED FORMAT. COPY INTO THE DEFAULT ARRAY.
C DEFFMT IS THAT.
    DO 3591 N1=1,10
    KKK=ICHAR(FORM(N1))
    KKK=MAX0(32,KKK)
C ASSUME NMSH COMPLETELY INIT'D
3591    DEFFMT(N1)=Char(KKK)
c    dvfmt(1)='('
c    dvfmt(12)=')'
C CHECK ITS LEGALITY BY TRYING TO USE IT ONCE.
    XX=3.14159
    WRITE(NMSH80(1:80),DVFMT,ERR=6888)XX
C    ENCODE(78,DVFMT,NMSH,ERR=6888)XX
C IF IT FAILS, PROGRAM WILL CRASH AND FILE WON'T GET CLOBBERED.
3589    CONTINUE
    CALL UVT100(1,15,1)
    CALL VWRT('Title for Spreadsheet:',22)
    ILL=IOLVL
C    IF(ILL.EQ.5)ILL=0
    READ(ILL,3006,END=5600,ERR=5600)FORM
3006    FORMAT(80A1,50A1)
    IF(ICHAR(FORM(1)).LE.32.AND.ICHAR(FORM(2)).LE.32) GOTO 3008
C COPY TITLE UNLESS IT'S OLD
    DO 3007 KKK=1,80
3007    NMSH(KKK)=FORM(KKK)
C THAT WAY JUST C.R. LEAVES IN OLD TITLE.
3008    CONTINUE
C ****** IF S OPTION GIVEN THEN ICODE=-2
C THEREFORE, DON'T ASK DISK SIZE ETC, BUT ALLOW RESET OF TITLE
C AND DEFAULT FORMATS.
    IF(ICODE.EQ.-2) GOTO 7831
C ******
    CALL UVT100(1,16,1)
    CALL VWRT('Give Max Rows to be used:',25)
    READ(ILL,7202,END=5600,ERR=5600)KR
    IF(KR.LE.0)KR=301
    CALL UVT100(1,17,1)
    CALL VWRT('Give Max Cols to be used:',25)
    READ(ILL,7202,END=5600,ERR=5600)KC
    IF(KC.LE.0)KC=60
C    KKK=(KR-1)*60+KC
C ALLOW REPLIES IN ANY RANGE AND REFLECT BACK TO PRIME RANGE
C NOTE WE WANT A CELL ADDRESS HERE FOR THE END CELL...
    CALL REFLEC(KR,KC,KKK)
    XKKKK=KR*KC
    XKDF=XKKKK/64.
    XKDN=XKKKK/100.
C COMPUTED ABOVE THE MIN # OF K FOR DISK FILES
    CALL UVT100(1,18,1)
    write(fwt(1:12),2058)xkdn
2058    format(F9.0)
    CALL SWRT('Min=',4)
    call swrt(fwt(1:12),9)
    write(fwt,2058)xkdf
    call swrt(' K Value file ',14)
    CALL SWRT(fwt(1:12),9)
    CALL SWRT(' K Formula file',15)
c    WRITE(0,2058)XKDN,XKDF
c2058    FORMAT(' Mins=',F9.0' K Value file, ',F9.0,' K Formula file',\)
C KKK IS MAX INDEX TO BE USED HERE.
    CALL UVT100(1,21,1)
    CALL VWRT('Give Value File size, K:',24)
    READ(ILL,7202,END=5600,ERR=5600)IPGMAX
7202    FORMAT(I6)
    IPGMOD=KKK
    IF(IPGMAX.LT.0)IPGMOD=0
    IPGMAX=IABS(IPGMAX)
    IF(IPGMAX.GT.2512)IPGMAX=1
    CALL UVT100(1,22,1)
    CALL VWRT('Give Formula File size, K:',26)
    READ(ILL,7202,END=5600,ERR=5600)LPGMXF
    LPGMOD=KKK
    IF(LPGMXF.LT.0)LPGMOD=0
    LPGMXF=IABS(LPGMXF)
C IF NUMBERS ARE ENTERED NEGATIVE, SET MODE TO "SLOW, FILE-SPACE
C CONSERVING" PACKING, SCATTERING PAGES ACROSS FILE.
    IF(LPGMXF.GT.4096)LPGMXF=(IPGMAX*3)/2
C NULL TERMINATE ALL FORMAT STRINGS.
C SET MAX WIDTH FOR PRINT TO DIMENSION OF THE BUFFER. NOTE THIS IS THE
C USUAL HARDWARE MAXIMUM SO WE DON'T WORRY TOO MUCH ABOUT IT. NOTE
C BILL TABOR'S PROGRAM TO PRINT PASTE-ABLE VERSIONS OF THE SHEET FROM
C SAVE FILES EXISTS, SO WE NEEDN'T WORRY TOO MUCH EITHER ABOUT USING
C DISPLAY FOR DOUBLE DUTY.
    MXL=132
C INITIALIZE WORK STORAGE FOR FORMULAS AND VARIABLES
    CALL WSSET
7831    CONTINUE
C SET DEFAULT WIDTHS OF COLUMNS TO 10. MAY BE ALTERED BELOW FOR DIFFERENT
C DEFAULT IF DESIRED.
    DO 16 N1=1,20
    CWIDS(N1)=KWID
16    CONTINUE
C
C NOW SET UP NRDSP, NCDSP
    IF(KMAP.EQ.0)GOTO 3009
C SET UP MAPPING NOW FOR INITIALLY UPPER LEFT CORNER OF PHYS SHEET IN DISPLAY SHT.
    DO 5 N1=1,20
    DO 5 N2=1,75
C INITIALLY WE DISPLAY THE UPPER LEFT PART OF THE SYSTEM.
C ESTABLISH ASSOCIATION INITIALLY THEREFORE OF DISPLAY TO UPPER
C LEFT OF PHYSICAL SHEET.
    NRDSP(N1,N2)=N1
    NCDSP(N1,N2)=N2+1
    DVS(N1,N2)=.00000031
5    CONTINUE
C FOR S OPTION USE SECRET -4 CODE TO RESET SHEET. STILL NEEDS WORK
C IN PORTACALC PC.
    IF(ICODE.EQ.-4)CALL WRKFIL(1,FORM,2)
3009    IF(ICODE.EQ.-4)GOTO 1
C43    CALL UVT100(1,21,1)
    KZPPD=0
    CMDLIN(1)=0
    IOLDFL=0
C3017    FORMAT(Q,80A1,80A1)
    MXL=1
    CMDLIN(MXL+1)=0
3572    FORMAT(I6)
    CALL UVT100(13,0,0)
C  SET UP RANDOM FILE AS NEEDED FOR SHEET
C EACH RECORD HAS:
C CHARS 1-110    FORMULAS
C CHARS 120-128    DISPLAY FORMAT (INITIALLY F9.2)
C CHAR 119    VALID FLAG (ALLOWS HANDLING READS.)
C    values: -3, -2: Numeric-only text (or special chars)
C         -1    : Alphanumeric text
C          0    : Uninitialized
C          1    : Alphanumeric formula
C         +2    : Number or pure numeric formula with value calculated
C         +3    : Number or pure numeric formula, value not yet computed
C CHAR 118    MAGIC NUMBER 15 (CHECKS ALL WELL)
C READ A RECORD, IF ERROR, CREATE EMPTY FILE.
C    IF(IOLDFL.EQ.0)GOTO 1
CC IF IOLDFL NONZERO IT MEANS USER CLAIMS THERE EXISTS A FILE. IF 0 IT'S NEW.
CC HERE IT'S OLD SO LET'S BE SURE IT REALLY IS OK.
1    CONTINUE
C HIT EOF OR ERROR. MUST BE A NEW FILE. THEREFORE ZERO IT TO OUR NEEDS.
C AT THIS POINT WE ARE CREATING A NEW FILE AND NEED TO ZERO IT.
C
    DO 3 N=1,128
    FORM(N)=0
3    CONTINUE
    DO 3592 N=1,9
C SET UP DEFAULT FORMAT
3592    FORM(119+N)=DEFFMT(N)
    FORM(118)=CHAR(15)
    FORM(1)='0'
    FORM(2)='.'
C CREATE NULL FILE INITIALLY BY RESETTING ALL.
    JRRCL=60*JRCL
    KZPPD=1
C
2    CONTINUE
C COMMON POINT WITH FILE PREPARED.
    PCOL=2
    PROW=1
    DCOL=1
    DROW=1
    RETURN
5600    CONTINUE
C ERROR ON READ FROM IOLVL HANDLED HERE.
C    REWIND 5
    Rewind 11
c    CLOSE(11)
c    OPEN(11,FILE='CON:0/150/500/49/Analy Command',
c     1  STATUS='OLD',FORM='FORMATTED')
    CLOSE(3)
    IOLVL=11
    RETURN
    END
c -h- block.for    Fri Aug 22 12:58:14 1986
    SUBROUTINE BLOCK
C    BLOCK DATA
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 18060 = 60*301
C 18033=18060-27
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C   +                                                +
C   +            CALC    VERSION  X01-06             +
C   +                                                +
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C *******************************************************
C *                                                     *
C *            BLOCK  DATA  MODULE                      *
C *                                                     *
C *******************************************************
C
C
C COMMON AREAS ARE INITIALIZED BY THIS MODULE.
C FAKEUP FOR MICROSOFT WHICH HAS NO BLOCK DATA.
C DO IT ALL VIA LOOPS...
C
C
C MODIFIED 18-MAY-1981 P.B. SET % TO VERSION 6
C
C
C
C   VARIABLE      USE
C
C  ALPHA(27)    HOLDS LEGAL VARIABLE NAMES: ALPHABETIC CHARACTERS
C               OR THE CHARACTER %.
C  BASED     HOLDS DEFAULT BASE.
C  BLANK        ' '
C  COMMA        ','
C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
C               SECOND SUBSCRIPT IS
C                     1 FOR DECIMAL
C                     2 FOR OCTAL
C                     3 FOR HEXADECIMAL
C  DTBL1(9,9,8) CONTROLS THE DECISION PROCESS WHEN EVALUATING A
C               BINARY OPERATION. SEE BELOW FOR DETAILS.
C  EQ           '='
C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
C               USED TO CONTROL ITERATION.
C  LINE(80)     COMMAND INPUT LINE
C  LPAR         '('
C  RPAR         ')'
C  ST1LIM       HOLDS THE SIZE OF STACK 1 (ALWAYS CONSTANT)
C  ST2LIM       HOLDS THE SIZE OF STACK 2 (ALWAYS CONSTANT)
C  ST1PT        POINTS TO THE TOP OF STACK 1 (CHANGES AS STACK IS USED)
C  ST2PT        POINTS TO THE TOP OF STACK 2 (CHANGES AS STACK IS USED)
C  ST1TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 1
C  ST2TYP(40)       DATA TYPE FOR EACH ELEMENT IN STACK 2
C  STACK1(20,40)   UTILITY STACKS USED WHEN EVALUATING EXPRESSIONS. THE FIRST
C  STACK2(20,40)   SUBSCRIPT CONTROLS INDEXING ACROSS THE BYTES OF A SINGLE
C                   VARIABLE. THE SECOND SUBSCRIPT CONTROLS STACK ELEMENTS.
C  TYPE(27)         HOLDS THE DATA TYPES FOR EACH OF THE 27 VARIABLES. SEE
C                   CODES.FTN FOR THE POSSIBLE VALUES.
C  VIEWSW           VIEW SWITCH
C                    0 = OUTPUT ERROR MESSAGES
C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
C                        EVALUATED.
C                    3 = OUTPUT EVERYTHING
C  VLEN(9)      INDEXED BY DATA TYPE. GIVES THE NUMBER OF BYTES USED
C               BY THAT DATA TYPE.
C  AVBLS(20,27)      HOLDS THE VALUES OF THE 27 LEGAL VARIABLES.(ACCUMULATORS)
C  VBLS(8,60,301)    HOLDS VALUES OF ALL VARIABLES
C
C
C
C    CONSTANTS ARE STORED IN VBLS ACCORDING TO THEIR TYPE:
C
C
C
C <----------- MULTIPLE PRECISION (M10, M8, M16) ------------------------->
C !                        <------------- DECIMAL AND REAL --------------->
C !                        !                      <-- INTEGER HEX OCTAL -->
C !                                               !             ---> ASCII <---
C !                        !                      !                        !
C
C -------------     -------------------------------------------------------
C !     !     !     !     !     !     !     !     !     !     !     !     !
C ! 20  !  19 ! ... !  9  !  8  !  7  !  6  !  5  !  4  !  3  !  2  !  1  !
C !     !     !     !     !     !     !     !     !     !     !     !     !
C -------------     -------------------------------------------------------
C
C
C NOTE: BYTE 20 HOLDS THE SIGN FOR MULTIPLE PRECISION NUMBERS.
C       0 = POSITIVE, 1 = NEGATIVE
C
C
C
C
C
C    BLOCK DATA
    InTeGer*4 LEVEL,NONBLK,LEND
    InTeGer*4 LASTOP
    InTeGer*4 ST1TYP(40),ST2TYP(40)
    InTeGer*4 TYPE(1,1)
    InTeGer*4 VIEWSW,BASED,VLEN(9),BVLEN(9)
    InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
    InTeGer*4 ITCNTV(6)
C
    CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ,LINE(80)
    CHARACTER*1 BOMMA,BBLANK,BRPAR,BLPAR,BEQ
    CHARACTER*1 STACK1(8,40),STACK2(8,40)
    CHARACTER*1 AVBLS(20,27),BLPHA(27)
    CHARACTER*1 VBLS(8,1,1)
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
d    integer*4 ill
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IC1POS,IC2POS,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    InTeGer*4 IC1POS,IC2POS
CCC    COMMON/ICPOS/IC1POS,IC2POS
    CHARACTER*1 DTBL1(9,9,8)
CC BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
C MOVED TABLE TO WRKFIL WHERE IT IS OVERLAIN BY A BUFFER DURING OPERATION
C AND JUST INITIALIZES DTBL1 AT STARTUP. THIS SHOULD ESSENTIALLY REMOVE DATA
C SPACE PENALTY FOR THIS HUGE ARRAY. NOTE IT'D BE SMALLER IF THERE WEREN'T
C SO MANY SUPPORTED DATA TYPES IN CALC.
C    InTeGer*4 BTBL(9,9,8)
C    InTeGer*4 BTBL1(9,9)
C    InTeGer*4 BTBL2(9,9),BTBL3(9,9),BTBL4(9,9),BTBL5(9,9)
C    InTeGer*4 BTBL6(9,9),BTBL7(9,9),BTBL8(9,9)
C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
    CHARACTER*1 DIGITS(16,3),BIGITS(16,3)
C
C OARRY WILL BE USED TO HOLD OUTPUT VARIABLE IF OSWIT IS NONZERO
CCC    InTeGer*4 OSWIT
C OCNTR MAY HOLD BYTES VALID IN OARRY (UP TO 100, NO MORE...)
CCC    InTeGer*4 OCNTR
CCC    CHARACTER*1 OARRY(100)
C
C ILINE IS PROGRAMMABLE LINE INPUT (I.E., NOT FROM CONSOLE)
    CHARACTER*1 ILINE(106)
    InTeGer*4 ILNFG
    InTeGer*4 ILNCT
    COMMON /ILN/ILNFG,ILNCT,ILINE
C ILINE IS PRESENT IF ILNFG <> 0 AND ILNCT HAS # BYTES IN IT.
CCC    COMMON /OAR/OSWIT,OCNTR,OARRY
    COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
    COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
    COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;         ST1LIM,ST2LIM
    COMMON /V/ TYPE,AVBLS,VBLS,VLEN
    COMMON /DECIDE/ DTBL1
    COMMON /DIGV/ DIGITS
C ***<<< KLSTO COMMON START >>>***
    InTeGer*4 DLFG
C    COMMON/DLFG/DLFG
    InTeGer*4 KDRW,KDCL
C    COMMON/DOT/KDRW,KDCL
    InTeGer*4 DTRENA
C    COMMON/DTRCMN/DTRENA
    REAL*8 EP,PV,FV
    DIMENSION EP(20)
    INTEGER*4 KIRR
C    COMMON/ERNPER/EP,PV,FV,KIRR
c    InTeGer*4 LASTOP
C    COMMON/ERROR/LASTOP
    CHARACTER*1 FMTDAT(9,76)
C    COMMON/FMTBFR/FMTDAT
    CHARACTER*1 EDNAM(16)
C    COMMON/EDNAM/EDNAM
    InTeGer*4 MFID(2),MFMOD(2)
C    COMMON/FRM/MFID,MFMOD
    InTeGer*4 JMVFG,JMVOLD
C    COMMON/FUBAR/JMVFG,JMVOLD
    COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC    COMMON /ERROR/ LASTOP
    COMMON/ITERA/ ITCNTV
    CHARACTER*1 DVFMT(12),BVFMT(12)
    COMMON/DEFVBX/DVFMT
C SUPPORT VVARY OVERLAY WITH INITIAL VARY DATA:
    REAL*8 QAC(26),QDERIV(8),QDEL(8),QOLDVV
    InTeGer*4 QCAC,QCENT(8),ACV(8)
    COMMON/VRYDAT/QAC,QDERIV,QDEL,QCAC,QCENT,QOLDVV,ACV
C INITIAL DEFAULT FORMAT FOR NUMERICS
    DATA BVFMT/'(','F','9','.','2',' ',
     1  ' ',' ',' ',' ',' ',')'/
C
C    DATA BIEWSW/2/
C    DATA ITCNTV/6*0/
    DATA BLPHA/'A','B','C','D','E','F','G','H','I','J','K','L','M',
     ;       'N','O','P','Q','R','S','T','U','V','W','X','Y','Z','%'/
    DATA BIGITS/'1','2','3','4','5','6','7','8','9',
     1  '0','0','0','0','0','0','0',
     ;       '1','2','3','4','5','6','7',
     1  '0','0','0','0','0','0','0','0','0',
     ;  '1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','0'/
    DATA BOMMA/','/,BBLANK/' '/,BRPAR/')'/,BLPAR/'('/,BEQ/'='/
C
C
C DEFAULT BASE IS 10
C    DATA BASED/10/
C
C
C STACKS ARE CURRENTLY SET AT 40 ELEMENTS DEEP
C    DATA ST1LIM/40/, ST2LIM/40/
C
C
C
C    DEFAULT TYPES
C    A,B,C,D,E,F,G,H  =  DECIMAL
C    I,J,K,L,M,N      =  INTEGER (BASE10)
C    O,P,Q,R,S,T,U,V,W,X,Y,Z  =  DECIMAL
C
C  % AS INTEGER TO HOLD CALC VERSION NUMBER
C
C    DATA TYPE/8*2,6*4,12*2,4,1*2/
c modify type array so ac's i-n are reals
C    DATA TYPE/8*2,6*2,12*2,2,1*2/
C
C
C GIVE VERSION # BY VALUE IN %
C
c don't bother with this; by the time user gets into calc,
c % already is clobbered most times, so no need for it.
c    DATA AVBLS(1,27)/6/
c    DATA AVBLS(2,27)/0/,AVBLS(3,27)/0/,AVBLS(4,27)/0/
C
C
C
C
C SPECIFY THE LENGTH USED BY EACH DATA TYPE
    DATA BVLEN/1,8,4,4,8,8,8,4,8/
C
C NOTE ALL LENGTHS 8 OR LESS SINCE MULTIPLE PRECISION THINGS SNIPPED OUT
C
C  DECISION TABLE FOR PERFORMING BINARY OPERATIONS
C
C  DTBL1(OPERAND2,OPERAND1,INDEX)
C
C  WHERE:                    OPERATOR:
C  INDEX=1    MODIFY CODE FOR OPERAND 1    */+-
C     2    MODIFY CODE FOR OPERAND 2    */+-
C     3    FUNCTION VALUE TYPE        */+-
C     4    OPERATOR CLASS            */+-
C
C     5    MODIFY CODE FOR OPERAND 1    **
C     6    MODIFY CODE FOR OPERAND 2    **
C     7    FUNCTION VALUE TYPE        **
C     8    OPERATOR CLASS            **
C
C
C  WHERE TYPE CODES (MODIFY CODES) ARE:
C    0    NO CHANGE
C    1    CONVERT TO ASCII
C    2    CONVERT TO DECIMAL
C    3    CONVERT TO HEXADECIMAL
C    4    CONVERT TO INTEGER
C    5    CONVERT TO M10
C    6    CONVERT TO M8
C    7    CONVERT TO M16
C    8    CONVERT TO OCTAL
C    9    CONVERT TO REAL
C
C  FOR */+- FUNCTION VALUE TYPES AND OPERATOR CLASS ARE PRESENTLY
C  IDENTICAL
C
C  FOR **  OPERATOR CLASSES FOLLOW:
C
C     CODE    OPERATOR CLASS
C    1    REAL**REAL
C    2    REAL**INTEGER
C    3    INTEGER**REAL
C    4    INTEGER**REAL
C    5    M8**INTEGER
C    6    M10**INTEGER
C    7    M16**INTEGER
C
C
C
C    DATA BTBL1 /4,2,3,4,5,6,7,8,9,
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,
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/
C    DATA BTBL2/
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,
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/
C    DATA BTBL3/4,2,3,4,5,6,7,8,9,
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,
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/
C    DATA BTBL4/
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,
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,
C     9  9,2,7*9/
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,
C     1  9*0,9*0/
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,
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,
C     3  4,3*0,3*9,2*0/
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,
C     4  7,9,6*7,9,9*8,9*9/
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,
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,
C     6  4,3,2,1,2,2,3*1,2,1/
C
C HERE COPY LOCAL DATA INTO THE COMMONS.
C SINCE MOST ARRAYS AND THINGS ARE SMALL, WE JUST DO IT WITH REGULAR FORTRAN.
C THE BTBL ARRAY IS HANDLED IN WRKFIL WHERE THERE'S A BIG ENOUGH ARRAY FOR
C SCRATCH SPACE TO HOLD THE INITIAL DATA; WRKFIL IS CALLED BY WSSET WITH
C "SECRET CODE" TO INIT DTBL1 FROM THE ARRAY AND DOES SO ONCE ONLY.
    VIEWSW=0
    LEVEL=1
    LASTOP=0
    BASED=10
    COMMA=BOMMA
    BLANK=BBLANK
    RPAR=BRPAR
    LPAR=BLPAR
    EQ=BEQ
    DO 1 N=1,6
    ITCNTV(N)=0
1    CONTINUE
    DO 2 N=1,27
    DO 12 NN=1,20
12    AVBLS(NN,N)=0
2    ALPHA(N)=BLPHA(N)
    ST1LIM=40
    ST2LIM=40
C THIS IS DONE IN WRKFIL SINCE THERE'S A BIG LOCAL ARRAY THERE
C WE CAN KEEP EQUIVALENCED TO THIS ONE...
C    DO 3 N2=1,9
C    DO 3 N1=1,9
C    DTBL1(N1,N2,2)=BTBL2(N1,N2)
C    DTBL1(N1,N2,3)=BTBL3(N1,N2)
C    DTBL1(N1,N2,4)=BTBL4(N1,N2)
C    DTBL1(N1,N2,5)=BTBL5(N1,N2)
C    DTBL1(N1,N2,6)=BTBL6(N1,N2)
C    DTBL1(N1,N2,7)=BTBL7(N1,N2)
C    DTBL1(N1,N2,8)=BTBL8(N1,N2)
C3    DTBL1(N1,N2,1)=BTBL1(N1,N2)
    DO 4 N=1,9
    VLEN(N)=BVLEN(N)
4    CONTINUE
    DO 5 N2=1,3
    DO 5 N1=1,16
    DIGITS(N1,N2)=BIGITS(N1,N2)
5    CONTINUE
C SET UP DEFAULT DISPLAY FORMAT (INCLUDES "(" AND ")" CHARS WHICH
C ***MUST*** BE THERE FOR MAIN PGM TO WORK).
    DO 17 N=1,12
    DVFMT(N)=BVFMT(N)
17    Continue
d    ill=loc(bvfmt(1))
d    write(*,9210) (bvfmt(n),n=1,12),ill
d    ill=loc(dvfmt(1))
d    write(*,9210) (dvfmt(n),n=1,12),ill
d9210   Format(' Bvfmt at init=',12A1,': addr=',i12)
    DO 15 N=1,26
    QAC(N)=0.
15    CONTINUE
    DO 18 N=1,8
    QDERIV(N)=1.
    ACV(N)=0
    QDEL(N)=0.
    QCENT(N)=0
18    CONTINUE
    QOLDVV=1.
    QCAC=1
    OSWIT=0
    OCNTR=0
    ILNFG=0
    ILNCT=0
    IC1POS=0
    IC2POS=0
    RETURN
    END
c -h- dtrcmd.for    Fri Aug 22 13:04:33 1986
C DATATRIEVE INTERFACE FUNCTIONS
C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
C
C THIS IS THE NON-DTR VERSION with dummy entry points for
C the DTR functions BUT supplying the new non-DTR functions
c completely.
    SUBROUTINE DTRCMD(LINE)
    CHARACTER*1 LINE(80)
    CHARACTER*62 LINEC
C    EQUIVALENCE(LINEC(1:1),LINE(1))
C    INCLUDE 'VKLUGPRM.FTN'
C COPYRIGHT (C) 1983 GLENN EVERHART
    INTEGER RETCD
C
C DEFINE FILE AREAS FOR MAPPING FILES...
C ONE INPUT FILE, TO BE ACCESSED AS A RANDOM ACCESS FILE OF 128 BYTE
C RECORDS OF DATA IF RANDOM, OR AS A FORMULA FILE IF SEQUENTIAL, AND
C ONE OUTPUT FILE TO BE WRITTEN THE SAME WAY. INPUT FILE CAN BE
C INPUT - ONLY OR READ/WRITE.
C
C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
C
C MFIOPN =    0    IF NOT OPEN
C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
C        2    IF OPEN READ ONLY, RANDOM
C        3    IF OPEN READ/WRITE, RANDOM.
C
C MFOOPN =    0    IF NOT OPEN
C        1    IF OPEN WRITE SEQUENTIAL
C        2    IF OPEN WRITE RANDOM
C
C OTHER OPTIONS DON'T MAKE SENSE.
C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
C MFILUN,MFOLUN ARE LOGICAL UNITS.
    InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
    InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH

    InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
    COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
     1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
C
C
    CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
    InTeGer*4 TYPE(1,1),VLEN(9)
    REAL*8 XAC,XVBLS(1,1)
    REAL*8 TAC,UAC,VAC,WAC,YAC
    REAL*8 TMP
    INTEGER*4 JVBLS(2,1,1)
    EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
    EQUIVALENCE(XAC,AVBLS(1,27))
    EQUIVALENCE(TAC,AVBLS(1,20))
    EQUIVALENCE(UAC,AVBLS(1,21))
    EQUIVALENCE(VAC,AVBLS(1,22))
    EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
    EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
CCC    CHARACTER*1 XTNCMD(80)
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC    InTeGer*4 RRWACT,RCLACT
CCC    COMMON/RCLACT/RRWACT,RCLACT
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
C (IMPLEMENT FOR VAX ONLY)
CCC    INTEGER KALKIT
CCC    COMMON/VARYIT/KALKIT
C ARGUMENTS COME IN IN ARGUMENTS IN LINE
C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    COMMON/D2R/NRDSP,NCDSP
C ***<<< KLSTO COMMON START >>>***
    InTeGer*4 DLFG
C    COMMON/DLFG/DLFG
    InTeGer*4 KDRW,KDCL
C    COMMON/DOT/KDRW,KDCL
    InTeGer*4 DTRENA
C    COMMON/DTRCMN/DTRENA
    REAL*8 EP,PV,FV
    DIMENSION EP(20)
    INTEGER*4 KIRR
C    COMMON/ERNPER/EP,PV,FV,KIRR
    InTeGer*4 LASTOP
C    COMMON/ERROR/LASTOP
    CHARACTER*1 FMTDAT(9,76)
C    COMMON/FMTBFR/FMTDAT
    CHARACTER*1 EDNAM(16)
C    COMMON/EDNAM/EDNAM
    InTeGer*4 MFID(2),MFMOD(2)
C    COMMON/FRM/MFID,MFMOD
    InTeGer*4 JMVFG,JMVOLD
C    COMMON/FUBAR/JMVFG,JMVOLD
    COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC    InTeGer*4 DTRENA
CCC    COMMON/DTRCMN/DTRENA
    CHARACTER *1 LINECL(82)
C    CHARACTER*70 LINEC
    EQUIVALENCE(LINEC(1:1),LINECL(1))
C    CHARACTER*80 SCRBUF
    CHARACTER*1 LBUF(128)
    CHARACTER*1 MBUF(128)
    CHARACTER*110 CLBUF,CMBUF
    CHARACTER*50 CCLBUF,CCMBUF
    CHARACTER*11 C11LBF
C    EQUIVALENCE(C11LBF(1:1),CLBUF(1:1))
    EQUIVALENCE(CLBUF(1:1),CCLBUF(1:1),LBUF(1),C11LBF(1:1)),
     1  (CMBUF(1:1),CCMBUF(1:1),MBUF(1))
C    EQUIVALENCE(CLBUF,LBUF(1)),(CMBUF,MBUF(1))
C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
    CHARACTER*9 FMTB
    EQUIVALENCE (FMTB(1:1),LBUF(120))
    CHARACTER*11 FMTBF
    CHARACTER*1 IFVLD
C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
ccc    DO 3332 N=1,80
ccc    NN=81-N
ccc    IF(ICHAR(LINE(NN)).GT.32)GOTO 3333
ccc    LINE(NN)=CHAR(0)
ccc3332    CONTINUE
ccc3333    CONTINUE
C SPACE FILL ENTIRE ARRAY
    DO 3334 N=1,82
3334    LINECL(N)=CHAR(32)
    RETCD=1
C HANDLE DTRCMD FUNCTIONS. LINE ARRAY PASSED IN HERE
C STARTS AFTER THE "DTR" SO WE CAN DECODE IT.
C EXECUTE DTR COMMAND
C  DTRCMD (COMMAND) GIVES DTR COMMAND FACILITY AT COMMAND
C LEVEL.
C ALLOW DTRIMM COMMAND TO USE DTR IMMEDIATE TERMINAL
C INTERFACE. THE REST CAN USE SAME COMMAND NAMES AS AFTER
C THE "DB" IN *U DBXXXX COMMANDS.
500    CONTINUE
C ENABLE/DISABLE FOR DTR FUNCTIONS
C SETTING DTRENA TO -1 IMPLIES DISABLE FUNCTIONS
    CALL SCMP(LINE,'ENA',3,ICODE)
    IF(ICODE.NE.1)GOTO 600
    DTRENA=1
    GOTO 9999
600    CONTINUE
    CALL SCMP(LINE,'DIS',3,ICODE)
    IF(ICODE.NE.1)GOTO 700
    DTRENA=-1
    GOTO 9999
700    CONTINUE
    CALL SCMP(LINE,'OPINS',5,ICODE)
C OPEN INPUT SEQUENTIAL
    IF(ICODE.NE.1)GOTO 3800
C DTROPINS RANGE FILENAME
    IBGN=6
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
    LINE(LSTCH+25)=CHAR(0)
    OPEN(UNIT=MFILUN,FILE=LINE(LSTCH),ACCESS='SEQUENTIAL',
     1  STATUS='OLD',IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFIOPN=1
    GOTO 9999
3800    CONTINUE
    CALL SCMP(LINE,'OPINRR',6,ICODE)
C OPEN IN RANDOM READ
    IF(ICODE.NE.1)GOTO 3900
    KK=2
    GOTO 3910
3900    CONTINUE
    CALL SCMP(LINE,'OPINRU',6,ICODE)
C OPEN IN RANDOM UPDATE
    IF(ICODE.NE.1)GOTO 3950
    KK=3
3910    CONTINUE
C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C *******
C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
    DO 5601 NN=1,50
5601    MBUF(NN)=' '
    DO 5602 NN=1,25
5602    MBUF(NN)=LINE(LSTCH+NN-1)
C    LINE(LSTCH+25)=0
C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
C    OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='BINARY',
C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='OLD',
C     1  RECL=128,BLOCKSIZE=128,ERR=9990)
    OPEN(UNIT=MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
     1  STATUS='OLD',FORM='UNFORMATTED',RECL=128,
     1  IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFIOPN=KK
    GOTO 9999
3950    CONTINUE
    CALL SCMP(LINE,'OPOUTS',6,ICODE)
C OPEN OUTPUT SEQUENTIAL
    IF(ICODE.NE.1)GOTO 4000
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C *******
C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
C    LINE(LSTCH+25)=0
    DO 5603 NN=1,50
5603    MBUF(NN)=' '
    DO 5604 NN=1,25
5604    MBUF(NN)=LINE(LSTCH+NN-1)
    OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='SEQUENTIAL',
     1  STATUS='NEW',IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFOOPN=1
    GOTO 9999
4000    CONTINUE
    CALL SCMP(LINE,'OPOUTR',6,ICODE)
C OPEN OUTPUT RANDOM
    IF(ICODE.NE.1)GOTO 4100
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
C *******
C NEED HERE TO MOVE NAME INTO CHAR ARRAY...
    DO 5605 NN=1,50
5605    MBUF(NN)=' '
    DO 5606 NN=1,25
5606    MBUF(NN)=LINE(LSTCH+NN-1)
C    LINE(LSTCH+25)=0
C    OPEN(UNIT=MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
C     1  INITIALSIZE=NBK,FORM='UNFORMATTED',STATUS='NEW',
C     1  RECL=32,BLOCKSIZE=128,ERR=9990)
    OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='DIRECT',
     1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
     2  IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFOOPN=2
    GOTO 9999
4100    CONTINUE
    CALL SCMP(LINE,'CLSOUT',6,ICODE)
C CLOSE OUTPUT
    IF(ICODE.NE.1)GOTO 4200
    CLOSE(UNIT=MFOLUN)
    MFOOPN=0
    GOTO 9999
4200    CONTINUE
    CALL SCMP(LINE,'CLSINP',6,ICODE)
C CLOSE INPUT
    IF(ICODE.NE.1)GOTO 4300
    CLOSE(UNIT=MFILUN)
    MFIOPN=0
    GOTO 9999
4300    CONTINUE
    CALL SCMP(LINE,'ENAOUT',6,ICODE)
C ENABLE OUTPUT
    IF(ICODE.NE.1)GOTO 4400
    MFOFLG=1
    GOTO 9999
4400    CONTINUE
    CALL SCMP(LINE,'ENAINP',6,ICODE)
C ENABLE INPUT
    IF(ICODE.NE.1)GOTO 4500
    MFIFLG=1
    GOTO 9999
4500    CONTINUE
    CALL SCMP(LINE,'DISINP',6,ICODE)
C DISABLE INPUT
    IF(ICODE.NE.1)GOTO 4510
    MFIFLG=0
    GOTO 9999
4510    CONTINUE
    CALL SCMP(LINE,'DISOUT',6,ICODE)
C DISABLE OUTPUT
    IF(ICODE.NE.1)GOTO 4520
    MFOFLG=0
    GOTO 9999
4520    CONTINUE
    CALL SCMP(LINE,'EDTINP',6,ICODE)
C ENABLE INPUT FORCE
C COMMAND
C DTREDTINP RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
    IF(ICODE.NE.1)GOTO 4600
C FORCE ENABLE OF READIN DURING THIS
    MFIFLG=1
    MFOFLG=1
C ENABLE OUTPUT TOO.
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
    DO 4550 N1=IXRL,IXRH
    DO 4550 N2=IXCL,IXCH
    CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
    CALL FVLDST(N1,N2,Char(255))
    CALL WRKFIL(IRX,LBUF,0)
    CALL WRKFIL(IRX,LBUF,1)
4550    CONTINUE
    MFIFLG=0
    MFOFLG=0
    GOTO 9999
4600    CONTINUE
    CALL SCMP(LINE,'FMTOUT',6,ICODE)
C FORMAT/WRITE OUTPUT
C COMMAND
C DTRFMTOUT RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
    IF(ICODE.NE.1)GOTO 4630
    IVLFG=1
    GOTO 4740
4630    CONTINUE
    CALL SCMP(LINE,'VALOUT',6,ICODE)
    IF(ICODE.NE.1)GOTO 4700
C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
    IVFLG=2
C    GOTO 4740
4740    CONTINUE
C FORCE ENABLE OF READIN DURING THIS
    MFIFLG=1
    MFOFLG=1
C ENABLE OUTPUT TOO.
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
    DO 4650 N1=IXRL,IXRH
    DO 4650 N2=IXCL,IXCH
C FIND INDEX FOR WRKFIL
    CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
    CALL XVBLGT(N1,N2,TMP)
C TMP IS REAL*8 SCRATCH
    CALL FVLDST(N1,N2,Char(255))
    CALL WRKFIL(IRX,LBUF,0)
C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
C NOW GRAB THE VALUE AND SAVE IT...
C FIRST MOVE THE FORMAT DOWN
C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
    DO 4651 N=1,9
    LBUF(N+1)=LBUF(N+119)
4651    CONTINUE
    LBUF(1)='('
    LBUF(11)=')'
c    LBUF(12)=CHAR(0)
C CHANGE TO USE CHAR VERSION OF LBUF
C *******
C FORMAT NOW LIVES IN LOW PART OF LBUF
C D25.17 FORMAT WOULD DO FOR WRITE
c    IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF(1:11),ERR=4652)TMP
    IF(IVLFG.EQ.1)WRITE(LINEC(1:70),C11LBF,ERR=4652)TMP
    IF(IVLFG.EQ.2)WRITE(LINEC(1:70),4658,ERR=4652)TMP
4658    FORMAT(D25.17)
C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
C USE DISPLAY FORMAT.
4652    CONTINUE
    KK=1
    DO 4653 N=1,110
4653    LBUF(N)=CHAR(0)
    DO 4654 N=1,60
C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
    KKK=JCHAR(LINECL(N))
    IF(KKK.LE.32)GOTO 4654
    LBUF(KK)=LINECL(N)
    KK=KK+1
4654    CONTINUE
    CALL WRKFIL(IRX,LBUF,1)
4650    CONTINUE
    MFIFLG=0
    MFOFLG=0
    GOTO 9999
4700    CONTINUE
    CALL SCMP(LINE,'CMPFRM',6,ICODE)
    IF(ICODE.NE.1)GOTO 4800
C DBCMPFRM V1:V2
C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
    IBGN=7
    IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
    CALL REFLEC(IXCL,IXRL,IRXL)
    CALL REFLEC(IXCH,IXRH,IRXH)
    IF(LINE(LSTCH).NE.',')GOTO 4780
    IBGN=LSTCH+1
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
    IF(IVLD.EQ.3)GOTO 4780
C GET THE LENGTHS NOW
    CALL XVBLGT(IYRL,IYCL,TMP)
    IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
    LBUFL=TMP
    CALL XVBLGT(IYRH,IYCH,TMP)
    IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
    MBUFL=TMP
C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
C COMPARISONS BASED ON THAT.
    GOTO 4770
4780    CONTINUE
C GET INDEX OF EACH ELEMENT...
    CALL WRKFIL(IRXL,LBUF,0)
    CALL WRKFIL(IRXH,MBUF,0)
C LOAD THE 2 FORMULAS.
C NOW FIND THE ENDS...
    DO 4750 N=1,110
    NN=111-N
    IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
4750    CONTINUE
4751    LBUFL=NN
    DO 4760 N=1,110
    NN=111-N
    IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
4760    CONTINUE
4761    MBUFL=NN
4770    CONTINUE
c find index pos'n by hand...
    KK=LBUFL-MBUFL+1
    DO 4776 NN=1,KK
    IF(LBUF(NN).NE.MBUF(1))GOTO 4776
    NNN=MBUFL-1
    DO 4777 N=1,NNN
    IVVV=NN+N
    IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
4777    CONTINUE
C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
C SINCE NN IS WHAT WE NEED, GO USE IT.
    GOTO 4779
4778    CONTINUE
4776    CONTINUE
C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
C
    NN=0
4779    CONTINUE
C NN IS LOCATION OF SUBSTRING NOW
C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
C NN IS LOCATION OF SUBSTRING NOW
    XAC=NN
C RETURN RESULT IN % ACCUMULATOR.
    WAC=0.
    IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
    IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
    GOTO 9999
4800    CONTINUE
    CALL SCMP(LINE,'LENFRM',6,ICODE)
    IF(ICODE.NE.1)GOTO 4900
C DBLENFRM V1:V2
C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
    IBGN=7
    IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
    CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
    CALL WRKFIL(IRXL,LBUF,0)
C LOAD THE FORMULA.
C NOW FIND THE END...
    DO 4850 N=1,110
    NN=111-N
    IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
4850    CONTINUE
4851    LBUFL=NN
    TMP=LBUFL
    XAC=TMP
C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
    NN=0
C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
    CALL FVLDGT(IXRH,IXCH,NN)
    IF(NN.EQ.0)GOTO 9999
    CALL XVBLST(IXRH,IXCH,TMP)
    GOTO 9999
4900    CONTINUE
    CALL SCMP(LINE,'TRMFRM',6,ICODE)
    IF(ICODE.NE.1)GOTO 5000
C TRIM FORMULA
C DTRTRMFRM INCELL:OUTCELL,START:END
C RETURNS TRIMMED FORMULA TO CELL.
    IBGN=7
    IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
    CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
    CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
    CALL REFLEC(IXCH,IXRH,IRXH)
    CALL WRKFIL(IRXL,LBUF,0)
    LO=LSTCHR+1
    LHI=LSTCHR+21
    LSTCHR=LHI
    CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
    IF(IVLD.EQ.0)GOTO 9990
    CALL XVBLGT(JD1,JD2,TMP)
    LOCHR=1
    IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
C LOCHR = START CHAR
    LO=LSTCHR+1
    LHI=LSTCHR+21
    LSTCHR=LHI
    CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
    IF(IVLD.EQ.0)GOTO 9990
    CALL XVBLGT(JD1,JD2,TMP)
    LHICHR=110
    IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
C LHICHR IS END CHARACTER
C NOW ALL ARGS ARE COLLECTED.
C (IGNORE WHAT WAS DELIMITER...)
C COPY DESIRED STUFF TO MBUF
    N=1
    DO 4910 NN=1,110
    MBUF(NN)=CHAR(0)
    IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
    MBUF(N)=LBUF(NN)
    N=N+1
C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
4910    CONTINUE
    DO 4911 NN=111,128
4911    MBUF(NN)=LBUF(NN)
    CALL WRKFIL(IRXH,MBUF,1)
C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
    GOTO 9999
5000    CONTINUE
    GOTO 9999
9990    RETCD=3
C ERROR RETURN
9999    RETURN
    END
c -h- dtrfct.for    Fri Aug 22 13:05:02 1986
C DATATRIEVE INTERFACE FUNCTIONS
C NON-DATATRIEVE PARTS, FOR MSDOS VERSION
C COPYRIGHT 1986 GCE
    SUBROUTINE DTRFCT(LINE,RETCD)
    InTeGer*4 RETCD
    CHARACTER*1 LINE(80)
    CHARACTER *1 LINECL(82)
    CHARACTER*62 LINEC
    EQUIVALENCE(LINEC(1:1),LINECL(1))
C
C
C DEFINE FILE AREAS FOR MAPPING FILES...
C
C DEFINE ALSO DATA STRUCTURES TO HOLD CELL RANGES (IN ROW AND COL)
C TO BE TREATED WITH THESE FILES, FLAG FOR HOW-OPEN, AND LUN USED.
C
C MFIOPN =    0    IF NOT OPEN
C        1    IF OPEN FOR READ ONLY, SEQUENTIAL
C        2    IF OPEN READ ONLY, RANDOM
C        3    IF OPEN READ/WRITE, RANDOM.
C
C MFOOPN =    0    IF NOT OPEN
C        1    IF OPEN WRITE SEQUENTIAL
C        2    IF OPEN WRITE RANDOM
C
C OTHER OPTIONS DON'T MAKE SENSE.
C MFIRL,MFIRH = RRW DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFICL,MFICH = RCL DIMENSION LOW, HIGH BOUND, INPUT FILE
C MFORL,RH,MFOCL,CH = OUT FILE BOUNDS
C MFILUN,MFOLUN ARE LOGICAL UNITS.
    InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
    InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
    InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
    COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
     1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
C
C
C    INCLUDE 'VKLUGPRM.FTN'
C COPYRIGHT (C) 1983 GLENN EVERHART
C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
    CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
    InTeGer*4 TYPE(1,1),VLEN(9)
    REAL*8 XAC,XVBLS(1,1)
    REAL*8 TAC,UAC,VAC,WAC,YAC
    REAL*8 TMP
    INTEGER*4 JVBLS(2,1,1)
    EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
    EQUIVALENCE(XAC,AVBLS(1,27))
    EQUIVALENCE(TAC,AVBLS(1,20))
    EQUIVALENCE(UAC,AVBLS(1,21))
    EQUIVALENCE(VAC,AVBLS(1,22))
    EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
    EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
CCC    CHARACTER*1 XTNCMD(80)
CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC    InTeGer*4 RRWACT,RCLACT
CCC    COMMON/RCLACT/RRWACT,RCLACT
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
C (IMPLEMENT FOR VAX ONLY)
    INTEGER IVVV
CCC    COMMON/VARYIT/KALKIT
C ARGUMENTS COME IN IN ARGUMENTS IN LINE
C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    COMMON/D2R/NRDSP,NCDSP
C ***<<< KLSTO COMMON START >>>***
    InTeGer*4 DLFG
C    COMMON/DLFG/DLFG
    InTeGer*4 KDRW,KDCL
C    COMMON/DOT/KDRW,KDCL
    InTeGer*4 DTRENA
C    COMMON/DTRCMN/DTRENA
    REAL*8 EP,PV,FV
    DIMENSION EP(20)
    INTEGER*4 KIRR
C    COMMON/ERNPER/EP,PV,FV,KIRR
    InTeGer*4 LASTOP
C    COMMON/ERROR/LASTOP
    CHARACTER*1 FMTDAT(9,76)
C    COMMON/FMTBFR/FMTDAT
    CHARACTER*1 EDNAM(16)
C    COMMON/EDNAM/EDNAM
    InTeGer*4 MFID(2),MFMOD(2)
C    COMMON/FRM/MFID,MFMOD
    InTeGer*4 JMVFG,JMVOLD
C    COMMON/FUBAR/JMVFG,JMVOLD
    COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC    InTeGer*4 DTRENA
CCC    COMMON/DTRCMN/DTRENA
C    CHARACTER*70 LINEC
    CHARACTER*1 LBUF(128)
    CHARACTER*1 MBUF(128)
    CHARACTER*110 CLBUF,CMBUF
C    EQUIVALENCE(CLBUF(1:1),LBUF(1)),(CMBUF(1:1),MBUF(1))
    CHARACTER*50 CCMBUF
    CHARACTER*11 C11LBF
    EQUIVALENCE(CCMBUF(1:1),CMBUF(1:1),MBUF(1)),
     1  (C11LBF(1:1),CLBUF(1:1),LBUF(1))
C USE CLBUF, CMBUF FOR CHARACTER COMPARISONS...
c    CHARACTER*1 IFVLD
    RETCD=1
    IF(DTRENA.LT.0)GOTO 9999
C NULL OUT ANY TRAILING BLANKS ON COMMAND LINE
ccc    DO 3332 N=1,76
ccc    NN=77-N
ccc    IF(JCHAR(LINE(NN)).GT.32)GOTO 3333
ccc    LINE(NN)=CHAR(0)
ccc3332    CONTINUE
ccc3333    CONTINUE
C SPACE FILL ENTIRE ARRAY
    DO 3334 N=1,82
3334    LINECL(N)=CHAR(32)
    RETCD=1
C HANDLE *U DBXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
C STARTS AFTER THE "DB" SO WE CAN DECODE IT.
C *U DBCMD (COMMAND) PASSES COMMAND TO DTR FOR ACTION
C  HOWEVER THIS DOES NOT RETURN A VALUE. USE FOR
C  SETUP PURPOSES ONLY.
C
C NO NEED TO INCLUDE ABILITY TO STORE COMMANDS IN CELLS
C FOR EDITING SINCE {CELL CONSTRUCT PROVIDES THIS ALREADY.
C (AND AT COMMAND LEVEL THE __{CELL CONSTRUCT DOES ALSO.)
500    CONTINUE
    CALL SCMP(LINE,'OPINS',5,ICODE)
C OPEN INPUT SEQUENTIAL
    IF(ICODE.NE.1)GOTO 3800
C DTROPINS RANGE FILENAME
    IBGN=6
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C    LINE(LSTCH+25)=CHAR(0)
    DO 5601 NN=1,50
5601    MBUF(NN)=' '
    DO 5602 NN=1,25
5602    MBUF(NN)=LINE(LSTCH+NN-1)
    OPEN(UNIT=MFILUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
     1  STATUS='OLD',IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFIOPN=1
    GOTO 9999
3800    CONTINUE
    CALL SCMP(LINE,'OPINRR',6,ICODE)
C OPEN IN RANDOM READ
    IF(ICODE.NE.1)GOTO 3900
    KK=2
    GOTO 3910
3900    CONTINUE
    CALL SCMP(LINE,'OPINRU',6,ICODE)
C OPEN IN RANDOM UPDATE
    IF(ICODE.NE.1)GOTO 3950
    KK=3
3910    CONTINUE
C HANDLE INPUT DIRECT ACCESS OPEN COMMONLY FOR READ ONLY AND R/W

    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFIRL,MFICL,MFIRH,MFICH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C    LINE(LSTCH+25)=0
    DO 5603 NN=1,50
5603    MBUF(NN)=' '
    DO 5604 NN=1,25
5604    MBUF(NN)=LINE(LSTCH+NN-1)
C    NBK=(MFIRH-MFIRL+1)*(MFICH-MFICL+1)
    OPEN(MFILUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
     1  FORM='UNFORMATTED',RECL=128,STATUS='OLD',IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFIOPN=KK
    GOTO 9999
3950    CONTINUE
    CALL SCMP(LINE,'OPOUTS',6,ICODE)
C OPEN OUTPUT SEQUENTIAL
    IF(ICODE.NE.1)GOTO 4000
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
    DO 5605 NN=1,50
5605    MBUF(NN)=' '
    DO 5606 NN=1,25
5606    MBUF(NN)=LINE(LSTCH+NN-1)
    OPEN(UNIT=MFOLUN,FILE=CCMBUF,ACCESS='SEQUENTIAL',
     1  STATUS='NEW',IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFOOPN=1
    GOTO 9999
4000    CONTINUE
    CALL SCMP(LINE,'OPOUTR',6,ICODE)
C OPEN OUTPUT RANDOM
    IF(ICODE.NE.1)GOTO 4100
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,MFORL,MFOCL,MFORH,MFOCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C    NBK=(MFORH-MFORL+1)*(MFOCH-MFOCL+1)
C    LINE(LSTCH+25)=0
    DO 5607 NN=1,50
5607    MBUF(NN)=' '
    DO 5608 NN=1,25
5608    MBUF(NN)=LINE(LSTCH+NN-1)
    OPEN(MFOLUN,FILE=CCMBUF(1:49),ACCESS='DIRECT',
     1  STATUS='NEW',FORM='UNFORMATTED',RECL=128,
     2  IOSTAT=IVVV)
    IF(IVVV.NE.0)GOTO 9990
    MFOOPN=2
    GOTO 9999
4100    CONTINUE
    CALL SCMP(LINE,'CLSOUT',6,ICODE)
C CLOSE OUTPUT
    IF(ICODE.NE.1)GOTO 4200
    CLOSE(UNIT=MFOLUN)
    MFOOPN=0
    GOTO 9999
4200    CONTINUE
    CALL SCMP(LINE,'CLSINP',6,ICODE)
C CLOSE INPUT
    IF(ICODE.NE.1)GOTO 4300
    CLOSE(UNIT=MFILUN)
    MFIOPN=0
    GOTO 9999
4300    CONTINUE
    CALL SCMP(LINE,'ENAOUT',6,ICODE)
C ENABLE OUTPUT
    IF(ICODE.NE.1)GOTO 4400
    MFOFLG=1
    GOTO 9999
4400    CONTINUE
    CALL SCMP(LINE,'ENAINP',6,ICODE)
C ENABLE INPUT
    IF(ICODE.NE.1)GOTO 4500
    MFIFLG=1
    GOTO 9999
4500    CONTINUE
    CALL SCMP(LINE,'DISINP',6,ICODE)
C DISABLE INPUT
    IF(ICODE.NE.1)GOTO 4510
    MFIFLG=0
    GOTO 9999
4510    CONTINUE
    CALL SCMP(LINE,'DISOUT',6,ICODE)
C DISABLE OUTPUT
    IF(ICODE.NE.1)GOTO 4520
    MFOFLG=0
    GOTO 9999
4520    CONTINUE
    CALL SCMP(LINE,'EDTINP',6,ICODE)
C ENABLE INPUT FORCE
C COMMAND
C DTREDTINP RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
    IF(ICODE.NE.1)GOTO 4600
C FORCE ENABLE OF READIN DURING THIS
    MFIFLG=1
    MFOFLG=1
C ENABLE OUTPUT TOO.
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
    DO 4550 N1=IXRL,IXRH
    DO 4550 N2=IXCL,IXCH
    CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
    CALL FVLDST(N1,N2,Char(255))
    CALL WRKFIL(IRX,LBUF,0)
    CALL WRKFIL(IRX,LBUF,1)
4550    CONTINUE
    MFIFLG=0
    MFOFLG=0
    GOTO 9999
4600    CONTINUE
    CALL SCMP(LINE,'FMTOUT',6,ICODE)
C FORMAT/WRITE OUTPUT
C COMMAND
C DTRFMTOUT RANGE
C GETS RANGE, THEN FOR EACH CELL IN RANGE READS IN (BY WRKFIL READ CALL)
C A CELL, SETS ITS FVLD CODE TO -1 (TO FLAG A TEXT CELL), AND WRITES
C IT OUT AGAIN.
    IF(ICODE.NE.1)GOTO 4630
    IVLFG=1
    GOTO 4740
4630    CONTINUE
    CALL SCMP(LINE,'VALOUT',6,ICODE)
    IF(ICODE.NE.1)GOTO 4700
C VALOUT CMD OUTPUTS VALUES WITH LONG D FORMAT
    IVFLG=2
C    GOTO 4740
4740    CONTINUE
C FORCE ENABLE OF READIN DURING THIS
    MFIFLG=1
    MFOFLG=1
C ENABLE OUTPUT TOO.
    IBGN=7
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
    DO 4650 N1=IXRL,IXRH
    DO 4650 N2=IXCL,IXCH
C FIND INDEX FOR WRKFIL
    CALL REFLEC(N2,N1,IRX)
C SET THE ELEMENT AS VALID AND READ/WRITE IT ONCE.
    CALL XVBLGT(N1,N2,TMP)
C TMP IS REAL*8 SCRATCH
    CALL FVLDST(N1,N2,Char(255))
    CALL WRKFIL(IRX,LBUF,0)
C HAVING LOADED THE RECORD NOW (GETTING FORMAT, ETC.)
C NOW GRAB THE VALUE AND SAVE IT...
C FIRST MOVE THE FORMAT DOWN
C NOTE LINEC AND LINECL ARE EQUIVALENT BUT LINECL IS CHAR*1
    DO 4651 N=1,9
    LBUF(N+1)=LBUF(N+119)
4651    CONTINUE
    LBUF(1)='('
    LBUF(11)=')'
c    LBUF(12)=0
C FORMAT NOW LIVES IN LOW PART OF LBUF
C D25.17 FORMAT WOULD DO FOR WRITE
C NEED CHAR VBL FOR FORMAT EQUIV'D TO LOW 12 CHARS OF LBUF
c    IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF(1:11),ERR=4652)TMP
    IF(IVLFG.EQ.1)WRITE(LINEC(1:62),C11LBF,ERR=4652)TMP
    IF(IVLFG.EQ.2)WRITE(LINEC(1:62),4658,ERR=4652)TMP
4658    FORMAT(D25.17)
C USE BUILTIN FORMAT TO WRITE THE VALUE IF COMMANDED TO DO SO OR
C USE DISPLAY FORMAT.
4652    CONTINUE
    KK=1
    DO 4653 N=1,110
4653    LBUF(N)=CHAR(0)
    DO 4654 N=1,60
C COPY LINECL CHARS TO LBUF, SKIPPING SPACES
    KKK=JCHAR(LINECL(N))
    IF(KKK.LE.32)GOTO 4654
    LBUF(KK)=LINECL(N)
    KK=KK+1
4654    CONTINUE
    CALL WRKFIL(IRX,LBUF,1)
4650    CONTINUE
    MFIFLG=0
    MFOFLG=0
    GOTO 9999
4700    CONTINUE
    CALL SCMP(LINE,'CMPFRM',6,ICODE)
    IF(ICODE.NE.1)GOTO 4800
C DBCMPFRM V1:V2
C RETURNS IN % THE INDEX OF FORMULA 1 IN FORMULA 2
    IBGN=7
    IVLD=0
    LSTCH=78
C USE GMTX TO GET CELL ADDRESSES.
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C IF WE HAVE A COMMA AND ANOTHER MTX USE IT AS LENGTHS
    CALL REFLEC(IXCL,IXRL,IRXL)
    CALL REFLEC(IXCH,IXRH,IRXH)
    IF(LINE(LSTCH).NE.',')GOTO 4780
    IBGN=LSTCH+1
    IVLD=0
    CALL GMTX(LINE,IBGN,LSTCH,IYRL,IYCL,IYRH,IYCH,IVLD)
    IF(IVLD.EQ.3)GOTO 4780
C GET THE LENGTHS NOW
    CALL XVBLGT(IYRL,IYCL,TMP)
    IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
    LBUFL=TMP
    CALL XVBLGT(IYRH,IYCH,TMP)
    IF(TMP.LT.1.OR.TMP.GT.109.)GOTO 4780
    MBUFL=TMP
C IF LENGTHS ARE OK FOR BOTH, THEN USE THEM AND DO THE
C COMPARISONS BASED ON THAT.
    GOTO 4770
4780    CONTINUE
C GET INDEX OF EACH ELEMENT...
    CALL WRKFIL(IRXL,LBUF,0)
    CALL WRKFIL(IRXH,MBUF,0)
C LOAD THE 2 FORMULAS.
C NOW FIND THE ENDS...
    DO 4750 N=1,110
    NN=111-N
    IF(JCHAR(LBUF(NN)).GT.32)GOTO 4751
4750    CONTINUE
4751    LBUFL=NN
    DO 4760 N=1,110
    NN=111-N
    IF(JCHAR(MBUF(NN)).GT.32)GOTO 4761
4760    CONTINUE
4761    MBUFL=NN
4770    CONTINUE
c find index pos'n by hand...
    KK=LBUFL-MBUFL+1
    DO 4776 NN=1,KK
    IF(LBUF(NN).NE.MBUF(1))GOTO 4776
    NNN=MBUFL-1
    DO 4777 N=1,NNN
    IVVV=NN+N
    IF (LBUF(IVVV).NE.MBUF(N+1))GOTO 4778
4777    CONTINUE
C IF WE GALL THRU HERE ANYTIME WE HAVE A MATCH.
C SINCE NN IS WHAT WE NEED, GO USE IT.
    GOTO 4779
4778    CONTINUE
4776    CONTINUE
C IF NO MATCH, SET NN=0 TO SO FLAG IT AND BUG OUT.
C
    NN=0
4779    CONTINUE
C NN IS LOCATION OF SUBSTRING NOW
C    NN=INDEX(CLBUF(1:LBUFL),CMBUF(1:MBUFL))
    XAC=NN
C RETURN RESULT IN % ACCUMULATOR.
    WAC=0.
    IF(LLT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=-1.
    IF(LGT(CLBUF(1:LBUFL),CMBUF(1:MBUFL)))WAC=1.
C RETURN LESS/GREATER/EQUAL IN W ACCUMULATOR FOR POSSIBLE
C USE IN SORTS, ETC. THUS WE CAN TEST 2 STRINGS BY TESTING W ACCUM.
C (LEAVES X, Y ALONE SINCE W IS MORE FREQUENTLY FREE.)
    GOTO 9999
4800    CONTINUE
    CALL SCMP(LINE,'LENFRM',6,ICODE)
    IF(ICODE.NE.1)GOTO 4900
C DBLENFRM V1:V2
C RETURNS LENGTH OF FORMULA IN V1 IN % AND V2
    IBGN=7
    IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
    CALL GMTX(LINE,IBGN,LSTCH,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
    CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
    CALL WRKFIL(IRXL,LBUF,0)
C LOAD THE FORMULA.
C NOW FIND THE END...
    DO 4850 N=1,110
    NN=111-N
    IF(JCHAR(LBUF(NN)).GT.32)GOTO 4851
4850    CONTINUE
4851    LBUFL=NN
    TMP=LBUFL
    XAC=TMP
C SAVE LENGTH IN OUTPUT CELL. DON'T TOUCH VALIDITY FOR THE CELL.
    NN=0
C SEE IF CELL IS VALID AND IF NOT VALID DON'T SAVE ANYTHING IN IT.
    CALL FVLDGT(IXRH,IXCH,NN)
    IF(NN.EQ.0)GOTO 9999
    CALL XVBLST(IXRH,IXCH,TMP)
    GOTO 9999
4900    CONTINUE
    CALL SCMP(LINE,'TRMFRM',6,ICODE)
    IF(ICODE.NE.1)GOTO 5000
C TRIM FORMULA
C DTRTRMFRM INCELL:OUTCELL,START:END
C RETURNS TRIMMED FORMULA TO CELL.
    IBGN=7
    IVLD=0
C USE GMTX TO GET CELL ADDRESSES.
    CALL GMTX(LINE,IBGN,LSTCHR,IXRL,IXCL,IXRH,IXCH,IVLD)
    IF(IVLD.EQ.3)GOTO 9990
C GOT CELL HERE...BOTH FOR INPUT AND OUTPUT
    CALL REFLEC(IXCL,IXRL,IRXL)
C GET INDEX OF EACH ELEMENT...
    CALL REFLEC(IXCH,IXRH,IRXH)
    CALL WRKFIL(IRXL,LBUF,0)
    LO=LSTCHR+1
    LHI=LSTCHR+21
    LSTCHR=LHI
    CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
    IF(IVLD.EQ.0)GOTO 9990
    CALL XVBLGT(JD1,JD2,TMP)
    LOCHR=1
    IF(TMP.GT.0..AND.TMP.LT.110.)LOCHR=TMP
C LOCHR = START CHAR
    LO=LSTCHR+1
    LHI=LSTCHR+21
    LSTCHR=LHI
    CALL VARSCN(LINE,LO,LHI,LSTCHR,JD1,JD2,IVLD)
    IF(IVLD.EQ.0)GOTO 9990
    CALL XVBLGT(JD1,JD2,TMP)
    LHICHR=110
    IF(TMP.GT.0..AND.TMP.LT.110.)LHICHR=TMP
C LHICHR IS END CHARACTER
C NOW ALL ARGS ARE COLLECTED.
C (IGNORE WHAT WAS DELIMITER...)
C COPY DESIRED STUFF TO MBUF
    N=1
    DO 4910 NN=1,110
    MBUF(NN)=CHAR(0)
    IF(NN.LT.LOCHR.OR.NN.GT.LHICHR)GOTO 4910
    MBUF(N)=LBUF(NN)
    N=N+1
C COPY DESIRED PART OF FORMULA TO MBUF WITH THE REST ZEROED.
4910    CONTINUE
    DO 4911 NN=111,128
4911    MBUF(NN)=LBUF(NN)
    CALL WRKFIL(IRXH,MBUF,1)
C WRITE BUFFER BACK TO CELL AS TRIMMED NOW, GOING TO OUT CELL
C RATHER THAN INPUT CELL (TO ALLOW REPEATED CALCS TO BE STABLE.)
    GOTO 9999
5000    CONTINUE
    GOTO 9999
9990    RETCD=3
C ERROR RETURN
9999    RETURN
    END
c -h- fft.ftn    Fri Aug 22 13:08:56 1986
C
C-----------------------------------------------------------------------
C SUBROUTINE: FOUREA
C PERFORMS COOLEY-TUKEY FAST FOURIER TRANSFORM
C-----------------------------------------------------------------------
C
      SUBROUTINE FOUREA(ID1,ID2,IC,IR,IVN,ISI)
C ID1,ID2 = COORDS OF FIRST CELL. IC AND IR ARE 0, OR 1
C ONLY ONE OF IC, IR MAY BE NONZERO. (FLAGS HORIZ/VERTICAL
C DATA AREA)
C
C THE COOLEY-TUKEY FAST FOURIER TRANSFORM IN ANSI FORTRAN
C
C DATA IS A ONE-DIMENSIONAL COMPLEX ARRAY WHOSE LENGTH, N, IS A
C POWER OF TWO.  ISI IS +1 FOR AN INVERSE TRANSFORM AND -1 FOR A
C FORWARD TRANSFORM.  TRANSFORM VALUES ARE RETURNED IN THE INPUT
C ARRAY, REPLACING THE INPUT.
C TRANSFORM(J)=SUM(DATA(I)*W**((I-1)*(J-1))), WHERE I AND J RUN
C FROM 1 TO N AND W = EXP (ISI*2*PI*SQRT(-1)/N).  PROGRAM ALSO
C COMPUTES INVERSE TRANSFORM, FOR WHICH THE DEFINING EXPRESSION
C IS INVTR(J)=(1/N)*SUM(DATA(I)*W**((I-1)*(J-1))).
C RUNNING TIME IS PROPORTIONAL TO N*LOG2(N), RATHER THAN TO THE
C CLASSICAL N**2.
C AFTER PROGRAM BY BRENNER, JUNE 1967. THIS IS A VERY SHORT VERSION
C OF THE FFT AND IS INTENDED MAINLY FOR DEMONSTRATION. PROGRAMS
C ARE AVAILABLE IN THIS COLLECTION WHICH RUN FASTER AND ARE NOT
C RESTRICTED TO POWERS OF 2 OR TO ONE-DIMENSIONAL ARRAYS.
C SEE -- IEEE TRANS AUDIO (JUNE 1967), SPECIAL ISSUE ON FFT.
C
C ASSUMES THAT FIRST N/2 ELEMENTS ARE REAL, SECOND COMPLEX...
C STORES DATA THAT WAY ALSO...
C
C      COMPLEX DATA(1)
C      COMPLEX TEMP, W
C MAKE THIS A REAL FFT, NOT COMPLEX...
    REAL*8 DATA(1),TEMP,W,TEMP2,TEMPI,WI
    InTeGer*4 ID1,ID2,IC,IR,IRX,IRXX,IVN,N
C SET UP STMT FUNCTIONS...
    ID1F(K)=ID1+IC*(K-1)
    ID2F(K)=ID2+IR*(K-1)
    N=IVN
C
C CHECK FOR POWER OF TWO UP TO 14
C
C INITIALLY SAY ALL OK
      NN = 1
      DO 10 I=1,14
        M = I
        NN = NN*2
        IF (NN.EQ.N) GO TO 20
    IF(NN.GT.N)GOTO 11
  10  CONTINUE
11    CONTINUE
    N=NN/2
C USE NEXT SMALLER POWER OF 2 ARRAY...
C    RETURN
C HERE BEGINNETH ACTUAL WORK.
C SET UP DATA COORDS ON THE FLY. NORMALLY I,J RUN IN RANGE 1 TO N
C SO WHERE K=(I OR J) (I.E., ONE OF THE TWO) WE USE A RELATION
C ID1V=ID1+IC*(K-1) AND ID2V=ID2+IR*(K-1). WE USE STMT FUNCTIONS
C ID1F AND ID2F FOR THIS.
  20  CONTINUE
    NOV2=N/2
C
C      PI = 4.*ATAN(1.)
    PI=3.14159265358979323846264
      FN = NOV2
C
C THIS SECTION PUTS DATA IN BIT-REVERSED ORDER
C
      J = 1
      DO 80 I=1,NOV2
C
C AT THIS POINT, I AND J ARE A BIT REVERSED PAIR (EXCEPT FOR THE
C DISPLACEMENT OF +1)
C
    IF(I.GE.J)GOTO 40
C
C EXCHANGE DATA(I) WITH DATA(J) IF I.LT.J.
C
 30    CONTINUE
C EXCHANGE DATA(J), DATA(I)
    CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
    CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
    CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
    CALL XVBLST(ID1F(I),ID2F(I),TEMP)
C FLIP BOTH REAL AND COMPLEX PARTS OF DATA
    CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMP)
    CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
    CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
    CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP)
C  30    TEMP = DATA(J)
C        DATA(J) = DATA(I)
C        DATA(I) = TEMP
C
C IMPLEMENT J=J+1, BIT-REVERSED COUNTER
C
  40    M = NOV2/2
  50    IF (J.LE.M) GOTO 70
  60    J = J - M
        M = (M+1)/2
        GO TO 50
  70    J = J + M
  80  CONTINUE
C
C NOW COMPUTE THE BUTTERFLIES
C
      MMAX = 1
  90  IF (MMAX.GE.NOV2)GOTO 130
 100  ISTEP = 2*MMAX
      DO 120 M=1,MMAX
        THETA = PI*FLOAT(ISI*(M-1))/FLOAT(MMAX)
     W = COS(THETA)
        WI = SIN(THETA)
C        W = CMPLX(COS(THETA),SIN(THETA))
        DO 110 I=M,NOV2,ISTEP
          J = I + MMAX
C GET REAL AND IMAG HALVES OF NUMBER...
      CALL XVBLGT(ID1F(J),ID2F(J),TEMP)
      CALL XVBLGT(ID1F(J+NOV2),ID2F(J+NOV2),TEMPI)
C DO COMPLEX MULTIPLICATION BY HAND TO AVOID LARGE RUNTIME SYSTEM
C ROUTINE INCLUSION.
      TEMP2=W*TEMP-WI*TEMPI
      TEMPI=WI*TEMP+W*TEMPI
    TEMP=TEMP2
C          TEMP = W*DATA(J)
C          DATA(J) = DATA(I) - TEMP
C          DATA(I) = DATA(I) + TEMP
       CALL XVBLGT(ID1F(I),ID2F(I),DATA(1))
       TEMP2=DATA(1)+TEMP
       DATA(1)=DATA(1) - TEMP
       CALL XVBLST(ID1F(J),ID2F(J),DATA(1))
       CALL XVBLST(ID1F(I),ID2F(I),TEMP2)
C COMPLEX PART
       CALL XVBLGT(ID1F(I+NOV2),ID2F(I+NOV2),DATA(1))
       TEMP2=DATA(1)+TEMPI
       DATA(1)=DATA(1) - TEMPI
       CALL XVBLST(ID1F(J+NOV2),ID2F(J+NOV2),DATA(1))
       CALL XVBLST(ID1F(I+NOV2),ID2F(I+NOV2),TEMP2)
 110    CONTINUE
 120  CONTINUE
      MMAX = ISTEP
      GO TO 90
  130  IF (ISI.LT.0) GOTO 160
C
C FOR INV TRANS -- ISI=1 -- MULTIPLY OUTPUT BY 1/N
C
 140  DO 150 I=1,N
C        DATA(I) = DATA(I)/FN
    CALL XVBLGT(ID1F(I),ID2F(I),TEMP)
    TEMP=TEMP/FN
    CALL XVBLST(ID1F(I),ID2F(I),TEMP)
 150  CONTINUE
 160  RETURN
      END
c -h- help.for    Fri Aug 22 13:20:10 1986
    SUBROUTINE HELP(LVL)
C PRINT HELP INFO ON SCREEN USING FIRST 22 LINES. ASSUME XQTCMD INVALIDATES
C THE DISPLAY.
C COPYRIGHT (C) 1983 GLENN AND MARY EVERHART
    CHARACTER*1 FORM(128)
    CALL UVT100(18,0,0)
    CALL UVT100(11,2,0)
    CALL UVT100(1,1,1)
C COPYRIGHT (C) 1983 GLENN and MARY EVERHART
C All Rights Reserved
C
C NEW PC HELP FILE
C DESIGNED TO BE SMALLER THAN OLD VERSION. READS FILES OFF DISK
C BY SKIPPING N*24 LINES AND DISPLAYING 24 LINES, WHERE N=LVL
C ASSUME HELP FILE ON DISK LOGGED CURRENTLY
    CLOSE(3)
c for now, assume help file lives on same disk as our default.
    IXXX=0
    OPEN(3,FILE='PCCHELP.HLP',STATUS='OLD',ACCESS='DIRECT',
     1  FORM='UNFORMATTED',RECL=128,IOSTAT=IXXX)
    IF(IXXX.GT.0)RETURN
C RETURN IF HELP FILE IS MISSING...
C USE A FIXED HELP FILE FOR MULTISCREEN HELP. LOWER OVERHEAD,...
    NSKP=LVL*24
C NOW READ IN THE DATA, WRITE TO SCREEN.
    KKL=NSKP+1
    KKH=NSKP+23
C JUST GO DIRECTLY TO THE DESIRED SCREENFUL OF INFO.
    DO 7640 KKK=KKL,KKH
    READ(3,REC=KKK,END=7642,ERR=7642)FORM
c use fortran writes here normally since we want the crlf stuff they imply
c always write 24 lines to scroll all else off...
    IVVV=78
C FIND END OF LINE AND ONLY EMIT CHARACTERS TO THAT; DON'T WASTE
C TIME DRAWING SPACES ON THE SCREEN.
    DO 772 IV=1,78
    IVVV=79-IV
    IF(ICHAR(FORM(IVVV)).GT.32)GOTO 773
772    CONTINUE
773    CONTINUE
    FORM(IVVV+1)=Char(13)
    FORM(IVVV+2)=Char(10)
    IVVV=IVVV+2
    CALL SWRT(FORM,IVVV)
C    WRITE(11,7643)(FORM(IV),IV=1,IVVV)
C NOTE WE HAVE LUN 6 OPENED AS CON: IN THE MAIN PROGRAM TO GIVE AN
C INDEPENDENT TERMINAL OUTPUT CHANNEL. HOPEFULLY THIS PREVENTS SOME
C SCREWUPS DUE TO USING LUN 0 FOR BOTH CONSOLE INPUT AND OUTPUT; END OF
C RECORDS OUGHT TO BE INDEPENDENT THIS WAY (I HOPE).
C7643    FORMAT(1X,82A1,4A1)
7640    CONTINUE
7642    CONTINUE
    CLOSE(3)
    FORM(1)=13
    CALL SWRT(FORM,1)
    RETURN
    END
c -h- linfit.for    Fri Aug 22 13:23:55 1986
C LINE FITTING SUBROUTINE WITH ERROR MEASURE RETURN ALSO.
    SUBROUTINE LINFIT(ID1X,ID2X,IRCOL,ID1,ID2,N,A,B,DEL,RR)
    InTeGer*4 ID1X,ID2X,IRCOL,ID1,ID2,N
    REAL*8 A,B,DEL,XY,SX2,SX,SY,RR
    InTeGer*4 IC,IR,KK,KKK,I
    REAL*8 XI,YI,SY2,EN,WRK
C FIT LINE TO EQUALLY SPACED POINTS...
C Y=BX+A
    SY2=0.
    EN=N
    XY=0.
    SX2=0.
    SX=0.
    SY=0.
    IC=IRCOL
    IR=1-IRCOL
C IRCOL IS 0 OR 1 FOR ACROSS OR DOWN
    DO 10 I=1,N
C IF ID1X < 0 THEN FORM IT HERE AS ID1+I-1
    IF (ID1X.GT.0)GOTO 20
C FORM XI
    XI=I
    GOTO 30
20    CONTINUE
C INPUT XI
    KK=ID1X+IC*(I-1)
    KKK=ID2X+IR*(I-1)
    CALL XVBLGT(KK,KKK,XI)
30    CONTINUE
C GET YI IN ANY CASE...
    KK=ID1+IC*(I-1)
    KKK=ID2+IR*(I-1)
    CALL XVBLGT(KK,KKK,YI)
    XY=XY+XI*YI
C FORM SUMS NEEDED TO FIT LINE...
    SX2=SX2+XI*XI
    SX=SX+XI
    SY=SY+YI
    SY2=SY2+YI*YI
10    CONTINUE
C NOW GET SLOPE
    WRK=((XY-(SX*SY)/EN)/(SX2-(SX*SX)/EN))
    B=WRK
C THEN INTERCEPT
    WRK=(SY/EN)-B*(SX/EN)
    A=WRK
    WRK=DSQRT((SY2-(A*SY+B*XY))/EN)
    DEL=WRK
C DEL = ERROR OF FIT
    RR=(EN*XY-SX*SY)/DSQRT((EN*SX2-SX*SX)*(EN*SY2-SY*SY))
C RR IS CORRELATION COEFFICIENT
    RETURN
    END
c -h- list.for    Fri Aug 22 13:24:14 1986
    SUBROUTINE LIST
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *              SUBROUTINE  LIST                  *
C *                                                *
C **************************************************
C
C
C LISTS THE LEGAL CALC COMMANDS AND GIVES A BRIEF
C DESCRIPTION OF THEIR FUNCTION.
C
C LIST IS CALLED BY CALC
C
C    SUBROUTINE LIST
C
C
C NOTE WE USE FORTRAN WRITE HERE SINCE IT SHOULD ONLY HAPPEN IN CALC MODE.
    rewind 11
    WRITE (11,20)
    WRITE (11,30)
    rewind 11
    RETURN
20    FORMAT (' CMDS= @FILE-DO FILE;*C-COMMENT;*E-EXIT;*R-READ CON')
30    FORMAT (' *S-STOP;*V n(bet.0,3)-VIEW CTL- HIGHER=SEE MORE')
    END
c -h- wsset.f40    Fri Aug 22 13:43:11 1986
        SUBROUTINE WSSET
C WORK SHEET MANAGMENT ROUTINES
C HANDLE SPREADSHEET "IN MEMORY" STORAGE
C COPYRIGHT (C) GLENN AND MARY EVERHART 1983,1984
C
C ALL RIGHTS RESERVED
C
C WSSET - INITIALIZE STORAGE TO START CONDITIONS
C EXPECT IMPLEMENTATION TO USE A COMMON BITMAP AND PROVIDE A VARIABLE
C NCEL TO TELL HOW MANY CELLS ARE IN USE
C NEXT BITMAPS IMPLEMENT FVLD
        CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
    CHARACTER*1 FVXX(6792)
    EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
    EQUIVALENCE (FV4(1),FVXX(4529))
        Common/FVLDM/FVXX
c        COMMON/FVLDM/FV1,FV2,FV4
C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
C TYPES OF AC'S STORAGE:
        CHARACTER*1 ITYP(2264)
        InTeGer*4 IATYP(27),LINTGR
        COMMON/TYP/IATYP,ITYP,LINTGR
        CHARACTER*1 LBITS(8)
        COMMON/BITS/LBITS
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC        InTeGer*4 IPGMAX,LPGMXF
CCC        COMMON/FILEMX/IPGMAX,LPGMXF
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C USE LUN 7 FOR FORMULAS, 9 FOR VALUES FILE IF NEEDED...
C
C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
C AREAS WITH DATA.
C ***<<< KLSTO COMMON START >>>***
    InTeGer*4 DLFG
C    COMMON/DLFG/DLFG
    InTeGer*4 KDRW,KDCL
C    COMMON/DOT/KDRW,KDCL
    InTeGer*4 DTRENA
C    COMMON/DTRCMN/DTRENA
    REAL*8 EP,PV,FV
    DIMENSION EP(20)
    INTEGER*4 KIRR
C    COMMON/ERNPER/EP,PV,FV,KIRR
    InTeGer*4 LASTOP
C    COMMON/ERROR/LASTOP
    CHARACTER*1 FMTDAT(9,76)
C    COMMON/FMTBFR/FMTDAT
    CHARACTER*1 EDNAM(16)
C    COMMON/EDNAM/EDNAM
    InTeGer*4 MFID(2),MFMOD(2)
C    COMMON/FRM/MFID,MFMOD
    InTeGer*4 JMVFG,JMVOLD
C    COMMON/FUBAR/JMVFG,JMVOLD
    COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC        CHARACTER*1 FMTDAT(9,76)
CCC        COMMON/FMTBFR/FMTDAT
        CHARACTER*1 DVF(12),DFMT(10)
        EQUIVALENCE(DVF(2),DFMT(1))
        COMMON/DEFVBX/DVF
CCC    InTeGer*4 DLFG
CCC    COMMON/DLFG/DLFG
C DLFG IS NONZERO IF ANY D## FORMS HAVE BEEN SEEN
        InTeGer*4 MPAG(2),MPMOD
        InTeGer*2 LVALBF(5,800)
    DIMENSION MPMOD(2)
        COMMON/VB/MPAG,LVALBF,MPMOD
    InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
    COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
CCC    InTeGer*4 MFID(2)
C        InTeGer*4 MFID,IFID(8,2048)
C        CHARACTER*1 LFID(16,2048)
C        EQUIVALENCE(IFID(1,1),LFID(1,1))
CCC        COMMON/FRM/MFID,MFMOD
C        COMMON/FRM/MFID,IFID
C
C ***<<< NULETC COMMON START >>>***
    InTeGer*4 ICREF,IRREF
C    COMMON/MIRROR/ICREF,IRREF
    InTeGer*4 MODPUB,LIMODE
C    COMMON/MODPUB/MODPUB,LIMODE
    InTeGer*4 KLKC,KLKR
    REAL*8 AACP,AACQ
C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
    InTeGer*4 NCEL,NXINI
C    COMMON/NCEL/NCEL,NXINI
    CHARACTER*1 NAMARY(20,301)
C    COMMON/NMNMNM/NAMARY
    InTeGer*4 NULAST,LFVD
C    COMMON/NULXXX/NULAST,LFVD
    COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC        COMMON /NCEL/NCEL,NXINI
    LINTGR=0
    MPMOD(1)=0
    MPMOD(2)=0
    MFMOD(1)=0
    MFMOD(2)=0
    DLFG=0
        IBP=1
C INITIALIZE ADDRESSES FOR FVLDSG/FVLDGT
C    CALL FVGO(FV1,LBITS)
        DO 2 N=1,9
2       FMTDAT(N,1)=DFMT(N)
        DO 3 N=2,76
        DO 3 NN=1,9
3       FMTDAT(NN,N)=CHAR(0)
        DO 1 N=1,8
    NN=128/IBP
        LBITS(N)=CHAR(NN)
1       IBP=IBP+IBP
        DO 4 N=1,2264
C CLEAR BITMAPS NOW
        FV1(N)=CHAR(0)
        FV2(N)=CHAR(0)
        FV4(N)=CHAR(0)
4       ITYP(N)=CHAR(0)
C OPEN THE WORK FILES SO WE DON'T NEED TO LATER...
C LUN 7 IS FORMULAS; LUN 9 IS VALUES
C HOWEVER, IF IPGMAX IS LESS THAN 800/205 (INDICATING ENTIRE FILE
C FITS IN MEMORY) DON'T OPEN LUN 9 AND IF LPGMXF IS < 2048/64, LIKEWISE
C FOR LUN 7.
C INITIALLY CLOSE FILES IN CASE THEY WERE OPEN...
        CLOSE(7,STATUS='DELETE')
        CLOSE(13,STATUS='DELETE')
C NOW OPEN THEM AS RANDOM ACCESS FILES.
        NBK=IPGMAX*2
C KEEP VALUE PAGES IN 500 BYTE UNITS, NOT 512 BYTE UNITS, TO COME
C OUT EVEN...
        IF(IPGMAX.GT.(800/100))OPEN(13,
     1  ACCESS='DIRECT',FORM='UNFORMATTED',
     3  RECL=500,STATUS='NEW')
        NBK=LPGMXF*2
        IF(LPGMXF.GT.(2048/64))OPEN(7,
     1  ACCESS='DIRECT',FORM='UNFORMATTED',
     3  RECL=512,STATUS='NEW')
C SET NOTHING IN MEMORY YET
        MFID(1)=0
    MFID(2)=0
        MPAG(1)=0
    MPAG(2)=0
C MARK BUFFER 1 AS IN MEMORY AND AS LAST-ACCESSED (SO WE FIRST ATTEMPT TO
C OVERWRITE BUFFER 2 TO GET STARTED.)
    MFLAST=1
    MFBASE=0
    MVLAST=1
    MVBASE=0
C ZERO MEMORY BUFFER AND FILES
C ACTUALLY MARK WITH -1 SO THAT WE CAN TELL WHEN WE HIT A VIRGIN
C AREA.
        DO 9 N=1,800
        DO 9 M=1,5
9       LVALBF(M,N)=-1
        NPG=(IPGMAX*2)
        IF(IPGMAX.LE.(800/100))GOTO 11
        DO 10 N=1,NPG
10      WRITE(13,REC=N,ERR=11)((LVALBF(K,KKK),K=1,5),KKK=1,50)
11      CONTINUE
    CALL WRKFIL(0,0,50)
C        DO 12 N=1,2048
C        DO 12 M=1,8
C12      IFID(M,N)=0
C    NPG=LPGMXF*2
C        IF(LPGMXF.LE.(2048/64))GOTO 14
C        DO 13 N=1,NPG
C13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
14      CONTINUE
C SET ALL AC'S TO TYPE FLOATING...
        DO 8 N=1,27
8       IATYP(N)=2
C TYPE 2 IS REALS (DEFAULT)
        NCEL=0
    NXINI=0
        RETURN
        END
c -h- wtbini.f40    Fri Aug 22 13:43:29 1986
C WORK FORMULA TABLE INITIALIZE FOR DTBL1 COMMON
C COPYRIGHT (C) GLENN AND MARY EVERHART 1985
C ALL RIGHTS RESERVED
    SUBROUTINE WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,
     1  BTBL6,BTBL7,BTBL8)
    CHARACTER*1 DTBL1(9,9,8)
C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
    Integer*4 LPGMXF
C    InTeGer*2 BTBL(6,6,8)
C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
C NO NEED TO WASTE IT.
    InTeGer*2 IFID(8,2048)
C    CHARACTER*1 LFID(16,2048)
C    EQUIVALENCE(LFID(1,1),IFID(1,1))
C    EQUIVALENCE(IFID(1,1),BTBL(1,1,1))
    InTeGer*2 BTBL1(6,6)
    InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
    InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
C    EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
C    EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
C    EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
C    EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
    COMMON /DECIDE/ DTBL1
C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
C TYPES (WHICH ARE NOT SUPPORTED HERE)
    do 135 n3=1,8
    do 135 n2=1,9
    do 135 n1=1,9
135    dtbl1(n1,n2,n3)=CHAR(0)
    DO 35 NN2=1,6
    N2=NN2
    IF(NN2.GT.4)N2=NN2+3
    DO 235 N1=1,4
    DTBL1(N1,N2,1)=CHAR(BTBL1(N1,NN2))
    DTBL1(N1,N2,2)=CHAR(BTBL2(N1,NN2))
    DTBL1(N1,N2,3)=CHAR(BTBL3(N1,NN2))
    DTBL1(N1,N2,4)=CHAR(BTBL4(N1,NN2))
    DTBL1(N1,N2,5)=CHAR(BTBL5(N1,NN2))
    DTBL1(N1,N2,6)=CHAR(BTBL6(N1,NN2))
    DTBL1(N1,N2,7)=CHAR(BTBL7(N1,NN2))
235    DTBL1(N1,N2,8)=CHAR(BTBL8(N1,NN2))
    do 335 n1=5,6
    DTBL1(N1+3,N2,1)=CHAR(BTBL1(N1,NN2))
    DTBL1(N1+3,N2,2)=CHAR(BTBL2(N1,NN2))
    DTBL1(N1+3,N2,3)=CHAR(BTBL3(N1,NN2))
    DTBL1(N1+3,N2,4)=CHAR(BTBL4(N1,NN2))
    DTBL1(N1+3,N2,5)=CHAR(BTBL5(N1,NN2))
    DTBL1(N1+3,N2,6)=CHAR(BTBL6(N1,NN2))
    DTBL1(N1+3,N2,7)=CHAR(BTBL7(N1,NN2))
    DTBL1(N1+3,N2,8)=CHAR(BTBL8(N1,NN2))
335    continue
35    CONTINUE
C NOW CLEAR THE BUFFER OUT, HAVING SET UP DTBL1 FROM IT.
C SET INITIAL -1 SO WE CAN RECOGNIZE WHEN TO STOP LOOKING
C INITIALLY...
    DO 36 NN=1,2048
    DO 36 N=1,8
36    IFID(N,NN)=-1
C ZERO THE FILE NOW
    NPG=LPGMXF*2
        IF(LPGMXF.LE.32)GOTO 14
C        IF(LPGMXF.LE.(2048/64))GOTO 14
        DO 13 N=1,NPG
13      WRITE(7,REC=N,ERR=14)((IFID(K,KKK),K=1,8),KKK=1,32)
14      CONTINUE
    RETURN
    END
c -h- wkdy.for    Fri Aug 22 13:44:33 1986
    SUBROUTINE WKDY(JULLO,JULHI,NDAYS)
C GIVEN START AND END JULIAN DATE, FIGURE OUT HOW MANY WEEK DAYS
C THERE ARE BETWEEN THEM.
    JL=JULLO
    JH=JULHI
    IF(JL.LE.JH)GOTO 10
    JL=JULHI
    JH=JULLO
10    CONTINUE
    IDL=(JH-JL)/7
C GET NUMBER OF WEEKS BETWEEN DAYS, 5 WORKDAYS PER WHOLE WEEK.
    IWDY=IDL*5
C ADD 3 SO THAT MODULO OF SUNDAY IS 0, NOT WED.
    IDOR=JH-JL-7*(IDL)
    IF(IDOR.NE.0)IDOR=5
C IDOR IS ORIGINAL # DAYS DIFFERENCE, CORRECTED FOR WHOLE
C WEEKS ALREADY ALLOWED.
    LD=JL+3
    LD=MOD(LD,7)
    LH=JH+3
    LH=MOD(LH,7)
C NOW HAVE DAY OF WEEK START,END. FIND WORK DAYS THAT WEEK (M-F ONLY)
    IKLU=0
    IK2=1
    IF(LD.LT.1)IK2=0
    IF(LD.LT.1)LD=1
    IF(LD.GT.5)LD=5
C FOR HIGH END OF RANGE IF THE END DATE IS SUNDAY SUBTRACT ONE DAY
C FROM THE DAYS SO WE OMIT THE MONDAY FROM THE RANGE...
    IF(LH.LT.1)IKLU=IK2
    IF(LH.LT.1)LH=1
    IF(LH.GT.5)LH=5
C LH = DAY ENDED ON, LD=START DAY, FORCED INTO WORK WEEK.
    IF (LH.GT.LD)IWDY=IWDY+LH-LD-IKLU
    IF (LH.LE.LD)IWDY=IWDY+IDOR-(LD-LH)-IKLU
C GIVES DAYS BETWEEN 2 DATES JUST LIKE JULIAN DATE SUBTRACTION FOR
C CALENDAR DATES.
    NDAYS=IWDY
    RETURN
    END
c -h- wrkint.for    Fri Aug 22 13:44:46 1986
    SUBROUTINE WRKINT(JULLO,NWDY,JULHI)
C GETS JULLO = START DATE AND NWDY = NO. WORKDAYS (M-F) TO ADD AND
C FINDS JULHI = END JULIAN DATE, CONSTRAINED TO BE IN MONDAY TO
C FRIDAY RANGE.
C MUST ADD 3 BECAUSE THAT'S THE BIAS OF OUR JULIAN DATE BASE.
    IDJL=MOD(JULLO+3,7)
C IDJL = DAY CODE OF START DATE
    NWWK=NWDY/5
    JL=JULLO
    IF(IDJL.LT.1)JL=JL+1
    IF(IDJL.GT.5)JL=JL+2
C BUMP START INTERVAL...
    NWDD=NWDY-5*NWWK
    JL=JL+NWWK*7+NWDD
    IDJL=MOD(JL+3,7)
    IF(IDJL.LT.1)JL=JL+1
    IF(IDJL.GT.5)JL=JL+2
C FORCE OUTPUT DATE TO BE WITHIN WORKWEEK
    JULHI=JL
    RETURN
    END