GCC Code Coverage Report
Directory: ./ Exec Total Coverage
File: misc/xermsg.F Lines: 0 65 0.0 %
Date: 2023-06-30 12:51:15 Branches: 0 80 0.0 %

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