	program bbs_main
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	This is the driver for a VAX CBBS system
c
c	Begun: 19-Jul-1985
c	Dale Miller - University of Arkansas at Little Rock
c	Rev. 1.0  29-Jul-1985
c	Rev. 1.1  01-Aug-1985
c	Rev. 1.2  05-Aug-1985
c	Rev. 1.3  06-Aug-1985
c	Rev. 1.4  08-Aug-1985
c	Rev. 1.5  14-Aug-1985
c	Rev. 1.6  18-Aug-1985
c	Rev. 1.7  24-Aug-1985
c	Rev. 1.8  27-Aug-1985
c	Rev. 1.9  08-Sep-1985
c	Rev. 1.10 13-Sep-1985
c	Rev. 1.11 14-Sep-1985
c       Rev. 1.12 17-Sep-1985
c	Rev. 1.13 28-Sep-1985
c	Rev. 1.14 29-Sep-1985
c	Rev. 1.15 15-Oct-1985
c	Rev. 2.0  14-Nov-1985
c	Rev. 2.1  07-Jan-1986
c	Rev. 2.2  18-Jan-1986
c	Rev. 2.3  03-Feb-1986
c	Rev. 3.0  18-Feb-1986
c	Rev. 3.1  24-Feb-1986
c	Rev. 3.2  02-Mar-1986
c	Rev. 3.3  04-Mar-1986
c	Rev. 3.4  19-Apr-1986
c	Rev. 3.5  19-Jun-1986
c	Rev. 3.6  25-Jun-1986
c	Rev. 4.0  27-Jun-1986
c	Rev. 4.1  07-Jul-1986
c	Rev. 4.2  23-Jul-1986
c	Rev. 4.3  26-Jul-1986
c	Rev. 4.4  15-Aug-1986
c	Rev. 4.5  24-Sep-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for/nolist'
	include 'sys$library:foriosdef/nolist'
	include '($syidef)'
	include '($jpidef)'
	include '($rmsdef)'
	character logon_date*9,logon_time*8,inp_password*10
	character cdate*9,ctime*8,lms*9,clms*9,uns*9
	character yesno*3,three*3,bull_date*11
	character space*30/'                    '/
	character zeros*40/'0000000000000000000000000000000000000000'/
	character dummy_20*20,dummy_40*40,line*200
	character error*60/' '/
	character pm*14/' ** private **'/
	character last_name*20,first_name*20
	character zmail_from*30,xxx*4
	character nodename*6,terminal*6
	character prcname*15,cminutes*2
	character zfirst_name*20,zlast_name*20,zmail_to*30,qmail_to*30
	character string*80,cdummy*1,darea*3,zmail_subject*30
	byte dummyb
	integer istat,pid,realpid,high_bull
	integer try,length,fnlen,lnlen,ctlen,pwlen,namln,flen
	integer spc,sect,i,j,k,l,ii,jj,kk,ll
	integer dummy,dummy1,dummy2,dummy3,dummy4
	integer kmess,irec,krec,slen,num_flags
	integer status,next_mess,fmess,lmess,mess,mnum
	integer stack_ptr,field,count,number
	integer idummy(8),flags(100),stack(200)
	integer compquad
	logical*1 interactive,reprint,found,nostop,dummyl
	logical*1 have_read(1000),busy,arklug
	real*8 long_ago,his_login,day_1,day_14,day_31,rdummy,right_now
	integer*4 la(2),hl(2)

c	System routines used
	integer str$upcase,str$trim,str$position
	integer sys$gettim,sys$setprn,sys$asctim,sys$bintim
	integer lib$getsyi,lib$getjpi,lib$set_symbol,lib$wait
	integer lib$spawn,lib$delete_file
	integer lbr$output_help,sys$trnlog

	equivalence(long_ago,la), (his_login,hl)
	equivalence(stack,rbuffer),(have_read,xbuffer)
	external uopen,getsize,bbs_put_output,bbs_get_input

	record /userlog_structure/ zur

	record /mail_header_structure/ mh

c

 1001	format(a)
 1002	format(i2.2)
 1003	format(q,a)
 1004	format('$!',a3,'=',a18,i3,1x,a)
 1005	format(a,i4,' users listed.')
 1006	format(a,'Last logon on ',a,' at ',a,
	1    'You have signed on',i6,' times.',a,
	2    'The last message you read was',a9,a,
	3    '      Current last message is',a9,a,
	4    '          You are user number',a9,a,
	5    'There are',i4,' bulletins today.  Last bulletin was ',a)
 1007	format(1x,a,z8,' Hex')
 1008	format(a,a28,1x,a9,1x,a8,i6,4x,a)
 1009	format(a,'You have',i3,' marked messages waiting.',a)
 1010	format(a,'There are',i4,' bulletins today.  Last bulletin was ',a)
 1011	format(i<dummy>)
 1012	format(i3.3)
 1013	format(a,i2,'>')
 1015	format(a,i2,1x,a)
 1018	format(a,'Sysop mode is ',l1,a,'Last header=',i6,
	1   a,'Last data=  ',i6)
 1019	format(a1,'file_',i6.6,'.dat')
 1020	format(a,i1,' - ',a)
 1021	format(a,8i2)
 1022	format(a,'S#',i1,' #',i7,' From:'a18,' To:',a18,' Sub:',a18)
 1023	format(a,'You have flagged',i4,' messages.  They may be read',
	1  a,'with the (F)lagged option of the (R)etrieve command')
 1024   format(i5.5)
 1025	format(a,1x,i6.6)
 1026	format(i6)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	logon message and user log update
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	open(unit=6,recl=1024,status='unknown',carriagecontrol='none')
	area = 'logon'
	sysop = .false.
	tnext=1
	allowable_units=3600			!How many seconds per day
	crlf=char(10)//char(13)
	ffeed=char(10)//char(13)
	cl=2
	fl=2
	line='FALSE'
	istat= sys$trnlog('ARKLUG',,line,,,)
	if(line(1:4).eq.'TRUE') then
	    arklug=.true.
	else
	    arklug=.false.
	endif

	istat=sys$bintim('18-NOV-1858 00:00:00',day_1)
	istat=sys$bintim('01-DEC-1858 00:00:00',day_14)
	istat=sys$bintim('18-DEC-1858 00:00:00',day_31)
	call fake_vaxnet		!set up the symbols, etc.
	interactive=.true.		!clear the control-s and disallow
	call setup_local(interactive)	!interruptions
	call date(logon_date)
	call time(logon_time)
	if (arklug) then
	    secnam(1)='General'
	    secnam(2)='VAX Sig'
	    secnam(3)='PDP 11 Sig'
	    secnam(4)='Graphics Sig'
	    secnam(5)='Office Automation'
	    secnam(6)='PC Sig'
	    secnam(7)='Unused'
	    secnam(8)='Unused'
	else
	    secnam(1)='General'
	    secnam(2)='Hardware'
	    secnam(3)='Software'
	    secnam(4)='For Sale/WTB'
	    secnam(5)='The Arts'
	    secnam(6)='Unused'
	    secnam(7)='Unused'
	    secnam(8)='Games'
	end if


	istat = lib$getsyi(syi$_nodename,,nodename,,,)
	pid=0
	istat = lib$getjpi(jpi$_pid,pid,,realpid,,)
	istat = lib$getjpi(jpi$_terminal,realpid,,,terminal,)
	istat = str$trim(terminal,terminal,length)
c	term = nodename(1:1)//terminal(1:2)//terminal(length-1:length)

c	open the userlog and message files
	open(unit=1,file='bbs$:userlog.dat',status='old',	
	1   organization='indexed',access='keyed',err=90500,
	2   recordtype='fixed',recl=50,shared,useropen=uopen,
	3   iostat=ios)
	open(unit=2,file='bbs$:message.hed',status='old',	
	1   organization='relative',access='direct',err=90600,
	2   recordtype='fixed',recl=48,shared,useropen=uopen,
	3   iostat=ios)
	open(unit=3,file='bbs$:message.dat',status='old',	
	1   organization='relative',access='direct',err=90700,
	2   recordtype='fixed',recl=20,shared,useropen=uopen,
	3   iostat=ios)

