1 SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT) 2C***BEGIN PROLOGUE XERSAV 3C***DATE WRITTEN 800319 (YYMMDD) 4C***REVISION DATE 820801 (YYMMDD) 5C***CATEGORY NO. Z 6C***KEYWORDS ERROR,XERROR PACKAGE 7C***AUTHOR JONES, R. E., (SNLA) 8C***PURPOSE Records that an error occurred. 9C***DESCRIPTION 10C Abstract 11C Record that this error occurred. 12C 13C Description of Parameters 14C --Input-- 15C MESSG, NMESSG, NERR, LEVEL are as in XERROR, 16C except that when NMESSG=0 the tables will be 17C dumped and cleared, and when NMESSG is less than zero the 18C tables will be dumped and not cleared. 19C --Output-- 20C ICOUNT will be the number of times this message has 21C been seen, or zero if the table has overflowed and 22C does not contain this message specifically. 23C When NMESSG=0, ICOUNT will not be altered. 24C 25C Written by Ron Jones, with SLATEC Common Math Library Subcommittee 26C Latest revision --- 19 Mar 1980 27C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- 28C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, 29C 1982. 30C***ROUTINES CALLED I1MACH,S88FMT,XGETUA 31C***END PROLOGUE XERSAV 32 INTEGER LUN(5) 33 CHARACTER*(*) MESSG 34 CHARACTER*20 MESTAB(10),MES 35 DIMENSION NERTAB(10),LEVTAB(10),KOUNT(10) 36 SAVE MESTAB,NERTAB,LEVTAB,KOUNT,KOUNTX 37C NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK 38C ERROR TABLE INITIALLY 39 DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5), 40 1 KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10) 41 2 /0,0,0,0,0,0,0,0,0,0/ 42 DATA KOUNTX/0/ 43C***FIRST EXECUTABLE STATEMENT XERSAV 44 IF (NMESSG.GT.0) GO TO 80 45C DUMP THE TABLE 46 IF (KOUNT(1).EQ.0) RETURN 47C PRINT TO EACH UNIT 48 CALL XGETUA(LUN,NUNIT) 49 DO 60 KUNIT=1,NUNIT 50 IUNIT = LUN(KUNIT) 51 IF (IUNIT.EQ.0) IUNIT = I1MACH(4) 52C PRINT TABLE HEADER 53 WRITE (IUNIT,10) 54 10 FORMAT (32H0 ERROR MESSAGE SUMMARY/ 55 1 51H MESSAGE START NERR LEVEL COUNT) 56C PRINT BODY OF TABLE 57 DO 20 I=1,10 58 IF (KOUNT(I).EQ.0) GO TO 30 59 WRITE (IUNIT,15) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I) 60 15 FORMAT (1X,A20,3I10) 61 20 CONTINUE 62 30 CONTINUE 63C PRINT NUMBER OF OTHER ERRORS 64 IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX 65 40 FORMAT (41H0OTHER ERRORS NOT INDIVIDUALLY TABULATED=,I10) 66 WRITE (IUNIT,50) 67 50 FORMAT (1X) 68 60 CONTINUE 69 IF (NMESSG.LT.0) RETURN 70C CLEAR THE ERROR TABLES 71 DO 70 I=1,10 72 70 KOUNT(I) = 0 73 KOUNTX = 0 74 RETURN 75 80 CONTINUE 76C PROCESS A MESSAGE... 77C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, 78C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. 79 MES = MESSG 80 DO 90 I=1,10 81 II = I 82 IF (KOUNT(I).EQ.0) GO TO 110 83 IF (MES.NE.MESTAB(I)) GO TO 90 84 IF (NERR.NE.NERTAB(I)) GO TO 90 85 IF (LEVEL.NE.LEVTAB(I)) GO TO 90 86 GO TO 100 87 90 CONTINUE 88C THREE POSSIBLE CASES... 89C TABLE IS FULL 90 KOUNTX = KOUNTX+1 91 ICOUNT = 1 92 RETURN 93C MESSAGE FOUND IN TABLE 94 100 KOUNT(II) = KOUNT(II) + 1 95 ICOUNT = KOUNT(II) 96 RETURN 97C EMPTY SLOT FOUND FOR NEW MESSAGE 98 110 MESTAB(II) = MES 99 NERTAB(II) = NERR 100 LEVTAB(II) = LEVEL 101 KOUNT(II) = 1 102 ICOUNT = 1 103 RETURN 104 END 105