GNU Octave  3.8.0
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Properties Friends Macros Pages
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