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 c Rev. 4.10 11-Feb-1987 c Rev. 7.1 19-Sep-1988 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.'AF') then call archive_files else if (choice.eq.'C') then call compress(.false.) else if (choice.eq.'CA') then call compress(.true.) 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 if (choice.eq.'CI') then call check_indices else write(6,*)'Programs available' write(6,*)'A - Aging' write(6,*)'AF - Archive files' write(6,*)'C - Compress message file' write(6,*)'CA - Compress m.f. eliminating ALL read messages' write(6,*)'CF - Check files' write(6,*)'CI - Check indices' 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 Rev. 4.5 - 03-Oct-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 istat=str$upcase(my_date,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='ubbs_data: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(public) 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 c Rev. 4.10 11-Feb-1987 c Rev. 7.2 29-Dec-1988 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,len integer sys$bintim, compquad, str$upcase, sys$asctim logical busy,public real*8 right_now,delete_before, this_message record /mail_header_structure/ mh 1001 format(a) call date(cdate) dummy_20=cdate(1:7)//'19'//cdate(8:9)//' 00:00:00' istat=sys$bintim(dummy_20,right_now) if (public) then 0009 print*,'Enter date of earliest public message (dd-mmm-yyyy)' read(5,1001)dummy_20 istat = str$upcase(dummy_20,dummy_20) dummy_20 = dummy_20(:11)//' 00:00:00.00' istat = sys$bintim(dummy_20, delete_before) istat = sys$asctim(len,dummy_20,delete_before,) print*,'Date is:'//dummy_20(:len)//'. Is this correct?' read(5,1001)yesno istat=str$upcase(yesno,yesno) if(yesno.ne.'Y') go to 9 else istat = sys$bintim('17-NOV-1858 00:00:00.00', delete_before) end if open(unit=2,file='ubbs_data:message.hed',status='old', 1 organization='relative',access='direct',shared, 2 recordtype='fixed',recl=48,useropen=uopen) open(unit=3,file='ubbs_data: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(mh.mail_read.and.public) then !public and read, ignore it istat = sys$bintim(mh.mail_date(1:7)//'19'// 1 mh.mail_date(8:9)//' '//mh.mail_time, 2 this_message) istat = compquad(this_message, delete_before) if(istat.eq.-1) then print*,mh.mail_messnum,' read public' go to 30 end if 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='ubbs_data:userlog.dat',status='old', 1 organization='indexed',access='keyed', 2 recordtype='fixed',recl=50,shared,useropen=uopen) open(unit=2,file='ubbs_data: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='ubbs_data: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 c Rev. 7.3 23-Jan-1989 c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc implicit none include 'sys$library:foriosdef/nolist' include '($rmsdef)' integer high_bull,ios,user_number character bull_date*11,user_key*40,filename*60 character zeros*40/'0000000000000000000000000000000000000000'/ integer fsize,compquad,fc1,istat integer lib$find_file real*8 rev_date,back_date,last_date common/filesize/fsize,rev_date,back_date external uopen,getsize open(unit=1,file='ubbs_data:userlog.dat',status='old', 1 organization='indexed',access='keyed',err=90500, 2 recordtype='fixed',recl=50,shared,useropen=uopen) 1002 format('ubbs_data:bulletin.',i3.3,';*') 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 high_bull = 1 fc1=0 write(filename,1002)high_bull istat=lib$find_file(filename,filename,fc1) do while(istat.eq.rms$_normal) open(unit=4,file=filename,status='old',readonly,shared, 1 useropen=getsize) close(unit=4) istat = compquad(last_date,rev_date) if(istat.eq.-1) last_date = rev_date fc1=0 high_bull = high_bull + 1 filename = ' ' write(filename,1002)high_bull istat=lib$find_file(filename,filename,fc1) end do high_bull = high_bull - 1 call sys$asctim(,bull_date,last_date,) print*,'highest=',high_bull,' date=',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 Rev. 4.11 05-Mar-1987 c Rev. 4.12 11-Jun-1987 c Rev. 6.2 26-Jul-1988 c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc implicit none include 'bbs_inc.for' include '($rmsdef)' character filename*100,types*1,section*3,do_section*1 integer d1,d2,dummy,istat integer find_file,find_next,fc,str$upcase close(unit=6) open(unit=6,recl=1024,status='unknown',carriagecontrol='none') crlf=char(13)//char(10)//' ' cl=2 tnext=1 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) write(6,1001)crlf(:cl)// 1 '(A)ll or (S)elected sections? [A]' dummy=1 call get_upcase_string(do_section,dummy) if(do_section.ne.'S') then filename='ubbs_files:[000000]*.dir;*' call str$trim(filename,filename,dummy) istat=find_file(filename,dummy,fc) do while (istat.ne.rms$_nmf) d1=1 do while(d1.ne.0) d1=index(filename,']') filename=filename(d1+1:) end do d2=index(filename,'.')-1 write(6,1001)crlf(:cl)//crlf(:cl)// 1 'UF - Beginning '//filename(:d2) call update_index(filename(:d2),types) istat=find_next(filename,dummy,fc) end do else section='XXX' do while(section.ne.' ') write(6,1001)crlf(:cl)// 1 'Which section? [exit]' dummy=3 call get_uplow_string(section,dummy) istat = str$upcase(section,section) if(dummy.ne.0) then call update_index(section,types) else section=' ' end if end do end if 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 Rev. 4.9 10-Feb-1987 c Rev. 4.14 14-Jul-1987 c Rev. 5.3 28-Oct-1987 c Rev. 6.0 06-Jun-1988 c Rev. 7.2 02-Jan-1989 c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc implicit none include 'bbs_inc.for' character*(*) darea character cdate*11,cdate2*11,filtyp*6,startoff*18,types*1,cdummy*1 character temptext*400,rename*100,yn*3 integer length,dummy real*8 long_ago integer istat,keyln,len,j,k integer compquad integer sys$asctim,sys$bintim,str$upcase,str$trim integer sys$gettim,lib$rename_file,lib$delete_file integer array_edit external uopen record/file_description/ fd c Open the indexed file for updating. open(unit=4, shared, 1 file='ubbs_files:['//darea//']files.idx', 2 status='old', organization='indexed', 3 access='keyed', form='unformatted', 4 recl=192, recordtype='variable', 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 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 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 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//' 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 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 = sys$asctim(,cdate2,fd.download_date,) cdate2(5:5)=char(ichar(cdate2(5:5))+32) cdate2(6:6)=char(ichar(cdate2(6:6))+32) if (fd.archived) then yn = 'Yes' else yn = 'No' end if 0105 continue istat=str$trim(fd.keywords,fd.keywords,keyln) 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, 1 fd.file_size,filtyp,fd.times_down,crlf(:cl), 2 cdate2,yn,crlf(:cl)//crlf(:cl), 3 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' call sys$gettim(fd.download_date) go to 105 else if(cdummy.eq.'U') then if(fd.file_type.eq.'A') fd.file_type='U' if(fd.file_type.eq.'B') fd.file_type='V' 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) if((fd.file_type.eq.'A').or.(fd.file_type.eq.'U')) then filtyp='ASC' else filtyp='BIN' end if temptext='ubbs_files:['//darea//'.'//filtyp(1:3)//']'// 1 fd.file_name call str$trim(temptext,temptext,istat) temptext(istat+1:)=';*' istat=lib$delete_file(temptext(1:istat+2)) print*,'Deleted' else if(cdummy.eq.'E') then message(1)=fd.upload_name message(2)=fd.keywords length=2 temptext=fd.upload_text istat=index(temptext,char(cr)) do while(istat.ne.0) length=length+1 message(length)=temptext(:istat-1) temptext=temptext(istat+1:) istat=index(temptext,char(cr)) end do call setup_local(.false.) istat=array_edit(message,length,80,20) call setup_local(.true.) fd.upload_name=message(1) fd.keywords=message(2) j=1 k=2 temptext=' ' do while(k.lt.length) k=k+1 istat=str$trim(message(k),message(k),len) temptext(j:len+j-1)=message(k)(1:len) j=j+len+1 temptext(j-1:j-1)=char(cr) end do fd.upload_text=temptext go to 105 else if(cdummy.eq.'R') then if((fd.file_type.eq.'A').or.(fd.file_type.eq.'U')) then filtyp='ASC' else filtyp='BIN' end if write(6,1001)crlf(:cl)//'Rename to?' length=18 call get_filnam_string(rename,length) if(length.eq.0) then write(6,1001)crlf(:cl)//'Rename aborted.' go to 105 end if startoff=fd.file_name read(4,key=rename,iostat=istat)fd if(istat.eq.1) then write(6,1001)crlf(:cl)//'That name is in use' go to 105 end if if(index(rename(1:length),'.').eq.0) then length=length+1 rename(length:length)='.' endif read(4,key=startoff)fd temptext='ubbs_files:['//darea//'.'//filtyp(1:3)//']' istat=str$trim(temptext,temptext,len) rename=temptext(1:len)//rename temptext(len+1:)=fd.file_name istat=lib$rename_file(temptext(1:100),rename) delete(unit=4) if (rename(length+len:length+len).eq.'.') then fd.file_name=rename(len+1:len+length-1) else fd.file_name=rename(len+1:) endif write(4,iostat=k)fd if(istat.ne.1.or.k.ne.0) then write(6,1004)crlf(:cl)// 1 'Rename failed - Status ',istat,k write(6,1001)crlf(:cl)//'From='//temptext(1:100) write(6,1001)crlf(:cl)//' To='//rename else write(6,1001)crlf(:cl)//'Rename successful' end if startoff=temptext(len+1:) 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.'M') then if(fd.archived) then print*,'Cannot move an archived file' go to 105 end if if((fd.file_type.eq.'A').or.(fd.file_type.eq.'U')) then filtyp='ASC' else filtyp='BIN' end if write(6,1001)crlf(:cl)//'Move to? [quit]' length=18 call get_filnam_string(rename,length) if(length.eq.0) then write(6,1001)crlf(:cl)//'Move aborted.' go to 105 end if open(unit=7, shared, 1 file='ubbs_files:['//rename(1:3)//']files.idx', 2 status='old', organization='indexed', 3 access='keyed', form='unformatted', 4 recl=192, recordtype='variable', 5 key=(1:18:character), useropen=uopen, 6 iostat = istat) if(istat.ne.0) then call lib$signal(%val(istat)) print*,'That is not a valid file section' go to 105 end if startoff=fd.file_name read(7,key=fd.file_name,iostat=istat)fd if(istat.eq.1) then write(6,1001)crlf(:cl)//'That name is in use is the '// 1 rename(1:3)//' section.' close(unit=7) go to 105 end if read(4,key=startoff)fd write(7,iostat=k)fd delete(unit=4) temptext='ubbs_files:['//darea//'.'//filtyp(1:3)//']'// 1 fd.file_name istat=str$trim(temptext,temptext,len) rename=temptext(1:12)//rename(1:3)//temptext(16:) istat=lib$rename_file(temptext(1:len),rename) if(istat.ne.1.or.k.ne.0) then write(6,1004)crlf(:cl)// 1 'Move failed - Status ',istat,k write(6,1001)crlf(:cl)//'From='//temptext(1:len) write(6,1001)crlf(:cl)//' To='//rename(1:len) else write(6,1001)crlf(:cl)//'Move successful' end if startoff=fd.file_name fd.file_name='$Header' read(7,key=fd.file_name,err=100)fd istat = sys$gettim(fd.upload_date) rewrite(7)fd close(unit=7) fd.file_name=startoff else if(cdummy.eq.'X'.or.dummy.eq.-1) then close(unit=4) return 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)//'M - Move to another section' write(6,1001)crlf(:cl)//'R - Rename' write(6,1001)crlf(:cl)//'U - Unapprove' 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,9x, 1 'Downloaded: ',a,' Archived: ',a,a, 2 'Keywords: ',a,' By:',a) 1003 format(q,a) 1004 format(a,z8,',',z8) 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 Rev. 4.5 03-Oct-1986 c Rev. 4.10 25-Feb-1987 c Rev. 4.11 26-May-1987 c Rev. 5.1 03-Oct-1987 c Rev. 5.4a 04-Jan-1988 c Rev. 5.6a 28-Mar-1988 c Rev. 5.6b 29-May-1988 c Rev. 7.3a 31-Jan-1989 c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc implicit none include 'bbs_inc.for' include 'sys$library:foriosdef/nolist' integer istat,i,str$upcase parameter city_max = 500 parameter nick_max = 20 character zz*2,appstr*12,fc*1 character*20 cities(city_max),nick_city(nick_max),nick_name(nick_max) character*20 tcity1,tcity2 integer*2 city_count(city_max) character*40 zeros/'0000000000000000000000000000000000000000'/ character*40 spaces/' '/ logical do_city,space integer num_cities,num_nick external uopen 1001 format(a) 1002 format(i6) 1003 format(a20,i5) 1004 format(a20,1x,a20) open(unit=1,file='ubbs_data: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 fc=' ' do_city=.true. open(unit=2,file='ubbs_data:cities.dat',status='old') ios=0 num_cities=0 do while(ios.eq.0) num_cities=num_cities+1 if(num_cities.gt.city_max) then print*,'UPUSER aborted - insufficient table space.' print*,'Increase size of CITY_MAX and rerun.' stop end if read(2,1003,iostat=ios)cities(num_cities) city_count(num_cities)=0 end do num_cities=num_cities-1 print*,num_cities,' cities read' close(unit=2) open(unit=2,file='ubbs_data:city_nick.dat',status='old', 1 iostat=ios) num_nick=0 do while(ios.eq.0) num_nick=num_nick+1 if(num_nick.gt.nick_max) then print*,'UPUSER aborted - insufficient table space.' print*,'Increase size of NICK_MAX and rerun.' stop end if read(2,1004,iostat=ios)nick_name(num_nick), nick_city(num_nick) end do num_nick=num_nick-1 close(unit=2) print*,num_nick,' nicknames read' 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) i=index(ur.user_key,',') if(i.ne.0) then ur.user_key=ur.user_key(1:i-1)//spaces(1:21-i)// 1 ur.user_key(i+1:) endif 0012 read(1,keyge=ur.user_key,iostat=ios)ur if(ios.eq.for$ios_sperecloc) go to 12 if(ios.ne.0) go to 5000 if(ur.user_key.eq.zeros) go to 10 go to 13 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.and.(ur.user_key(1:1).ne.fc)) then fc=ur.user_key(1:1) write(6,1001) ' UU - Beginning '//fc end if 0013 if(do_city) then do i=1,num_cities if(ur.city.eq.cities(i)) then city_count(i)=city_count(i)+1 go to 10 end if end do istat=str$upcase(tcity1,ur.city) do i=1,num_cities istat=str$upcase(tcity2,cities(i)) if(tcity1.eq.tcity2) then write(6,*)'Changing '//ur.city//' to '//cities(i) ur.city=cities(i) city_count(i)=city_count(i)+1 rewrite(1,err=90500)ur go to 10 end if end do do i=1,num_nick if(tcity1.eq.nick_name(i)) then write(6,*)'Changing '//ur.city//' to '//nick_city(i) ur.city=nick_city(i) rewrite(1,err=90500)ur go to 13 end if end do istat=str$upcase(ur.city,ur.city) space = .false. do i=2,20 if((ur.city(i:i).ge.'A').and.(ur.city(i:i).le.'Z') 1 .and.(.not.space)) then ur.city(i:i)=char(ichar(ur.city(i:i))+32) end if if(ur.city(i:i).eq.' ') then space = .true. else space = .false. end if 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) c First, check two character possibilities. 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.'DN') then print*,'Decus number?' read(5,1002)ur.decus_number go to 11 end if if(zz.eq.'PN') then print*,'Phone number?' read(5,1001)ur.phone_number go to 11 end if c Then the single character ones. if(zz.eq.'A') then ur.approved=.true. 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.'D') then delete(unit=1) go to 10 end if if(zz.eq.'E') go to 5000 if(zz.eq.'G') then if(do_city) then num_cities=num_cities+1 if(num_cities.gt.city_max) then print*,'UPUSER aborted - insufficient table space.' print*,'Increase size of CITY_MAX and rerun.' stop end if cities(num_cities)=ur.city city_count(num_cities)=1 end if rewrite(1,err=90500)ur go to 10 end if 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.'S') then print*,'State?' read(5,1001)ur.state istat=str$upcase(ur.state,ur.state) go to 11 end if if(zz.eq.'U') then ur.approved=.false. 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(zz.eq.'?') then print*,'Valid options are:' print*,'A - Approve user' print*,'B - Beginning of program (re-enter key)' print*,'C - Change city' print*,'CN - Change company name' print*,'CO - Change computer type' print*,'D - Delete record' print*,'DN - Change DECUS number' print*,'E - Exit program' print*,'G - Accept as good (add city to table and write)' print*,'P - Change password' print*,'PN - Change phone number' print*,'S - Change state' print*,'U - Un-approve user' print*,'W - Write record' print*,'Z - Zero time used today' go to 11 end if if(zz.eq.' ') go to 10 print*,'Unknown command, type "?" for list' go to 11 5000 close(unit=1) if(do_city) then open(unit=2,file='ubbs_data:cities.dat',status='new', 1 carriagecontrol='list') do i=1,num_cities write(2,1003)cities(i),city_count(i) end do close(unit=2) print*,num_cities,' entries in CITIES.DAT' 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 FILES.IDX files. c c Dale Miller - UALR c c Rev. 4.3 07-Aug-1986 c Rev. 4.5 26-Sep-1986 c Rev. 4.8 09-Feb-1987 c Rev. 4.12 11-Jun-1987 c Rev. 5.3 28-Oct-1987 c Rev. 6.0 06-Jun-1988 c Rev. 6.1 08-Jun-1988 c Rev. 6.2 26-Jul-1988 c Rev. 7.1 19-Sep-1988 c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc implicit none include 'bbs_inc.for' include '($rmsdef)' character filnam1*100,filnam2*100,filnam3*100 character darea*3,tempfile*50,dsp*1,filetype*1 logical delflag integer d1,d2,dummy,istat,fc1,fc2,du1,du2,i,length integer find_file,find_next,lib$delete_file,lib$find_file integer array_edit integer str$trim,str$upcase,sys$gettim integer fsize,rev_date(2),back_date(2) common/filesize/fsize,rev_date,back_date external uopen,getsize record/file_description/ fd sysop2 = .true. ! Allow including files print*,'(D)elete or (P)rompt? [D]' read(5,1001)dsp istat=str$upcase(dsp,dsp) delflag=.false. if(dsp.ne.'P') delflag=.true. filnam1='ubbs_files:[000000]*.dir;*' call str$trim(filnam1,filnam1,dummy) fc1=0 tempfile=filnam1 istat=rms$_nmf istat=lib$find_file(tempfile,filnam1,fc1) do while (istat.ne.rms$_nmf) d1=1 do while(d1.ne.0) d1=index(filnam1,']') filnam1=filnam1(d1+1:) end do d2=index(filnam1,'.')-1 darea=filnam1(:d2) write(6,1001)' CF - Beginning '//darea c c Get the index file. c open(unit=4, shared, 1 file='ubbs_files:['//darea//']files.idx', 2 status='old', organization='indexed', 3 access='keyed', form='unformatted', 4 recl=192, recordtype='variable', 5 key=(1:18:character), 6 useropen=uopen) filnam2='ubbs_files:['//darea//'.*]*.*;*' istat=find_file(filnam2,dummy,fc2) do while(istat.ne.rms$_nmf) filnam3=filnam2 d1=1 do while(d1.ne.0) d1=index(filnam3,']') if(d1.ne.0) filetype=filnam3(d1-3:d1-3) filnam3=filnam3(d1+1:) end do d2=index(filnam3,';')-1 fd.file_name=filnam3(:d2) if(filnam3(d2:d2).eq.'.') fd.file_name=filnam3(:d2-1) read(4,key=fd.file_name,iostat=ios)fd if((ios.eq.0).and.fd.archived) then fd.archived = .false. rewrite(4) fd print*,'Resetting ARCHIVE flag on '//fd.file_name else if((ios.ne.0).and.(fd.file_name.ne.'*.*')) then print*,'File '//fd.file_name//' Type='//filetype if (.not.delflag) print*,'Disposition?' dsp='X' do while(dsp.ne.'A'.and.dsp.ne.'D'.and.dsp.ne.'I') if (delflag) then dsp='D' else read(5,1001)dsp end if istat=str$upcase(dsp,dsp) if(dsp.eq.'D') then istat=lib$delete_file(filnam2) print*,'File '//fd.file_name//' deleted.' else if (dsp.eq.'A') then print*,'File Description?' istat=array_edit(message,length,80,20) du1=1 fd.upload_text=' ' do i=1,length istat=str$trim(message(i),message(i),du2) fd.upload_text(du1:du1+du2)= 1 message(i)(:du2)//char(cr) du1=du1+du2+1 end do print*,'Keywords?' read(5,1001)fd.keywords c Find out how big the file is. This useropen will put the file c size into fsize. open(unit=17,file=filnam2,status='old',readonly, 1 useropen=getsize) close(unit=17) fd.file_size=fsize call sys$gettim(fd.upload_date) fd.download_date = fd.upload_date fd.times_down=0 print*,'Name?' read(5,1001)fd.upload_name istat=str$upcase(fd.upload_name,fd.upload_name) fd.file_type=filetype fd.archived=.false. write(4)fd else if(dsp.eq.'I') then continue else print*,'Invalid disposition, A or D allowed' end if end do end if istat=find_next(filnam2,dummy,fc2) end do istat=lib$find_file(tempfile,filnam1,fc1) end do 1001 format(a) stop end subroutine check_indices cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c UBBS utilities - Check_indices.for c This program removes all records in the FILES.IDX that are not actually c present in the files section except those marked ARCHIVED. c c Dale Miller - UALR c c Rev. 4.11 05-Mar-1987 c Rev. 4.12 11-Jun-1987 c Rev. 6.0 06-Jun-1988 c Rev. 6.2 26-Jul-1988 c Rev. 7.1 19-Sep-1988 c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc implicit none include 'bbs_inc.for' include '($rmsdef)' include 'sys$library:foriosdef.for/nolist' character filnam1*100,filnam2*100,darea*3,tempfile*50,dsp*1 integer d1,d2,dummy,istat,fc1,fc2,du1,du2,i,length integer lib$find_file integer str$trim,str$upcase,sys$gettim external uopen record/file_description/ fd filnam1='ubbs_files:[000000]*.dir;*' call str$trim(filnam1,filnam1,dummy) fc1=0 tempfile=filnam1 istat=rms$_nmf istat=lib$find_file(tempfile,filnam1,fc1) do while (istat.ne.rms$_nmf) d1=1 do while(d1.ne.0) d1=index(filnam1,']') filnam1=filnam1(d1+1:) end do d2=index(filnam1,'.')-1 darea=filnam1(:d2) write(6,1001)' CI - Beginning '//darea c c Get the index file. c open(unit=4, shared, 1 file='ubbs_files:['//darea//']files.idx', 2 status='old', organization='indexed', 3 access='keyed', form='unformatted', 4 recl=192, recordtype='variable', 5 key=(1:18:character), 6 useropen=uopen) fd.file_name=char(0) read(4,keygt=fd.file_name,iostat=ios)fd do while(ios.ne.for$ios_attaccnon) if(fd.file_name.eq.'$Header') go to 8888 if(fd.archived) go to 8888 if(fd.file_type.eq.'A'.or.fd.file_type.eq.'U') then filnam2='ubbs_files:['//darea//'.ASC]'//fd.file_name else filnam2='ubbs_files:['//darea//'.BIN]'//fd.file_name end if istat=lib$find_file(filnam2,filnam2,fc2) if(istat.eq.rms$_fnf) then print*,fd.file_name//' record deleted.' delete(unit=4) end if 8888 read(4,keygt=fd.file_name,iostat=ios)fd end do close(unit=4) c Now, go on to the next directory. istat=lib$find_file(tempfile,filnam1,fc1) end do 1001 format(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 Rev. 4.12 11-Jun-1987 c Rev. 6.0 06-Jun-1988 c Rev. 6.2 26-Jul-1988 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='ubbs_files:[000000]*.dir;*' call str$trim(filename,filename,dummy) istat=find_file(filename,dummy,fc) do while (istat.ne.rms$_nmf) d1=1 do while(d1.ne.0) d1=index(filename,']') filename=filename(d1+1:) end do d2=index(filename,'.')-1 print*,'Area='//filename(:d2) call make_cosysop(filename(: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='ubbs_files:['//darea//']files.idx', 2 status='old', organization='indexed', 3 access='keyed', form='unformatted', 4 recl=192, recordtype='variable', 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 subroutine archive_files cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c UBBS subroutines - ARCHIVE_FILES c This routine reads all of the FILES.IDX files and deletes and sets c the ARCHIVED flag for all those which have not been accessed since a c Specified date. c Dale Miller - UALR c c Rev. 7.1 19-Sep-1988 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc implicit none include 'bbs_inc.for' include '($rmsdef)' include 'sys$library:foriosdef.for/nolist' character filnam1*100,filnam2*100,darea*3,tempfile*50,dsp*1 character*30 my_date,time integer*4 long_ago(2) integer d1,d2,dummy,istat,fc1,fc2,du1,du2,i,length integer lib$find_file,lib$delete_file integer fsize,rev_date(2),back_date(2),total_size integer str$trim,str$upcase,sys$gettim,compquad integer sys$bintim,sys$asctim external uopen,getsize common/filesize/ fsize,rev_date,back_date record/file_description/ fd 0009 print*,'Enter date of interest (dd-mmm-yyyy)' read(5,1001)my_date 1001 format(a) istat=str$upcase(my_date,my_date) my_date=my_date(:11)//' 00:00:00.00' istat = sys$bintim(my_date,long_ago) istat = sys$asctim(length,time,long_ago,) print*,'Date is:'//time(:length)//'. Is this correct?' read(5,1001)dsp istat=str$upcase(dsp,dsp) if(dsp.ne.'Y') go to 9 filnam1='ubbs_files:[000000]*.dir;*' call str$trim(filnam1,filnam1,dummy) fc1=0 total_size = 0 tempfile=filnam1 istat=rms$_nmf istat=lib$find_file(tempfile,filnam1,fc1) do while (istat.ne.rms$_nmf) d1=1 do while(d1.ne.0) d1=index(filnam1,']') filnam1=filnam1(d1+1:) end do d2=index(filnam1,'.')-1 darea=filnam1(:d2) write(6,*)' AF - Beginning '//darea c c Get the index file. c open(unit=4, shared, 1 file='ubbs_files:['//darea//']files.idx', 2 status='old', organization='indexed', 3 access='keyed', form='unformatted', 4 recl=192, recordtype='variable', 5 key=(1:18:character), 6 useropen=uopen) fd.file_name=char(0) read(4,keygt=fd.file_name,iostat=ios)fd do while(ios.ne.for$ios_attaccnon) if(fd.file_name.eq.'$Header') go to 8888 if(fd.archived) go to 8888 dummy = compquad(long_ago,fd.download_date) if(dummy.eq.1) then c Check to make sure it has been backed up. if(fd.file_type.eq.'A'.or.fd.file_type.eq.'U') then filnam2='ubbs_files:['//darea//'.ASC]'//fd.file_name else filnam2='ubbs_files:['//darea//'.BIN]'//fd.file_name end if if(index(fd.file_name,'.').eq.0) then call str$trim(filnam2,filnam2,dummy) filnam2(dummy+1:dummy+1)='.' end if open(unit=17,file=filnam2,status='old',readonly, 1 useropen=getsize) close(unit=17) dummy = compquad(back_date,rev_date) if(dummy.ne.1) then print*,'File has not been backed up, archiving '// 1 'not possible:'//darea//' '//fd.file_name go to 8888 end if print*,'Deleting '//fd.file_name//' Size=',fd.file_size total_size = total_size + fd.file_size istat=lib$delete_file(filnam2) fd.archived = .true. rewrite(unit=4) fd end if 8888 read(4,keygt=fd.file_name,iostat=ios)fd end do close(unit=4) c Now, go on to the next directory. istat=lib$find_file(tempfile,filnam1,fc1) end do print*,'Total size of deleted files=',total_size stop end