 	SUBROUTINE WRITE_CTRL(BUFF,SIZE)
C
C	This routine is used to convert and write a buffer to the remote.
C	Characters of the form "^char" to control character before the
C	buffer is written.
C
C	Inputs:
C		BUFF - address of buffer to send.
C		SIZE - the buffer byte count.
C
C	Outputs:
C		BUFF - converted to control characters.
C		SIZE - the new buffer size.
C
	implicit none
	LOGICAL*1 BUFF(1)
	INTEGER*4 SIZE

	IF (SIZE .GT. 0) THEN
		CALL CVT_CTRL(BUFF,SIZE)	! Convert control characters.
		CALL WRITE_BYTE(BUFF,SIZE)	! Write buffer to the remote.
	ENDIF
	RETURN
	END

	SUBROUTINE CANCEL_IO
C
C	This routine is used to cancel the local I/O.
C
C	The status return from the SYS$CANCEL's are not checked
C	since this routine is called from the error routine.
C
	implicit none
	include 'bbs_inc.for'
	integer status
	integer sys$cancel
C
C	Cancel the local I/O (if any).
C
	status = sys$cancel(%val(lchan_in))
	status = sys$cancel(%val(lchan_out))
	CALL CHECK_STATUS('CANCEL_LOCAL',STATUS)
	RETURN
	END

	SUBROUTINE WAKE_UP
C
C	Subroutine to wake up hibernate state.
C
	implicit none
	INTEGER*4 STATUS, SYS$WAKE, CHECK_STATUS

	STATUS = SYS$WAKE(,)	! Wake us up.
	CALL CHECK_STATUS('WAKE_UP',STATUS)
	RETURN
	END

	SUBROUTINE INIT_TIMER(timer_pointer)
C
C	The subroutine simply calls LIB$INIT_TIMER.
C
	IMPLICIT NONE

	INTEGER STATUS, LIB$INIT_TIMER, timer_pointer

	STATUS = LIB$INIT_TIMER(timer_pointer)
	CALL CHECK_STATUS('INIT_TIMER',STATUS)
	RETURN
	END

	SUBROUTINE ELAPSED_TIME(timer_pointer)
C
C	This routine is called at the end of file transmission to output
C	the elapsed time.  The LIB$INIT_TIMER must have been called previous
C	to calling this routine.
C
	IMPLICIT NONE
	integer*4 timer_pointer

	EXTERNAL WRITE_ELAPSED

	CALL LIB$SHOW_TIMER(timer_pointer,,WRITE_ELAPSED,)
	RETURN
	END

	SUBROUTINE WRITE_ELAPSED (TIME)
