xersve.F

Go to the documentation of this file.

*DECK XERSVE
      SUBROUTINE xersve (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL,
     +   icount)
      IMPLICIT NONE
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
      INTEGER,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/
      INTEGER NERR,LEVEL,KONTRL
      INTEGER NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
      INTEGER KFLAG, ICOUNT, NUNIT, KUNIT, IUNIT, I1MACH, I
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