	program sysop
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Sysop.for
c	This program combines all of the UBBS utility functions.
c	Dale Miller - UALR
c	07-Jul-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

	implicit none
	character choice*2
	integer str$upcase,istat

 0010	write(6,*)'Choice?'
	read(5,1001,end=900)choice
 1001	format(a)
	istat=str$upcase(choice,choice)
	if(choice.eq.' '.or.choice.eq.'E') then
	    call exit
	else if(choice.eq.'A') then
	    call aging
	else if (choice.eq.'C') then
	    call compress
	else if (choice.eq.'F') then
	    call fixcounts
	else if (choice.eq.'UL') then
	    call ulist
	else if (choice.eq.'UB') then
	    call upbull
	else if (choice.eq.'UF') then
	    call update_files
	else if (choice.eq.'US') then
	    call update_sysops
	else if (choice.eq.'UU') then
	    call upuser
	else if (choice.eq.'CF') then
	    call check_files
	else
	    write(6,*)'Programs available'
	    write(6,*)'A  - Aging'
	    write(6,*)'C  - Compress message file'
	    write(6,*)'CF - Check files'
	    write(6,*)'F  - Fixcounts'
	    write(6,*)'UB - Update bulletin number & date'
	    write(6,*)'UF - Update files'
	    write(6,*)'UL - User list'
	    write(6,*)'US - Update sysops on file sections'
	    write(6,*)'UU - Update userlog'
	    go to 10
	end if
900	continue
	end

	subroutine aging
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - AGING.FOR
c	This program allows deletion of users before a specified date.
c	Dale Miller - UALR
c	05-Mar-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	include 'sys$library:foriosdef/nolist'

	integer app,nap
	character*30 time,my_date
	character*1 da,dn
	real*8 long_ago,never
	real*8 his_login
	integer istat,len,sys$asctim,sys$bintim,str$upcase
	integer compquad
	external uopen

	character zz*1,appstr*3

 0009	print*,'Enter date of interest (dd-mmm-yyyy)'
	read(5,1001)my_date
 1001	format(a)
	my_date=my_date(:11)//' 00:00:00.00'
	istat = sys$bintim(my_date,long_ago)
	istat = sys$asctim(len,time,long_ago,)
	print*,'Date is:'//time(:len)//'.  Is this correct?'
	read(5,1001)da
	istat=str$upcase(da,da)
	if(da.ne.'Y') go to 9

	print*,'Delete authorized before this date?'
	read(5,1001)da
	istat=str$upcase(da,da)
	print*,'Delete non-authorized users before this date?'
	read(5,1001)dn
	istat=str$upcase(dn,dn)

	app=0
	nap=0
	open(unit=1,file='userlog.dat',status='old',	
	1   organization='indexed',access='keyed',useropen=uopen,
	2   recordtype='fixed',recl=50,shared)

	ur.user_key='0000000000000000000000000000000000000000'
	
 0010	read(1,keygt=ur.user_key,iostat=ios) ur
	if(ios.eq.for$ios_sperecloc) go to 10
	if(ios.ne.0) go to 5000
	istat = sys$bintim(ur.last_log_date(1:7)//'19'//
	1   ur.last_log_date(8:9)//' '//ur.last_log_time//'.00',
	2   his_login)

	istat=compquad(long_ago,his_login)
	if(istat.eq.-1) go to 10
 0011	if(ur.approved) then
	    appstr='*A*'
	    app=app+1
	    if(da.eq.'Y') delete(unit=1)
	else
	    nap=nap+1
	    appstr=' na'
	    if(dn.eq.'Y') delete(unit=1)
	endif
	write(6,1009)ur.user_key,ur.last_log_date,appstr
	go to 10
 1009	format(1x,a,1x,a,1x,a)

 5000	close(unit=1)
	print*,'app=',app
	print*,'nap=',nap
	print*,'finished'
	return

