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