SUBROUTINE XQTCMD(ICODE) 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. C SPREAD SHEET COMMAND PROCESSOR C Created as a gift to the world by G. Everhart because our installation C can't affort $4000 for a commercial one. INCLUDE 'VKLUGPRM.FTN' C PARAMETER RRW = 32 C PARAMETER RCL = 32 ! REAL ROWS, COLS C PARAMETER DRW = 8 C PARAMETER DCL = 8 ! DISPLAY MAX ROWS, COLS. C PARAMETER RRCL = 1024 C PARAMETER RRCL=RRW*RCL PARAMETER CUP = 1, CUU = 2, CUD = 3, CUF = 4, CUB = 5, DECDWL = 6 $, DECDHL = 7, DECRC = 8, DECSC = 9, DECSWL = 10, ED = 11, EL = 12 $, SGR = 13, NEL = 14, SCS = 15, SM = 16, RM = 17, ANSI = 18 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. LOGICAL*1 FORM,FVLD,CMDLIN(132) InTEgeR*4 RRWACT,RCLACT,FOOBAR COMMON/FOOBAR/FOOBAR COMMON/RCLACT/RRWACT,RCLACT INTEGER*4 VNLT LOGICAL*1 LET1,LET2,FORM2(128),NMSH(80) COMMON/NMSH/NMSH D Integer*4 rabptr,rabsts REAL*8 XVBLS(RRWP,RCLP) INTEGER KPYBAK InTEgeR*4 IOLVL,JMVFG,JMVOLD INTEGER*4 JVBLS(2,RRWP,RCLP) 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. C PUT JMVFG INTO A PSECT BY ITSELF SO IT WILL SURVIVE OVERLAYS. COMMON/FUBAR/JMVFG,JMVOLD DIMENSION FORM(128),FVLD(RRWP,RCLP) LOGICAL*1 DFE,FVWRK,FVWRK2 DIMENSION DFE(12) 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 FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC. 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. InTEgeR*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,IDOL7, 1 IDOL8 COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,IDOL7, 1 IDOL8 InTEgeR*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV InTEgeR*4 LLCMD,LLDSP COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP InTEgeR*4 ILNFG,ILNCT,RCF,NCEL,NXINI COMMON/NCEL/NCEL,NXINI LOGICAL*1 ILINE(106) COMMON/ILN/ILNFG,ILNCT,ILINE InTEgeR*4 IC1POS,IC2POS COMMON/ICPOS/IC1POS,IC2POS LOGICAL*1 OARRY(100) InTEgeR*4 OSWIT,OCNTR COMMON/OAR/OSWIT,OCNTR,OARRY C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2 InTEgeR*4 TYPE(RRWP,RCLP),VLEN(9) LOGICAL*1 AVBLS(20,27),VBLS(8,RRWP,RCLP) LOGICAL*1 FVLDTP REAL*8 XAC,ZAC EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26)) REAL*8 XXAC,XYAC EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25)) LOGICAL*1 ARGSTR(52,4) COMMON/ARGSTR/ARGSTR C EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1)) C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND. EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1)) EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN COMMON/KLVL/KLVL InTEgeR*4 MODPUB,LIMODE COMMON/MODPUB/MODPUB,LIMODE LOGICAL*1 DEFVB(12) COMMON/DEFVBX/DEFVB Common/VEWHAK/IVWHK INTEGER*4 IVWHK C Viewhack will simply (if turned on) cause RECALC to display C the current row number on the fly as recalculations C proceed. It will be set by VH+ and reset by VH- commands C processed here. 0 means off, nonzero means on. InTEgeR*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1, 1 IRCE2 COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1, 1 IRCE2 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(DRW) 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 DRW NOT DCL. REAL*8 DVS(DRW,DCL) INTEGER*4 LDVS(2,DRW,DCL) EQUIVALENCE(LDVS(1,1,1),DVS(1,1)) COMMON /FVLDC/FVLD C LOGICAL*1 DFMTS(10,DRW,DCL) C 10 CHARACTERS PER ENTRY. COMMON/DSPCMN/DVS,CWIDS C THISRW,THISCL = CURRENT DISPLAYED LOCS. InTEgeR*4 THISRW,THISCL C LOGICAL*1 IBITMP(BRRCL) C COMMON/INITD/IBITMP C FOLLOWING COMMON IS TO CONTROL "EXTERNAL" CALL OF XQTCMD C TO ALLOW USE FROM INSIDE CELLS. LOGICAL*1 XTNCMD(80) InTEgeR*4 XTCFG,XTNCNT,IPSET COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET InTEgeR*4 NULAST,LFVD COMMON/NULXXX/NULAST,LFVD logical*1 blanks dimension blanks(30) data blanks/30*32/ C OSWIT=2 C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND C C COMMANDS INCLUDE: C E = ENTER NUMBERS OR FORMULAS C M = MOVE DIRECTION (1,2,3,4 = U,D,L,R) C D = DISPLAY CHARACTERISTIC CHANGES C C DISPLAY ALTERING SUBCOMMANDS: C DL V1:V2 RN:M OR CN:M - DISPLAY VARIABLE RANGE V1:V2 AT DISPLAY C ROW OR COL N THRU M. C RN:M MEANS ACROSS A ROW ON DISPLAY STARTING AT DISPLAY COORD N,M C CN:M MEANS DOWN A DISPLAY COLUMN STARTING AT DISPLAY COORD N,M C DF V1:V2 [FORMAT] C SET FORMAT FOR DISPLAY OF V1 THRU V2 TO [FORMAT] (NOT INCL. []) C A OR L DESIGNATOR SAYS SHOW TEXT IN FORMULA BUFFER. ELSE SHOW C NUMBER VALUE AT THAT LOC. C DT V1:V2 F OR I - SET NUMERIC TYPE OF V1 THRU V2 TO FLOAT OR INT. C DW N,M - SET WIDTH OF COL. N TO M CHARS WIDE. C DB MC,MR - SET MAX COLS TO MC, MAX ROWS TO MR. C C V = VIEWSCREEN UPDATE. REDISPLAY EVERYTHING FROM SCRATCH. C VF = VIEW BUT DISPLAY FORMULAS ALL LOCS. C VM = DISABLE REDRAWING SCREEN UNTIL A V IS SEEN. C C = COPY NUMBERS/FORMULAS/DISPLAY STUFF(FORMAT)/ALL/RELOCATING C 1,2,3,4 = MOVE CURSOR UP,DOWN,LEFT,RIGHT 1 ROW/COL C (THESE DO NOT INVALIDATE CALCULATION SO RECALCULATION IS NOT C DONE FOR THESE COMMANDS.) C F FILENAME/NNN FILL SCREEN (DISPLAYED PART ONLY) FROM FILENAME, C SKIPPING NNN RECORDS FIRST IF CALLED FOR. /NNN PART OPTIONAL. C (SPLITS STUFF READ IN ACROSS COLUMNS CURRENTLY DEFINED AND C SETS FVLD FOR DISPLAY OF TEXT, NOT #S.) C A[R/A] n [R/C] ADDS/SUBTRACTS (INSERTS/DELETES) n ROWS OR COLUMNS C AT CURENT LOCATION. AR/AA SELECTS RELOCATING/ABSOLUTE. C R = RECALCULATE SHEET. RM = RECALCULATE MANUALLY ONLY (R RESETS) C K = DROP INTO CALC CALCULATOR (*E RETURNS TO SHEET) C L = LOCATE CURSOR (MOVE TO POSITION ON SHEET) C (L VARIABLE IS THE COMMAND, AND IT LOCATES ORIGIN ON PHYSICAL C SHEET. WILL ALSO MOVE CURSOR ON DISPLAY SHEET IF THAT CELL IS C DISPLAYED, BUT OTHERWISE DOES NOT DISPLAY THE NUMBER.) C Z = ZERO FORMULA/NUMBERS (OR ALL SHEET) C ZERO VARIABLE ZEROES THAT VARIABLE C ZERO VARIABLE1:VARIABLE2 ZEROES THAT RANGE (ROW OR COL) C ZERO * ZEROES ALL OF THE SHEET. C X = EXIT (RETURNS TO OS) C P = PUT NUMBERS TO FILE. ALWAYS GENERATES P#+nn#+mm forms based on C current location. C G = GET NUMBERS OUT OF FILE. USES CURRENT ORIGIN FROM L COMMAND OR 1,1 C TO ENTER NUMBERS (ALLOWS COMBINING DATA). C W = WRITE SCREEN ON PRINTER (HARDCOPY FORMAT APPROX. AS DISPLAY.) C OA VARIABLE = SET ORIGIN OF DISPLAY SHEET TO VARIABLE LOC IN C PHYSICAL SHEET (CLAMPED TO MAX. SIZE OF SHEET). STARTS AT R1,C1 OF C DISPLAY SHEET. C OR VARIABLE = SET ORIGIN OF DISPLAY SHEET TO LOC'N OF VARIABLE IN C PHYSICAL SHEET. MODIFIES DISPLAY SHEET STARTING AT CURRENT DISPLAY C LOCATION RATHER THAN AT 1,1. C C NOTE THAT N-ARY FUNCTIONS ARE FNAME[ARGS,ARGS,...] C AND RANGES ARE CELL1:CELLN. MULTIPLE COMMANDS IN FORMULA ARE C DELIMITED BY \ CHARACTER. C C RETURN CODES: C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE C THE ENTIRE SHEET. C ICODE =-1 ==> REINITIALIZE DISPLAY DEFAULTS C ICODE =2 ==> REDRAW WHOLE SCREEN C ICODE =-2 ==> NEW SPREAD SHEET FILE SETUP. C OTHER: ALL OK. 498 CONTINUE KLVL=1 ICODE=3 C DEFAULT RETURN CODE SAYING ALL WELL C FIRST DISPLAY CURRENT CELL AGAIN IN NORMAL. THISRW=DROW THISCL=DCOL FORM(1)=0 C GET IN THE CURRENT FORMAT WHEREVER WE ARE, EVEN IF NOT ON DISPLAY SHEET. C IRRX=(PCOL-1)*RRW+PROW CALL REFLEC(PCOL,PROW,IRRX) CALL WRKFIL(IRRX,FORM,0) C READ(7'IRRX)FORM IF(THISRW.LE.0.OR.THISCL.LE.0)GOTO 200 N1=NRDSP(THISRW,THISCL) N2=NCDSP(THISRW,THISCL) IXLSTC=THISCL IXLSTR=THISRW IF(THISCL.GT.DCLV.OR.THISRW.GT.DRWV)GOTO 200 C REDRAW LAST DISPLAYED CELL IN NORMAL (I.E., NOT REVERSE) VIDEO. C IF(FVLD(N1,N2).EQ.0)GOTO 200 C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED. J=8 C IRRX=(N2-1)*RRW+N1 CALL REFLEC(N2,N1,IRRX) C ADD 6 COLS FOR LABELS DO 1 M1=1,DROW C FIND DISPLAY COLUMN TO USE 1 J=J+CWIDS(M1) J=J-CWIDS(DROW) C USE THISCL+1 TO LET 1ST ROW BE LABELS. ICCC=THISCL+2 C JVTINC = 1 IF VT100, 0 IF VT52 C SAVE PHYS COORDS BEING DISPLAYED NEXT. FVLD CAN BE TESTED FOR NUMERICS C DIRECTLY, IF UVT100 NEEDS THAT ACCESS. IC1POS=N1 IC2POS=N2 IF(PZAP.NE.0)GOTO 3607 CALL UVT100(CUP,ICCC,J+JVTINC) !SELECT ROW "THISCL", COL "J" CALL UVT100(SGR,7) CALL FVLDGT(N1,N2,FVLD(1,1)) ivv=min0(30,cwids(DROW)) C reset blanks to be sure we write something even for vt52 blanks(1)='>' IF(FVLD(1,1).EQ.0)WRITE(6,5538)(blanks(iv),iv=1,ivv) blanks(1)=32 5538 FORMAT(30a1) 3607 CONTINUE C WE CAN BE SURE THE COLUMN IS 3 WIDE OR MORE... CALL FVLDGT(N1,N2,FVLDTP) IF(FVLDTP.EQ.0)GOTO 200 C IRRX=(N2-1)*RRW+N1 C SELECT REVERSE VIDEO DO 5540 KKKK=1,100 5540 CMDLIN(KKKK)=32 CALL WRKFIL(IRRX,FORM,0) C READ(7'IRRX)FORM IF(FORM(120).LE.0)GOTO 200 IF(FVLDTP.LT.0.OR.FORMFG.NE.0) 1 ENCODE(100,8201,CMDLIN)(FORM(II),II=1,100) 8201 FORMAT(128A1) IF(FORMFG.NE.0)GOTO 4320 DO 6301 KKK=1,9 KKKK=FORM(KKK+119) C KKKK=DFMTS(KKK,THISRW,THISCL) 6301 DFE(KKK+1)=MAX0(32,KKKK) DFE(11)=32 C 32 = ASCII SPACE DFE(1)='(' DFE(12)=')' CALL TYPGET(N1,N2,TYPE(1,1)) IF(TYPE(1,1).EQ.2.AND.FVLDTP.GT.0) 1 ENCODE(100,DFE,CMDLIN,ERR=4320)DVS(THISRW,THISCL) IF(TYPE(1,1).NE.2.AND.FVLDTP.GT.0) 1 ENCODE(100,DFE,CMDLIN,ERR=4320)LDVS(1,THISRW,THISCL) C REDRAW THIS COL. WITH REVERSE VIDEO HERE. 4320 IF(PZAP.EQ.0)WRITE(6,9000)(CMDLIN(II),II=1,CWIDS(THISRW)) 9000 FORMAT(128A1) IF(PZAP.EQ.0)CALL UVT100(SGR,0) C NOTE THIS REDRAWS PREVIOUS COL. IN REVERSE VIDEO. C NO CARRIAGE CTL 200 CONTINUE IF(PZAP.NE.0)GOTO 3608 KKKK=FVLDTP IF(NULAST.EQ.NCEL.AND.FVLDTP.EQ.0.AND.LFVD.EQ.0)GOTO 222 CALL UVT100(CUP,LLDSP,1) CALL UVT100(EL,2) IF(FORM(1).LE.0)GOTO 222 9092 FORMAT(I5,' Used. Curr=',64A1,50A1) WRITE(6,9092)NCEL,(FORM(II),II=1,109) C3608 CONTINUE 222 CALL UVT100(CUP,LLCMD,1) C REMEMBER LAST DISPLAY ROW STUFF SO WE UPDATE ONLY WHEN SOME PRINT C STUFF HAS TO CHANGE. NULAST=NCEL LFVD=KKKK CALL UVT100(EL,2) C NOTE PROW IS ACROSS TOP, PCOL IS DOWN SIDE C PROW GOES AS ID1, ALPHAS C PCOL GOES AS ID2, NUMERICS CALL IN2AS(PROW,FORM) C NOTE PCOL STARTS AT 2 FOR NORMAL SHEET VARIABLES. PCOL=1 IS FOR ACCUMULATORS CALL UVT100(SGR,0) KKKKKK=62 IF(MODPUB.EQ.1)KKKKKK=58 C 62 IS > CHARACTER. 58 IS : CHARACTER C PROVIDE A FLAG OF WHICH MODE WE'RE IN FOR USERS WRITE(6,9001,ERR=3608)(FORM(I),I=1,4),PCOL-1,KKKKKK 9001 FORMAT(4A1,I5,1A1) 3608 CONTINUE ISCANX=0 IF(XTCFG.NE.0)GOTO 3870 IF(IOLVL.NE.5.OR.FOOBAR.NE.0) 1 READ(IOLVL,9002,END=510,ERR=510)CMDLIN C FOR READING THE CONSOLE, WE NEED A QIO$ TO CAPTURE ESCAPE SEQUENCES. IF(IOLVL.EQ.5.AND.FOOBAR.EQ.0)CALL GETTTL(CMDLIN) C FURTHER MUNGES FOR COMMAND LANGUAGE CALL GTMUNG(CMDLIN) GOTO 3871 3870 CONTINUE XTCFG=0 DO 3872 I=1,XTNCNT CMDLIN(I)=XTNCMD(I) 3872 CONTINUE C COPY IN EXTERNAL COMMAND AND LET IT BE EXECUTED. IT'S THE USER'S C PROBLEM IF THE COMMAND REQUIRES STILL FURTHER INPUT... C ALSO NULL OUT SOME DELIMITER CHARS AFTER THE COMMAND READ IN. CMDLIN(XTNCNT+1)=0 CMDLIN(XTNCNT+2)=0 3871 CONTINUE 9002 FORMAT(132A1) CMDLIN(132)=0 CMDLIN(131)=0 CMDLIN(130)=0 C SAVE CURRENT PHYS ROW, COL IN AC'S X AND Y XXAC=PROW XYAC=PCOL C ZAP IN SPECIAL FUNCTION KEY REPLIES INTO NORMAL FORMS CALL CMDMUN(CMDLIN) DO 9048 I=1,129 K=130-I C START AT BACK OF LINE AND ZAP WHITESPACE BY NULL TERMINATOR IF(CMDLIN(K).GT.32)GOTO 9049 CMDLIN(K)=0 C ALSO GET RID OF POSSIBLE TRAILING CR, LF. 9048 CONTINUE 9049 CONTINUE C C THIS GETS COMMAND LINE IN. NOW ACTON IT. C REPOS'N TO OLD LINE NOW. CALL UVT100(CUP,LLCMD,1) C C THE FOLLOWING SECTION IMPLEMENTS THE ADDITIONAL FUNCTION OF C JOURNALING: (DONE ON VAX ONLY SINCE SPACE REQUIREMENTS FOR FILE C OPERATIONS MAY BE A PROBLEM ON PDP11'S). C Command +J FILENAME will record all remaining C line inputs at this point in it. (Assumes JNLFLG=0 initially) C Command +N closes journal file. K=K+1 IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'J'.AND.JNLFLG.NE.1) 1 GOTO 4290 IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'N')GOTO 4292 IF(JNLFLG.EQ.1)WRITE(10,9002)(CMDLIN(IV),IV=1,K) D If(jnlflg.ne.1)goto 8444 D rabptr=FOR$RAB(10) C Flush logfile to disk D rabsts=SYS$FLUSH(%VAL(rabptr)) C Needed to ensure CURRENT output in logfile. Compile with /d_lines C to enable. D8444 Continue GOTO 4291 4292 CONTINUE CLOSE(UNIT=10) JNLFLG=0 GOTO 9990 4290 CONTINUE JNLFLG=1 C USE WHATEVER FILE NAME THE USER HAS SUPPLIED AFTER THE +J C FOR FILE TO JOURNAL ONTO. (NO MORE QUESTIONS NEEDED.) CALL ASSIGN(10,CMDLIN(3)) GOTO 9990 4291 CONTINUE C C C ALLOW COMMENTS IF LINE BEGINS WITH * (JUST LIKE CALC) IF(CMDLIN(1).NE.'*')GOTO 6002 ICODE=1 GOTO 9990 6002 CONTINUE C IF(CMDLIN(1).EQ.'*')GOTO 9990 C C * NEW **************** C ADD PLACE TO PUT IN USER COMMANDS. DEFAULT IS NONE EXIST, DO NOTHING IGOTIT=0 CALL USRCMD(CMDLIN,ICODE,IGOTIT) C WHEN WE GET A COMMAND, SET IGOTIT TO 1 AND WE THEN PROCESS COMMAND NORMALLY IF(IGOTIT.EQ.1)GOTO 9990 C * NEW **************** C C COMMAND -PROMPT WILL READ FROM LUN 5 TO ARGSTR C TERMINATING WITH SPACES. IF(CMDLIN(1).NE.'-')GOTO 350 ICODE=1 CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) WRITE(6,9000)(CMDLIN(IV),IV=2,50) READ(5,9000,END=510,ERR=510)FORM2 II=1 KK=1 DO 351 KKK=1,128 C LOAD UP OUR ARGUMENTS IN ARGSTR(N,1) TO ARGSTR(N,4) ARGSTR(KK,II)=FORM2(KKK) KK=KK+1 ARGSTR(KK,II)=0 IF(KK.LT.52)GOTO 352 354 KK=1 II=II+1 IF(II.GT.4)GOTO 353 352 CONTINUE IF(FORM2(KKK).GT.32)GOTO 351 C ON SPACE, GO TO THE NEXT ARGUMENT. ALSO SPILL INTO C THE NEXT ARGUMENT IF WE SEE NO SPACES AND JUST TRAIL ALONG. GOTO 354 351 CONTINUE 353 GOTO 9990 350 CONTINUE C C CONTROL SCROLLING. PERMIT THE COMMAND "SC" TO TURN SCROLLING ON C AND "NS" TO TURN IT BACK OFF. IVV=-1 IF(CMDLIN(1).EQ.'S'.AND.CMDLIN(2).EQ.'C')IVV=1 IF(CMDLIN(1).EQ.'N'.AND.CMDLIN(2).EQ.'S')IVV=0 IF(IVV.GE.0)IDOL7=IVV IF(IVV.GE.0)ICODE=5 IF(IVV.GE.0)GOTO 9990 C C ALLOW PROGRAMMED "REWIND" OF INPUT COMMAND LINE ON C COMMAND LINE BEGINNING WITH "<". MAKE IT CONDITIONAL C BY SAYING THAT IF % IS NEGATIVE WE WON'T DO IT. IF(CMDLIN(1).NE.'<')GOTO 356 ICODE=5 IF(XAC.GT.0.)REWIND IOLVL GOTO 9990 356 CONTINUE C C HANDLE @FILE COMAND TO CHANGE TO INPUT OFF THAT FILE. IF(CMDLIN(1).NE.'@')GOTO 511 C WOW, A FILE. (OR AT LEAST SO WE HOPE). CLOSE(UNIT=3) C CLOSE LUN 3 (OR NOTHING IF IT WAS NOT OPEN) C *** C NOW OPEN NEW LUN 3... OPEN(UNIT=3,FILE=CMDLIN(2),READONLY,STATUS='OLD', 1 ERR=510) C CALL ASSIGN(3,CMDLIN(2)) C USE FACT THAT WE JUST NULL TERMINATED THE FILENAME PART AND SET C IT TO BE LUN 3. IOLVL=3 C NOW GO BACK FOR ANOTHER COMMAND...NO SENSE WASTING RECALC TIME SINCE C NOTHING HAS REALLY HAPPENED YET. C NOTE EVERY READ TO LUN 3 HAS EOF/ERROR CHECK TO GO TO 510 TO RESET C TO LUN 5 INPUT AND CLOSE FILE WE OPENED ON 3. GOTO 498 511 CONTINUE C C AA n R, AA n C, AR n R, AR n C COMMANDS C IF(CMDLIN(1).NE.'O'.OR.CMDLIN(2).NE.'V')GOTO 6887 C OV + TURNS ON OVERRIDE C OV - TURNS OFF OVERRIDE C ALLOWS ONE TO OVERRIDE $ SIGN FORMS' ABSOLUTE NATURE IF(CMDLIN(3).EQ.'+'.OR.CMDLIN(4).EQ.'+')IDOL3=1 IF(CMDLIN(3).EQ.'-'.OR.CMDLIN(4).EQ.'-')IDOL3=0 GOTO 9990 6887 CONTINUE IF(CMDLIN(1).NE.'A')GOTO 8845 C ADD ROWS OR COLUMNS (OR REMOVE THEM) AT THE CURRENT PHYSICAL LOCATION C WHERE AA MEANS ADD ABSOLUTE (NO RELOCATION), AR MEANS ADD RELOCATING C (RELOCATE ALL VARIABLES BELOW), AND R OR C SAYS TO ADD/SEBTRACT ROWS C OR COLUMNS. C C FIRST COLLECT THE ARGUMENTS TO THE FUNCTION. KM1=3 KM2=10 CALL GN(KM1,KM2,ICNT,CMDLIN) C GETS THE NUMBER. IF NO NUMBER SEEN OR ZERO, RETURNS 0. IGNORE THEN. IF(ICNT.EQ.0)GOTO 9990 ICR=0 C LOOK FOR THE R OR C C START AT CMDLIN(4) TO PASS THE AR/AA AND THE NUMBER IF ANY. DO 8844 KKK=4,50 IF(CMDLIN(KKK).EQ.'R')ICR=1 IF(CMDLIN(KKK).EQ.'C')ICR=2 IF(ICR.NE.0)GOTO 8846 C SKIP OUT ON FIRST ROW OR COLUMN DESIGNATOR SEEN 8844 CONTINUE 8846 CONTINUE IF(ICR.EQ.0)GOTO 9990 ICODE=2 C NOW WE HAVE ALL ARGUMENTS. SET UP FOR THE COPY AND PARASITE THE C LOGIC USED FOR THE CA OR CR COMMANDS. (NOTE THAT 2ND CHARACTER C IS A OR R IN CMDLIN ALREADY SO THOSE COMMANDS' LOGIC WILL BE OK.) JRTR=PROW JRTC=PCOL IF(ICR.EQ.2)JRTC=1 IF(ICR.EQ.1)JRTR=1 C RELOC THESHOLD IS PHYSICAL CURRENT POSITION. IF(ICR.EQ.1)GOTO 8843 C INSERT OR DELETE COLUMNS C FIRST FIGURE OUT HOW MANY COLUMNS MUST BE MOVED RIGHT KD=RRW-PROW-IABS(ICNT)+1 IF(KD.LE.0)GOTO 9990 C CAN'T MOVE 0 COLUMNS. DOESN'T MAKE SENSE. DO 8842 KR=1,KD IRA=RRW-KR+1 C IRA IS DESTINATION COLUMN IN EACH LOOP. IF(ICNT.LT.0)IRA=PROW-1+KR C IRS IS SOURCE COLUMN IRS=RRW-KR+1-ICNT IF(ICNT.LT.0)IRS=PROW+KR-ICNT-1 C C IF DELETING COLUMNS AND DESTINATION IS PAST CURRENT C ACTIVE MAX, SKIP THE MOVE SINCE WE'RE NOT ACCOMPLISHING ANYTHING. IF(ICNT.LT.0.AND.IRA.GT.RRWACT)GOTO 8842 C IF ADDING COLUMNS AND SOURCE IS PAST CURRENT MAX ACTIVE THEN C WE'RE DOING NOTHING, SO SKIP THE WORK IF(ICNT.GT.0.AND.IRS.GT.RRWACT)GOTO 8842 JDELT=RCLACT C JDELT=RCL C LOOP WE'LL CALL IS OVER ENTIRE ROWS, BUT ONLY DO ONE AT A TIME HERE JD1A=IRA JD1B=1 ID1A=IRS ID2A=1 I1IN=0 I2IN=1 JIN1=0 JIN2=1 ASSIGN 8840 TO KPYBAK C CALL INTERNAL COPY-RANGE PROCEDURE INSIDE CA/CR LOGIC GOTO 8364 8840 CONTINUE 8842 CONTINUE C C NOW CLEAN UP THE REST OF FORMULAS IF THERE ARE ANY TO DO... C MUST RELOCATE OTHER FORMULAE IF CMDLIN(2) IS R KX=PROW-1 C RELY ON RCLACT HAVING BEEN UPDATED TO REFLECT NEW C ADDITIONS IF ANY KY=RCLACT C KY=RCL C RELOCATE UPPER LEFT PART OF SHEET C NOTE II1,II2,JJ1,JJ2,JRTR,JRTC ARE UNCHANGED FROM PRIOR CALL SO C MAY BE USED... RELVBL ONLY CARES ABOUT RELATIVE MOTION ANYHOW... 3600 CONTINUE IF(CMDLIN(2).NE.'R'.OR.KX.LE.0.OR.KY.LE.0)GOTO 9990 DO 3601 KK=1,KX DO 3601 KK2=1,KY CALL FVLDGT(KK,KK2,FVLD(1,1)) IF(FVLD(1,1).NE.1)GOTO 3601 C ONLY RELOCATE FORMULAS, NOT TEXT OR NUMBERS (OR EMPTIES...) C IRX=(KK2-1)*RRW+KK CALL REFLEC(KK2,KK,IRX) CALL WRKFIL(IRX,FORM,0) C READ(7'IRX)FORM CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC) CALL WRKFIL(IRX,FORM2,1) C WRITE(7'IRX)FORM2 3601 CONTINUE GOTO 9990 8843 CONTINUE C ROW INSERT/DELETE C AGAIN FIND HOW MANY ROWS TO MOVE. KD=RCL-PCOL-IABS(ICNT)+1 IF(KD.LE.0)GOTO 9990 DO 8839 KC=1,KD C ICA = DESTINATION AND ICS IS SOURCE ICA=RCL-KC+1 ICS=RCL-KC+1-ICNT IF(ICNT.GT.0)GOTO 8838 ICA=PCOL-1+KC ICS=PCOL+KC-1-ICNT 8838 CONTINUE C IF INSERTING ROWS AND SRC ROW IS BEYOND ACTIVE AREA, SKIP IF(ICNT.GT.0.AND.ICS.GT.RCLACT)GOTO 8839 C IF DELETING ROWS AND DST ROW IS BEYOND ACTIVE AREA, SKIP IF(ICNT.LT.0.AND.ICA.GT.RCLACT)GOTO 8839 C NOW CALL COPY LOOP AGAIN. JDELT=RRWACT C JDELT=RRW JD1A=1 JD1B=ICA C DEST ID1A=1 ID2A=ICS C SOURCE I1IN=1 I2IN=0 JIN1=1 JIN2=0 ASSIGN 8836 TO KPYBAK C CALL INTERNAL RANGE COPY PROCEDURE TO COPY A ROW GOTO 8364 8836 CONTINUE 8839 CONTINUE KX=RRWACT C KX=RRW KY=PCOL-1 GOTO 3600 8845 CONTINUE C OA AND OR COMMANDS. SET DISPLAY SHEET MAPPING TO ORIGIN AS FOUND BY C VARIABLE, STARTING AT 1,1 OR (DROW,DCOL) FOR OA AND OR RESPECTIVELY. IF(CMDLIN(1).NE.'O')GOTO 650 C PROCESS COMMAND... LRO=1 LCO=1 IF(CMDLIN(2).EQ.'R')LRO=MAX0(1,DROW) IF(CMDLIN(2).EQ.'R')LCO=MAX0(1,DCOL) LRO=MIN0(LRO,DRW-1) LCO=MIN0(LCO,DCL-1) C NOW HAVE CORRECT ORIGIN IN DISPLAY SHEET TO USE SET UP. C GRAB VARIABLE ID. LA=INDEX(CMDLIN,32) IF(LA.GT.20)LA=3 LE=40 CALL VARSCN(CMDLIN,LA,LE,LSTCX,ID1,ID2,IVLD) IF(IVLD.EQ.0)GOTO 651 C NOW HAVE VARIABLE NAME AND LOCATION... CAN DO IT FINALLY. C NOTE WE'RE GUARANTEED WE START OFF IN BOUNDS BUT MUST CHECK C ALONG THE WAY TO BE SURE WE STAY THAT WAY. KKKK=0 C ALLOW ORD OR OAD COMMANDS TO REPAINT WITH DISPLACEMENT C KEEPING "WINDOW" STRUCTURE INTACT BUT MOVING IT... IQQ=0 IF(CMDLIN(3).NE.'D')GOTO 6712 7112 CONTINUE KKKK=1 6712 CONTINUE KKKKK=NRDSP(LRO,LCO) KKKKKK=NCDSP(LRO,LCO) C IKR=DROW C IKC=DCOL C IF(IQQ.EQ.0.AND.CMDLIN(2).EQ.'R')GOTO 5711 CC OA GETS DIFFERENT LIMITS FROM OR C IKR=0 C IKC=1 5711 CONTINUE C IF(ID1.GT.(RRW-(DRWV-IKR)))ID1=RRW-DRWV+IKR C IF(ID2.GT.(RCL-DCLV+IKC))ID2=RCL-DCLV+IKC DO 652 IRO=LRO,DRWV DO 653 ICO=LCO,DCLV C HERE CAN SET UP NRDSP AND NCDSP SUITABLY C NRDSP(IRO,ICO)=MIN0(ID1+IRO-LRO,RRW) C NCDSP(IRO,ICO)=MIN0(ID2+ICO-LCO,RCL) IVV=IRO-LRO IVVV=ICO-LCO IF(KKKK.EQ.0)GOTO 1653 IVV=NRDSP(IRO,ICO)-KKKKK IVVV=NCDSP(IRO,ICO)-KKKKKK 1653 CONTINUE NRDSP(IRO,ICO)=ID1+IVV NCDSP(IRO,ICO)=ID2+IVVV 653 CONTINUE 652 CONTINUE IF(DROW.LE.0.OR.DCOL.LE.0)GOTO 3924 PROW=NRDSP(DROW,DCOL) PCOL=NCDSP(DROW,DCOL) 3924 CONTINUE C FORCE REDRAW OF WHOLE SHEET. C SKIP RECALC HOWEVER IF IN "OLD" NORMAL MODE ICODE=6 IF(RCMODE.LE.0)GOTO 9990 ICODE=2 651 GOTO 9990 650 CONTINUE C F FILENAME/NNN C READ IN TEXT FROM FILE NAMED AND SPREAD ACROSS DISPLAY SCREEN. SET C DISPLAYED SCREEN INTO FVLD(NN)=-1 TO SHOW TEXT ONLY. IF(CMDLIN(1).NE.'F')GOTO 1740 LA=INDEX(CMDLIN,32) C PASS SPACE LB=INDEX(CMDLIN(LA+1),'/') IF(LB.LT.2)GOTO 1741 LB=LB+LA C LB= LOC OF / CHARACTER OR END OF LINE LB=MIN0(80,LB) C JUST "F /" ISN'T GOOD ENOUGH IF(LB.LE.2)GOTO 1741 CMDLIN(LB)=0 IF(LB-LA.LE.1)GOTO 1741 C NO ATTEMPTED READ IF NO FILESPEC IS PRESENT CALL ASSIGN(4,CMDLIN(LA+1)) C THIS OUGHT TO OPEN THE FILE IF IT EXISTS.. C NOW IF THERE'S A NUMBER THERE, EXTRACT IT. LSKP=0 IF(LB.GT.78.OR.LB.LE.5)GOTO 1743 LAA=LB+1 LAAA=LB+7 CALL GN(LAA,LAAA,LSKP,CMDLIN) 1743 CONTINUE C NOW SKIP THE LINES IF(LSKP.LE.0)GOTO 1744 DO 1745 IV=1,LSKP READ(4,8201,END=1742,ERR=1742)FORM2 1745 CONTINUE 1744 CONTINUE C NOW WE'RE READY TO READ IN THE STUFF. ICODE=2 DO 1746 LA=1,DCLV DO 1751 IV=1,128 1751 FORM2(IV)=32 READ(4,8201,END=1742,ERR=1742)FORM2 IXC=0 DO 1747 LB=1,DRWV C DRWV = # ACROSS TOP... C DCLV=LENGTH ID1=NRDSP(LB,LA) ID2=NCDSP(LB,LA) C GET PHYSICAL SHEET COORDINATES AS ID1,ID2 C MUST THEN COPY CWIDS(LB) CHARS ONTO FILE... CALL FVLDST(ID1,ID2,-1) C FVLD(ID1,ID2)=-1 C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,FORM,0) C READ(7'IRX)FORM FORM(119)=-1 DO 1749 IVV=1,110 1749 FORM(IVV)=0 DO 1748 IVV=1,CWIDS(LB) IXC=IXC+1 1748 FORM(IVV)=FORM2(IXC) CALL WRKFIL(IRX,FORM,1) C WRITE(7'IRX)FORM 1747 CONTINUE 1746 CONTINUE 1742 CLOSE(UNIT=4) 1741 GOTO 9990 1740 CONTINUE IF(CMDLIN(1).NE.'E')GOTO 8000 C ENTER COMMAND C EN expression. expression may be numbers/text. LA=INDEX(CMDLIN,32) LA=LA+1 C SKIP SPACE AFTER "EN" IF(LA.GT.4)LA=4 IF (LA.GE.100)GOTO 7901 LE=132-LA LE=MIN0(110,LE) C IRX=(PCOL-1)*RRW+PROW CALL REFLEC(PCOL,PROW,IRX) C FIND WHERE IN FILE TO STORE. CALL WRKFIL(IRX,FORM,0) C READ(7'IRX)FORM IF(CMDLIN(2).EQ.'D') 1 CALL SED(CMDLIN(LA),FORM,FORM2,ARGSTR,ZAC,110) C IF COMMAND IS "ED STRING1STRING2" THEN C SUBSTITUTE STRING2 FOR STRING1 IN FORMULA, RETURN IT TO THE C COMMAND LINE, AND REENTER IT. C NOTE THAT THE STRINGS MAY CONTAIN &n FORMS WHERE 1-4 MEAN C ENTERED ARGUMENTS 1-4, 5 TREATS XAC AS A NUMBER, AND 6 C TREATS ZAC AS A SINGLE CHARACTER (ZAC IS VARIABLE Z). DO 5133 II=1,110 5133 FORM(II)=0 NALF=0 NSG=-1 NXNUM=3 KSG=0 N=1 IRCE1=PROW IRCE2=PCOL IF(CMDLIN(2).EQ.'"'.OR.CMDLIN(2).EQ.'T')KSG=1 IF(CMDLIN(2).EQ.'V')NSG=1 C "ET" MEANS ENTER TEXT C "EV" MEANS ENTER VALUE C REGARDLESS OF FORMULA CONTENTS... 2097 CONTINUE IF(N.GT.LE)GOTO 7902 C DO 7902 N=1,LE C LOOK FOR ALPHAS. IF WE FIND ANY, FLAG NOT NUMERIC C NOTE @ INCLUDED SINCE COULD HAVE A *@3 COMMAND TO CALL 3.CMD C AND REFER TO OTHER CELLS. C THIS IS A RESTRICTION: COMMANDS TO CMND NEED TO HAVE ALPHAS C SOMEWHERE OR THIS WILL BE FOOLED. IF(CMDLIN(LA).EQ.'P'.AND. 1 CMDLIN(LA+1).EQ.'#'.AND. 2 CMDLIN(LA+2).EQ.'0'.AND. 3 CMDLIN(LA+3).EQ.'#'.AND. 4 CMDLIN(LA+4).EQ.'0') GOTO 3356 IF(CMDLIN(LA).GE.'@'.AND.CMDLIN(LA).LE.'Z')NXNUM=1 3356 CONTINUE C IF(CMDLIN(LA).GE.'@'.AND.CMDLIN(LA).LE.'Z')NXNUM=1 IF(CMDLIN(LA).EQ.'+'.OR.CMDLIN(LA).EQ.'-')NSG=1 IF(CMDLIN(LA).EQ.'['.OR.CMDLIN(LA).EQ.'.')NSG=1 IF(CMDLIN(LA).EQ.'(')NSG=1 IF(CMDLIN(LA).EQ.'"')KSG=1 C ON SEEING THE _@V1,V2 CONSTRUCT, REPLACE WITH THE VARIABLE C ADDRESSED BY V1,V2 (COL,ROW) BY NAME. C ON SEEING THE _#V1 CONSTRUCT, UNPACK UP TO 8 CHARS OUT OF C REAL*8 VARIABLE (PACKED BY MULTIPLYING BY 128 EARLIER). C IN EACH CASE, ADJUSTN AND LE TO CONTINUE APPROPRIATELY. IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'@')CALL 1 SVBL(CMDLIN,LA,N,LE,FORM) IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'#')CALL 1 SSTR(CMDLIN,LA,N,LE,FORM) FORM(N)=CMDLIN(LA) IF(CMDLIN(LA).GT.32)NALF=NALF+1 LA=LA+1 C FAKE OUT DO LOOP SINCE SVBL OR SSTR MAY MUNG INDICES INSIDE IT N=N+1 GOTO 2097 7902 CONTINUE IF(KSG.NE.0)NSG=-1 FORM(110)=0 IF(FORM(119).NE.0)GOTO 7903 C LEAVE DISPLAY INDICATOR ALONE IF SET BUT SET VBL OTHERWISE. FORM(119)=NSG*NXNUM C SET NEG FOR DISPLAY OF FORMULA, NOT NUMBER. ALLOWS TEXT ENTRY. C ASSUME FORMULA IF WE SEE + OR - 7903 CONTINUE C FORCE FORM TO FOLLOW EDITS EVEN IF FORMAT/TYPE PRESET. IVVVV=FORM(119) IF(IVVVV.NE.0)FORM(119)=ISGN(IVVVV)*NXNUM IF(NALF.LE.0)GOTO 6221 CALL FVLDST(PROW,PCOL,FORM(119)) CALL WRKFIL(IRX,FORM,1) 6221 CONTINUE ASSIGN 7904 TO NBK GOTO 7905 C LOOK UP PROW, PCOL, LEAVE DISPLAY COORDS IN LR,LC 7905 CONTINUE DO 7906 LA1=1,DRWV LR=LA1 DO 7906 LA2=1,DCLV LC=LA2 IF(NRDSP(LA1,LA2).EQ.PROW.AND.NCDSP(LA1,LA2).EQ.PCOL)GOTO7907 7906 CONTINUE C IF WE FALL OUT OF THE LOOP, WE DIDN'T FIND THE LOC; FLAG BY PUTTING 0'S. LR=0 LC=0 GOTO 7908 7907 CONTINUE C ARRIVE HERE ON SUCCESS. LR, LC ALL SET UP. 7908 CONTINUE GOTO NBK 7904 CONTINUE IF(LR.EQ.0.OR.LC.EQ.0)GOTO 7901 THISRW=LR THISCL=LC C ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL. LRO=1 LCO=1 ID1=NRDSP(1,1) ID2=NCDSP(1,1) IF(.NOT.(JMVFG.EQ.51.AND.THISRW.EQ.1))GOTO 7110 IF(IDOL7.EQ.0)GOTO 7110 C MUST SCROLL LEFT C INHIBIT REDRAW AT ORIGIN... IF(ID1.LE.1)GOTO 7110 C LEAVE 2 COLUMNS AS BEFORE ID1=MAX0(1,ID1-DRWV+2) DROW=MAX0(DRWV-2,1) IQQ=1 GOTO 7112 7110 CONTINUE IF(JMVFG.EQ.51)THISRW=MAX0(1,(THISRW-1)) IF(.NOT.(JMVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 7116 C MUST SCROLL RIGHT IF(IDOL7.EQ.0)GOTO 7116 DROW=3 C ID1=MIN0(RRW,ID1+DRWV-MIN0(DRWV,2)) ID1=ID1+DRWV-MIN0(DRWV,2) IQQ=1 GOTO 7112 C 7112 FAKES OUT OA CALL TO SCROLL OVER. 7116 CONTINUE IF(JMVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV) IF(.NOT.(JMVFG.EQ.49.AND.THISCL.EQ.1))GOTO 7117 C MUST SCROLL UP IF(IDOL7.EQ.0)GOTO 7117 IF(ID2.LE.2)GOTO 7117 DCOL=MAX0(1,DCLV-2) ID2=MAX0(2,ID2-DCLV+2) IQQ=1 GOTO 7112 7117 CONTINUE IF(JMVFG.EQ.49)THISCL=MAX0(1,(THISCL-1)) IF(.NOT.(JMVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 7118 C MUST SCROLL DOWN IF(IDOL7.EQ.0)GOTO 7118 DCOL=3 C ID2=MIN0(RCL,ID2+DCLV-MIN0(DCLV,2)) ID2=ID2+DCLV-MIN0(DCLV,2) IQQ=1 GOTO 7112 7118 CONTINUE IF(JMVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV) DROW=THISRW DCOL=THISCL PROW=NRDSP(DROW,DCOL) PCOL=NCDSP(DROW,DCOL) C FORCE REDO OF BOTH LAST AND NEW COLUMN BY DISPLAYER. DVS(LR,LC)=DVS(LR,LC)+.0000000057 DVS(DROW,DCOL)=DVS(DROW,DCOL)+.000000062 7901 GOTO 9990 8000 IF(CMDLIN(1).NE.'M')GOTO 8001 ICODE=1 C MACROCELL COMMAND IF MH (HIDE) OR MS (SHOW) IF(CMDLIN(2).EQ.'S')IDOL4=1 IF(CMDLIN(2).EQ.'H')IDOL4=0 IF(CMDLIN(2).EQ.'S'.OR.CMDLIN(2).EQ.'H')GOTO 9990 C MOVE COMMAND C M1,M2,M3,M4 MOTION DIRECTION IS U,D,L,R C ALLOW M0 TO RESTORE OLD AUTOMOVE CONDITION, ALL OTHERS TO SAVE IT IVVV=CMDLIN(2) IF(CMDLIN(2).EQ.'0')IVVV=JMVOLD JMVOLD=JMVFG JMVFG=IVVV C JMVFG=CMDLIN(2) C STORE CHARACTER AS MOVE FLAG GOTO 9990 8001 IF(CMDLIN(1).NE.'D')GOTO 8002 C DISPLAY COMMANDS C C DISPLAY SORT C DSRA 1 C DS = CONSTANT KEYWORD C R/C=ROW/COL (DISPLAY COORD #S) C A/D=ASCENDING/DESCENDING ORDER C NUMBER= DISPLAY COORD ROW/COL # TO SORT ON. C SORTS NUMERIC FIELDS ONLY. IF(CMDLIN(2).NE.'S')GOTO 1752 ICODE=2 C MUST REDRAW. WE DO WHOLESALE RELOCATIONS OF THINGS HERE. C FIRST GET ARGUMENTS LAA=6 LBB=15 CALL GN(LAA,LBB,NBR,CMDLIN) C THIS EXTRACTS THE NUMBER OF ROW/COL TO USE. C DEFAULT IS PHYS, COL, ASCENDING IF(NBR.LE.0.OR.NBR.GT.MAX0(DRW,DCL))GOTO 9990 SSIGN=1. IF(CMDLIN(4).EQ.'D')SSIGN=-1. C SSIGN USED TO CONTROL ASCENDING/DESCENDING SORT (MULTIPLY BY IT) C GET LENGTH TO GO THRU IN SORT IF(CMDLIN(3).EQ.'C')IDELTA=DCLV-1 IF(CMDLIN(3).EQ.'R')IDELTA=DRWV-1 I1IN=0 I2IN=1 C GET PHYSICAL COORDINATES OF ROW/COL WE'RE SORTING ON. IF(CMDLIN(3).EQ.'R')GOTO 6222 ID1=NRDSP(NBR,1) ID2=NCDSP(NBR,1) GOTO 1753 6222 CONTINUE ID1=NRDSP(1,NBR) ID2=NCDSP(1,NBR) I1IN=1 I2IN=0 C HACK TO HANDLE ROW/COL ALIKE 1753 CONTINUE IFLIP=0 C IFLIP = BUBBLESORT FLAG WE CHANGED SOMETHING C (USE SIMPLE MINDED SMALL SORT. TOO MUCH OVHD FOR BETTER ONE...NO ROOM) ID1A=ID1 ID2A=ID2 C IGNORE CASE OF IDELTA=0... SHOULDN'T BE ANY WAY FOR THAT TO HAPPEN DO 1754 IV=1,IDELTA C SORT HERE. IFLIP=1 IF WE INVERT ANYTHING. C JUST COMPARE XVBLS... C NOTE WE ASSUME A "NORMAL" TYPE DISPLAY, JUST RESET PHYSICAL STUFF. CALL XVBLGT(ID1A,ID2A,XAC) CALL XVBLGT(ID1A+I1IN,ID2A+I2IN,XVBLS(1,1)) IF(XAC*SSIGN.LE.XVBLS(1,1)*SSIGN)GOTO 1755 C IF((XVBLS(ID1A,ID2A)*SSIGN).LE.(SSIGN*XVBLS(ID1A+I1IN, C 1 ID2A+I2IN)))GOTO 1755 C FLIP ASSIGNMENTS C FLIP XVBLS NUMBERS TOO TO MAINTAIN SORT. WE RECOMPUTE ANYWAY.. C XAC=XVBLS(ID1A+I1IN,ID2A+I2IN) C XVBLS(ID1A+I1IN,ID2A+I2IN)=XVBLS(ID1A,ID2A) C XVBLS(ID1A,ID2A)=XAC CALL XVBLST(ID1A+I1IN,ID2A+I2IN,XAC) CALL XVBLST(ID1A,ID2A,XVBLS(1,1)) IFLIP=1 C SWAP ASSIGNMENTS OF DISPLAY STUFF IF IN RANGE C OPERATES LIKE A SORTED OA COMMAND C CURRENT PHYSICAL ROW IS ID2A (1...RCL LIMITS) C AND PHYS COL IS ID1A. LDELTA=DRW-1 C FOR REASSIGNMENT, ROLE OF I1IN,I2IN CAN BE REVERSED... ID1B=1 C NOTE DISPLAY ID2 IS 1 LESS THAN PHYSICAL ONE. (AC'S) ID2B=ID2A-1 IF(ID2B.LE.0)GOTO 1754 IF(CMDLIN(3).NE.'R')GOTO 1756 C ROW... LDELTA=DCL-1 C ID1 SAME AS DISPLAY COORDS ID1B=ID1A ID2B=1 1756 CONTINUE DO 1757 IVV=1,LDELTA C FLIP THE ROW/COL 1 ENTRY AT A TIME. JUST CHANGES ASSIGNMENTS. JD1=NRDSP(ID1B,ID2B) JD2=NCDSP(ID1B,ID2B) NRDSP(ID1B,ID2B)=NRDSP(ID1B+I1IN,ID2B+I2IN) NCDSP(ID1B,ID2B)=NCDSP(ID1B+I1IN,ID2B+I2IN) NRDSP(ID1B+I1IN,ID2B+I2IN)=JD1 NCDSP(ID1B+I1IN,ID2B+I2IN)=JD2 ID1B=ID1B+I2IN ID2B=ID2B+I1IN 1757 CONTINUE C WE CAN ALWAYS FLIP SINCE WE STAY ON DISPLAY SHEET. 1755 CONTINUE ID1A=ID1A+I1IN ID2A=ID2A+I2IN 1754 CONTINUE C DONE 1 PASS. IF ANYTHING CHANGED, TRY AGAIN. IF(IFLIP.NE.0)GOTO 1753 C DONE SORT AT END GOTO 9990 1752 CONTINUE C IF(CMDLIN(2).NE.'L')GOTO 8101 C DL = DISPLAY LOCATE V1:V2 N:M ASSIGN 8103 TO IBACK GOTO 8104 C STRIP VARIABLE NAMES OFF CMD LINE STARTING AT POSITION 3 8104 LA=3 LE=98 L1=0 CALL VARSCN(CMDLIN(1),LA,LE,LSTC,ID1A,ID2A,IVLD) L2=0 C L1,L2 = FLAGS VARIABLE 1,2 FOUND VALIDLY LA=LSTC+1 LE=100-LA IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8102 L1=1 IF(CMDLIN(LSTC).NE.':')GOTO 8102 C MUST SEE : BETWEEN NAMES. NO SPACES PERMITTED. CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1B,ID2B,IVLD) IF(IVLD.LE.0)GOTO 8102 L2=1 8102 CONTINUE C NOTE THAT LSTC RETURNS AS CHARACTER AFTER VARIABLE LAST GRABBED IN INPUT LINE. GOTO IBACK C NOW PICK UP RN:M OR CN:M (R=ROW,C=COL) 8103 CONTINUE IF(L1.LT.1)GOTO 8101 C INVALID UNLESS AT LEAST 1 VBL NAME SEEN. LA=LSTC+2 RCF=0 IF(CMDLIN(LSTC+1).EQ.'R')RCF=2 IF(CMDLIN(LSTC+1).EQ.'C')RCF=1 IF(RCF.EQ.0)GOTO 8101 KM1=1 CALL GN(KM1,LE,NUM1,CMDLIN(LA)) IF(NUM1.EQ.0)GOTO 8101 LE=INDEX(CMDLIN(LA),':') NUM2=0 IF(LE.GT.100)GOTO 8101 LA=LA+LE KM1=1 KM8=8 CALL GN(KM1,KM8,NUM2,CMDLIN(LA)) C NOW NUM1,NUM2 ARE DESIRED ROW/COL RANGE. NOW SET UP DISPLAY. IF(NUM2.EQ.0.OR.NUM2.GT.DCL)GOTO 8101 IF(NUM1.GT.DRW)GOTO 8101 C ILLEGAL ROW/COL IS A NO-GO. C R N:M MEANS STARTING AT COL N ROW M GOING L TO R. C C N:M MEANS DOWN STARTING THERE. DISPLAY COORDS ASSUMED. IF(ID1A.NE.ID1B.AND.ID2A.NE.ID2B)GOTO 8101 C ONLY HANDLE ROWS OR COLS, NOT DIAGONALS. C MUST BE A PHYS MTX ROW OR COL. LRINC=0 LCINC=0 IF(RCF.EQ.1)LRINC=1 IF(RCF.EQ.2)LCINC=1 ASSIGN 8108 TO JBACK GOTO 8109 C COPY DATA 8109 CONTINUE ICODE=6 IDELT=1 IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B))+1 I1IN=0 I2IN=1 IF(ID1A.EQ.ID1B)GOTO 8106 I1IN=1 I2IN=0 8106 CONTINUE ID1=ID1A ID2=ID2A GOTO JBACK 8108 CONTINUE ICODE=1 IR=NUM1 IC=NUM2 DO 8105 NM=1,IDELT C CLAMP TO MAX DISPLAY ARRAY IF(IR.GT.DRW.OR.IC.GT.DCL)GOTO 8105 NRDSP(IR,IC)=ID1 NCDSP(IR,IC)=ID2 DVS(IR,IC)=DVS(IR,IC)-1.E-11 C THISRW=IR C THISCL=IC C JRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,JRX) CALL WRKFIL(JRX,FORM2,0) C READ(7'JRX)FORM2 C DO 7104 N7=1,9 C7104 DFMTS(N7,IR,IC)=FORM2(N7+119) C DFMTS(10,IR,IC)=0 IR=IR+LCINC IC=IC+LRINC C NOTE REVERSAL FOR DISPLAY. ID1=ID1+I1IN ID2=ID2+I2IN 8105 CONTINUE 8101 CONTINUE IF(CMDLIN(2).NE.'F')GOTO 8111 C DF STUFF - SET FORMAT. ASSIGN 8112 TO IBACK GOTO 8104 8112 CONTINUE C NOW HAVE VARIABLE ID'S SET UP IF(L1.LE.0)GOTO 8120 C MUST HAVE 1 OR MORE... ASSIGN 8113 TO JBACK GOTO 8109 C IDELT NOW SET UP. SET FORMATS UP NOW. C FORMATS ARE IN [] BRACKETS. FIND THESE AND USE. 8113 CONTINUE ICODE=1 LA=INDEX(CMDLIN,'[')+1 LB=INDEX(CMDLIN,']')-1 LDELT=LB-LA+1 LDELT=MIN0(LDELT,9) DO 8114 LN=1,IDELT C IDELT IS OVER VRBL LIST GIVEN. MAY BE 1 ONLY. C IRRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRRX) CALL WRKFIL(IRRX,FORM,0) C KEEP EXISTING FORMAT IF [*] IS USED IF(CMDLIN(LA).EQ.'*')GOTO 7115 IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')GOTO 7115 C READ(7'IRRX)FORM DO 7989 KKKK=1,9 7989 FORM(119+KKKK)=0 DO 8115 LNA=1,LDELT FORM(LNA+119)=CMDLIN(LA-1+LNA) IF(LNA.LT.9)FORM(LNA+120)=0 8115 CONTINUE 7115 CONTINUE C FORM(128)=0 CALL FVLDGT(ID1,ID2,FVWRK) IVVVV=FVWRK IF(IVVVV.EQ.0)IVVVV=3 C SET UP DEFAULT AS NUMERIC. C IVVVV=FVLD(ID1,ID2) C FVLD(ID1,ID2)=MAX0(1,IABS(IVVVV)) IVVVV=MAX0(1,IABS(IVVVV)) IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')IVVVV= 1 MIN0(-1,-IABS(IVVVV)) CALL FVLDST(ID1,ID2,IVVVV) IF(CMDLIN(LA).EQ.'I')CALL TYPSET(ID1,ID2,4) IF(CMDLIN(LA).EQ.'F'.OR.CMDLIN(LA).EQ.'E') 1 CALL TYPSET(ID1,ID2,2) FORM(119)=IVVVV C C TO BE SURE WE DON'T FOUL UP THE FILE, TRY AN ENCODE ON THIS FORMAT C PRIOR TO THE WRITE. THAT WAY IF WE BOMB, THE FILE WE HAVE DIRECT ACCESS C DATA ON IS NOT CLOBBERED. IF(IVVVV.LE.0)GOTO 7990 DO 7988 KKK=1,9 KKKK=FORM(119+KKK) 7988 DFE(KKK+1)=MAX0(32,KKKK) DFE(1)='(' DFE(12)=')' CALL TYPGET(N1,N2,TYPE(1,1)) CALL FVLDGT(N1,N2,FVLD(1,1)) IF(FVLD(1,1).LE.0)GOTO 7990 IF(TYPE(1,1).NE.2)GOTO 6224 ENCODE(100,DFE,FORM2,ERR=4302)DVS(THISRW,THISCL) GOTO 7990 6224 CONTINUE ENCODE(100,DFE,FORM2,ERR=4302)LDVS(1,THISRW,THISCL) 7990 CONTINUE CALL WRKFIL(IRRX,FORM,1) C WRITE(7'IRRX)FORM DO 8116 NX1=1,DRW DO 8116 NX2=1,DCL C LOCATE DISPLAY CELL IF ANY IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8117 8116 CONTINUE GOTO 8118 8117 CONTINUE DVS(NX1,NX2)=DVS(NX1,NX2)-1.23E-12 8118 CONTINUE ID1=ID1+I1IN ID2=ID2+I2IN 8114 CONTINUE 8111 CONTINUE IF(CMDLIN(2).NE.'T')GOTO 8120 C DT DISPLAY TYPE ASSIGN 8121 TO IBACK GOTO 8104 C GET VBL NAMES 8121 ASSIGN 8122 TO JBACK GOTO 8109 8122 LA=LSTC+1 IF(L1.LE.0)GOTO 8120 KTYP=2 IF(CMDLIN(LA).EQ.'I')KTYP=4 ICODE=1 DO 8123 LNA=1,IDELT CALL TYPSET(ID1,ID2,KTYP) C TYPE(ID1,ID2)=KTYP DO 8126 NX1=1,DRWV DO 8126 NX2=1,DCLV IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8127 C FIND DISPLAY LOC IF ANY AND SET IT UP FOR REDRAW 8126 CONTINUE GOTO 8128 8127 CONTINUE DVS(NX1,NX2)=DVS(NX1,NX2)-1.211E-12 8128 CONTINUE ID1=ID1+I1IN ID2=ID2+I2IN 8123 CONTINUE 8120 CONTINUE IF(CMDLIN(2).NE.'W')GOTO 8130 C DW SETS COL WIDTH ASSIGN 8131 TO KBACK GOTO 8132 C GET 2 NUMBERS STARTING AT CMDLIN(4) 8132 CONTINUE KM1=1 KM6=6 CALL GN(KM1,KM6,NCL,CMDLIN(4)) LA=INDEX(CMDLIN(4),',') C COMMA MUST BE SEPARATOR LCWID=7 IF(LA.GT.100)GOTO 8138 KM1=1 CALL GN(KM1,KM6,LCWID,CMDLIN(LA+4)) 8138 GOTO KBACK 8131 CONTINUE ICODE=6 IF(RCMODE.GT.0)ICODE=2 NCL=MAX0(1,NCL) NCL=MIN0(NCL,DRW) LCWID=MAX0(1,LCWID) LCWID=MIN0(LCWID,110) C COL WIDTH IS 3 TO 110 CHARS. IF(NCL.GT.0)CWIDS(NCL)=LCWID 8133 CONTINUE 8130 CONTINUE IF(CMDLIN(2).NE.'B')GOTO 8140 C DB = BOUNDS ON ROW,COL ASSIGN 8141 TO KBACK GOTO 8132 C PARASITE OTHER CODE TO GET DIGITS 8141 MC=NCL MR=LCWID MC=MIN0(MC,DRW) MR=MIN0(MR,DCL) C CLAMP RANGE TO LEGAL IF(MC.GT.0)DRWV=MC IF(MR.GT.0)DCLV=MR ICODE=6 IF(RCMODE.GT.0)ICODE=2 C REDRAW SCREEN WHEN BOUNDS CHANGE. 8140 CONTINUE GOTO 9990 8002 IF(CMDLIN(1).NE.'V')GOTO 8003 C VIEW REDRAW COMMAND PZAP=0 FORMFG=0 IF(CMDLIN(2).EQ.'H') GOTO 8206 IF(CMDLIN(2).EQ.'F')FORMFG=1 IF(CMDLIN(2).EQ.'M')PZAP=1 8207 CONTINUE ICODE=6 IF(RCMODE.GT.0)ICODE=2 GOTO 9990 8206 CONTINUE C TREAT VH+ AND VH- AS CONTROLS TO TURN VIEW HACK ON AND OFF C VIEW HACK (IF ON) DISPLAYS ROW NUMBER ON SCREEN DYNAMICALLY C DURING RECALCULATIONS. (GIVES VISUAL INDICATION SOMETHING'S C HAPPENING.) IF(CMDLIN(3).EQ.'+')IVWHK=1 IF(CMDLIN(3).EQ.'-')IVWHK=0 C DON'T REDRAW SCREEN JUST TO SET THESE FLAGS. ICODE=2 IF(CMDLIN(3).EQ.'+'.OR.CMDLIN(3).EQ.'-')GOTO 9990 C IF NOT A VALID VH[+/-] COMMAND, TREAT AS JUST V GOTO 8207 C 8003 IF(CMDLIN(1).NE.'C'.AND.CMDLIN(1).NE.'I')GOTO 8004 C COPY NUMBERS COMMAND C COPY (NUMBERS,FORMAT,DISPLAY,ALL) C CV=COPY VALUE, CD=COPY DISPLAY FMT, CF=COPY FORMULA, CA=COPY ALL C Ca V1:V2 V3:V4 COPIES FIRST RANGE TO SECOND. C IR RANGES DOES INPLACE RELOCATION... C C COLLECT ARGS ASSIGN 8301 TO IBACK GOTO 8104 8301 CONTINUE C NOW L1,L2 SAY IF VBLS(ID1A,ID2A) AND (ID1B,ID2B) EXIST C COLLECT JD2A,JD2B. USE SIMILAR INTERNAL PROCEDURE CODE. IF(L1.LE.0)GOTO 8399 ASSIGN 8302 TO MBACK GOTO 8303 8303 CONTINUE C COLLECT 2 VARS STARTING AT LSTC+3 C SKIPS LSTC DELIMITER. LJ1=0 LJ2=0 LA=LSTC+1 LE=110-LA IF(LE.LE.0)GOTO 8304 CALL VARSCN(CMDLIN,LA,LE,LSTC,JD1A,JD1B,IVLD) LA=LSTC+1 LE=110-LA IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8304 LJ1=1 IF(CMDLIN(LSTC).NE.':')GOTO 8304 CALL VARSCN(CMDLIN,LA,LE,LSTC,JD2A,JD2B,IVLD) IF(IVLD.LE.0)GOTO 8304 LJ2=1 8304 GOTO MBACK 8302 CONTINUE IF(LJ1.LE.0)GOTO 8399 IDELT=1 IF(L2.NE.0.AND.(ID1A.NE.ID1B.AND.ID2A.NE.ID2B))GOTO 8305 IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B))+1 8305 CONTINUE JDELT=1 IF(LJ2.EQ.0)GOTO 8306 IF(JD1A.NE.JD2A.AND.JD1B.NE.JD2B)GOTO 8306 JDELT=MAX0(IABS(JD1A-JD2A),IABS(JD1B-JD2B))+1 8306 IF(L2.NE.0)JDELT=MIN0(IDELT,JDELT) C CHANGE FOR REPLICATE : JDELT CAN BE JUST JDELT IF L2=0 ASSIGN 8307 TO JBACK C 8109 IS WHERE WE SET UP I1IN AND I2IN ASSUMING THAT THE VARIABLES C ARE SET PROPERLY. HANDLED AS AN INTERNAL PROCEDURE. GOTO 8109 8307 CONTINUE JIN1=1 JIN2=0 IF(JD1B.EQ.JD2B)GOTO 8308 JIN1=0 JIN2=1 8308 CONTINUE C CHANGE FOR REPLICATE: IF L2 IS 0 (NO 2ND SRC VARIABLE), NO BUMPS C PAST THE SINGLE VARIABLE SPECIFIED. IF(L2.EQ.0)I1IN=0 IF(L2.EQ.0)I2IN=0 C FOR PCC-PC DO RECALC ALWAYS TO ALLOW DISPLAY TO LOOK OK ICODE=3 C ICODE=1 C FORCE RECALC IF ONLY 1 SOURCE VARIABLE. C IF(L2.EQ.0)ICODE=3 JRTR=PROW JRTC=PCOL C JRTR AND JRTC = RELOCATION THRESHOLDS C CELLS ABOVE OR LEFT OF JRTR,JRTC WILL NOT BE RELOCATED IN A CR C OPERATION. THIS WILL GENERALLY BE THE PHYSICAL COLUMN OR ROW C OF THE CURRENT POSITION. CELLS LOWER OR EQUAL, OR TO THE RIGHT C OF THE CURRENT LOCATION OR EQUAL, WILL BE RELOCATED. (VARIABLE C NAMES GET EDITED) ASSIGN 8365 TO KPYBAK GOTO 8364 C 8364 BEGINS COPY PROCEDURE SECTION C GOES FOR JDELT CELLS WITH I1IN AND I2IN BEING SOURCE INCREMENTS FOR C RRW DIMENSION, RCL DIMENSION, AND JIN1,2 BEING INCREMENTS FOR C DESTINATION RRW,RCL DIMENSIONS RESPECTIVELY. USES CMDLIN(2) TO C FLAG WHETHER TO HANDLE ALL, JUST FORMAT, RELOCATE, ETC. C ALSO ID1A,ID2A ARE START SOURCE LOCATION C JD1A,JD1B = DEST START LOCATION. C C COPIES 1 ROW OR COLUMN AT A TIME. 8364 CONTINUE C ICODE=1 C SET DISPLAY UPDATE ON COPIED CELLS CCD DO 3620 JV=1,BRRCL CCD3620 IBITMP(JV)=0 DO 8309 JV=1,JDELT DO 8380 NX1=1,DRWV DO 8380 NX2=1,DCLV C LOCATE DISPLAY CELL IF ANY IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8387 8380 CONTINUE GOTO 8388 8387 CONTINUE DVS(NX1,NX2)=DVS(NX1,NX2)+1.245E-14 8388 CONTINUE C JRXX=(JD1B-1)*RRW+JD1A C IRXX=(ID2A-1)*RRW+ID1A CALL REFLEC(JD1B,JD1A,JRXX) CALL REFLEC(ID2A,ID1A,IRXX) CALL FVLDGT(ID1A,ID2A,FVLD(1,1)) KKKKK=FVLD(1,1) CALL FVLDGT(JD1A,JD1B,FVLD(1,1)) IF(KKKKK.EQ.0.AND.FVLD(1,1).EQ.0)GOTO 8314 C IF(FVLD(ID1A,ID2A).EQ.0.AND.FVLD(JD1A,JD1B).EQ.0)GOTO 8314 C READ(7'IRXX)FORM C READ(7'JRXX)FORM2 CALL WRKFIL(IRXX,FORM,0) CALL WRKFIL(JRXX,FORM2,0) IF(KKKKK.EQ.-2)CALL FVLDST(ID1A,ID2A,-3) IF(KKKKK.EQ.2)CALL FVLDST(ID1A,ID2A,3) IF(FORM (119).EQ. 2)FORM (119)=3 IF(FORM (119).EQ.-2)FORM (119)=-3 IF(FORM2(119).EQ. 2)FORM2(119)=3 IF(FORM2(119).EQ.-2)FORM2(119)=-3 IF(CMDLIN(2).NE.'R'.AND.CMDLIN(2).NE.'A')GOTO 8310 IF(CMDLIN(2).NE.'R')GOTO 8366 C RELOCATE, THEN WRITE NEW CELL II1=ID1A II2=ID2A JJ1=JD1A JJ2=JD1B CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC) C THE ABOVE WILL RELOCATE FORM INTO FORM2 WHICH WE NOW EMIT. C ALLOW IR COMMAND TO DO INPLACE RELOCATION. IF(CMDLIN(1).NE.'I')GOTO 6225 CALL WRKFIL(IRXX,FORM2,1) GOTO 9222 6225 CONTINUE CALL WRKFIL(JRXX,FORM2,1) C WRITE(7'JRXX)FORM2 GOTO 8367 8366 CONTINUE CALL WRKFIL(JRXX,FORM,1) C WRITE(7'JRXX)FORM 8367 CONTINUE CALL TYPGET(ID1A,ID2A,TYPE(1,1)) CALL TYPSET(JD1A,JD1B,TYPE(1,1)) C TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A) CALL XVBLGT(ID1A,ID2A,XVBLS(1,1)) CALL XVBLST(JD1A,JD1B,XVBLS(1,1)) C XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A) CALL FVLDGT(ID1A,ID2A,FVLD(1,1)) CALL FVLDST(JD1A,JD1B,FVLD(1,1)) C FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A) 9222 ID1A=ID1A+I1IN ID2A=ID2A+I2IN JD1A=JD1A+JIN1 JD1B=JD1B+JIN2 GOTO 8309 8310 CONTINUE IF(CMDLIN(2).NE.'V')GOTO 8312 CALL TYPGET(ID1A,ID2A,TYPE(1,1)) CALL TYPSET(JD1A,JD1B,TYPE(1,1)) C TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A) CALL XVBLGT(ID1A,ID2A,XVBLS(1,1)) CALL XVBLST(JD1A,JD1B,XVBLS(1,1)) C XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A) 8312 IF(CMDLIN(2).NE.'D')GOTO 8313 CALL FVLDGT(ID1A,ID2A,FVLD(1,1)) CALL FVLDST(JD1A,JD1B,FVLD(1,1)) C FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A) DO 8315 LXQ=1,10 8315 FORM2(118+LXQ)=FORM(118+LXQ) CALL WRKFIL(JRXX,FORM2,1) C WRITE(7'JRXX)FORM2 8313 IF(CMDLIN(2).NE.'F')GOTO 8314 DO 8316 LXQ=1,110 8316 FORM2(LXQ)=FORM(LXQ) CALL WRKFIL(JRXX,FORM2,1) C WRITE(7'JRXX)FORM2 8314 CONTINUE ID1A=ID1A+I1IN ID2A=ID2A+I2IN JD1A=JD1A+JIN1 JD1B=JD1B+JIN2 8309 CONTINUE C RETURN POINT FROM COPY LOOP IN NORMAL COPY GOTO KPYBAK 8365 CONTINUE 8399 GOTO 9990 8004 IF(CMDLIN(1).LT.'1'.OR.CMDLIN(1).GT.'4')GOTO 8005 C 1,2,3,4 POSITIONING COMMANDS ICODE=5 C IF(CMDLIN(1).EQ.'3')THISRW=MAX0(1,(THISRW-1)) C IF(CMDLIN(1).EQ.'4')THISRW=MIN0((THISRW+1),DRWV) C IF(CMDLIN(1).EQ.'1')THISCL=MAX0(1,(THISCL-1)) C IF(CMDLIN(1).EQ.'2')THISCL=MIN0((THISCL+1),DCLV) C ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL. MVFG=CMDLIN(1) LRO=1 LCO=1 ID1=NRDSP(1,1) ID2=NCDSP(1,1) IF(.NOT.(MVFG.EQ.51.AND.THISRW.EQ.1))GOTO 2110 C MUST SCROLL LEFT IF(IDOL7.EQ.0)GOTO 2110 IF(ID1.LE.1)GOTO 2110 ID1=MAX0(1,ID1-DRWV+2) DROW=MAX0(1,DRWV-2) IQQ=1 GOTO 7112 2110 IF(MVFG.EQ.51)THISRW=MAX0(1,(THISRW-1)) IF(.NOT.(MVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 2116 C MUST SCROLL RIGHT IF(IDOL7.EQ.0)GOTO 2116 DROW=3 C ID1=MIN0(RRW,ID1+DRWV-MIN0(DRWV,2)) ID1=ID1+DRWV-MIN0(DRWV,2) IQQ=1 GOTO 7112 C 7112 FAKES OUT OA CALL TO SCROLL OVER. 2116 IF(MVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV) IF(.NOT.(MVFG.EQ.49.AND.THISCL.EQ.1))GOTO 2117 C MUST SCROLL UP IF(IDOL7.EQ.0)GOTO 2117 IF(ID2.LE.2)GOTO 2117 DCOL=MAX0(1,DCLV-2) ID2=MAX0(2,ID2-DCLV+2) IQQ=1 GOTO 7112 2117 IF(MVFG.EQ.49)THISCL=MAX0(1,(THISCL-1)) IF(.NOT.(MVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 2118 C MUST SCROLL DOWN IF(IDOL7.EQ.0)GOTO 2118 DCOL=3 C ID2=MIN0(RCL,ID2+DCLV-MIN0(DCLV,2)) ID2=ID2+DCLV-MIN0(DCLV,2) IQQ=1 GOTO 7112 2118 IF(MVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV) PROW=NRDSP(THISRW,THISCL) PCOL=NCDSP(THISRW,THISCL) DROW=THISRW DCOL=THISCL GOTO 9990 8005 CONTINUE 8007 IF(CMDLIN(1).NE.'R')GOTO 8008 IF(CMDLIN(2).NE.'B')GOTO 7333 C RB VAR SETS RELOCATE BOUNDARY TO VAR COORDS IF(CMDLIN(3).EQ.'*')GOTO 7332 C NORMAL RB COMMAND C RB VAR USES VAR NAME TO RESET BDY LO=3 KKKK=20 CALL VARSCN(CMDLIN,LO,KKKK,IV,ID1,ID2,IVALID) IF(IVALID.LE.0)GOTO 9990 C IGNORE ERRORS IDOL5=ID1 IDOL6=ID2 GOTO 9990 7332 IDOL5=32000 IDOL6=32000 C RB* RESETS RELOCATE BDY TO END OF SHEET GOTO 9990 7333 CONTINUE C RECOMPUTE SHEET. C RM COMMAND SETS MANUAL FLAG. RCFGX=0 RCONE=0 IF(CMDLIN(2).NE.'S')GOTO 5114 RRWACT=RRW RCLACT=RCL 5114 CONTINUE C RCFGX NONZERO INHIBITS RECALCULATION. C RCONE SET 1 TO FORCE RECALC OF ALL. C CHANGE FROM OTHER SYNTAX: RF FORCES RECALC, R DOES NOT. IF(CMDLIN(2).EQ.'F'.OR.CMDLIN(2).EQ.'R')RCONE=1 C NOTE RXF (X=ANY CHAR BUT F) ACTS LIKE OLD VERSION RXF. C BARE R COMMAND HOWEVER JUST REDOES CALC. F NOW MEANS "FORCE" C AND SEEMS A BIT MORE MNEMONIC THIS WAY. ALLOW RR COMMAND C TO WORK AS WELL AS RF. IF(CMDLIN(2).NE.'R')RCMODE=0 C RR COMMAND RECALCULATES WITH FORCE, BUT LEAVES MODE ALONE. IF(CMDLIN(2).EQ.'E')RCMODE=1 IF(CMDLIN(2).EQ.'I')RCMODE=2 IF(CMDLIN(2).EQ.'1')RCMODE=-RCMODE C R1 DOES ONE TIME RECALC OF ALL C RE COMMAND RECALCULATES ENTRY ONLY C RI COMMAND RECALCULATES INCREMENTALLY THE DISPLAY AND ENTRY ONLY IF(CMDLIN(2).EQ.'M')RCFGX=1 ICODE=3 IF(CMDLIN(3).EQ.'I')ICODE=1 C 3RD CHAR "I" Inhibits RECALCULATION THIS TIME BUT SETS MODES UP... GOTO 9990 8008 IF(CMDLIN(1).NE.'K')GOTO 8009 C DROP INTO CALC BARE. IF(IPSET.NE.0)GOTO 9990 C CAN'T CALL CALC RECURSIVELY OSWIT=0 ILNFG=0 C ICODE=-1 C CLOSE UNIT 1 JUST IN CASE... CLOSE(UNIT=1) CALL UVT100(ED,2) KLVL=1 ILNCT=0 C SAVE PROW,PCOL ACROSS CALC SINCE IT MAY NOW USE *P AND *W TO C MODIFY THEM. C IPRSSS=PROW C IPCSSS=PCOL C CALL CALC C PROW=IPRSSS C PCOL=IPCSSS CC CLOSE CONSOLE LUN USED BY CALC. C CLOSE(UNIT=1) CC CLOSE ANY OTHER LUNS CALC MAY HAVE USED... C CLOSE(UNIT=2) C CLOSE(UNIT=3) ICODE=420 GOTO 9990 8009 IF(CMDLIN(1).NE.'L')GOTO 8010 C LOCATE CURSOR ORIGIN C FORMAT IS L VARIABLE C ONLY 1 VARIABLE NAME TO BE ENTERED. LA=2 LE=30 CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1A,ID2A,IVLD) L1=IVLD C ASSIGN 8900 TO IBACK C GOTO 8104 8900 IF(L1.LT.1)GOTO 9990 3800 PROW=ID1A PCOL=ID2A C LOOK UP DISPLAY COORDS IF ANY ASSIGN 8901 TO NBK GOTO 7905 8901 CONTINUE DROW=LR DCOL=LC THISRW=LR THISCL=LC 3802 ICODE=1 GOTO 9990 8010 CONTINUE IF(CMDLIN(1).NE.'>')GOTO 3801 C >STRING SEARCH FOR STRING IN FORMULA. STRING TERMINATES WITH EOL. C SEARCH FROM CURRENT POSITION TO RB RANGE END LA=MIN0(RRWACT,IDOL5) LB=MIN0(RCLACT,IDOL6) IF(PROW.GT.LA.OR.PCOL.GT.LB)GOTO 3802 C ONLY SEARCH IF THERE'S A VALID RANGE TO SEARCH DO 3803 ID1=PROW,LA DO 3803 ID2=PCOL,LB CALL FVLDGT(ID1,ID2,FVLD(1,1)) IF(FVLD(1,1).EQ.0)GOTO 3803 ID1A=ID1 ID2A=ID2 C USE SCMP SUBROUTINE FROM CMND FILE. (VAX ONLY OR RE-OVERLAY) C GET FORMULA IN MEMORY FIRST. LMN=2 LMX=50 IF(CMDLIN(2).NE.'>')GOTO 3809 LMN=3 LMX=1 C ANCHOR SEARCH IF 2 > IN A ROW 3809 CONTINUE C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,FORM2,0) C SEARCH IN FIRST 50 CHARACTERS OF FORMULA FOR USERS STRING C NOW THAT WE HAVE IT LOCAL. DO 3805 IVV=1,LMX KKKK=110-IVV C DON'T GO COMPARING NULLS. IF(FORM2(IVV).LE.0)GOTO 3803 CALL SCMP(FORM2(IVV),CMDLIN(LMN),KKKK,IV) IF(IV.EQ.1)GOTO 3804 3805 CONTINUE 3803 CONTINUE GOTO 3802 3804 CONTINUE C SET ID1A AND ID2A TO CELL LOC TO USE. GOTO 3800 3801 IF(CMDLIN(1).NE.'Z')GOTO 8011 C ZERO COMMAND C ZA OR ZE V1:V2 IF(CMDLIN(2).NE.'A')GOTO 8950 C ZA = ZERO ALL. BE SURE HE MEANS IT. CALL UVT100(CUP,LLDSP,1) WRITE(6,8951) 8951 FORMAT(/,'Really Zero All of sheet [Y/N]? ') READ(IOLVL,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4) 8952 FORMAT(4A1) ICODE=6 IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990 CALL UVT100(ED,2) ICODE=-4 GOTO 9990 8950 IF(CMDLIN(2).NE.'E')GOTO 9990 ASSIGN 8953 TO IBACK GOTO 8104 C GET NAMES 8953 IF(L1.LE.0)GOTO 9990 ASSIGN 8954 TO JBACK GOTO 8109 8954 CONTINUE DO 8955 NI=1,128 8955 FORM2(NI)=0 FORM2(118)=15 DO 8823 NI=1,9 8823 FORM2(119+NI)=DEFVB(1+NI) DO 8956 NI=1,IDELT C IRX=(ID2-1)*RRW+ID1 CALL REFLEC(ID2,ID1,IRX) CALL WRKFIL(IRX,FORM2,1) C WRITE(7'IRX)FORM2 CALL FVLDST(ID1,ID2,0) CALL XVBLST(ID1,ID2,0.0D0) C FVLD(ID1,ID2)=0 C XVBLS(ID1,ID2)=0. IPRS=PROW IPCS=PCOL PROW=ID1 PCOL=ID2 ASSIGN 8957 TO NBK C FIND DISPLAY LOC IF ANY GOTO 7905 8957 PROW=IPRS PCOL=IPCS IF(LR.EQ.0.OR.LC.EQ.0)GOTO 8958 DVS(LR,LC)=DVS(LR,LC)+1.E-10 8958 CONTINUE ID1=ID1+I1IN ID2=ID2+I2IN 8956 CONTINUE GOTO 9990 8011 IF(CMDLIN(1).NE.'X')GOTO 8012 C EXIT TO OS C SINCE THERE'S NO WORKFILE HERE, MAKE SURE HE MEANS IT... IF(IPSET.NE.0)GOTO 9990 ICODE=6 CALL UVT100(CUP,LLDSP,1) WRITE(6,3718) 3718 FORMAT(' Exit now may lose data unless sheet has been saved') CALL UVT100(CUP,LLCMD,1) WRITE(6,3717) 3717 FORMAT(' Confirm Exit Request [Y/N]:') READ(IOLVL,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4) IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990 IF(CMDLIN(2).NE.'D')GOTO 3603 C THE XD COMMAND WILL EXIT AND DELETE THE SCRATCH FILE. C CALL WRKFIL(1,FORM,3) C CLOSE(UNIT=7,DISP='DELETE') C FINISH UP WITH DATATRIEVE IF USING IT... CALL DTRFIN C NOW CLEAN EXIT. CALL EXIT 3603 CONTINUE C CALL WRKFIL(1,FORM,3) C CALL CLOSE(7) CALL EXIT 8012 IF(CMDLIN(1).NE.'S')GOTO 8013 C SAVE SHEET TO DISK (NEW SET OF DATA) C NOW JUST PERMITS RESTART... ICODE=-2 ISTAT=-2 CALL UVT100(ED,2) GOTO 9990 8013 IF(CMDLIN(1).NE.'P')GOTO 8014 IRTN=0 CALL PGET(CMDLIN,ICODE,IRTN) IF(IRTN.EQ.1)GOTO 510 GOTO 9990 8014 CONTINUE 8015 IF(CMDLIN(1).NE.'G')GOTO 8016 C GET INPUT NUMBERS OFF SEQUENTIAL FILE. USE CURRENT ORIGIN ICODE=2 IRTN=0 CALL PGGET(CMDLIN,ICODE,IRTN) IF(IRTN.EQ.1)GOTO 510 RCMODE=-IABS(RCMODE) C FORCE RECALC OF EVERYTHING AT LEAST ONCE THROUGH. C NOTE ALL'S WELL IF RCMODE WAS 0... GOTO 9990 8016 IF(CMDLIN(1).NE.'W')GOTO 8017 C WRITE (PRINT) SCREEN OUT TO FILE (MAY BE PRINTER) C CALL DSPSHT(10) C ICODE=1 ICODE=400 C CODE 10 IS PRINT SECRET CODE TO DSPSHT. GOTO 9990 8017 CONTINUE IF(CMDLIN(1).NE.'H')GOTO 5019 IF(IPSET.NE.0)GOTO 9990 IVVV=0 IVVVV=CMDLIN(2) ivvx=cmdlin(3) 9308 CONTINUE IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48 if(ivvx.lt.48.or.ivvx.gt.57)goto 9381 C implement 2 digit help code. ivvvx=ivvx-48 ivvv=(ivvv*10)+ivvvx ivvv=min0(ivvv,maxhlp) 9381 continue C SELECT HELP LEVEL 0-9 IF SPECIFIED. ICODE=30+IVVV C CALL HELP(IVVV) C IVVV=0 C WRITE(6,5020) C5020 FORMAT(/'Type return to continue, Hn for other Help pages:') C READ(IOLVL,8952,END=510,ERR=510)(FORM2(K),K=1,4) C IVVVV=FORM2(2) C IF(FORM2(1).EQ.'H')GOTO 9308 C ICODE=2 GOTO 9990 5019 CONTINUE C *** ALLOW EVALUATION OF A CELL TO PERMIT INTERACTIVE COMMAND FILES TO C *** BE CONTROLLED RATIONALLY. KEYWORD IS "TEST" IF(CMDLIN(1).NE.'T'.OR.CMDLIN(2).NE.'E')GOTO 4302 C TEST EXPRESSION IS SYNTAX. C COPY CMDLIN INTO XTNCMD AND FLAG VIA ICODE=430 XTNCNT=0 ICODE=430 DO 4303 N=1,79 XTNCMD(N)=CMDLIN(3+N) C ALLOW "TE " WITH OPTIONAL SPACE. JUST RETURNS VALUE IN C % VARIABLE. IF(XTNCMD(N).LT.32)GOTO 4304 XTNCNT=N 4303 CONTINUE 4304 CONTINUE XTNCMD(XTNCNT+1)=0 GOTO 9990 4302 CONTINUE C C HERE ADD SOME CODE TO INSERT __{cell0 IF WE SEE SOMETHING THAT MIGHT BE C A VALID CELL NAME IN THE RANGE THAT'S LEGAL... C I1=1 I2=16 III=16 IVVVVV=0 IF(CMDLIN(1).LE.32)GOTO 7622 C SKIP NULL COMMANDS C TRY AND MUNGE OTHER COMMANDS NOT UNDERSTOOD INTO SOMETHING C AT LEAST REDIRECTABLE... IVVVV=CMDLIN(1) C KEEP AROUND A FLAG IN IVVVVV THAT WE MESSED AROUND WITH A SPECIAL C CHARACTER, ALLOWING LATER FIXUPS FOR REST OF CMD LINE. IF(IVVVV.LE.64)IVVVVV=1 IF(IVVVV.LE.64)IVVVV=IVVVV+64 C NOW HAVE ! THRU @ CHARS IN RANGE 96=128 IVVVV=MOD(IVVVV,32)+64 C THUS A=65. MOD(65,32)=1. 1+64=65 SO CHARS GET TRANSFORMED C INTO THEMSELVES. HOWEVER = IS 61. THUS, 61+64=123. 123 MOD 32=27 C 27+64=91, CODE FOR [ C FIX THESE UP BY SUBTRACTING 9 AGAIN C THUS 91 - 9 =82, CODE FOR R IF(IVVVV.GT.90)IVVVV=IVVVV-9 CMDLIN(1)=IVVVV IF(CMDLIN(1).GT.64)GOTO 7620 7622 CONTINUE C ERROR UNLESS WE GET AN ALPHA COMMAND AT THIS POINT. WRITE(6,8018) C EMIT ERROR MESSAGE AND SKIP OUT. GOTO 200 7620 CONTINUE KK=CMDLIN(2) KKK=CMDLIN(3) C IF WE MUNGED A SPECIAL CHAR INTO A LETTER, TERMINATE AFTER IT C FOR NAME SCAN AND FIX UP REST LATER... IF(IVVVVV.GT.0)CMDLIN(2)=0 CALL VARSCN(CMDLIN,I1,I2,III,ID1,ID2,IVALID) IF(IVVVVV.GT.0)CMDLIN(2)=KK IF(IVALID.EQ.0)GOTO 200 I1=0 CALL FVLDGT(ID1,ID2,I1) IF(I1.EQ.0)GOTO 200 C ENSURE THE CELL WE ARE GRABBING HAS SOMETHING IN IT C OTHER THAN DEFAULT ALSO. C LOOKS LIKE AN OK CELL NAME IF IN RANGE... IF(ID1.GT.RRW.AND.ID2.LE.1)GOTO 200 C TRY AND MOVE THINGS UP THE LINE AND RESCAN... C III=PAST END OF OLD ONE... IIV=III+3+80 C ALLOW TO COPY DOWN 80 CHARS OR SO OF REST OF CMD LINE IF(IIV.LT.4)GOTO 200 KKK=3 IF(IVVVVV.GT.0)KKK=4 KKKK=KKK+1 DO 7621 IV=KKKK,IIV IVV=IIV+KKKK-IV IVVV=IVV-KKK CMDLIN(IVV)=CMDLIN(IVVV) 7621 CONTINUE C FILL IN NECESSARY PREFIX. CMDLIN(1)='_' CMDLIN(2)='_' CMDLIN(3)='{' IF(IVVVVV.LE.0)GOTO 7623 CMDLIN(4)=CMDLIN(5) CMDLIN(5)=' ' C INSERT DELIMITERS AS NEEDED FOR MUNGED SPECIAL CHARS C ALSO MOVE RESULT CHAR DOWN... 7623 CONTINUE DO 7624 IV=IIV,132 7624 CMDLIN(IV)=0 C NULL OUT REST OF COMMAND LINE AFTER THIS STUFF.. C C if(cmdlin(1).gt.32)WRITE(6,8018) 8018 FORMAT('Invalid Command.') C GO FOR RESCAN OF COMMAND HERE... ISCANX=ISCANX+1 C LIMIT NUMBER OF RESCANS THROUGH COMMAND LINE TO KEEP OUT C OF LOOPS. IF(ISCANX.GT.3)GOTO 200 GOTO 3871 C GOTO 200 C ERROR ON READIN ADDRESS. REWIND TERMINAL IF USER C TYPES CTRL Z (EOF), ELSE LEAVE INDIRECT FILES. 510 IF(IOLVL.EQ.5)REWIND 5 CLOSE(UNIT=3) FOOBAR=0 IOLVL=5 CLOSE(UNIT=5) OPEN(UNIT=5,FILE='SYS$COMMAND:',CARRIAGECONTROL='NONE') GOTO 498 9990 CONTINUE C HERE CLEAN UP AND RETURN C FIRST DISPLAY LAST CURRENT COL IN NORMAL VIDEO IF(IXLSTR.LE.0.OR.IXLSTC.LE.0)GOTO 2000 N1=NRDSP(IXLSTR,IXLSTC) N2=NCDSP(IXLSTR,IXLSTC) C IRRX=(N2-1)*RRW+N1 CALL REFLEC(N2,N1,IRRX) C REWRITE LAST LOCATION WITH NO REVERSE VIDEO. C IF(FVLD(N1,N2).EQ.0)GOTO 2000 IF(IXLSTC.GT.DCLV.OR.IXLSTR.GT.DRWV)GOTO 2000 C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED. IF(ICODE.LT.0.OR.ICODE.EQ.2)GOTO 2000 C NO SENSE REDRAWING IF WE'RE ABOUT TO ERASE DISPLAY ANYWAY. IF(ICODE.GT.30)GOTO 2000 J=8 C ADD 6 COLS FOR LABELS C DROW,DCOL IS CURRENT DISPLAY LOC. DO 3301 M1=1,IXLSTR C FIND DISPLAY COLUMN TO USE 3301 J=J+CWIDS(M1) J=J-CWIDS(IXLSTR) C USE THISCL+1 TO LET 1ST ROW BE LABELS. ICCC=IXLSTC+2 C JVTINC = 1 IF VT100, 0 IF VT52 C JVTINC NEEDED SINCE UVT100 FOR VT100 DOES BACKSPACE AT THE SGR ENTRY C AND THUS WE NEED TO CORRECT FOR IT. THIS WAS FIXED IN THE UVT52 C VERSION AND ITS DESCENDANTS. IC1POS=N1 IC2POS=N2 IF(PZAP.NE.0)GOTO 2000 CALL UVT100(CUP,ICCC,J+JVTINC) !SELECT ROW "IXLSTC", COL "J" CALL UVT100(SGR,0) C DESELECT REVERSE VIDEO CALL FVLDGT(N1,N2,FVLDTP) ivv=min0(30,cwids(IXLSTR)) IF(FVLDTP.EQ.0)WRITE(6,5538)(blanks(iv),iv=1,ivv) C IF(FVLDTP.EQ.0)WRITE(6,5537) C5537 FORMAT(' ') IF(FVLDTP.EQ.0)GOTO 2000 CC IF(FVLD(N1,N2).LT.0)READ(7'IRRX)FORM CALL WRKFIL(IRRX,FORM,0) C READ(7'IRRX)FORM DO 5546 KKKK=1,100 IV=FORM(KKKK) IV=MAX0(IV,32) 5546 FORM(KKKK)=IV IF(FVLDTP.LT.0.OR.FORMFG.NE.0) 1 ENCODE(100,8201,CMDLIN)(FORM(II),II=1,100) IF(FORMFG.NE.0)GOTO 4324 DO 6302 KKK=1,9 KKKK=FORM(KKK+119) C KKKK=DFMTS(KKK,IXLSTR,IXLSTC) 6302 DFE(KKK+1)=MAX0(32,KKKK) DFE(11)=32 C 32 = ASCII SPACE DFE(1)='(' DFE(12)=')' CALL TYPGET(N1,N2,TYPE(1,1)) IF(FVLDTP.LE.0)GOTO 4324 IF(TYPE(1,1).NE.2)GOTO 6227 ENCODE(100,DFE,CMDLIN,ERR=4324)DVS(IXLSTR,IXLSTC) GOTO 4324 6227 CONTINUE ENCODE(100,DFE,CMDLIN,ERR=4324)LDVS(1,IXLSTR,IXLSTC) C REDRAW THIS COL. WITHOUT REVERSE VIDEO HERE. 4324 WRITE(6,9000)(CMDLIN(II),II=1,CWIDS(IXLSTR)) C NOTE THIS REDRAWS PREVIOUS COL. IN NORMAL VIDEO. C NO CARRIAGE CTL C CALL UVT100(SGR,0) C SELECT REVERSE VIDEO OFF 2000 CONTINUE C NOW COMPLETE ANY CLEANUP. C SET CMDLIN TO 0 AT START TO INHIBIT ANY MISINTERPRETATION. C WE USE CMDLIN AS A BUFFER IN REDRAWIND DSPLY SO DON'T LET IT GET C CLOBBERED. DO 945 K=1,132 945 CMDLIN(K)=0 RETURN END SUBROUTINE RELVBL(LNIN,LNOUT,INRW,INCL,JOUTR,JOUTC,JRTR,JRTC) C RELOCATE VARIABLES BELOW/RIGHT OF JRTR,JRTC INTO LNOUT FROM LNIN INCLUDE 'VKLUGPRM.FTN' PARAMETER CUP=1,ED=11,EL=12 LOGICAL*1 NAME(4),NUMBER(6) LOGICAL*1 LNIN,LNOUT DIMENSION LNIN(128),LNOUT(128) InTEgeR*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6 COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6 LI=1 LO=1 C LI = INPUT LOCATION C LO=OUTPUT LOCATION 100 CONTINUE C IF(LNIN(LI).LT.'A'.OR.LNIN(LI).GT.'Z')GOTO 200 LCC=LNIN(LI) IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200 C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START. L1=LI LE=110 LSTC=LE CALL VARSCN(LNIN,L1,LE,LSTC,ID1,ID2,IVLD) C IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0 C OMIT MODIFYING ANYTHING IN ROW 0 SO WE DON'T GET C RANDOM FUNCTION NAMES MUCKED UP. IF(ID2.EQ.1)IVLD=0 IF(IVLD.EQ.0)GOTO 200 C FOUND VARIABLE. NOW GENERATE ASCII ANDSTUFF INTO OUTPUT. C FIRST DON'T RELOCATE P## AND D## FORMS. IF(LNIN(LI+1).EQ.'#')GOTO 250 C RELOCATE NORMAL VARIABLE HERE. C C THE NEW VARIABLE IS TO BE DIFFERENT ONLY IF (ID1,ID2) HAS C ID1.GT.JRTR AND ID2.GT.JRTC IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 210 IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 210 C OK, KNOW NOW THAT WE HAVE TO RELOCATE ALL. C THEREFORE ADD THE DIFFERENCE BETWEEN DEST AND SRC TO BOTH C AND CLAMP TO VALID DIMENSIONS. IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW) IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL) ID1=MAX0(ID1,1) ID2=MAX0(ID2,1) C ID1=MIN0(RRW,ID1) C ID2=MIN0(RCL,ID2) ID1=MIN0(RRCL,ID1) ID2=MIN0(RRCL,ID2) 210 CONTINUE CALL IN2AS(ID1,NAME) C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL L2=ID2-1 ENCODE(6,1000,NUMBER)L2 1000 FORMAT(I6) C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES. C THROW OUT SPACES AND COPY THE REST. LI=LSTC DO 202 N=1,4 IF(NAME(N).LE.32)GOTO 202 LNOUT(LO)=NAME(N) LO=LO+1 IF(LO.GT.110)GOTO 300 202 CONTINUE IF(IDOL1.GT.0)LNOUT(LO)=36 IF(IDOL1.GT.0.AND.LO.LE.109)LO=LO+1 DO 203 N=1,6 IF(NUMBER(N).LE.32)GOTO 203 C IF 32 ISN'T SPACE, LOSE LNOUT(LO)=NUMBER(N) LO=LO+1 IF(LO.GT.110)GOTO 300 203 CONTINUE IF(IDOL2.EQ.0)GOTO 300 LNOUT(LO)=36 IF(LO.LE.109)LO=LO+1 GOTO 300 250 CONTINUE C JUST COPY DISPLAY FORMS. L1=LSTC-1 DO 251 N=LI,L1 LNOUT(LO)=LNIN(N) LO=LO+1 IF(LO.GT.110)GOTO 300 251 CONTINUE LI=LSTC C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON. GOTO 300 200 LNOUT(LO)=LNIN(LI) LO=LO+1 LI=LI+1 300 IF(LO.LT.109.AND.LI.LT.109)GOTO 100 C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE. DO 400 N=LO,110 400 LNOUT(N)=0 DO 1 N=111,128 1 LNOUT(N)=LNIN(N) C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT. RETURN END C C STRING EDIT ROUTINE. SUBROUTINE SED(LCMD,LIN,LWRK,ARGSTR,XAC,LENGTH) INCLUDE 'VKLUGPRM.FTN' LOGICAL*1 LIN(1),LWRK(1),ARGSTR(52,4) LOGICAL*1 LCMD(1),LSU(10) INTEGER*4 III REAL*8 XAC C C OPERATION: C EDIT LIN TO LWRK, WITH LENGTH VARIABLE HOLDING INPUT C LENGTH IN CHARACTERS. LCMD HOLDS COMMAND LINE, WHICH C ULTIMATELY GETS EDITED STRING COPIED BACK INTO IT. C C EDITS: C CHARACTER AT IDELIM IS DELIMITER. REPLACE STRING IN 1ST C INTERVAL BETWEEN DELIMITERS WITH SECOND. C HOWEVER: C &1 TO &4 GET CONTENTS (UP TO NULL) OF ARGSTR(X,1) TO (X,4) C C &5 RETURNS XAC VALUE CONVERTED TO DECIMAL INTEGER AND C PRINTED. C &6 RETURNS XAC VALUE CONVERTED TO ASCII CODE (1 BYTE) AND C INSERTED. C XAC ENTERS WITH CONTENTS OF ACCUMULATOR Z (TO AVOID TOO MUCH C DIFFICULTY IN USING IT OWING TO THE UBIQUITY OF USE OF %). C WE ENTER JUST POINTING AT THE COMMAND LINE AFTER THE ENTER C AND ITS SPACE. ASSUME 1ST CHARACTER IS OUR DELIMITER. DO 335 IV=1,80 335 LWRK(IV)=0 IDELIM=LCMD(1) ID2=INDEX(LCMD(2),IDELIM) IF(ID2.GE.LENGTH)GOTO 100 C NOW HAVE 1ST STRING, OF NONZERO LENGTH C FIND SECOND STRING NOW. EITHER MAY BE OF 0 LENGTH BUT C BOTH MUST BE DEFINED BY A DELIMITER. ID3=INDEX(LCMD(2+ID2),IDELIM) IF(ID3.GE.LENGTH)GOTO 100 C WELL, WE GOT IT SOMEHOW. NOW TRY AND EDIT THE JUNK IN. C (NOTE WE WANT TO FILL ALL OF LENGTH) INLIN=1 INWRK=1 IVV=ID3+ID2+2 DO 336 IV=IVV,LENGTH 336 LCMD(IV)=0 LSA=ID2-1 LSB=ID3-1 LSSB=2+ID2 LZR=0 DO 1 N=1,LENGTH IF(LSA.GT.0)GOTO 350 C ZERO LENGTH INITIAL STRING, SO ASSUME HE WANTS TO APPEND TO C EXISTING STRING AT THE END. C (HANDY FOR ADDING TO FORMULAE OR THE LIKE.) IF(LIN(N).EQ.0)GOTO 351 C JUST COPY THE INPUT FIRST AND GO OFF GOTO 2 351 CONTINUE C HERE WE HAVE THE TERMINAL NULL LZR=LZR+1 C ALLOW US TO PRETEND FOR ONCE THAT WE GOT A MATCH IF(LZR.EQ.1)GOTO 222 GOTO 1 350 CONTINUE IF(LIN(INLIN).EQ.0)GOTO 1 CALL SSCMP(LIN(INLIN),LCMD(2),LSA,ICOD) IF(ICOD.EQ.0)GOTO 2 C HERE HAVE TO SUBSTITUTE C PASS STRING TO SUBSTITUTE ON INPUT LINE FIRST. 222 CONTINUE INLIN=INLIN+LSA C ALLOW ZERO LENGTH SUBSTITUTE CHARACTER IF(LSB.LE.0)GOTO 1 C DO 6 M=1,LSB M=1 106 CONTINUE IF(LCMD(LSSB+M-1).EQ.'&')GOTO 7 8 CONTINUE C JUST COPY ONE CHARACTER OF THE SUBSTITUTE STRING IN HERE. LWRK(INWRK)=LCMD(LSSB+M-1) IF(INWRK.LT.LENGTH)INWRK=INWRK+1 GOTO 6 7 CONTINUE C HANDLE & FORMS IF(LCMD(LSSB+M).LT.'1'.OR.LCMD(LSSB+M).GT.'6')GOTO 8 C REQUIRE ALL FORMS TO BE &1 THRU &6 TO BE DEALT WITH HERE. M=M+1 IF(LCMD(LSSB+M-1).GT.'4')GOTO 10 C HERE JUST HANDLE ARGSTR SUBSTITUTIONS. II=LCMD(LSSB+M-1) II=II-48 C II IS NOW THE INDEX. DO 11 MM=1,52 LWRK(INWRK)=ARGSTR(MM,II) IF(INWRK.LT.LENGTH)INWRK=INWRK+1 IF(ARGSTR(MM,II).EQ.0)GOTO 12 11 CONTINUE 12 CONTINUE M=M+1 C PASS THE NUMBER OF THE &NUMBER FORM GOTO 6 10 CONTINUE C HANDLE ZAC FORMS M=M+1 C PASS THE DIGIT IF(LCMD(LSSB+M-2).EQ.'5')GOTO 14 C FILL IN ZAC AS AN INTEGER II=32 IF(XAC.GE.1.AND.XAC.LT.256.)II=XAC C ONLY HANDLE CONVERSION IF LEGAL LWRK(INWRK)=II IF(INWRK.LT.LENGTH)INWRK=INWRK+1 GOTO 6 14 CONTINUE C HANDLE NUMERIC CONVERSION HERE LSU(1)=0 III=0 IF(ABS(XAC).LT.9999999.)III=XAC ENCODE(10,15,LSU,ERR=22)III 15 FORMAT(I9) 22 DO 16 MK=1,10 IF(LSU(MK).EQ.0)GOTO 6 IF(LSU(MK).EQ.' ')GOTO 16 LWRK(INWRK)=LSU(MK) IF(INWRK.LT.LENGTH)INWRK=INWRK+1 16 CONTINUE 6 CONTINUE M=M+1 IF(M.LE.LSB)GOTO 106 GOTO 1 2 CONTINUE C HERE JUST ANOTHER CHARACTER TO MOVE, DO THE MOVE. LWRK(INWRK)=LIN(INLIN) IF(INLIN.LT.LENGTH)INLIN=INLIN+1 IF(INWRK.LT.LENGTH)INWRK=INWRK+1 1 CONTINUE C COPY BACK OUT TO CMDLIN AFTER FIXUP IF(INWRK.GE.LENGTH)GOTO 3 DO 4 N=INWRK,LENGTH 4 LWRK(N)=0 3 CONTINUE C REPLACE COMMAND LINE WITH EDITED STRING FOR ENTRY NOW. DO 5 N=1,LENGTH 5 LCMD(N)=LWRK(N) 100 CONTINUE RETURN END C STRING COMPARE 2 ARRAYS UNTIL EITHER ENDSTRING IS SEEN C ON ONE OR MISMATCH IS SEEN. SUBROUTINE SSCMP(LINA,LINB,LENM,ICODE) DIMENSION LINA(1),LINB(1) LOGICAL*1 LINA,LINB ICODE=1 DO 1 N=1,LENM C IF(LINA(N).EQ.0.OR.LINB(N).EQ.0)GOTO 2 IF(LINA(N).NE.LINB(N))ICODE=0 IF(ICODE.NE.1)GOTO 2 1 CONTINUE 2 CONTINUE RETURN END SUBROUTINE SVBL(CMDLIN,LA,N,LE,FORM) INCLUDE 'VKLUGPRM.FTN' InTEgeR*4 VLEN(9),TYPE(RRWP,RCLP) LOGICAL*1 AVBLS(20,27) REAL*8 XVBLS(RRWP,RCLP) COMMON/V/TYPE,AVBLS,XVBLS,VLEN LOGICAL*1 CMDLIN(132),FORM(128),NBF(8) InTEgeR*4 LA,N,LE NI=N N=N+2 C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN. LAA=N LEE=LE CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD) IF(IVLD.LE.0)GOTO 990 LAA=LSTC+1 C ACCEPT ANY DELIMITER LEE=LE CALL VARSCN(CMDLIN,LAA,LEE,LSTC,J1,J2,IVLD) IF(IVLD.LE.0)GOTO 990 C XX=XVBLS(I1,I2) CALL XVBLGT(I1,I2,XX) C XX IS COL # C XY=XVBLS(J1,J2)-1.0 CALL XVBLGT(J1,J2,XY) IF(XX.LE..99.OR.XX.GT.DFLOAT(RRW))GOTO 990 IF(XY.LE..99.OR.XY.GT.DFLOAT(RCL))GOTO 990 IC=XX CALL IN2AS(IC,NBF) IR=XY ENCODE(3,300,NBF(5))IR 300 FORMAT(I3.3) NL=NI C FILL IN DECODED VARIABLE NAME, ZOTTING OUT EXTRA SPACES. DO 400 NN=1,7 FORM(NL)=NBF(NN) IF(FORM(NL).GT.64)NL=NL+1 400 CONTINUE C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP C NOTE NI IS WHERE N WAS ON START (INDEX OF _) C AND LSTC IS NEXT CHAR AFTER 2ND VARIABLE ON CMDLIN C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER C AND MOVE CMDLIN DOWN. N=NL LE=LE-LSTC+NL DO 401 M=N,LE CMDLIN(M)=CMDLIN(M+LSTC-NL) 401 CONTINUE C HOPE ALL'S WELL NOW... RETURN 990 CONTINUE FORM(N)=CMDLIN(N) RETURN END SUBROUTINE SSTR(CMDLIN,LA,N,LE,FORM) LOGICAL*1 CMDLIN(132),FORM(128),NBF(8) InTEgeR*4 LA,N,LE INCLUDE 'VKLUGPRM.FTN' InTEgeR*4 VLEN(9),TYPE(RRWP,RCLP) LOGICAL*1 AVBLS(20,27) REAL*8 XVBLS(RRWP,RCLP),XX,VP,TMP COMMON/V/TYPE,AVBLS,XVBLS,VLEN NI=N N=N+2 C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN. LAA=N LEE=LE CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD) IF(IVLD.LE.0)GOTO 990 C XX=XVBLS(I1,I2) CALL XVBLGT(I1,I2,XX) VP=128.D0**7 DO 1 NN=1,8 TMP=AINT(XX/VP) NBF(NN)=TMP VP=VP/128.D0 XX=XX-(128.D0*TMP) 1 CONTINUE C NOW NBF HAS 8 BYTES OF DATA CORRESPONDING TO DE-HASHED C STRING. COPY TO FORM. NL=NI DO 2 NN=1,8 FORM(NL)=NBF(NN) IF(NN.GE.1)NL=NL+1 2 CONTINUE C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP C NOTE NI IS WHERE N WAS ON START (INDEX OF _) C AND LSTC IS NEXT CHAR AFTER VARIABLE ON CMDLIN C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER C AND MOVE CMDLIN DOWN. N=NL LE=LE-LSTC+NL DO 401 M=N,LE CMDLIN(M)=CMDLIN(M+LSTC-NL) 401 CONTINUE C HOPE ALL'S WELL NOW... RETURN 990 FORM(N)=CMDLIN(N) RETURN END SUBROUTINE PGET(CMDLIN,ICODE,IRTN) INCLUDE 'VKLUGPRM.FTN' PARAMETER CUP = 1, CUU = 2, CUD = 3, CUF = 4, CUB = 5, DECDWL = 6 $, DECDHL = 7, DECRC = 8, DECSC = 9, DECSWL = 10, ED = 11, EL = 12 $, SGR = 13, NEL = 14, SCS = 15, SM = 16, RM = 17, ANSI = 18 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. LOGICAL*1 FORM,FVLD,CMDLIN(132) INTEGER*4 VNLT LOGICAL*1 LET1,LET2,FORM2(128),FORM3(128),NMSH(80) real*8 r8s equivalence(r8s,form3(1)) COMMON/NMSH/NMSH InTEgeR*4 ICREF,IRREF COMMON/MIRROR/ICREF,IRREF REAL*8 XVBLS(RRWP,RCLP) INTEGER KPYBAK InTEgeR*4 IOLVL INTEGER*4 JVBLS(2,RRWP,RCLP) 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. DIMENSION FORM(128),FVLD(RRWP,RCLP) LOGICAL*1 DFE,FVWRK,FVWRK2 DIMENSION DFE(12) 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 FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC. 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. InTEgeR*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV InTEgeR*4 LLCMD,LLDSP COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP InTEgeR*4 TYPE(RRWP,RCLP),VLEN(9) LOGICAL*1 AVBLS(20,27),VBLS(8,RRWP,RCLP) REAL*8 XAC,ZAC EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26)) REAL*8 XXAC,XYAC EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25)) LOGICAL*1 ARGSTR(52,4) COMMON/ARGSTR/ARGSTR C EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1)) C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND. EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1)) EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN COMMON/KLVL/KLVL LOGICAL*1 DEFVB(12) COMMON/DEFVBX/DEFVB C RRWACT AND RCLACT ARE MAX OFFSETS IN USE InTEgeR*4 RRWACT,RCLACT COMMON/RCLACT/RRWACT,RCLACT InTEgeR*4 FORMFG,RCFGX,PZAP,RCONE COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE 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(DRW) 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 DRW NOT DCL. REAL*8 DVS(DRW,DCL) INTEGER*4 IDRO,IDCL LOGICAL*1 LETR INTEGER*4 INUMEM INTEGER*4 IIRO,IICO INTEGER*4 LDVS(2,DRW,DCL) EQUIVALENCE(LDVS(1,1,1),DVS(1,1)) COMMON /FVLDC/FVLD C LOGICAL*1 DFMTS(10,DRW,DCL) C 10 CHARACTERS PER ENTRY. COMMON/DSPCMN/DVS,CWIDS C C PUT NUMBERS OUT TO FILE C USES RELATIVE FORMS TO CURRENT POS. C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET. C ONLY WRITES PHYSICALLY PRESENT DATA. C PB acts like PP but saves in unformatted file for speed. C GB is corresponding load. C P/D RRR,CCC,FORMULA,VALID,FORMAT C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS. ICODE=1 CLOSE(UNIT=4,ERR=7954) 7954 CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) C ASK FOR FILE NAME WRITE(6,7952) READ(IOLVL,7953,END=510,ERR=510)ILN,FORM2 7952 FORMAT('Enter filename>') 7953 FORMAT(Q,128A1) C FORMAT Q RETURNS NUMBER CHARACTERS READ. CAN USE KLUDGE TO C FIND THIS BY LOOKING FOR LAST NONSPACE BUT THIS IS EASIER. ILN=MIN0(ILN,127) FORM2(ILN+1)=0 IBIN=0 if(cmdlin(2).eq.'B')ibin=1 If(Ibin.eq.0) 1 OPEN(UNIT=4,FILE=FORM2,CARRIAGECONTROL='LIST', 1 ACCESS='SEQUENTIAL',RECL=512, 1 STATUS='NEW',ERR=9990) If(Ibin.eq.1) 1 OPEN(UNIT=4,FILE=FORM2,form='UNFORMATTED', 1 ACCESS='SEQUENTIAL',RECL=512, 1 STATUS='NEW',ERR=9990) C CALL ASSIGN(4,FORM2) IIVV=MIN0(DCL,15) C WRITE OUT THE NAME ARRAY FOLLOWED BY SOME GLOBAL INFO C SO THE STUFF GETS PRESERVED. C FILL SPACES INTO NAME SO THE SAVED RECORD READS IN OK. DO 6952 III=1,80 IVV=NMSH(III) 6952 NMSH(III)=MAX0(32,IVV) If(Ibin.eq.0) 1 WRITE(4,6951,ERR=9990)NMSH,ICREF,IRREF,(CWIDS(III), 1 III=1,IIVV),DRWV,DCLV If(Ibin.eq.1) 1 WRITE(4,ERR=9990)NMSH,ICREF,IRREF,(CWIDS(III), 1 III=1,IIVV),DRWV,DCLV 6951 FORMAT(80A1,64I3) C *** NOTE THAT IF DCL GETS BIGGER THAN 96 WE LOSE. C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) mdxm=12000 ldxm=12000 if(Ibin.eq.1)goto 448 WRITE(6,7980) 7977 FORMAT('Enter max. displ down to save or 0 for all>') READ(IOLVL,7978,END=510,ERR=510)LDXM 6950 FORMAT(80A1) 7978 FORMAT(I7) CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) WRITE(6,7977) 7980 FORMAT('Enter max. displ right to save or 0 for all>') READ(IOLVL,7978,END=510,ERR=510)MDXM IF(MDXM.LE.0)MDXM=12000 IF(LDXM.LE.0)LDXM=12000 448 Continue C 12000 IS "AN ARBITRARILY LARGE NUMBER TO ASSURE THAT ALL VALID C RANGES ARE SAVED". IT MUST BE SMALL ENOUGH TO ASSURE WE DON'T OVERFLOW AN C INTEGER THOUGH. IF(CMDLIN(2).LT.' ')GOTO 7983 IF(CMDLIN(2).NE.'P'.and.(ibin.eq.0))GOTO 7950 C allow pb to work as binary pp 7983 CONTINUE C DEFAULT TO PP IF USER JUST TYPES "P" C MAKE SURE ONE ITERATION IS OK AT LEAST. C ONLY SAVE THE PART OF SHEET IN USE. KRRW=MAX0(PROW,RRWACT) KRCL=MAX0(PCOL,RCLACT) DO 7951 ICO=PCOL,KRCL DO 7951 IRO=PROW,KRRW C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY. C IRX=(ICO-1)*RRW+IRO CALL REFLEC(ICO,IRO,IRX) IDRO=IRO-PROW+1 IDCL=ICO-PCOL+1 IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951 C FORM DISPLACEMENT LOCATORS CALL FVLDGT(IRO,ICO,FVLD(1,1)) IF(FVLD(1,1).EQ.0)GOTO 7951 CALL WRKFIL(IRX,FORM2,0) C READ(7'IRX)FORM2 IF(FORM2(119).EQ.2)FORM2(119)=3 IF(FORM2(119).EQ.-2)FORM2(119)=-3 CALL TYPGET(IRO,ICO,TYPE(1,1)) IF(CMDLIN(3).NE.'N')GOTO 5402 C FOR FORMULAS, EMIT THEM ANYHOW... NUMBERS USUALLY ARE 0. IF(FVLD(1,1).LT.0)GOTO 5402 C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER LETR=80 C 80 = UPPERCASE 'P' IN ASCII ASSIGN 5405 TO INUMEM 6400 CONTINUE C INTERNAL PROC TO EMIT NUMERIC VALUES C TO CALL, SET LETR TO EITHER 80 OR 112 (UPPER OR LOWERCASE P) CALL XVBLGT(IRO,ICO,XVBLS(1,1)) C FLAG VALUE WITH LOWER CASE P HERE INSTEAD OF UPPER CASE C AND GENERALLY EMIT IT FIRST if(ibin.eq.1)goto 449 IF(ABS(TYPE(1,1)).EQ.4)WRITE(4,5403)LETR,IDRO,IDCL, 1 JVBLS(1,1,1) 5403 FORMAT(A1,I5,',',I5,',',I15) IF(ABS(TYPE(1,1)).NE.4)WRITE(4,5404)LETR,IDRO,IDCL, 1 XVBLS(1,1) 5404 FORMAT(A1,I5,',',I5,',',D30.19) Goto 450 449 Continue r8s=xvbls(1,1) IF(ABS(TYPE(1,1)).EQ.4)WRITE(4)LETR,IDRO,IDCL, 1 (form3(ivv),ivv=1,110) C Keep record lengths constant IF(ABS(TYPE(1,1)).NE.4)WRITE(4)LETR,IDRO,IDCL, 1 (form3(ivv),ivv=1,110) 450 Continue GOTO INUMEM,(5405,6406) C GOTO 5405 5402 CONTINUE C FIND END OF TEXT IN FORMULA AREA DO 4330 IV=2,110 IVVV=113-IV IF(FORM2(IVVV).GT.32)GOTO 4331 4330 CONTINUE 4331 CONTINUE C SAVE ON PPX IN EFFICIENT FORM. C DON'T WRITE OUT TRAILING NULLS. C ENSURE FORMAT HAS NO NULLS IN IT DURING SAVE DO 358 IV=120,128 358 IF(FORM2(IV).LT.' ')FORM2(IV)=32 IF(CMDLIN(3).EQ.'F')GOTO 6404 C PPF WILL SAVE FORMULA ONLY C PPA WILL SAVE ALL (I.E., NUMERIC TOO) C SAVE THE NUMBERS FIRST SO WE CAN HAVE GRAPHICS ETC. FIND THEM C FIRST WITHOUT SPECIAL WORK. LETR=112 C LOWERCASE P FLAGS DOUBLE SAVE STUFF. NORMAL PPN IS UPPERCASE C P. ASSIGN 6406 TO INUMEM C NOW GO WRITE FIRST LINE OF STUFF NUMERICALLY GOTO 6400 6406 CONTINUE C NOW HAVE NUMERIC LINE WRITTEN. WRITE 2ND LINE ALSO SO WE DON'T C CONFUSE GRAPHICS PGMS. If(Ibin.eq.0) 1 WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1) If(Ibin.eq.1) 1 WRITE(4)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1) C NOW HAVE THE SPECIAL RECORD DONE, GO AHEAD AND WRITE THE FORMULA C TOO... 6404 CONTINUE C WRITE OUT THE FORMULA IF CALLED FOR... If(Ibin.eq.0) 1 WRITE(4,7955)IDRO,IDCL,(FORM2(IV),IV=1,IVVV) Letr=80 If(Ibin.eq.1) 1 WRITE(4)Letr,IDRO,IDCL,(FORM2(IV),IV=1,IVVV) 5405 CONTINUE C DUMP TO SERIAL FILE IN OUR OWN FORMAT, BUT ALL IN ASCII. 7955 FORMAT('P',I5,',',I5,',',128A1) C NOTE LONG RECORDS. If(Ibin.eq.0) 1 WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1) If(Ibin.eq.1) 1 WRITE(4)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1) 7956 FORMAT(I3,',',9A1,',',I5) 7951 CONTINUE 2951 CONTINUE C C NOW SAVE NRDSP AND NCDSP MAPPINGS TOO. IF(CMDLIN(4).NE.'M')GOTO 6541 C SKIP THE SAVE OF MAPPING UNLESS 4TH CHAR OF COMMAND IS M C (FOR "MAPPING") MXIRO=DRWV MXICO=DCLV IF(CMDLIN(5).NE.'A')GOTO 6549 MXIRO=DRW MXICO=DCL C "MA" SUFFIX MEANS SAVE ALL OF MAPPING C "M" SUFFIX ALONE SAVES JUST DISPLAYED PAGE 6549 CONTINUE DO 6540 IRO=DROW,MXIRO DO 6540 ICO=DCOL,MXICO IIRO=IRO+64000 IICO=ICO+64000 C NOTE SPECIAL FLAG. 6955 FORMAT('M',I5,',',I5,',',2I7) Letr=77 C 77 = Ascii M If(Ibin.eq.0) 1 WRITE(4,6955,ERR=6541)IIRO,IICO,NRDSP(IRO,ICO), 1 NCDSP(IRO,ICO) If(Ibin.eq.1) 1 WRITE(4,ERR=6541)Letr,IIRO,IICO,NRDSP(IRO,ICO), 1 NCDSP(IRO,ICO) C WRITE A SECOND RECORD BUT DON'T CARE WHAT IT HAS IN IT C SO JUST REPEAT THE LAST... If(Ibin.eq.0) 1 WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1) If(Ibin.eq.1) 1 WRITE(4)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1) 6540 CONTINUE 6541 CONTINUE CLOSE(UNIT=4) GOTO 9990 7950 IF(CMDLIN(2).NE.'D')GOTO 9990 DO 7957 ICO=DCOL,DCL DO 7957 IRO=DROW,DRW IDRO=IRO-DROW+1 IDCL=ICO-DCOL+1 IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7957 NR=NRDSP(IRO,ICO) NC=NCDSP(IRO,ICO) C IRX=(NC-1)*RRW+NR CALL REFLEC(NC,NR,IRX) CALL FVLDGT(NR,NC,FVLD(1,1)) IF(FVLD(1,1).EQ.0)GOTO 7957 CALL WRKFIL(IRX,FORM2,0) C READ(7'IRX)FORM2 IF(FORM2(119).EQ.2)FORM2(119)=3 IF(FORM2(119).EQ.-2)FORM2(119)=-3 IF(CMDLIN(3).NE.'N')GOTO 5412 C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER IF(FVLD(1,1).LT.0)GOTO 5412 C ALWAYS EMIT LABELS EVEN IN NUMERIC SAVE CALL TYPGET(NR,NC,TYPE(1,1)) CALL XVBLGT(NR,NC,XVBLS(1,1)) IF(ABS(TYPE(1,1)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,1,1) 5413 FORMAT('P',I5,',',I5,',',I15) IF(ABS(TYPE(1,1)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(1,1) 5414 FORMAT('P',I5,',',I5,',',D30.19) GOTO 5415 5412 CONTINUE WRITE(4,7958)IDRO,IDCL,(FORM2(IV),IV=1,110) 5415 CONTINUE 7958 FORMAT('D',I5,',',I5,',',128A1) DO 359 IV=120,128 359 IF(FORM2(IV).LT.' ')FORM2(IV)=32 WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(1,1) 7957 CONTINUE C ALLOW SAVE OF MAPPING TOO AS APPROPRIATE. GOTO 2951 C CLOSE(UNIT=4) 9990 RETURN 510 CONTINUE IRTN=1 RETURN END SUBROUTINE PGGET(CMDLIN,icode,irtn) INCLUDE 'VKLUGPRM.FTN' PARAMETER CUP = 1, CUU = 2, CUD = 3, CUF = 4, CUB = 5, DECDWL = 6 $, DECDHL = 7, DECRC = 8, DECSC = 9, DECSWL = 10, ED = 11, EL = 12 $, SGR = 13, NEL = 14, SCS = 15, SM = 16, RM = 17, ANSI = 18 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. LOGICAL*1 FORM,FVLD,CMDLIN(132) INTEGER*4 VNLT LOGICAL*1 LET1,LET2,FORM2(128),NMSH(80) real*8 r8s INTEGER*4 I4S,I4T equivalence(r8s,form2(1)) EQUIVALENCE(I4S,FORM2(1)),(I4T,FORM2(3)) COMMON/NMSH/NMSH REAL*8 R8WK REAL*8 XVBLS(RRWP,RCLP) InTEgeR*4 ICREF,IRREF COMMON/MIRROR/ICREF,IRREF INTEGER KPYBAK InTEgeR*4 IOLVL INTEGER*4 JVBLS(2,RRWP,RCLP) 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. DIMENSION FORM(128),FVLD(RRWP,RCLP) LOGICAL*1 DFE,FVWRK,FVWRK2 DIMENSION DFE(12) 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 FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC. 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. InTEgeR*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV InTEgeR*4 LLCMD,LLDSP COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP InTEgeR*4 TYPE(RRWP,RCLP),VLEN(9) INTEGER*4 IRRW,ICCL C ALLOW BIG NUMBERS HERE SO WE CAN SUBTRACT 64000 AND STILL AVOID C WRAP AROUND... C THIS AVOIDS POSSIBLE NEG NUMBER PROBLEMS IN OTHER PROGRAMS FOR C GRAPHS, ETC. LOGICAL*1 AVBLS(20,27),VBLS(8,RRWP,RCLP) REAL*8 XAC,ZAC EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26)) REAL*8 XXAC,XYAC EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25)) LOGICAL*1 ARGSTR(52,4) COMMON/ARGSTR/ARGSTR C EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1)) C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS. C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND. EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1)) EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN COMMON/KLVL/KLVL LOGICAL*1 DEFVB(12) COMMON/DEFVBX/DEFVB InTEgeR*4 FORMFG,RCFGX,PZAP,RCONE InTEgeR*4 RCMODE,IRCE1,IRCE2 COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1, 1 IRCE2 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(DRW) 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 DRW NOT DCL. REAL*8 DVS(DRW,DCL) INTEGER*4 LDVS(2,DRW,DCL) EQUIVALENCE(LDVS(1,1,1),DVS(1,1)) COMMON /FVLDC/FVLD InTEgeR*4 NCEL,NXINI COMMON/NCEL/NCEL,NXINI C LOGICAL*1 DFMTS(10,DRW,DCL) C 10 CHARACTERS PER ENTRY. COMMON/DSPCMN/DVS,CWIDS C 7952 FORMAT('Enter filename>') 7953 FORMAT(Q,128A1) 6950 FORMAT(80A1) 7978 FORMAT(I7) 7956 FORMAT(I3,',',9A1,',',I5) CLOSE(UNIT=4,ERR=7960) 7960 CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) C GET FILE NAME WRITE(6,7952) READ(IOLVL,7953,END=510,ERR=510)ILN,FORM2 ILN=MIN0(127,ILN) FORM2(ILN+1)=0 C SPECIAL "FAST READ" MODE TO SET UP DATA AREAS ON GETTING OLD SHEETS... NXINI=1 LDXM=INDEX(FORM2,'/') C IF FILE IS FILENAME/M WE WON'T DO IT FAST... IF(LDXM.LE.0.OR.LDXM.GE.ILN)GOTO 8400 FORM2(LDXM)=0 C TERMINATE AFTER THE / AND SET NXINI TO 0 AGAIN NXINI=0 8400 CONTINUE IBIN=0 if(cmdlin(2).eq.'B')IBIN=1 If(Ibin.eq.0) 1 OPEN(UNIT=4,FILE=FORM2,CARRIAGECONTROL='LIST', 1 ACCESS='SEQUENTIAL',RECL=512, 1 STATUS='OLD',ERR=9990) If(Ibin.eq.1) 1 OPEN(UNIT=4,FILE=FORM2,form='unformatted', 1 ACCESS='SEQUENTIAL',RECL=512, 1 STATUS='OLD',ERR=9990) C CALL ASSIGN(4,FORM2) IIVV=MIN0(DCL,15) If(Ibin.eq.0) 1 READ(4,6951,END=7964,ERR=7964)NMSH,ICREF,IRREF, 1 (CWIDS(III),III=1,IIVV),DRWV,DCLV If(Ibin.eq.1) 1 READ(4,END=7964,ERR=880)NMSH,ICREF,IRREF, 1 (CWIDS(III),III=1,IIVV),DRWV,DCLV 880 CONTINUE C NOW FILL IN DEFAULTS IF NEEDED C THIS IS SO THAT OLDER SAVED SHEETS WILL STILL WORK. C NOTE ZERO REFLECTION PARAMETERS ARE NOT LEFT ALONE C BUT TREATED AS ERRORS. IF(ICREF.LE.0.OR.ICREF.GT.RRW)ICREF=RRW/10 IF(IRREF.LE.0.OR.IRREF.GT.RCL)IRREF=RCL/10 DO 6954 III=1,IIVV IF(CWIDS(III).LE.0.OR.CWIDS(III).GT.99)CWIDS(III)=10 6954 CONTINUE IF(DRWV.LE.0.OR.DRWV.GT.DRW)DRWV=MXCOLS IF(DCLV.LE.0.OR.DCLV.GT.DCL)DCLV=MXROWS 6951 FORMAT(80A1,80I3) C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) if(Ibin.eq.1)Goto 662 WRITE(6,7982) 6977 FORMAT('Enter max. displ down to restore or 0 for all>') READ(IOLVL,7978,END=510,ERR=510)LDXM CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) WRITE(6,6977) 7982 FORMAT('Enter max. displ right to restore or 0 for all>') READ(IOLVL,7978,END=510,ERR=510)MDXM CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) WRITE(6,7984) 7983 FORMAT('Enter min. displ. down (1 or more)>') READ(IOLVL,7978,END=510,ERR=510)LLDXM CALL UVT100(CUP,LLCMD,1) CALL UVT100(EL,2) WRITE(6,7983) 7984 FORMAT('Enter min. displ. right (1 or more)>') READ(IOLVL,7978,END=510,ERR=510)MMDXM 662 continue IF(MDXM.LE.0)MDXM=12000 LLDXM=MAX0(1,LLDXM) MMDXM=MAX0(1,MMDXM) IF(LDXM.LE.0)LDXM=12000 C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER. IF(CMDLIN(4).EQ.'+'.OR.CMDLIN(4).EQ.'-')RCFGX=1 C IF ADDING OR SUBTRACTING OTHER SHEETS GO TO RECALC MANUAL C MODE... THIS PREVENTS MESSUP OF SUMS AS GOTTEN IN... 7961 CONTINUE C ENSURE THE FORM ARRAYS ARE CLEAR BEFORE FILLING THEM IN. DO 8961 N=1,128 FORM(N)=0 FORM2(N)=0 8961 CONTINUE If(Ibin.eq.0) 1 READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV), 1 IV=1,110) If(Ibin.eq.1) 1 READ(4,END=7964,ERR=881)LET1,IRRW,ICCL,(FORM2(IV), 1 IV=1,110) 881 CONTINUE 7962 FORMAT(A1,I5,X,I5,X,128A1) if(ibin.eq.1)goto 4496 DO 4497 IV=1,110 IVV=111-IV IF(FORM2(IVV).GT.32)GOTO 4496 FORM2(IVV)=0 4497 CONTINUE 4496 CONTINUE C ABOVE LOOP ENSURES THAT EXTRA PARTS OF BUFFER NOT IN SAVE FILE ARE C ZEROED ON READIN. If(Ibin.eq.0) 1 READ(4,7956,END=7964,ERR=7964)FORM2(119),(FORM2(IV),IV=120,128), 1 KKTYP If(Ibin.eq.1) 1 READ(4,END=7964,ERR=882)FORM2(119),(FORM2(IV),IV=120,128), 1 KKTYP 882 CONTINUE IF(LET1.EQ.77) GOTO 6500 C 77 IS ASCII 'M'. INDICATES NOW RESTORING NRDSP AND NCDSP C MAPPINGS... C NOTE WE USE THE REGULAR READ LOOP TO GRAB THIS STUFF, BUT C FLAG THE RECORDS WITH SPECIAL CHARACTERS AND ALSO ADD C 64000 TO THE ROW AND COLUMN NUMBERS BEING SAVED TO C KEEP FOLLOW ON PROGRAMS FROM GETTING MESSED UP. IF(FORM2(119).EQ.2)FORM2(119)=3 IF(FORM2(119).EQ.-2)FORM2(119)=-3 IF(IRRW.LE.0.OR.ICCL.LE.0)GOTO 9990 IF(IRRW.GT.LDXM.OR.ICCL.GT.MDXM)GOTO 7961 IF(IRRW.LT.LLDXM.OR.ICCL.LT.MMDXM) GOTO 7961 C PRODUCE NEW ADDRESSES IN PHYSICAL SHEET USING SAVED FILE'S ONES C AND CURSOR LOCATION (SINCE WE SAVE/RESTORE RELATIVE TO CURSOR). C THIS PROVIDES A SHEET PARTIAL SAVE / MERGE CAPABILITY. NR=IRRW+PROW-LLDXM NC=ICCL+PCOL-MMDXM IF(CMDLIN(2).NE.'D'.AND.LET1.NE.68)GOTO 7963 C 68 = D ASCII (UPPERCASE) IF(CMDLIN(2).EQ.'P'.OR.CMDLIN(2).LE.' ')GOTO 7963 C GET DISPLAY VERSION... C THIS IS THE DEFAULT MODE IF THE SAVE WAS PD... OR IF THE COMMAND C IS GD... BUT WILL BE OVER-RIDDEN IF THE COMMAND IS GP... EXPLICITLY. LRR=IRRW+DROW-LLDXM LCC=ICCL+DCOL-MMDXM LRR=MAX0(1,LRR) LCC=MAX0(1,LCC) IF(LRR.GT.DRWV.OR.LCC.GT.DCLV)GOTO 7961 NR=NRDSP(LRR,LCC) NC=NCDSP(LRR,LCC) 7963 CONTINUE C HANDLE LET1=112 (LOWERCASE P) ALSO SINCE THAT'S NUMERIC SAVE STUFF C IRX=(NC-1)*RRW+NR CALL REFLEC(NC,NR,IRX) IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961 FORM2(118)=15 DO 7113 IVV=1,128 7113 FORM(IVV)=FORM2(IVV) INRW=PROW INCL=PCOL JOUTR=1 JOUTC=2 C A1 = OUTPUT COORDS JRTR=1 JRTC=1 C GXR COMMAND RELOCATES INPUT CELLS. BASICALLY DESIGNED FOR RELOC C OF PHYSICAL CELL ADDRESSES; OPERATION WITH DISPLAY COORDS NOT C GUARANTEED... IF(CMDLIN(3).EQ.'R')CALL RELVBL(FORM,FORM2,JOUTR,JOUTC, 1 INRW,INCL,JRTR,JRTC) C ALLOW RELOCATION ON THE WAY IN FOR SAVED FILE FORMULAS. CALL FVLDST(NR,NC,FORM2(119)) C FVLD(NR,NC)=FORM2(119) CALL TYPSET(NR,NC,KKTYP) C TYPE(NR,NC)=KKTYP C IF THIS IS THE VALUE RECORD OF A CELL, DON'T STORE IN FORMULA C STORAGE. DO HOWEVER SET IT IN THE VALUE STORAGE. SINCE THE REST C OF THE RECORDS ARE THE SAME, WE KNOW FVLD BITS ARE SET UP OK C EVEN THOUGH THEY GET RESET TO THE SAME VALUES AGAIN WHEN C STORING THE FORMULA. IF(LET1.NE.112)CALL WRKFIL(IRX,FORM2,1) C WRITE(7'IRX)FORM2 IF(LET1.NE.112)GOTO 7961 C IF WE HAVE LOWERCASE 'P' THEN SET THE VALUE ALSO SINCE WE C WILL RESET THE REST NEXT RECORD. if(Ibin.eq.1)xvbls(1,1)=r8s if(Ibin.eq.0)DECODE(35,6408,FORM2(1),ERR=7961)XVBLS(1,1) 6408 FORMAT(D30.19) If(Cmdlin(4).ne.'-'.And.Cmdlin(4).ne.'+') Goto 982 CALL XVBLGT(NR,NC,R8WK) IF(CMDLIN(4).EQ.'+')XVBLS(1,1)=XVBLS(1,1)+R8WK IF(CMDLIN(4).EQ.'-')XVBLS(1,1)=R8WK-XVBLS(1,1) C IMPLEMENT ADD/SUBTRACT WHOLE SHEETS ON READ-IN C GPR+ ADDS, GPR- SUBTRACTS. (FOR EXAMPLE). CALL XVBLST(NR,NC,XVBLS(1,1)) C THAT SAVES THE VALUE BACK; NOW GET NEXT RECORD. 982 Continue GOTO 7961 6500 CONTINUE C HERE RESTORE MAPPINGS; DONE WITH NORMAL VALUES ETC. C MAPPING FLAGGED WITH "M" INITIAL LETTER OF FIRST C LINE AND COLUMN NUMBERS TOO LARGE BY 64000 IRRW=IRRW-64000 ICCL=ICCL-64000 C ADDED 64000 TO THESE BEFORE SAVE; RESTORE THEM HERE. C JUST RESTORE NRDSP AND NCDSP USING FORM2 ARRAY TO HOLD C NUMBERS. IF(IBIN.EQ.0) 1 DECODE(14,6501,FORM2(1),ERR=7961)II,III IF(IBIN.EQ.1) 1 II=I4S IF(IBIN.EQ.1) 1 III=I4T 6501 FORMAT(2I7) NRDSP(IRRW,ICCL)=II NCDSP(IRRW,ICCL)=III GOTO 7961 C JUST USE REGULAR LOOP TO READ THIS... 7964 CONTINUE CLOSE(UNIT=4,ERR=9990) 9990 NXINI=0 RETURN 510 CONTINUE IRTN=1 NXINI=0 RETURN END