src/numerical/slatec/fortran/xersve.f

   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