+++ /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