	implicit integer*4 (a-z)
	include 'vth.inc/nolist'
	parameter read_func = io$_readpblk.or.io$m_trmnoecho.or.io$m_noecho
	byte devbuf(0:dib$k_length) ! array of bytes for the device info
	character*(dib$k_length) devstring ! need to pass by string desc.
	equivalence (devbuf,devstring)
	equivalence (devprocid,devbuf(dib$l_pid)) ! the proc id of modem user
	character*12 username ! username of vth user, for error message
	character*12 okayname ! used w/ above to chech permission to run vth


	external reset_world,read_ast
	integer*4 exit_block(4)



	byte sync ! the character to use to syncronize file transfering
	parameter cha_ret = char(13)
	parameter bs_uline = '_'//char(8)

	character*63 locdev ! will be name of local physical device.
	character*63 remdev ! the name of the device with the modem
	character*80 help_buffer ! used by help command
	character*80 command ! input buffer for == mode commands

	parameter z = ichar('Z') ! letters to send to modem
	parameter a = ichar('A') ! for start command reset

	byte delecho(3) ! send backspace,space,backspace
	data delecho /8,32,8/ ! to echo a delete
	parameter linefeed = 10 ! numeric values of ascii characters
	parameter return = 13

	call getjpi(,jpi$_username,12,%ref(username))
	open(unit=21,name='_drb3:[morris]okaylist.vth',readonly,
     *		type='old',err=9900)
	k = 12
	do while (username(k:k).le.' ')
		k = k - 1
	end do
	do while (.true.)
		read(21,1003,end=9900,err=9900) j,okayname
		if (okayname(1:j).eq.username(1:k)) goto 10
	end do
9900	stop 'This program is restricted to the IDBS technical staff'
		
10	continue ! this person is on the okaylist	

	sync = linefeed ! initial value of sync char
	command_char = 1 ! control A is initial escape
	waitval = -1 ! default wait is none
	parity = none ! default is zero in parity bits
	uline = .false. ! don't do underlining in session log
	fill = .true. ! default is to pass through fill characters
	logfile(1) = .false.
	logfile(2) = .false.
	halfdup = .false.
	acc_type_code = acc$k_insmsg

	call error(10, sys$trnlog('SYS$ERROR',i,locdev,,,))
	if ((locdev(5:7).ne.'_TT').and.(locdev(5:7).ne.'_OP').and.
     *   (locdev(5:7).ne.'_PT')) then
		stop 'VTH must NEVER be used from a command file, or batch'
	end if
!	figure out which terminal we are being run from

	call error(20, sys$assign(locdev(5:i),portchan(1),,))
!	set up channels for the users terminal

!	figure out what device the dialout modem is attached to
!	by translating the logical name DIAL_OUT_MODEM

	call error (30,sys$trnlog('DIAL_OUT_MODEM',length,remdev,,,))
	if ((remdev(:3).ne.'_TT').and.(remdev(:3).ne.'_PT')) then
		stop 'DIAL_OUT_MODEM must be assigned to a terminal port'
	end if
!	what device do we use as the remote terminal?

	retcode = sys$assign(remdev(:length),portchan(2),,)
!	assign a channel to the modem

	do while (retcode.eq.ss$_devalloc) ! it is allocated to someone
		call error(35,sys$getdev(remdev(:length),,devstring,,))
!		get the proc id of the process owning the modem

		call error(37,getjpi(devprocid,jpi$_uic,4,devuic))
!		get the user id code, to see if it is login-out

		if (devuic.eq.'80020'x)  then ! we will kill the process
		! 80020 hex is equal to [10,40] in modified split octal
			call error (40,sys$delprc(devprocid,))
			retcode = sys$assign(remdev(:length),portchan(2),,)
		else
			call getjpi(devprocid,jpi$_username,12,%ref(username))
			write (6,1001) ' modem is in use by '//username
			stop 'try again later'
		end if
	end do
	call error (47,retcode) ! in case the assign failed for other reasons

!	set up an exit handler

	exit_block(2) = %loc(reset_world)
	exit_block(3) = 1
	exit_block(4) = %loc(status)
	call error (50,sys$dclexh(exit_block))

	call setterm (portchan(2))
!	assume the port is set up properly.

	do j = 1,buf_count
		bufadd(j) = %loc(buffer(1,j))
	end do

	write (6,1001) ' Welcome to the virtual terminal handler '
