SUBROUTINE NUMIO(X,MAXPTS,MAXCOL,LINES,MODE) C Version 02.20 FORCE Q,A C X=INPUT/OUTPUT array, dimensioned as below C MAXPTS=max. number of input data points C MAXCOL=total number of input columns C LINES=Number of lines of data entered C MODE=Control arg. If=0, don't allow read/write, erase, C insert or delete. Also don't erase screen on entry, C or print instructions. C IF<0 erase screen, but don't print instructions C IF>0 function as usual. C The TEST array contains the ADE values of all valid input C commands in the following order: C TEST# Character Value DEC(OCT) Function C 1 Cursor U 139(213) Cursor control C 2 Cursor D 138(212) " " C 3 Cursor L 136(210) " " C 4 Cursor R 140(214) " " C 5 ^Z 154(232) End Edit, return C 6 CR 141(215) Close input, and Cur. R C 7 ^D 132(204) Delete cursor line C 8 ^I 137(211) Insert above cursor line C 9 ^R 146(222) Read from input file C 10 ^E 133(205) Zero buffer C 11 ^W 151(227) Write C 12 R1-R2-C^S 147(223) Total of ROW 1-ROW 2 C 13 VAL/ 175(257) Divide col by val. C 14 C1-C2^X 152(230) Exchange Col1-Col2 C 15 VAL* 170(252) Scale col. by VAL C 16 VAL+ 171(253) Add to col. C 17 L<-C>@ 192(300) Cursor to Line<,Col.> C 18 E 197(305) Exponent in entry mode C 19 e 229(345) Ditto C 20 Cursor L 136(210) Rubout in entry mode C 21 RUBOUT 255(377) Another rubout C 22 SPACE 160(240) Looks like CR in entry mode C 23 COMMA 172(254) Ditto C 24 Cursor R 140(214) Ditto C 25 - 173(255) For numeric entry C 26 . 174(256) For numeric entry DIMENSION X(MAXPTS,MAXCOL),FNUM(3) COMMON /STRFUN/IPTR,ITEXT(44) COMMON /FILES/ FILE(3) INTEGER UP,YES,ERROR,ESCAPE,SCREEN,HOME,ERASE,END, 1 RUBOUT,COLUMN,CR,TERM,SPACE,TEST(26),UPPER LOGICAL KFLAG DATA YES,ERASE,HOME,RUBOUT/217,154,158,255/ C Number: 1 2 3 4 5 6 7 8 9 10 11 12 C Function: CUP,CDN,LFT,RHT, ^Z, CR, ^D, ^I, ^R, ^E, ^W, ^S C Octal: 213,212,210,214,232,215,204,211,222,205,227,223 DATA TEST /139,138,136,140,154,141,132,137,146,133,151,147, 1 175,152,170,171,192,197,229,136,255,160,172,140, 1 173,174/ C Octal: 257,230,252,253,300,305,345,210,377,240,254,214 C Function: / , ^X, * , + , @ , E , e ,LFT,RUB, SP,COM,RHT C Number: 13 14 15 16 17 18 19 20 21 22 23 24 DATA NEWLN,SPACE,ESCAPE,TEE/159,160,155,84/ DATA KFLAG /.T./,TERM/13/ EQUIVALENCE (TEST(6),CR),(TEST(3),LEFT),(TEST(1),UP), 1 (TEST(4),RIGHT),(TEST(16),PLUS),(TEST(17),SLASH) EQUIVALENCE (FNUM(1),LOWER),(FNUM(2),UPPER),(FNUM(3),INCOL), 1 (FNUM(1),FLOWER) IF(MODE.NE.0)GOTO 100 LIMIT1=6 LIMIT2=17 GOTO 120 100 LIMIT1=12 LIMIT2=11 IF(MODE.LT.0)GOTO 740 CALL WRKEY(ERASE) WRITE(0,110) 110 FORMAT(//// 1 ' USE CURSOR CONTROLS TO LOCATE ENTRY.'// 1 ' ^D ---------- DELETE LINE'/ 1 ' ^I----------- INSERT LINE'/ 1 ' CLR SPACE --- RETURN'/ 1 ' ^E ---------- ERASE DATA SET'/ 1 ' ^R ---------- READ FILE'/ 1 ' ^W --- WRITE FILE'/ 1 ' L<-C>@ ------ CURSOR TO LINE<,COL>'/ 1 ' C1-C2^X ----- EXCHANGE C1 AND C2'/ 1 ' VAL* -------- MULT COL BY "VAL"'/ 1 ' C1-C2<-C3>* - MULT C1 BY C2 '/ 1 ' VAL+ -------- ADD "VAL" TO COL'/ 1 ' C1-C2<-C3>+ - ADD C1 TO C2 '/ 1 ' VAL/ -------- DIV COL BY "VAL"'/ 1 ' C1-C2<-C3>/ - DIV C1 BY C2 '/ 1 ' L1-L2<-C>^S - SUM FROM L1-L2 '// 1 ' HIT ANY KEY TO CONTINUE!'$ CALL RDKEY(ERROR) GOTO 740 C Here to refresh the screen. Home the cursor, and write C the first 25 lines (or less) on the screen 120 CALL WRKEY(HOME) 130 LINE=1 !Set array line COLUMN=1 !Also column 140 IF(LINES.EQ.0)GOTO 160 !No Defined lines UPPER=12+LINE !Compute index to last line IF(UPPER.LT.24)UPPER=24 !Always fill page if we can IF(LINES.LT.UPPER)UPPER=LINES !Saftey for upper limit LOWER=UPPER-23 !Define first line IF(LOWER.LE.0)LOWER=1 !Saftey for lower limit SCREEN=LINE-LOWER+1 !Define cursor location DO 150 LOWER=LOWER,UPPER !Write lines LOWER to UPPER WRITE(0,340)LOWER,(X(LOWER,J),J=1,MAXCOL) 150 IF(LOWER.LT.UPPER.AND.MAXCOL.LT.7)CALL WRKEY(NEWLN)!New line code GOTO 360 160 WRITE(0,170)LINE SCREEN=1 170 FORMAT('+',I3$ C Here to turn input stream over to command processor 180 ASSIGN 200 TO GOTCHR !Here for initial character CALL WRKEY(SPACE) !space for attractive result C Here to pick characters off the keyboard 190 CALL RDKEY(ERROR) GOTO GOTCHR !220 or 260 C Test character for one of the possible control inputs 200 DO 210 I=1,LIMIT1 !6 if MODE 0, 12 if not. IF(ERROR.EQ.TEST(I)) 1 GOTO(470,400,460,350,880,350,540,560,610,730,670,810),I C FUNCTION: CUP,CDN,LFT,RHT, ^Z, CR, ^D, ^I, ^R, ^E, ^W, ^T 210 CONTINUE C We fall out the bottom if none of them match. C Then test for entry into numeric entry mode. 171=253 octal, C 185=271 octal. These comprise the following characters: C +,-./0123456789 C These characters all set numeric input mode, except SLASH IF(ERROR.LT.PLUS.OR.ERROR.GT.185.OR.ERROR.EQ.SLASH)GOTO 190 C Here to enter numeric entry mode: ASSIGN 290 TO NUMB !Set for ARRAY input 220 ASSIGN 250 TO GOTCHR !Found a number IPTR=1 !Init. buffer pointer DO 230 I=1,11 !11 spaces to ZAP old entry 230 CALL WRKEY(SPACE) DO 240 I=1,11 !Then 11 backspaces 240 CALL WRKEY(LEFT) IF(ERROR.EQ.PLUS)GOTO 280 !First "+" not command 250 IF(ERROR.GE.176.AND.ERROR.LE.185.OR.ERROR.EQ.CR)GOTO 280 DO 260 I=LIMIT2,26 !Filter characters IF(ERROR.NE.TEST(I))GOTO 260 !Doesn't match, try another IF(I.LE.17)GOTO 890 !All commands with arguments GOTO(280,280,500,500,270,270,270,280,280),I-17 C Function: E , e ,RUB,RUB, CR, CR, CR, - , . 260 CONTINUE C If we fall out the bottom, ignore the character GOTO 190 !Allow "+" through C Here on all CR equivalents 270 ERROR=CR 280 CALL WRKEY(ERROR) !Echo character CALL PUTWRD(ITEXT,IPTR,ERROR) !Char. into input buffer IPTR=IPTR+1 !Bump character if legal char. IF(ERROR.NE.CR)GOTO 190 !Next char. if not CR IPTR=1 !Set for input GOTO NUMB C Here for input numbers 290 CALL NUMBR(ITEXT,IPTR,X(LINE,COLUMN),TERM) 300 ASSIGN 320 TO RETRN IF(LINE.LE.LINES)GOTO 370 !Position cursor LINES=LINE !Stretch out one line DO 310 I=1,MAXCOL !Zero rest of fresh line 310 IF(I.NE.COLUMN)X(LINE,I)=0. GOTO 370 !Position cursor 320 WRITE(0,330)X(LINE,COLUMN) !Reformat number on screen 330 FORMAT('+',1P7E11.3$ 340 FORMAT('+',I3,1P7E11.3$ Cursor functions **************************** C Here for cursor right 350 IF(COLUMN.EQ.MAXCOL)GOTO 390 !Do cursor down COLUMN=COLUMN+1 !Next col. position 360 ASSIGN 380 TO RETRN 370 CALL WRKEY(ESCAPE) !Position cursor CALL WRKEY(189) CALL WRKEY(SCREEN+31) CALL WRKEY(COLUMN*11+24) GOTO RETRN 380 IF(KFLAG)GOTO 180 IF(TERM.NE.13)GOTO 290 !13=CR with no parity C Here for cursor down 390 COLUMN=1 !Entry from Cursor right 400 IF(LINE-LINES)420,410,530 !Can't go past end either 410 IF(MODE.EQ.0)GOTO 530 !Keeps cursor behaved 420 IF(LINE.GE.MAXPTS)GOTO 530 !Limit is MAXPTS entrys ASSIGN 440 TO RETRN LINE=LINE+1 !Allows empty last line IF(SCREEN.GE.24)GOTO 430 !Can't roll past end of screen SCREEN=SCREEN+1 !Bump screen pointer GOTO 370 !Position cursor 430 CALL WRKEY(NEWLN) !Must bump line off of top IF(LINE.LE.LINES)GOTO 490 !Write next entry COLUMN=1 440 IF(LINE.LE.LINES.OR.COLUMN.NE.1)GOTO 450 CALL WRKEY(CR) WRITE(0,340)LINE 450 IF(KFLAG)GOTO 530 !Back to KBD GOTO 640 !Or Read new line from file C Here for cursor left 460 COLUMN=COLUMN-1 !Back up COL number IF(COLUMN.GT.0)GOTO 530 !Position cursor COLUMN=MAXCOL !New col position ASSIGN 470 TO RETRN !ready for cursor up GOTO 370 C Here for cursor up. 470 ASSIGN 180 TO RETRN IF(LINE.LE.1)GOTO 370 LINE=LINE-1 !Back up if line is there IF(SCREEN.EQ.1)GOTO 480 !Do line insert here SCREEN=SCREEN-1 GOTO 370 480 CALL WRKEY(ESCAPE) CALL WRKEY(197) !Insert line function 490 WRITE(0,340)LINE,(X(LINE,I),I=1,MAXCOL) GOTO 440 C Here for rubout 500 CALL WRKEY(LEFT) !Perform rubout operation IF(IPTR.LE.1)GOTO 510 CALL WRKEY(SPACE) CALL WRKEY(LEFT) 510 IPTR=IPTR-1 !Back up character pointer IF(IPTR.GT.0)GOTO 190 !Next character 520 WRITE(0,330)X(LINE,COLUMN) 530 ASSIGN 180 TO RETRN !Position cursor GOTO 370 !Reset cursor C Function section************************************* C Here for delete line 540 IF(LINE.GT.LINES)GOTO 190 !Line not defined COLUMN=1 !Set col 1 CALL WRKEY(ESCAPE) CALL WRKEY(210) !ESC R: Delete line DO 550 I=LINE,LINES !Do garbage collection DO 550 J=1,MAXCOL 550 X(I,J)=X(I+1,J) LINES=LINES-1 !Decrement line count C Now, we must bring a line in on the bottom J=LINE+24-SCREEN !Compute index to end of screen IF(J.GT.LINES)GOTO 190 !Do nix if no line there CALL WRKEY(HOME) !Home cursor CALL WRKEY(UP) !Bottom of page WRITE(0,340)LINE,(X(J,I),I=1,MAXCOL)!New line on screen GOTO 530 !reposition cursor C Here to insert line 560 IF(LINE.GT.LINES)GOTO 190 !Ignore if last line 570 IF(LINES.GE.MAXPTS)GOTO 190 !Also don't allow overflow C First make a suitable hole in the data set. I=LINES+1-LINE IF(I.EQ.0)GOTO 590 DO 580 I=1,LINES+1-LINE J=LINES+1-I DO 580 ERROR=1,MAXCOL 580 X(J+1,ERROR)=X(J,ERROR) 590 DO 600 I=1,MAXCOL 600 X(LINE,I)=0. LINES=LINES+1 COLUMN=1 CALL WRKEY(ESCAPE) CALL WRKEY(197) !E: Insert line ERROR=128 !Null character WRITE(0,170)LINE IF(KFLAG)GOTO 180 !Go get line from terminal GOTO 290 C Read operation ********************************* C Here for read file operation 610 IFUNC=2 !Set open function for USR ASSIGN 640 TO RETRN !Set up cursor control KFLAG=.F. !No KBD input now C Locate cursor at top of page for file request, and clear up line 620 CALL WRKEY(HOME) CALL WRKEY(ESCAPE) CALL WRKEY(TEE) !Erase line WRITE(0,630) 630 FORMAT('+ENTER FILENAME:'$ CALL RDLIN(0,ITEXT,ERROR) !Get file name from USER CALL FILNAM(ITEXT,-1,FILE,ERROR) C Now replace crapped out line CALL WRKEY(ESCAPE) CALL WRKEY(TEE) J=LINE-SCREEN+1 IF(LINES.GE.1)WRITE(0,340)J,(X(J,I),I=1,MAXCOL) CALL WRKEY(CR) CALL USR(9,FILE,IFUNC,ERROR) !Do file operation IF(ERROR.NE.0)GOTO 870 !File lookup/open error GOTO 370 !Go reposition CURSOR 640 CALL RDLIN(9,ITEXT,ERROR) !Read in a data line IPTR=1 !Set character pointer WRITE(0,650) !Crash possible line feed 650 FORMAT('+'$ IF(ERROR.GT.0)GOTO 570 !Line now in ITEXT KFLAG=.T. !File operation complete GOTO 190 C Here for limited file write operation. Lower and upper C bounds are already set 660 IF(LOWER.LE.0)LOWER=LINE !Current line if 0 IF(UPPER.LE.0)UPPER=LINE !Current line if 0 IF(UPPER.GT.LINES)UPPER=LINES IF(LOWER.GT.UPPER)LOWER=UPPER GOTO (680,800),I-10 !Enter write or total C Here for write entire file 670 LOWER=1 !set upper and lower bounds UPPER=LINES 680 IFUNC=3 !Open file function ASSIGN 690 TO RETRN !Set up cursor control GOTO 620 !Rest is same as read C Return here after file is set up, to write the data to C the file. 690 DO 700 I=LOWER,UPPER 700 WRITE(9,710)(X(I,J),J=1,MAXCOL) 710 FORMAT(1P6E11.3) WRITE(9,720) 720 FORMAT(/$ CALL USR(9,FILE,4,ERROR) !Close file now GOTO 520 C Misc. Functions: C ^E: Erase data set 730 LINES=0 !Set all=0 740 CALL WRKEY(ERASE) GOTO 130 !Refresh screen C Here to move cursor to a given line. Target line and col. are C in LOWER and UPPER. 750 ASSIGN 760 TO RETRN GOTO 370 !Position cursor to old line 760 WRITE(0,330)X(LINE,COLUMN) !Fix damaged number I=LINE-SCREEN !Compute limits INCOL=I+24 !of lines on screen IF(LOWER.GE.LINES)LOWER=LINES !Can't pass last line IF(LOWER.GT.0)LINE=LOWER !Define new line # IF(UPPER.GT.0.AND.UPPER.LE.MAXCOL)COLUMN=UPPER IF(LINE.LE.I.OR.LINE.GT.INCOL)GOTO 790 SCREEN=LINE-I !Compute new screen line GOTO 530 !Position cursor to new line C Here for SWAP command. Upper and lower are set already. C check them for range. 770 IF(UPPER.GE.MAXCOL)UPPER=MAXCOL IF(UPPER.LE.0)UPPER=COLUMN IF(LOWER.LE.0)LOWER=COLUMN IF(LOWER.GE.UPPER)GOTO 790 !Don't swap with self DO 780 I=1,LINES ACUM=X(I,LOWER) X(I,LOWER)=X(I,UPPER) 780 X(I,UPPER)=ACUM 790 CALL WRKEY(ERASE) !fresh screen GOTO 140 !Go write it C Here for scale, add and total command. Input register usage C is as follows: C TOTAL COMMAND: LOWER= first row. UPPER= last row INCOL=Col.# C Scalar form: C SCALE COMMAND: ACUM= Multiplier C PLUS COMMAND: ACUM= Addend C DIV COMMAND: ACUM= Divisor C Answer col. is always the cursor col. C Col. Form C Lower=Multiplicand, addend, or dividend col. C Upper=Multiplier, addend, or divisor col. C Incol=answer col., or cursor col. if 0 800 ACUM=0.0 !Here if Total command ASSIGN 843 TO ARITH 805 IF(INCOL.LE.0)GOTO 830 !Current col. default IF(INCOL.GT.MAXCOL)INCOL=MAXCOL GOTO 840 !Enter loop 810 FLOWER=0.0 !For ^T with no args C Here if "*", "+", or "/" 820 IF(UPPER.NE.0)GOTO 860 ASSIGN 843 TO ARITH ACUM=FLOWER !Save input in ACUM LOWER=1 !Force limits UPPER=LINES !On plus and scale 830 INCOL=COLUMN !Define INCOL for indexing C Loop here to complete operation 840 DO 850 LOWER=LOWER,UPPER GOTO ARITH 843 XT=X(LOWER,INCOL) !Save indexing 844 GOTO(845,846,850,848,847),I-11 C ^S, / NOP * + 845 ACUM=ACUM+XT !Total operation GOTO 850 !Merge below 846 XT=XT/ACUM !Divide operation GOTO 850 !Merge below 847 XT=XT+ACUM !Plus operation GOTO 850 !Merge below 848 XT=XT*ACUM !Scale operation 850 X(LOWER,INCOL)=XT !Replace element IF(I.NE.12)GOTO 790 !If scale, plus or divide X(LINE,COLUMN)=ACUM !Store total value GOTO 300 !Go finish up input 860 ASSIGN 865 TO ARITH !Fix up to get nums. loaded ERROR=LOWER !Set 1st input col IF(ERROR.LE.0)ERROR=COLUMN !default col. IF(ERROR.GE.MAXCOL)ERROR=MAXCOL !default col. IARITH=UPPER !Ditto for second col IF(IARITH.GE.MAXCOL)IARITH=MAXCOL LOWER=1 !Force limits UPPER=LINES !On plus and scale GOTO 805 !Go test INCOL value C Here when operating on col. Get the appropriate numbers into C ACUM and XT 865 ACUM=X(LOWER,IARITH) !Load second col. XT=X(LOWER,ERROR) !Load first col. GOTO 844 !Loop back for operation C Here if FILE I-O error 870 CALL WRKEY(ERASE) CALL USRER(ERROR) KFLAG=.T. !Go set KFLAG and return CALL RDKEY(ERROR) !Wait for response GOTO 770 !Refresh screen at C1;L1 880 RETURN C Here to get numbers in registers. Leave register 0 if no C number specified. 890 UPPER=0 INCOL=0 CALL PUTWRD(ITEXT,IPTR,CR) !C.R. into input buffer IPTR=1 !reset IPTR DO 900 ERROR=1,3 !Up to 3 numbers CALL NUMBR(ITEXT,0,FNUM(ERROR),TERM) IF(TERM.EQ.13)GOTO 910 900 CONTINUE 910 GOTO(660,660,820,770,820,820,750),I-10 C Function: ^W, ^S, / , ^X, * , + , @ END