90500	print*,'an error has occurred'
	return
	end

	subroutine compress
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Compress.for
c	This program compresses the message data base eliminating deleted and
c	expired messages as well as private messages which have already been
c	read.
c	Dale Miller - UALR
c	14-Nov-1985
c
c	Rev. 3.5  24-Jun-1986
c	Rev. 4.3  26-Jul-1986
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	character*114 dummy
	integer*4 zero/0/,one/1/
	character line*80,yesno*1,dummy_20*20,cdate*9
	include 'sys$library:foriosdef/nolist'
	external uopen
	integer zlast_header,zlast_data,zfirst_mnum,zlast_mnum
	integer current_header,current_data,old_last_header
	integer k,l,temp_mail_first,istat,old_message_number
	integer sys$bintim,compquad
	logical busy
	real*8 right_now

	record /mail_header_structure/ mh

	call date(cdate)
	dummy_20=cdate(1:7)//'19'//cdate(8:9)//' 00:00:00'
	istat=sys$bintim(dummy_20,right_now)

	open(unit=2,file='message.hed',status='old',
	1    organization='relative',access='direct',shared,
	2    recordtype='fixed',recl=48,useropen=uopen)

	open(unit=3,file='message.dat',status='old',
	1    organization='relative',access='direct',shared,
	2    recordtype='fixed',recl=20,useropen=uopen)

 2100	read(unit=2,rec=1,iostat=ios)last_header,
	1   last_data,first_mnum,last_mnum,busy
	if(ios.ne.0) then
	    print*,'Error on header record ios=',ios
	    stop
	    end if
	busy=.true.
	write(unit=2,rec=1)last_header,last_data,
	1   first_mnum,last_mnum,busy

	print*,'Last header=  ',last_header
	print*,'Last data=    ',last_data
	print*,'First message=',first_mnum
	print*,'Last message= ',last_mnum
	zlast_header=last_header
	zlast_data=last_data
	zfirst_mnum=first_mnum
	zlast_mnum=last_mnum

	current_header=1
	current_data=0
	old_message_number=1

	do k=2,max(last_header,1000)
c
c	loop through all message headers to see if they are deleted, etc.
c
 	    read(2,rec=k)mh

	    if(mh.mail_messnum.eq.99999999) go to 30
	    if(mh.mail_messnum.le.old_message_number) then
	        print*,mh.mail_messnum,' ignored, less than current'
	        go to 30
	        end if

	    old_message_number = mh.mail_messnum
	    if(mh.mail_deleted) then		!deleted, ignore it
		print*,mh.mail_messnum,' deleted'
		go to 30
		end if

	    if(mh.mail_private.and.mh.mail_read) then !private and read, ignore it
		print*,mh.mail_messnum,' read private'
		go to 30
		end if

	    if(.not.mh.mail_person) then
		istat=compquad(mh.mail_expire,right_now)
		if(istat.eq.-1) then
		    print*,mh.mail_messnum,' expired'
		    go to 30
		    end if
		end if

	    temp_mail_first=current_data+1		!The data start here
	    if(temp_mail_first.ne.mh.mail_first) then
		do l=mh.mail_first,mh.mail_last
		    current_data=current_data+1		!Get next record
 		    read(3,rec=l)line			!Read it...
		    write(3,rec=current_data)line	!...and place it
		    end do
	        mh.mail_first=temp_mail_first		!Get new locations
	        mh.mail_last=current_data
	    else
		current_data=mh.mail_last
	    end if

	    current_header=current_header+1		!Compute new header location
	    write(2,rec=current_header)mh
 0030	    continue
	    end do

c	Set up to rewrite the header record
 2400	continue
	read(2,rec=2)mh

	old_last_header=last_header
	last_header=current_header
	last_data=current_data
	first_mnum=mh.mail_messnum

