--- /dev/null
+*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
+ PARAMETER (LENTAB=10)
+ INTEGER LUN(5)
+ CHARACTER*(*) LIBRAR, SUBROU, MESSG
+ CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
+ CHARACTER*20 MESTAB(LENTAB), MES
+ 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 XGETUA (LUN, NUNIT)
+ DO 20 KUNIT = 1,NUNIT
+ IUNIT = LUN(KUNIT)
+ IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
+C
+C Print the table header.
+C
+ WRITE (IUNIT,9000)
+C
+C Print body of table.
+C
+ DO 10 I = 1,NMSG
+ WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I),
+ * NERTAB(I),LEVTAB(I),KOUNT(I)
+ 10 CONTINUE
+C
+C Print number of other errors.
+C
+ IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX
+ WRITE (IUNIT,9030)
+ 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