C 
	SUBROUTINE TCS(I,J,K,L)
C 
C	Terminal Control Subroutine
C	by Dave Thorson, September 1981, The Ohio State University
C 
C 
C	(bits numbered:   16|15 14 13|12 11 10| 9  8  7| 6  5  4| 3  2  1|
C	 so octal 13, or   0|    0   |    0   |    0   |    1   |    3   |
C	 in binary, 1011:  0|    0   |    0   |    0   | 0  0  1| 0  1  1|
C	 would mean bits 4, 2 and 1 are set)
C 
C	a,b, and c refer to the terminal type the commands below
C	refer to; a=VT100, b=VT52, c=ADDS 100.  Commands sent to the
C	wrong terminal are ignored, as are unused bits in I and J words.
C	Bit	I functions
C	Set	(escape sequences to terminal)
C	---	------------------------------
C	 1 abc	clear screen, leave cursor in upper left corner
C	 2 abc	ring bell
C	 3  a	reverse video (white background, dark characters)
C	 4  a	normal video (dark background, white characters)
C	 5  a	set screen to 80 column mode
C	 6  a	set screen to 132 column mode
C	 7 abc	absolute screen addressing, leaves cursor at row
C		K, column L
C	 8  a	set scrolling margins; begin at row K, end at row L
C	 9  a	select smooth scrolling
C	10  a	select jump scrolling
C	11 ab	enable alternate keypad
C	12 ab	enable numeric keypad
C	13 ac	set character atttributes K and L, in the order K,L:
C		K or L		character attribute
C		  0		all attributes off
C		  1		bold intensity on (c: half intensity)
C		  4		underscore on
C		  5		blink on
C		  7		reverse video on
C		note: for type c terminal, only two attributes may be
C		active at once.  The order of K and L makes no difference.
C		Attribute 0 is set first, then the others;
C		(0,4), (4,0), and (4,4) all have the same effect as do
C		(1,7) and (7,1).  See code below (statement label 13) and
C		ADDS Regent 100 user's guide for more information.
C	14  a	programmable LED's defined by K and L
C		K or L		LED status
C		  0		all LED's off
C		  1		LED 1 on
C		  2		LED 2 on
C		  3		LED 3 on
C		  4		LED 4 on
C	15  a	reset terminal
C	16 abc	clear screen from cursor to end, don't move cursor
C	For details on I word functions, see terminal user's guides.
C 
C	Bit	J word functions (QIO/ MCR functions)
C	Set	(J word functions work for all terminals)
C	---	-------------------------------------
C	 1	SET /LOWER=TI:
C	 2	SET /NOLOWER=TI:
C	 3	SET /FDX=TI:
C	 4	SET /NOFDX=TI:
C	 5	SET /SLAVE=TI:
C	 6	SET /NOSLAVE=TI:
C	 7	SET /BUF=TI:	(buffer size returned in K)
C	 8	SET /BUF=TI:K   (buffer set to decimal size in K)
C	 9	SET /TERM=TI:	(terminal type returned in L:
C				0=unknown, 9=VT52, 13=VT100)
C	10	SET /TERM=TI:L	(set terminal to type sent in L;
C				types defined above)
C	11	SET /ECHO=TI:	enables echo (default)
C	12	SET /NOECHO=TI: disables echo
C	13	SET /TYPEAHEAD=TI: set typeahead buffer to 36 characters
C	14	SET /NOTYPEAHEAD=TI: set buffer to 1 character
C	15	empty typeahead buffer (characters lost)
C	16	return no. characters in typeahead buffer in K
C	For details on J word functions, see I/O DRIVERS MANUAL and
C	the MCR OPERATIONS manual.
C 
	LOGICAL*1 ITC(2),ITCX(16,2)
	DIMENSION IPARM(6),IOSB(2)
	LOGICAL*1 IBIT(16)
	DATA IDID /0/
	DATA ITCX /"25,"25,"64,"64,"50,"50,1,1,8,8,"47,"47,7,7,"71,"71,
     C1,0,1,0,1,0,0,0,0,0,0,1,1,0,0,0/
	IF(IDID.EQ.13131) GOTO 2000