c	blank out the rest of the message headers
	print*,'Blanking out headers now.'
	mh.mail_to=' '
	mh.mail_from=' '
	mh.mail_subject=' '
	mh.mail_date=' '
	mh.mail_time=' '
	mh.mail_section=0
	mh.mail_first=0
	mh.mail_last=0
	mh.mail_messnum=99999999
	mh.mail_private=.false.
	mh.mail_read=.false.
	mh.mail_deleted=.true.
	mh.mail_person=.false.
	mh.mail_reply_to=0
	do k=1,10
	    mh.mail_replys(k)=0
	    end do
	do k=last_header+1,max(old_last_header,1000)
	    write(2,rec=k)mh
	    end do

c	now, rewrite the header record.

 2500	busy=.false.
	write(unit=2,rec=1,iostat=ios)last_header,last_data,
	1   first_mnum,last_mnum,busy
	if(ios.eq.for$ios_sperecloc) then
	    print*,'Header is locked!'
	    go to 2500
	    endif
	if(ios.ne.0) then
	    print*,'Error on header record ios=',ios
	    stop
	    end if
	write(6,1002)
	write(6,1003)'Last header=',zlast_header,last_header,
	1   (zlast_header-last_header)
	write(6,1003)'Last data=',zlast_data,last_data,
	1   (zlast_data-last_data)
	write(6,1003)'First message=',zfirst_mnum,first_mnum
	write(6,1003)'Last message= ',zlast_mnum,last_mnum
 1002	format(17x,'original     new   diff.',/,
	1      17x,'------------------------')
 1003	format(1x,a16,3i8)
c	That's all, folks
	close(unit=2)
	close(unit=3)
	return
 9060	print*,'could not open file'
	return
90000	continue
	print*,'Error reading record, ios=',ios
	close(unit=2)
	close(unit=3)
	stop
	end

	subroutine fixcounts
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Fixcounts.for
c	This program erases the unread message counts for all users and then
c	fixes them up form the message header file.
c	Dale Miller - UALR
c	02-May-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	character*114 dummy
	character first_name*20,last_name*20
	include 'sys$library:foriosdef/nolist'
	external uopen
	integer k,l,spc,str$upcase


	record /mail_header_structure/ mh

	open(unit=1,file='userlog.dat',status='old',	
	1   organization='indexed',access='keyed',
	2   recordtype='fixed',recl=50,shared,useropen=uopen)

	open(unit=2,file='message.hed',status='old',
	1    organization='relative',access='direct',shared,
	2    recordtype='fixed',recl=48,useropen=uopen)

	ur.user_key='0000000000000000000000000000000000000000'
	
 0010	read(1,keygt=ur.user_key,iostat=ios) ur
	if(ios.ne.0) go to 2100
	ur.num_unread = 0
	rewrite(unit=1) ur
	go to 10

 2100	continue
	print*,'Zeroed all users'

	read(unit=2,rec=1,iostat=ios)last_header,
	1   last_data,first_mnum,last_mnum
	if(ios.ne.0) then
	    print*,'Error on header record ios=',ios
	    stop
	    end if

	print*,last_header,' messages to process.'
	do k = 1, last_header
 	    read(2,rec=k)mh

	    if(mh.mail_person.and.(.not.mh.mail_read).and.
	1	(.not.mh.mail_deleted)) then

		l=str$upcase(mh.mail_to,mh.mail_to)
		spc=index(mh.mail_to,' ')
		first_name=mh.mail_to(1:spc-1)	
		l=spc+1
		do while(mh.mail_to(l:l).eq.' ')
		    l=l+1
		    end do
		last_name=mh.mail_to(l:30)
		ur.user_key=last_name//first_name
		if(l.ne.spc+1) then
		    mh.mail_to = first_name(1:spc-1)//' '//last_name
		    write(2,rec=k)mh
		    print*,'Fixed name on:'//mh.mail_to
		    end if
		print*,'updating '//mh.mail_to
		read(1,key=ur.user_key,iostat=ios)ur
		if(ios.ne.0) then
		    mh.mail_deleted=.true.
		    write(2,rec=k)mh
		    print*,'Deleted #',mh.mail_messnum,' to '//mh.mail_to
		else
		    ur.num_unread=ur.num_unread+1
		    rewrite(unit=1) ur
	            end if
		end if
	    end do

	close(unit=1)
	close(unit=2)
	return
 9060	print*,'could not open file'
	stop
