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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
*DECK XERSVE
SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL,
+ ICOUNT)
C***BEGIN PROLOGUE XERSVE
C***SUBSIDIARY
C***PURPOSE Record that an error has occurred.
C***LIBRARY SLATEC (XERROR)
C***CATEGORY R3
C***TYPE ALL (XERSVE-A)
C***KEYWORDS ERROR, XERROR
C***AUTHOR Jones, R. E., (SNLA)
C***DESCRIPTION
C
C *Usage:
C
C INTEGER KFLAG, NERR, LEVEL, ICOUNT
C CHARACTER * (len) LIBRAR, SUBROU, MESSG
C
C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
C
C *Arguments:
C
C LIBRAR :IN is the library that the message is from.
C SUBROU :IN is the subroutine that the message is from.
C MESSG :IN is the message to be saved.
C KFLAG :IN indicates the action to be performed.
C when KFLAG > 0, the message in MESSG is saved.
C when KFLAG=0 the tables will be dumped and
C cleared.
C when KFLAG < 0, the tables will be dumped and
C not cleared.
C NERR :IN is the error number.
C LEVEL :IN is the error severity.
C ICOUNT :OUT the number of times this message has been seen,
C or zero if the table has overflowed and does not
C contain this message specifically. When KFLAG=0,
C ICOUNT will not be altered.
C
C *Description:
C
C Record that this error occurred and possibly dump and clear the
C tables.
C
C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
C Error-handling Package, SAND82-0800, Sandia
C Laboratories, 1982.
C***ROUTINES CALLED I1MACH, XGETUA
C***REVISION HISTORY (YYMMDD)
C 800319 DATE WRITTEN
C 861211 REVISION DATE from Version 3.2
C 891214 Prologue converted to Version 4.0 format. (BAB)
C 900413 Routine modified to remove reference to KFLAG. (WRB)
C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling
C sequence, use IF-THEN-ELSE, make number of saved entries
C easily changeable, changed routine name from XERSAV to
C XERSVE. (RWC)
C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS)
C 920501 Reformatted the REFERENCES section. (WRB)
C***END PROLOGUE XERSVE
include '../stack.h'
PARAMETER (LENTAB=10)
INTEGER LUN(5)
CHARACTER*(*) LIBRAR, SUBROU, MESSG
CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
CHARACTER*20 MESTAB(LENTAB), MES
CHARACTER*148 CBUFF
DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
DATA KOUNTX/0/, NMSG/0/
C***FIRST EXECUTABLE STATEMENT XERSVE
C
IF (KFLAG.LE.0) THEN
C
C Dump the table.
C
IF (NMSG.EQ.0) RETURN
C
C Print to each unit.
C
CALL BASOUT(IO,WTE,'0 ERROR MESSAGE SUMMARY')
CALL BASOUT(IO,WTE,
+ ' LIBRARY SUBROUTINE MESSAGE START NERR'//
+ ' LEVEL COUNT')
DO 10 I = 1,NMSG
WRITE (CBUFF,9010) LIBTAB(I), SUBTAB(I), MESTAB(I),
* NERTAB(I),LEVTAB(I),KOUNT(I)
CALL BASOUT(IO,WTE,CBUFF)
10 CONTINUE
IF (KOUNTX.NE.0) then
WRITE (CBUFF,9020) KOUNTX
CALL BASOUT(IO,WTE,CBUFF)
ENDIF
CALL BASOUT(IO,WTE,' ')
CSTD CALL XGETUA (LUN, NUNIT)
CSTD DO 20 KUNIT = 1,NUNIT
CSTD IUNIT = LUN(KUNIT)
CSTD IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
CSTDC
CSTDC Print the table header.
CSTDC
CSTD WRITE (IUNIT,9000)
CSTDC
CSTDC Print body of table.
CSTDC
CSTD DO 10 I = 1,NMSG
CSTD WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I),
CSTD * NERTAB(I),LEVTAB(I),KOUNT(I)
CSTD 10 CONTINUE
CSTDC
CSTDC Print number of other errors.
CSTDC
CSTD IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX
CSTD WRITE (IUNIT,9030)
CSTD 20 CONTINUE
C
C Clear the error tables.
C
IF (KFLAG.EQ.0) THEN
NMSG = 0
KOUNTX = 0
ENDIF
ELSE
C
C PROCESS A MESSAGE...
C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
C
LIB = LIBRAR
SUB = SUBROU
MES = MESSG
DO 30 I = 1,NMSG
IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND.
* MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND.
* LEVEL.EQ.LEVTAB(I)) THEN
KOUNT(I) = KOUNT(I) + 1
ICOUNT = KOUNT(I)
RETURN
ENDIF
30 CONTINUE
C
IF (NMSG.LT.LENTAB) THEN
C
C Empty slot found for new message.
C
NMSG = NMSG + 1
LIBTAB(I) = LIB
SUBTAB(I) = SUB
MESTAB(I) = MES
NERTAB(I) = NERR
LEVTAB(I) = LEVEL
KOUNT (I) = 1
ICOUNT = 1
ELSE
C
C Table is full.
C
KOUNTX = KOUNTX+1
ICOUNT = 0
ENDIF
ENDIF
RETURN
C
C Formats.
C
9000 FORMAT ('0 ERROR MESSAGE SUMMARY' /
+ ' LIBRARY SUBROUTINE MESSAGE START NERR',
+ ' LEVEL COUNT')
9010 FORMAT (1X,A,3X,A,3X,A,3I10)
9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
9030 FORMAT (1X)
END
|
