subroutine e9rint(messg,nw,nerr,save)
c
c this routine stores the current error message or prints the old one,
c if any, depending on whether or not save = .true. .
c
integer messg(nw)
logical save
c
c messgp stores at least the first 72 characters of the previous
c message. its length is machine dependent and must be at least
c
c 1 + 71/(the number of characters stored per integer word).
c
integer messgp(36),fmt(14),ccplus
c
c start with no previous message.
c
data messgp(1)/1h1/, nwp/0/, nerrp/0/
c
c set up the format for printing the error message.
c the format is simply (a1,14x,72axx) where xx=i1mach(6) is the
c number of characters stored per integer word.
c
data ccplus / 1h+ /
c
data fmt( 1) / 1h( /
data fmt( 2) / 1ha /
data fmt( 3) / 1h1 /
data fmt( 4) / 1h, /
data fmt( 5) / 1h1 /
data fmt( 6) / 1h4 /
data fmt( 7) / 1hx /
data fmt( 8) / 1h, /
data fmt( 9) / 1h7 /
data fmt(10) / 1h2 /
data fmt(11) / 1ha /
data fmt(12) / 1hx /
data fmt(13) / 1hx /
data fmt(14) / 1h) /
c
if (.not.save) go to 20
c
c save the message.
c
nwp=nw
nerrp=nerr
do 10 i=1,nw
10 messgp(i)=messg(i)
c
go to 30
c
20 if (i8save(1,0,.false.).eq.0) go to 30
c
c print the message.
c
iwunit=i1mach(4)
write(iwunit,9000) nerrp
9000 format(7h error ,i4,4h in )
c
call s88fmt(2,i1mach(6),fmt(12))
write(iwunit,fmt) ccplus,(messgp(i),i=1,nwp)
c
30 return
c
end
subroutine entsrc(irold,irnew)
c
c this routine returns irold = lrecov and sets lrecov = irnew.
c
c if there is an active error state, the message is printed
c and execution stops.
c
c irnew = 0 leaves lrecov unchanged, while
c irnew = 1 gives recovery and
c irnew = 2 turns recovery off.
c
c error states -
c
c 1 - illegal value of irnew.
c 2 - called while in an error state.
c
if (irnew.lt.0 .or. irnew.gt.2)
1 call seterr(31hentsrc - illegal value of irnew,31,1,2)
c
irold=i8save(2,irnew,irnew.ne.0)
c
c if have an error state, stop execution.
c
if (i8save(1,0,.false.) .ne. 0) call seterr
1 (39hentsrc - called while in an error state,39,2,2)
c
return
c
end
subroutine eprint
c
c this subroutine prints the last error message, if any.
c
integer messg(1)
c
call e9rint(messg,1,1,.false.)
return
c
end
subroutine erroff
c
c turns off the error state off by setting lerror=0.
c
i=i8save(1,0,.true.)
return
c
end
integer function i8save(isw,ivalue,set)
c
c if (isw = 1) i8save returns the current error number and
c sets it to ivalue if set = .true. .
c
c if (isw = 2) i8save returns the current recovery switch and
c sets it to ivalue if set = .true. .
c
logical set
c
integer iparam(2)
c iparam(1) is the error number and iparam(2) is the recovery switch.
c
c start execution error free and with recovery turned off.
c
data iparam(1) /0/, iparam(2) /2/
c
i8save=iparam(isw)
if (set) iparam(isw)=ivalue
c
return
c
end
integer function nerror(nerr)
c
c returns nerror = nerr = the value of the error flag lerror.
c
nerror=i8save(1,0,.false.)
nerr=nerror
return
c
end
subroutine retsrc(irold)
c
c this routine sets lrecov = irold.
c
c if the current error becomes unrecoverable,
c the message is printed and execution stops.
c
c error states -
c
c 1 - illegal value of irold.
c
if (irold.lt.1 .or. irold.gt.2)
1 call seterr(31hretsrc - illegal value of irold,31,1,2)
c
itemp=i8save(2,irold,.true.)
c
c if the current error is now unrecoverable, print and stop.
c
if (irold.eq.1 .or. i8save(1,0,.false.).eq.0) return
c
call eprint
stop
c
end
subroutine s88fmt( n, w, ifmt )
c
c s88fmt replaces ifmt(1), ... , ifmt(n) with
c the characters corresponding to the n least significant
c digits of w.
c
integer n,w,ifmt(n)
c
integer nt,wt,digits(10)
c
data digits( 1) / 1h0 /
data digits( 2) / 1h1 /
data digits( 3) / 1h2 /
data digits( 4) / 1h3 /
data digits( 5) / 1h4 /
data digits( 6) / 1h5 /
data digits( 7) / 1h6 /
data digits( 8) / 1h7 /
data digits( 9) / 1h8 /
data digits(10) / 1h9 /
c
nt = n
wt = w
c
10 if (nt .le. 0) return
idigit = mod( wt, 10 )
ifmt(nt) = digits(idigit+1)
wt = wt/10
nt = nt - 1
go to 10
c
end
subroutine seterr(messg,nmessg,nerr,iopt)
c
c this version modified by w. fullerton to dump if iopt = 1 and
c not recovering.
c seterr sets lerror = nerr, optionally prints the message and dumps
c according to the following rules...
c
c if iopt = 1 and recovering - just remember the error.
c if iopt = 1 and not recovering - print, dump and stop.
c if iopt = 2 - print, dump and stop.
c
c input
c
c messg - the error message.
c nmessg - the length of the message, in characters.
c nerr - the error number. must have nerr non-zero.
c iopt - the option. must have iopt=1 or 2.
c
c error states -
c
c 1 - message length not positive.
c 2 - cannot have nerr=0.
c 3 - an unrecovered error followed by another error.
c 4 - bad value for iopt.
c
c only the first 72 characters of the message are printed.
c
c the error handler calls a subroutine named fdump to produce a
c symbolic dump. to complete the package, a dummy version of fdump
c is supplied, but it should be replaced by a locally written version
c which at least gives a trace-back.
c
integer messg(1)
c
c the unit for error messages.
c
iwunit=i1mach(4)
c
if (nmessg.ge.1) go to 10
c
c a message of non-positive length is fatal.
c
write(iwunit,9000)
9000 format(52h1error 1 in seterr - message length not positive.)
go to 60
c
c nw is the number of words the message occupies.
c
10 nw=(min0(nmessg,72)-1)/i1mach(6)+1
c
if (nerr.ne.0) go to 20
c
c cannot turn the error state off using seterr.
c
write(iwunit,9001)
9001 format(42h1error 2 in seterr - cannot have nerr=0//
1 34h the current error message follows///)
call e9rint(messg,nw,nerr,.true.)
itemp=i8save(1,1,.true.)
go to 50
c
c set lerror and test for a previous unrecovered error.
c
20 if (i8save(1,nerr,.true.).eq.0) go to 30
c
write(iwunit,9002)
9002 format(23h1error 3 in seterr -,
1 48h an unrecovered error followed by another error.//
2 48h the previous and current error messages follow.///)
call eprint
call e9rint(messg,nw,nerr,.true.)
go to 50
c
c save this message in case it is not recovered from properly.
c
30 call e9rint(messg,nw,nerr,.true.)
c
if (iopt.eq.1 .or. iopt.eq.2) go to 40
c
c must have iopt = 1 or 2.
c
write(iwunit,9003)
9003 format(42h1error 4 in seterr - bad value for iopt//
1 34h the current error message follows///)
go to 50
c
c test for recovery.
c
40 if (iopt.eq.2) go to 50
c
if (i8save(2,0,.false.).eq.1) return
c
c call eprint
c stop
c
50 call eprint
60 call fdump
stop
c
end
subroutine fdump
c
call abort
return
end
.