90000	continue
	print*,'Error reading record, ios=',ios
	close(unit=1)
	close(unit=2)
	stop
	end

	subroutine ulist
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Ulist.for
c	This program produces a brief list of all users in the userlog.
c	Dale Miller - UALR
c	05-Mar-1986
c
c	Rev. 17-Jun-1986
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	include 'sys$library:foriosdef/nolist'

	character zz*1,appstr*3,ayn*1,uyn*1
	integer str$upcase
	integer app,nap
	external uopen

 1001	format(a)

	open(unit=1,file='userlog.dat',status='old',	
	1   organization='indexed',access='keyed',useropen=uopen,
	2   recordtype='fixed',recl=50,shared)

	ur.user_key='0000000000000000000000000000000000000000'
	app=0
	nap=0

	print*,'List approved users? [N]'
	read(5,1001)ayn
	print*,'List unapproved users? [N]'
	read(5,1001)uyn
	ios=str$upcase(ayn,ayn)
	ios=str$upcase(uyn,uyn)
	
 0010	read(1,keygt=ur.user_key,iostat=ios) ur
	if(ios.eq.for$ios_sperecloc) go to 10
	if(ios.ne.0) go to 5000
	if(ur.approved) then
	    appstr='*A*'
	    app=app+1
	else
	    appstr=' NA'
	    nap=nap+1
	endif
	if(ur.approved.and.(ayn.ne.'Y')) go to 10
	if((.not.ur.approved).and.(uyn.ne.'Y')) go to 10
	write(6,1000)ur.user_key(1:15),ur.user_key(21:35),
	1   ur.city,ur.state,appstr,ur.phone_number(1:3),
	2   ur.phone_number(4:6),ur.phone_number(7:10)
 1000	format(1x,a,a,1x,a,1x,a,1x,a,1x,'(',a,') ',a,'-',a)
	go to 10

 5000	close(unit=1)
	print*,' '
	print*,'Approved users =',app
	print*,'  Non-approved =',nap
	print*,'         Total =',nap+app
	return

90500	print*,'an error has occurred'
	stop
	end

	subroutine upbull
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Upbull.for
c	This program updates the last bulletin number and date.
c	Dale Miller - UALR
c	14-Nov-1985
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

	implicit none
	include 'sys$library:foriosdef/nolist'
	integer high_bull,ios,user_number
	character bull_date*11,user_key*40
	character zeros*40/'0000000000000000000000000000000000000000'/

	open(unit=1,file='userlog.dat',status='old',
	1    organization='indexed',access='keyed',err=90500,
	2    recordtype='fixed',recl=50,shared)

 1000	read(1,key=zeros,iostat=ios)user_key,user_number,high_bull,
	1    bull_date
	if(ios.eq.for$ios_sperecloc) go to 1000
	if(ios.ne.0) go to 90500
	print*,'highest=',high_bull,' date=',bull_date
	print*,'highest='
	read*,high_bull
	print*,'date='
	read(5,10)bull_date
	rewrite(1,err=90500)user_key,user_number,high_bull,
	1    bull_date
	close (unit=2)
	return
 0010	format(a)