100	continue ! top of command loop
	write (6,1002) ' == '
	read  (5,1001,end=100) command

	call str$upcase(command,command)

	if (command.eq.'START') then
		call setterm (portchan(1))
		go to 150 ! go to transparent operation loop
	else if (command.eq.'ULINE') then
		if(.not.halfdup) write(6,1001) ' requires halfdup to work '
		uline = .true.
	else if (command.eq.'VMS') then
		call creproc
	else if (command.eq.'NOULINE') then
		uline = .false.
	else if (command.eq.'QUIT') then
		if (logfile(2)) call write_log_file(32)
		stop ' vth termination '
	else if (command.eq.'FILL') then
		fill = .true.
	else if (command.eq.'NOFILL') then
		fill = .false.
	else if (command(1:8).eq.'LOGFILE=') then
		call logfile_init
		open (unit=32,carriagecontrol='LIST',name=command(9:),
     *		 type='NEW')
		logfile(2) = .true.
	else if (command.eq.'CLOSE') then
		logfile(2) = .false.
		call write_log_file(32)
	else if (command.eq.'ESCAPE') then
110		continue ! in case of an error on the read, do it again.
		write (6,3001) command_char
3001		format (' present escape: ',i4,' new escape: ',$)
		read (5,3002,end=110,err=110) command_char
3002		format (i)
	else if (command.eq.'SYNC') then
120		continue
		write (6,3003) sync
3003		format(' present sync: ',i4,' new sync: ',$)
		read (5,3002,end=120,err=120) sync
	else if (command.eq.'WAIT') then
220		continue
		write (6,3004) waitval
3004		format(' present wait: ',i4,' new wait: ',$)
		read(5,3002,err=220,end=220) waitval
	else if (command(1:5).eq.'SEND=') then
		command=command(6:)
		sendfile = .true.
		open(unit=24,name=command,type='old',err=130,shared,readonly)
		go to 150
130		continue
		write (5,1001) ' error opening file: '//command
	else if (command.eq.'ABORT') then
		sendfile = .false.
		close (unit=24,err=100)
	else if (command.eq.'EVEN') then
		parity = even
	else if (command.eq.'RESTART') then
		call setterm (portchan(1))
		go to 150
	else if (command.eq.'ODD') then
		parity = odd
	else if (command.eq.'NONE') then
		parity = none
	else if (command.eq.'ONES') then
		parity = ones
	else if (command.eq.'HALFDUP') then
		halfdup = .true.
	else if (command.eq.'FULLDUP') then
		halfdup = .false.
	else if (command.eq.'HELP') then
		open (unit=21,err=900,name='drb3:[morris.termio]vth.hlp',
     *		type='old',readonly)
		help_buffer = ' '
		do while (.true.)
			read(21,4001,end=900) j,help_buffer
4001			format (q,a)
			write (6,1001) ' '//help_buffer(:j)
		end do
900		continue
		close (unit=21)
	else
		write (6,1001) ' illegal command '
	end if
	go to 100

150	continue
!	now we are ready for the main I/O loop

	portdest(1) = 2
	portdest(2) = 1
	bufuse(1) = 1
	bufuse(2) = 2

	sync_flag = .false.


	do j = 1,2
		bsize(j) = 1
		call error(1020,sys$qio(,%val(portchan(j)),%val(read_func),iosb(1,j),
     *		 read_ast,%val(j),%val(bufadd(j)),%val(1),,,,))
	end do
	call error(1030,sys$hiber())
	call sys$cancel(portchan(1))
	call sys$cancel(portchan(2))
	call unsetterm(portchan(1))
	go to 100
1001	format (a)
1002	format (a,$)
1003	format (q,a)
	end

	subroutine readast(astprm)
	implicit integer*4 (a-z)
	include 'vth.inc'
	external writeast
	external read_ast
	parameter read_func = io$_readpblk.or.io$m_trmnoecho.or.io$m_noecho

c	come here when a read completes
	bufnum = %loc(astprm)

	port = bufuse(bufnum)			! port from which we just read
	outport = portdest(port)		! port to which we will write

	len = iosb(2,bufnum) + iosb(4,bufnum)

	if (logfile(port)) call make_log_file(buffer(1,bufnum),len)

	char_count = char_count + len
	io_count = io_count + 1
	
	do j = 1,len
		if (buffer(j,bufnum) .eq. 1) then
			call error(1035,sys$wake(,))
			return
		end if
	end do

