	implicit integer*4 (a-z)
	include 'include.for/nolist'

	common /vtharea/ rchanin,lchanin
	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
	integer*4 exit_block(4)

	logical*1 halfdup ! true means a half duplex machine
	logical*1 uline ! underline input in session log (requires halfdup)
	logical*1 sendfile ! means file transfer outward is in progress
	logical*1 sync_wait ! waiting for sync to continue transfer
	logical*1 fill ! true means vth is NOT to swallow fill characters
	logical*1 logfile ! true means that the user wants a log made

	byte lchar,rchar ! buffers for the char by char I/O
	byte sync ! the character to use to syncronize file transfering
	parameter efn1 = 1, efn2 = 2, efn1_mask = 2, efn2_mask = 4
	parameter efn3 = 3, efn3_mask = 8
	parameter cha_ret = char(13)
	parameter bs_uline = '_'//char(8)

	parameter modemcnt = 2
	character*14 dial_out_name(modemcnt)
	data dial_out_name(1) /'DIAL_OUT_MODEM'/
	data dial_out_name(2) /'DIAL_OUT_MOD_1'/

	character*63 locdev ! will be name of local physical device.
	character*63 remdev ! the name of the device with the modem
	character*80 buffer ! used by help command
	parameter bufsize = 1000 ! for file transfers
	character*(bufsize) logbuf ! buffer used to create logfile
	character*(bufsize) sendbuf ! used to send files out
	character*80 command ! input buffer for == mode commands
	byte command_char ! store the escape char, initialized to ^A

	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 = .false.
	halfdup = .false.
c
	readchar = %loc(io$_readpblk) + %loc(io$m_trmnoecho) +
     *  	%loc(io$m_noecho)
!	the io function code that will be used.

	call error(10, sys$trnlog('SYS$INPUT',i,locdev,,,))
	if ((locdev(5:8).ne.'__TT').and.(locdev(5:8).ne.'__OP').and.
     *   (locdev(5:8).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),lchanin,,))
	lchanout = lchanin
!	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
       
       do j=1,modemcnt

	call error (30,sys$trnlog(dial_out_name(j),length,remdev,,,))
	if ((remdev(:4).ne.'__TT').and.(remdev(:4).ne.'__PT').and.
     *	    (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),rchanin,,)
!	assign a channel to the modem

	 if (retcode.eq.ss$_devalloc) then! 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$_username,12,%ref(username)))
!		get the user name, to see if it is login

		if (username(1:7).eq.'<login>')  then ! we will kill it
			call error (40,sys$delprc(devprocid,))
			retcode = sys$assign(remdev(:length),rchanin,,)
		else
			write (6,1001) ' modem is in use by '//username
			if (j.eq.modemcnt)stop 'try again later'
		end if
	end if
       end do
	call error (47,retcode) ! in case the assign failed for other reasons


	rchanout = rchanin
!	set up channels for the modem.

!	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 (rchanin)

!	assume the port is set up properly.

	write (6,1001) ' Welcome to the virtual terminal handler '
	cunit = 5
	go to 100
99	continue
	if (cunit.eq.31) then
		close (unit=31)
		cunit = 5
	else if (cunit.eq.5)then
		stop ' '
	else
		close (unit = cunit)
		cunit = cunit - 1
	end if
100	continue ! top of command loop
	if (cunit.eq.5) write (6,1002) ' == '
	read  (cunit,6001,end=99) command_len,command
6001	format (q,a)

	call str$upcase(command,command)
	if (command(1:1).eq.'@') then
		if (cunit.gt.30) then
			cunit = cunit + 1
		else
			cunit = 31
		end if
		open (unit=cunit,name=command(2:),type='old',readonly,err=602)
		go to 100
602		continue
		write (6,1001) ' file '//command(2:)//' could not be opened'
		cunit = 5
	else if (command.eq.'START') then
		call setterm (lchanin)
		call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk))
     *		,,,,z,%val(1),,,,) ! issues Z command to modem
		call wait(200)
		call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk))
     *		,,,,return,%val(1),,,,) ! sends the carriage return
		call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk))
     *		,,,,a,%val(1),,,,) ! send an A to get it in answer mode
		go to 150 ! go to transparent operation loop
	else if (command(1:6).eq.'WRITE=') then
		command(command_len+1:command_len+1) = cha_ret
		call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk))
     *		,,,,%ref(command(7:)),%val(command_len-5),,,,)
	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 lib$spawn
	else if (command.eq.'NOULINE') then
		uline = .false.
	else if (command.eq.'QUIT') then
		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
		command = command(9:) ! the file name
		logfile = .true.
		open (unit=22,name=command,type='new',err=125,
     *		recl=bufsize,carriagecontrol='list')
		point = 0 ! buffer empty now
		go to 100