90500	print*,'aborted'
	stop
	end

	subroutine update_files
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Update_files.for
c	This program allows interactive updating of the FILES.IDX files.
c	Dale Miller - UALR
c	Rev. 4.1  07-Jul-1986
c	Rev. 4.5  26-Sep-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	include '($rmsdef)'
	character filename*100,types*1
	integer d1,d2,dummy,istat
	integer find_file,find_next,fc

	close(unit=6)
	open(unit=6,recl=1024,status='unknown',carriagecontrol='none')
	crlf=char(13)//char(10)//'  '
	cl=2
	call fake_vaxnet
	call setup_local(.true.)
	sysop2=.true.
	write(6,1001)crlf(:cl)//
	1   'View (A)ll or (U)napproved files? [U]'
	dummy=1
	call get_upcase_string(types,dummy)
	filename='dua10:[bbs_files]*.dir;*'
	dummy=24
	istat=find_file(filename,dummy,fc)
	do while (istat.ne.rms$_nmf)
	    d1=index(filename,']')+1
	    d2=index(filename,'.')-1
	    write(6,1001)crlf(:cl)//crlf(:cl)//
	1	'Beginning '//filename(d1:d2)
	    call update_index(filename(d1:d2),types)
	    istat=find_next(filename,dummy,fc)
	    end do
	call setup_local(.false.)
 1001	format(a)
	return
	end

	subroutine update_index(darea,types)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will allow updating of the download directory
c	Dale Miller - UALR
c
c
c	Rev. 4.0  30-Jun-1986
c	Rev. 4.2  20-Jul-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	character*(*) darea
	character cdate*11,filtyp*6,startoff*18,types*1,cdummy*1,temptext*400
	integer length,dummy
	real*8 long_ago

	integer istat,keyln,len,j
	integer compquad
	integer sys$asctim,sys$bintim,str$upcase,str$trim,lib$spawn
	integer sys$gettim
	external uopen

	record/file_description/ fd

c	Open the indexed file for updating.
	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='$Header'
	read(4,key=fd.file_name,err=100)fd
