C C VT100 VIDEO DISPLAY COMMAND PROGRAM. CALLING SEQUENCE IS C CALL UVT100(CMD,N1,N2), WHERE CMD IS ONE OF THE COMMANDS IN C THE PARAMETER LIST BELOW, AND N1 AND N2 ARE OPTIONAL PARAMETERS C DEPENDING UPON CMD. SEE THE UVT100 USER'S MANUAL FOR MORE DETAILS. C C AUTHOR: GLEN HOFFING C DATE: 24-FEB-81 C SUBROUTINE UVT100(CMD, N1, N2,C1) IMPLICIT INTEGER(A - Z) BYTE C1 DIMENSION PRL(6) C CURSOR POSITION AND PRINT 1 CHARACTER C CURSOR POSITION REPORT C CURSOR UP C CURSOR DOWN C CURSOR FORWARD C CURSOR BACK C DOUBLE WIDTH LINE 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, CPP=19 BYTE OUTBUF(10),STORE(109) DATA ILEN/0/,ISTRT/1/ C SET FIRST CHARACTER TO 'ESCAPE' CODE 100 OUTBUF(1) = 27 DO 2000 I = 2, 10 OUTBUF(I) = 0 2000 CONTINUE IF (CMD .NE. CUP.AND.CMD .NE. CPP) GOTO 2020 C CURSOR POSITION OUTBUF(2) = '[' IF (.NOT.(N1 .GT. 0.AND.N1 .LT. 25)) GOTO 2040 C ...ROW N1 ENCODE(2, 10, OUTBUF(3)) N1 2040 CONTINUE OUTBUF(5) = ';' IF (.NOT.(N2 .GT. 0.AND.N2 .LT. 81)) GOTO 2060 C ...COLUMN N2 ENCODE(2, 10, OUTBUF(6)) N2 2060 CONTINUE OUTBUF(8) = 'H' LEN = 8 IF(CMD .EQ. CPP) THEN OUTBUF(9) = C1 LEN = 9 ENDIF GOTO 2030 2020 CONTINUE IF (.NOT.(CMD .EQ. CUB)) GOTO 2080 C CURSOR BACK OUTBUF(2) = '[' IF (.NOT.(N1 .GT. 0.AND.N1 .LT. 81)) GOTO 2100 C ...N1 COLUMNS ENCODE(2, 10, OUTBUF(3)) N1 2100 CONTINUE OUTBUF(5) = 'D' LEN = 5 GOTO 2030 2080 CONTINUE IF (.NOT.(CMD .EQ. CUD)) GOTO 2120 C CURSOR DOWN OUTBUF(2) = '[' IF (.NOT.(N1 .GT. 0.AND.N1 .LT. 25)) GOTO 2140 C ...N1 ROWS ENCODE(2, 10, OUTBUF(3)) N1 2140 CONTINUE OUTBUF(5) = 'B' LEN = 5 GOTO 2030 2120 CONTINUE IF (.NOT.(CMD .EQ. CUF)) GOTO 2160 C CURSOR FORWARD OUTBUF(2) = '[' IF (.NOT.(N1 .GT. 0.AND.N1 .LT. 81)) GOTO 2180 C ...N1 COLUMNS ENCODE(2, 10, OUTBUF(3)) N1 2180 CONTINUE OUTBUF(5) = 'C' LEN = 5 GOTO 2030 2160 CONTINUE IF (.NOT.(CMD .EQ. CUU)) GOTO 2200 C CURSOR UP OUTBUF(2) = '[' IF (.NOT.(N1 .GT. 0.AND.N1 .LT. 25)) GOTO 2220 C ...N1 ROWS ENCODE(2, 10, OUTBUF(3)) N1 2220 CONTINUE OUTBUF(5) = 'A' LEN = 5 GOTO 2030 2200 CONTINUE IF (.NOT.(CMD .EQ. DECDHL)) GOTO 2240 C DOUBLE-HEIGHT LINE OUTBUF(2) = '#' IF (.NOT.(N1 .EQ. 1)) GOTO 2260 C ...BOTTOM HALF OUTBUF(3) = '4' GOTO 2270 2260 CONTINUE C ...TOP HALF OUTBUF(3) = '3' 2270 CONTINUE LEN = 3 GOTO 2030 2240 CONTINUE IF (.NOT.(CMD .EQ. DECDWL)) GOTO 2280 C DOUBLE-WIDTH LINE OUTBUF(2) = '#' OUTBUF(3) = '6' LEN = 3 GOTO 2030 2280 CONTINUE IF (.NOT.(CMD .EQ. DECRC)) GOTO 2300 C RESTORE CURSOR OUTBUF(2) = '8' LEN = 2 GOTO 2030 2300 CONTINUE IF (.NOT.(CMD .EQ. DECSC)) GOTO 2320 C SAVE CURSOR OUTBUF(2) = '7' LEN = 2 GOTO 2030 2320 CONTINUE IF (.NOT.(CMD .EQ. DECSWL)) GOTO 2340 C SINGLE-WIDTH,SINGLE-HEIGHT LINE OUTBUF(2) = '#' OUTBUF(3) = '5' LEN = 3 GOTO 2030 2340 CONTINUE IF (.NOT.(CMD .EQ. ED)) GOTO 2360 C ERASE DISPLAY OUTBUF(2) = '[' IF (.NOT.(N1 .EQ. 0)) GOTO 2380 C ...CURSOR POSITION TO END OF SCREEN OUTBUF(3) = '0' GOTO 2390 2380 CONTINUE IF (.NOT.(N1 .EQ. 1)) GOTO 2400 C ...START OF SCREEN TO CURSOR POSITION OUTBUF(3) = '1' GOTO 2390 2400 CONTINUE C ...ENTIRE SCREEN OUTBUF(3) = '2' 2390 CONTINUE OUTBUF(4) = 'J' LEN = 4 GOTO 2030 2360 CONTINUE IF (.NOT.(CMD .EQ. EL)) GOTO 2420 C ERASE LINE OUTBUF(2) = '[' IF (.NOT.(N1 .EQ. 0)) GOTO 2440 C ...CURSOR POSITION TO END OF LINE OUTBUF(3) = '0' GOTO 2450 2440 CONTINUE IF (.NOT.(N1 .EQ. 2)) GOTO 2460 C ...ENTIRE LINE OUTBUF(3) = '2' C ...START OF LINE TO CURSOR POSITION GOTO 2450 2460 CONTINUE OUTBUF(3) = '1' 2450 CONTINUE OUTBUF(4) = 'K' LEN = 4 GOTO 2030 2420 CONTINUE IF (.NOT.(CMD .EQ. SGR)) GOTO 2480 C SELECT GRAPHIC RENDITION OUTBUF(2) = '[' IF (.NOT.(N1 .EQ. 7)) GOTO 2500 C ...REVERSE FIELD ON OUTBUF(3) = '7' GOTO 2510 2500 CONTINUE C ...REVERSE FIELD OFF OUTBUF(3) = '0' 2510 CONTINUE OUTBUF(4) = 'm' OUTBUF(5) = 8 LEN = 5 GOTO 2030 2480 CONTINUE IF (.NOT.(CMD .EQ. NEL)) GOTO 2520 C CURSOR TO NEW LINE OUTBUF(2) = 'E' LEN = 2 GOTO 2030 2520 CONTINUE IF (.NOT.(CMD .EQ. SCS)) GOTO 2540 C SELECT CHARACTER SET IF (.NOT.(N1 .EQ. 0)) GOTO 2560 C ...G0 CHARACTER SET OUTBUF(2) = '(' C ...G1 CHARACTER SET GOTO 2570 2560 CONTINUE OUTBUF(2) = ')' 2570 CONTINUE IF (.NOT.(N2 .EQ. 0)) GOTO 2580 C ...UNITED KINGDOM CHARACTER SET OUTBUF(3) = 'A' GOTO 2590 2580 CONTINUE IF (.NOT.(N2 .EQ. 1)) GOTO 2600 C ...ASCII CHARACTER SET OUTBUF(3) = 'B' C ...SPECIAL GRAPHICS SET GOTO 2590 2600 CONTINUE OUTBUF(3) = '0' 2590 CONTINUE LEN = 3 GOTO 2030 2540 CONTINUE IF (.NOT.(CMD .EQ. SM)) GOTO 2620 C SET MODE OUTBUF(2) = '[' OUTBUF(3) = '?' IF (.NOT.(N1 .GT. 0.AND.N1 .LT. 10)) GOTO 2640 C ...MODE TO SET ENCODE(1, 5, OUTBUF(4)) N1 2640 CONTINUE OUTBUF(5) = 'h' LEN = 5 GOTO 2030 2620 CONTINUE IF (.NOT.(CMD .EQ. RM)) GOTO 2660 C RESET MODE OUTBUF(2) = '[' OUTBUF(3) = '?' IF (.NOT.(N1 .GT. 0.AND.N1 .LT. 10)) GOTO 2680 C ...MODE TO RESET ENCODE(1, 5, OUTBUF(4)) N1 2680 CONTINUE OUTBUF(5) = 'l' LEN = 5 GOTO 2030 2660 CONTINUE IF (.NOT.(CMD .EQ. ANSI)) GOTO 2700 C ANSI MODE OUTBUF(2) = '<' LEN = 2 2700 CONTINUE 2030 CONTINUE C CONVERT ANY BLANKS TO ZEROES DO 2720 I = 1, LEN IF (OUTBUF(I) .EQ. ' ') OUTBUF(I) = 0 2720 CONTINUE IF(CMD .EQ. CPP) OUTBUF(9)=C1 GOTO 3500 ENTRY BUFFER(IFLAG) ITEMP = IFLAG IF(ITEMP .NE. 2) RETURN 3500 IF(ITEMP .EQ. 1) THEN ! IF WRITE LATER THEN DO 123 I = 1,LEN STORE(ISTRT+I-1) = OUTBUF(I) ! STORE UNTIL LATER 123 CONTINUE ISTRT = ISTRT + LEN ! UPDATE STORAGE POINTER ILEN = ILEN + LEN ! STORE NEW LENGTH RETURN ELSEIF(ITEMP .EQ. 2) THEN ! IF FLUSH STORAGE BUFFER THEN CALL GETADR(PRL,STORE) PRL(2) = ILEN ISTRT = 1 ! RESET STORAGE POINTER ITEMP = 0 ! RESET TO NO BUFFERING IF(ILEN .EQ. 0) RETURN ILEN = 0 ! RESET LENGTH ELSE CALL GETADR(PRL, OUTBUF) PRL(2) = LEN ENDIF CALL WTQIO(4608, 2, 20, , , PRL) 5 FORMAT(I1) 10 FORMAT(I2) 150 RETURN END