c
	read(1,key=zeros,iostat=ios,err=90500)ur.user_key,
	1   user_number,high_bull,bull_date
	user_number=user_number+1
	rewrite(1,err=90500)zeros,user_number,high_bull,bull_date

	read(2,rec=1,iostat=ios,err=90600)last_header,last_data,
	1   first_mnum,last_mnum
	unlock(unit=2)
c
c
c
	call out('     Welcome to UBBS - The UALR Bulletin Board System',*95)
	call out('               Rev. 4.5  --  24-Sep-1986'//crlf(:cl),*95)
	call type_file('bbs$:welcome.txt')

 0095	yesno='N'
	do while(yesno(1:1).eq.'N')
 0100	    write(6,1001)crlf(:cl)//'Please enter your first name..'
	    fnlen=20
	    call get_upcase_string(first_name,fnlen)
	    if(fnlen.eq.0) go to 100	!force an answer
 0110	    write(6,1001)crlf(:cl)//'          and your last name..'
	    lnlen=20
	    call get_upcase_string(last_name,lnlen)
	    if(lnlen.eq.0) go to 110	!force an answer
	    mail_name=first_name(1:fnlen)//' '//last_name(1:lnlen)
	    prcname=last_name(1:lnlen)//','//first_name(1:fnlen)
	    write(6,1001)crlf(:cl)//crlf(:cl)//' Your name is '//mail_name
	    write(6,1001)crlf(:cl)//'is this correct? [Yes]'
	    dummy=3
	    call get_upcase_string(yesno,dummy)
	    end do
	istat = lib$set_symbol('cb_handle',mail_name)
	if(mail_name.eq.'DALE MILLER'.or.
	2   mail_name.eq.'MICHAEL SMITH'.or.
	3   mail_name.eq.'NETA COUNTS') then
	    sysop2=.true.
	else
	    sysop2=.false.
	end if

c
c	Check for existence of user and update user file.
c
	ur.user_key=last_name//first_name

	read(1,key=ur.user_key,iostat=ios)ur
	if(ios.ne.0) go to 150				!Record does not exist

c	get his password
	try=1				!set up for his first chance
 0130	write(6,1001)crlf(:cl)//'Please enter your password..'
	call get_password(inp_password,pwlen)
	if(ur.password.eq.inp_password) go to 140
	if(try.gt.2) go to 90000
	try=try+1
	write(6,1001)crlf(:cl)//'Not right, try again'
	go to 130

 0140	continue
c	now, set up to re-write
	ur.num_logon=ur.num_logon+1
	if(ur.current_day.ne.logon_date) then
	    ur.current_day = logon_date
	    ur.seconds_today = 0
	    end if
	zur=ur
	zur.last_log_date=logon_date
	zur.last_log_time=logon_time
	rewrite(1,iostat=ios,err=90500)zur
	go to 190

 0150	continue	!come here if no record in userlog
	write(6,1001)crlf(:cl)//crlf(:cl)
	write(6,1001)crlf(:cl)//
	1   'There is no information for you in the user log'
	write(6,1001)crlf(:cl)//
	1   'Please enter some information about yourself.'
	write(6,1001)crlf(:cl)//
	1   '(<cr> returns you to the "First name" prompt).'

 0151	continue
	if(.not.arklug) go to 153
	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   ' What is you DECUS number?'
	dummy=6
	dummyl=.false.
	call get_number(string,dummy,dummyl)
	if (dummy.eq.0) go to 95
	if (dummy.lt.6)go to 151
	read(string,1026)ur.decus_number
	if(ur.decus_number.eq.0) go to 151

 0152	continue
	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   ' What is your company name?'
	dummy=20
	call get_uplow_string(ur.company_name,dummy)
	if (dummy.eq.0) go to 95
	if(ur.city.eq.' ') go to 152

 0153	continue
	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   ' The city you are calling from is?'
	ctlen=20
	call get_uplow_string(ur.city,ctlen)
	if (ctlen.eq.0) go to 95
	if(ctlen.eq.0.or.ur.city.eq.' ') go to 153

 0154	continue
	write(6,1001)crlf(:cl)//'The state you are calling from is?'
	dummy=2
	call get_upcase_string(ur.state,dummy)
	if (dummy.eq.0) go to 95
	if(dummy.lt.2.or.ur.state.eq.' ') go to 154

 0155	continue
	write(6,1001)crlf(:cl)//'What type of computer do you use?'
	dummy=20
	call get_uplow_string(ur.computer,dummy)
	if (dummy.eq.0) go to 95
	if(ur.computer.eq.' ') go to 155

	write(6,1001)crlf(:cl)
	if(arklug) then
	    write(6,1025)crlf(:cl)//'Your DECUS number is ',ur.decus_number
	    write(6,1001)crlf(:cl)//'Your company name is '//ur.company_name
	    end if
	write(6,1001)crlf(:cl)//'You are calling from '//
	1   ur.city(1:ctlen)//','//ur.state
	write(6,1001)crlf(:cl)//'And you use a '//ur.computer
	write(6,1001)crlf(:cl)//'Is this correct? [Yes]'
	dummy=3
	call get_upcase_string(yesno,dummy)
	if(yesno(1:1).eq.'N') go to 151

 0156	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   'To allow you to send messages, you must supply your'
	write(6,1001)crlf(:cl)//
	1   'phone number.  This will not appear to anyone other than'
	write(6,1001)crlf(:cl)//
	1   'the system operator.'
	write(6,1001)crlf(:cl)//crlf(:cl)//'Number (with area code):'
	dummy=10
	dummyl=.false.
	call get_number(ur.phone_number,dummy,dummyl)
	if(dummy.lt.10) then
	    write(6,1001)crlf(:cl)//bell//
	1	'That is not a valid phone number.'
	    go to 156
	    end if

 0157	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   'Passwords are required on this system.'
	write(6,1001)crlf(:cl)//'Please enter a 4 to 10 character password'
	write(6,1001)crlf(:cl)//'to be used to help prevent unauthorized'
	write(6,1001)crlf(:cl)//'usage.  No control characters are allowed,'
	write(6,1001)crlf(:cl)//'and case is unimportant..'
	call get_password(ur.password,dummy)
	if(dummy.lt.4) go to 157
	write(6,1001)crlf(:cl)//'Enter it again please....'
	call get_password(inp_password,dummy)
	if(inp_password.ne.ur.password) then
	    write(6,1001)crlf(:cl)//crlf(:cl)//bell//
	1	'Those did not match, please try again.'
	    go to 157
	    end if
	ur.num_logon=1
	ur.last_log_date=logon_date
	ur.last_log_time=logon_time
	ur.last_message=0
	ur.num_unread=0
	ur.auth_sections=255
	ur.approved=.false.
	ur.user_crlf=char(13)//char(10)//char(255)
	ur.user_ff=char(13)//char(10)//char(255)
	istat=sys$gettim(ur.last_pass_chg)
	ur.current_day = logon_date
	ur.seconds_today = 0
	zur=ur
	write(1,iostat=ios,err=90500)zur
	call out(crlf(:cl)//'You are now entered into the user log.',*190)
	call out('You may use all UBBS functions except entering',*190)
	call out('messages and CB. To be able to use those, you must',*190)
	call out('use the (P)rivate message to operator function to',*190)
	call out('leave a message giving me a time to call you to',*190)
	call out('verify you.'//crlf(:cl)//crlf(:cl),*190)


c	Check his logon time so far today, and set up user-specific items
 0190	istat=sys$setprn(prcname)
	initial_units = ur.seconds_today
	current_units = ur.seconds_today
	if(ur.seconds_today.gt.allowable_units) go to 91000
	call init_timer(user_timer)
	crlf=ur.user_crlf
	ffeed=ur.user_ff
	cl=index(crlf,char(255))-1
	fl=index(ffeed,char(255))-1
	if(cl.le.0) cl=4
	if(fl.le.0) fl=4

c	print information message
	call comint(ur.last_message,lms)
	call comint(last_mnum,clms)
	call comint(user_number,uns)
	write(6,1006)crlf(:cl)//crlf(:cl),ur.last_log_date,
	1   ur.last_log_time//crlf(:cl),ur.num_logon,crlf(:cl),
	2   lms,crlf(:cl),clms,crlf(:cl),
	3   uns,crlf(:cl)//crlf(:cl),high_bull,bull_date
	zur=ur
	istat=sys$gettim(right_now)
	call subquad(right_now,day_31,rdummy)
	istat=compquad(rdummy,ur.last_pass_chg)
	if(istat.eq.1) then
	    write(6,1001)crlf(:cl)//bell//bell//
	1	'********************************************************'
	    write(6,1001)crlf(:cl)//
	1	'*                                                       *'
	    write(6,1001)crlf(:cl)//
	1	'* It has been more than 1 month since you changed your  *'
	    write(6,1001)crlf(:cl)//
	1	'* password.  For your own security, you need to change  *'
	    write(6,1001)crlf(:cl)//
	1	'* your password.  (use the (M) option of the main menu) *'
	    write(6,1001)crlf(:cl)//
	1	'*                                                       *'
	    write(6,1001)crlf(:cl)//bell//bell//
	1	'*********************************************************'
	    end if

	if(ur.num_unread.eq.1) then
	    write(6,1001)crlf(:cl)//bell//bell//
	1	'You have a marked message waiting.'
	else if(ur.num_unread.gt.1) then
	    write(6,1009)crlf(:cl),ur.num_unread,bell//bell
	end if

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	the main menu is at 200
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 0200	continue
	call time(ctime)
	call add_elapsed_time(*91000)
	write(cminutes,1002)current_units/60
	area='menu'
	if((.not.ur.xpert).or.reprint) then
	    reprint=.false.
	    call out(ffeed(:fl)//
	1	     '            UBBS Main Menu',*201)
	    call out(crlf(:cl)//
	1	     '(B)ulletins         (P)rivate message to operator',*201)
	    call out('(C).B. simulator    (R)etrieve messages',*201)
	    call out('(E)nter message     (S)can messages',*201)
	    call out('(F)ile transfer     (U)ser log',*201)
	    call out('(G)oodbye           (W)elcome reprint',*201)
	    call out('(H)elp              (X)pert user toggle',*201)
	    call out('(M)odify user info',*201)
 0201	    continue
	    write(6,1001)crlf(:cl)//crlf(:cl)//ctime//'-'//
	1	cminutes//' Command ? '
	else
	    write(6,1001)crlf(:cl)//ctime//'-'//cminutes//
	1	' Command (B,C,E,F,G,H,M,P,R,S,U,W,X,?)?'
	end if
	length=80
	call get_uplow_string(string,length)
	istat=str$upcase(cdummy,string)
	if(cdummy.eq.'B') go to 2000		!Bulletins
	if(cdummy.eq.'C') go to 15000		!CB simulator
	if(cdummy.eq.'E') go to 3000		!Enter message
	if(cdummy.eq.'F') go to 4000		!File transfer
	if(cdummy.eq.'G') go to 5000		!Goodbye
	if(cdummy.eq.'H') go to 6000		!Help
	if(cdummy.eq.'M') go to 8000		!Modify user info
	if(cdummy.eq.'P') go to 9000		!Private message
	if(cdummy.eq.'Q'.and.
	1   (mail_name.eq.'DALE MILLER'.or.
	2   mail_name.eq.'MICHAEL SMITH'.or.
	3   mail_name.eq.'NETA COUNTS')) THEN
	    sysop = .not.sysop
	    write(6,1018)crlf(:cl),sysop,crlf(:cl),
	1	last_header,crlf(:cl),last_data
	    go to 0200
	    end if
	if(cdummy.eq.'R') go to 10000		!Retrieve message
	if(cdummy.eq.'S') go to 11000		!Scan message
	if(cdummy.eq.'U') go to 12000		!User log
	if(cdummy.eq.'W') go to 13000		!Welcome reprint
	if(cdummy.eq.'X') go to 14000		!Xpert user mode
	if(cdummy.eq.'?') then			!reprint menu
	    reprint=.true.
	    go to 0200
	end if

	write(6,1001)crlf(:cl)//'That was not a valid command.  '//
	1   'Try again, please'
	go to 0200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 2000	continue		!Bulletins
	area='bulletin'
	write(6,1010)ffeed(:fl),high_bull,bull_date
	call type_file('bbs$:bulletin.mnu')
 2010	write(6,1001)crlf(:cl)//crlf(:cl)//'Bulletin number? [quit] '
	dummy=7
	dummyl=.false.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0) go to 200	!end of bulletins
	read(string,1011)number		!get number into an integer
	if(number.lt.1) go to 2050
	if(number.gt.high_bull) go to 2050
	write(three,1012)number		!put it into the string
	write(6,1001)ffeed(:fl)
	call type_file('bbs$:bulletin.'//three)
	write(6,1001)crlf(:cl)//crlf(:cl)//'Press <cr> to continue'
	dummy=1
	call get_uplow_string(cdummy,dummy)
	go to 2000

 2050	write(6,1001)crlf(:cl)//'That bulletin does not exist.  '//
	1   'Please try again.'
	go to 2010

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 3000	continue		!Enter message
	area='enter message'
	if (.not.ur.approved) then
	    write(6,1001)crlf(:cl)//bell//
	1	'You are not yet approved to send messages.'
	    write(6,1001)crlf(:cl)//'Sorry.'
	    go to 0200
	    end if
	write(6,1001)crlf(:cl)//crlf(:cl)//'Message is to: '
	namln=30
	mh.mail_person=.true.
	call get_uplow_string(zmail_to,namln)
	if(namln.eq.0) then
	    write(6,1001)crlf(:cl)//'Message send aborted'//bell
	    go to 200
	    end if
	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.  This must be a public message
	mh.mail_person=.false.
	go to 3030	!no need to check further

 3010	zlast_name=qmail_to(ii:30)
	zur.user_key=zlast_name//zfirst_name
	read(1,key=zur.user_key,iostat=ios)zur
	unlock(unit=1)
	if(ios.ne.0) mh.mail_person=.false.		!Error on read
 3030	write(6,1001)crlf(:cl)//'      Subject: '
	dummy=20
	call get_uplow_string(mh.mail_subject,dummy)
	if(dummy.eq.0) then
	    write(6,1001)crlf(:cl)//'Message send aborted'//bell
	    go to 200
	    end if
	if(.not.mh.mail_person) then
 3031	    call date(cdate)
	    dummy_20=cdate(1:7)//'19'//cdate(8:9)//' 00:00:00'
	    istat=sys$bintim(dummy_20,rdummy)
	    if(arklug) then
		call addquad(rdummy,day_14,right_now)
	    else
		right_now=rdummy
	    end if
	    istat=sys$asctim(,dummy_20,right_now,)
	    mh.mail_private=.false.
	    write(6,1001)crlf(:cl)//
	1	'What is the expiration date for this message? ['//
	2	dummy_20(:11)//']'
	    dummy=11
	    call get_uplow_string(line,dummy)
	    istat=str$upcase(line,line)
	    if(dummy.eq.0) then
		mh.mail_expire=right_now
	    else if(line.eq.'T') then
		call addquad(right_now,day_1,mh.mail_expire)
	    else
		istat=sys$bintim(line(:11)//' 00:00:00',mh.mail_expire)
	    end if
	    dummy=compquad(mh.mail_expire,right_now)
	    if(dummy.eq.-1) then
		write(6,1001)crlf(:cl)//
	1	    'That is not a valid date.  Dates must be of the'//
	2	    crlf(:cl)//'form dd-mmm-yyyy (e.g. 01-Jan-1986)'
		go to 3031
	    end if
	    call addquad(right_now,day_31,rdummy)
	    dummy=compquad(rdummy,mh.mail_expire)
	    if(dummy.eq.-1) then
		write(6,1001)crlf(:cl)//
	1	    'Your expiration date may be no more than 1 month in'//
	2	    crlf(:cl)//'the future.  Please try again'
		go to 3031
	    end if
	    istat=sys$asctim(,line,mh.mail_expire,)
	else
	    mh.mail_private=.false.
	    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.
	end if
	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   'Your message is to: '//zmail_to(1:namln)
	write(6,1001)crlf(:cl)//'The subject is:     '//mh.mail_subject
	if(mh.mail_private) then
	    write(6,1001)crlf(:cl)//'** Private message **'
	else if(mh.mail_person) then
	    write(6,1001)crlf(:cl)//'Non-private message'
	else
	    write(6,1001)crlf(:cl)//'Expiration: '//line(:11)
	end if
	write(6,1001)crlf(:cl)//'Is this correct? [Yes]'
	dummy=3
	call get_upcase_string(yesno,dummy)
	if(dummy.gt.0.and.yesno(1:1).ne.'Y') go to 3000
	ii=20
	call enter_message(ii,*0200,0)

 3080	write(6,1001)crlf(:cl)//'Section number? [list]'
	dummy=1
	dummyl=.false.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0) then
	    do kk=0,7
		call ctrl_o_check(*3080,*3080)
		write(6,1020)crlf(:cl),kk,secnam(kk+1)
		end do
	    go to 3080
	    end if
	read(string,1011)sect
	if(sect.gt.7) then
	    write(6,1001)crlf(:cl)//'Invalid section number'
	    go to 3080
	    end if
	mh.mail_section=sect
3090	read(2,rec=1,iostat=ios,err=90600)last_header,last_data,
	1   first_mnum,last_mnum,busy
	if(busy) then
	    unlock(unit=2)
	    dummy=lib$wait(1.0)
	    go to 3090
	    end if
	last_header=last_header+1
	last_mnum=last_mnum+1
	write(2,rec=1,iostat=ios,err=90600)last_header,last_data+ii,
	1   first_mnum,last_mnum,busy
	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_reply_to=0
	do i=1,10
	    mh.mail_replys(i)=0
	    end do
	mh.mail_first=last_data+1
	mh.mail_last=last_data+ii
	mh.mail_from=mail_name
	mh.mail_messnum=last_mnum
	write(2,rec=last_header,iostat=ios,err=90600) mh

	do jj=1,ii
	    write(3,rec=last_data+jj)message(jj)
	    end do
	call comint(last_mnum,lms)
	write(6,1001)crlf(:cl)//crlf(:cl)//' Message number '//lms//
	1   ' sent.'//bell//bell

	if(.not.mh.mail_person) go to 200		!cannot flag mailbox
	read(1,key=zur.user_key,iostat=ios,err=90500)zur
	zur.num_unread=zur.num_unread+1
	rewrite(1,iostat=ios,err=90500)zur
	unlock(unit=1)
	unlock(unit=2)
	unlock(unit=3)
	go to 200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 4000	continue		!File transfer
	area='file transfer'
	call add_elapsed_time(*91000)
	read(1,key=ur.user_key,iostat=ios,err=90500)ur
	ur.seconds_today = current_units
	rewrite(1,iostat=ios,err=90500)ur
 
	if(arklug) then
	    call arklug_files_section
	else
	    call ubbs_files_section
	end if

c	Turn the timer back on.

 4900	continue
	call init_timer(user_timer)
	initial_units=ur.seconds_today
	go to 0200
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 5000	continue		!Goodbye
	area='goodbye'
	read(1,key=ur.user_key,iostat=ios,err=90500)ur
	ur.seconds_today = current_units
	rewrite(1,iostat=ios,err=90500)ur
	write(6,1001)crlf(:cl)//crlf(:cl)//'Thank you for calling UBBS'
	go to 99990

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 6000	continue		!Help
	area='help'
	controlc_typed = .false.
	istat=lbr$output_help(bbs_put_output,,'bbs_help'
	1   ,'bbs$:helplib',,bbs_get_input)
	go to 0200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c7000	continue		!Kill message
c	area='kill'
c 7010	read(2,rec=1,iostat=ios,err=90600)last_header,last_data,
c	1   first_mnum,last_mnum
c	unlock(unit=2)
c 7020	write(6,1001)crlf(:cl)//
c	1   'Which message do you wish to kill? [exit]'
c	dummy=7
c	dummyl=.false.
c	call get_number(string,dummy,dummyl)
c	if(dummy.eq.0) go to 0200
c	read(string,1011)kmess
c	if(kmess.lt.first_mnum.or.kmess.gt.last_mnum) then
c	    write(6,1001)crlf(:cl)//
c	1	'That message does not exist.  Try again.'
c	    go to 7020
c	    end if
c	found=.false.
c	krec=1
c	do while(.not.found)
c	    krec=krec+1
c	    if(krec.gt.last_header) found=.true.
c	    read(2,rec=krec,iostat=ios,err=90600) mh
c	    if(mh.mail_messnum.ge.kmess) found=.true.
c	    end do
c	unlock(unit=2)
c 	istat = str$upcase(mh.mail_to,mh.mail_to)
c	if(mh.mail_messnum.eq.kmess) then
c	    if(mail_name.ne.mh.mail_to.and.mail_name.ne.mh.mail_from) then
c		write(6,1001)crlf(:cl)//'That is not your message.'
c		go to 7020
c		end if
c	    end if
c
c	if(mh.mail_deleted.or.mh.mail_messnum.ne.kmess) then
c		write(6,1001)crlf(:cl)//
c	1	    'That message does not exist.  Try again.'
c		go to 7020
c		end if
c
c	istat = str$trim(mh.mail_from,mh.mail_from,dummy1)
c	istat = str$trim(mh.mail_to,mh.mail_to,dummy2)
c	istat = str$trim(mh.mail_subject,mh.mail_subject,dummy3)
c	write(6,1001)crlf(:cl)//'   From: '//mh.mail_from(1:dummy1)
c	write(6,1001)crlf(:cl)//'     To: '//mh.mail_to(1:dummy2)
c	write(6,1001)crlf(:cl)//'Subject: '//mh.mail_subject(1:dummy3)
c	write(6,1001)crlf(:cl)//crlf(:cl)//'Delete this message? [Yes] '
c	dummy=3
c	call get_upcase_string(yesno,dummy)
c	if(dummy.gt.0.and.yesno(1:1).eq.'N') then
c	    unlock(unit=2)
c	    go to 7000
c	    end if
c	mh.mail_deleted=.true.
c	write(2,rec=krec,iostat=ios,err=90600) mh
c	if(mh.mail_person.and..not.mh.mail_read) then
c	    istat=str$upcase(qmail_to,mh.mail_to)
c	    spc=index(qmail_to,' ')
c	    zfirst_name=qmail_to(1:spc-1)	
c	    do ii=spc+1,30
c		if(zmail_to(ii:ii).ne.' ') go to 7040
c		end do
c
c 7040	    zlast_name=qmail_to(ii:30)
c	    zur.user_key=zlast_name//zfirst_name
c	    read(1,key=zur.user_key,iostat=ios)zur
c	    if(ios.ne.0) go to 7060
c	    zur.num_unread=zur.num_unread-1
c	    rewrite(1,iostat=ios,err=90500)zur
c	    end if
c
c 7060	write(6,1001)crlf(:cl)//crlf(:cl)//'Message from '//
c	1   mh.mail_from(1:dummy1)//' to '//mh.mail_to(1:dummy2)//
c	2   ' deleted.'//bell
c	go to 0200
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 8000	continue		!Modify user info
	area='modify'
	read(1,key=ur.user_key,iostat=ios,err=90500)ur
	unlock(unit=1)
	istat=str$trim(ur.city,ur.city,dummy1)
	istat=str$trim(ur.computer,ur.computer,dummy2)
	call out(ffeed(:fl)//'You are calling from ',ur.city(1:dummy1)
	1    //', '//ur.state,*8050)
	call out('And you use a '//ur.computer(1:dummy2),*8050)
	call out(crlf(:cl)//'You are currently set to read sections:',*8050)
	kk=0
	do ii=0,7
	    dummyb=0
	    dummyb=dummyb.or.(2**ii)
	    if((dummyb.and.ur.auth_sections).ne.0) then
		kk=kk+1
		idummy(kk)=ii
		end if
	    end do
	if (kk.eq.0) then
	    call out('None!!',*8050)
	else
	    write(6,1021)crlf(:cl),(idummy(ll),ll=1,kk)
	    call ctrl_o_check(*8050,*8050)
	end if
	dummy1=cl
	call make_readable(ur.user_crlf,dummy1,dummy_20)
	call out(' Your end-of-line sequence is:'//dummy_20(1:dummy1),*8050)
	dummy1=fl
	call make_readable(ur.user_ff,dummy1,dummy_20)
	call out('Your clear-screen sequence is:'//dummy_20(1:dummy1),*8050)
	istat=sys$asctim(,dummy_20,%ref(ur.last_pass_chg),)	
	call out('Your password was last changed on '//
	1   dummy_20(1:11)//' at '//dummy_20(13:20),*8050)

8050	continue	!modification menu
	call out(crlf(:cl),*8051)
	call out('You may change any of the following information',*8051)
	call out('(C)ity, state and computer type',*8051)
	call out('(E)xit (no more changes)',*8051)
	call out('(H)elp',*8051)
	call out('(M)essage sections',*8051)
	call out('(P)assword',*8051)
	call out('(T)erminal characteristics',*8051)
 8051	call out(crlf(:cl)//'Item [E]?',*8051)
	dummy=1
	call get_upcase_string(cdummy,dummy)
	if(dummy.eq.0.or.cdummy.eq.'E') go to 8900
	if(cdummy.eq.'C') go to 8100
	if(cdummy.eq.'H') go to 8200
	if(cdummy.eq.'M') go to 8300
	if(cdummy.eq.'P') go to 8400
	if(cdummy.eq.'T') go to 8500
	write(6,1001)crlf(:cl)//'That is not a valid command'
	write(6,1001)crlf(:cl)//'Please try again.'//bell
	go to 8050

 8100	write(6,1001)crlf(:cl)//' The city you are calling from is? ['//
	1    ur.city(1:dummy1)//'] '
	ctlen=20
	call get_uplow_string(zur.city,ctlen)
	if(ctlen.eq.0) go to 8110
	if(zur.city.eq.' ') go to 8100
	ur.city=zur.city
 8110	write(6,1001)crlf(:cl)//'The state you are calling from is? ['//
	1   ur.state//'] '
	dummy=2
	call get_upcase_string(zur.state,dummy)
	if(dummy.eq.0) go to 8120
	if(zur.state.eq.' ') go to 8110
	ur.state=zur.state
 8120	write(6,1001)crlf(:cl)//'What type of computer do you use? ['//
	1    ur.computer(1:dummy2)//'] '
	dummy=20
	call get_uplow_string(zur.computer,dummy)
	if(dummy.eq.0) go to 8130
	if(zur.computer.eq.' ') go to 8120
	ur.computer=zur.computer
 8130	continue
	istat=str$trim(ur.city,ur.city,dummy1)
	istat=str$trim(ur.computer,ur.computer,dummy2)
	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   'You are calling from ',ur.city(1:dummy1)//', '//ur.state
	write(6,1001)crlf(:cl)//'And you use a '//ur.computer(1:dummy2)
	write(6,1001)crlf(:cl)//'Is this correct? [Yes]'
	dummy=3
	call get_upcase_string(yesno,dummy)
	if(yesno(1:1).eq.'N') go to 8100
	go to 8050

 8200	continue	! Help with options
	controlc_typed = .false.
	istat=lbr$output_help(bbs_put_output,,
	1   'bbs_help modify','bbs$:helplib',,bbs_get_input)
	go to 8050

 8300	continue	! choose message sections
	write(6,1001)crlf(:cl)//'The message sections available are:'
	do ii=0,7
	    write(6,1020)crlf(:cl),ii,secnam(ii+1)
	    end do
	write(6,1001)crlf(:cl)//crlf(:cl)
 8350	write(6,1001)crlf(:cl)//'Enter the sections you wish to read as a'
	write(6,1001)crlf(:cl)//'comma-seperated list, ALL for all sections'
	write(6,1001)crlf(:cl)//'or a carriage return for no change.'
	write(6,1001)crlf(:cl)//'?'
	slen=20
	call get_uplow_string(string,slen)
	istat=str$upcase(string,string)
	if(slen.eq.0) then
	    write(6,1001)crlf(:cl)//'No section change made.'
	    go to 8050
	    end if
	if(string.eq.'ALL') then
	    ur.auth_sections=255
	    write(6,1001)crlf(:cl)//'Set to read all sections.'
	    go to 8050
	    end if
	do ii=1,slen
	    i=ichar(string(ii:ii))
	    if((i.lt.48.or.i.gt.55).and.i.ne.44) then
		write(6,1001)crlf(:cl)//'Invalid list, try again.'
		go to 8350
		end if
	    end do
	ur.auth_sections=0
	do while(string.ne.' ')
	    dummy=index(string,',')-1
	    if(dummy.le.0) dummy=slen
	    read(string,1011)ii
	    dummyb=2**ii
	    ur.auth_sections=ur.auth_sections.or.dummyb
	    string(1:dummy+1)=' '
	    end do
	go to 8050

 8400	continue	!Change password
	write(6,1001)crlf(:cl)//'Enter your old password..'
	dummy=10
	call get_password(inp_password,dummy)
	if(inp_password.ne.ur.password) then
	    write(6,1001)crlf(:cl)//'No match.  Password not changed.'
	else
 8401	    write(6,1001)crlf(:cl)//'Enter your new password..'
	    dummy=10
	    call get_password(inp_password,dummy)
	    if(dummy.lt.4) then
		write(6,1001)crlf(:cl)//
	1	    'That is too short.  Your password must be'//
	2	    crlf(:cl)//'at least 4 characters.'
		go to 8401
	    end if
	    write(6,1001)crlf(:cl)//'Enter it again...........'
	    dummy=10
	    call get_password(zur.password,dummy)
	    if(zur.password.ne.inp_password) then
		write(6,1001)crlf(:cl)//'No match.  Password not changed.'
	    else if(zur.password.eq.ur.password) then
		write(6,1001)crlf(:cl)//'Password not changed.'
	    else
		ur.password=inp_password
		istat=sys$gettim(%ref(ur.last_pass_chg))
	    end if
	end if
	go to 8050
	
 8500	continue	!Terminal options
	dummy1=cl
	call make_readable(ur.user_crlf,dummy1,dummy_20)
	write(6,1001)crlf(:cl)//
	1   ' Your end-of-line sequence is:'//dummy_20(1:dummy1)
	dummy1=fl
	call make_readable(ur.user_ff,dummy1,dummy_20)
	write(6,1001)crlf(:cl)//
	1   'Your clear-screen sequence is:'//dummy_20(1:dummy1)
	write(6,1001)crlf(:cl)//
	1   'Do you wish to change your end-of-line sequence? [No]'
	dummy=3
	call get_upcase_string(yesno,dummy)
	if(yesno(1:1).ne.'Y') go to 8550
	write(6,1001)crlf(:cl)//'Available end of line sequences are:'
	write(6,1001)crlf(:cl)//crlf(:cl)//'(0)  No change'
	write(6,1001)crlf(:cl)//'(1)  Carriage return / line feed'
	write(6,1001)crlf(:cl)//'(2)  Carriage return only'
	write(6,1001)crlf(:cl)//'(3)  Line feed only'
	write(6,1001)crlf(:cl)//crlf(:cl)//
	1   'Please choose one of the above.  If you need'
	call out('a different sequence, please contact the operator.',*8050)
	write(6,1001)crlf(:cl)//'Your choice? [0]'
	dummy=1
	dummyl=.false.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0) go to 8500
	read(string,1011)number
	if(number.eq.0) then
	    go to 8550
	else if(number.eq.1) then
	    ur.user_crlf=char(13)//char(10)//char(255)
	    cl=2
	else if(number.eq.2) then
	    ur.user_crlf=char(13)//char(255)
	    cl=1
	else if(number.eq.3) then
	    ur.user_crlf=char(10)//char(255)
	    cl=1
	else
	    write(6,1001)crlf(:cl)//bell//
	1	'Invalid choice.  Please try again'
	    go to 8500
	end if
	crlf=ur.user_crlf

 8550	write(6,1001)crlf(:cl)//
	1   'Do you wish to change your clear-screen sequence? [No]'
	dummy=3
	call get_upcase_string(yesno,dummy)
	if(yesno(1:1).ne.'Y') go to 8050
	write(6,1001)crlf(:cl)//'Your clear-screen sequence may be 1 to 4'
	write(6,1001)crlf(:cl)//'characters.  You will be prompted to enter'
	write(6,1001)crlf(:cl)//'each character in decimal.  When you have'
	write(6,1001)crlf(:cl)//'entered all characters, just enter <return>.'
	dummy1=0
	do i=1,4
 8560	    write(6,1013)crlf(:cl)//'Character',i
	    dummy=3
	    dummyl=.false.
	    call get_number(string,dummy,dummyl)
	    if(dummy.eq.0) then
		go to 8570
		end if
	    read(string,1011)number
	    if(number.le.127) then
		dummy_20(i:i)=char(number)
		dummy1=dummy1+1
	    else
		write(6,1001)crlf(:cl)//
	1	    'Characters must be less than 128 decimal'
		go to 8560
	    end if
	    end do
 8570	if(dummy1.eq.0) then
	    write(6,1001)crlf(:cl)//'Clear-screen not changed'
	else
	    ur.user_ff=dummy_20(1:dummy1)//char(255)
	    ffeed=ur.user_ff
	    fl=dummy1
	end if
	go to 8050

 8900	continue	!Re-write his userlog record
	write(6,1001)crlf(:cl)//'Changes are now complete.'
	read(1,key=ur.user_key,iostat=ios,err=90500)zur
	rewrite(1,iostat=ios,err=90500)ur
	go to 0200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
9000	continue		!Private message to operator
	area='private'
	ii=20
	call enter_message(ii,*0200,0)
c	send message via VAX MAIL
	open(unit=4,file='mail.tmp',status='new',
	1   carriagecontrol='list')
	write(4,1001)'From: '//mail_name//' ('//ur.phone_number(1:3)//
	1   ') '//ur.phone_number(4:6)//'-'//ur.phone_number(7:10)//
	2   ' '//ur.city//','//ur.state
	write(4,1001)'On: '//logon_date//' at '//logon_time
	do jj=1,ii
	    call str$trim(message(jj),message(jj),dummy)
	    write(4,1001)message(jj)(1:dummy)
	    end do
	close(unit=4)
	istat = lib$spawn('mail/subject="comment" mail.tmp sysop')
	write(6,1001)crlf(:cl)//'Message sent.  Thank you.'
	go to 0200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
10000	continue		!Retrieve message
	call time(ctime)
	call add_elapsed_time(*91000)
	write(cminutes,1002)current_units/60
	area='retrieve'
	read(2,rec=1,iostat=ios,err=90600)last_header, last_data,
	1   first_mnum,last_mnum
	unlock (unit=2)
	call comint(first_mnum,clms)
	call comint(last_mnum,lms)
10001	write(6,1001)crlf(:cl)//'The message file contains messages'//
	1   clms//' through'//lms
	if((.not.ur.xpert).or.reprint) then
	    reprint=.false.
	    call out(crlf(:cl)//'    Retrieve Menu',*10010)
	    call out('(F)lagged        (I)ndividual',*10010)
	    call out('(M)arked         (N)ew',*10010)
	    call out('(R)ange          (T)hread',*10010)
	    call out('(E)xit to main menu',*10010)
10010	    write(6,1001)crlf(:cl)//ctime//'-'//cminutes//' Command? '
	else
	    write(6,1001)crlf(:cl)//ctime//'-'//
	1	cminutes//' Command (E,F,I,M,N,R,T,?)? '
	end if
	dummy=1
	call get_uplow_string(cdummy,dummy)
	istat=str$upcase(cdummy,cdummy)
	if(cdummy.eq.'E') then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	if(cdummy.eq.'F') go to 10100
	if(cdummy.eq.'I') go to 10200
	if(cdummy.eq.'M') go to 10300
	if(cdummy.eq.'N') go to 10400
	if(cdummy.eq.'R') go to 10500
	if(cdummy.eq.'T') go to 10600
	if(cdummy.eq.'?') then
	    reprint=.true.
	    go to 10001
	    end if

	write(6,1001)crlf(:cl)//bell//
	1   'That is not a valid retrieve command.'
	go to 10001

10100	continue		!Read flagged
	area='flagged'
	if(num_flags.eq.0) then
	    write(6,1001)crlf(:cl)//'No messages flagged.'
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	nostop=.false.
	irec=1
	do ii=1,num_flags
	    call read_mail(flags(ii),irec,status,nostop,next_mess)
	    if(status.eq.1) go to 90500
	    if(status.eq.2) go to 90600
	    if(status.eq.3) go to 10000
	    end do
	go to 10000

10200	continue		!Read individual
	area='individual'
	nostop=.false.
	write(6,1001)crlf(:cl)//'Message number? [exit]'
	dummy=7
	dummyl=.false.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0) go to 10000
	read(string,1011)mess
	if(mess.lt.first_mnum.or.mess.gt.last_mnum) then
	    write(6,1001)crlf(:cl)//'Message number out of range.'
	    go to 10200
	    end if
	irec=1
	call read_mail(mess,irec,status,nostop,next_mess)
	if(status.eq.1) go to 90500
	if(status.eq.2) go to 90600
	go to 10200

	    
10300	continue		!Read marked
	area='marked'
	nostop=.false.
	do krec=2,last_header
10310	read(2,rec=krec,iostat=ios,err=90600) mh
	    unlock(unit=2)
	    if (.not.mh.mail_read.and..not.mh.mail_deleted
	1	.and.mh.mail_person) then
		istat=str$upcase(qmail_to,mh.mail_to)
		if(mail_name.eq.qmail_to) then
		    irec=krec-1
		    call read_mail(mh.mail_messnum,irec,status,
	1		nostop,next_mess)
		    if(status.eq.1) go to 90500
		    if(status.eq.2) go to 90600
		    if(status.eq.3) go to 10000	!User flagged exit
		    end if
		end if
	    end do
	go to 10000

10400	continue		!Read new
	area='new'
	nostop=.false.
	fmess=ur.last_message+1		!the next message
	lmess=last_mnum
	go to 10505


10500	continue		!Read range
	area='range'
	nostop=.false.
	write(6,1001)crlf(:cl)//'Starting message number? [exit]'
	dummy=7
	dummyl=.true.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0) then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	if(string.eq.'*') then
	    fmess=ur.last_message+1
	else
	    read(string,1011)fmess
	end if
	write(6,1001)crlf(:cl)//'Ending message number? [exit]'
	dummy=7
	dummyl=.true.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0) then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	if(string.eq.'*') then
	    lmess=last_mnum
	else
	    read(string,1011)lmess
	end if
10505	if(fmess.lt.first_mnum) fmess=first_mnum
	if(lmess.gt.last_mnum) lmess=last_mnum
	irec=1
	mess=fmess
	do while(mess.le.lmess)
	    call read_mail(mess,irec,status,nostop,next_mess)
	    if(status.eq.1) go to 90500
	    if(status.eq.2) go to 90600
	    if(status.eq.3) go to 10000
	    if((status.eq.0).and.(next_mess.ne.0)) then
		mess=next_mess
	    else
		mess=mess+1
	    end if
	    end do
	go to 10000


10600	continue		!Read thread
	area='thread'
	write(6,1001)crlf(:cl)//'Starting message number? [exit]'
	dummy=7
	dummyl=.true.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0) then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	if(string.eq.'*') then
	    fmess=ur.last_message+1
	else
	    read(string,1011)fmess
	end if
	found=.false.
c	get within 20 of the first message
	i=2
	do while (.not.found)
10610	read(2,rec=i,iostat=ios,err=90600) mh
	    unlock(unit=2)
	    if(mh.mail_messnum.ge.fmess) found=.true.
	    i=i+20
	    end do
	i=i-40
	if(i.lt.2) i=2

	stack_ptr=0
	do l=i,last_header
	    have_read(l)=.false.
	    end do

	do l=i,last_header
	read(2,rec=l,iostat=ios,err=90600) mh
	    unlock(unit=2)

	    if(mh.mail_messnum.lt.fmess) go to 10680
	    if(have_read(l)) go to 10680

	    mnum=mh.mail_messnum
	    if(mh.mail_messnum.gt.last_mnum) go to 10000
10650	    irec=l
	    call read_mail(mnum,irec,status,nostop,next_mess)
	    if(status.eq.1) go to 90500
	    if(status.eq.2) go to 90600
	    if(status.eq.3) go to 10000

	    if(status.eq.0) go to 10680
	read(2,rec=irec,iostat=ios,err=90600) mh
	    unlock(unit=2)

	    have_read(irec)=.true.
	    do ll=10,1,-1
		if(mh.mail_replys(ll).ne.0) then
		    if(stack_ptr.ge.200) go to 10680
		    stack_ptr=stack_ptr+1
		    stack(stack_ptr)=mh.mail_replys(ll)
		    end if
		end do
10680	    if(stack_ptr.gt.0) then
		mnum=stack(stack_ptr)
		stack_ptr=stack_ptr-1
		go to 10650
		end if
	    end do
	go to 10000


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
11000	continue		!Scan messages
	area='scan'
	num_flags=0
	read(2,rec=1,iostat=ios,err=90600)last_header, last_data,
	1   first_mnum,last_mnum
	unlock (unit=2)
	call comint(first_mnum,clms)
	call comint(last_mnum,lms)
	write(6,1001)crlf(:cl)//'The message file contains messages'//
	1   clms//' through'//lms
	fmess=first_mnum
	lmess=last_mnum
	call out(crlf(:cl)//'        Scan menu',*11010)
	call out(crlf(:cl)//'(L)ist range of messages',*11010)
	call out('(F) search on From: field',*11010)
	call out('(T) search on To: field',*11010)
	call out('(S) search on Subject: field',*11010)

11010	write(6,1001)crlf(:cl)//'Command [exit]?'
	dummy=1
	call get_upcase_string(cdummy,dummy)
	if(dummy.eq.0)  then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	if (cdummy.eq.'L') go to 11100
	if (cdummy.eq.'F') go to 11200
	if (cdummy.eq.'T') go to 11300
	if (cdummy.eq.'S') go to 11400
	write(6,1001)crlf(:cl)//bell//'That was not a valid scan command'
	go to 11000

11100	continue		!List messages
	write(6,1001)crlf(:cl)//'Starting message number? [exit]'
	dummy=7
	dummyl=.true.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0)  then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	if(string.eq.'*') then
	    fmess=ur.last_message+1
	else
	    read(string,1011)fmess
	end if
	write(6,1001)crlf(:cl)//'Ending message number? [exit]'
	dummy=7
	dummyl=.true.
	call get_number(string,dummy,dummyl)
	if(dummy.eq.0)  then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	if(string.eq.'*') then
	    lmess=last_mnum
	else
	    read(string,1011)lmess
	end if
	if(fmess.lt.first_mnum) fmess=first_mnum
	if(lmess.gt.last_mnum) lmess=last_mnum
	irec=1
	do krec=2,last_header
	    read(2,rec=krec,iostat=ios,err=90600) mh
	    unlock(unit=2)
	    if(mh.mail_messnum.lt.fmess) goto 11190
	    if(mh.mail_messnum.gt.lmess) goto 11900
	    if(mh.mail_deleted) goto 11190
	    istat=str$upcase(zmail_to,mh.mail_to)
	    if(mh.mail_private.and..not.((zmail_to.eq.mail_name).or.
	1	(mh.mail_from.eq.mail_name).or.sysop)) go to 11190
	    if(mh.mail_read) then
		istat=str$trim(mh.mail_to,mh.mail_to,length)
		mh.mail_to=mh.mail_to(1:length)//' (X)'
		end if
	    write(6,1022)crlf(:cl),mh.mail_section,mh.mail_messnum,
	1	mh.mail_from,mh.mail_to,mh.mail_subject
11120	    write(6,1001)crlf(:cl)//'Command? (C,E,F,K,?) [C]'
	    dummy=1
	    call get_uplow_string(cdummy,dummy)
	    istat=str$upcase(cdummy,cdummy)
	    if(dummy.eq.0.or.cdummy.eq.'C') go to 11190
	    if(cdummy.eq.'?') then
		write(6,1001)crlf(:cl)//'(C)ontinue'
		write(6,1001)crlf(:cl)//'(E)xit'
		write(6,1001)crlf(:cl)//'(F)lag'
		write(6,1001)crlf(:cl)//'(K)ill'
		go to 11120
		end if
	    if(cdummy.eq.'F') then
		num_flags=num_flags+1
		flags(num_flags)=mh.mail_messnum
		if(num_flags.eq.100) then
		    write(6,1001)crlf(:cl)//'You have set 100 flags.'
		    write(6,1001)crlf(:cl)//'You must read these before'
		    write(6,1001)crlf(:cl)//'flagging any more.'
		    unlock(unit=2)
		    unlock(unit=3)
		    go to 0200
		    end if
		go to 11190
		end if
	    if(cdummy.eq.'E') go to 11900
	    if(cdummy.eq.'K') then
		call kill_mess(krec,status)
		if(status.eq.1) go to 90500
		if(status.eq.2) go to 90600
		go to 11190
		end if
	    write(6,1001)crlf(:cl)//'That was not a valid command.'
	    go to 11120

11190	    end do
	go to 11900


11200	continue		!Scan on from field
	field=1
	go to 11500

11300	continue		!Scan on to field
	field=2
	go to 11500

11400	continue		!Scan on subject field
	field=3
	go to 11500

11500	continue
	dummy=-30
	write(6,1001)crlf(:cl)//'Search string? [exit]'
	call get_uplow_string(string,dummy)
	istat=str$upcase(string,string)
	if(dummy.eq.0)  then
	    unlock(unit=2)
	    unlock(unit=3)
	    go to 0200
	    end if
	istat=str$trim(string,string,length)
	irec=1
	do krec=2,last_header
	    read(2,rec=krec,iostat=ios,err=90600) mh
	    unlock(unit=2)
	    if(mh.mail_messnum.gt.last_mnum) go to 11900
	    if(mh.mail_deleted) goto 11590
	    istat=str$upcase(zmail_to,mh.mail_to)
	    if(mh.mail_private.and..not.((zmail_to.eq.mail_name).or.
	1	(mh.mail_from.eq.mail_name).or.sysop)) go to 11590
	    if(field.eq.1) then
		count=str$position(mh.mail_from,string(1:length))
	    else if(field.eq.2) then
		count=str$position(zmail_to,string(1:length))
	    else if(field.eq.3) then
		istat=str$upcase(zmail_subject,mh.mail_subject)
		count=str$position(zmail_subject,string(1:length))
	    end if
	    if (count.eq.0) go to 11590

	    if(mh.mail_read) then
		istat=str$trim(mh.mail_to,mh.mail_to,dummy)
		mh.mail_to=mh.mail_to(1:dummy)//' (X)'
		end if
	    write(6,1022)crlf(:cl),mh.mail_section,mh.mail_messnum,
	1	mh.mail_from,mh.mail_to,mh.mail_subject
11520	    write(6,1001)crlf(:cl)//'Command? (C,E,F,K,?) [C]'
	    dummy=1
	    call get_uplow_string(cdummy,dummy)
	    istat=str$upcase(cdummy,cdummy)
	    if(dummy.eq.0.or.cdummy.eq.'C') go to 11590
	    if(cdummy.eq.'?') then
		write(6,1001)crlf(:cl)//'(C)ontinue'
		write(6,1001)crlf(:cl)//'(E)xit'
		write(6,1001)crlf(:cl)//'(F)lag'
		write(6,1001)crlf(:cl)//'(K)ill'
		go to 11520
		end if
	    if(cdummy.eq.'F') then
		num_flags=num_flags+1
		flags(num_flags)=mh.mail_messnum
		if(num_flags.eq.100) then
		    write(6,1001)crlf(:cl)//'You have set 100 flags.'
		    write(6,1001)crlf(:cl)//'You must read these before'
		    write(6,1001)crlf(:cl)//'flagging any more.'
		    unlock(unit=2)
		    unlock(unit=3)
		    go to 0200
		    end if
		go to 11590
		end if
	    if(cdummy.eq.'E') go to 11900
	    if(cdummy.eq.'K') then
		call kill_mess(krec,status)
		if(status.eq.1) go to 90500
		if(status.eq.2) go to 90600
		go to 11590
		end if
	    write(6,1001)crlf(:cl)//'That was not a valid command.'
	    go to 11520

11590	    end do

11900	if(num_flags.eq.0) then
	    write(6,1001)crlf(:cl)//'No messages flagged.'
	else
	    write(6,1023)crlf(:cl),num_flags
	end if
	unlock(unit=2)
	unlock(unit=3)
	go to 0200


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
12000	continue		!User log
	area='user log'
	write(6,1001)crlf(:cl)//'Please enter starting surname'
	write(6,1001)crlf(:cl)//'or <cr> to start at beginning.'
	write(6,1001)crlf(:cl)//'?'
	dummy=20
	call get_uplow_string(zur.user_key,dummy)
	call str$upcase(zur.user_key,zur.user_key)
	if(dummy.eq.0) zur.user_key=zeros
	write(6,1001)crlf(:cl)//'Enter cutoff date for login (users'//
	1   ' before this date will not be'//crlf(:cl)//
	2   'displayed.)  The date must be dd-mmm-yyyy (e.g. 19-APR-1986)'//
	3   crlf(:cl)//'Or enter <cr> for a complete list.'//
	4   crlf(:cl)//'?'
	dummy=11
	call get_uplow_string(line,dummy)
	if(dummy.eq.0) line='01-JUL-1985'
	istat=str$upcase(line,line)
	istat = sys$bintim(line(:11)//' 00:00:00',long_ago)
	istat = sys$asctim(,line,long_ago,)
	dummy=0

	call out(crlf(:cl)//'Ctrl-s to pause/Ctrl-q to resume,'//
	1   ' Ctrl-o to skip',*12100)
	call out('Users logged on since: '//line(:11)//crlf(:cl),*12100)
	call out('User name                    Last logon'//
	1    '         # Times  Calling from',*12100)
	call out('---------------------------------------'//
	1    '------------------------------',*12100)
12050	read(1,keygt=zur.user_key,iostat=ios,err=12150)zur
	call ctrl_o_check(*12100,*12100)
	if(.not.zur.approved) go to 12050
	istat = sys$bintim(zur.last_log_date(1:7)//'19'//
	1   zur.last_log_date(8:9)//' '//zur.last_log_time,his_login)
	if(hl(2).lt.la(2)) go to 12050
	istat=str$trim(zlast_name,zur.user_key(1:20),dummy1)
	istat=str$trim(zfirst_name,zur.user_key(21:40),dummy2)
	istat=str$trim(zur.city,zur.city,dummy4)
	dummy3=27-dummy1-dummy2
	if(dummy3.lt.1) dummy3=1
	write(6,1008)crlf(:cl),zfirst_name(1:dummy2)//' '//
	1    zlast_name(1:dummy1)//space(1:dummy3),
	2    zur.last_log_date,zur.last_log_time,zur.num_logon,
	3    zur.city(1:dummy4)//','//zur.state
	dummy=dummy+1
	go to 12050

12100	write(6,1001)crlf(:cl)//crlf(:cl)//'Aborted'
	go to 12151

12150	write(6,1001)crlf(:cl)//crlf(:cl)//'End of user log'
12151	write(6,1005)crlf(:cl),dummy
	unlock(unit=1)
	go to 0200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
13000	continue		!Welcome message
	area='welcome reprint'
	call type_file('bbs$:welcome.txt')
	go to 0200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
14000	continue		!Xpert user mode
	area='expert'
	read(1,key=ur.user_key,iostat=ios,err=90500)ur
	ur.xpert = .not. ur.xpert
	rewrite(1,err=90500)ur
	go to 0200

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
15000	continue		!CB simulator
	if(arklug) then
	    call arklug_cb(*90500)
	else
	    call ubbs_cb(*90500)
	end if
	go to 0200


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	exception conditions are handled after 90000
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
90000	write(6,1001)crlf(:cl)//
	1   'I''m sorry.  That is not a valid password.'
	write(6,1001)crlf(:cl)//'If you are having trouble, the sysop may be'
	write(6,1001)crlf(:cl)//'reached between 8:00 and 17:00 central time'
	write(6,1001)crlf(:cl)//'at (501) 569-3220' 	
	go to 99990
c
90500	continue
	write(6,1001)crlf(:cl)//'Internal error -- unable to update userlog.'
	write(6,1001)crlf(:cl)//'The sysop will be notified.'
	error='unable to update user log'
	go to 90900
c
90600	write(6,1001)crlf(:cl)//'Internal error -- unable'//
	1   ' to access message file.'
	write(6,1001)crlf(:cl)//'The sysop will be notified.'
	error='unable to access message.hed file'
	go to 90900
c
90700	write(6,1001)crlf(:cl)//'Internal error -- unable'//
	1   ' to access message file.'
	write(6,1001)crlf(:cl)//'The sysop will be notified.'
	error='unable to access message.dat file'
	go to 90900
c
90900	continue
c
c	error message to sysop here
c
	close(unit=1)
	close(unit=2)
	close(unit=3)
	open(unit=4,file='mail.tmp',status='new',
	1    carriagecontrol='list')
	write(4,1001)'The BBS has a fatal error'
	write(4,1001)'The user is '//mail_name
	write(4,1001)'The area is '//area
	write(4,1001)'The error is '//error
	write(4,1007)'The iostatus is ',ios
	close(unit=4)
	istat=lib$spawn('mail/subject="abort" mail.tmp sysop')
	go to 99990

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	User has exceeded his allowable time
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

91000	write(6,1001)crlf(:cl)//
	1   'You have been logged on for 1 hour today.'
	write(6,1001)crlf(:cl)//'You must wait until tomorrow.'
	read(1,key=ur.user_key,iostat=ios,err=90500)ur
	ur.seconds_today = current_units
	rewrite(1,iostat=ios,err=90500)ur
	go to 99990

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	exit from the BBS the right way
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
99990	continue
	close(unit=1)
	close(unit=2)
	close(unit=3)
	interactive=.false.		!reset before exiting
	call setup_local(interactive)
	write(6,1001)crlf(:cl)
	call exit
	end