c
c	next fix the associated buffer length for the port we just read from
c
	if (iosb(1,bufnum).eq.ss$_timeout) then
		bsize(port) = 1
		lastport = port
		consec_count = 1
	else if ((lastport.eq.port).and.
     *		(len.eq.bsize(port)) .and.
     *		(consec_count.ge.4) 	) then ! the buffer is full
		bsize(port) = min(bsize(port)*4,max_bsize)
		lastport = -1
		consec_count = 0
	else
		if (lastport.eq.port) then
			consec_count = consec_count + 1
		else
			consec_count = 0
		end if
		lastport = port
	end if
c

	call error(1040,sys$qio(,%val(portchan(outport)),%val(io$_writepblk),
     *		iosb(outport,1),
     *		writeast,%val(bufnum),%val(bufadd(bufnum)),
     *		%val(len),,,,))
c
c	now that we have settled the buffer length, we can issue a new read
c
c	first, get a free buffer
c	call error(1050,lib$remqhi (bufq(buf_count+1),addr))
c	offset = %loc(bufq(buf_count+1)) - addr
c	bnum = buf_count + 1 - (offset/8)
c	bufuse(bnum) = port

	return
	end

	subroutine writeast (astprm)
	implicit integer*4 (a-z)
	include 'vth.inc'
	external read_ast
	parameter read_func = io$_readpblk.or.io$m_trmnoecho.or.io$m_noecho
c
	bnum = %loc(astprm)
	port = bufuse(bnum)
c
	j = read_func
	if (bsize(port).gt.1) j = j .or. io$m_timed
	call error(1060,sys$qio (,%val(portchan(port)),
     *	 %val(j),
     *	 iosb(1,bnum),
     *	 read_ast,
     *	 %val(bnum),
     *	 %val(bufadd(bnum)),
     *	 %val(bsize(port)),
     *	 %val(1),,,))
c	call error(1070,lib$insqhi(bufq(bnum),bufq(buf_count+1)))
	return
	end
c
	subroutine read_ast(x)
	integer*4 x
	call readast(x)
	return
	end
c
	subroutine error(in,code)
	implicit integer*4 (a-z)
	if (code) return
	write (6,1001) in
1001	format (' fatal error at location ',i)
	call sys$exit(%val(code))
	end

	subroutine reset_world
	implicit integer*4 (a-z)
!	this is VTH's exit handler.
	return
	end


	subroutine wait(n)

	implicit integer*4 (a-z)

	common /timedummy/  time,negone

	time = -100000 * n
	negone = -1

	call sys$clref (%val(5))
	call sys$setimr (%val(5),time,,)
	call sys$waitfr (%val(5))

	return 
	end    

	integer*4 function getjpi (procid,code,buflen,result)
	implicit integer*4 (a-z)
	integer*2 len1,len2,code1,code2
	common /mbpdummy/ len1,code1,addr1,lenaddr1,len2,code2
	data len2 /0/, code2 /0/, lenaddr1 /0/ ! zero out unused stuff
	len1 = buflen
	code1 = code
	addr1 = %loc(result)
	getjpi = sys$getjpi(,procid,,len1,,,)
	return
	end

	subroutine creproc
	implicit integer*4 (a-z)

	integer*2 mbchan,mlen,inchan
	integer*4 privs(2)
	character*64 device,inbox,mname
	include 'dibdef.for'
	include 'iodef.for'
	include 'jpidef.for'

	byte termbuf(100)
	character*(dib$k_length+1) chanbuf
	integer*2 unit
	byte xxx
	equivalence (unit,xxx)
	equivalence (chanbuf(13:14),xxx)

	call getjpi (,jpi$_authpriv,8,privs)
	j = sys$crembx (,mbchan,,,,,)
	call error(910,j)
	j = sys$getchn (%val(mbchan),,chanbuf,,)
	call error(920,j)
	call error(940,sys$trnlog('SYS$INPUT',len,device,,,))
	j = sys$trnlog(inbox(:6),mlen,mname,,,)
	call error (960,j)
	j = sys$creprc ( ,'SYS$SYSTEM:LOGINOUT',
     *  	device(5:len),device(5:len),
     *		device(5:len),privs,,,%VAL(4),,%val(unit),%val(0))
	call error(930,j)
	j = sys$qiow(,%val(mbchan),%val('31'x),,,,termbuf,%val(100),,,,)
	return
	end

	subroutine setpar(cha,mode)
	byte table(0:127)
	include 'include.for'
	logical*1 temp
	byte cha
	integer*2 mode
	common /dummy/ table
