SUBROUTINE XQTCMD(ICODE) 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. PUBLIC DOMAIN. C with thanks to the DECUS library which provided the calculator C program on which this is based. 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 VNLT INTEGER*2 JNLFLG COMMON/JNLJNL/JNLFLG LOGICAL*1 LET1,LET2,FORM2(128),NMSH(80) COMMON/NMSH/NMSH LOGICAL*1 DEFVB(12) COMMON/DEFVBX/DEFVB INTEGER*2 JMVFG COMMON/FUBAR/JMVFG C COMMON FUBAR IS ONLY HERE TO GET THIS FLAG INTO OVERLAY ROOT. REAL*8 XVBLS(RRW,RCL) INTEGER*2 IC1POS,IC2POS COMMON/ICPOS/IC1POS,IC2POS INTEGER*2 IOLVL 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(RRW,RCL) LOGICAL*1 DFE 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 ==> NUMERIC CONST, COMPUTED. FVLD=3 ==> NUMERIC CONST, NOT COMP. 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*2 PROW,PCOL,DROW,DCOL,DRWV,DCLV COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP INTEGER*2 ILNFG,ILNCT,RCF LOGICAL*1 ILINE(106) COMMON/ILN/ILNFG,ILNCT,ILINE LOGICAL*1 OARRY(100) INTEGER*2 OSWIT,OCNTR COMMON/OAR/OSWIT,OCNTR,OARRY C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2 INTEGER*2 TYPE(RRW,RCL),VLEN(9) LOGICAL*1 AVBLS(100,27),VBLS(8,RRW,RCL) 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) 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)) INTEGER*4 JVBLS(2,RRW,RCL) EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN INTEGER*2 FORMFG,RCFGX,PZAP,RCONE COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE COMMON/KLVL/KLVL 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*2 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*2 THISRW,THISCL C 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 = TURN OFF AUTO REDRAW UNTIL A V IS SEEN. C C = COPY NUMBERS/FORMULAS/DISPLAY STUFF(FORMAT)/ALL 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 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 S = SAVE SHEET TO DISK (FORMULAS) 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. IRRX=(PCOL-1)*RRW+PROW 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 IRRX=(N2-1)*RRW+N1 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 IC1POS=N1 IC2POS=N2 CALL UVT100(CUP,ICCC,J+JVTINC) !SELECT ROW "THISCL", COL "J" CALL UVT100(SGR,7) IF(FVLD(N1,N2).EQ.0)WRITE(6,5538) 5538 FORMAT('>-<') C WE CAN BE SURE THE COLUMN IS 3 WIDE OR MORE... IF(FVLD(N1,N2).EQ.0)GOTO 200 C IRRX=(N2-1)*RRW+N1 C SELECT REVERSE VIDEO DO 5540 KKKK=1,100 5540 CMDLIN(KKKK)=32 READ(7'IRRX)FORM IF(FORM(120).LE.0)GOTO 200 IF(FVLD(N1,N2).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(119+KKK) C KKKK=DFMTS(KKK,THISRW,THISCL) 6301 DFE(KKK+1)=MAX0(32,KKKK) DFE(11)=32 DFE(1)='(' DFE(12)=')' IF(TYPE(N1,N2).EQ.2.AND.FVLD(N1,N2).GT.0) 1 ENCODE(100,DFE,CMDLIN)DVS(THISRW,THISCL) IF(TYPE(N1,N2).NE.2.AND.FVLD(N1,N2).GT.0) 1 ENCODE(100,DFE,CMDLIN)LDVS(1,THISRW,THISCL) C IF(FVLD(N1,N2).GT.0)ENCODE(100,DFE,CMDLIN) C 1 DVS(THISRW,THISCL) C REDRAW THIS COL. WITH REVERSE VIDEO HERE. 4320 WRITE(6,9000)(CMDLIN(II),II=1,CWIDS(THISRW)) 9000 FORMAT(128A1) CALL UVT100(SGR,0) C NOTE THIS REDRAWS PREVIOUS COL. IN REVERSE VIDEO. C NO CARRIAGE CTL 200 CONTINUE CALL UVT100(CUP,LDSPR,1) CALL UVT100(EL,2) IF(FORM(1).LE.0)GOTO 222 WRITE(6,9002)(FORM(II),II=1,110) 222 CALL UVT100(CUP,LCMDR,1) 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) WRITE(6,9001)(FORM(I),I=1,4),PCOL-1 9001 FORMAT(4A1,I4,'>') READ(IOLVL,9002,END=510,ERR=510)CMDLIN 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 THIS GETS COMMAND LINE IN. NOW ACTON IT. C REPOS'N TO OLD LINE NOW. CALL UVT100(CUP,LCMDR,1) C CC THE FOLLOWING COMMENTED OUT SECTION IMPLEMENTS THE ADDITIONAL FUNCTION OF CC JOURNALING: CC Command +J FILENAME will record all remaining CC line inputs at this point in it. (Assumes JNLFLG=0 initially) CC Command +N closes journal file. C K=K+1 C IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'J'.AND.JNLFLG.NE.1) C 1 GOTO 4290 C IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'N')GOTO 4292 C IF(JNLFLG.EQ.1)WRITE(10,9002)(CMDLIN(IV),IV=1,K) C GOTO 4291 C4292 CONTINUE C CLOSE(UNIT=10) C JNLFLG=0 C GOTO 9990 C4290 CONTINUE C JNLFLG=1 CC USE WHATEVER FILE NAME THE USER HAS SUPPLIED AFTER THE +J CC FOR FILE TO JOURNAL ONTO. (NO MORE QUESTIONS NEEDED.) C CALL ASSIGN(10,CMDLIN(3)) C GOTO 9990 C4291 CONTINUE CC CC C ALLOW COMMENTS IF LINE BEGINS WITH * (JUST LIKE CALC) IF(CMDLIN(1).EQ.'*')GOTO 9990 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,LCMDR,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 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=1 IF(XAC.GT.0.)REWIND IOLVL GOTO 9990 356 CONTINUE C C HANDLE @FILE COMMAND TO CHANGE TO INPUT OFF THAT FILE. IF(CMDLIN(1).NE.'@')GOTO 511 C WOW, A FILE. (OR AT LEAST SO WE HOPE). 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.'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 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 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 NOW CALL COPY LOOP AGAIN. 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 GOTO 9990 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. DO 652 IRO=LRO,DRWV DO 653 ICO=LCO,DCLV C HERE CAN SET UP NRDSP AND NCDSP SUITABLY NRDSP(IRO,ICO)=MIN0(ID1+IRO-LRO,RRW) NCDSP(IRO,ICO)=MIN0(ID2+ICO-LCO,RCL) 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. 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),'/') LB=LB+LA C LB= LOC OF / CHARACTER LB=MIN0(80,LB) IF(LB.LE.2)GOTO 1741 CMDLIN(LB)=0 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... FVLD(ID1,ID2)=-1 IRX=(ID2-1)*RRW+ID1 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) 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) IRX=(PCOL-1)*RRW+PROW C FIND WHERE IN FILE TO STORE. 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 DO 7902 N=1,LE C LOOK FOR ALPHAS. IF WE FIND ANY, FLAG NOT NUMERIC 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 FORM(N)=CMDLIN(LA) IF(CMDLIN(LA).GT.32)NALF=NALF+1 LA=LA+1 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 IVVVV=FORM(119) IF(IVVVV.NE.0)FORM(119)=ISGN(IVVVV)*NXNUM IF(NALF.GT.0)FVLD(PROW,PCOL)=FORM(119) IF(NALF.GT.0)WRITE(7'IRX)FORM ASSIGN 7904 TO NBK GOTO 7905 C LOOK UP PROW, PCOL, LEAVE DISPLAY COORDS IN LR,LC 7905 CONTINUE DO 7906 LA1=1,DRW LR=LA1 DO 7906 LA2=1,DCL 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. IF(JMVFG.EQ.51)THISRW=MAX0(1,(THISRW-1)) IF(JMVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV) IF(JMVFG.EQ.49)THISCL=MAX0(1,(THISCL-1)) 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)=.0000000057 DVS(DROW,DCOL)=.000000062 7901 GOTO 9990 8000 IF(CMDLIN(1).NE.'M')GOTO 8001 C MOVE COMMAND C M1,M2,M3,M4 MOTION DIRECTION IS U,D,L,R JMVFG=CMDLIN(2) C STORE CHARACTER AS MOVE FLAG ICODE=1 GOTO 9990 8001 IF(CMDLIN(1).NE.'D')GOTO 8002 C DISPLAY COMMANDS C UNCOMMENT THE DS COMMAND BELOW IF THERE IS ROOM FOR IT... CC CC DISPLAY SORT CC DSRA 1 CC DS = CONSTANT KEYWORD CC R/C=ROW/COL (DISPLAY COORD #S) CC A/D=ASCENDING/DESCENDING ORDER CC NUMBER= DISPLAY COORD ROW/COL # TO SORT ON. CC SORTS NUMERIC FIELDS ONLY. C IF(CMDLIN(2).NE.'S')GOTO 1752 C ICODE=2 CC MUST REDRAW. WE DO WHOLESALE RELOCATIONS OF THINGS HERE. CC FIRST GET ARGUMENTS C LAA=6 C LBB=15 C CALL GN(LAA,LBB,NBR,CMDLIN) CC THIS EXTRACTS THE NUMBER OF ROW/COL TO USE. CC DEFAULT IS PHYS, COL, ASCENDING C IF(NBR.LE.0.OR.NBR.GT.MAX0(DRW,DCL))GOTO 9990 C SSIGN=1. C IF(CMDLIN(4).EQ.'D')SSIGN=-1. CC SSIGN USED TO CONTROL ASCENDING/DESCENDING SORT (MULTIPLY BY IT) CC GET LENGTH TO GO THRU IN SORT C IF(CMDLIN(3).EQ.'C')IDELTA=DCL-1 C IF(CMDLIN(3).EQ.'R')IDELTA=DRW-1 C I1IN=0 C I2IN=1 CC GET PHYSICAL COORDINATES OF ROW/COL WE'RE SORTING ON. C IF(CMDLIN(3).NE.'R')ID1=NRDSP(NBR,1) C IF(CMDLIN(3).NE.'R')ID2=NCDSP(NBR,1) C IF(CMDLIN(3).NE.'R')GOTO 1753 C ID1=NRDSP(1,NBR) C ID2=NCDSP(1,NBR) C I1IN=1 C I2IN=0 CC HACK TO HANDLE ROW/COL ALIKE C1753 CONTINUE C IFLIP=0 CC IFLIP = BUBBLESORT FLAG WE CHANGED SOMETHING CC (USE SIMPLE MINDED SMALL SORT. TOO MUCH OVHD FOR BETTER ONE...NO ROOM) C ID1A=ID1 C ID2A=ID2 CC IGNORE CASE OF IDELTA=0... SHOULDN'T BE ANY WAY FOR THAT TO HAPPEN C DO 1754 IV=1,IDELTA CC SORT HERE. IFLIP=1 IF WE INVERT ANYTHING. CC JUST COMPARE XVBLS... CC NOTE WE ASSUME A "NORMAL" TYPE DISPLAY, JUST RESET PHYSICAL STUFF. C IF((XVBLS(ID1A,ID2A)*SSIGN).LE.(SSIGN*XVBLS(ID1+I1IN, C 1 ID2A+I2IN)))GOTO 1755 CC FLIP ASSIGNMENTS CC 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 C IFLIP=1 CC SWAP ASSIGNMENTS OF DISPLAY STUFF IF IN RANGE CC OPERATES LIKE A SORTED OA COMMAND CC CURRENT PHYSICAL ROW IS ID2A (1...RCL LIMITS) CC AND PHYS COL IS ID1A. C LDELTA=DRW-1 CC FOR REASSIGNMENT, ROLE OF I1IN,I2IN CAN BE REVERSED... C ID1B=1 CC NOTE DISPLAY ID2 IS 1 LESS THAN PHYSICAL ONE. (AC'S) C ID2B=ID2A-1 C IF(ID2B.LE.0)GOTO 1754 C IF(CMDLIN(3).NE.'R')GOTO 1756 CC ROW... C LDELTA=DCL-1 CC ID1 SAME AS DISPLAY COORDS C ID1B=ID1A C ID2B=1 C1756 CONTINUE C DO 1757 IVV=1,LDELTA CC FLIP THE ROW/COL 1 ENTRY AT A TIME. JUST CHANGES ASSIGNMENTS. C JD1=NRDSP(ID1B,ID2B) C JD2=NCDSP(ID1B,ID2B) C NRDSP(ID1B,ID2B)=NRDSP(ID1B+I1IN,ID2B+I2IN) C NCDSP(ID1B,ID2B)=NCDSP(ID1B+I1IN,ID2B+I2IN) C NRDSP(ID1B+I1IN,ID2B+I2IN)=JD1 C NCDSP(ID1B+I1IN,ID2B+I2IN)=JD2 C ID1B=ID1B+I2IN C ID2B=ID2B+I1IN C1757 CONTINUE CC WE CAN ALWAYS FLIP SINCE WE STAY ON DISPLAY SHEET. C1755 CONTINUE C ID1A=ID1A+I1IN C ID2A=ID2A+I2IN C1754 CONTINUE CC DONE 1 PASS. IF ANYTHING CHANGED, TRY AGAIN. C IF(IFLIP.NE.0)GOTO 1753 CC DONE SORT AT END C GOTO 9990 C1752 CONTINUE CC 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=2 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)=-1.E24 C THISRW=IR C THISCL=IC JRX=(ID2-1)*RRW+ID1 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,8) DO 8114 LN=1,IDELT C IDELT IS OVER VRBL LIST GIVEN. MAY BE 1 ONLY. IRRX=(ID2-1)*RRW+ID1 READ(7'IRRX)FORM DO 7989 KKKK=1,8 7989 FORM(119+KKKK)=0 DO 8115 LNA=1,LDELT FORM(LNA+119)=CMDLIN(LA-1+LNA) FORM(LNA+120)=0 8115 CONTINUE FORM(128)=0 DVS(ID1,ID2)=-1.1E-22 IVVVV=FVLD(ID1,ID2) FVLD(ID1,ID2)=MAX0(1,IABS(IVVVV)) IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')FVLD(ID1,ID2)= 1 MIN0(-1,-IABS(IVVVV)) IF(CMDLIN(LA).EQ.'I')TYPE(ID1,ID2)=4 IF(CMDLIN(LA).EQ.'F'.OR.CMDLIN(LA).EQ.'E')TYPE(ID1,ID2)=2 FORM(119)=FVLD(ID1,ID2) 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(FVLD(ID1,ID2).LE.0)GOTO 7990 DO 7988 KKK=1,9 KKKK=FORM(119+KKK) 7988 DFE(KKK+1)=MAX0(32,KKKK) DFE(11)=32 DFE(1)='(' DFE(12)=')' IF(TYPE(N1,N2).EQ.2.AND.FVLD(N1,N2).GT.0) 1 ENCODE(100,DFE,FORM2)DVS(THISRW,THISCL) IF(TYPE(N1,N2).NE.2.AND.FVLD(N1,N2).GT.0) 1 ENCODE(100,DFE,FORM2)LDVS(1,THISRW,THISCL) C IF(FVLD(N1,N2).GT.0)ENCODE(100,DFE,FORM2) C 1 DVS(THISRW,THISCL) 7990 CONTINUE C %%%%%% WRITE(7'IRRX)FORM DO 8116 NX1=1,DRW DO 8116 NX2=1,DCL IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8117 8116 CONTINUE GOTO 8118 8117 CONTINUE DVS(NX1,NX2)=-1.23E-12 C DO 8119 LNA=1,LDELT C DFMTS(LNA,NX1,NX2)=CMDLIN(LA-1+LNA) C DFMTS(LNA+1,NX1,NX2)=0 C8119 CONTINUE 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 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)=-1.211E-16 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=2 NCL=MAX0(1,NCL) NCL=MIN0(NCL,DRW) LCWID=MAX0(3,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=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.'F')FORMFG=1 IF(CMDLIN(2).EQ.'M')PZAP=1 ICODE=2 GOTO 9990 8003 IF(CMDLIN(1).NE.'C')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 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 FORCE REDRAW SINCE WE DON'T FILL IN DISPLAY QUANTITIES HERE. ICODE=2 C FORCE RECALC IF ONLY 1 SOURCE CELL. 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 ICODE=1 DO 8309 JV=1,JDELT DO 8380 NX1=1,DRWV DO 8380 NX2=1,DCLV IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8387 8380 CONTINUE GOTO 8388 8387 CONTINUE DVS(NX1,NX2)=1.245E-14 8388 CONTINUE JRXX=(JD1B-1)*RRW+JD1A IRXX=(ID2A-1)*RRW+ID1A READ(7'IRXX)FORM READ(7'JRXX)FORM2 IF(FORM2(119).EQ. 2)FORM2(119)= 3 IF(FORM2(119).EQ.-2)FORM2(119)=-3 IF(FORM(119).EQ. 2)FORM(119)= 3 IF(FORM(119).EQ.-2)FORM(119)=-3 IF(FVLD(ID1A,ID2A).EQ.-2)FVLD(ID1A,ID2A)=-3 IF(FVLD(ID1A,ID2A).EQ.2)FVLD(ID1A,ID2A)=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. WRITE(7'JRXX)FORM2 GOTO 8367 8366 CONTINUE WRITE(7'JRXX)FORM 8367 CONTINUE TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A) XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A) FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A) ID1A=ID1A+I1IN ID2A=ID2A+I2IN JD1A=JD1A+JIN1 JD1B=JD1B+JIN2 GOTO 8309 8310 CONTINUE IF(CMDLIN(2).NE.'V')GOTO 8312 TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A) XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A) 8312 IF(CMDLIN(2).NE.'D')GOTO 8313 FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A) DO 8315 LXQ=1,10 8315 FORM2(118+LXQ)=FORM(118+LXQ) WRITE(7'JRXX)FORM2 8313 IF(CMDLIN(2).NE.'F')GOTO 8314 DO 8316 LXQ=1,110 8316 FORM2(LXQ)=FORM(LXQ) 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=1 IF(CMDLIN(1).EQ.'3')THISRW=MAX0(1,(THISRW-1)) IF(CMDLIN(1).EQ.'4')THISRW=MIN0((THISRW+1),DRWV) IF(CMDLIN(1).EQ.'1')THISCL=MAX0(1,(THISCL-1)) IF(CMDLIN(1).EQ.'2')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 C RECOMPUTE SHEET. C RM COMMAND SETS MANUAL FLAG. RCFGX=0 RCONE=0 C FORCE RECALC IF NOT RM C IF(CMDLIN(2).NE.'M')RCONE=1 IF(CMDLIN(2).NE.'M'.AND.CMDLIN(3).NE.'F')RCONE=1 IF(CMDLIN(2).EQ.'M')RCFGX=1 ICODE=3 GOTO 9990 8008 IF(CMDLIN(1).NE.'K')GOTO 8009 C DROP INTO CALC BARE. C C FOR OVERLAY VERSION RETURN ICODE=25 TO FLAG SPREDSHT TO ICODE=25 C CALL CALC AND SET THINGS UP. COMMENT OUT CODE BELOW: C +++++++++++++++++++++++++++++++++++++++++++++++++++ C OSWIT=0 C ILNFG=0 C ICODE=-1 CC CLOSE UNIT 1 JUST IN CASE... C CLOSE(UNIT=1) C CALL UVT100(ED,2) C KLVL=1 C ILNCT=0 CC SAVE PROW,PCOL ACROSS CALC SINCE IT MAY NOW USE *P AND *W TO CC 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) C +++++++++++++++++++++++++++++++++++++++++++++++++++ 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 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 ICODE=1 GOTO 9990 8010 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,LDSPR,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) IF(FORM2(1).NE.'Y')GOTO 9990 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) C FORM2(120)='F' C FORM2(121)='9' C FORM2(122)='.' C FORM2(123)='2' DO 8956 NI=1,IDELT IRX=(ID2-1)*RRW+ID1 WRITE(7'IRX)FORM2 FVLD(ID1,ID2)=0 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)=1.E20 8958 CONTINUE ID1=ID1+I1IN ID2=ID2+I2IN 8956 CONTINUE GOTO 9990 8011 IF(CMDLIN(1).NE.'X')GOTO 8012 C EXIT TO OS CALL CLOSE(7) CALL EXIT 8012 IF(CMDLIN(1).NE.'S')GOTO 8013 C SAVE SHEET TO DISK (NEW SET OF DATA) ICODE=-2 ISTAT=-2 GOTO 9990 C C 8013 IF(CMDLIN(1).NE.'P')GOTO 8014 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 P/D RRR,CCC,FORMULA,VALID,FORMAT ICODE=1 CALL PSHT(CMDLIN,ICODE,FORM2,NMSH,JRTN) IF(JRTN.EQ.1)GOTO 510 IF(JRTN.EQ.2)GOTO 9990 C5413 FORMAT('P',I5,',',I5,',',I15) C5414 FORMAT('P',I5,',',I5,',',D35.19) C7958 FORMAT('D',I5,',',I5,',',128A1) GOTO 9990 8014 CONTINUE 8015 IF(CMDLIN(1).NE.'G')GOTO 8016 C GET INPUT NUMBERS OFF SEQUENTIAL FILE. USE CURRENT ORIGIN ICODE=2 CALL GSHT(CMDLIN,ICODE,FORM2,NMSH,JRTN) IF(JRTN.EQ.1)GOTO 510 IF(JRTN.EQ.2)GOTO 9990 ISTAT=2 GOTO 9990 8016 IF(CMDLIN(1).NE.'W')GOTO 8017 C WRITE (PRINT) SCREEN OUT TO FILE (MAY BE PRINTER) ICODE=26 C COMMENT THE FOLLOWING OUT: C CALL DSPSHT(10) C ICODE=1 C CODE 10 IS PRINT SECRET CODE TO DSPSHT. GOTO 9990 8017 CONTINUE IF(CMDLIN(1).NE.'H')GOTO 5019 IVVV=0 IVVVV=CMDLIN(2) IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48 ICODE=28+IVVV C MOVE HELP CALL DOWN C CALL HELP C WRITE(6,5020) C5020 FORMAT(/'Type return to continue.') C READ(IOLVL,8952,END=510,ERR=510)(FORM2(K),K=1,4) C ICODE=2 GOTO 9990 5019 CONTINUE WRITE(6,8018) 8018 FORMAT('Invalid Command.') 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) IOLVL=5 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) IRRX=(N2-1)*RRW+N1 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.OR.ICODE.EQ.25 1 .OR.(ICODE.GE.28.AND.ICODE.LE.37) 1 .OR.ICODE.EQ.26)GOTO 2000 C NO SENSE REDRAWING IF WE'RE ABOUT TO ERASE DISPLAY ANYWAY. 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 IC1POS=N1 IC2POS=N2 CALL UVT100(CUP,ICCC,J+JVTINC) !SELECT ROW "IXLSTC", COL "J" CALL UVT100(SGR,0) C DESELECT REVERSE VIDEO IF(FVLD(N1,N2).EQ.0)WRITE(6,5537) 5537 FORMAT(' ') IF(FVLD(N1,N2).EQ.0)GOTO 2000 C IF(FVLD(N1,N2).LT.0)READ(7'IRRX)FORM READ(7'IRRX)FORM DO 5546 KKKK=1,100 5546 CMDLIN(KKKK)=32 IF(FVLD(N1,N2).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(119+KKK) C KKKK=DFMTS(KKK,IXLSTR,IXLSTC) 6302 DFE(KKK+1)=MAX0(32,KKKK) DFE(11)=32 C 32 = ASCII SPACE DFE(1)='(' DFE(12)=')' IF(TYPE(N1,N2).EQ.2.AND.FVLD(N1,N2).GT.0) 1 ENCODE(100,DFE,CMDLIN)DVS(IXLSTR,IXLSTC) IF(TYPE(N1,N2).NE.2.AND.FVLD(N1,N2).GT.0) 1 ENCODE(100,DFE,CMDLIN)LDVS(1,IXLSTR,IXLSTC) C IF(FVLD(N1,N2).GT.0)ENCODE(100,DFE,CMDLIN) C 1 DVS(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) LI=1 LO=1 C LI = INPUT LOCATION C LO=OUTPUT LOCATION 100 CONTINUE LCC=LNIN(LI) IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200 L1=LI LE=110 LSTC=LE CALL VARSCN(LNIN,L1,LE,LSTC,ID1,ID2,IVLD) IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0 C SINGLE ALPHAS DON'T RELOCATE. 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.JRJR.OR.ID2.LT.JRTC)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. ID1=ID1+(JOUTR-INRW) ID2=ID2+(JOUTC-INCL) ID1=MAX0(ID1,1) ID2=MAX0(ID2,1) ID1=MIN0(RRW,ID1) ID2=MIN0(RCL,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 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 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. 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 LSA=ID2-1 LSB=ID3-1 LSSB=2+ID2 DO 1 N=1,LENGTH 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. INLIN=INLIN+LSA 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 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 PSHT(CMDLIN,ICODE,FORM2,NMSH,JRTN) INTEGER*2 ICODE LOGICAL*1 CMDLIN(132),FORM2(128),NMSH(80) INCLUDE 'VKLUGPRM.FTN' LOGICAL*1 FVLD REAL*8 XVBLS(RRW,RCL) DIMENSION FVLD(RRW,RCL) INTEGER*2 IOLVL COMMON/IOLVL/IOLVL INTEGER*2 PROW,PCOL,DROW,DCOL,DRWV,DCLV COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP INTEGER*2 TYPE(RRW,RCL),VLEN(9) LOGICAL*1 AVBLS(100,27),VBLS(8,RRW,RCL) REAL*8 XAC,ZAC EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26)) LOGICAL*1 ARGSTR(52,4) 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)) INTEGER*4 JVBLS(2,RRW,RCL) EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN COMMON /FVLDC/FVLD JRTN=0 CLOSE(UNIT=4,ERR=7954) 7954 CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) C ASK FOR FILE NAME WRITE(6,7952) 7952 FORMAT(' Enter filename>') READ(IOLVL,7953,END=510,ERR=510)ILN,FORM2 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 CALL ASSIGN(4,FORM2) WRITE(4,6950)NMSH 6950 FORMAT(80A1) C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) WRITE(6,7977) 7977 FORMAT(' Enter max. displ down to save or 0>') READ(IOLVL,7978,END=510,ERR=510)LDXM 7978 FORMAT(I7) CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) WRITE(6,7980) 7980 FORMAT(' Enter max. displ right to save or 0>') READ(IOLVL,7978,END=510,ERR=510)MDXM IF(MDXM.LE.0)MDXM=12000 LLDXM=MAX0(1,LLDXM) MMDXM=MAX0(1,MMDXM) IF(LDXM.LE.0)LDXM=12000 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).NE.'P')GOTO 7950 DO 7951 IRO=PROW,RRW DO 7951 ICO=PCOL,RCL C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY. IRX=(ICO-1)*RRW+IRO IDRO=IRO-PROW+1 IDCL=ICO-PCOL+1 IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951 C FORM DISPLACEMENT LOCATORS IF(FVLD(IRO,ICO).EQ.0)GOTO 7951 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 5402 C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER IF(ABS(TYPE(IRO,ICO)).EQ.4)WRITE(4,5403)IDRO,IDCL,JVBLS(1,IRO,ICO) 5403 FORMAT('P',I5,',',I5,',',I15) IF(ABS(TYPE(IRO,ICO)).NE.4)WRITE(4,5404)IDRO,IDCL,XVBLS(IRO,ICO) 5404 FORMAT('P',I5,',',I5,',',D35.19) GOTO 5405 5402 CONTINUE WRITE(4,7955)IDRO,IDCL,(FORM2(IV),IV=1,110) 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. DO 358 IV=120,128 358 IF(FORM2(IV).LT.' ')FORM2(IV)=32 WRITE(4,7956)FORM2(119),(FORM2(IV),IV=120,128),TYPE(IRO,ICO) 7956 FORMAT(I3,',',9A1,',',I5) 7951 CONTINUE CLOSE(UNIT=4) GOTO 9990 7950 IF(CMDLIN(2).NE.'D')GOTO 9990 DO 7957 IRO=DROW,DRW DO 7957 ICO=DCOL,DCL 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) IRX=(NC-1)*RRW+NR IF(FVLD(NR,NC).EQ.0)GOTO 7957 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(ABS(TYPE(NR,NC)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,NR,NC) 5413 FORMAT('P',I5,',',I5,',',I15) IF(ABS(TYPE(NR,NC)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(NR,NC) 5414 FORMAT('P',I5,',',I5,',',D35.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(NR,NC) 7957 CONTINUE CLOSE(UNIT=4) RETURN 510 JRTN=1 RETURN 9990 JRTN=2 RETURN END SUBROUTINE GSHT(CMDLIN,ICODE,FORM2,NMSH,JRTN) INTEGER*2 ICODE LOGICAL*1 CMDLIN(132),FORM2(128),NMSH(80) INCLUDE 'VKLUGPRM.FTN' REAL*8 XVBLS(RRW,RCL) LOGICAL*1 FVLD INTEGER*2 IOLVL COMMON/IOLVL/IOLVL DIMENSION FVLD(RRW,RCL) INTEGER*2 PROW,PCOL,DROW,DCOL,DRWV,DCLV COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV DIMENSION NRDSP(DRW,DCL),NCDSP(DRW,DCL) COMMON/D2R/NRDSP,NCDSP INTEGER*2 TYPE(RRW,RCL),VLEN(9) LOGICAL*1 AVBLS(100,27),VBLS(8,RRW,RCL) REAL*8 XAC,ZAC EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26)) LOGICAL*1 ARGSTR(52,4) 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)) INTEGER*4 JVBLS(2,RRW,RCL) EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1)) COMMON/V/TYPE,AVBLS,VBLS,VLEN COMMON /FVLDC/FVLD JRTN=0 CLOSE(UNIT=4,ERR=7960) 7960 CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) WRITE(6,7952) 7952 FORMAT(' Enter filename>') READ(IOLVL,7953,END=510,ERR=510)ILN,FORM2 7953 FORMAT(Q,128A1) 6950 FORMAT(80A1) ILN=MIN0(127,ILN) FORM2(ILN+1)=0 CALL ASSIGN(4,FORM2) READ(4,6950)NMSH C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) WRITE(6,6977) 6977 FORMAT(' Enter max. displ down to restore or 0>') READ(IOLVL,7978,END=510,ERR=510)LDXM 7978 FORMAT(I7) CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) WRITE(6,7982) 7982 FORMAT(' Enter max. displ right to restore or 0>') READ(IOLVL,7978,END=510,ERR=510)MDXM CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) WRITE(6,7983) 7983 FORMAT(' Enter min. displ. down>') READ(IOLVL,7978,END=510,ERR=510)LLDXM CALL UVT100(CUP,LCMDR,1) CALL UVT100(EL,2) WRITE(6,7984) 7984 FORMAT(' Enter min. displ. right>') READ(IOLVL,7978,END=510,ERR=510)MMDXM IF(MDXM.LE.0)MDXM=12000 IF(LDXM.LE.0)LDXM=12000 C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER. 7961 CONTINUE READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV), 1 IV=1,110) 7962 FORMAT(A1,I5,X,I5,X,128A1) READ(4,7956,END=7964,ERR=7964)FORM2(119),(FORM2(IV),IV=120,128), 1 KKTYP 7956 FORMAT(I3,',',9A1,',',I5) IF(FORM2(119).EQ. 2)FORM2(119)= 3 IF(FORM2(119).EQ.-2)FORM2(119)=-3 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(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 NR=IRRW+PROW-LLDXM NC=ICCL+PCOL-MMDXM IF(LET1.NE.68)GOTO 7963 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 IRX=(NC-1)*RRW+NR IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961 FORM2(118)=15 FVLD(NR,NC)=FORM2(119) TYPE(NR,NC)=KKTYP WRITE(7'IRX)FORM2 GOTO 7961 7964 CONTINUE RETURN 510 JRTN=1 RETURN 9990 JRTN=2 RETURN END