GNU Octave  9.1.0
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
xersve.f
Go to the documentation of this file.
1 *DECK XERSVE
2  SUBROUTINE xersve (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL,
3  + ICOUNT)
4 C***BEGIN PROLOGUE XERSVE
5 C***SUBSIDIARY
6 C***PURPOSE Record that an error has occurred.
7 C***LIBRARY SLATEC (XERROR)
8 C***CATEGORY R3
9 C***TYPE ALL (XERSVE-A)
10 C***KEYWORDS ERROR, XERROR
11 C***AUTHOR Jones, R. E., (SNLA)
12 C***DESCRIPTION
13 C
14 C *Usage:
15 C
16 C INTEGER KFLAG, NERR, LEVEL, ICOUNT
17 C CHARACTER * (len) LIBRAR, SUBROU, MESSG
18 C
19 C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
20 C
21 C *Arguments:
22 C
23 C LIBRAR :IN is the library that the message is from.
24 C SUBROU :IN is the subroutine that the message is from.
25 C MESSG :IN is the message to be saved.
26 C KFLAG :IN indicates the action to be performed.
27 C when KFLAG > 0, the message in MESSG is saved.
28 C when KFLAG=0 the tables will be dumped and
29 C cleared.
30 C when KFLAG < 0, the tables will be dumped and
31 C not cleared.
32 C NERR :IN is the error number.
33 C LEVEL :IN is the error severity.
34 C ICOUNT :OUT the number of times this message has been seen,
35 C or zero if the table has overflowed and does not
36 C contain this message specifically. When KFLAG=0,
37 C ICOUNT will not be altered.
38 C
39 C *Description:
40 C
41 C Record that this error occurred and possibly dump and clear the
42 C tables.
43 C
44 C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
45 C Error-handling Package, SAND82-0800, Sandia
46 C Laboratories, 1982.
47 C***ROUTINES CALLED I1MACH, XGETUA
48 C***REVISION HISTORY (YYMMDD)
49 C 800319 DATE WRITTEN
50 C 861211 REVISION DATE from Version 3.2
51 C 891214 Prologue converted to Version 4.0 format. (BAB)
52 C 900413 Routine modified to remove reference to KFLAG. (WRB)
53 C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling
54 C sequence, use IF-THEN-ELSE, make number of saved entries
55 C easily changeable, changed routine name from XERSAV to
56 C XERSVE. (RWC)
57 C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS)
58 C 920501 Reformatted the REFERENCES section. (WRB)
59 C***END PROLOGUE XERSVE
60  parameter(lentab=10)
61  INTEGER LUN(5)
62  CHARACTER*(*) LIBRAR, SUBROU, MESSG
63  CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
64  CHARACTER*20 MESTAB(LENTAB), MES
65  dimension nertab(lentab), levtab(lentab), kount(lentab)
66  SAVE libtab, subtab, mestab, nertab, levtab, kount, kountx, nmsg
67  DATA kountx/0/, nmsg/0/
68 C***FIRST EXECUTABLE STATEMENT XERSVE
69 C
70  IF (kflag.LE.0) THEN
71 C
72 C Dump the table.
73 C
74  IF (nmsg.EQ.0) RETURN
75 C
76 C Print to each unit.
77 C
78  CALL xgetua (lun, nunit)
79  DO 20 kunit = 1,nunit
80  iunit = lun(kunit)
81  IF (iunit.EQ.0) iunit = i1mach(4)
82 C
83 C Print the table header.
84 C
85  WRITE (iunit,9000)
86 C
87 C Print body of table.
88 C
89  DO 10 i = 1,nmsg
90  WRITE (iunit,9010) libtab(i), subtab(i), mestab(i),
91  * nertab(i),levtab(i),kount(i)
92  10 CONTINUE
93 C
94 C Print number of other errors.
95 C
96  IF (kountx.NE.0) WRITE (iunit,9020) kountx
97  WRITE (iunit,9030)
98  20 CONTINUE
99 C
100 C Clear the error tables.
101 C
102  IF (kflag.EQ.0) THEN
103  nmsg = 0
104  kountx = 0
105  ENDIF
106  ELSE
107 C
108 C PROCESS A MESSAGE...
109 C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
110 C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
111 C
112  lib = librar
113  sub = subrou
114  mes = messg
115  DO 30 i = 1,nmsg
116  IF (lib.EQ.libtab(i) .AND. sub.EQ.subtab(i) .AND.
117  * mes.EQ.mestab(i) .AND. nerr.EQ.nertab(i) .AND.
118  * level.EQ.levtab(i)) THEN
119  kount(i) = kount(i) + 1
120  icount = kount(i)
121  RETURN
122  ENDIF
123  30 CONTINUE
124 C
125  IF (nmsg.LT.lentab) THEN
126 C
127 C Empty slot found for new message.
128 C
129  nmsg = nmsg + 1
130  libtab(i) = lib
131  subtab(i) = sub
132  mestab(i) = mes
133  nertab(i) = nerr
134  levtab(i) = level
135  kount(i) = 1
136  icount = 1
137  ELSE
138 C
139 C Table is full.
140 C
141  kountx = kountx+1
142  icount = 0
143  ENDIF
144  ENDIF
145  RETURN
146 C
147 C Formats.
148 C
149  9000 FORMAT ('0 ERROR MESSAGE SUMMARY' /
150  + ' LIBRARY SUBROUTINE MESSAGE START NERR',
151  + ' LEVEL COUNT')
152  9010 FORMAT (1x,a,3x,a,3x,a,3i10)
153  9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', i10)
154  9030 FORMAT (1x)
155  END
integer function i1mach(i)
Definition: i1mach.f:23
subroutine xersve(LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
Definition: xersve.f:4
subroutine xgetua(IUNITA, N)
Definition: xgetua.f:3