-+-+-+-+-+-+-+-+ START OF PART 4 -+-+-+-+-+-+-+-+
X`09    go to 10
X`09end if
X900`09continue
X`09end
X`0C
X`09subroutine aging
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - AGING.FOR
Xc`09This program allows deletion of users before a specified date.
Xc`09Dale Miller - UALR
Xc`0905-Mar-1986
Xc`09Rev. 4.5  - 03-Oct-1986
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include 'sys$library:foriosdef/nolist'
X
X`09integer app,nap
X`09character*30 time,my_date
X`09character*1 da,dn
X`09real*8 long_ago,never
X`09real*8 his_login
X`09integer istat,len,sys$asctim,sys$bintim,str$upcase
X`09integer compquad
X`09external uopen
X
X`09character zz*1,appstr*3
X
X 0009`09print*,'Enter date of interest (dd-mmm-yyyy)'
X`09read(5,1001)my_date
X`09istat=str$upcase(my_date,my_date)
X 1001`09format(a)
X`09my_date=my_date(:11)//' 00:00:00.00'
X`09istat = sys$bintim(my_date,long_ago)
X`09istat = sys$asctim(len,time,long_ago,)
X`09print*,'Date is:'//time(:len)//'.  Is this correct?'
X`09read(5,1001)da
X`09istat=str$upcase(da,da)
X`09if(da.ne.'Y') go to 9
X
X`09print*,'Delete authorized before this date?'
X`09read(5,1001)da
X`09istat=str$upcase(da,da)
X`09print*,'Delete non-authorized users before this date?'
X`09read(5,1001)dn
X`09istat=str$upcase(dn,dn)
X
X`09app=0
X`09nap=0
X`09open(unit=1,file='ubbs_data:userlog.dat',status='old',`09
X`091   organization='indexed',access='keyed',useropen=uopen,
X`092   recordtype='fixed',recl=50,shared)
X
X`09ur.user_key='0000000000000000000000000000000000000000'
X`09
X 0010`09read(1,keygt=ur.user_key,iostat=ios) ur
X`09if(ios.eq.for$ios_sperecloc) go to 10
X`09if(ios.ne.0) go to 5000
X`09istat = sys$bintim(ur.last_log_date(1:7)//'19'//
X`091   ur.last_log_date(8:9)//' '//ur.last_log_time//'.00',
X`092   his_login)
X
X`09istat=compquad(long_ago,his_login)
X`09if(istat.eq.-1) go to 10
X 0011`09if(ur.approved) then
X`09    appstr='*A*'
X`09    app=app+1
X`09    if(da.eq.'Y') delete(unit=1)
X`09else
X`09    nap=nap+1
X`09    appstr=' na'
X`09    if(dn.eq.'Y') delete(unit=1)
X`09endif
X`09write(6,1009)ur.user_key,ur.last_log_date,appstr
X`09go to 10
X 1009`09format(1x,a,1x,a,1x,a)
X
X 5000`09close(unit=1)
X`09print*,'app=',app
X`09print*,'nap=',nap
X`09print*,'finished'
X`09return
X
X90500`09print*,'an error has occurred'
X`09return
X`09end
X`0C
X`09subroutine compress(public)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Compress.for
Xc`09This program compresses the message data base eliminating deleted and
Xc`09expired messages as well as private messages which have already been
Xc`09read.
Xc`09Dale Miller - UALR
Xc`0914-Nov-1985
Xc
Xc`09Rev. 3.5  24-Jun-1986
Xc`09Rev. 4.3  26-Jul-1986
Xc`09Rev. 4.10 11-Feb-1987
Xc`09Rev. 7.2  29-Dec-1988
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*114 dummy
X`09integer*4 zero/0/,one/1/
X`09character line*80,yesno*1,dummy_20*20,cdate*9
X`09include 'sys$library:foriosdef/nolist'
X`09external uopen
X`09integer zlast_header,zlast_data,zfirst_mnum,zlast_mnum
X`09integer current_header,current_data,old_last_header
X`09integer k,l,temp_mail_first,istat,old_message_number,len
X`09integer sys$bintim, compquad, str$upcase, sys$asctim
X`09logical busy,public
X`09real*8 right_now,delete_before, this_message
X
X`09record /mail_header_structure/ mh
X
X 1001`09format(a)
X
X`09call date(cdate)
X`09dummy_20=cdate(1:7)//'19'//cdate(8:9)//' 00:00:00'
X`09istat=sys$bintim(dummy_20,right_now)
X
X`09if (public) then
X 0009`09    print*,'Enter date of earliest public message (dd-mmm-yyyy)'
X`09    read(5,1001)dummy_20
X`09    istat = str$upcase(dummy_20,dummy_20)
X`09    dummy_20 = dummy_20(:11)//' 00:00:00.00'
X`09    istat = sys$bintim(dummy_20, delete_before)
X`09    istat = sys$asctim(len,dummy_20,delete_before,)
X`09    print*,'Date is:'//dummy_20(:len)//'.  Is this correct?'
X`09    read(5,1001)yesno
X`09    istat=str$upcase(yesno,yesno)
X`09    if(yesno.ne.'Y') go to 9
X`09else
X            istat = sys$bintim('17-NOV-1858 00:00:00.00', delete_before)
X`09end if
X
X`09open(unit=2,file='ubbs_data:message.hed',status='old',
X`091    organization='relative',access='direct',shared,
X`092    recordtype='fixed',recl=48,useropen=uopen)
X
X`09open(unit=3,file='ubbs_data:message.dat',status='old',
X`091    organization='relative',access='direct',shared,
X`092    recordtype='fixed',recl=20,useropen=uopen)
X
X 2100`09read(unit=2,rec=1,iostat=ios)last_header,
X`091   last_data,first_mnum,last_mnum,busy
X`09if(ios.ne.0) then
X`09    print*,'Error on header record ios=',ios
X`09    stop
X`09    end if
X`09busy=.true.
X`09write(unit=2,rec=1)last_header,last_data,
X`091   first_mnum,last_mnum,busy
X
X`09print*,'Last header=  ',last_header
X`09print*,'Last data=    ',last_data
X`09print*,'First message=',first_mnum
X`09print*,'Last message= ',last_mnum
X`09zlast_header=last_header
X`09zlast_data=last_data
X`09zfirst_mnum=first_mnum
X`09zlast_mnum=last_mnum
X
X`09current_header=1
X`09current_data=0
X`09old_message_number=1
X
X`09do k=2,max(last_header,1000)
Xc
Xc`09loop through all message headers to see if they are deleted, etc.
Xc
X `09    read(2,rec=k)mh
X
X`09    if(mh.mail_messnum.eq.99999999) go to 30
X`09    if(mh.mail_messnum.le.old_message_number) then
X`09        print*,mh.mail_messnum,' ignored, less than current'
X`09        go to 30
X`09        end if
X
X`09    old_message_number = mh.mail_messnum
X`09    if(mh.mail_deleted) then`09`09!deleted, ignore it
X`09`09print*,mh.mail_messnum,' deleted'
X`09`09go to 30
X`09`09end if
X
X`09    if(mh.mail_private.and.mh.mail_read) then !private and read, ignore i
Vt
X`09`09print*,mh.mail_messnum,' read private'
X`09`09go to 30
X`09`09end if
X
X`09    if(mh.mail_read.and.public) then !public and read, ignore it
X`09`09istat = sys$bintim(mh.mail_date(1:7)//'19'//
X`091`09    mh.mail_date(8:9)//' '//mh.mail_time,
X`092`09    this_message)
X`09`09istat = compquad(this_message, delete_before)
X`09`09if(istat.eq.-1) then
X`09`09    print*,mh.mail_messnum,' read public'
X`09`09    go to 30
X`09`09    end if
X`09`09end if
X
X`09    if(.not.mh.mail_person) then
X`09`09istat=compquad(mh.mail_expire,right_now)
X`09`09if(istat.eq.-1) then
X`09`09    print*,mh.mail_messnum,' expired'
X`09`09    go to 30
X`09`09    end if
X`09`09end if
X
X`09    temp_mail_first=current_data+1`09`09!The data start here
X`09    if(temp_mail_first.ne.mh.mail_first) then
X`09`09do l=mh.mail_first,mh.mail_last
X`09`09    current_data=current_data+1`09`09!Get next record
X `09`09    read(3,rec=l)line`09`09`09!Read it...
X`09`09    write(3,rec=current_data)line`09!...and place it
X`09`09    end do
X`09        mh.mail_first=temp_mail_first`09`09!Get new locations
X`09        mh.mail_last=current_data
X`09    else
X`09`09current_data=mh.mail_last
X`09    end if
X
X`09    current_header=current_header+1`09`09!Compute new header location
X`09    write(2,rec=current_header)mh
X 0030`09    continue
X`09    end do
X
Xc`09Set up to rewrite the header record
X 2400`09continue
X`09read(2,rec=2)mh
X
X`09old_last_header=last_header
X`09last_header=current_header
X`09last_data=current_data
X`09first_mnum=mh.mail_messnum
X
Xc`09blank out the rest of the message headers
X`09print*,'Blanking out headers now.'
X`09mh.mail_to=' '
X`09mh.mail_from=' '
X`09mh.mail_subject=' '
X`09mh.mail_date=' '
X`09mh.mail_time=' '
X`09mh.mail_section=0
X`09mh.mail_first=0
X`09mh.mail_last=0
X`09mh.mail_messnum=99999999
X`09mh.mail_private=.false.
X`09mh.mail_read=.false.
X`09mh.mail_deleted=.true.
X`09mh.mail_person=.false.
X`09mh.mail_reply_to=0
X`09do k=1,10
X`09    mh.mail_replys(k)=0
X`09    end do
X`09do k=last_header+1,max(old_last_header,1000)
X`09    write(2,rec=k)mh
X`09    end do
X
Xc`09now, rewrite the header record.
X
X 2500`09busy=.false.
X`09write(unit=2,rec=1,iostat=ios)last_header,last_data,
X`091   first_mnum,last_mnum,busy
X`09if(ios.eq.for$ios_sperecloc) then
X`09    print*,'Header is locked!'
X`09    go to 2500
X`09    endif
X`09if(ios.ne.0) then
X`09    print*,'Error on header record ios=',ios
X`09    stop
X`09    end if
X`09write(6,1002)
X`09write(6,1003)'Last header=',zlast_header,last_header,
X`091   (zlast_header-last_header)
X`09write(6,1003)'Last data=',zlast_data,last_data,
X`091   (zlast_data-last_data)
X`09write(6,1003)'First message=',zfirst_mnum,first_mnum
X`09write(6,1003)'Last message= ',zlast_mnum,last_mnum
X 1002`09format(17x,'original     new   diff.',/,
X`091      17x,'------------------------')
X 1003`09format(1x,a16,3i8)
Xc`09That's all, folks
X`09close(unit=2)
X`09close(unit=3)
X`09return
X 9060`09print*,'could not open file'
X`09return
X90000`09continue
X`09print*,'Error reading record, ios=',ios
X`09close(unit=2)
X`09close(unit=3)
X`09stop
X`09end
X`0C
X`09subroutine fixcounts
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Fixcounts.for
Xc`09This program erases the unread message counts for all users and then
Xc`09fixes them up form the message header file.
Xc`09Dale Miller - UALR
Xc`0902-May-1986
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*114 dummy
X`09character first_name*20,last_name*20
X`09include 'sys$library:foriosdef/nolist'
X`09external uopen
X`09integer k,l,spc,str$upcase
X
X
X`09record /mail_header_structure/ mh
X
X`09open(unit=1,file='ubbs_data:userlog.dat',status='old',`09
X`091   organization='indexed',access='keyed',
X`092   recordtype='fixed',recl=50,shared,useropen=uopen)
X
X`09open(unit=2,file='ubbs_data:message.hed',status='old',
X`091    organization='relative',access='direct',shared,
X`092    recordtype='fixed',recl=48,useropen=uopen)
X
X`09ur.user_key='0000000000000000000000000000000000000000'
X`09
X 0010`09read(1,keygt=ur.user_key,iostat=ios) ur
X`09if(ios.ne.0) go to 2100
X`09ur.num_unread = 0
X`09rewrite(unit=1) ur
X`09go to 10
X
X 2100`09continue
X`09print*,'Zeroed all users'
X
X`09read(unit=2,rec=1,iostat=ios)last_header,
X`091   last_data,first_mnum,last_mnum
X`09if(ios.ne.0) then
X`09    print*,'Error on header record ios=',ios
X`09    stop
X`09    end if
X
X`09print*,last_header,' messages to process.'
X`09do k = 1, last_header
X `09    read(2,rec=k)mh
X
X`09    if(mh.mail_person.and.(.not.mh.mail_read).and.
X`091`09(.not.mh.mail_deleted)) then
X
X`09`09l=str$upcase(mh.mail_to,mh.mail_to)
X`09`09spc=index(mh.mail_to,' ')
X`09`09first_name=mh.mail_to(1:spc-1)`09
X`09`09l=spc+1
X`09`09do while(mh.mail_to(l:l).eq.' ')
X`09`09    l=l+1
X`09`09    end do
X`09`09last_name=mh.mail_to(l:30)
X`09`09ur.user_key=last_name//first_name
X`09`09if(l.ne.spc+1) then
X`09`09    mh.mail_to = first_name(1:spc-1)//' '//last_name
X`09`09    write(2,rec=k)mh
X`09`09    print*,'Fixed name on:'//mh.mail_to
X`09`09    end if
X`09`09print*,'updating '//mh.mail_to
X`09`09read(1,key=ur.user_key,iostat=ios)ur
X`09`09if(ios.ne.0) then
X`09`09    mh.mail_deleted=.true.
X`09`09    write(2,rec=k)mh
X`09`09    print*,'Deleted #',mh.mail_messnum,' to '//mh.mail_to
X`09`09else
X`09`09    ur.num_unread=ur.num_unread+1
X`09`09    rewrite(unit=1) ur
X`09            end if
X`09`09end if
X`09    end do
X
X`09close(unit=1)
X`09close(unit=2)
X`09return
X 9060`09print*,'could not open file'
X`09stop
X90000`09continue
X`09print*,'Error reading record, ios=',ios
X`09close(unit=1)
X`09close(unit=2)
X`09stop
X`09end
X`0C
X`09subroutine ulist
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Ulist.for
Xc`09This program produces a brief list of all users in the userlog.
Xc`09Dale Miller - UALR
Xc`0905-Mar-1986
Xc
Xc`09Rev. 17-Jun-1986
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include 'sys$library:foriosdef/nolist'
X
X`09character zz*1,appstr*3,ayn*1,uyn*1
X`09integer str$upcase
X`09integer app,nap
X`09external uopen
X
X 1001`09format(a)
X
X`09open(unit=1,file='ubbs_data:userlog.dat',status='old',`09
X`091   organization='indexed',access='keyed',useropen=uopen,
X`092   recordtype='fixed',recl=50,shared)
X
X`09ur.user_key='0000000000000000000000000000000000000000'
X`09app=0
X`09nap=0
X
X`09print*,'List approved users? `5BN`5D'
X`09read(5,1001)ayn
X`09print*,'List unapproved users? `5BN`5D'
X`09read(5,1001)uyn
X`09ios=str$upcase(ayn,ayn)
X`09ios=str$upcase(uyn,uyn)
X`09
X 0010`09read(1,keygt=ur.user_key,iostat=ios) ur
X`09if(ios.eq.for$ios_sperecloc) go to 10
X`09if(ios.ne.0) go to 5000
X`09if(ur.approved) then
X`09    appstr='*A*'
X`09    app=app+1
X`09else
X`09    appstr=' NA'
X`09    nap=nap+1
X`09endif
X`09if(ur.approved.and.(ayn.ne.'Y')) go to 10
X`09if((.not.ur.approved).and.(uyn.ne.'Y')) go to 10
X`09write(6,1000)ur.user_key(1:15)//ur.user_key(21:35),
X`091   ur.city,ur.state,appstr,ur.phone_number(1:3),
X`092   ur.phone_number(4:6),ur.phone_number(7:10)
X 1000`09format(1x,a,a,1x,a,1x,a,1x,a,1x,'(',a,') ',a,'-',a)
X`09go to 10
X
X 5000`09close(unit=1)
X`09print*,' '
X`09print*,'Approved users =',app
X`09print*,'  Non-approved =',nap
X`09print*,'         Total =',nap+app
X`09return
X
X90500`09print*,'an error has occurred'
X`09stop
X`09end
X`0C
X`09subroutine upbull
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Upbull.for
Xc`09This program updates the last bulletin number and date.
Xc`09Dale Miller - UALR
Xc`0914-Nov-1985
Xc
Xc`09Rev. 7.3  23-Jan-1989
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X
X`09implicit none
X`09include 'sys$library:foriosdef/nolist'
X`09include '($rmsdef)'
X`09integer high_bull,ios,user_number
X`09character bull_date*11,user_key*40,filename*60
X`09character zeros*40/'0000000000000000000000000000000000000000'/
X`09integer fsize,compquad,fc1,istat
X`09integer lib$find_file
X`09real*8 rev_date,back_date,last_date
X`09common/filesize/fsize,rev_date,back_date
X
X`09external uopen,getsize
X
X
X`09open(unit=1,file='ubbs_data:userlog.dat',status='old',
X`091    organization='indexed',access='keyed',err=90500,
X`092    recordtype='fixed',recl=50,shared,useropen=uopen)
X
X 1002`09format('ubbs_data:bulletin.',i3.3,';*')
X
X 1000`09read(1,key=zeros,iostat=ios)user_key,user_number,high_bull,
X`091    bull_date
X`09if(ios.eq.for$ios_sperecloc) go to 1000
X`09if(ios.ne.0) go to 90500
X`09print*,'highest=',high_bull,' date=',bull_date
X
X`09high_bull = 1
X`09fc1=0
X`09write(filename,1002)high_bull
X`09istat=lib$find_file(filename,filename,fc1)
X`09do while(istat.eq.rms$_normal)
X`09    open(unit=4,file=filename,status='old',readonly,shared,
X`091`09useropen=getsize)
X`09    close(unit=4)
X`09    istat = compquad(last_date,rev_date)
X`09    if(istat.eq.-1) last_date = rev_date
X`09    fc1=0
X`09    high_bull = high_bull + 1
X`09    filename = ' '
X`09    write(filename,1002)high_bull
X`09    istat=lib$find_file(filename,filename,fc1)
X`09    end do
X`09high_bull = high_bull - 1
X
X`09call sys$asctim(,bull_date,last_date,)
X
X`09print*,'highest=',high_bull,' date=',bull_date
X`09rewrite(1,err=90500)user_key,user_number,high_bull,
X`091    bull_date
X`09close (unit=2)
X`09return
X 0010`09format(a)
X90500`09print*,'aborted'
X`09stop
X`09end
X`0C
X`09subroutine update_files
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Update_files.for
Xc`09This program allows interactive updating of the FILES.IDX files.
Xc`09Dale Miller - UALR
Xc`09Rev. 4.1  07-Jul-1986
Xc`09Rev. 4.5  26-Sep-1986
Xc`09Rev. 4.11 05-Mar-1987
Xc`09Rev. 4.12 11-Jun-1987
Xc`09Rev. 6.2  26-Jul-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include '($rmsdef)'
X`09character filename*100,types*1,section*3,do_section*1
X`09integer d1,d2,dummy,istat
X`09integer find_file,find_next,fc,str$upcase
X
X`09close(unit=6)
X`09open(unit=6,recl=1024,status='unknown',carriagecontrol='none')
X`09crlf=char(13)//char(10)//'  '
X`09cl=2
X`09tnext=1
X`09call fake_vaxnet
X`09call setup_local(.true.)
X`09sysop2=.true.
X`09write(6,1001)crlf(:cl)//
X`091   'View (A)ll or (U)napproved files? `5BU`5D'
X`09dummy=1
X`09call get_upcase_string(types,dummy)
X`09write(6,1001)crlf(:cl)//
X`091   '(A)ll or (S)elected sections? `5BA`5D'
X`09dummy=1
X`09call get_upcase_string(do_section,dummy)
X`09if(do_section.ne.'S') then
X`09    filename='ubbs_files:`5B000000`5D*.dir;*'
X`09    call str$trim(filename,filename,dummy)
X`09    istat=find_file(filename,dummy,fc)
X`09    do while (istat.ne.rms$_nmf)
X`09`09d1=1
X`09`09do while(d1.ne.0)
X`09`09    d1=index(filename,'`5D')
X`09`09    filename=filename(d1+1:)
X`09`09    end do
X`09`09d2=index(filename,'.')-1
X`09`09write(6,1001)crlf(:cl)//crlf(:cl)//
X`091`09    'UF - Beginning '//filename(:d2)
X`09`09call update_index(filename(:d2),types)
X`09`09istat=find_next(filename,dummy,fc)
X`09`09end do
X`09else
X`09    section='XXX'
X`09    do while(section.ne.'   ')
X`09`09write(6,1001)crlf(:cl)//
X`091`09    'Which section? `5Bexit`5D'
X`09`09dummy=3
X`09`09call get_uplow_string(section,dummy)
X`09`09istat = str$upcase(section,section)
X`09`09if(dummy.ne.0) then
X`09`09    call update_index(section,types)
X`09`09else
X`09`09    section='   '
X`09`09end if
X`09`09end do
X`09end if
X`09call setup_local(.false.)
X 1001`09format(a)
X`09return
X`09end
X`0C
X`09subroutine update_index(darea,types)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will allow updating of the download directory
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 4.0  30-Jun-1986
Xc`09Rev. 4.2  20-Jul-1986
Xc`09Rev. 4.9  10-Feb-1987
Xc`09Rev. 4.14 14-Jul-1987
Xc`09Rev. 5.3  28-Oct-1987
Xc`09Rev. 6.0  06-Jun-1988
Xc`09Rev. 7.2  02-Jan-1989
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) darea
X`09character cdate*11,cdate2*11,filtyp*6,startoff*18,types*1,cdummy*1
X`09character temptext*400,rename*100,yn*3
X`09integer length,dummy
X`09real*8 long_ago
X
X`09integer istat,keyln,len,j,k
X`09integer compquad
X`09integer sys$asctim,sys$bintim,str$upcase,str$trim
X`09integer sys$gettim,lib$rename_file,lib$delete_file
X`09integer array_edit
X`09external uopen
X
X`09record/file_description/ fd
X
Xc`09Open the indexed file for updating.
X`09open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09fd.file_name='$Header'
X`09read(4,key=fd.file_name,err=100)fd
Xc`09Now, see if he is allowed to do this.
X`09if(sysop2) go to 0090
X`09if((mail_name.eq.fd.upload_name) .or.
X`091   (mail_name.eq.fd.upload_text(1:30)).or.
X`092   (mail_name.eq.fd.upload_text(31:60))) go to 0090
X`09return`09`09`09! He didn't pass.  return him with no message.
X 0090`09istat = sys$asctim(,cdate,fd.upload_date,)
X
X`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09write(6,1001)crlf(:cl)//'Last file added: '//cdate
X`09if(types.eq.'X') then
X`09    write(6,1001)crlf(:cl)//
X`091`09'View (A)ll or (U)napproved files? `5BU`5D'
X`09    dummy=1
X`09    call get_upcase_string(types,dummy)
X`09end if
X
X`09if(types.eq.'A') then
X`09    write(6,1001)crlf(:cl)//'Enter earliest date of files you'//
X`091`09' wish to see.'//crlf(:cl)//
X`092`09'The date must be dd-mmm-yyyy (e.g. 19-APR-1986)'//
X`093`09crlf(:cl)//'Or enter <cr> for a all dates.'//
X`094`09crlf(:cl)//'?'
X`09    dummy=11
X`09    call get_uplow_string(cdate,dummy)
X`09    if(dummy.eq.0) cdate='01-JUL-1985'
X`09    write(6,1001)crlf(:cl)//
X`091`09'Enter the starting file name or <cr> for beginning :'
X`09    dummy=18
X`09    startoff=' '
X`09    call get_filnam_string(startoff,dummy)
X`09else
X`09    cdate='01-JUL-1985'
X`09    startoff=' '
X`09end if
X
X`09istat=str$upcase(cdate,cdate)
X`09istat = sys$bintim(cdate//' 00:00:00.00',long_ago)
X`09istat = sys$asctim(,cdate,long_ago,)
X
X`09if(startoff.eq.' ') startoff='.'
X`09cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09write(6,1001)crlf(:cl)//'    Files since: '//cdate
X`09call ctrl_o_check(*10,*10)
X
X`09call ctrl_o_check(*10,*10)
X
X 0100`09fd.file_name=startoff
X`09fd.upload_text=' '
X`09read(4,keygt=fd.file_name,iostat=ios)fd
X`09do while (ios.eq.0)
X`09    call ctrl_o_check(*10,*10)
X`09    if((fd.file_type.eq.'A'.or.fd.file_type.eq.'B').and.types.ne.'A')
X`091`09go to 110
X`09    istat=compquad(fd.upload_date,long_ago)
X`09    if(istat.eq.-1) go to 110
X`09    istat = sys$asctim(,cdate,fd.upload_date,)
X`09    cdate(5:5)=char(ichar(cdate(5:5))+32)
X`09    cdate(6:6)=char(ichar(cdate(6:6))+32)
X`09    istat = sys$asctim(,cdate2,fd.download_date,)
X`09    cdate2(5:5)=char(ichar(cdate2(5:5))+32)
X`09    cdate2(6:6)=char(ichar(cdate2(6:6))+32)
X`09    if (fd.archived) then
X`09`09yn = 'Yes'
X`09    else
X`09`09yn = 'No'
X`09    end if
X 0105`09    continue
X`09    istat=str$trim(fd.keywords,fd.keywords,keyln)
X`09    if(fd.file_type.eq.'A') then
X`09`09filtyp='Ascii '
X`09    else if(fd.file_type.eq.'B') then
X`09`09filtyp='Binary'
X`09    else if(fd.file_type.eq.'U') then
X`09`09filtyp='Uascii'
X`09    else if(fd.file_type.eq.'V') then
X`09`09filtyp='Ubinary'
X`09    else
X`09`09filtyp='??????'
X`09    end if
X`09    write(6,1002)crlf(:cl)//fd.file_name,cdate,
X`091`09fd.file_size,filtyp,fd.times_down,crlf(:cl),
X`092`09cdate2,yn,crlf(:cl)//crlf(:cl),
X`093`09fd.keywords(:keyln),fd.upload_name//crlf(:cl)
X
X`09    temptext=fd.upload_text
X`09    istat=index(temptext,char(cr))
X`09    do while(istat.ne.0)
X`09`09write(6,1001)crlf(:cl)//temptext(:istat-1)
X`09`09call ctrl_o_check(*10,*10)
X`09`09temptext=temptext(istat+1:)
X`09`09istat=index(temptext,char(cr))
X`09`09end do
X`09    write(6,1001)crlf(:cl)//'Command?'
X`09    dummy=1
X`09    call get_uplow_string(cdummy,dummy)
X`09    istat=str$upcase(cdummy,cdummy)
X`09    if(cdummy.eq.'A') then
X`09`09if(fd.file_type.eq.'U') fd.file_type='A'
X`09`09if(fd.file_type.eq.'V') fd.file_type='B'
X`09`09call sys$gettim(fd.download_date)
X`09`09go to 105
X`09    else if(cdummy.eq.'U') then
X`09`09if(fd.file_type.eq.'A') fd.file_type='U'
X`09`09if(fd.file_type.eq.'B') fd.file_type='V'
X`09`09go to 105
X`09    else if(cdummy.eq.'W') then
X`09`09rewrite(4)fd
X`09`09write(6,1001)crlf(:cl)//'Record written'
X`09`09startoff=fd.file_name
X`09`09fd.file_name='$Header'
X`09`09read(4,key=fd.file_name,err=100)fd
X`09`09istat = sys$gettim(fd.upload_date)
X`09`09rewrite(4)fd
X`09`09fd.file_name=startoff
X`09    else if(cdummy.eq.'D') then
X`09`09delete(unit=4)
X`09`09if((fd.file_type.eq.'A').or.(fd.file_type.eq.'U')) then
X`09`09    filtyp='ASC'
X`09`09else
X`09`09    filtyp='BIN'
X`09`09end if
X`09`09temptext='ubbs_files:`5B'//darea//'.'//filtyp(1:3)//'`5D'//
X`091`09    fd.file_name
X`09`09call str$trim(temptext,temptext,istat)
X`09`09temptext(istat+1:)=';*'
X`09`09istat=lib$delete_file(temptext(1:istat+2))
X`09`09print*,'Deleted'
X`09    else if(cdummy.eq.'E') then
X`09`09message(1)=fd.upload_name
X`09`09message(2)=fd.keywords
X`09`09length=2
X`09`09temptext=fd.upload_text
X`09`09istat=index(temptext,char(cr))
X`09`09do while(istat.ne.0)
X`09`09    length=length+1
X`09`09    message(length)=temptext(:istat-1)
X`09`09    temptext=temptext(istat+1:)
X`09`09    istat=index(temptext,char(cr))
X`09`09    end do
X`09`09call setup_local(.false.)
X`09`09istat=array_edit(message,length,80,20)
X`09`09call setup_local(.true.)
X`09`09fd.upload_name=message(1)
X`09`09fd.keywords=message(2)
X`09`09j=1
X`09`09k=2
X`09`09temptext=' '
X`09`09do while(k.lt.length)
X`09`09    k=k+1
X`09`09    istat=str$trim(message(k),message(k),len)
X`09`09    temptext(j:len+j-1)=message(k)(1:len)
X`09`09    j=j+len+1
X`09`09    temptext(j-1:j-1)=char(cr)
X`09`09    end do
X`09`09fd.upload_text=temptext
X`09`09go to 105
X`09    else if(cdummy.eq.'R') then
X`09`09if((fd.file_type.eq.'A').or.(fd.file_type.eq.'U')) then
X`09`09    filtyp='ASC'
X`09`09else
X`09`09    filtyp='BIN'
X`09`09end if
X`09`09write(6,1001)crlf(:cl)//'Rename to?'
X`09`09length=18
X`09`09call get_filnam_string(rename,length)
X`09`09if(length.eq.0) then
X`09`09    write(6,1001)crlf(:cl)//'Rename aborted.'
X`09`09    go to 105
X`09`09    end if
X`09`09startoff=fd.file_name
X`09`09read(4,key=rename,iostat=istat)fd
X`09`09if(istat.eq.1) then
X`09`09    write(6,1001)crlf(:cl)//'That name is in use'
X`09`09    go to 105
X`09`09    end if
X`09`09if(index(rename(1:length),'.').eq.0) then
X`09`09    length=length+1
X`09`09    rename(length:length)='.'
X`09`09    endif
X`09`09read(4,key=startoff)fd
X`09`09temptext='ubbs_files:`5B'//darea//'.'//filtyp(1:3)//'`5D'
X`09`09istat=str$trim(temptext,temptext,len)
X`09`09rename=temptext(1:len)//rename
X`09`09temptext(len+1:)=fd.file_name
X`09`09istat=lib$rename_file(temptext(1:100),rename)
X`09`09delete(unit=4)
X`09`09if (rename(length+len:length+len).eq.'.') then
X`09`09    fd.file_name=rename(len+1:len+length-1)
X`09`09else
X`09`09    fd.file_name=rename(len+1:)
X`09`09endif
X`09`09write(4,iostat=k)fd
X`09`09if(istat.ne.1.or.k.ne.0) then
X`09`09    write(6,1004)crlf(:cl)//
X`091`09`09'Rename failed - Status ',istat,k
X`09`09    write(6,1001)crlf(:cl)//'From='//temptext(1:100)
X`09`09    write(6,1001)crlf(:cl)//'  To='//rename
X`09`09else
X`09`09    write(6,1001)crlf(:cl)//'Rename successful'
X`09`09end if
X`09`09startoff=temptext(len+1:)
X`09`09fd.file_name='$Header'
X`09`09read(4,key=fd.file_name,err=100)fd
X`09`09istat = sys$gettim(fd.upload_date)
X`09`09rewrite(4)fd
X`09`09fd.file_name=startoff
X`09    else if(cdummy.eq.'M') then
X`09`09if(fd.archived) then
X`09`09    print*,'Cannot move an archived file'
X`09`09    go to 105
X`09`09    end if
X`09`09if((fd.file_type.eq.'A').or.(fd.file_type.eq.'U')) then
X`09`09    filtyp='ASC'
X`09`09else
X`09`09    filtyp='BIN'
X`09`09end if
X`09`09write(6,1001)crlf(:cl)//'Move to? `5Bquit`5D'
X`09`09length=18
X`09`09call get_filnam_string(rename,length)
X`09`09if(length.eq.0) then
X`09`09    write(6,1001)crlf(:cl)//'Move aborted.'
X`09`09    go to 105
X`09`09    end if
X`09`09open(unit=7,`09`09shared,
X`091`09file='ubbs_files:`5B'//rename(1:3)//'`5Dfiles.idx',
X`092`09status='old',`09`09organization='indexed',
X`093`09access='keyed',`09`09form='unformatted',
X`094`09recl=192,`09`09recordtype='variable',
X`095`09key=(1:18:character),`09useropen=uopen,
X`096`09iostat = istat)
X`09`09if(istat.ne.0) then
X`09`09    call lib$signal(%val(istat))
X`09`09    print*,'That is not a valid file section'
X`09`09    go to 105
X`09`09    end if
X`09`09startoff=fd.file_name
X`09`09read(7,key=fd.file_name,iostat=istat)fd
X`09`09if(istat.eq.1) then
X`09`09    write(6,1001)crlf(:cl)//'That name is in use is the '//
X`091`09`09rename(1:3)//' section.'
X`09`09    close(unit=7)
X`09`09    go to 105
X`09`09    end if
X`09`09read(4,key=startoff)fd
X`09`09write(7,iostat=k)fd
X`09`09delete(unit=4)
X
X`09`09temptext='ubbs_files:`5B'//darea//'.'//filtyp(1:3)//'`5D'//
X`091`09    fd.file_name
X`09`09istat=str$trim(temptext,temptext,len)
X`09`09rename=temptext(1:12)//rename(1:3)//temptext(16:)
X`09`09istat=lib$rename_file(temptext(1:len),rename)
X`09`09if(istat.ne.1.or.k.ne.0) then
X`09`09    write(6,1004)crlf(:cl)//
X`091`09`09'Move failed - Status ',istat,k
X`09`09    write(6,1001)crlf(:cl)//'From='//temptext(1:len)
X`09`09    write(6,1001)crlf(:cl)//'  To='//rename(1:len)
X`09`09else
X`09`09    write(6,1001)crlf(:cl)//'Move successful'
X`09`09end if
X`09`09startoff=fd.file_name
X`09`09fd.file_name='$Header'
X`09`09read(7,key=fd.file_name,err=100)fd
X`09`09istat = sys$gettim(fd.upload_date)
X`09`09rewrite(7)fd
X`09`09close(unit=7)
X`09`09fd.file_name=startoff
X`09    else if(cdummy.eq.'X'.or.dummy.eq.-1) then
X`09`09close(unit=4)
X`09`09return
X`09    else if(cdummy.eq.'?') then
X`09`09write(6,1001)crlf(:cl)//'A - Approve'
X`09`09write(6,1001)crlf(:cl)//'D - Delete'
X`09`09write(6,1001)crlf(:cl)//'E - Edit'
X`09`09write(6,1001)crlf(:cl)//'M - Move to another section'
X`09`09write(6,1001)crlf(:cl)//'R - Rename'
X`09`09write(6,1001)crlf(:cl)//'U - Unapprove'
X`09`09write(6,1001)crlf(:cl)//'W - Write'
X`09`09write(6,1001)crlf(:cl)//'X - Exit'
X`09    end if
X`09   `20
X 0110`09    fd.upload_text=' '
X`09    read(4,keygt=fd.file_name,iostat=ios)fd
X`09    end do
X 0010`09close(unit=4)
X`09return
X 1001`09format(a)
X 1002`09format(a18,5x,a11,2x,'Size:'i6,2x,a6,4x,'Accesses:',i5,a,9x,
X`091   'Downloaded: ',a,'  Archived:  ',a,a,
X`092   'Keywords: ',a,' By:',a)
X 1003`09format(q,a)
X 1004`09format(a,z8,',',z8)
X`09end
X`0C
X`09subroutine upuser
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Upuser.for
Xc`09This program allows interactive updating of the user log.
Xc`09As an option, it will check for cities not currently recognized in
Xc`09the user log.  This is for people who like for the user list`20
Xc`09to look pretty.
Xc`09Dale Miller - UALR
Xc`09Rev. 4.1  07-Jul-1986
Xc`09Rev. 4.5  03-Oct-1986
Xc`09Rev. 4.10 25-Feb-1987
Xc`09Rev. 4.11 26-May-1987
Xc`09Rev. 5.1  03-Oct-1987
Xc`09Rev. 5.4a 04-Jan-1988
Xc`09Rev. 5.6a 28-Mar-1988
Xc`09Rev. 5.6b 29-May-1988
Xc`09Rev. 7.3a 31-Jan-1989
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include 'sys$library:foriosdef/nolist'
X`09integer istat,i,str$upcase
X
X`09parameter city_max = 500
X`09parameter nick_max = 20
X`09character  zz*2,appstr*12,fc*1
X`09character*20 cities(city_max),nick_city(nick_max),nick_name(nick_max)
X`09character*20 tcity1,tcity2
X`09integer*2 city_count(city_max)
X`09character*40 zeros/'0000000000000000000000000000000000000000'/
X`09character*40 spaces/' '/
X`09logical do_city,space
X`09integer num_cities,num_nick
X`09external uopen
X
X
X 1001`09format(a)
X 1002`09format(i6)
X 1003`09format(a20,i5)
X 1004`09format(a20,1x,a20)
X`09open(unit=1,file='ubbs_data:userlog.dat',status='old',`09
X`091   organization='indexed',access='keyed',useropen=uopen,
X`092   recordtype='fixed',recl=50,shared)
X
X
X`09print*,'(C)ities or (A)ll? `5BA`5D'
X`09read(5,1001)zz
X`09istat=str$upcase(zz,zz)
X`09if(zz.ne.'C') then
X`09    do_city=.false.
X`09else
X`09    fc=' '
X`09    do_city=.true.
X`09    open(unit=2,file='ubbs_data:cities.dat',status='old')
X`09    ios=0
X`09    num_cities=0
X`09    do while(ios.eq.0)
X`09`09num_cities=num_cities+1
X`09`09if(num_cities.gt.city_max) then
X`09`09    print*,'UPUSER aborted - insufficient table space.'
X`09`09    print*,'Increase size of CITY_MAX and rerun.'
X`09`09    stop
X                    end if
X`09`09read(2,1003,iostat=ios)cities(num_cities)
X`09`09city_count(num_cities)=0
X`09`09end do
X`09    num_cities=num_cities-1
X`09    print*,num_cities,' cities read'
X`09    close(unit=2)
X
X`09    open(unit=2,file='ubbs_data:city_nick.dat',status='old',
X`091`09iostat=ios)
X`09    num_nick=0
X`09    do while(ios.eq.0)
X`09`09num_nick=num_nick+1
X`09`09if(num_nick.gt.nick_max) then
X`09`09    print*,'UPUSER aborted - insufficient table space.'
X`09`09    print*,'Increase size of NICK_MAX and rerun.'
X`09`09    stop
X                    end if
X`09`09read(2,1004,iostat=ios)nick_name(num_nick), nick_city(num_nick)
X`09`09end do
X`09    num_nick=num_nick-1
X`09    close(unit=2)
X`09    print*,num_nick,' nicknames read'
X`09end if
X`09
X 0009`09ur.user_key=char(0)
X`09print*,'Enter key:'
X`09read(5,1001)ur.user_key
X`09istat=str$upcase(ur.user_key,ur.user_key)
X`09i=index(ur.user_key,',')
X`09if(i.ne.0) then
X`09    ur.user_key=ur.user_key(1:i-1)//spaces(1:21-i)//
X`091`09ur.user_key(i+1:)
X`09    endif
X 0012`09read(1,keyge=ur.user_key,iostat=ios)ur
X`09if(ios.eq.for$ios_sperecloc) go to 12
X`09if(ios.ne.0) go to 5000
X`09if(ur.user_key.eq.zeros) go to 10
X`09go to 13
X`09
X 0010`09read(1,keygt=ur.user_key,iostat=ios)ur
X`09if(ios.eq.for$ios_sperecloc) go to 10
X`09if(ios.ne.0) go to 5000
X`09if(ur.user_key.eq.zeros) go to 10
X`09if(do_city.and.(ur.user_key(1:1).ne.fc)) then
X`09    fc=ur.user_key(1:1)
X`09    write(6,1001) ' UU - Beginning '//fc
X`09    end if
X 0013`09if(do_city) then
X`09    do i=1,num_cities
X`09`09if(ur.city.eq.cities(i)) then
X`09`09    city_count(i)=city_count(i)+1
X`09`09    go to 10
X`09`09    end if
X`09`09end do
X`09    istat=str$upcase(tcity1,ur.city)
X`09    do i=1,num_cities
X`09`09istat=str$upcase(tcity2,cities(i))
X`09`09if(tcity1.eq.tcity2) then
X`09`09    write(6,*)'Changing '//ur.city//' to '//cities(i)
X`09`09    ur.city=cities(i)
X`09`09    city_count(i)=city_count(i)+1
X`09`09    rewrite(1,err=90500)ur
X`09`09    go to 10
X`09`09    end if
X`09`09end do
X
X`09    do i=1,num_nick
X`09`09if(tcity1.eq.nick_name(i)) then
X`09`09    write(6,*)'Changing '//ur.city//' to '//nick_city(i)
X`09`09    ur.city=nick_city(i)
X`09`09    rewrite(1,err=90500)ur
X`09`09    go to 13
X`09`09    end if
X`09`09end do
X
X`09    istat=str$upcase(ur.city,ur.city)
X`09    space = .false.
X`09    do i=2,20
X`09`09if((ur.city(i:i).ge.'A').and.(ur.city(i:i).le.'Z')
X`091`09    .and.(.not.space)) then
X`09`09    ur.city(i:i)=char(ichar(ur.city(i:i))+32)
X`09`09end if
X`09`09if(ur.city(i:i).eq.' ') then
X`09`09    space = .true.
X`09`09else
X`09`09    space = .false.
X`09`09end if
X`09`09end do
X`09    end if
X
X 0011`09if(ur.approved) then
X`09    appstr='* Approved *'
X`09else
X`09    appstr='Not Approved'
X`09endif
X
X`09write(6,1000)ur.user_key,ur.city,ur.state,ur.phone_number(1:3),
X`091   ur.phone_number(4:6),ur.phone_number(7:10),ur.computer,
X`092   ur.last_log_date,ur.last_log_time,ur.num_logon,ur.password,
X`093   appstr,ur.decus_number,ur.company_name
X
X 1000`09format(1x,a,1x,a,','a,1x,'(',a,')',a,'-',a,/,
X`091   1x,a,1x,a,1x,a,i6,1x,a,/,1x,a,1x,i6.6,1x,a)
X`09read(5,1001,end=5000)zz
X`09istat=str$upcase(zz,zz)
X
Xc`09First, check two character possibilities.
X`09if(zz.eq.'CN') then
X`09    print*,'Company name?'
X`09    read(5,1001)ur.company_name
X`09    go to 11
X`09    end if
X`09if(zz.eq.'CO') then
X`09    print*,'Computer?'
X`09    read(5,1001)ur.computer
X`09    go to 11
X`09    end if
X`09if(zz.eq.'DN') then
X`09    print*,'Decus number?'
X`09    read(5,1002)ur.decus_number
X`09    go to 11
X`09    end if
X`09if(zz.eq.'PN') then
X`09    print*,'Phone number?'
X`09    read(5,1001)ur.phone_number
X`09    go to 11
X`09    end if
X
Xc`09Then the single character ones.
X`09if(zz.eq.'A') then
X`09    ur.approved=.true.
X`09    go to 11
X`09    end if
X`09if(zz.eq.'B') go to 9
X`09if(zz.eq.'C') then
X`09    print*,'City?'
X`09    read(5,1001)ur.city
X`09    if(ur.city.eq.'l'.or.ur.city.eq.'L') ur.city='Little Rock'
X`09    if(ur.city.eq.'n'.or.ur.city.eq.'N') ur.city='North Little Rock'
X`09    if(ur.city.eq.'s'.or.ur.city.eq.'S') ur.city='Sherwood'
X`09    if(ur.city.eq.'j'.or.ur.city.eq.'J') ur.city='Jacksonville'
X`09    go to 11
X`09    end if
X`09if(zz.eq.'D') then
X`09    delete(unit=1)
X`09    go to 10
X`09    end if
X`09if(zz.eq.'E') go to 5000
X`09if(zz.eq.'G') then
X`09    if(do_city) then
X`09`09num_cities=num_cities+1
X`09`09if(num_cities.gt.city_max) then
X`09`09    print*,'UPUSER aborted - insufficient table space.'
X`09`09    print*,'Increase size of CITY_MAX and rerun.'
X`09`09    stop
X`09`09    end if
X`09`09cities(num_cities)=ur.city
X`09`09city_count(num_cities)=1
X`09`09end if
X`09    rewrite(1,err=90500)ur
X`09    go to 10
X`09    end if
X`09if(zz.eq.'P') then
X`09    print*,'Password?'
X`09    read(5,1001)ur.password
X`09    istat=str$upcase(ur.password,ur.password)
X`09    go to 11
X`09    end if
X`09if(zz.eq.'S') then
X`09    print*,'State?'
X`09    read(5,1001)ur.state
X`09    istat=str$upcase(ur.state,ur.state)
X`09    go to 11
X`09    end if
X`09if(zz.eq.'U') then
X`09    ur.approved=.false.
X`09    go to 11
X`09    end if
X`09if(zz.eq.'W') then
X`09    rewrite(1,err=90500)ur
X`09    go to 10
X`09    end if
X`09if(zz.eq.'Z') then
X`09    print*,'Time was',ur.seconds_today
X`09    ur.seconds_today=0
X`09    go to 11
X`09    end if
X`09if(zz.eq.'?') then
X`09    print*,'Valid options are:'
X`09    print*,'A  - Approve user'
X`09    print*,'B  - Beginning of program (re-enter key)'
X`09    print*,'C  - Change city'
X`09    print*,'CN - Change company name'
X`09    print*,'CO - Change computer type'
X`09    print*,'D  - Delete record'
X`09    print*,'DN - Change DECUS number'
X`09    print*,'E  - Exit program'
X`09    print*,'G  - Accept as good (add city to table and write)'
X`09    print*,'P  - Change password'
X`09    print*,'PN - Change phone number'
X`09    print*,'S  - Change state'
X`09    print*,'U  - Un-approve user'
X`09    print*,'W  - Write record'
X`09    print*,'Z  - Zero time used today'
X`09    go to 11
X`09    end if
X`09if(zz.eq.' ') go to 10
X`09print*,'Unknown command, type "?" for list'
X`09go to 11
X`09
X
X
X 5000`09close(unit=1)
X`09if(do_city) then
X`09    open(unit=2,file='ubbs_data:cities.dat',status='new',
X`091`09carriagecontrol='list')
X`09    do i=1,num_cities
X`09    write(2,1003)cities(i),city_count(i)
X`09    end do
X`09    close(unit=2)
X`09    print*,num_cities,' entries in CITIES.DAT'
X`09    end if
X`09print*,'finished'
X`09return
X
X90500`09print*,'an error has occurred'
X`09stop
X`09end
X`0C
X`09subroutine check_files
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Check_files.for
Xc`09This program removes all files in the files sections that do not
Xc`09appear in the FILES.IDX files.
Xc
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 4.3  07-Aug-1986
Xc`09Rev. 4.5  26-Sep-1986
Xc`09Rev. 4.8  09-Feb-1987
Xc`09Rev. 4.12 11-Jun-1987
Xc`09Rev. 5.3  28-Oct-1987
Xc`09Rev. 6.0  06-Jun-1988
Xc`09Rev. 6.1  08-Jun-1988
Xc`09Rev. 6.2  26-Jul-1988
Xc`09Rev. 7.1  19-Sep-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include '($rmsdef)'
X`09character filnam1*100,filnam2*100,filnam3*100
X`09character darea*3,tempfile*50,dsp*1,filetype*1
X`09logical delflag
X`09integer d1,d2,dummy,istat,fc1,fc2,du1,du2,i,length
X`09integer find_file,find_next,lib$delete_file,lib$find_file
X`09integer array_edit
X`09integer str$trim,str$upcase,sys$gettim
X`09integer fsize,rev_date(2),back_date(2)
X`09common/filesize/fsize,rev_date,back_date
X
X`09external uopen,getsize
X
X`09record/file_description/ fd
X
X`09sysop2 = .true.`09`09`09`09! Allow including files
X`09print*,'(D)elete or (P)rompt? `5BD`5D'
X`09read(5,1001)dsp
X`09istat=str$upcase(dsp,dsp)
X`09delflag=.false.
X`09if(dsp.ne.'P') delflag=.true.
X`09filnam1='ubbs_files:`5B000000`5D*.dir;*'
X`09call str$trim(filnam1,filnam1,dummy)
X`09fc1=0
X`09tempfile=filnam1
X`09istat=rms$_nmf
X`09istat=lib$find_file(tempfile,filnam1,fc1)
X`09do while (istat.ne.rms$_nmf)
X`09    d1=1
X`09    do while(d1.ne.0)
X`09`09d1=index(filnam1,'`5D')
X`09`09filnam1=filnam1(d1+1:)
X`09`09end do
X`09    d2=index(filnam1,'.')-1
X`09    darea=filnam1(:d2)
X`09    write(6,1001)' CF - Beginning '//darea
Xc
Xc Get the index file.
Xc
X`09open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09filnam2='ubbs_files:`5B'//darea//'.*`5D*.*;*'
X`09istat=find_file(filnam2,dummy,fc2)
X`09do while(istat.ne.rms$_nmf)
X`09    filnam3=filnam2
X`09    d1=1
X`09    do while(d1.ne.0)
X`09`09d1=index(filnam3,'`5D')
X`09`09if(d1.ne.0) filetype=filnam3(d1-3:d1-3)
X`09`09filnam3=filnam3(d1+1:)
X`09`09end do
X`09    d2=index(filnam3,';')-1
X`09    fd.file_name=filnam3(:d2)
X`09    if(filnam3(d2:d2).eq.'.') fd.file_name=filnam3(:d2-1)
X`09    read(4,key=fd.file_name,iostat=ios)fd
X`09    if((ios.eq.0).and.fd.archived) then
X`09`09fd.archived = .false.
X`09`09rewrite(4) fd
X`09`09print*,'Resetting ARCHIVE flag on '//fd.file_name
X`09    else if((ios.ne.0).and.(fd.file_name.ne.'*.*')) then
X`09`09print*,'File '//fd.file_name//' Type='//filetype
X`09`09if (.not.delflag) print*,'Disposition?'
X`09`09dsp='X'
X`09`09do while(dsp.ne.'A'.and.dsp.ne.'D'.and.dsp.ne.'I')
X`09`09    if (delflag) then
X`09`09`09dsp='D'
X`09`09    else
X`09`09`09read(5,1001)dsp
X`09`09    end if
X`09`09    istat=str$upcase(dsp,dsp)
X`09`09    if(dsp.eq.'D') then
X`09`09`09istat=lib$delete_file(filnam2)
X`09`09`09print*,'File '//fd.file_name//' deleted.'
X`09`09    else if (dsp.eq.'A') then
X`09`09`09print*,'File Description?'
X`09`09`09istat=array_edit(message,length,80,20)
X`09`09`09du1=1
X`09`09`09fd.upload_text=' '
X`09`09`09do i=1,length
X`09`09`09    istat=str$trim(message(i),message(i),du2)
X`09`09`09    fd.upload_text(du1:du1+du2)=
X`091`09`09`09message(i)(:du2)//char(cr)
X`09`09`09    du1=du1+du2+1
X`09`09`09    end do
X`09`09`09print*,'Keywords?'
X`09`09`09read(5,1001)fd.keywords
Xc`09Find out how big the file is.  This useropen will put the file
Xc`09size into fsize.
X`09`09`09open(unit=17,file=filnam2,status='old',readonly,
X`091`09`09    useropen=getsize)
X`09`09`09close(unit=17)
X`09`09`09fd.file_size=fsize
X`09`09`09call sys$gettim(fd.upload_date)
X`09`09`09fd.download_date = fd.upload_date
X`09`09`09fd.times_down=0
X`09`09`09print*,'Name?'
X`09`09`09read(5,1001)fd.upload_name
X`09`09`09istat=str$upcase(fd.upload_name,fd.upload_name)
X`09`09`09fd.file_type=filetype
X`09`09`09fd.archived=.false.
X`09`09`09write(4)fd
X`09`09    else if(dsp.eq.'I') then
X`09`09`09continue
X`09`09    else
X`09`09`09print*,'Invalid disposition, A or D allowed'
X`09`09    end if
X`09`09    end do
X`09`09end if
X`09    istat=find_next(filnam2,dummy,fc2)
X`09    end do
X`09    istat=lib$find_file(tempfile,filnam1,fc1)
X`09    end do
X 1001`09format(a)
X`09stop
X`09end
X`0C
X`09subroutine check_indices
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Check_indices.for
Xc`09This program removes all records in the FILES.IDX that are not actually
Xc`09present in the files section except those marked ARCHIVED.
Xc
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 4.11 05-Mar-1987
Xc`09Rev. 4.12 11-Jun-1987
Xc`09Rev. 6.0  06-Jun-1988
Xc`09Rev. 6.2  26-Jul-1988
Xc`09Rev. 7.1  19-Sep-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include '($rmsdef)'
X`09include 'sys$library:foriosdef.for/nolist'
X`09character filnam1*100,filnam2*100,darea*3,tempfile*50,dsp*1
X`09integer d1,d2,dummy,istat,fc1,fc2,du1,du2,i,length
X`09integer lib$find_file
X`09integer str$trim,str$upcase,sys$gettim
X`09external uopen
X`09record/file_description/ fd
X
X`09filnam1='ubbs_files:`5B000000`5D*.dir;*'
X`09call str$trim(filnam1,filnam1,dummy)
X`09fc1=0
X`09tempfile=filnam1
X`09istat=rms$_nmf
X`09istat=lib$find_file(tempfile,filnam1,fc1)
X`09do while (istat.ne.rms$_nmf)
X`09    d1=1
X`09    do while(d1.ne.0)
X`09`09d1=index(filnam1,'`5D')
X`09`09filnam1=filnam1(d1+1:)
X`09`09end do
X`09    d2=index(filnam1,'.')-1
X`09    darea=filnam1(:d2)
X`09    write(6,1001)' CI - Beginning '//darea
Xc
Xc Get the index file.
Xc
X`09open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09fd.file_name=char(0)
X`09read(4,keygt=fd.file_name,iostat=ios)fd
X`09do while(ios.ne.for$ios_attaccnon)
X`09    if(fd.file_name.eq.'$Header') go to 8888
X`09    if(fd.archived) go to 8888
X`09    if(fd.file_type.eq.'A'.or.fd.file_type.eq.'U') then
X`09`09filnam2='ubbs_files:`5B'//darea//'.ASC`5D'//fd.file_name
X`09    else
X`09`09filnam2='ubbs_files:`5B'//darea//'.BIN`5D'//fd.file_name
X`09    end if
X`09    istat=lib$find_file(filnam2,filnam2,fc2)
X`09    if(istat.eq.rms$_fnf) then
X`09`09print*,fd.file_name//' record deleted.'
X`09`09delete(unit=4)
X`09`09end if
X 8888`09    read(4,keygt=fd.file_name,iostat=ios)fd
X`09    end do
X`09    close(unit=4)
X
Xc`09Now, go on to the next directory.
X`09    istat=lib$find_file(tempfile,filnam1,fc1)
X`09    end do
X 1001`09format(a)
X`09stop
X`09end
X`0C
X`09subroutine update_sysops
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS utilities - Update_sysops.for
Xc`09This program allows interactive updating of the FILES.IDX files
Xc`09Dale Miller - UALR
Xc`09Rev. 4.2  20-Jul-1986
Xc`09Rev. 4.12 11-Jun-1987
Xc`09Rev. 6.0  06-Jun-1988
Xc`09Rev. 6.2  26-Jul-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include '($rmsdef)'
X`09character filename*50
X`09integer d1,d2,dummy,istat
X`09integer find_file,find_next,fc
X
X`09filename='ubbs_files:`5B000000`5D*.dir;*'
X`09call str$trim(filename,filename,dummy)
X`09istat=find_file(filename,dummy,fc)
X`09do while (istat.ne.rms$_nmf)
X`09    d1=1
X`09    do while(d1.ne.0)
X`09`09d1=index(filename,'`5D')
X`09`09filename=filename(d1+1:)
X`09`09end do
X`09    d2=index(filename,'.')-1
X`09    print*,'Area='//filename(:d2)
X`09    call make_cosysop(filename(:d2))
X`09    istat=find_next(filename,dummy,fc)
X`09    end do
X 1001`09format(a)
X`09return
X`09end
X`0C
X`09subroutine make_cosysop(darea)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will allow updating of the SYSOPs for download sections.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 4.2  20-Jul-1986
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) darea
X`09logical done
X`09integer length
X`09integer istat
X`09integer str$upcase
X`09external uopen
X
X`09record/file_description/ fd
X
Xc`09Open the indexed file for updating.
X`09open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09fd.file_name='$Header'
X`09read(4,key=fd.file_name)fd
X`09done=.false.
X`09do while(.not.done)
X`09    done=.true.
X`09    print*,'Sysop1? `5B'//fd.upload_name//'`5D'
X`09    read(5,1003)length,mail_name
X`09    if(length.gt.0) then
X`09`09istat=str$upcase(mail_name,mail_name)
X`09`09fd.upload_name=mail_name
X`09`09done=.false.
X`09`09end if
X`09    print*,'Sysop2? `5B'//fd.upload_text(1:30)//'`5D'
X`09    read(5,1003)length,mail_name
X`09    if(length.gt.0) then
X`09`09istat=str$upcase(mail_name,mail_name)
X`09`09fd.upload_text(1:30)=mail_name
X`09`09done=.false.
X`09`09end if
X`09    print*,'Sysop3? `5B'//fd.upload_text(31:60)//'`5D'
X`09    read(5,1003)length,mail_name
X`09    if(length.gt.0) then
+-+-+-+-+-+-+-+-  END  OF PART 4 +-+-+-+-+-+-+-+-