C	get terminal type:
	CALL GETADR(IPARM(1),ITC(1))
	IPARM(2)=2
	ITC(1)="10
	ITC(2)=0
	CALL WTQIO("2560,5,5,50,IOSB,IPARM,IDS)
	IT=ITC(2)  ! terminal type (0,9 or 13 recognized)
	IDID=13131
C	put K and L into ASR and ASC (integer to character trans.)
C	store K as '[kkk' and L as ';lll'  (K=20,L=45 --> '[020',';045')
2000	IF(IT.EQ.13) CALL SCRADR(K,L,ASR,ASC)
	IF(I.EQ.0) GOTO 100
C	decode I word into bit pattern, store in IBIT:
	CALL INTBIT(I,IBIT)
C	perform I word functions:
1	IF(IBIT(1).EQ.0) GOTO 2
	IF(IT.EQ.13) WRITE(5,1001) "33,"33
	IF(IT.EQ.9) WRITE(5,1002) "33,"33,'J'
	IF(IT.EQ.0) WRITE(5,1002) "33,"33,'k'
2	IF(IBIT(2).EQ.1) WRITE(5,1004) "7
3	IF(IBIT(3).EQ.0) GOTO 4
	IF(IT.EQ.13) WRITE(5,1005) "33,'[?5h'
4	IF(IBIT(4).EQ.0) GOTO 5
	IF(IT.EQ.13) WRITE(5,1005) "33,'[?5l'
5	IF(IBIT(5).EQ.0) GOTO 6
	IF(IT.EQ.13) WRITE(5,1005) "33,'[?3l'
6	IF(IBIT(6).EQ.0) GOTO 7
	IF(IT.EQ.13) WRITE(5,1005) "33,'[?3h'
7	IF(IBIT(7).EQ.0) GOTO 8
	IF(IT.EQ.13) WRITE(5,1009) "33,ASR,ASC,'f'
	IF(IT.EQ.9.OR.IT.EQ.0) WRITE(5,1010) "33,K+"37,L+"37
8	IF(IBIT(8).EQ.0) GOTO 9
	IF(IT.EQ.13) WRITE(5,1009) "33,ASR,ASC,'r'
9	IF(IBIT(9).EQ.0) GOTO 10
	IF(IT.EQ.13) WRITE(5,1005) "33,'[?4h'
10	IF(IBIT(10).EQ.0) GOTO 11
	IF(IT.EQ.13) WRITE(5,1005) "33,'[?4l'
11	IF(IBIT(11).EQ.0) GOTO 12
	IF(IT.EQ.13.OR.IT.EQ.9) WRITE(5,1008) "33,'='
12	IF(IBIT(12).EQ.0) GOTO 13
	IF(IT.EQ.13.OR.IT.EQ.9) WRITE(5,1008) "33,'>'
13	IF(IBIT(13).EQ.0) GOTO 14
	IF(IT.EQ.13) WRITE(5,1014) "33,K,L,'m'
	IF(IT.NE.0) GOTO 14
C	screen attributes for ADDS 100 terminal:
	K2=K+L
	ESCSEQ='@'
	IF(K2.EQ.1) ESCSEQ='A'
	IF(K2.EQ.4) ESCSEQ='`'
	IF(K2.EQ.5.AND.K*L.EQ.0) ESCSEQ='B'
	IF(K2.EQ.7) ESCSEQ='P'
	IF(K2.EQ.5.AND.K*L.EQ.4) ESCSEQ='a'
	IF(K2.EQ.6) ESCSEQ='C'
	IF(K2.EQ.8) ESCSEQ='Q'
	IF(K2.EQ.9) ESCSEQ='b'
	IF(K2.EQ.11) ESCSEQ='p'
	IF(K2.EQ.12) ESCSEQ='R'
	WRITE(5,1006) "33,ESCSEQ,"0,"0
14	IF(IBIT(14).EQ.0) GOTO 15
	IF(IT.EQ.13) WRITE(5,1014) "33,K,L,'q'
15	IF(IBIT(15).EQ.0) GOTO 16
	IF(IT.EQ.13) WRITE(5,1008) "33,'c'
16	IF(IBIT(16).EQ.0) GOTO 100
	IF(IT.EQ.13) WRITE(5,1006) "33,'[','0','J'
	IF(IT.EQ.9) WRITE(5,1008) "33,'J'
	IF(IT.EQ.0) WRITE(5,1008) "33,'k'
1001	FORMAT('+',$/'+',A1,'[H',A1,'[J',$/'+',$)
1002	FORMAT('+',$/'+',A1,'Y  ',2A1,$/'+',$)
1004	FORMAT('+',$/'+',A1,$/'+',$)
1005	FORMAT('+',$/'+',A1,A4,$/'+',$)
1006	FORMAT('+',$/'+',4A1,$/'+',$)
1007	FORMAT('+',$/'+',A1,'[0J',$/'+',$)
1008	FORMAT('+',$/'+',2A1,$/'+',$)
1009	FORMAT('+',$/'+',A1,2A4,A1,$/'+'$)
1010	FORMAT('+',$/'+',A1,'Y',2A1,$/'+',$)
1014	FORMAT('+',$/'+',A1,'[',I1,';',I1,A1,$/'+',$)
C	decode J word into bit pattern, store in IBIT:
100	IF(J.EQ.0) GOTO 200
C	decode  J into bit pattern:
	CALL INTBIT(J,IBIT)
C	perform J word functions:
	IBUF=80
	IF(K.GT.0) IBUF=K
	DO 101 I1=1,16
	IF(IBIT(I1).EQ.0)  GOTO 101
	ITC(1)=ITCX(I1,1)
	ITC(2)=ITCX(I1,2)
	IF(I1.EQ.8) ITC(2)=IBUF
	IF(I1.EQ.10) ITC(2)=L
	IF(I1.EQ.10) IT=L  ! UPDATE TCS'S MEMORY OF TERMINAL TYPE
	IF(I1.EQ.7.OR.I1.EQ.9) CALL WTQIO("2560,5,5,50,IOSB,IPARM,IDS)
	IF(I1.NE.7.AND.I1.NE.9) CALL WTQIO("2440,5,5,50,IOSB,IPARM,IDS)
	IF(I1.EQ.7) K=ITC(2)
	IF(I1.EQ.9) L=ITC(2)
101	CONTINUE
200	RETURN
	END
	SUBROUTINE SCRADR(IR,IC,AR,AC)
C	SCReen ADRess subroutine for VT100 terminal in ANSI mode.
C	PROGRAMMED BY DAVE THORSON, SEPTEMBER 1981, OHIO STATE UNIVERSITY
C
C	STORES IR AND IC IN AR AND AC AS "[iii" and ";jjj" WHERE iii=IR
C	AND jjj=IC. USED FOR VT-100 ANSI COMPATIBLE COMMANDS.
C 
	LOGICAL*1 ATR(4),ATC(4)
	EQUIVALENCE (ASR,ATR(1)),(ASC,ATC(1))
	I1=IR
	IF(I1.LT.0) I1=-I1
	J=0
1	IF(I1.LT.0) I1=-I1 ! NEGATIVE NUMBERS CAN BE USED FOR ADDRESS
	I3=(I1+.5)/100 ! HUNDREDS DIGIT
	I4=(I3+.005)*100 ! HUNDREDS
	I1=I1-I4+.5 ! HUNDREDS TRUNCATED
	I2=(I1+.5)/10  ! TENS DIGIT
	I4=(I2+.05)*10  ! TENS
	I1=I1-I4+.5 !  TENS TRUNCATED LEAVING ONES DIGIT
	IF(J.EQ.1) GOTO 2
	ATR(1)='['
	ATR(2)=I3+"60
	ATR(3)=I2+"60
	ATR(4)=I1+"60
	J=1
	I1=IC
	GOTO 1
2	ATC(1)=';'
	ATC(2)=I3+"60
	ATC(3)=I2+"60
	ATC(4)=I1+"60
	AR=ASR ! NECESSARY TO AVOID MULTIPLE DEFINITION OF AR,AC IN
	AC=ASC ! EQUIVALENCE STATEMENT.
	RETURN
	END
