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