c	Now, see if he is allowed to do this.
	if(sysop2) go to 0090
	if((mail_name.eq.fd.upload_name) .or.
	1   (mail_name.eq.fd.upload_text(1:30)).or.
	2   (mail_name.eq.fd.upload_text(31:60))) go to 0090
	return			! He didn't pass.  return him with no message.
 0090	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)
	if(types.eq.'X') then
	    write(6,1001)crlf(:cl)//
	1	'View (A)ll or (U)napproved files? [U]'
	    dummy=1
	    call get_upcase_string(types,dummy)
	end if

	if(types.eq.'A') then
	    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'
	    write(6,1001)crlf(:cl)//
	1	'Enter the starting file name or <cr> for beginning :'
	    dummy=18
	    startoff=' '
	    call get_filnam_string(startoff,dummy)
	else
	    cdate='01-JUL-1985'
	    startoff=' '
	end if

	istat=str$upcase(cdate,cdate)
	istat = sys$bintim(cdate(:11)//' 00:00:00.00',long_ago)
	istat = sys$asctim(,cdate,long_ago,)

	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)

	call ctrl_o_check(*10,*10)

 0100	fd.file_name=startoff
	fd.upload_text=' '
	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'.or.fd.file_type.eq.'B').and.types.ne.'A')
	1	go to 110
	    istat=compquad(fd.upload_date,long_ago)
	    if(istat.eq.-1) go to 110
	    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)
 0105	    continue
	    if(fd.file_type.eq.'A') then
		filtyp='Ascii '
	    else if(fd.file_type.eq.'B') then
		filtyp='Binary'
	    else if(fd.file_type.eq.'U') then
		filtyp='Uascii'
	    else if(fd.file_type.eq.'V') then
		filtyp='Ubinary'
	    else
		filtyp='??????'
	    end if
	    write(6,1002)crlf(:cl)//fd.file_name,cdate(:11),
	1	fd.file_size,filtyp,fd.times_down,crlf(:cl)//crlf(:cl),
	2	fd.keywords(:keyln),fd.upload_name//crlf(:cl)

	    temptext=fd.upload_text
	    istat=index(temptext,char(cr))
	    do while(istat.ne.0)
		write(6,1001)crlf(:cl)//temptext(:istat-1)
		call ctrl_o_check(*10,*10)
		temptext=temptext(istat+1:)
		istat=index(temptext,char(cr))
		end do
	    write(6,1001)crlf(:cl)//'Command?'
	    dummy=1
	    call get_uplow_string(cdummy,dummy)
	    istat=str$upcase(cdummy,cdummy)
	    if(cdummy.eq.'A') then
		if(fd.file_type.eq.'U') fd.file_type='A'
		if(fd.file_type.eq.'V') fd.file_type='B'
		go to 105
	    else if(cdummy.eq.'W') then
		rewrite(4)fd
		write(6,1001)crlf(:cl)//'Record written'
		startoff=fd.file_name
		fd.file_name='$Header'
		read(4,key=fd.file_name,err=100)fd
		istat = sys$gettim(fd.upload_date)
		rewrite(4)fd
		fd.file_name=startoff
	    else if(cdummy.eq.'D') then
		delete(unit=4)
		print*,'Deleted'
	    else if(cdummy.eq.'E') then
		open(unit=11,file='edit.tmp',status='new',
	1	    carriagecontrol='list')
		write(11,1001)fd.keywords
		temptext=fd.upload_text
		istat=index(temptext,char(cr))
		do while(istat.ne.0)
		    write(11,1001)temptext(:istat-1)
		    call ctrl_o_check(*10,*10)
		    temptext=temptext(istat+1:)
		    istat=index(temptext,char(cr))
		    end do
		close(unit=11)
		call setup_local(.false.)
		istat=lib$spawn('zilch edit.tmp')
		call setup_local(.true.)
		open(unit=11,file='edit.tmp',status='old',
	1	    carriagecontrol='none')
		read(11,1001)fd.keywords
		j=1
		read(11,1003,iostat=istat)len,temptext(j:len)
		do while(.not.istat)
		    j=j+len+1
		    temptext(j-1:j-1)=char(cr)
		    read(11,1003,iostat=istat)len,temptext(j:len+j-1)
		    end do
		close(11)
		fd.upload_text=temptext
		go to 105
	    else if(cdummy.eq.'X'.or.dummy.eq.-1) then
		go to 10
	    else if(cdummy.eq.'?') then
		write(6,1001)crlf(:cl)//'A - Approve'
		write(6,1001)crlf(:cl)//'D - Delete'
		write(6,1001)crlf(:cl)//'E - Edit'
		write(6,1001)crlf(:cl)//'W - Write'
		write(6,1001)crlf(:cl)//'X - Exit'
	    end if
	    
 0110	    fd.upload_text=' '
	    read(4,keygt=fd.file_name,iostat=ios)fd
	    end do
 0010	close(unit=4)
	return
 1001	format(a)
 1002	format(a18,5x,a11,2x,'Size:'i6,2x,a6,4x,'Accesses:',i5,a,5x,
	1   'Keywords: ',a,' By:',a)
 1003	format(q,a)
	end

	subroutine upuser
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Upuser.for
c	This program allows interactive updating of the user log.
c	As an option, it will check for cities not currently recognized in
c	the user log.  This is for people who like for the user list 
c	to look pretty.
c	Dale Miller - UALR
c	Rev. 4.1  07-Jul-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	include 'sys$library:foriosdef'
	integer istat,i,str$upcase

	character  zz*1,appstr*12
	character*20 cities(100)
	character*40 zeros/'0000000000000000000000000000000000000000'/
	logical do_city
	integer num_cities
	external uopen


	open(unit=1,file='userlog.dat',status='old',	
	1   organization='indexed',access='keyed',useropen=uopen,
	2   recordtype='fixed',recl=50,shared)


	print*,'(C)ities or (A)ll? [A]'
	read(5,1001)zz
	istat=str$upcase(zz,zz)
	if(zz.ne.'C') then
	    do_city=.false.
	else
	    do_city=.true.
	    open(unit=2,file='cities.dat',status='old')
	    ios=0
	    num_cities=0
	    do while(ios.eq.0)
		num_cities=num_cities+1
		read(2,1001,iostat=ios)cities(num_cities)
		end do
	    num_cities=num_cities-1
	    close(unit=2)
	end if
	
 0009	ur.user_key=char(0)
	print*,'Enter key:'
	read(5,1001)ur.user_key
	istat=str$upcase(ur.user_key,ur.user_key)
	
 0010	read(1,keygt=ur.user_key,iostat=ios)ur
	if(ios.eq.for$ios_sperecloc) go to 10
	if(ios.ne.0) go to 5000
	if(ur.user_key.eq.zeros) go to 10
	if(do_city) then
	    do i=1,num_cities
		if(ur.city.eq.cities(i)) go to 10
		end do
	    end if

 0011	if(ur.approved) then
	    appstr='* Approved *'
	else
	    appstr='Not Approved'
	endif

	write(6,1000)ur.user_key,ur.city,ur.state,ur.phone_number(1:3),
	1   ur.phone_number(4:6),ur.phone_number(7:10),ur.computer,
	2   ur.last_log_date,ur.last_log_time,ur.num_logon,ur.password,
	3   appstr,ur.decus_number,ur.company_name

 1000	format(1x,a,1x,a,','a,1x,'(',a,')',a,'-',a,/,
	1   1x,a,1x,a,1x,a,i6,1x,a,/,1x,a,1x,i6.6,1x,a)
	read(5,1001,end=5000)zz
	istat=str$upcase(zz,zz)

 1001	format(a)
 1002	format(i6)
	
	if(zz.eq.'A') then
	    ur.approved=.not.ur.approved
	    go to 11
	    end if
	if(zz.eq.'B') go to 9
	if(zz.eq.'C') then
	    print*,'City?'
	    read(5,1001)ur.city
	    if(ur.city.eq.'l'.or.ur.city.eq.'L') ur.city='Little Rock'
	    if(ur.city.eq.'n'.or.ur.city.eq.'N') ur.city='North Little Rock'
	    if(ur.city.eq.'s'.or.ur.city.eq.'S') ur.city='Sherwood'
	    if(ur.city.eq.'j'.or.ur.city.eq.'J') ur.city='Jacksonville'
	    go to 11
	    end if
	if(zz.eq.'CN') then
	    print*,'Company name?'
	    read(5,1001)ur.company_name
	    go to 11
	    end if
	if(zz.eq.'CO') then
	    print*,'Computer?'
	    read(5,1001)ur.computer
	    go to 11
	    end if
	if(zz.eq.'D') then
	    delete(unit=1)
	    go to 10
	    end if
	if(zz.eq.'DN') then
	    print*,'Decus number?'
	    read(5,1002)ur.decus_number
	    go to 11
	    end if
	if(zz.eq.'E') go to 5000
	if(zz.eq.'P') then
	    print*,'Password?'
	    read(5,1001)ur.password
	    istat=str$upcase(ur.password,ur.password)
	    go to 11
	    end if
	if(zz.eq.'PN') then
	    print*,'Phone number?'
	    read(5,1001)ur.phone_number
	    go to 11
	    end if
	if(zz.eq.'S') then
	    print*,'State?'
	    read(5,1001)ur.state
	    istat=str$upcase(ur.state,ur.state)
	    go to 11
	    end if
	if(zz.eq.'W') then
	    rewrite(1,err=90500)ur
	    go to 10
	    end if
	if(zz.eq.'Z') then
	    print*,'Time was',ur.seconds_today
	    ur.seconds_today=0
	    go to 11
	    end if
	if(do_city) then
	    num_cities=num_cities+1
	    cities(num_cities)=ur.city
	    end if
	go to 10
	


 5000	close(unit=1)
	if(do_city) then
	    open(unit=2,file='cities.dat',status='new',carriagecontrol='list')
	    do i=1,num_cities
	    write(2,1001)cities(i)
	    end do
	    close(unit=2)
	    end if
	print*,'finished'
	return

