1*DECK XERSVE 2 SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, 3 + ICOUNT) 4C***BEGIN PROLOGUE XERSVE 5C***SUBSIDIARY 6C***PURPOSE Record that an error has occurred. 7C***LIBRARY SLATEC (XERROR) 8C***CATEGORY R3 9C***TYPE ALL (XERSVE-A) 10C***KEYWORDS ERROR, XERROR 11C***AUTHOR Jones, R. E., (SNLA) 12C***DESCRIPTION 13C 14C *Usage: 15C 16C INTEGER KFLAG, NERR, LEVEL, ICOUNT 17C CHARACTER * (len) LIBRAR, SUBROU, MESSG 18C 19C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) 20C 21C *Arguments: 22C 23C LIBRAR :IN is the library that the message is from. 24C SUBROU :IN is the subroutine that the message is from. 25C MESSG :IN is the message to be saved. 26C KFLAG :IN indicates the action to be performed. 27C when KFLAG > 0, the message in MESSG is saved. 28C when KFLAG=0 the tables will be dumped and 29C cleared. 30C when KFLAG < 0, the tables will be dumped and 31C not cleared. 32C NERR :IN is the error number. 33C LEVEL :IN is the error severity. 34C ICOUNT :OUT the number of times this message has been seen, 35C or zero if the table has overflowed and does not 36C contain this message specifically. When KFLAG=0, 37C ICOUNT will not be altered. 38C 39C *Description: 40C 41C Record that this error occurred and possibly dump and clear the 42C tables. 43C 44C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC 45C Error-handling Package, SAND82-0800, Sandia 46C Laboratories, 1982. 47C***ROUTINES CALLED I1MACH, XGETUA 48C***REVISION HISTORY (YYMMDD) 49C 800319 DATE WRITTEN 50C 861211 REVISION DATE from Version 3.2 51C 891214 Prologue converted to Version 4.0 format. (BAB) 52C 900413 Routine modified to remove reference to KFLAG. (WRB) 53C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling 54C sequence, use IF-THEN-ELSE, make number of saved entries 55C easily changeable, changed routine name from XERSAV to 56C XERSVE. (RWC) 57C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) 58C 920501 Reformatted the REFERENCES section. (WRB) 59C***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/ 68C***FIRST EXECUTABLE STATEMENT XERSVE 69C 70 IF (KFLAG.LE.0) THEN 71C 72C Dump the table. 73C 74 IF (NMSG.EQ.0) RETURN 75C 76C Print to each unit. 77C 78 CALL XGETUA (LUN, NUNIT) 79 DO 20 KUNIT = 1,NUNIT 80 IUNIT = LUN(KUNIT) 81 IF (IUNIT.EQ.0) IUNIT = I1MACH(4) 82C 83C Print the table header. 84C 85 WRITE (IUNIT,9000) 86C 87C Print body of table. 88C 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 93C 94C Print number of other errors. 95C 96 IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX 97 WRITE (IUNIT,9030) 98 20 CONTINUE 99C 100C Clear the error tables. 101C 102 IF (KFLAG.EQ.0) THEN 103 NMSG = 0 104 KOUNTX = 0 105 ENDIF 106 ELSE 107C 108C PROCESS A MESSAGE... 109C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, 110C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. 111C 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 124C 125 IF (NMSG.LT.LENTAB) THEN 126C 127C Empty slot found for new message. 128C 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 138C 139C Table is full. 140C 141 KOUNTX = KOUNTX+1 142 ICOUNT = 0 143 ENDIF 144 ENDIF 145 RETURN 146C 147C Formats. 148C 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 156