seterr.f
2.73 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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)
external i1mach, i8save
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