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