1      SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT)
2C***BEGIN PROLOGUE  XERSAV
3C***DATE WRITTEN   800319   (YYMMDD)
4C***REVISION DATE  820801   (YYMMDD)
5C***CATEGORY NO.  Z
6C***KEYWORDS  ERROR,XERROR PACKAGE
7C***AUTHOR  JONES, R. E., (SNLA)
8C***PURPOSE  Records that an error occurred.
9C***DESCRIPTION
10C     Abstract
11C        Record that this error occurred.
12C
13C     Description of Parameters
14C     --Input--
15C       MESSG, NMESSG, NERR, LEVEL are as in XERROR,
16C       except that when NMESSG=0 the tables will be
17C       dumped and cleared, and when NMESSG is less than zero the
18C       tables will be dumped and not cleared.
19C     --Output--
20C       ICOUNT will be the number of times this message has
21C       been seen, or zero if the table has overflowed and
22C       does not contain this message specifically.
23C       When NMESSG=0, ICOUNT will not be altered.
24C
25C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
26C     Latest revision ---  19 Mar 1980
27C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
28C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
29C                 1982.
30C***ROUTINES CALLED  I1MACH,S88FMT,XGETUA
31C***END PROLOGUE  XERSAV
32      INTEGER LUN(5)
33      CHARACTER*(*) MESSG
34      CHARACTER*20 MESTAB(10),MES
35      DIMENSION NERTAB(10),LEVTAB(10),KOUNT(10)
36      SAVE MESTAB,NERTAB,LEVTAB,KOUNT,KOUNTX
37C     NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK
38C     ERROR TABLE INITIALLY
39      DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5),
40     1     KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10)
41     2     /0,0,0,0,0,0,0,0,0,0/
42      DATA KOUNTX/0/
43C***FIRST EXECUTABLE STATEMENT  XERSAV
44      IF (NMESSG.GT.0) GO TO 80
45C     DUMP THE TABLE
46         IF (KOUNT(1).EQ.0) RETURN
47C        PRINT TO EACH UNIT
48         CALL XGETUA(LUN,NUNIT)
49         DO 60 KUNIT=1,NUNIT
50            IUNIT = LUN(KUNIT)
51            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
52C           PRINT TABLE HEADER
53            WRITE (IUNIT,10)
54   10       FORMAT (32H0          ERROR MESSAGE SUMMARY/
55     1      51H MESSAGE START             NERR     LEVEL     COUNT)
56C           PRINT BODY OF TABLE
57            DO 20 I=1,10
58               IF (KOUNT(I).EQ.0) GO TO 30
59               WRITE (IUNIT,15) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I)
60   15          FORMAT (1X,A20,3I10)
61   20       CONTINUE
62   30       CONTINUE
63C           PRINT NUMBER OF OTHER ERRORS
64            IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX
65   40       FORMAT (41H0OTHER ERRORS NOT INDIVIDUALLY TABULATED=,I10)
66            WRITE (IUNIT,50)
67   50       FORMAT (1X)
68   60    CONTINUE
69         IF (NMESSG.LT.0) RETURN
70C        CLEAR THE ERROR TABLES
71         DO 70 I=1,10
72   70       KOUNT(I) = 0
73         KOUNTX = 0
74         RETURN
75   80 CONTINUE
76C     PROCESS A MESSAGE...
77C     SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
78C     OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
79      MES = MESSG
80      DO 90 I=1,10
81         II = I
82         IF (KOUNT(I).EQ.0) GO TO 110
83         IF (MES.NE.MESTAB(I)) GO TO 90
84         IF (NERR.NE.NERTAB(I)) GO TO 90
85         IF (LEVEL.NE.LEVTAB(I)) GO TO 90
86         GO TO 100
87   90 CONTINUE
88C     THREE POSSIBLE CASES...
89C     TABLE IS FULL
90         KOUNTX = KOUNTX+1
91         ICOUNT = 1
92         RETURN
93C     MESSAGE FOUND IN TABLE
94  100    KOUNT(II) = KOUNT(II) + 1
95         ICOUNT = KOUNT(II)
96         RETURN
97C     EMPTY SLOT FOUND FOR NEW MESSAGE
98  110    MESTAB(II) = MES
99         NERTAB(II) = NERR
100         LEVTAB(II) = LEVEL
101         KOUNT(II)  = 1
102         ICOUNT = 1
103         RETURN
104      END
105