90500	print*,'an error has occurred'
	stop
	end

	subroutine check_files
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Check_files.for
c	This program removes all files in the files sections that do not
c	appear in the FILEX.IDX files.
c
c	Dale Miller - UALR
c	          08-Jul-1986
c	Rev. 4.3  07-Aug-1986
c	Rev. 4.5  26-Sep-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	include '($rmsdef)'
	character filnam1*100,filnam2*100,darea*3,tempfile*50
	integer d1,d2,dummy,istat,fc1,fc2
	integer find_file,find_next,lib$delete_file,lib$find_file
	integer str$trim

	external uopen

	record/file_description/ fd

	filnam1='dua10:[bbs_files]*.dir;*'
	dummy=24
	fc1=0
	tempfile=filnam1
	istat=rms$_nmf
	istat=lib$find_file(tempfile,filnam1,fc1)
	do while (istat.ne.rms$_nmf)
	    d1=index(filnam1,']')+1
	    d2=index(filnam1,'.')-1
	    darea=filnam1(d1:d2)
	    write(6,1001)'Beginning '//darea
c
c Get the index file.
c
	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)

	filnam2='bbs$files:['//darea//'.*]*.*;*'
	istat=find_file(filnam2,dummy,fc2)
	do while(istat.ne.rms$_nmf)
	    d1=index(filnam2,']')+1
	    d1=index(filnam2(d1:),']')+d1
	    d2=index(filnam2,';')-1
	    fd.file_name=filnam2(d1:d2)
	    if(filnam2(d2:d2).eq.'.') fd.file_name=filnam2(d1:d2-1)
	    read(4,key=fd.file_name,iostat=ios)fd
	    if((ios.ne.0).and.(fd.file_name.ne.'*.*')) then
		istat=lib$delete_file(filnam2)
		print*,'File '//fd.file_name//' deleted.'
		end if
	    istat=find_next(filnam2,dummy,fc2)
	    end do
	    istat=lib$find_file(tempfile,filnam1,fc1)
	    end do
 1001	format(1x,a)
	stop
	end

	subroutine update_sysops
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Update_sysops.for
c	This program allows interactive updating of the FILES.IDX files
c	Dale Miller - UALR
c	Rev. 4.2  20-Jul-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	include '($rmsdef)'
	character filename*50
	integer d1,d2,dummy,istat
	integer find_file,find_next,fc

	filename='dua10:[bbs_files]*.dir;*'
	dummy=24
	istat=find_file(filename,dummy,fc)
	do while (istat.ne.rms$_nmf)
	    d1=index(filename,']')+1
	    d2=index(filename,'.')-1
	    print*,'Area='//filename(d1:d2)
	    call make_cosysop(filename(d1:d2))
	    istat=find_next(filename,dummy,fc)
	    end do
 1001	format(a)
	return
	end

	subroutine make_cosysop(darea)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS subroutines