125		continue ! to handle file open errors
		write (6,1001) ' file: '//command//' could not be opened'
		go to 100
	else if (command.eq.'CLOSE') then
		close (unit=22)
		logfile = .false.
	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 (cunit,3002,end=110,err=110) command_char
3002		format (i)
	else if (command(:6).eq.'ESCAPE') then
		j = index (command,'^')
		if (j.gt.0) then
			command_char = ichar(command(j+1:j+1)) - 64
		else
			call ots$cvt_ti_l(command(7:),command_char,%val(4),%val(3))
		end if
		write (6,3007) command_char
3007		format (' escape character is:',i)
	else if (command.eq.'SYNC') then
120		continue
		write (6,3003) sync
3003		format(' present sync: ',i4,' new sync: ',$)
		read (cunit,3002,end=120,err=120) sync
	else if (command(:4).eq.'SYNC') then
		j = index (command,'^')
		if (j.gt.0) then
			sync = ichar(command(j+1:j+1)) - 64
		else
			call ots$cvt_ti_l(command(5:),sync,%val(4),%val(3))
		end if
		write (6,3006) sync
3006		format (' sync value: ',i)
	else if (command.eq.'WAIT') then
220		continue
		write (6,3004) waitval
3004		format(' present wait: ',i4,' new wait: ',$)
		read(cunit,3002,err=220,end=220) waitval
	else if (command(1:4).eq.'WAIT') then
		call ots$cvt_ti_l(command(5:),waitval,%val(4),%val(3))
		write (6,3005) waitval
3005		format (' wait value: ',i)
	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 (6,1001) ' error opening file: '//command
	else if (command.eq.'ABORT') then
		sendfile = .false.
		cunit = 5
		close (unit=24,err=100)
	else if (command.eq.'EVEN') then
		parity = even
	else if (command.eq.'RESTART') then
		call setterm (lchanin)
		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)
		buffer = ' '
		do while (.true.)
			read(21,4001,end=900) j,buffer
4001			format (q,a)
			write (6,1001) ' '//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
	call sys$clref(%val(3))
	sync_flag = .false.
	if (sendfile) then
		read (24,1003,err=970,end=970) j,sendbuf
		j = j+1
		sendbuf(j:j) = cha_ret ! stick a carriage return on the end
		if (parity.ne.none) then
			do n = 1,j
				call setpar(%ref(sendbuf(n:n)),parity)
			end do
		end if
		call sys$qio(%val(3),%val(rchanout),%val(%loc(io$_writepblk))
     *  	,,,,%ref(sendbuf),%val(j),,,,)
	end if

!	issue a qio read in each direction, to start it off.

	call sys$qio(%val(1),%val(rchanin),%val(readchar),,,,
     *  rchar,%val(1),,,,)

	call sys$qio(%val(2),%val(lchanin),%val(readchar),,,,
     *  lchar,%val(1),,,,)

200	continue ! this statement is the top of the main loop.

	call sys$wflor(%val(0),%val(14)) ! 14 = bits 1,2, & 3 set.
	call sys$readef (%val(2),state)

!	at this point, we know that one of the three waits has
!	just been answered, the next if statement figures out
!	which one.

	if (( state.and.efn2_mask) .ne. 0) then ! it was #2 local read done
	call setpar (lchar,parity)
	    if ((lchar.and.'7f'x).ne.command_char) then
		call sys$qio(,%val(rchanout),%val(%loc(io$_writepblk))
     *  	,,,,lchar,%val(1),,,,) ! send it to the remote device.