C
C	This routine is used to write the elapsed time.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	CHARACTER*(*) TIME
	INTEGER TIME_SIZE, INDEX

	TIME_SIZE = LEN(TIME)			! Get the time string size.
	TIME_SIZE = INDEX (TIME, '  BUFIO:')
	CALL WRITE_USER('***'//TIME(1:TIME_SIZE)//'***'//crlf(:cl))
	RETURN
	END

	INTEGER FUNCTION CHECK_STATUS(FACILITY_NAME,STATUS_CODE)
C
C	Subroutine to check status from a System Service.
C
C	Inputs:
C		FACILITY_NAME - Subroutine name.
C		STATUS_CODE - Status code.
C
C	Outputs:
C		Returns the status code passed in.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'
C
C	Setup the error message.
C
	CHARACTER*(*) FACILITY_NAME, ERROR_MESSAGE
	PARAMETER (ERROR_MESSAGE = ss//
	1 '*** VAXNET Terminated with ERROR ***'//BELL//ss)
	CHARACTER*80 MESS_TXT
	INTEGER*4 STATUS_CODE

	CHECK_STATUS = STATUS_CODE	! Pass back the status code.

	IF (STATUS_CODE .EQ. SS$_NORMAL) RETURN
C
C	If the error is exceeded quota (probably buffered I/O quota),
C	cancel the outstanding I/O so the write of the error message
C	will complete successfully.
C
	IF (STATUS_CODE .EQ. SS$_EXQUOTA) THEN
		CALL CANCEL_IO()	! Cancel the outstanding I/O.
	ENDIF
C
C	Report error message to the terminal.
C
C	Set flags for GETMSG for:
C		- Include text of message.
C		- Include message identifier.
C		- Include severity indicator.
C		- Do not include facility name.
C
	FLAGS = "7			! Set up the flags.
	CALL SYS$GETMSG(%VAL(STATUS_CODE),MSGLEN,MESS_TXT,%VAL(FLAGS),)
C
	write(6,*)crlf(:cl)//'%'//facility_name//'-'//mess_txt(2:msglen)
	1   //bell//crlf(:cl)
C
C	If the modem hangs up, show it was hungup, and insure a file
C	transfer (if any) gets aborted.
C
	IF (STATUS_CODE .EQ. SS$_HANGUP) THEN
		CONTROLC_TYPED = .TRUE.	! Set flag to abort transmission.
	ENDIF
	CALL HANGUP_MODEM()		! Make sure modem is hungup.
	CALL SYS$EXIT(%VAL(STATUS_CODE)) ! Exit with the status code.
	END

	LOGICAL FUNCTION GET_VAXFILE(FILE)
C
C	This function is used to get the file name of the file
C	on the VAX and then open it for either read or write.
C
C	Inputs:
C		FILE - string descriptor with the file name (if any).
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'
	INCLUDE '($RMSDEF)/NOLIST'


	CHARACTER*(*) FILE, MODULE_NAME

	PARAMETER (MODULE_NAME = 'GET_VAXFILE')

	GET_VAXFILE = .FALSE.		! Initialize to bad return.
C
C	If we were passed a file name, use it.
C
	VAX_FILE = FILE		! Copy the file name
	VSIZE = LEN(FILE)	!    and the file size.
C
C	Sending a file to the remote.
C
C	Vaxnet> SEND vax_file remote_file
C
200	IF (FLOW .EQ. TO_VAX) GO TO 500		! Send a file to the VAX.
C
C
C	Open the file for read.
C
400	OPEN (UNIT=FILE_UNIT, TYPE='OLD', READONLY, SHARED,
	1			FILE=VAX_FILE(1:VSIZE), ERR=9900)
	GET_VAXFILE = .TRUE.			! Return success.
	RETURN
C
C	Getting a file from the REMOTE.
C
C	Vaxnet> GET remote_file vax_file
C
C
C	Open the file for write.
C
500	OPEN (UNIT=FILE_UNIT, TYPE='NEW', NAME=VAX_FILE(1:VSIZE),
	1		RECORDSIZE=OUT_SIZE, CARRIAGECONTROL='LIST',
	1		BUFFERCOUNT=2, ERR=9900)
	GET_VAXFILE = .TRUE.			! Return success.
	RETURN

9900	continue
c	CALL RMS_ERROR (MODULE_NAME)		! Report the RMS error.
	RETURN
	END

	INTEGER FUNCTION XMODEM_CHECKSUM (BUFFER, BYTES)
C
C	This routine is used to calculate the checksum with the XMODEM
C	protocol.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	LOGICAL*1 BUFFER(1)
	INTEGER BYTES

	XMODEM_CHECKSUM = 0			! Initialize the checksum.
	IF (BYTES .GT. 0) THEN
	    DO 100 I=1,BYTES
	    XMODEM_CHECKSUM = (XMODEM_CHECKSUM + BUFFER(I)) .AND. BITMASK
100	    CONTINUE
	ENDIF
	RETURN
	END

	SUBROUTINE SEND_CODE
C
C	These routines are used to send a control character to the remote.
C
C	The entrys for sending of SOH, STX, and ETX were added for the
C	DEC DF03 ACU.  They must not have a carriage return appended to
C	them as do the other control characters.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'
	LOGICAL*1 LAST_CODE(2)
C
C	Entry to send line feed
C
	ENTRY SEND_LF
	LAST_CODE(1) = LF
	GO TO 50
C
C	Entry to send carriage return
C
	ENTRY SEND_CR
	LAST_CODE(1) = CR
	GO TO 50
C
C	Entry to send SOH (Start of Header).	CTRL/A
C
	ENTRY SEND_SOH
	LAST_CODE(1) = SOH		! Save the last code.
	GO TO 50			!  and send it.
C
C	Entry to send STX (Start of Text).	CTRL/B
C
	ENTRY SEND_STX
	LAST_CODE(1) = STX		! Save the last code.
	GO TO 50			!  and send it.
C
C	Entry to send ETX (End of Text).	CTRL/C
C
	ENTRY SEND_ETX
	LAST_CODE(1) = ETX		! Save the last code.
50	CALL WRITE_BYTE(LAST_CODE(1),1)	! Write a single byte.
	RETURN
C
C	Entry to send ACK (Acknowlegment).
C
	ENTRY SEND_ACK
	LAST_CODE(1) = ACK		! Save the last code.
	GO TO 100			!  and send it.
C
C	Entry to send NAK (Negative Acknowlement).
C
	ENTRY SEND_NAK
	LAST_CODE(1) = NAK		! Save the last code,
	GO TO 100			!  and send it.
C
C	Entry to send SYN (Synchronize).
C
	ENTRY SEND_SYN
	LAST_CODE(1) = SYN		! Save the last code,
	GO TO 100 			!  and send it.
C
C	Entry to send ENQ (Enquire).
C
	ENTRY SEND_ENQ
	LAST_CODE(1) = ENQ		! Save the last code,
	GO TO 100			!  and send it.
C
C	Entry to send EOF (End of File).
C
	ENTRY SEND_EOF
	LAST_CODE(1) = sub 		! Save the last code,
	GO TO 100			!  and send it.
C
C	Entry to send EOT (End of Transmission).
C
	ENTRY SEND_EOT
	LAST_CODE(1) = EOT		! Save the last code,
	GO TO 100			!  and send it.
C
C	Entry to send CAN (Cancel).
C
	ENTRY SEND_CAN
	LAST_CODE(1) = CAN		! Save the last code,
	GO TO 100			!  and send it.
C
C	This entry is used to resend the last code in the event that
C	the previous transmission was lost or garbled and the remote
C	sent us an ENQ to find out what the last response was.
C
	ENTRY RESEND_CODE
100	CALL RAW_WRITE (LAST_CODE(1), 1)
	RETURN
	END

	SUBROUTINE UPDATE_TOTALS(NBYTES)
C
C	This routine is called after a record is successfully transmitted
C	to update the various counters.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	RETRY_COUNT = 0				! Reinitialize retry counter.
	BYTE_COUNT = BYTE_COUNT + NBYTES	! Accumulate the byte count
	RECORD_COUNT = RECORD_COUNT + 1		!	and the record count.
	TOTAL_BYTES = TOTAL_BYTES + NBYTES	! Update the total byte count.
	TOTAL_RECORDS = TOTAL_RECORDS + 1	!	and the record count.
	RETURN

	ENTRY CLEAR_COUNTS
C
C	Entry to initialize counts.
C
	BYTE_COUNT = 0				! Clear byte count.
	RECORD_COUNT = 0			! Clear record count.
	TOTAL_BYTES = 0				! Clear total bytes.
	TOTAL_RECORDS = 0			! Clear total records.
	ERROR_COUNT = 0				! Clear error count.
	ERROR_RECORD = 0			! Clear error record #.
	PARITY_ERRORS = 0			! Initialize
	OVERRUN_ERRORS = 0			!      the
	TIMEOUTS = 0				!        various
	RETRY_COUNT = 0				!           
	FILE_COUNT = 0				! Number of file transfered.
	BLOCK_COUNT = 0				! Number of blocks transfered.
	BLOCK_RECEIVED = 0			! Received block number.
	BLOCK_XMITTED = 0			! Transmitted block number.
	RETURN

	ENTRY COUNT_FILES
C
C	This routine is called after each file transmission to reset
C	the byte count and record count and adjust the file count.
C
	BYTE_COUNT = 0				! Clear byte count.
	RECORD_COUNT = 0			! Clear record count.
	FILE_COUNT = FILE_COUNT + 1		! Adjust the file count.
	RETURN

	ENTRY REPORT_TOTALS
C
C	Entry to report the final statistics.
C
	CALL SYS$FAO ('!/XMODEM Status Report:!/'//
	1    'Total blocks:!7UL, total records:!7UL, total bytes:!8UL!/'//
	2    'Parity errors:!6UL,      overruns:!7UL,    timeouts:!8UL!/',
	3    SIZE, SCRATCH,
	4    %VAL(BLOCK_COUNT), %VAL(RECORD_COUNT), %VAL(BYTE_COUNT),
	5    %VAL(PARITY_ERRORS), %VAL(OVERRUN_ERRORS), %VAL(TIMEOUT_COUNT))
	CALL WRITE_USER (SCRATCH(1:SIZE))
	END

	SUBROUTINE REPORT_RECORD
C
C	This routine is used to update the statistics on the screen.
C	This routine is also called by the out-of-band AST generated by
C	typing the ESCape key.  If this AST occurs while we're in the
C	middle of updating the screen, the error "Recursive I/O operation"
C	occurs and VAXNET aborts.  For this reason, the IO_IN_PROGRESS
C	flag is used to avoid this problem.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'
	INCLUDE '($ttdef)/NOLIST'
	INTEGER SIZE, SON, EON

	SON = INDEX (VAX_FILE(1:VSIZE), ']') + 1	! Start of name.
	EON = INDEX (VAX_FILE(1:VSIZE), ';') - 1	! End of name.
	IF (EON .LT. 0) EON = VSIZE			! No version number.
	CALL SYS$FAO ('!AS - Blocks: !UL, records: !UL, bytes: !UL'//
	1		', Naks: !UL, (!UL)', SIZE, SCRATCH,
	2		VAX_FILE(SON:EON), %VAL(BLOCK_COUNT),
	3		%VAL(RECORD_COUNT), %VAL(BYTE_COUNT),
	4		%VAL(ERROR_COUNT), %VAL(ERROR_RECORD) )
	CALL WRITE_TTY (SCRATCH(1:SIZE)//CHAR(CR))
	RETURN
	END

	LOGICAL FUNCTION REPORT_ERROR(DISPLAY)
C
C	This routine is used to report a transmission error.  If the retry
C	limit is exceeded, the function returns failure.
C
C	Inputs:
C		DISPLAY - Controls whether the error should be displayed.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	LOGICAL DISPLAY
	CHARACTER*(*) RETRY_MSG
	PARAMETER (RETRY_MSG = ss//
	1 '*** Retry limit exceeded, aborting file transmission ***'
	1 //BELL//ss)

	REPORT_ERROR = .TRUE.			! Presume limit not exceeded.
	ERROR_COUNT = ERROR_COUNT + 1		! Bump the error count.
	ERROR_RECORD = RECORD_COUNT + 1		! Save the error record number.
	RETRY_COUNT = RETRY_COUNT + 1		! Bump the retry count.

	IF (RETRY_COUNT .GE. RETRY_LIMIT) THEN
		REPORT_ERROR = .FALSE.		! Show retry limit exceeded.
C		CALL WRITE_USER(RETRY_MSG)	! Tell the user what happened.
	ENDIF
	RETURN
	END

	SUBROUTINE REPORT_SUCCESS
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
C
C	Routine to display a successful transmission.
C
	CALL CHECK_DISPLAY()
	CALL SYS$FAO ('*** File "!AS" successfully transferred. ***!/',
	1   SIZE, SCRATCH, VAX_FILE(1:VSIZE))
	CALL WRITE_USER (SCRATCH(1:SIZE))
	RETURN

	ENTRY REPORT_ABORT
C
C	Routine to display a aborted transmission.
C
	CALL CHECK_DISPLAY()
	CALL WRITE_USER('*** Transmission of file "'//VAX_FILE(1:VSIZE)//
	1		'" aborted. ***'//crlf(:cl))
	RETURN
	END

	SUBROUTINE CHECK_DISPLAY
C
C	This routine simply writes single spacing to the local terminal
C	if record information was displayed on the screen.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	IF (RECORD_COUNT .GE. DISPLAY_RECORD) THEN
	    CALL WRITE_TTY (crlf(:cl))
	    ENDIF
	RETURN
	END

	SUBROUTINE SETUP_LOCAL(INTERACTIVE)
C
C	This routine is used to setup the local terminal characteristics.
C
C	Inputs:
C		INTERACTIVE - logical .TRUE. for interactive mode.
C				else .FALSE. for normal mode.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'
	INCLUDE '($TTDEF)/NOLIST'
	INCLUDE '($TT2DEF)/NOLIST'

	LOGICAL INTERACTIVE
	CHARACTER*(*) MODULE_NAME
	PARAMETER (MODULE_NAME = 'SETUP_LOCAL')
C
C	Get the local terminal characteristics and set the terminal
C	to full duplex to allow simultanious reads and writes.
C
	STATUS = SYS$QIOW(%VAL(LEFN_IN),%VAL(LCHAN_IN),
	1		%VAL(IO$_SENSEMODE),LIOSB,,,LOCAL_CHAR,%VAL(12),,,,)
	IF (.NOT. CHECK_STATUS(MODULE_NAME,STATUS)) RETURN
C
C	Disable the screen display if we're not on a scope.
C
C
C	For interactive mode, we must enable full duplex (if not enabled)
C	and put the terminal in binary passall mode.  The terminal must
C	be in passall mode to prevent control characters (CTRL/C, CTRL/S,
C	CTRL/Q, CTRL/X, and CTRL/Y) from being processed by the terminal
C	driver when a read is not active.
C
	IF (INTERACTIVE) THEN
c	    LOCAL_CHAR(2) = LOCAL_CHAR(2) .OR. TT$M_PASSALL
	    local_char(3) = local_char(3) .or. tt2$m_pasthru
	    LOCAL_CHAR(2) = LOCAL_CHAR(2) .AND. (.NOT. TT$M_HALFDUP)
	    LOCAL_CHAR(2) = LOCAL_CHAR(2) .OR. TT$M_EIGHTBIT
	    LOCAL_CHAR(2) = LOCAL_CHAR(2) .AND. (.NOT. TT$M_TTSYNC)
	ELSE
c	    LOCAL_CHAR(2) = LOCAL_CHAR(2) .AND. (.NOT. TT$M_PASSALL)
	    local_char(3) = local_char(3) .and. (.not. tt2$m_pasthru)
	    LOCAL_CHAR(2) = LOCAL_CHAR(2) .AND. (.NOT. TT$M_EIGHTBIT)
	    LOCAL_CHAR(2) = LOCAL_CHAR(2) .OR. TT$M_TTSYNC
	ENDIF
C
C	The CTRL/S state must be cleared before going into passall mode,
C	otherwise the read never completes because the CTRL/Q used to clear
C	the suspended state get put in the input buffer.  This results in
C	VAXNET getting hung in a hibernate even though reads are active.
C
	LOCAL_CHAR(3) = LOCAL_CHAR(3) .OR. TT2$M_XON
	STATUS = SYS$QIOW(%VAL(LEFN_IN),%VAL(LCHAN_IN),
	1		%VAL(IO$_SETMODE),LIOSB,,,LOCAL_CHAR,%VAL(12),,,,)
	CALL CHECK_STATUS(MODULE_NAME,STATUS)
	RETURN
	END

	subroutine clear_typeahead
c
c	Clears the typeahead buffer on the local channel.
c	Also sets up the local typeahead buffer.
c
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'

	status = sys$qiow(%val(lefn_in),%val(lchan_in),
	1	%val(io$_readlblk + io$m_purge),
	2	liosb,,,rbuffer,%val(0),,,,)
	call check_status('clear_typeahead',status)
	tnext=1
	return
	end

	SUBROUTINE WAITABIT(SECONDS)
C
C	This subroutine just waits a little then returns.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	CHARACTER*(*) SECONDS
	INTEGER*4 DELTA(2)

	STATUS = SYS$BINTIM('0 00:00:'//SECONDS,DELTA)
	IF (.NOT. CHECK_STATUS('WAITABIT(BINTIM)',STATUS)) RETURN
	STATUS = SYS$SETIMR(%VAL(TIMER_EFN),DELTA,,)
	IF (.NOT. CHECK_STATUS('WAITABIT(SETIMR)',STATUS)) RETURN
	STATUS = SYS$WAITFR(%VAL(TIMER_EFN))
	CALL CHECK_STATUS('WAITABIT(WAITFR)',STATUS)

C	STATUS = SYS$SCHDWK(,,DELTA,,)	! Schedule wakeup.
C	IF (.NOT. CHECK_STATUS('WAITABIT(SCHDWK)',STATUS)) RETURN
C	STATUS = SYS$HIBER()		! Go into hibernation.
	RETURN
	END

	LOGICAL FUNCTION CVT_DTB(STR,NUM)
C
C	This routine is used to convert an ASCII string of numbers to
C	an integer.
C
C	Inputs:
C		STR - string descriptor.
C		NUM - integer to return number to.
C
C	Outputs:
C		.TRUE./.FALSE. = success/failure.
C
	CHARACTER*(*) STR
	INTEGER*4 NUM

	CVT_DTB = LIB$CVT_DTB(%VAL(LEN(STR)),%REF(STR),NUM)
	RETURN
	END

	SUBROUTINE CVT_CTRL(BUFF,SIZE)
C
C	This routine searches for and converts "^char" to control
C	characters.  The original buffer is converted (if necessary)
C	and the new buffer size is passed back in SIZE.
C
	LOGICAL*1 BUFF(1)
	INTEGER*4 SIZE

	I = 1				! Input buffer index.
	O = 1				! Output buffer index.
100	IF (I .GT. SIZE) THEN		! If finished,
		BUFF(O) = 0		! Terminate the buffer.
		SIZE = O - 1		! And pass back new size.
		RETURN
	ENDIF
	BUFF(O) = BUFF(I)		! Copy the next character.
	IF (BUFF(O) .EQ. '^') THEN	! If its an "^",
		I = I + 1		! Point to the next
		BUFF(O) = BUFF(I)-64	! and convert to ctrl/char.
	ENDIF
	I = I + 1			! Next input index.
	O = O + 1			! Next output index.
	GO TO 100			! Loop until we're done.
	END

	INTEGER FUNCTION GET_EFN(EVENT_FLAG)
C
C	Get an event flag.
C
	IMPLICIT NONE
	INTEGER*4 EVENT_FLAG, CHECK_STATUS, LIB$GET_EF, STATUS

	STATUS = LIB$GET_EF(EVENT_FLAG)	! Local input event flag.
	CALL CHECK_STATUS('LIB$GET_EF',STATUS)
	RETURN
	END

	LOGICAL FUNCTION GET_XMODEM
C
C	This routine is used transfer a file from the remote system to
C	the VAX using the XMODEM protocol.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	CHARACTER*(*) MODULE_NAME

	PARAMETER (MODULE_NAME = 'GET_XMODEM')
	PARAMETER (DATA_INDEX = 4)		! Index to 1st data byte.
	PARAMETER (DATA_SIZE = 128)		! Number of data bytes.
	PARAMETER (CHECKSUM_INDEX = 132)	! Index to checksum byte.
	LOGICAL REPORT_ERROR, RECEIVED_EOF
	INTEGER I, INDEX, SIZE
	INTEGER BLOCK_EXPECTED, PREVIOUS_BLOCK, BLOCK_COMP, CHECKSUM, REC_SIZE

	GET_XMODEM = .FALSE.			! Initialize to bad return.
C
C	Synchronize with remote XMODEM.  The sending XMODEM program is
C	waiting to receive a NAK, all other characters are ignored.
C
	CALL SEND_NAK()				! Send NAK to synchronize.
	BLOCK_EXPECTED = 1			! Initialize the block number.
	PREVIOUS_BLOCK = BLOCK_EXPECTED		! Initialize the previous block.
	RECEIVED_EOF = .FALSE.			! Initialize the EOF flag.
	REC_SIZE = 0				! Initialize the record size.
C
C	Loop, waiting for the first byte from the remote.
C
C	We expect either an SOH or EOT byte at this point.
C
100	continue
	RBUFFER(1) = READ_BYTE (6)		! Read the first byte.
	IF (LIOSB(1) .NE. SS$_NORMAL) GO TO 600 ! Report error/NAK.
	IF ( (RBUFFER(1) .NE. SOH) .AND. (RBUFFER(1) .NE. EOT) ) GO TO 100
	IF (RBUFFER(1) .EQ. EOT) GO TO 700	! End of transmission.
	IF (RBUFFER(1) .NE. SOH) GO TO 600	! First byte sould be SOH.
C
C	We received the SOH byte, read the rest of the block.
C
C	Format:  <SOH><block #><comp block #>< 128 data bytes ><checksum>
C
	CALL RAW_READ (RBUFFER(2), DATA_SIZE+(DATA_INDEX-1), TIMEOUT_COUNT)
	BLOCK_RECEIVED = RBUFFER(2) .AND. BITMASK ! Copy the block number.
	BLOCK_COMP = RBUFFER(3)	.AND. BITMASK	! Copy complemented block #.
	IF (BLOCK_RECEIVED .NE. BLOCK_EXPECTED) GO TO 550
	IF ( (BLOCK_RECEIVED + BLOCK_COMP) .NE. BITMASK) GO TO 600
	CHECKSUM = XMODEM_CHECKSUM (RBUFFER(DATA_INDEX), DATA_SIZE)
	IF (CHECKSUM .NE. (RBUFFER(CHECKSUM_INDEX) .AND. BITMASK)) GO TO 600
	BLOCK_COUNT = BLOCK_COUNT + 1		! Adjust the block count.
C
C	Copy the receive buffer and break at CR/LF if text mode.
C
	DO 200 I = DATA_INDEX,DATA_SIZE+(DATA_INDEX-1)
	REC_SIZE = REC_SIZE + 1			! Update the record size.
	LBUFFER(REC_SIZE) = RBUFFER(I)		! Copy the receive buffer.
	IF (FILE_TYPE .EQ. BINARY) GO TO 200	! Copy entire buffer if binary.
	IF (LBUFFER(REC_SIZE) .EQ. sub) THEN
	    REC_SIZE = REC_SIZE - 1		! Don't write the CTRL/Z.
	    RECEIVED_EOF = .TRUE.		! Show EOF was received.
	    GO TO 300				! And go write the buffer.
	ENDIF
	IF (REC_SIZE .GT. 1) THEN
	    IF ( (LBUFFER(REC_SIZE-1) .EQ. CR) .AND.
	1		(LBUFFER(REC_SIZE) .EQ. LF) ) THEN
		REC_SIZE = REC_SIZE - 2		! Adjust for the CR/LF.
		WRITE (FILE_UNIT,400,ERR=999) (LBUFFER(INDEX),INDEX=1,REC_SIZE)
		CALL XMODEM_TOTALS (REC_SIZE)	! Update the file totals.
                RETRY_COUNT=0
		REC_SIZE = 0
	    ENDIF
	ENDIF
200	CONTINUE
C
C	Check for too many bytes in the output buffer.
C
	IF (REC_SIZE .GT. OUT_SIZE) THEN
	    CALL CHECK_DISPLAY()
	    CALL WRITE_USER ('*** The output record is too large, '//
	1		'are you sure this is an ASCII file ? ***'//crlf(:cl))
	    CALL SEND_CAN()			! Cancel the transmission.
	    GO TO 9999				! And report the abortion.
	ENDIF
	IF (FILE_TYPE .EQ. ASCII) GO TO 500	! Don't write buffer yet.
C
C	Write the buffer to the output file.
C
300	IF (REC_SIZE .GT. 0) THEN
	    WRITE (FILE_UNIT,400,ERR=999) (LBUFFER(INDEX),INDEX=1,REC_SIZE)
400	    FORMAT (<REC_SIZE>A1)
	    CALL XMODEM_TOTALS (REC_SIZE)	! Update the totals.
            RETRY_COUNT=0
	    REC_SIZE = 0			! Initialize the record size.
	ENDIF
500	PREVIOUS_BLOCK = BLOCK_EXPECTED		! Copy the current block #.
	BLOCK_EXPECTED = MOD (BLOCK_EXPECTED+1,256) .AND. BITMASK
	CALL SEND_ACK()				! Send an ACKnowlegment.
	GO TO 100				! Go read the next block.
C
C	We come here when the block number don't match.
C
550	IF (BLOCK_RECEIVED .EQ. PREVIOUS_BLOCK) THEN
	    CALL SEND_ACK()			! ACK previous block number.
	    GO TO 100				! Go read the next block.
	ELSE
	    CALL CHECK_DISPLAY()
	    CALL SYS$FAO ('*** Phase error -- received block is !UL ***!/',
	1		SIZE, SCRATCH, %VAL(BLOCK_RECEIVED) )
	    CALL WRITE_USER (SCRATCH(1:SIZE))
	    CALL SYS$FAO ('***      While the expected block is !UL. ***!/',
	1		SIZE, SCRATCH, %VAL(BLOCK_EXPECTED) )
	    CALL WRITE_USER (SCRATCH(1:SIZE))
	    CALL SEND_CAN()			! Cancel the transmission.
	    GO TO 9999
	ENDIF
C
C	We come here to send a NAK for a tranmission error.
C
600	CONTINUE
C	CALL CLEAR_TYPEAHEAD		! Wait until remote is idle.
	IF (REPORT_ERROR(.TRUE.)) THEN	! Report the transmission error.
	    CALL SEND_NAK()		! Tell remote to resend last record.
	    GO TO 100			! And try again.
	ELSE
	    CALL SEND_CAN()		! Limit exceeded, abort transmission.
	    GO TO 9999			! Report the abortion ...
	ENDIF
C
C	We come here to process end of file.
C
700	CLOSE (UNIT=FILE_UNIT)		! Close the input file
	CALL SEND_ACK()			! Tell remote XMODEM we got EOT.
	CALL REPORT_SUCCESS()		! Report the transmission success.
	GET_XMODEM = .TRUE.		! Return success.
	RETURN
C
C	We come here if an error occurs writing the output file.
C
999	CALL RMS_ERROR (MODULE_NAME)	! Report the RMS error message.
	CALL SEND_CAN()			! Cancel the transmission & exit.
C
C	We come here to report failure.
C
9999	CLOSE (UNIT=FILE_UNIT)		! Close the input file.
	CALL REPORT_ABORT()		! Report the aborted transmission.
	RETURN
	END

	LOGICAL FUNCTION SEND_XMODEM
C
C	This routine is used transfer a file to the remote system from
C	the VAX using the XMODEM protocol.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	PARAMETER (DATA_INDEX = 4)		! Index to 1st data byte.
	PARAMETER (DATA_SIZE = 128)		! Number of data bytes.
	PARAMETER (BLOCK_SIZE = DATA_SIZE + 3)	! Size of block - checksum.
	LOGICAL REPORT_ERROR, AT_EOF
	INTEGER BYTES, XMIT_SIZE, CHECKSUM, DINDEX, I

	SEND_XMODEM = .FALSE.			! Initialize to bad return.
	AT_EOF = .FALSE.			! Show not at end of file.
	BLOCK_XMITTED = 1			! Initialize the block #.
	XMIT_SIZE = DATA_INDEX - 1		! Initialize the XMIT size.
C
C	Wait until the remote XMODEM sends us a NAK.
C
	CALL CLEAR_TYPEAHEAD()			! Clear any garbage.
0010	RBUFFER(1) = READ_BYTE (TIMEOUT_COUNT)	! Read the first byte.
	if(rbuffer(1).eq.nak) go to 99
	IF (REPORT_ERROR(.TRUE.)) THEN		! Report transmission error.
	    GO TO 10				! And try again.
	ELSE
	    CALL SEND_CAN()			! Limit exceeded, abort.
	    GO TO 9999				! Report the abortion ...
	ENDIF
 0099	error_count=0				! Don't penalize him for startup

C
C	Read a record from the input file.
C
100	DINDEX = 1				! Index into input record.
	READ (FILE_UNIT,110,END=9900,ERR=9990) BYTES,(LBUFFER(I),I=1,BYTES)
110	FORMAT (Q,<BYTES+1>A1)
	CALL XMODEM_TOTALS (BYTES)		! Update the file totals.
        RETRY_COUNT=0
C
C	If we're in text mode, append a CR/LF sequence.
C
	IF (FILE_TYPE .EQ. ASCII) THEN
	    LBUFFER(BYTES+1) = CR		! Append a carraige return
	    LBUFFER(BYTES+2) = LF		!	and a line feed.
	    BYTES = BYTES + 2			! Adjust the byte count.
	ENDIF
	IF (BYTES .EQ. 0) GO TO 100		! Blank binary record.
C
C	Prepare the buffer to transmit.
C
C	Format:  <SOH><block #><comp block #>< 128 data bytes ><checksum>
C
200	DO 300 I = DINDEX,BYTES
	XMIT_SIZE = XMIT_SIZE + 1		! Adjust the XMIT buffer size.
	XBUFFER(XMIT_SIZE) = LBUFFER(I) .AND. BITMASK ! Copy the next byte.
	IF (XMIT_SIZE .EQ. BLOCK_SIZE) GO TO 400 ! Go transmit this block.
300	CONTINUE
	GO TO 100				! Go read the next record.
C
C	Calculate the checksum and transmit this block.
C
400	DINDEX = I + 1				! Save index into record.
	XBUFFER(1) = SOH			! Start with the SOH byte.
	XBUFFER(2) = BLOCK_XMITTED		! Fill in the block number.
	XBUFFER(3) = (255 - BLOCK_XMITTED) .AND. BITMASK ! Comp. block number.
	CHECKSUM = XMODEM_CHECKSUM (XBUFFER(DATA_INDEX), DATA_SIZE)
	XMIT_SIZE = XMIT_SIZE + 1		! Point to checksum byte.
	XBUFFER(XMIT_SIZE) = CHECKSUM		! Fill in the checksum.
	BLOCK_XMITTED = MOD (BLOCK_XMITTED+1,256) .AND. BITMASK
	BLOCK_COUNT = BLOCK_COUNT + 1		! Adjust the block count.
C
C	Write the buffer to the remote.
C
600	CALL RAW_WRITE (XBUFFER, XMIT_SIZE)	! Write this block of data.
C
C	Now, we must wait for an ACKnowlegment.
C
	RBUFFER(1) = READ_BYTE (TIMEOUT_COUNT)	! Read response from remote.
	IF (LIOSB(1) .NE. SS$_NORMAL) GO TO 700 ! Report transmission error.
	IF (RBUFFER(1) .EQ. CAN) GO TO 9999	! Transmission is cancelled.
	IF (RBUFFER(1) .EQ. ACK) GO TO 800	! Block successfully sent.
C
C	Report the transmission error.
C
700	IF (REPORT_ERROR(.TRUE.)) THEN		! Report transmission error.
	    GO TO 600				! And try again.
	ELSE
	    CALL SEND_CAN()			! Limit exceeded, abort.
	    GO TO 9999				! Report the abortion ...
	ENDIF
C
C	Now we're ready to finish the previous record or read the next.
C
800	IF (XBUFFER(1) .EQ. EOT) GO TO 9910	! Our EOT has been ACKed.
        RETRY_COUNT=0
900	IF (AT_EOF) THEN
	    XMIT_SIZE = 1			! Set size of XMIT buffer.
	    XBUFFER(XMIT_SIZE) = EOT		! Get ready to send EOT.
	    GO TO 600				! Send end of transmission.
	ENDIF
	XMIT_SIZE = DATA_INDEX - 1		! Reinitialize the XMIT size.
	IF (DINDEX .LE. BYTES) THEN
	    GO TO 200				! Finish the previous record.
	ELSE
	    GO TO 100				! Read the next record.
	ENDIF
C
C	We come here for end of file on input file.
C
9900	AT_EOF = .TRUE.				! Show we're at end of file.
	IF ( (FILE_TYPE .EQ. BINARY) .AND.
	1	(XMIT_SIZE .EQ. DATA_INDEX-1) ) GO TO 900 ! Send EOT only.
C
C	This is the last block, so we pad it with EOF bytes.
C
	DO 9901 I = 1,BLOCK_SIZE
	XMIT_SIZE = XMIT_SIZE + 1		! Bump the XMIT buffer size.
	XBUFFER(XMIT_SIZE) = sub		! Fill buffer with EOF's.
	IF (XMIT_SIZE .EQ. BLOCK_SIZE) GO TO 400 ! Go transmit this block.
9901	CONTINUE
C
C	Transmission complete.
C
9910    CLOSE (UNIT=FILE_UNIT)			! Close the input file.
	CALL REPORT_SUCCESS()			! Report transmission success.
	SEND_XMODEM = .TRUE.			! Show success.
	RETURN
C
C	We come here if an error occurs writing the output file.
C
9990	CALL RMS_ERROR (MODULE_NAME)		! Report the RMS error message.
	CALL SEND_CAN()				! Cancel the transmission.
C
C	Here to report failure.
C
9999	CLOSE (UNIT=FILE_UNIT)			! Close the output file.
	IF (AT_EOF) THEN
	    CALL CHECK_DISPLAY()
	    CALL WRITE_USER('*** Remote not responding on completion. ***'//
	1	crlf(:cl))
	ENDIF
	CALL REPORT_ABORT()			! Report aborted transmission.
	RETURN
	END

	integer function read_byte (seconds)
c
c	This routine is used to read a single byte.
c	If any characters are in the local typeahead, they are used first.
c
c	Inputs:
c		SECONDS = The timeout in seconds.
c
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'

	integer seconds
	logical*1 buff(1)

	if(tnext.gt.1) then
	    read_byte = tbuffer(1)
	    cbuffer=cbuffer(2:tnext)
	    tnext=tnext-1
	    return
	else
	    call raw_read (buff, 1, seconds)
	    read_byte = buff(1) .and. bitmask
	    return
	endif
	end

	SUBROUTINE SEND_BYTE (BUFFER)
C
C	This routine is used to write a single byte.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	LOGICAL*1 BUFFER(1), BUFF(1)

	BUFF(1) = BUFFER(1) .AND. BITMASK
	CALL RAW_WRITE (BUFF(1),1)
	RETURN
	END

	INTEGER FUNCTION RAW_READ (BUFFER, BYTES, SECONDS)
C
C	This routine is used to read raw data (no interpretation).
C
C	Inputs:
C		BUFFER = The buffer to read into.
C		BYTES = The number of bytes to read.
C		SECONDS = The timeout in seconds.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	CHARACTER*(*) MODULE_NAME
	PARAMETER (MODULE_NAME = 'RAW_READ')

	LOGICAL*1 BUFFER(1)
	INTEGER BYTES, SECONDS, STATUS

	STATUS = SYS$QIOW (%VAL(LEFN_IN),%VAL(LCHAN_IN),
	1		%VAL(IO$_TTYREADALL + IO$M_NOECHO + IO$M_TIMED),
	1		LIOSB,,,BUFFER,%VAL(BYTES),
	1		%VAL(SECONDS),NOTERM,,)

	RAW_READ = STATUS		! Copy the directive status.
	IF (.NOT. CHECK_STATUS (MODULE_NAME, STATUS)) RETURN
	RAW_READ = LIOSB(1)		! Pass back I/O status.
	RBYTE_COUNT = LIOSB(2)		! Save the byte count.
C
C	Check for various errors:
C
	IF     (LIOSB(1) .EQ. SS$_TIMEOUT) THEN		! Timeout error ?
		TIMEOUTS = TIMEOUTS + 1			! Yes, count it.
		GO TO 200				! And continue ...
	ELSEIF (LIOSB(1) .EQ. SS$_PARITY) THEN		! Parity error ?
		PARITY_ERRORS = PARITY_ERRORS + 1	! Yes, count it,
		GO TO 200				! And continue ...
	ELSEIF (LIOSB(1) .EQ. SS$_DATAOVERUN) THEN	! Data overrun ?
		OVERRUN_ERRORS = OVERRUN_ERRORS + 1	! Yes, count it.
		GO TO 200				! And continue ...
	ELSEIF (LIOSB(1) .NE. SS$_ABORT) THEN		! CTRL/C to abort.
		CALL CHECK_STATUS (MODULE_NAME, RAW_READ)
	ENDIF
	RETURN
C
C	Here for timeout and hardware errors.
C
200	BUFFER(1) = 0				! Force bad transmission
	RBYTE_COUNT = 0				!  by clearing buffer & BC.
	RETURN
	END

	SUBROUTINE RAW_WRITE (BUFFER, BYTES)
C
C	This routine is used to write raw data (no interpretation).
C
C	Inputs:
C		BUFFER - The buffer to write.
C		BYTES - The number of bytes to write.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	CHARACTER*(*) MODULE_NAME
	PARAMETER (MODULE_NAME = 'RAW_WRITE')

	LOGICAL*1 BUFFER(1)
	INTEGER BYTES, STATUS

c	CALL WRITE_DEBUG (MODULE_NAME, BUFFER, BYTES)
	STATUS = SYS$QIOW (%VAL(LEFN_OUT),%VAL(LCHAN_OUT),
	1		%VAL(IO$_WRITELBLK + IO$M_NOFORMAT),
	1		XIOSB,,,BUFFER,%VAL(BYTES),,,,)
	CALL CHECK_STATUS (MODULE_NAME, STATUS)
	RETURN
	END

	SUBROUTINE XMODEM_TOTALS (BYTES)
C
C	This routine is called after a record is successfully transmitted
C	to update the various counters.  Since the routine is called while
C	building a transmit buffer from multiple input records, the record
C	display has a special entry which is called after tranmitting the
C	current block.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	INTEGER BYTES

	BYTE_COUNT = BYTE_COUNT + BYTES		! Accumulate the byte count
	RECORD_COUNT = RECORD_COUNT + 1		!	and the record count.
	RETURN
	END

	SUBROUTINE WRITE_USER(MSG)
C
C	Write a buffer to the user and the log file if open.
C
C	Inputs:
C		MSG - string descriptor with message.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	CHARACTER*(*) MSG
	INTEGER SIZE, STATUS

	SIZE = LEN(MSG)
	GO TO 100

	ENTRY WRITE_BUFF (MSG)
C
C	Entry to write to the log file and the terminal.
C
	SIZE = LEN(MSG)
	GO TO 100

	ENTRY WRITE_TTY (MSG)
C
C	Entry to write to the terminal only.
C
	SIZE = LEN(MSG)
100	STATUS = SYS$QIOW(%VAL(LEFN_OUT),%VAL(LCHAN_OUT),
	1    %VAL(IO$_WRITELBLK + IO$M_NOFORMAT),
	1    LIOSB,,,%REF(MSG),%VAL(SIZE),,,,)
	IF (.NOT. STATUS) THEN
	    CALL LIB$SIGNAL(%VAL(STATUS))
	    CALL SYS$EXIT(%VAL(STATUS))
	    ENDIF
	RETURN
	END

	SUBROUTINE RMS_ERROR (MODULE)
C
C	This routine is called to report an RMS error.
C
C	CALL ERRSNS(num,rmssts,rmsstv,iunit,)
C
C	Where:	num = fortran error code,
C		rmssts = RMS completion status code.
C		rmsstv = RMS status code.
C		iunit = logical unit number.
C
	IMPLICIT NONE

	INTEGER*4 FERR, RMSSTS, RMSSTV, LUN, CHECK_STATUS, ERROR
	CHARACTER*(*) MODULE

	CALL ERRSNS (FERR,RMSSTS,RMSSTV,LUN,)	! Get the last error code.
	ERROR = RMSSTS				! Copy the RMS error code.
	IF (ERROR .EQ. 0) ERROR = FERR		! Use the FORTRAN error code.
	CALL CHECK_STATUS (MODULE, ERROR)	! Go report the error message.
	RETURN
	END

	SUBROUTINE WRITE_REMOTE (BUFFER, NBYTES)
C
C	This subroutine is used to write a buffer to the remote.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	LOGICAL*1 BUFFER(1)

	BYTES = NBYTES + 1		! Adjust the byte count.
	BUFFER(BYTES) = CR		! Append Terminator.
	GO TO 100			! And continue ...
C
C	The next entry is used to write the buffer without appending
C	a carriage return to the end of the message.
C
	ENTRY WRITE_BYTE (BUFFER, NBYTES)
	BYTES = NBYTES			! Copy the byte count.

100	STATUS = SYS$QIOW(%VAL(LEFN_OUT),%VAL(LCHAN_OUT),
	1		%VAL(IO$_WRITELBLK + IO$M_NOFORMAT),
	1		XIOSB,,,BUFFER,%VAL(BYTES),,,,)
	CALL CHECK_STATUS('WRITE_REMOTE',STATUS)
	RETURN
	END

	SUBROUTINE HANGUP_MODEM
C
C	This routine is called to hangup the modem.
C
	implicit integer*4 (a-z)
	INCLUDE 'BBS_INC.FOR/NOLIST'

	LOCAL_STATUS = SYS$QIOW(%VAL(LEFN_IN),%VAL(LCHAN_IN),
	1   %VAL(IO$_SETMODE + IO$M_HANGUP),LIOSB,,,,,,,,)
	RETURN
	END

	subroutine fake_vaxnet
c	This code was surgically removed from VAXNET, and appears here
c	in a somewhat mangled, but usuable state.
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	bitmask=sevenbit_mask
c	set up event flags
	call get_efn(lefn_in)		! Local input event flag
	call get_efn(lefn_out)		! Local output event flag
C
C	Translate SYS$COMMAND, and assign a channel for QIO's.
C
	I = 11				! Size of SYS$COMMAND
	LOCAL_DEVICE = 'SYS$COMMAND'
10	STATUS = SYS$TRNLOG(LOCAL_DEVICE(1:I),I,LOCAL_DEVICE,,,)
	IF (STATUS .NE. SS$_NOTRAN) GO TO 10
C
C	Note in the following that I contains the true length, and remember
C	that TRNLOG puts a stupid 4-byte header on the translations of
C	SYS$INPUT/OUTPUT specifically.  This header only exists if the
C	first byte starts with an escape character.
C
	IF (LOCAL_DEVICE(1:1) .EQ. CHAR(esc)) THEN
		S = 5			! Point past header.
	ELSE
		S = 1			! Use entire string.
	ENDIF
	STATUS = SYS$ASSIGN(LOCAL_DEVICE(S:I),LCHAN_IN,,)
	IF (.NOT. STATUS) THEN
		CALL LIB$SIGNAL(%VAL(STATUS))
		CALL SYS$EXIT(%VAL(STATUS))
	ENDIF
	STATUS = SYS$ASSIGN(LOCAL_DEVICE(S:I),LCHAN_OUT,,)

	return
	END

	subroutine get_password (password,len)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will read a password and echo asterisks in its place.
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	logical*1 asterisk(1)/'*'/
	logical*1 back_up(3)/bs,' ',bs/
	character password*(*),temp3*10
	integer temp1(11)
	character temp2(10)
	equivalence(temp3,temp2)
	len=1
	timeouts=0
 0010	temp1(len)=read_byte(60)
	if(timeouts.gt.4) call finish_timeout
	if(temp1(len).eq.cr) go to 50		!carriage return
	if(temp1(len).eq.bs) go to 20		!backspace
	if(temp1(len).eq.rub) go to 20		!rubout
	if(temp1(len).eq.nak) go to 30		!control-u
	if(temp1(len).eq.can) go to 30		!control-x
	if(temp1(len).le.us) go to 10		!other control character
	if(temp1(len).ge.97.and.temp1(len).le.122) 
	1    temp1(len)=temp1(len)-32
	if(len.gt.10) go to 10
	call send_byte(asterisk)
	len=len+1
	go to 10

c	delete a character (^h or del)
 0020	if(len.eq.1) go to 10		!nothing to delete
	len=len-1
	call raw_write(back_up,3)
	go to 10

c	delete to beginning of string
 0030	do j=2,len
	    call raw_write(back_up,3)
	    end do
	len=1
	go to 10

 0050	len=len-1
	do j=len+1,10
	    call send_byte(asterisk)
	    end do
	call send_byte(cr)
	temp3='          '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	password=temp3
	return
	end

	subroutine get_upcase_string (string,len)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will allow input of an upper-case-only string.
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	character string*(*),temp3*20
	logical*1 back_up(3)/bs,' ',bs/
	logical*1 to_send(1)
	logical*1 spc
  	integer temp1(21)
	character temp2(20)
	equivalence(temp3,temp2)
	spc=.false.
	if(len.lt.0) then
	    len=-len
	    spc=.true.
	    end if
	max=len
	len=1
	timeouts=0
 0010	temp1(len)=read_byte(60)
	if(timeouts.gt.4) call finish_timeout
	if(temp1(len).eq.cr) go to 50		!carriage return
	if(temp1(len).eq.bs) go to 20		!backspace
	if(temp1(len).eq.rub) go to 20		!rubout
	if(temp1(len).eq.dc2) go to 60		!Control-r  (Repaint line)
	if(temp1(len).eq.nak) go to 30		!control-u
	if(temp1(len).eq.can) go to 30		!control-x
	if(temp1(len).le.us) go to 10		!other control character
	if(temp1(len).eq.32.and..not.spc) go to 10
c	force to only alphabetic plus ' and -
	if(temp1(len).ge.33.and.temp1(len).le.38) go to 10
	if(temp1(len).ge.40.and.temp1(len).le.44) go to 10
	if(temp1(len).ge.46.and.temp1(len).le.64) go to 10
	if(temp1(len).ge.91.and.temp1(len).le.96) go to 10
	if(temp1(len).ge.123.and.temp1(len).le.126) go to 10
c	convert lower-case to upper-case
	if(temp1(len).ge.97.and.temp1(len).le.122)
	1     temp1(len)=temp1(len)-32
	if(len.gt.max) go to 10
	to_send(1)=temp1(len)
	call send_byte(to_send)
	len=len+1
	go to 10

c	delete a character (^h or del)
 0020	if(len.eq.1) go to 10		!nothing to delete
	len=len-1
	call raw_write(back_up,3)
	go to 10

c	delete to beginning of string
 0030	do j=2,len
	    call raw_write(back_up,3)
	    end do
	len=1
	go to 10

 0050	continue
	call send_byte(cr)
	len=len-1
	temp3=' '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	return

 0060	continue	!repaint line
	len=len-1
	temp3=' '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	call out(string(1:len),*10)
	len=len+1
	go to 10	
	end

	subroutine get_uplow_string (string,len)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will allow input of all but control characters.
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	character string*(*),temp3*200
	logical*1 back_up(3)/bs,' ',bs/
	logical*1 to_send(1),ctlz
  	integer temp1(201)
	character temp2(200)
	equivalence(temp3,temp2)
	ctlz=.false.		!assume no control-z allowed
	if(len.lt.0) then
	    len=-len
	    ctlz=.true.
	    end if
	max=len
	len=1
	timeouts=0
 0010	temp1(len)=read_byte(60)
	if(timeouts.gt.4) call finish_timeout
	if(temp1(len).eq.cr) go to 50		!carriage return
	if(temp1(len).eq.bs) go to 20		!backspace
	if(temp1(len).eq.rub) go to 20		!rubout
	if(temp1(len).eq.dc2) go to 90		!Control-r
	if(temp1(len).eq.nak) go to 30		!control-u
	if(temp1(len).eq.can) go to 30		!control-x
	if(temp1(len).eq.sub.and.len.eq.1.and.ctlz)
	1    go to 70				!control-z (eof)
	if(temp1(len).eq.etx.and.len.eq.1.and.ctlz)
	1    go to 80				!control-c (abort)
	if(temp1(len).le.us) go to 10		!other control character
	if(len.gt.max) go to 10
	to_send(1)=temp1(len)
	call send_byte(to_send)
	len=len+1
	go to 10

c	delete a character (^h or del)
 0020	if(len.eq.1) go to 10			!nothing to delete
	len=len-1
	call raw_write(back_up,3)
	go to 10

c	delete to beginning of string
 0030	do j=2,len
	    call raw_write(back_up,3)
	    end do
	len=1
	go to 10

 0050	len=len-1
	call send_byte(cr)
 0060	continue
	temp3='                    '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	return

 0070	continue	!control-z
	len=-1
	string=' '
	return

 0080	continue	!control-c
	len=-2
	string=' '
	return

 0090	continue	!repaint line
	len=len-1
	temp3=' '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	call out(string(1:len),*10)
	len=len+1
	go to 10	
	end

	subroutine get_number (string,len,flag)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will read a numeric string or an asterisk.
c	If flag = .true. an asterisk is allowed.
c
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	logical*1 asterisk(1)/'*'/
	logical*1 back_up(3)/bs,' ',bs/
	character string*(*),temp3*80
	character temp2(80)
	logical flag
	integer temp1(81)
	equivalence(temp3,temp2)
	max=len				
	len=1
	timeouts=0
 0010	temp1(len)=read_byte(60)
	if(timeouts.gt.4) call finish_timeout
	if(temp1(len).eq.cr) go to 50		!carriage return
	if(temp1(len).eq.bs) go to 20		!backspace
	if(temp1(len).eq.rub) go to 20		!rubout
	if(temp1(len).eq.dc2) go to 60		!Control-r
	if(temp1(len).eq.nak) go to 30		!control-u
	if(temp1(len).eq.can) go to 30		!control-x
	if(temp1(len).eq.42.and.len.eq.1.and.flag)
	1    go to 15				!asterisk
	if(temp1(len).lt.48) go to 10		!less than 0
	if(temp1(len).gt.57) go to 10		!greater than 9
	if(len.gt.max) go to 10
 0015	call send_byte(temp1(len))
	len=len+1
	go to 10

c	delete a character (^h or del)
 0020	if(len.eq.1) go to 10		!nothing to delete
	len=len-1
	call raw_write(back_up,3)
	go to 10

c	delete to beginning of string
 0030	do j=2,len
	    call raw_write(back_up,3)
	    end do
	len=1
	go to 10

 0050	len=len-1
	call send_byte(cr)
	temp3='          '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	return

 0060	continue	!repaint line
	len=len-1
	temp3=' '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	call out(string(1:len),*10)
	len=len+1
	go to 10	
	end

	subroutine get_filnam_string (string,len)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will allow input of a VAX filename.
c
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	character string*(*),temp3*30
	logical*1 back_up(3)/bs,' ',bs/
	logical*1 to_send(1)
	logical*1 period
  	integer temp1(31)
	character temp2(30)
	equivalence(temp3,temp2)
	period=.false.
	max=len
	len=1
	timeouts=0
 0010	temp1(len)=read_byte(60)
	if(timeouts.gt.4) call finish_timeout
	if(temp1(len).eq.cr) go to 50		!carriage return
	if(temp1(len).eq.bs) go to 20		!backspace
	if(temp1(len).eq.rub) go to 20		!rubout
	if(temp1(len).eq.dc2) go to 60		!Control-r
	if(temp1(len).eq.nak) go to 30		!control-u
	if(temp1(len).eq.can) go to 30		!control-x
	if(temp1(len).le.us) go to 10		!other control character
c	force to only alphabetic plus _ and .
	if(temp1(len).le.45) go to 10
	if(temp1(len).eq.46.and.period) go to 10
	if(temp1(len).eq.46) period=.true.
	if(temp1(len).eq.47) go to 10
	if(temp1(len).ge.58.and.temp1(len).le.64) go to 10
	if(temp1(len).ge.91.and.temp1(len).le.94) go to 10
	if(temp1(len).eq.96) go to 10
	if(temp1(len).ge.123.and.temp1(len).le.126) go to 10
c	convert lower-case to upper-case
	if(temp1(len).ge.97.and.temp1(len).le.122)
	1     temp1(len)=temp1(len)-32
	if(len.gt.max) go to 10
	to_send(1)=temp1(len)
	call send_byte(to_send)
	len=len+1
	go to 10

c	delete a character (^h or del)
 0020	if(len.eq.1) go to 10		!nothing to delete
	len=len-1
	if(temp1(len).eq.46) period=.false.
	call raw_write(back_up,3)
	go to 10

c	delete to beginning of string
 0030	do j=2,len
	    call raw_write(back_up,3)
	    end do
	len=1
	period=.false.
	go to 10

 0050	continue
	call send_byte(cr)
	if(period) then
	    len=len-1
	else
	    temp1(len)=46
	    end if
	temp3=' '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	return

 0060	continue	!repaint line
	len=len-1
	temp3=' '
	do j=1,len
	    temp2(j)=char(temp1(j))
	    end do
	string=temp3
	call out(string(1:len),*10)
	len=len+1
	go to 10	
	end

	subroutine ctrl_o_check(*,*)
c	this routine will stick anything other than ^c, ^q, ^s, and ^o
c	into the local typeahead buffer.
c	and take alternate returns for ^o or ^c
c
	implicit none
	include 'bbs_inc.for/nolist'
	logical*1 temp1(1)

	timeouts=0
	call raw_read(temp1,1,0)
	temp1(1) = temp1(1) .and. bitmask
	do while(temp1(1).ne.0)
	    if(temp1(1).eq.03) return 1	!Control-c return statement
	    if(temp1(1).eq.15) return 2	!Control-o return statement
	    if(temp1(1).eq.21.or.temp1(1).eq.24) tnext=1   !^x/^u
	    if(temp1(1).eq.19) then
		do while(temp1(1).ne.3.and.temp1(1).ne.17
	1	    .and.temp1(1).ne.15)
		    call raw_read(temp1,1,60)
		    temp1(1) = temp1(1) .and. bitmask
		    if(timeouts.gt.4) call finish_timeout
		    if(tnext.lt.1024) then
			tbuffer(tnext)=temp1(1)
			tnext=tnext+1
		    else
			write(6,1001)bell
		    endif
		    end do
		if(temp1(1).eq.03) return 1
		if(temp1(1).eq.15) return 2
		if(temp1(1).eq.17) return
		end if
	    if(tnext.lt.1024) then
		tbuffer(tnext)=temp1(1)
		tnext=tnext+1
		temp1(1)=0
	    else
		write(6,1001)bell
		temp1(1)=0
	    endif
	    timeouts=0
	    call raw_read(temp1,1,0)
	    temp1(1) = temp1(1) .and. bitmask
	    end do
	return
 1001	format(a)
	end

	subroutine read_mail(mess,irec,status,nostop,next_mess)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will read a message, display it on the screen,
c	and then give the user a menu of options.
c
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c	Rev. 4.5  29-Aug-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	include 'sys$library:foriosdef/nolist'
	external bbs_get_input,bbs_put_output

	character line*80,pm*14/' ** private **'/,xxx*4
	character cdummy*1,zmail_to*30,zmail_from*30
	character snum*6,qmail_to*30,yesno*3,string*30,lms*9
	character zfirst_name*20,zlast_name*20,defcmd*1
	logical flag
	byte dummyb
	logical*1 reprint,found,nostop,busy

	record /userlog_structure/ zur

	record /mail_header_structure/ mh

 1001	format(a)
 1011	format(i<dummy>)
 1013	format(a,i2,'>')
 1015	format(a,i2,1x,a)
 1019	format(a,'Section #',i1,' - ',a)
	status=0
	err=0

c	step 1.  Get in the general area of the message

	found=.false.
	next_mess=0
	do while(.not.found)
	    irec=irec+20
	    if(irec.gt.last_header) found=.true.
	    read(2,rec=irec,iostat=ios,err=90600)mh
	    unlock(unit=2)
	    if(mh.mail_messnum.ge.mess) found=.true.
	    end do
	irec=irec-20

c	we are now within 20 reads of the message

	found=.false.
	do while(.not.found)
	    if(irec.gt.last_header) found=.true.
	    read(2,rec=irec,iostat=ios,err=90600) mh
	    unlock(unit=2)
	    if(mh.mail_messnum.ge.mess) then
		found=.true.
	    else
		irec=irec+1
	    end if
	    end do
	if(mh.mail_messnum.gt.mess) then
	    next_mess=mh.mail_messnum
	    irec=irec-1
	    go to 20000
	    end if
	if(mh.mail_deleted.and.(.not.sysop)) go to 20000
	zz=mh.mail_section
	dummyb=2**zz
	istat=str$upcase(zmail_to,mh.mail_to)
	istat=str$upcase(zmail_from,mh.mail_from)

	if((mh.mail_to.ne.mail_name).and.
	1   ((dummyb.and.ur.auth_sections).eq.0)) go to 20000

	if(mh.mail_messnum.eq.mess.and.mh.mail_private) then
	    if((mail_name.ne.zmail_to).and.
	1	(mail_name.ne.zmail_from).and.(.not.sysop)) then
		go to 20000
		end if
	    end if
	if(mh.mail_messnum.eq.mess) then
	    status=-1					! We read it
	    istat=str$trim(mh.mail_from,mh.mail_from,dummy1)
	    istat=str$trim(mh.mail_to,mh.mail_to,dummy2)
	    istat=str$trim(mh.mail_subject,mh.mail_subject,dummy3)
	    if(dummy1.lt.1.or.dummy1.gt.30) dummy1=30
	    if(dummy2.lt.1.or.dummy2.gt.30) dummy2=30
	    if(dummy3.lt.1.or.dummy3.gt.30) dummy3=30
	    xxx = '    '
	    write(6,1019)crlf(:cl)//ffeed(:fl),mh.mail_section,
	1	secnam(mh.mail_section+1)
	    call ctrl_o_check(*21000,*10580)
	    call comint(mh.mail_messnum,lms)
	    write(6,1001)crlf(:cl)//'Message number:'//lms//' on '//
	1	mh.mail_date//' at '//mh.mail_time
	    call ctrl_o_check(*21000,*10580)
	    if(mh.mail_read) xxx = ' (X)'
	    if(mh.mail_private) then
		write(6,1001)crlf(:cl)//
	1	    '   From: '//mh.mail_from(1:dummy1)//pm
	    else
		write(6,1001)crlf(:cl)//'   From: '//mh.mail_from(1:dummy1)
	    end if
	    call ctrl_o_check(*21000,*10580)
	    write(6,1001)crlf(:cl)//'     To: '//Mh.mail_to(1:dummy2)//xxx
	    call ctrl_o_check(*21000,*10580)
	    if(mh.mail_reply_to.eq.0) then
		write(6,1001)crlf(:cl)//'Subject: '//mh.mail_subject(1:dummy3)
	    else
		call comint(mh.mail_reply_to,lms)
		write(6,1001)crlf(:cl)//'Subject: #'//lms//'-'//
	1	    mh.mail_subject(1:dummy3)
	    end if
	    if((sysop.or.sysop2).and..not.mh.mail_person) then
		istat=sys$asctim(,string,mh.mail_expire,)
		write(6,1001)' -- Expires on: '//string(1:11)
		end if
	    call ctrl_o_check(*21000,*10580)
	    if(mh.mail_deleted) write(6,1001)crlf(:cl)//'**** deleted ****'
	    write(6,1001)crlf(:cl)
	    do ii=mh.mail_first,mh.mail_last
		read(3,rec=ii,iostat=ios)line
		unlock(unit=3)
		call ctrl_o_check(*21000,*10580)
		istat=str$trim(line,line,x)
		write(6,1001)crlf(:cl)//line(1:x)
		end do
	    write(6,1001)crlf(:cl)
	    end if
	if((mh.mail_messnum.eq.mess).and.(.not.mh.mail_read).and.
	1    (zmail_to.eq.mail_name)) then
	    read(2,rec=irec,iostat=ios,err=90600) mh
	    mh.mail_read=.true.
	    write(2,rec=irec,err=90600,iostat=ios) mh
	    read(1,key=ur.user_key,iostat=ios,err=90500)ur
	    ur.num_unread=ur.num_unread-1
	    if(ur.num_unread.lt.0) ur.num_unread=0
	    if(mess.gt.ur.last_message.and.area.ne.'marked')
	1	ur.last_message=mess
	    rewrite(1,err=90500)ur
	    end if
	if (area.eq.'marked') go to 10580
	if(mess.gt.ur.last_message) then
10540	    read(1,key=ur.user_key,iostat=ios,err=90500)ur
	    if(area.ne.'marked')ur.last_message=mess
	    rewrite(1,err=90500,iostat=ios)ur
	    end if
10580	continue
	if(nostop.and.(zmail_to.ne.mail_name)) return
10590	continue
	if(zmail_to.eq.mail_name) then
	    defcmd='K'
	else
	    defcmd='C'
	endif

10591	continue
	if(reprint) then
	    reprint=.false.
	    write(6,1001)crlf(:cl)//'(C)ontinue     (E)nd'
	    write(6,1001)crlf(:cl)//'(H)elp         (K)ill'
	    write(6,1001)crlf(:cl)//'(N)ostop       (R)eply'
	    write(6,1001)crlf(:cl)//crlf(:cl)//'Command? ['//defcmd//']'
	else
	    write(6,1001)crlf(:cl)//
	1	'Command (C,E,H,K,N,R,?)? ['//defcmd//'] '
	end if
	dummy=1
	call get_uplow_string(cdummy,dummy)
	istat=str$upcase(cdummy,cdummy)
	if(dummy.eq.0) cdummy=defcmd
	if(cdummy.eq.'C') go to 20000
	if(cdummy.eq.'E') go to 21000
	if(cdummy.eq.'H') go to 22000
	if(cdummy.eq.'K') go to 22500
	if(cdummy.eq.'N') go to 23000
	if(cdummy.eq.'R') go to 24000
	if(cdummy.eq.'U'.and.sysop) go to 22600	! undelete message
	if(cdummy.eq.'?') then
	    reprint=.true.
	    go to 10591
	    end if

	write(6,1001)crlf(:cl)//'That was not a valid command'
	go to 10591

20000	continue		!Continue
	return

21000	continue		!Exit
	status=3
	return

22000	continue		!Help
	controlc_typed=.false.
	istat=lbr$output_help(bbs_put_output,,
	1   'bbs_help retrieve','bbs$:helplib',,bbs_get_input)
	go to 10591


22500	continue		!Kill message
	call kill_mess (irec,kstatus)
	if(kstatus.eq.1) go to 90500
	if(kstatus.eq.2) go to 90600
	DEFCMD='C'
	go to 10591

22600	continue		!Unkill message
	read(2,rec=irec,iostat=ios,err=90600) mh

	mh.mail_deleted=.false.
	write(2,rec=irec,iostat=ios,err=90600) mh
	write(6,1001)crlf(:cl)//'Message restored'
	go to 10591


23000	continue		!Nostop
	nostop=.true.
	return

24000	continue		!Reply
	if (.not.ur.approved) go to 10591
	mh.mail_person=.true.
	mh.mail_private=.false.
	zmail_to=mh.mail_from
	istat=str$upcase(qmail_to,zmail_to)
	spc=index(qmail_to,' ')
	zfirst_name=qmail_to(1:spc-1)
	do ii=spc+1,30
	    if(zmail_to(ii:ii).ne.' ') go to 3010
	    end do
c	no last name found.
	write(6,1001)crlf(:cl)//'There seems to be some problem here'//
	1    crlf(:cl)//'This person does not exist!'
	go to 10591
3010	zlast_name=qmail_to(ii:30)
	zur.user_key=zlast_name//zfirst_name
	dummy=0
	hold_messnum=mh.mail_messnum
	write(6,1001)crlf(:cl)//'Is this a private message? [no]'
	dummy=3
	call get_upcase_string(yesno,dummy)
	if(yesno(1:1).eq.'Y') mh.mail_private=.true.
	ii=20
	call enter_message(ii,*10591,0)

 3020	read(2,rec=1,iostat=ios,err=90500)last_header, last_data,
	1   first_mnum,last_mnum,busy
	if(busy) then
	    unlock(unit=2)
	    dummy=lib$wait(1.0)
	    go to 3020
	    end if
	last_header=last_header+1
	last_mnum=last_mnum+1
	write(2,rec=1)last_header,last_data+ii,first_mnum,last_mnum
	call date(mh.mail_date)
	call time(mh.mail_time)
	mh.mail_read=.false.
	mh.mail_deleted=.false.
	mh.mail_to=zmail_to
	mh.mail_from=mail_name
	mh.mail_reply_to=mh.mail_messnum
	mh.mail_messnum=last_mnum
	mh.mail_first=last_data+1
	mh.mail_last=last_data+ii
	do qq=1,10
	    mh.mail_replys(qq)=0
	    end do

c	write the header
	write(2,rec=last_header,err=90600,iostat=ios) mh

c	and the message
	do jj=1,ii
	    write(3,rec=last_data+jj)message(jj)
	    end do

c	now, set up for read thread
	read(2,rec=irec,iostat=ios,err=90600) mh
	qq=1
	do while(mh.mail_replys(qq).ne.0.and.qq.lt.11)
	    qq=qq+1
	    end do
	if(qq.le.10.and.mh.mail_replys(qq).eq.0) mh.mail_replys(qq)=last_mnum
	write(2,rec=irec,iostat=ios,err=90600) mh

c	tell him about it
	call comint(last_mnum,lms)
	write(6,1001)crlf(:cl)//' Message number'//lms//
	1   ' sent.'//bell//bell

c	tell reciever he has mail
	if(.not.mh.mail_person) go to 10591

	read(1,key=zur.user_key,iostat=ios,err=10591)zur
	zur.num_unread = zur.num_unread+1
	rewrite(1,err=90500,iostat=ios)zur

	go to 10591			!Ask him for another command


90500	status=1	!error on userlog
	return

90600	status=2	!error on message files
	return

	end

	subroutine kill_mess (irec,status)
	implicit integer*4 (a-z)
	include 'bbs_inc.for/nolist'
	include 'sys$library:foriosdef/nolist'
c
	character cdummy*1,zmail_to*30,zmail_from*30
	character snum*6,qmail_to*30,yesno*3,string*30
	character zfirst_name*20,zlast_name*20
	byte dummyb
	logical*1 reprint,found,nostop

	record /userlog_structure/ zur

	record /mail_header_structure/ mh

 1001	format(a)

	status=0
10000	read(2,rec=irec,iostat=ios,err=90600) mh
	unlock(unit=2)
	istat = str$upcase(mh.mail_to,mh.mail_to)
	if(mail_name.ne.mh.mail_to.and.mail_name.ne.mh.mail_from
	1   .and.(.not.(sysop.or.sysop2))) then
	    write(6,1001)crlf(:cl)//'That is not your message.'
	    return
	    end if

	write(6,1001)crlf(:cl)//'Are you sure? [Yes] '
	dummy=3
	call get_upcase_string(yesno,dummy)
	if(dummy.gt.0.and.yesno(1:1).eq.'N') then
	    return
	    end if
	read(2,rec=irec,iostat=ios,err=90600) mh
	mh.mail_deleted=.true.
	write(2,rec=irec,iostat=ios,err=90600) mh
	if(mh.mail_person.and..not.mh.mail_read) then
	    istat=str$upcase(qmail_to,mh.mail_to)
	    spc=index(qmail_to,' ')
	    zfirst_name=qmail_to(1:spc-1)	
	    do ii=spc+1,30
		if(zmail_to(ii:ii).ne.' ') go to 10200
		end do

10200	    zlast_name=qmail_to(ii:30)
	    zur.user_key=zlast_name//zfirst_name
	    read(1,key=zur.user_key,iostat=ios,err=10400)zur
	    zur.num_unread=zur.num_unread-1
	    if (zur.num_unread.lt.0) zur.num_unread=0
	    rewrite(1,err=90500)zur
	    end if

10400	write(6,1001)crlf(:cl)
	istat=str$trim(mh.mail_from,mh.mail_from,dummy1)
	istat=str$trim(mh.mail_to,mh.mail_to,dummy2)
	if(dummy1.lt.1.or.dummy1.gt.30) dummy1=30
	if(dummy2.lt.1.or.dummy2.gt.30) dummy2=30
	write(6,1001)crlf(:cl)//'Message from '//mh.mail_from(1:dummy1)//
	1    ' to '//mh.mail_to(1:dummy2)//' deleted.'//bell
	return

90500	status=1	!error on userlog
	return

90600	status=2	!error on message files
	return
	end

	subroutine finish_timeout
*	this routine is called in case of a timeout.
	implicit integer*4 (a-z)
	include 'bbs_inc.for'
	write(6,1001)crlf(:cl)//'Your terminal has been idle too long.'
	write(6,1001)crlf(:cl)//'UBBS is signing off now.'
	read(1,key=ur.user_key,iostat=ios,err=90500)ur
	ur.seconds_today = current_units
	rewrite(1,iostat=ios,err=90500)ur
90500	continue		!graceful non-handling of errors
	close(unit=1)
	close(unit=2)
	close(unit=3)
	interactive=.false.		!reset before exiting
	call setup_local(interactive)
	write(6,1001)crlf(:cl)
	close(unit=6)
	call exit
 1001	format(a)
	end

	integer function uopen(fab,rab,lun)
	implicit none

	include '($rabdef)'
	include '($fabdef)'

	record /rabdef/ rab
	record /fabdef/ fab
	integer sys$open,sys$connect

	integer lun,status
	
c	modify the rab to simplify things
	rab.rab$l_rop = ibset(rab.rab$l_rop, rab$v_wat)

c	actually open the file
	status=sys$open(fab)
	if(status) status=sys$connect(rab)
c	return the status
	uopen=status
	return
	end

	integer function getsize(fab,rab,lun)
c	This user open finds out the file size.

	implicit none

	include '($rabdef)'
	include '($fabdef)/list'

	record /rabdef/ rab
	record /fabdef/ fab
	integer sys$open,sys$connect
	
	integer lun,status,fsize
	common/filesize/fsize
	
c	actually open the file
	status=sys$open(fab)
	if(status) status=sys$connect(rab)
c	return the status
	getsize=status
c	store the size
	fsize=fab.fab$l_alq
	return
	end

	INTEGER FUNCTION FIND_FILE (FILE,SIZE)
C
C	This function is used to lookup a file spec containing wildcards.
C
C	Inputs:
C		FILE - The file spec to lookup.
C		SIZE - The file spec size.
C
C	Outputs:
C		Any error from LIB$FIND_FILE.
C
	implicit integer*4 (a-z)
	INCLUDE 'bbs_inc.for'
	INCLUDE '($RMSDEF)/NOLIST'

	CHARACTER*(*) FILE, MODULE_NAME
	CHARACTER*128 FILE_NAME

	PARAMETER (MODULE_NAME = 'FIND_FILE')
	LOGICAL WILD_CARDS
	INTEGER FIND_CONTEXT, FILE_SIZE, SIZE, DFLAG, SON

	FILE_NAME = FILE(1:SIZE)	! Copy the file specification.
	FILE_SIZE = SIZE		! Copy the file size.
	FIND_CONTEXT = 0		! Initialize the file context.
C
C	Set flag to determine if device and/or directory is specified.
C
	GO TO 100			! Go find the specified file(s).

	ENTRY FIND_NEXT (FILE, SIZE)
C
C	Find the first/next file name.
C
	FIND_NEXT = RMS$_NMF		! Initialize to "No more files"

100	STATUS = LIB$FIND_FILE (FILE_NAME(1:FILE_SIZE), FILE, FIND_CONTEXT)
	FIND_NEXT = STATUS		! Pass back the status.

	SIZE = INDEX (FILE, ' ') - 1	! End of expanded file name.
C
C	Return the file name size minus the spaces it's padded with.
C
	SIZE = INDEX (FILE, ' ') - 1	! Return the file name size.
	IF (.NOT. STATUS) THEN
	    IF (STATUS .NE. RMS$_NMF) THEN
		    IF (STATUS .EQ. RMS$_PRV) THEN
			GO TO 100	! Next file on privilege violation.
		    ENDIF
	    ELSE
		VAX_WILD = .FALSE.	! Wildcards are no longer active.
	    ENDIF
	ENDIF
	RETURN
	END

	subroutine type_file(filename)
	implicit none
	include 'bbs_inc.for'
	character*(*) filename
	character*512 record
	integer length

	open(unit=4,file=filename,status='old',readonly,
	1   shared)
	read(4,1002,iostat=ios)length,record
	do while (.not.ios)
	    call ctrl_o_check(*10,*10)
	    write(6,1001)crlf(:cl)//record(1:length)
	    read(4,1002,iostat=ios)length,record
	    end do
 0010	close(unit=4)
	return
 1001	format(a)
 1002	format(q,a)
	end

	subroutine make_readable(instring,length,outstring)
	implicit none
	character*(*) instring,outstring
	integer*4 length,i,j,temp
	character*3 text(33)
	integer*4 ltxt(33)
	data text/'NUL','SOH','STX','ETX','EOT','ENQ','ACK','BEL',
	1	  'BS ','HT ','LF ','VT ','FF ','CR ','SO ','SI ',
	2	  'DLE','DC1','DC2','DC3','DC4','NAK','SYN','ETB',
	3	  'CAN','EM ','SUB','ESC','FS ','GS ','RS ','US ','SP '/

	data ltxt/8*3,8*2,9*3,2,2*3,5*2/

	j=0
	do i=1,length
	    temp=ichar(instring(i:i))+1
	    if(temp.le.33) then
		outstring=outstring(1:j)//'<'//text(temp)(1:ltxt(temp))//'>'
		j=j+2+ltxt(temp)
	    else if(temp.eq.128) then
		outstring=outstring(1:j)//'<DEL>'
		j=j+5
	    else
		outstring=outstring(1:j)//instring(i:i)
		j=j+1
	    end if
	    end do
	length=j
	return
	end

	integer function bbs_put_output(msg_str)
c
c	This routine mimics lib$put_output for the bbs to allow it to use
c	its own carriage control and interrupt routines
c
	implicit none
	include 'bbs_inc.for'
	character*(*) msg_str

	bbs_put_output = ss$_normal

	if (controlc_typed) return
	call ctrl_o_check(*10,*10)
	write(6,1001)crlf(:cl)//msg_str
	return

 0010	controlc_typed = .true.
	return

 1001	format(a)
	end

	integer function bbs_get_input(get_str,prompt_str,out_len)
c
c	This routine mimics lib$get_input for the bbs to allow it to use
c	its own carriage control, typeahead buffer, and interrupt routines
c
	implicit none
	include 'bbs_inc.for'
	character*(*) get_str,prompt_str
	integer*2 out_len

	bbs_get_input = ss$_normal

	if (controlc_typed) go to 10

	call ctrl_o_check(*10,*10)
	write(6,1001)crlf(:cl)//prompt_str
	out_len=50
	call get_uplow_string(get_str,out_len)
	return

 0010	controlc_typed = .true.
	get_str=' '
	out_len=0
	return

 1001	format(a)
 1002	format(q,a)
	end

	subroutine out(msg_str,*)
c
c	This routine provides a convienient way to output a line and
c	check the status on return.
c
	implicit none
	include 'bbs_inc.for'
	character*(*) msg_str

	call ctrl_o_check(*10,*10)
	write(6,1001)crlf(:cl)//msg_str
	return

 0010	return 1

 1001	format(a)
	end

	subroutine add_elapsed_time(*)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c
c	This routine is called at each entry to the main or mail menu.  It 
c	will add the time so far to the user's time and check it against
c	the total allowed.  The LIB$INIT_TIMER must have been called previous
c	to calling this routine.
c
c	Rev. 3.6  25-Jun-1986
c	Rev. 4.1  07-Jul-1986
c	Rev. 4.4  15-Aug-1986
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

	implicit none
	include 'bbs_inc.for/nolist'
	character cdate*9,ctime*8
	real*8 systime,qdummy,mill10
	integer*4 zone,daynum,oldzone,istat
	integer*4 syst(2),hours
	integer lib$day_of_week,lib$stat_timer
	equivalence(systime,syst)
	data mill10/'ffffffffff676980'x/	!Quadword -10,000,000
	
 1001	format(a)
 1002	format(i2)

c	See if the date has changed.
	call date(cdate)
	if(cdate.ne.ur.current_day) then
	    read(1,key=ur.user_key,iostat=ios,err=90500)ur
	    ur.current_day=cdate
	    ur.seconds_today=0
	    rewrite(1,iostat=ios,err=90500)ur
	    initial_units=0
	    current_units=0
	    call init_timer(user_timer)
	    write(6,1001)crlf(:cl)//crlf(:cl)//'Your timer has been reset.'//
	1	crlf(:cl)//bell
	    end if
c
c	Find out how badly to hit him.
	zone=lib$day_of_week(,daynum)
	call time(ctime)
	read(ctime,1002)hours
	zone=1
	if(hours.gt.18)zone=2
	if(hours.lt.08.or.daynum.ge.6)zone=4
	if(zone.ne.oldzone) then
	    read(1,key=ur.user_key,err=90500)ur
	    ur.seconds_today = current_units
	    rewrite(1,err=90500)ur
	    call init_timer(user_timer)
	    initial_units=ur.seconds_today
	    oldzone=zone
	    endif

c	Return his time used as a quadword.
	istat=lib$stat_timer(1,qdummy,user_timer)

c	Divide the system time by -10,000,000 to get seconds
	call ediv(qdummy,mill10,systime)

	current_units=syst(1)/zone+initial_units
	if(current_units.gt.allowable_units) return 1
	if(current_units.gt.ur.seconds_today+60) then
	    read(1,key=ur.user_key,iostat=ios,err=90500)ur
	    ur.seconds_today = current_units
	    rewrite(1,iostat=ios,err=90500)ur
	    endif
	return

90500	continue
	return 1
	end

	subroutine enter_message(length,*,size)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine handles the entering of messages.
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for/nolist'
	include 'sys$library:foriosdef/nolist'

	character cdummy*1,string*80
	logical flag
	integer i,length,dummy,istat,number,size,current
c	system routines
	integer str$trim

 1001	format(a)
 1011	format(i<dummy>)
 1013	format(a,i2,'>')
 1015	format(a,i2,1x,a)

	current=0
	if(size.eq.0) write(6,1001)crlf(:cl)//crlf(:cl)//
	1   'Your message may be 1 to 20 80-character lines.'
	write(6,1001)crlf(:cl)//'End your entry with a blank line.'
	i=1
 3040	do length=i,20
	    dummy=80
	    if((size.ne.0).and.(size-current.lt.79)) dummy=size-current-1
	    write(6,1013)crlf(:cl),length
	    call get_uplow_string(message(length),dummy)
	    if(dummy.eq.0) go to 3050
	    current=current+dummy+1
	    if((size.ne.0).and.(current.ge.size)) go to 3050
	    end do
	length=21
 3050	length=length-1			!message length
	if(length.eq.0) then
	    write(6,1001)crlf(:cl)//'Message aborted.'//bell
	    return 1
	    end if
c	send menu goes here
 3060	write(6,1001)crlf(:cl)//crlf(:cl)//'(S)end, (C)ontinue,'//
	1   ' (A)bort, or (E)dit? [S] '
	dummy=1
	call get_upcase_string(cdummy,dummy)
	if(dummy.eq.0) return
	if(cdummy.eq.'A') then
	    write(6,1001)crlf(:cl)//'Entry aborted.'//bell	
	    return 1
	    endif
	if(cdummy.eq.'C') then
	    i=length+1
	    go to 3040
	    endif
	if(cdummy.eq.'E') then
	    write(6,1001)crlf(:cl)//'Your entry now reads:'
	    do i=1,length
		istat=str$trim(message(i),message(i),dummy)
		write(6,1015)crlf(:cl),i,message(i)(1:dummy)
		end do
	    write(6,1001)crlf(:cl)
 3070	    write(6,1001)crlf(:cl)//
	1	'Which line do you wish to change? [exit] '
	    dummy=2
	    flag=.false.
	    call get_number(string,dummy,flag)
	    if(dummy.eq.0) go to 3060
	    read(string,1011)number
	    if(number.eq.0) go to 3060
	    if(number.gt.length) then
		write(6,1001)crlf(:cl)//'Invalid line number'
		go to 3070
		end if
	    write(6,1001)crlf(:cl)//'Enter the new line'
	    write(6,1013)crlf(:cl),number
	    dummy=80
	    call get_uplow_string(message(number),dummy)
	    go to 3060
	    end if

	    
	if(cdummy.ne.'S') then
	    write(6,1001)crlf(:cl)//bell//'Invalid response..try again.'//bell
	    go to 3060 
	    end if

	return
	end

	subroutine ubbs_files_section
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine handles all of the UBBS file transfer.
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c	Rev. 3.6  24-Jun-1986
c	Rev. 4.0  27-Jun-1986
c	Rev. 4.1  07-Jul-1986
c	Rev. 4.2  20-Jul-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for/nolist'
	include 'sys$library:foriosdef/nolist'
	include '($rmsdef)'
	character cdummy*1,darea*3
	character filename*50,filnam*80,disk*4,line*200,ftyp*7
	character binasc*4,zfilnam*20,term*5,cdate*9,types*1
	character space*30/'                    '/
	logical*1 reprint,dummyl
	integer i,istat,per,spc,length,flen
	integer file_character/65/	! The value of 'A' in decimal
	integer dummy,dummy1,dummy2
	integer get_xmodem,send_xmodem,find_file,find_next
	integer fsize
	logical get_vaxfile
	integer lib$spawn,lib$delete_file,str$trim
	integer lbr$output_help,str$upcase,sys$gettim
	external getsize,bbs_put_output,bbs_get_input,uopen

	record /userlog_structure/ zur
	record/file_description/ fd

	common/filesize/fsize

 1001	format(a)
 1003	format(q,a)
 1004	format('$!',a3,'=',a18,i3,1x,a)
 1019	format(a1,'file_',i6.6,'.dat')
 1024   format(i5.5)

c	Start the whole thing off
 4000	continue
	call date(cdate)
	write(term,1024)mod(user_number,100000)	! set up filename for Kermit
	write(6,1001)crlf(:cl)//
	1   '(D)ownload, (U)pload, (H)elp or (E)xit? [exit] '
	dummy=1
	call get_upcase_string(cdummy,dummy)
	if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	if(cdummy.eq.'D') go to 4100
	if(cdummy.eq.'U') go to 4700
	if(cdummy.eq.'H') then
	    controlc_typed=.false.
	    istat=lbr$output_help(bbs_put_output,,
	1	'bbs_help file_transfer','bbs$:helplib',,bbs_get_input)
	    go to 4000
	    end if
	write(6,1001)crlf(:cl)//'Invalid selection.  Please try again.'
	go to 4000

 4100	continue		!Download
	area='download'
	flow=to_remote
	if(reprint.or.(.not.ur.xpert)) then
	    reprint=.false.
	    call out(crlf(:cl)//'The following download areas'//
	1	' are available:',*4101)
	    call out(crlf(:cl)//'100 - Radio shack MOD100 & MOD200',*4101)
	    call out('128 - Commodore 128',*4101)
	    call out('AMI - Amiga',*4101)
	    call out('APP - Apple',*4101)
	    call out('AST - Atari ST',*4101)
	    call out('ATA - Atari',*4101)
	    call out('COM - Commodore 64',*4101)
	    call out('CPM - CP/M & CP/M 86',*4101)
	    call out('CUG - CP/M users group software',*4101)
	    call out('IBM - IBM-PC & MS/DOS',*4101)
	    call out('MAC - Apple Macintosh',*4101)
	    call out('MIS - Miscellaneous files',*4101)
	    call out('TRS - Radio Shack Model II,III,4',*4101)
 4101	    write(6,1001)crlf(:cl)//crlf(:cl)//
	1	'Enter area of interest? [exit]'
	else
	    write(6,1001)crlf(:cl)//'Area? '
	end if
	dummy=3	    	    
	call get_uplow_string(darea,dummy)
	istat = str$upcase(darea,darea)
	if(dummy.eq.0.or.darea.eq.'EXI') go to 4900
	if(darea.eq.'?') then
	    reprint=.true.
	    go to 4100
	    end if
	if( (darea.ne.'APP') .and. (darea.ne.'COM') .and.
	1   (darea.ne.'CPM') .and. (darea.ne.'IBM') .and.
	2   (darea.ne.'MIS') .and. (darea.ne.'TRS') .and.
	3   (darea.ne.'ATA') .and. (darea.ne.'CUG') .and.
	4   (darea.ne.'100') .and. (darea.ne.'MAC') .and.
	5   (darea.ne.'AMI') .and. (darea.ne.'AST') .and.
	6   (darea.ne.'128')) then
	    write(6,1001)crlf(:cl)//
	1	'That is not a valid area.  Please try again'
	    reprint=.true.
	    go to 4100
	    end if

 4150	continue
	if(darea.eq.'CUG') goto 4160	! Users group, special

	write(6,1001)crlf(:cl)//
	1'Enter name of file to download, ? for list, or <cr> to exit. '
	dummy=30
	call get_uplow_string(filename,dummy)
	istat=str$upcase(filename,filename)
	if(dummy.eq.0) go to 4900
	if(filename.eq.'?') then
	    call listcat(darea)
	    go to 4150	    
	    end if
	if(filename.eq.'ABC.XYZ') go to 5000
	per=index(filename,'.')
	if(per.eq.0) then
	    spc=index(filename,' ')
	    filename(spc:spc)='.'
	    end if
	file_type=ascii			!make assumption
	filnam='bbs$files:['//darea//'.asc]'//filename
	dummyl=get_vaxfile(filnam)
	if(dummyl) go to 4170
	file_type=binary		!wrong assumption, try again
	filnam='bbs$files:['//darea//'.bin]'//filename
	dummyl=get_vaxfile(filnam)
	if(dummyl) go to 4170
	write(6,1001)crlf(:cl)//bell//
	1   'That is not a valid filename.  Try again.'
	go to 4150

 4160	continue	!process cp/m users group downloads
	write(6,1001)crlf(:cl)//
	1   'Enter disk number (Cxxx or Sxxx), ? for help, or <cr> to exit. '
	dummy=4
	call get_uplow_string(disk,dummy)
	istat=str$upcase(disk,disk)
	if(dummy.eq.0) go to 4900
	if(disk.eq.'?') then
	    call type_file('bbs$:cpmug.howto')
	    go to 4160
	    end if
	open(unit=9,file='dua10:[cpmug.asc]'//disk//'.dir',
	1   iostat=ios,readonly,shared,status='old')
	close(unit=9)
	if(ios.ne.0) then
	    write(6,1001)crlf(:cl)//'That is not a valid disk number.'
	    write(6,1001)crlf(:cl)//'Please try again.'
	    go to 4160
	    end if
 4161	write(6,1001)crlf(:cl)//
	1   'Enter name of file to download, ? for list, or <cr> to exit. '
	dummy=30
	call get_uplow_string(filename,dummy)
	istat=str$upcase(filename,filename)
	if(dummy.eq.0) go to 4900
	if(filename.eq.'?') then

c	Do a DIRectory from Fortran
	    filename='dua10:[cpmug.asc.'//disk//']*.*;*'
	    dummy=27
	    istat=find_file(filename,dummy)
	    if(istat.eq.rms$_fnf) go to 4162
	    call out('   Ascii files'//crlf(:cl)//crlf(:cl),*4161)
	    i=0
	    do while (istat.ne.rms$_nmf)
		dummy1=index(filename,']')+1
		dummy2=index(filename,';')-1
		write(6,1001)filename(dummy1:dummy2)//
	1	    space(1:16-(dummy2-dummy1))
		i=i+1
		if(i.eq.4) then
		    write(6,1001)crlf(:cl)
		    call ctrl_o_check(*4161,*4161)
		    i=0
		    end if
		istat=find_next(filename,dummy)
		end do
4162	    filename='dua10:[cpmug.bin.'//disk//']*.*;*'
	    dummy=27
	    istat=find_file(filename,dummy)
	    if(istat.eq.rms$_fnf) go to 4163
	    i=0
	    call out(crlf(:cl)//'   Binary files'//crlf(:cl),*4161)
	    do while (istat.ne.rms$_nmf)
		dummy1=index(filename,']')+1
		dummy2=index(filename,';')-1
		write(6,1001)filename(dummy1:dummy2)//
	1	    space(1:16-(dummy2-dummy1))
		i=i+1
		if(i.eq.4) then
		    write(6,1001)crlf(:cl)
		    i=0
		    end if
		istat=find_next(filename,dummy)
		end do
4163	    write(6,1001)crlf(:cl)
	    go to 4161
	    end if
	per=index(filename,'.')
	if(per.eq.0) then
	    spc=index(filename,' ')
	    filename(spc:spc)='.'
	    end if
	file_type=ascii			!make assumption
	filnam='dua10:[cpmug.asc.'//disk//']'//filename
	dummyl=get_vaxfile(filnam)
	if(dummyl) go to 4170
	file_type=binary		!wrong assumption, try again
	filnam='dua10:[cpmug.bin.'//disk//']'//filename
	dummyl=get_vaxfile(filnam)
	if(dummyl) go to 4170
	write(6,1001)crlf(:cl)//bell//
	1   'That is not a valid filename.  Try again.'
	go to 4161

 4170	if(file_type.eq.binary) then
	    protocol=asciid
	    write(6,1001)crlf(:cl)//'Binary files must be transferred via'
	    write(6,1001)crlf(:cl)//'Xmodem or Kermit'
 4172	    write(6,1001)crlf(:cl)//'(K)ermit or (X)modem transfer [exit]'
	    protocol=unknown
	    dummy=1
	    call get_upcase_string(cdummy,dummy)
	    if(dummy.eq.0.or.cdummy.eq.'E') go to 4150
	    if(cdummy.eq.'K') protocol=kermit
	    if(cdummy.eq.'X') protocol=xmodem
	    if(protocol.eq.unknown) then
		write(6,1001)crlf(:cl)//'Unknown protocol.  Try again.'
		go to 4172
		endif
	else
 4175	    write(6,1001)crlf(:cl)//
	1	'(A)scii, (K)ermit or (X)modem transfer? [exit]'
	    protocol=unknown
	    dummy=1
	    call get_upcase_string(cdummy,dummy)
	    if(dummy.eq.0.or.cdummy.eq.'E') go to 4150
	    if(cdummy.eq.'A') protocol=asciid
	    if(cdummy.eq.'K') protocol=kermit
	    if(cdummy.eq.'X') protocol=xmodem
	    if(protocol.eq.unknown) then
		write(6,1001)crlf(:cl)//'Unknown protocol.  Try again.'
		go to 4175
		end if
	    end if

c	Update the directory entry for this file.

	if(darea.eq.'CUG') go to 4177

	open(unit=4,		shared,
	1   file='bbs$files:['//darea//']files.idx',
	2   status='old',	organization='indexed',
	3   access='keyed',	form='unformatted',
	4   recl=128,		recordtype='fixed',
	5			key=(1:18:character),
	6   useropen=uopen)

	fd.file_name=filename
	istat=str$trim(fd.file_name,fd.file_name,dummy)
	if(fd.file_name(dummy:dummy).eq.'.') fd.file_name(dummy:dummy)=' '

	read(4,key=fd.file_name,err=4176)fd

	fd.times_down=fd.times_down+1

	rewrite(4)fd
	
 4176	close(unit=4)
c
c	File is open, protocol is selected.  Do it to it.
c
 4177	continue
	if (protocol.eq.xmodem) then
	    call clear_counts()
	    timeout_count=10
	    retry_limit=5
	    bitmask=eightbit_mask
	    call init_timer(file_timer)
	    dummyl=send_xmodem()
	    bitmask=sevenbit_mask
	    call waitabit('10')
	    call elapsed_time(file_timer)	!Display elapsed time
	    call report_totals()		!Report final stats
	    if(dummyl) then
		write(6,1001)crlf(:cl)//'Successful transfer'
	    else
		write(6,1001)crlf(:cl)//'Transfer failed.'//bell
	    end if
	else if(protocol.eq.kermit) then
	    call init_timer(file_timer)
	    call waitabit('5')
	    close(unit=file_unit)
	    open(unit=file_unit,file=term//'kerm.com',
	1	carriagecontrol='none',status='new',iostat=ios)
	    if(ios) then
		write(6,1001)crlf(:cl)//
	1	    'Internal error.  Kermit is nonfunctional'
		go to 4900
		end if
	    if(file_type.eq.binary)write(file_unit,1001)'set file type binary'
	    write(file_unit,1001)'send '//filnam
	    write(file_unit,1001)'exit'
	    close(unit=file_unit)
	    istat=lib$spawn('kermit @'//term//'kerm')
	    write(6,1001)crlf(:cl)//'Transfer finished'
	    istat=lib$delete_file(term//'kerm.com;*')
	    call waitabit('5')
	    call elapsed_time(file_timer)
	else		!ascii dump
	    write(6,1001)crlf(:cl)//'Control-c to abort download'
	    write(6,1001)crlf(:cl)//'Open your capture buffer now.'
	    call waitabit('10')
	    call init_timer(file_timer)
 4180	    read(file_unit,1003,end=4200)length,line
	    call out(line(1:length),*4199)
	    go to 4180
 4199	    write(6,1001)crlf(:cl)//bell//'Download aborted'
 4200	    write(6,1001)crlf(:cl)//crlf(:cl)//'Finished'
	    close (unit=file_unit)
	    call waitabit('10')
	    call elapsed_time(file_timer)
	end if
	go to 4150


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 4700	continue		!Upload
	area='upload'
	if(reprint.or.(.not.ur.xpert)) then
	    reprint=.false.
	    call out(crlf(:cl)//'The following upload areas'//
	1	' are available:',*4701)
	    call out('100 - Radio shack MOD100 & MOD 200',*4701)
	    call out('128 - Commodore 128',*4701)
	    call out('AMI - Amiga',*4701)
	    call out('APP - Apple',*4701)
	    call out('AST - Atari ST',*4701)
	    call out('ATA - Atari',*4701)
	    call out('COM - Commodore 64',*4701)
	    call out('CPM - CP/M & CP/M 86',*4701)
	    call out('IBM - IBM-PC & MS/DOS',*4701)
	    call out('MAC - Apple Macintosh',*4701)
	    call out('MIS - Miscellaneous files',*4701)
	    call out('TRS - Radio Shack series',*4701)
 4701	    write(6,1001)crlf(:cl)//'Enter area of interest? [exit]'
	else
	    write(6,1001)crlf(:cl)//'Area? '
	end if
	dummy=3	    	    
	call get_uplow_string(darea,dummy)
	istat = str$upcase(darea,darea)
	if(dummy.eq.0.or.darea.eq.'EXI') go to 4900
	if(darea.eq.'?') then
	    reprint=.true.
	    go to 4700
	    end if
	if( (darea.ne.'APP') .and. (darea.ne.'COM') .and.
	1   (darea.ne.'CPM') .and. (darea.ne.'IBM') .and.
	2   (darea.ne.'MIS') .and. (darea.ne.'TRS') .and.
	3   (darea.ne.'ATA') .and. (darea.ne.'100') .and.
	4   (darea.ne.'MAC') .and. (darea.ne.'AMI') .and.
	5   (darea.ne.'AST') .and. (darea.ne.'128')) then
	    write(6,1001)crlf(:cl)//
	1	'That is not a valid area.  Please try again'
	    reprint=.true.
	    go to 4700
	    end if
	write(6,1001)crlf(:cl)//'(A)scii, (B)inary, (H)elp, (E)xit? [exit]'
	dummy=1
	call get_upcase_string(cdummy,dummy)
	if (cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	if (cdummy.eq.'A') then
	    file_type = ascii
	    ftyp='Ascii '
	    fd.file_type='U'
	    binasc='.asc'
	else if (cdummy.eq.'B') then
	    file_type=binary
	    fd.file_type='V'
	    ftyp='Binary'
	    binasc='.bin'
	else if (cdummy.eq.'H') then
	    controlc_typed=.false.
	    istat=lbr$output_help(bbs_put_output,,
	1	'bbs_help file','bbs$:helplib',,bbs_get_input)
	    go to 4700
	else
	    write(6,1001)crlf(:cl)//'Invalid selection. Please try again'
	    go to 4700
	end if

	if(file_type.eq.binary) then
	    write(6,1001)crlf(:cl)//'Binary transfers must be by xmodem'
	    write(6,1001)crlf(:cl)//'or Kermit protocol.'
	    write(6,1001)crlf(:cl)//'(K)ermit or (X)modem protocol? [exit] '
	    dummy=1
	    call get_upcase_string(cdummy,dummy)
	    if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	    if(cdummy.eq.'K') protocol=kermit
	    if(cdummy.eq.'X') protocol=xmodem
	    if(protocol.eq.unknown) go to 4720
	else
 4720	    write(6,1001)crlf(:cl)//'(A)scii, (K)ermit or'//
	1	' (X)modem protocol? [exit] '
	    dummy=1
	    call get_upcase_string(cdummy,dummy)
	    if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	    if(cdummy.eq.'A') protocol=asciid
	    if(cdummy.eq.'K') protocol=kermit
	    if(cdummy.eq.'X') protocol=xmodem
	    if(protocol.eq.unknown) go to 4720
	end if	
c	get the file name
	write(6,1001)crlf(:cl)//
	1   'File names may consist of a-z, 0-9, underscore,'
	write(6,1001)crlf(:cl)//
	1   'and at most 1 period.  Names may be 1-18 characters.'
 4721	write(6,1001)crlf(:cl)//'File name? [exit]'
	flen=18
	call get_filnam_string(filename,flen)
	if(flen.eq.0) go to 4900

	fd.file_name=filename
	if(fd.file_name(flen:flen).eq.'.') fd.file_name(flen:flen)=' '
	filnam='bbs$files:['//darea//binasc//']'//filename

	open(unit=4,		shared,
	1   file='bbs$files:['//darea//']files.idx',
	2   status='old',	organization='indexed',
	3   access='keyed',	form='unformatted',
	4   recl=128,		recordtype='fixed',
	5			key=(1:18:character),
	6   useropen=uopen)

	read(4,key=fd.file_name,err=4725)fd
	unlock(unit=4)

c	If it's his, give him the option to change it.
	if(fd.upload_name.eq.mail_name) then
	    write(6,1001)crlf(:cl)//
	1	'You have already uploaded a file with that name.'
	    write(6,1001)crlf(:cl)//
	1	'Do you wish to overwrite it? [N]'
	    dummy=1
	    call get_upcase_string(cdummy,dummy)
	    if(cdummy.ne.'Y') go to 4721
	    read(4,key=fd.file_name,err=4725)fd
	    delete(unit=4)
	    go to 4725
	    end if
	close(unit=4)

c	It's not his, make him choose another name.
	write(6,1001)crlf(:cl)//
	1   'That file already exists.  Please choose another name.'
	write(6,1001)crlf(:cl)//
	1   'If this is to be a replacement for '//filename(:flen)//','
	write(6,1001)crlf(:cl)//
	1   'please notify the operator via (P)rivate message.'
	go to 4721

 4725	continue
	close(unit=4)
c
c	if he has made it this far, we are ready to upload.
c
	if(protocol.eq.xmodem) then
	    write(6,1001)crlf(:cl)//
	1	'Beginning xmodem upload -- Ctrl-d to abort.'
	    call init_timer(file_timer)
	    call clear_counts()
	    timeout_count=10
	    retry_limit=5
	    flow=to_vax
	    bitmask=eightbit_mask
	    dummyl=get_vaxfile(filnam)
	    dummyl=get_xmodem()
	    bitmask=sevenbit_mask
	    call waitabit('10')
	    call elapsed_time(file_timer)	!Display elapsed time
	    call report_totals()		!Report final stats
	    if(dummyl) then
		write(6,1001)crlf(:cl)//'Successful upload!'
		go to 4800
	    else
		write(6,1001)crlf(:cl)//'Upload failed'
 4730		istat = lib$delete_file(filnam//';*')
	    end if
	elseif (protocol.eq.kermit) then
	    close(unit=file_unit,status='delete')
	    open(unit=file_unit,file=term//'kerm.com',
	1	carriagecontrol='none',status='new',iostat=ios)
	    if(ios) then
		write(6,1001)crlf(:cl)//
	1	    'Internal error.  Kermit is nonfunctional'
		go to 4900
		end if
	    if(file_type.eq.binary)write(file_unit,1001)'set file type binary'
	    write(file_unit,1001)'rec '//filnam
	    write(file_unit,1001)'exit'
	    close(unit=file_unit)
	    istat=lib$spawn('kermit @'//term//'kerm')
	    write(6,1001)crlf(:cl)//'Transfer finished'
 4731	    istat=lib$delete_file(term//'kerm.com;*')
	    call waitabit('5')
	    call elapsed_time(file_timer)
	    go to 4800
	else			!ascii upload
	    flow=to_vax
	    dummyl=get_vaxfile(filnam)
	    call out('Ascii files must not contain any non-printable',*4739)
	    call out('characters, and must not have any lines over',*4739)
	    call out('200 characters in length.',*4739)
	    call out('Each line must be terminated by a carriage',*4739)
	    call out('return.  The BBS will add a line feed for each',*4739)
	    call out('line you send.',*4739)
	    call out('Control-z to end, Control-c to abort.',*4739)
 4739	    write(6,1001)crlf(:cl)//crlf(:cl)//bell//
	1	'Start your file send now.'
	    write(6,1001)crlf(:cl)
 4740	    length=-200
	    call get_uplow_string(line,length)
	    if(length.lt.0) go to 4750
	    call send_cr()
	    call send_lf()
	    if(length.eq.0) then
		write(file_unit,1001)' '
	    else
		write(file_unit,1001)line(1:length)
	    end if
	    go to 4740

 4750	    if(length.eq.-1) then
		close(unit=file_unit)
		write(6,1001)crlf(:cl)//'Successful upload!'
		go to 4800
	    else
		close(unit=file_unit,disp='delete')
		write(6,1001)crlf(:cl)//bell//'Upload aborted'
	    end if
	end if
	go to 4900

 4800	continue	! get file description
	write(6,1001)crlf(:cl)//'Please enter the description for this file'
	write(6,1001)crlf(:cl)//'to be placed in the download directory.'
	write(6,1001)crlf(:cl)//
	1   'The description may be up to 20 lines. (max of 400 characters)'
	call enter_message(length,*4800,400)
	dummy1=1
	fd.upload_text=' '
	do i=1,length
	    istat=str$trim(message(i),message(i),dummy2)
	    fd.upload_text(dummy1:dummy1+dummy2)=message(i)(:dummy2)//char(cr)
	    dummy1=dummy1+dummy2+1
	    end do

	write(6,1001)crlf(:cl)//
	1   'Please enter keywords descriptive of this file for searches'//
	1   crlf(:cl)//'(up to 40 characters)?'
	dummy=40
	call get_uplow_string(fd.keywords,dummy)
	if(dummy.eq.0.or.fd.keywords.eq.' ') go to 4800

c	find out how big the file is.  This useropen will put the file
c	size into fsize.
	open(unit=4,file=filnam,status='old',readonly,
	1   useropen=getsize)
	close(unit=4)

	fd.file_size=fsize

	open(unit=4,		shared,
	1   file='bbs$files:['//darea//']files.idx',
	2   status='old',	organization='indexed',
	3   access='keyed',	form='unformatted',
	4   recl=128,		recordtype='fixed',
	5			key=(1:18:character),
	6   useropen=uopen)

	istat=sys$gettim(fd.upload_date)
	fd.times_down=0
	fd.upload_name=mail_name

	write(4)fd
	close(unit=4)
 
 4900	continue
	return
 5000	continue
	types='X'
	call update_index(darea,types)
	go to 4000
	end

	subroutine arklug_files_section
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine takes care of the ARKLUG files section
c	Dale Miller - UALR
c
c
c	Rev. 3.5  19-Jun-1986
c	Rev. 3.6  25-Jun-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for/nolist'
	include 'sys$library:foriosdef/nolist'
	include '($rmsdef)'
	character cdummy*1,darea*3
	character filename*50,filnam*80,disk*4,line*200,ftyp*7
	character binasc*4,zfilnam*20,term*5,cdate*9
	character space*30/'                    '/
	logical*1 reprint,dummyl
	integer i,istat,per,spc,length,flen
	integer file_character/65/	! The value of 'A' in decimal
	integer dummy,dummy1
	integer get_xmodem,send_xmodem
	integer fsize
	integer sflags/4/
	logical get_vaxfile
	integer lib$spawn,lib$delete_file,str$trim,sys$setddir
	integer lbr$output_help,str$upcase,sys$trnlog,lib$set_logical
	real*8  noprivs/'000000000000000'x/
	external getsize,bbs_put_output,bbs_get_input
	record /userlog_structure/ zur

	common/filesize/fsize

 1001	format(a)
 1003	format(q,a)
 1004	format('$!',a3,'=',a18,i3,1x,a)
 1019	format(a1,'file_',i6.6,'.dat')
 1024   format(i5.5)

c	Start the whole thing off
 4000	continue
	if (.not.ur.approved) then
	    write(6,1001)crlf(:cl)//bell//
	1	'You are not yet approved for the files section.'
	    write(6,1001)crlf(:cl)//'Sorry.'
	    return
	    end if
	call date(cdate)
	write(term,1024)user_number	! set up terminal name for Kermit
	write(6,1001)crlf(:cl)//
	1   '(D)ownload, (U)pload, (H)elp or (E)xit? [exit] '
	dummy=1
	call get_upcase_string(cdummy,dummy)
	if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	if(cdummy.eq.'D') go to 4100
	if(cdummy.eq.'U') go to 4700
	if(cdummy.eq.'H') then
	    controlc_typed=.false.
	    istat=lbr$output_help(bbs_put_output,,
	1	'bbs_help file_transfer','bbs$:helplib',,bbs_get_input)
	    go to 4000
	    end if
	write(6,1001)crlf(:cl)//'Invalid selection.  Please try again.'
	go to 4000

 4100	continue		!Download
	area='download'
	write(6,1001)crlf(:cl)//
	1   'You are now entering DCL. You may move freely thru the DECUS'
	write(6,1001)crlf(:cl)//
	1   'directory with DCL commands.  Kermit and Xmodem are available'
	write(6,1001)crlf(:cl)//'for downloading.'
	write(6,1001)crlf(:cl)//
	1   'Note: You have only read permissions on all files.'//crlf(:cl)
	istat= sys$trnlog('SYS$DISK',,line,,,)
	istat=lib$set_logical('SYS$DISK','DUA10:')
	istat=sys$setddir('[decus]',dummy,filnam)
	call setup_local(.false.)
	istat=lib$spawn(,,,sflags,,,,,,,)
	call setup_local(.true.)
	istat=sys$setddir(filnam(1:dummy),,)
	istat=str$trim(line,line,dummy)
	istat=lib$set_logical('SYS$DISK',line(1:dummy))
	return
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 4700	continue		!Upload
	area='upload'
	if(reprint.or.(.not.ur.xpert)) then
	    reprint=.false.
	    call out(crlf(:cl)//'The following upload areas'//
	1	' are available:',*4701)
	    call out('VAX - VAX/VMS',*4701)
	    call out('PDP - PDP 11 series',*4701)
	    call out('RNB - Rainbow',*4701)
	    call out('MIS - Miscellaneous files',*4701)
 4701	    write(6,1001)crlf(:cl)//'Enter area of interest? [exit]'
	else
	    write(6,1001)crlf(:cl)//'Area? '
	end if
	dummy=3	    	    
	call get_uplow_string(darea,dummy)
	istat = str$upcase(darea,darea)
	if(dummy.eq.0.or.darea.eq.'EXI') go to 4900
	if(darea.eq.'?') then
	    reprint=.true.
	    go to 4700
	    end if
	if( (darea.ne.'VAX') .and. (darea.ne.'PDP') .and.
	1   (darea.ne.'RNB') .and. (darea.ne.'MIS')) then
	    write(6,1001)crlf(:cl)//
	1	'That is not a valid area.  Please try again'
	    reprint=.true.
	    go to 4700
	    end if
	write(6,1001)crlf(:cl)//'(A)scii, (B)inary, (H)elp, (E)xit? [exit]'
	dummy=1
	call get_upcase_string(cdummy,dummy)
	if (cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	if (cdummy.eq.'A') then
	    file_type = ascii
	    ftyp='Ascii '
	    binasc='.asc'
	else if (cdummy.eq.'B') then
	    file_type=binary
	    ftyp='Binary'
	    binasc='.bin'
	else if (cdummy.eq.'H') then
	    controlc_typed=.false.
	    istat=lbr$output_help(bbs_put_output,,
	1	'bbs_help file','bbs$:helplib',,bbs_get_input)
	    go to 4700
	else
	    write(6,1001)crlf(:cl)//'Invalid selection. Please try again'
	    go to 4700
	end if

	if(file_type.eq.binary) then
	    write(6,1001)crlf(:cl)//'Binary transfers must be by xmodem'
	    write(6,1001)crlf(:cl)//'or Kermit protocol.'
	    write(6,1001)crlf(:cl)//'(K)ermit or (X)modem protocol? [exit] '
	    dummy=1
	    call get_upcase_string(cdummy,dummy)
	    if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	    if(cdummy.eq.'K') protocol=kermit
	    if(cdummy.eq.'X') protocol=xmodem
	    if(protocol.eq.unknown) go to 4720
	else
 4720	    write(6,1001)crlf(:cl)//'(A)scii, (K)ermit or'//
	1	' (X)modem protocol? [exit] '
	    dummy=1
	    call get_upcase_string(cdummy,dummy)
	    if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
	    if(cdummy.eq.'A') protocol=asciid
	    if(cdummy.eq.'K') protocol=kermit
	    if(cdummy.eq.'X') protocol=xmodem
	    if(protocol.eq.unknown) go to 4720
	end if	
c	get the file name
	write(6,1001)crlf(:cl)//
	1   'File names may consist of a-z, 0-9, underscore,'
	write(6,1001)crlf(:cl)//
	1   'and at most 1 period.  Names may be 1-18 characters.'
	write(6,1001)crlf(:cl)//'File name? [exit]'
	flen=18
	call get_filnam_string(filename,flen)
	if(dummy.eq.0) go to 4900
c
c	compute a dummy file name
c
	write(zfilnam,1019)char(file_character),user_number
	filnam='bbs$files:[upl]'//zfilnam
	file_character=file_character+1
c
c	if he has made it this far, we are ready to upload.
c
	if(protocol.eq.xmodem) then
	    write(6,1001)crlf(:cl)//
	1	'Beginning xmodem upload -- Ctrl-d to abort.'
	    call init_timer(file_timer)
	    call clear_counts()
	    timeout_count=10
	    retry_limit=5
	    flow=to_vax
	    bitmask=eightbit_mask
	    dummyl=get_vaxfile(filnam)
	    dummyl=get_xmodem()
	    bitmask=sevenbit_mask
	    call waitabit('10')
	    call elapsed_time(file_timer)	!Display elapsed time
	    call report_totals()		!Report final stats
	    if(dummyl) then
		write(6,1001)crlf(:cl)//'Successful upload!'
		go to 4800
	    else
		write(6,1001)crlf(:cl)//'Upload failed'
 4730		istat = lib$delete_file(filnam//';*')
	    end if
	elseif (protocol.eq.kermit) then
	    close(unit=file_unit,status='delete')
	    open(unit=file_unit,file=term//'kerm.com',
	1	carriagecontrol='none',status='new',iostat=ios)
	    if(ios) then
		write(6,1001)crlf(:cl)//
	1	    'Internal error.  Kermit is nonfunctional'
		go to 4900
		end if
	    if(file_type.eq.binary)write(file_unit,1001)'set file type binary'
	    write(file_unit,1001)'rec '//filnam
	    write(file_unit,1001)'exit'
	    close(unit=file_unit)
	    istat=lib$spawn('kermit @'//term//'kerm')
	    write(6,1001)crlf(:cl)//'Transfer finished'
 4731	    istat=lib$delete_file(term//'kerm.com;*')
	    call waitabit('5')
	    call elapsed_time(file_timer)
	    go to 4800
	else			!ascii upload
	    flow=to_vax
	    dummyl=get_vaxfile(filnam)
	    call out('Ascii files must not contain any non-printable',*4739)
	    call out('characters, and must not have any lines over',*4739)
	    call out('200 characters in length.',*4739)
	    call out('Each line must be terminated by a carriage',*4739)
	    call out('return.  The BBS will add a line feed for each',*4739)
	    call out('line you send.',*4739)
	    call out('Control-z to end, Control-c to abort.',*4739)
 4739	    write(6,1001)crlf(:cl)//crlf(:cl)//bell//
	1	'Start your file send now.'
	    write(6,1001)crlf(:cl)
 4740	    length=-200
	    call get_uplow_string(line,length)
	    if(length.lt.0) go to 4750
	    call send_cr()
	    call send_lf()
	    if(length.eq.0) then
		write(file_unit,1001)' '
	    else
		write(file_unit,1001)line(1:length)
	    end if
	    go to 4740

 4750	    if(length.eq.-1) then
		close(unit=file_unit)
		write(6,1001)crlf(:cl)//'Successful upload!'
		go to 4800
	    else
		close(unit=file_unit,disp='delete')
		write(6,1001)crlf(:cl)//bell//'Upload aborted'
	    end if
	end if
	go to 4900

 4800	continue	! get file description
	write(6,1001)crlf(:cl)//'Please give a 1-line description of the'
	write(6,1001)crlf(:cl)//'file for the download directory.'
	write(6,1001)crlf(:cl)//'?'
	dummy=40
	call get_uplow_string(line,dummy)
	if(dummy.eq.0.or.line.eq.' ') go to 4800

c	find out how big the file is.  This useropen will put the file
c	size into fsize.
	open(unit=4,file=filnam,status='old',readonly,
	1   useropen=getsize)
	close(unit=4)

c	Format a message and send to the operator.
	open(unit=4,file='mail.tmp',status='new',
	1    carriagecontrol='list')
	istat=str$trim(filnam,filnam,dummy)
	write(4,1001)'File name='//filename
	write(4,1001)'From:'//mail_name//' Stored as:'//zfilnam
	write(4,1001)'$rename '//filnam(1:dummy)//
	1   ' bbs$files:['//darea//binasc//']'//filename(1:flen)
	write(4,1004)darea,filename(1:18),fsize,ftyp//cdate//
	1   ' '//line(1:dummy)
 	close(unit=4)
	istat = lib$spawn('mail/subject="upload" mail.tmp sysop')
	go to 4900	!finished
 
 4900	continue
	return
	end

	subroutine listcat(darea)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will give the directory of files for a download area
c	Dale Miller - UALR
c
c
c	Rev. 4.0  27-Jun-1986
c	Rev. 4.5  24-Sep-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	character*(*) darea
	character cdate*11,filtyp*6,startoff*18
	integer length,dummy
	real*8 long_ago
	logical short

	integer istat,keyln
	integer compquad
	integer sys$asctim,sys$bintim,str$upcase,str$trim
	external uopen

	record/file_description/ fd

	short=.true.
	write(6,1001)crlf(:cl)//'Do you want a short or a long listing?'//
	1   ' [Short]'
	dummy=5
	call get_upcase_string(startoff,dummy)
	if(startoff(1:1).eq.'L') short=.false.

	write(6,1001)crlf(:cl)//'Enter earliest date of files you'//
	1   ' wish to see.'//crlf(:cl)//
	2   'The date must be dd-mmm-yyyy (e.g. 19-APR-1986)'//
	3   crlf(:cl)//'Or enter <cr> for a all dates.'//
	4   crlf(:cl)//'?'
	dummy=11
	call get_uplow_string(cdate,dummy)
	if(dummy.eq.0) cdate='01-JUL-1985'
	istat=str$upcase(cdate,cdate)
	istat = sys$bintim(cdate(:11)//' 00:00:00.00',long_ago)
	istat = sys$asctim(,cdate,long_ago,)

	write(6,1001)crlf(:cl)//
	1   'Enter the starting file name or <cr> for beginning :'
	dummy=18
	startoff=' '
	call get_filnam_string(startoff,dummy)
	if(startoff.eq.' ') startoff='.'
	cdate(5:5)=char(ichar(cdate(5:5))+32)
	cdate(6:6)=char(ichar(cdate(6:6))+32)
	write(6,1001)crlf(:cl)//'    Files since: '//cdate(:11)
	call ctrl_o_check(*10,*10)

c	Open the indexed file for reading.
	open(unit=4,		shared,
	1   file='bbs$files:['//darea//']files.idx',
	2   status='old',	organization='indexed',
	3   access='keyed',	form='unformatted',
	4   recl=128,		recordtype='fixed',
	5   readonly,		key=(1:18:character),
	6   useropen=uopen)

	fd.file_name='$Header'
	read(4,key=fd.file_name,err=100)fd
	istat = sys$asctim(,cdate,fd.upload_date,)

	cdate(5:5)=char(ichar(cdate(5:5))+32)
	cdate(6:6)=char(ichar(cdate(6:6))+32)
	write(6,1001)crlf(:cl)//'Last file added: '//cdate(:11)
	call ctrl_o_check(*10,*10)

 0100	fd.file_name=startoff
	read(4,keygt=fd.file_name,iostat=ios)fd
	do while (ios.eq.0)
	    call ctrl_o_check(*10,*10)
	    if(fd.file_type.eq.'A') then
		filtyp='Ascii '
	    else if(fd.file_type.eq.'B') then
		filtyp='Binary'
	    else
		go to 110
	    end if
	    istat=compquad(fd.upload_date,long_ago)
	    if(istat.ne.-1 .and. (.not.short)) then
		write(6,1001)crlf(:cl)//
	1	    '************************************************'//
	2	    '***********************'//crlf(:cl)
		istat = sys$asctim(,cdate,fd.upload_date,)
		cdate(5:5)=char(ichar(cdate(5:5))+32)
		cdate(6:6)=char(ichar(cdate(6:6))+32)
		istat=str$trim(fd.keywords,fd.keywords,keyln)

	    	write(6,1002)crlf(:cl),fd.file_name,cdate(:11),
	1	    (fd.file_size+1)/2,filtyp,fd.times_down,
	2	    crlf(:cl)//crlf(:cl),
	3	    fd.keywords(:keyln),fd.upload_name//crlf(:cl)

		istat=index(fd.upload_text,char(cr))
		do while(istat.ne.0)
		    write(6,1001)crlf(:cl)//fd.upload_text(:istat-1)
		    call ctrl_o_check(*10,*10)
		    fd.upload_text=fd.upload_text(istat+1:)
		    istat=index(fd.upload_text,char(cr))
		    end do
	        end if
	    if(istat.ne.-1 .and. short) then
		istat = sys$asctim(,cdate,fd.upload_date,)
		cdate(5:5)=char(ichar(cdate(5:5))+32)
		cdate(6:6)=char(ichar(cdate(6:6))+32)
		istat=str$trim(fd.keywords,fd.keywords,keyln)

	    	write(6,1003)crlf(:cl),fd.file_name,cdate(:11),
	1	    (fd.file_size+1)/2,filtyp,fd.keywords(:keyln)

	        end if
 0110	    read(4,keygt=fd.file_name,iostat=ios)fd
	    end do
 0010	close(unit=4)
	return
 1001	format(a)
 1002	format(a,a18,5x,a11,1x,i5,'K bytes',2x,a6,4x,'Accesses:',i5,a,5x,
	1   'Keywords: ',a,' By:',a)
 1003	format(a,a18,1x,a11,i4,'K ',a6,1x,a)
	end
