cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	UBBS utilities - Fixmess.for
c	This program add expiration dates to messages created by UBBS
c	previous to version 3.5.  New users may ignore its existance.
c	Dale Miller - UALR
c
c	Rev. 3.5  20-Jun-1986
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	implicit none
	include 'bbs_inc.for'
	character dummy_20*20
	include 'sys$library:foriosdef/nolist'
	external uopen
	integer k,istat
	integer sys$bintim,compquad
	real*8  my_time,one_month,time_zero

	record /mail_header_structure/ mh

	istat=sys$bintim('18-DEC-1858 00:00:00',one_month)
	istat=sys$bintim('19-JUN-1986 00:00:00',time_zero)

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

 2100	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=  ',last_header
	print*,'Last data=    ',last_data
	print*,'First message=',first_mnum
	print*,'Last message= ',last_mnum

	do k=2,last_header
c
c	Loop through all message headers to see if they need fixing
c
 	    read(2,rec=k)mh

	    if(mh.mail_person) go to 30

	    dummy_20=mh.mail_date(1:7)//'19'//mh.mail_date(8:9)//' 00:00:00'
	    istat=sys$bintim(dummy_20,my_time)
	    istat=compquad(my_time,time_zero)
	    if(istat.eq.1) go to 30
	    call addquad(my_time,one_month,mh.mail_expire)
	    write(2,rec=k)mh
	    print*,'Fixed ',mh.mail_messnum,' from:'//mh.mail_from//
	1	' To:'//mh.mail_to
 0030	    continue
	    end do

	close(unit=2)
	stop
 9060	print*,'could not open file'
	stop
90000	continue
	print*,'Error reading record, ios=',ios
	close(unit=2)
	close(unit=3)
	close(unit=4)
	stop
	end

	integer function uopen(fab,rab,lun)
	implicit none

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

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

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

c	actually open the file
	status=sys$open(fab)
	if(status) status=sys$connect(rab)
c	return the status
	uopen=status
	return
	end

	integer function uopen2(fab,rab,lun)
	implicit none

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

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

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

c	actually open the file
	status=sys$open(fab)
	if(status) status=sys$connect(rab)
c	return the status
	uopen2=status
	return
	end