!
!	this routine receives a character and returns
!	it with its parity bit set properly, according
!	to mode
!

	temp = table(cha) .eq. 1

	cha = cha .and. '7f'x

	if (mode .eq. none) return

	if (mode .eq. ones) temp = .true.

	if (mode .eq. even) temp = .not. temp

	if (temp) cha = cha .or. '80'x

	return
	end

	block data
	common /dummy/ table
	byte table(0:127)

	data table /
     *	0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0,
     *  1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1,
     *  1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1,
     *  0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0,
     *  1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1,
     *  0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0,
     *  0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0,
     *  1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1/

	end




C	SETVAXNET.FOR
C
C	THIS SUBROUTINE GETS THE CURRENT CHARACTERISTICS OF THE CHANNEL
C	ASSIGNED TO THE REMOTE VAXNET PORT.  IT THEN CHANGES THE
C	CHARACTERISTICS SO THAT THE PORT WILL WORK PROPERLY FOR VAXNET.
C	ON PROPER VAXNET TERMINATION, THE ENTRY POINT SETNORMAL IS
C	USED TO MAKE THE PORT ACCESSIBLE TO NORMAL DIAL-UP.
C
C	J. THOMPSON  INTERMETRICS  27 JULY 1979
C
	SUBROUTINE setterm(chan_num)
!	channel number is the channel of the terminal we want to set
	implicit integer*4 (a-z)
	include 'include.for'
	LOGICAL*1 B,BE(128),CLASS,TYPE,PAGELENGTH
	INTEGER*2 PAGEWIDTH
	INTEGER*4 TERM_CHAR
	CHARACTER*128 BUFF	!CHARACTERISTICS BUFFER

	COMMON/RTTCHAR/ B(128)

	EQUIVALENCE (BE(1),BUFF(1:1))
	EQUIVALENCE (CLASS,B(5)), (TYPE,B(6))
	EQUIVALENCE (PAGEWIDTH,B(7)), (TERM_CHAR,B(9))
	EQUIVALENCE (PAGELENGTH,B(12))
	EQUIVALENCE (W1,B(1)),(W2,B(5)),(W3,B(9))

	EXTERNAL TT$M_LOWER,TT$M_MECHTAB,TT$M_NOECHO
	EXTERNAL TT$M_WRAP,TT$M_REMOTE,TT$M_PASSALL,TT$M_SCOPE
	external tt$m_holdscreen,tt$m_ttsync,tt$m_halfdup
	external tt$m_hostsync

	call error(120,SYS$GETCHN(%VAL(chan_num),L1,BUFF,,,))
	DO 100 I=1,L1
100	B(I)=BE(I)


	TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_LOWER)
	TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_MECHTAB)
	TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_NOECHO)
	term_char = term_char .or. %loc(tt$m_hostsync)
	TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_REMOTE)
	TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_PASSALL)
	TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_SCOPE)
	term_char = term_char.and..not.%loc(tt$m_holdscreen)
	term_char = term_char.and..not.%loc(tt$m_ttsync)
	term_char = term_char.and..not.%loc(tt$m_halfdup)

	NOWRAP = .NOT. %LOC(TT$M_WRAP)
	TERM_CHAR = TERM_CHAR .AND. NOWRAP

	PAGEWIDTH = 132

	call error(110,SYS$QIOW(,%VAL(chan_num),%VAL(%LOC(IO$_SETMODE)),,,,
     *	B(5),%VAL(8),,,,))

C	THE %VAL(8) IS THE LENGTH OF THE CHARACTERISTICS BUFFER WHICH
C	STARTS AT BYTE 5 OF ARRARY B.  THIS P2 PARAMETER IS NOT DOCUMENTED
C	UP THROUGH RELEASE 1.5 OF VMS.


	RETURN


C	RESET TERMINAL SO IT CAN BE USED AS A DIAL-UP.
C	(DON'T NEED TO RESET ALL CHARACTERISTICS)

	entry unsetterm (chan_num)

	call error (130,SYS$GETCHN(%VAL(chan_num),L1,BUFF,,,))
	DO 200 I = 1,L1
200	B(I) = BE(I)

	ECHO = .NOT. %LOC(TT$M_NOECHO)
	INTERACTIVE = .NOT. %LOC(TT$M_PASSALL)

	TERM_CHAR = TERM_CHAR .AND. ECHO
	TERM_CHAR = TERM_CHAR .AND. INTERACTIVE
	TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_WRAP)
	term_char = term_char .or. %loc(tt$m_ttsync)

	PAGEWIDTH = 80

	call error (140,SYS$QIOW(,%VAL(chan_num),%VAL(%LOC(IO$_SETMODE)),,,,
     *	B(5),%VAL(8),,,,))

	RETURN
	END

