|
3274
|
1 *DECK XERMSG |
|
|
2 SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) |
|
|
3 C***BEGIN PROLOGUE XERMSG |
|
|
4 C***PURPOSE Process error messages for SLATEC and other libraries. |
|
|
5 C***LIBRARY SLATEC (XERROR) |
|
|
6 C***CATEGORY R3C |
|
|
7 C***TYPE ALL (XERMSG-A) |
|
|
8 C***KEYWORDS ERROR MESSAGE, XERROR |
|
|
9 C***AUTHOR Fong, Kirby, (NMFECC at LLNL) |
|
|
10 C***DESCRIPTION |
|
|
11 C |
|
|
12 C XERMSG processes a diagnostic message in a manner determined by the |
|
|
13 C value of LEVEL and the current value of the library error control |
|
|
14 C flag, KONTRL. See subroutine XSETF for details. |
|
|
15 C |
|
|
16 C LIBRAR A character constant (or character variable) with the name |
|
|
17 C of the library. This will be 'SLATEC' for the SLATEC |
|
|
18 C Common Math Library. The error handling package is |
|
|
19 C general enough to be used by many libraries |
|
|
20 C simultaneously, so it is desirable for the routine that |
|
|
21 C detects and reports an error to identify the library name |
|
|
22 C as well as the routine name. |
|
|
23 C |
|
|
24 C SUBROU A character constant (or character variable) with the name |
|
|
25 C of the routine that detected the error. Usually it is the |
|
|
26 C name of the routine that is calling XERMSG. There are |
|
|
27 C some instances where a user callable library routine calls |
|
|
28 C lower level subsidiary routines where the error is |
|
|
29 C detected. In such cases it may be more informative to |
|
|
30 C supply the name of the routine the user called rather than |
|
|
31 C the name of the subsidiary routine that detected the |
|
|
32 C error. |
|
|
33 C |
|
|
34 C MESSG A character constant (or character variable) with the text |
|
|
35 C of the error or warning message. In the example below, |
|
|
36 C the message is a character constant that contains a |
|
|
37 C generic message. |
|
|
38 C |
|
|
39 C CALL XERMSG ('SLATEC', 'MMPY', |
|
|
40 C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', |
|
|
41 C *3, 1) |
|
|
42 C |
|
|
43 C It is possible (and is sometimes desirable) to generate a |
|
|
44 C specific message--e.g., one that contains actual numeric |
|
|
45 C values. Specific numeric values can be converted into |
|
|
46 C character strings using formatted WRITE statements into |
|
|
47 C character variables. This is called standard Fortran |
|
|
48 C internal file I/O and is exemplified in the first three |
|
|
49 C lines of the following example. You can also catenate |
|
|
50 C substrings of characters to construct the error message. |
|
|
51 C Here is an example showing the use of both writing to |
|
|
52 C an internal file and catenating character strings. |
|
|
53 C |
|
|
54 C CHARACTER*5 CHARN, CHARL |
|
|
55 C WRITE (CHARN,10) N |
|
|
56 C WRITE (CHARL,10) LDA |
|
|
57 C 10 FORMAT(I5) |
|
|
58 C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// |
|
|
59 C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// |
|
|
60 C * CHARL, 3, 1) |
|
|
61 C |
|
|
62 C There are two subtleties worth mentioning. One is that |
|
|
63 C the // for character catenation is used to construct the |
|
|
64 C error message so that no single character constant is |
|
|
65 C continued to the next line. This avoids confusion as to |
|
|
66 C whether there are trailing blanks at the end of the line. |
|
|
67 C The second is that by catenating the parts of the message |
|
|
68 C as an actual argument rather than encoding the entire |
|
|
69 C message into one large character variable, we avoid |
|
|
70 C having to know how long the message will be in order to |
|
|
71 C declare an adequate length for that large character |
|
|
72 C variable. XERMSG calls XERPRN to print the message using |
|
|
73 C multiple lines if necessary. If the message is very long, |
|
|
74 C XERPRN will break it into pieces of 72 characters (as |
|
|
75 C requested by XERMSG) for printing on multiple lines. |
|
|
76 C Also, XERMSG asks XERPRN to prefix each line with ' * ' |
|
|
77 C so that the total line length could be 76 characters. |
|
|
78 C Note also that XERPRN scans the error message backwards |
|
|
79 C to ignore trailing blanks. Another feature is that |
|
|
80 C the substring '$$' is treated as a new line sentinel |
|
|
81 C by XERPRN. If you want to construct a multiline |
|
|
82 C message without having to count out multiples of 72 |
|
|
83 C characters, just use '$$' as a separator. '$$' |
|
|
84 C obviously must occur within 72 characters of the |
|
|
85 C start of each line to have its intended effect since |
|
|
86 C XERPRN is asked to wrap around at 72 characters in |
|
|
87 C addition to looking for '$$'. |
|
|
88 C |
|
|
89 C NERR An integer value that is chosen by the library routine's |
|
|
90 C author. It must be in the range -99 to 999 (three |
|
|
91 C printable digits). Each distinct error should have its |
|
|
92 C own error number. These error numbers should be described |
|
|
93 C in the machine readable documentation for the routine. |
|
|
94 C The error numbers need be unique only within each routine, |
|
|
95 C so it is reasonable for each routine to start enumerating |
|
|
96 C errors from 1 and proceeding to the next integer. |
|
|
97 C |
|
|
98 C LEVEL An integer value in the range 0 to 2 that indicates the |
|
|
99 C level (severity) of the error. Their meanings are |
|
|
100 C |
|
|
101 C -1 A warning message. This is used if it is not clear |
|
|
102 C that there really is an error, but the user's attention |
|
|
103 C may be needed. An attempt is made to only print this |
|
|
104 C message once. |
|
|
105 C |
|
|
106 C 0 A warning message. This is used if it is not clear |
|
|
107 C that there really is an error, but the user's attention |
|
|
108 C may be needed. |
|
|
109 C |
|
|
110 C 1 A recoverable error. This is used even if the error is |
|
|
111 C so serious that the routine cannot return any useful |
|
|
112 C answer. If the user has told the error package to |
|
|
113 C return after recoverable errors, then XERMSG will |
|
|
114 C return to the Library routine which can then return to |
|
|
115 C the user's routine. The user may also permit the error |
|
|
116 C package to terminate the program upon encountering a |
|
|
117 C recoverable error. |
|
|
118 C |
|
|
119 C 2 A fatal error. XERMSG will not return to its caller |
|
|
120 C after it receives a fatal error. This level should |
|
|
121 C hardly ever be used; it is much better to allow the |
|
|
122 C user a chance to recover. An example of one of the few |
|
|
123 C cases in which it is permissible to declare a level 2 |
|
|
124 C error is a reverse communication Library routine that |
|
|
125 C is likely to be called repeatedly until it integrates |
|
|
126 C across some interval. If there is a serious error in |
|
|
127 C the input such that another step cannot be taken and |
|
|
128 C the Library routine is called again without the input |
|
|
129 C error having been corrected by the caller, the Library |
|
|
130 C routine will probably be called forever with improper |
|
|
131 C input. In this case, it is reasonable to declare the |
|
|
132 C error to be fatal. |
|
|
133 C |
|
|
134 C Each of the arguments to XERMSG is input; none will be modified by |
|
|
135 C XERMSG. A routine may make multiple calls to XERMSG with warning |
|
|
136 C level messages; however, after a call to XERMSG with a recoverable |
|
|
137 C error, the routine should return to the user. Do not try to call |
|
|
138 C XERMSG with a second recoverable error after the first recoverable |
|
|
139 C error because the error package saves the error number. The user |
|
|
140 C can retrieve this error number by calling another entry point in |
|
|
141 C the error handling package and then clear the error number when |
|
|
142 C recovering from the error. Calling XERMSG in succession causes the |
|
|
143 C old error number to be overwritten by the latest error number. |
|
|
144 C This is considered harmless for error numbers associated with |
|
|
145 C warning messages but must not be done for error numbers of serious |
|
|
146 C errors. After a call to XERMSG with a recoverable error, the user |
|
|
147 C must be given a chance to call NUMXER or XERCLR to retrieve or |
|
|
148 C clear the error number. |
|
|
149 C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC |
|
|
150 C Error-handling Package, SAND82-0800, Sandia |
|
|
151 C Laboratories, 1982. |
|
|
152 C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE |
|
|
153 C***REVISION HISTORY (YYMMDD) |
|
|
154 C 880101 DATE WRITTEN |
|
|
155 C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. |
|
|
156 C THERE ARE TWO BASIC CHANGES. |
|
|
157 C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO |
|
|
158 C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES |
|
|
159 C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS |
|
|
160 C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE |
|
|
161 C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER |
|
|
162 C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY |
|
|
163 C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE |
|
|
164 C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. |
|
|
165 C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE |
|
|
166 C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE |
|
|
167 C OF LOWER CASE. |
|
|
168 C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. |
|
|
169 C THE PRINCIPAL CHANGES ARE |
|
|
170 C 1. CLARIFY COMMENTS IN THE PROLOGUES |
|
|
171 C 2. RENAME XRPRNT TO XERPRN |
|
|
172 C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES |
|
|
173 C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / |
|
|
174 C CHARACTER FOR NEW RECORDS. |
|
|
175 C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO |
|
|
176 C CLEAN UP THE CODING. |
|
|
177 C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN |
|
|
178 C PREFIX. |
|
|
179 C 891013 REVISED TO CORRECT COMMENTS. |
|
|
180 C 891214 Prologue converted to Version 4.0 format. (WRB) |
|
|
181 C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but |
|
|
182 C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added |
|
|
183 C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and |
|
|
184 C XERCTL to XERCNT. (RWC) |
|
|
185 C 920501 Reformatted the REFERENCES section. (WRB) |
|
|
186 C***END PROLOGUE XERMSG |
|
|
187 CHARACTER*(*) LIBRAR, SUBROU, MESSG |
|
|
188 CHARACTER*8 XLIBR, XSUBR |
|
|
189 CHARACTER*72 TEMP |
|
|
190 CHARACTER*20 LFIRST |
|
|
191 C***FIRST EXECUTABLE STATEMENT XERMSG |
|
|
192 LKNTRL = J4SAVE (2, 0, .FALSE.) |
|
|
193 MAXMES = J4SAVE (4, 0, .FALSE.) |
|
|
194 C |
|
|
195 C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. |
|
|
196 C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE |
|
3963
|
197 C SHOULD BE PRINTED. IF MAXMES IS LESS THAN ZERO, THERE IS |
|
|
198 C NO LIMIT. |
|
3274
|
199 C |
|
|
200 C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN |
|
|
201 C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, |
|
|
202 C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. |
|
|
203 C |
|
|
204 IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. |
|
|
205 * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN |
|
|
206 CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // |
|
|
207 * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// |
|
|
208 * 'JOB ABORT DUE TO FATAL ERROR.', 72) |
|
|
209 CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) |
|
|
210 CALL XERHLT (' ***XERMSG -- INVALID INPUT') |
|
|
211 RETURN |
|
|
212 ENDIF |
|
|
213 C |
|
|
214 C RECORD THE MESSAGE. |
|
|
215 C |
|
|
216 I = J4SAVE (1, NERR, .TRUE.) |
|
|
217 CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) |
|
|
218 C |
|
|
219 C HANDLE PRINT-ONCE WARNING MESSAGES. |
|
|
220 C |
|
|
221 IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN |
|
|
222 C |
|
|
223 C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. |
|
|
224 C |
|
|
225 XLIBR = LIBRAR |
|
|
226 XSUBR = SUBROU |
|
|
227 LFIRST = MESSG |
|
|
228 LERR = NERR |
|
|
229 LLEVEL = LEVEL |
|
|
230 CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) |
|
|
231 C |
|
|
232 LKNTRL = MAX(-2, MIN(2,LKNTRL)) |
|
|
233 MKNTRL = ABS(LKNTRL) |
|
|
234 C |
|
|
235 C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS |
|
|
236 C ZERO AND THE ERROR IS NOT FATAL. |
|
|
237 C |
|
|
238 IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 |
|
3963
|
239 IF (LEVEL.EQ.0 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES) GO TO 30 |
|
|
240 IF (LEVEL.EQ.1 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES |
|
|
241 * .AND. MKNTRL.EQ.1) GO TO 30 |
|
|
242 IF (LEVEL.EQ.2 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAX(1,MAXMES)) |
|
|
243 * GO TO 30 |
|
3274
|
244 C |
|
|
245 C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A |
|
|
246 C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) |
|
|
247 C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG |
|
|
248 C IS NOT ZERO. |
|
|
249 C |
|
|
250 IF (LKNTRL .NE. 0) THEN |
|
|
251 TEMP(1:21) = 'MESSAGE FROM ROUTINE ' |
|
|
252 I = MIN(LEN(SUBROU), 16) |
|
|
253 TEMP(22:21+I) = SUBROU(1:I) |
|
|
254 TEMP(22+I:33+I) = ' IN LIBRARY ' |
|
|
255 LTEMP = 33 + I |
|
|
256 I = MIN(LEN(LIBRAR), 16) |
|
|
257 TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) |
|
|
258 TEMP(LTEMP+I+1:LTEMP+I+1) = '.' |
|
|
259 LTEMP = LTEMP + I + 1 |
|
|
260 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) |
|
|
261 ENDIF |
|
|
262 C |
|
|
263 C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE |
|
|
264 C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE |
|
|
265 C FROM EACH OF THE FOLLOWING THREE OPTIONS. |
|
|
266 C 1. LEVEL OF THE MESSAGE |
|
|
267 C 'INFORMATIVE MESSAGE' |
|
|
268 C 'POTENTIALLY RECOVERABLE ERROR' |
|
|
269 C 'FATAL ERROR' |
|
|
270 C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE |
|
|
271 C 'PROG CONTINUES' |
|
|
272 C 'PROG ABORTED' |
|
|
273 C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK |
|
|
274 C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS |
|
|
275 C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) |
|
|
276 C 'TRACEBACK REQUESTED' |
|
|
277 C 'TRACEBACK NOT REQUESTED' |
|
|
278 C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT |
|
|
279 C EXCEED 74 CHARACTERS. |
|
|
280 C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. |
|
|
281 C |
|
|
282 IF (LKNTRL .GT. 0) THEN |
|
|
283 C |
|
|
284 C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. |
|
|
285 C |
|
|
286 IF (LEVEL .LE. 0) THEN |
|
|
287 TEMP(1:20) = 'INFORMATIVE MESSAGE,' |
|
|
288 LTEMP = 20 |
|
|
289 ELSEIF (LEVEL .EQ. 1) THEN |
|
|
290 TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' |
|
|
291 LTEMP = 30 |
|
|
292 ELSE |
|
|
293 TEMP(1:12) = 'FATAL ERROR,' |
|
|
294 LTEMP = 12 |
|
|
295 ENDIF |
|
|
296 C |
|
|
297 C THEN WHETHER THE PROGRAM WILL CONTINUE. |
|
|
298 C |
|
|
299 IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. |
|
|
300 * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN |
|
|
301 TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' |
|
|
302 LTEMP = LTEMP + 14 |
|
|
303 ELSE |
|
|
304 TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' |
|
|
305 LTEMP = LTEMP + 16 |
|
|
306 ENDIF |
|
|
307 C |
|
|
308 C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. |
|
|
309 C |
|
|
310 IF (LKNTRL .GT. 0) THEN |
|
|
311 TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' |
|
|
312 LTEMP = LTEMP + 20 |
|
|
313 ELSE |
|
|
314 TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' |
|
|
315 LTEMP = LTEMP + 24 |
|
|
316 ENDIF |
|
|
317 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) |
|
|
318 ENDIF |
|
|
319 C |
|
|
320 C NOW SEND OUT THE MESSAGE. |
|
|
321 C |
|
|
322 CALL XERPRN (' * ', -1, MESSG, 72) |
|
|
323 C |
|
|
324 C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A |
|
|
325 C TRACEBACK. |
|
|
326 C |
|
|
327 IF (LKNTRL .GT. 0) THEN |
|
|
328 WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR |
|
|
329 DO 10 I=16,22 |
|
|
330 IF (TEMP(I:I) .NE. ' ') GO TO 20 |
|
|
331 10 CONTINUE |
|
|
332 C |
|
|
333 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) |
|
|
334 CALL FDUMP |
|
|
335 ENDIF |
|
|
336 C |
|
|
337 C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. |
|
|
338 C |
|
|
339 IF (LKNTRL .NE. 0) THEN |
|
|
340 CALL XERPRN (' * ', -1, ' ', 72) |
|
|
341 CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) |
|
|
342 CALL XERPRN (' ', 0, ' ', 72) |
|
|
343 ENDIF |
|
|
344 C |
|
|
345 C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE |
|
|
346 C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. |
|
|
347 C |
|
|
348 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN |
|
|
349 C |
|
|
350 C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A |
|
|
351 C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR |
|
|
352 C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. |
|
|
353 C |
|
3963
|
354 IF (LKNTRL.GT.0 |
|
|
355 * .AND. (MAXMES.LT.0 .OR. KOUNT.LT.MAX(1,MAXMES))) THEN |
|
3274
|
356 IF (LEVEL .EQ. 1) THEN |
|
|
357 CALL XERPRN |
|
|
358 * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) |
|
|
359 ELSE |
|
|
360 CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) |
|
|
361 ENDIF |
|
|
362 CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) |
|
|
363 CALL XERHLT (' ') |
|
|
364 ELSE |
|
|
365 CALL XERHLT (MESSG) |
|
|
366 ENDIF |
|
|
367 RETURN |
|
|
368 END |