!		if half duplex, then echo the character to the user
		if (halfdup) then
			if ((lchar.and.'7f'x).ne.127) then
				 call sys$qio(,%val(lchanout),%val(
     *				%loc(io$_writepblk)),,,,lchar,%val(1),,,,)
			else ! it was a <del> so echo <bs> space <bs>
				call sys$qio(,%val(lchanout),%val(
     *				%loc(io$_writepblk)),,,,delecho,
     *				%val(3),,,,)
				point = point - 1 ! take out of logfile
				if (uline) point = point - 2
			end if
			if (logfile.and.(lchar.and.'7f'x).ne.127) then
				if (uline) then
					if(lchar.ne.return) then
						point=min(bufsize,point+2)
						logbuf(point-1:point)=bs_uline
					else
						point=min(bufsize,point+4)
						logbuf(point-3:point)='<CR>'
					end if
						
				end if
				point=min(bufsize,point+1)
				logbuf(point:point)=char(lchar)
			end if
		end if
		call sys$qio(%val(2),%val(lchanin),%val(readchar),,,,
     *  	lchar,%val(1),,,,) ! issue another local read request
	    else
		call sys$cancel(%val(lchanin))
		call sys$cancel(%val(rchanin))
		call unsetterm (lchanin)
		go to 100
	    end if
	else if ((state.and.efn3_mask).ne.0.and.sendfile) then
		sync_wait = .true.
		call sys$clref (%val(efn3))

	else ! it was #1, remote read done.
	if ((((rchar.or.'80'x).ne.'ff'x).and.rchar.ne.0).or.fill) then
		call sys$qio(,%val(lchanout),%val(%loc(io$_writepblk))
     *  	,,,,rchar,%val(1),,,,)

		if (rchar.eq.sync.and.sync_wait) then ! continue sending file
			sync_wait = .false.
			if(waitval.ge.0) call wait(waitval)
			read (24,1003,end=970,err=970) j,sendbuf
			j = j + 1
			sendbuf(j:j) = cha_ret
			if (parity.ne.none) then
				do n = 1,j
					call setpar(%ref(sendbuf(n:n)),parity)
				end do
			end if
			call sys$qio(%val(3),%val(rchanout),%val(%loc(
     *  		io$_writepblk)),,,,%ref(sendbuf),%val(j),,,,)
		end if

		if (logfile) then
!	this is the code to creat a file on the vax.  We will assume that
!	the linefeed character marks where one record stops, and where the
!	next begins.
			if (rchar.eq.linefeed) then
				start = 1
				do while (logbuf(start:start).eq.cha_ret)
					start = start + 1
				end do
				do while (logbuf(point:point).eq.cha_ret)
					point=point - 1
				end do
				if(point.gt.0) then
					write (22,5001,err=950) logbuf(start:point)
				else
					write (22,5001,err=950)
				end if
5001				format (a)
				point = 0
			else ! this is a regular character
				point = min(bufsize,point + 1)
				logbuf(point:point) = char(rchar)
			end if
			go to 960
950			continue ! for error writing log file
			write (6,1001) ' == ERROR WRITING LOG FILE '//CHAR(7)
			logfile = .false.
960			continue
		end if
	end if


		call sys$qio(%val(1),%val(rchanin),%val(readchar),,,,
     *  	rchar,%val(1),,,,) ! issue another remote read request

	end if

	go to 200
970	continue ! for end of file on transfer outward
	sendfile = .false.
	close (unit=24,err=100)
	write (6,1001) char(7)//' == VTH file transfer finished'//char(7)
	write (6,1001) ' ' ! to place users cursor at lower left
	call sys$cancel(%val(lchanin))
	call sys$cancel(%val(rchainin))
	if (cunit.eq.31) then
		call unsetterm (lchanin)
		go to 100
	else
		go to 150
	end if

1001	format (a)
1002	format (a,$)
1003	format (q,a)
	
	end



	subroutine error(in,code)
	implicit integer*4 (a-z)
	character*132 mess
	if ((code.and.1).ne.0) return
	call sys$getmsg(%val(code),len,mess,%val(15),)
	write (6,2001) in,mess(1:len)
2001	format (' location = ',i3,2x,a<len+1>)
	call exit
	end

	subroutine reset_world
	implicit integer*4 (a-z)

!	this is VTH's exit handler.


	common /vtharea/ rchanin,lchanin
	call unsetterm(rchanin)
	call unsetterm(lchanin)
	return
	end
