	implicit integer*4 (a-z)
	include 'vth.inc/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)

	external send_ast

	character*1 sync ! the character to use to syncronize file transfering
	parameter cha_ret = char(13)
	character*2 bs_uline
	parameter readchar = io$_readpblk .or. io$m_trmnoecho .or. io$m_noecho
     *				.or. io$m_timed

	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) rchar,lchar ! buffers for terminal traffic
	character*(bufsize) logbuf ! buffer used to create logfile
	integer*2 riosb(4),liosb(4)
	character*(bufsize) sendbuf ! used to send files out
	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 = char(10) ! numeric values of ascii characters
	parameter return = char(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	
	bs_uline = char(8)//'_'
	sync = linefeed ! initial value of sync char
	command_char = char(1) ! control A is initial escape
	waitval = -1 ! default wait is none
	freq = 20	! default frequency of polling is 0.20 seconds
	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.
	acc_type_code = acc$k_insmsg

!	the io function code that will be used.

	call error(10, sys$trnlog('SYS$INPUT',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),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

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

	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)

90	continue
	if (inunit.eq.5) stop 'VTH termination'
	inunit = 5

!	assume the port is set up properly.

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

	call str$upcase(command,command)

	if (command.eq.'START') then
		call setterm (lchanin)
		call sys$qiow(,%val(rchanout),%val(io$_writepblk)
     *		,,,,z,%val(1),,,,) ! issues Z command to modem
		call wait(200)
		call sys$qiow(,%val(rchanout),%val(io$_writepblk)
     *		,,,,return,%val(1),,,,) ! sends the carriage return
		call sys$qiow(,%val(rchanout),%val(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:1).eq.'@') then
		if (inunit.ne.5) then
			write (6,1001) ' no nesting of command files allowed'
		else
			command = command(2:)
			open (unit=26,name=command,readonly,type='old',err=95)
			inunit = 26
			go to 100
		end if
95		write (6,1001) ' error opening file: '//command
		go to 100
	else if (command.eq.'ULINE') then
		if(.not.halfdup) write(6,1001) ' requires halfdup to work'
		uline = .true.
	else if (command.eq.'STATS') then
		write (6,6001)send_total,send_count,local_total,local_count,
     *			remote_total,remote_count,io_count
6001		format(
     *			' number of characters transfered out: ',i,/,
     *			' number of lines transfered out: ',i,/,
     *			' number of characters read locally: ',i,/,
     *			' number of reads needed locally: ',i,/,
     *			' number of characters read remotelly: ',i,/,
     *			' number of reads needed remotelly: ',i,/,
     *			' total number of reads each way: ',i
     *		)
	else if (command.eq.'VMS') then
		call creproc
	else if (command.eq.'NOULINE') then
		uline = .false.
	else if (command.eq.'QUIT') then
		call sys$exit(%val(1))
	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,
     *		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 (inunit,3002,end=110,err=110) command_char
3002		format (i)
	else if (command.eq.'SYNC') then
120		continue
		write (6,3003) ichar(sync)
3003		format(' present sync: ',i4,' new sync: ',$)
		read (inunit,3002,end=120,err=120) isync
		sync = char(isync)
	else if (command.eq.'WAIT') then
220		continue
		write (6,3004) waitval
3004		format(' present wait: ',i4,' new wait: ',$)
		read(inunit,3002,err=220,end=220) waitval
	else if (command.eq.'FREQ') then
320		continue
		write (6,4004) freq
4004		format(' present frequency: ',i4,' new frequency: ',$)
		read(inunit,3002,err=320,end=320) freq
	else if (command(1:5).eq.'SEND=') then
		command=command(6:)
		sendfile = .true.
		open(unit=24,name=command,type='old',err=130,shared,readonly)
		send_total = 0
		send_count = 0
		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' .or. command.eq.'BEGIN') 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
	sync_flag = .false.
	if (sendfile) then
		read (24,1003,err=970,end=970) j,sendbuf
		send_total = send_total + j
		send_lines = send_lines + 1
		j = j+1
		sendbuf(j:j) = cha_ret ! stick a carriage return on the end
		if (parity.ne.none) call setpar(sendbuf(:j),parity)
		call sys$qio(,%val(rchanout),%val(io$_writepblk)
     *  	,,send_ast,,%ref(sendbuf),%val(j),,,,)
	end if

200	continue

	call sys$qio(,%val(rchanin),%val(readchar),riosb,,,
     *  %ref(rchar),%val(bufsize),,,,)

	call sys$qio(,%val(lchanin),%val(readchar),liosb,,,
     *  %ref(lchar),%val(bufsize),,,,)

	io_count = io_count + 1

	lenl = liosb(2) + liosb(4)
	if (lenl.gt.0) then ! we have done a local read
	    local_total = local_total + lenl
	    local_count = local_count + 1
	    if (  0.eq.index(lchar(:lenl),command_char)	) then
	        call setpar (lchar(:lenl),parity)
		call sys$qiow(,%val(rchanout),
     *		 %val(io$_writepblk),,,,%ref(lchar),%val(lenl),,,,)
		if (halfdup) call sys$qiow(,%val(lchanout),
     *		 %val(io$_writepblk),,,,%ref(lchar),%val(lenl),,,,)
	    if (halfdup.and.logfile) then
		call lfwrite(lchar(:lenl))
		if (uline) then
			do j = 1,2
				do k = 1,lenl
					lchar(k:k) = bs_uline(j:j)
				end do
				call lfwrite(lchar(:lenl))
			end do
		end if
	     end if

	    else
		call sys$cancel(%val(lchanin))
		call sys$cancel(%val(rchanin))
		call unsetterm (lchanin)
		go to 100
	    end if
	end if
	lenr = riosb(2) + riosb(4)
	if (lenr.gt.0) then ! we have a remote read done
	    remote_total = remote_total + lenr
	    remote_count = remote_count + 1
		call sys$qiow(,%val(lchanout),%val(io$_writepblk)
     *		  ,,,,%ref(rchar),%val(lenr),,,,)

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

		if (logfile) call lfwrite(rchar(:lenr))

	end if

	call wait (freq)
	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 (inunit.ne.5) go to 100
	go to 150

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

	subroutine send_ast
	include 'vth.inc/nolist'
	sync_wait = .true.
	return
	end