c	This routine will allow updating of the SYSOPs for download sections.
c	Dale Miller - UALR
c
c
c	Rev. 4.2  20-Jul-1986
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	character*(*) darea
	logical done
	integer length
	integer istat
	integer str$upcase
	external uopen

	record/file_description/ fd

c	Open the indexed file for updating.
	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='$Header'
	read(4,key=fd.file_name)fd
	done=.false.
	do while(.not.done)
	    done=.true.
	    print*,'Sysop1? ['//fd.upload_name//']'
	    read(5,1003)length,mail_name
	    if(length.gt.0) then
		istat=str$upcase(mail_name,mail_name)
		fd.upload_name=mail_name
		done=.false.
		end if
	    print*,'Sysop2? ['//fd.upload_text(1:30)//']'
	    read(5,1003)length,mail_name
	    if(length.gt.0) then
		istat=str$upcase(mail_name,mail_name)
		fd.upload_text(1:30)=mail_name
		done=.false.
		end if
	    print*,'Sysop3? ['//fd.upload_text(31:60)//']'
	    read(5,1003)length,mail_name
	    if(length.gt.0) then
		istat=str$upcase(mail_name,mail_name)
		fd.upload_text(31:60)=mail_name
		done=.false.
		end if
	    end do
	rewrite(unit=4)fd
	close(unit=4)
	return
 1003	format(q,a)
	end
