00001 *DECK XERMSG 00002 SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) 00003 C***BEGIN PROLOGUE XERMSG 00004 C***PURPOSE Process error messages for SLATEC and other libraries. 00005 C***LIBRARY SLATEC (XERROR) 00006 C***CATEGORY R3C 00007 C***TYPE ALL (XERMSG-A) 00008 C***KEYWORDS ERROR MESSAGE, XERROR 00009 C***AUTHOR Fong, Kirby, (NMFECC at LLNL) 00010 C***DESCRIPTION 00011 C 00012 C XERMSG processes a diagnostic message in a manner determined by the 00013 C value of LEVEL and the current value of the library error control 00014 C flag, KONTRL. See subroutine XSETF for details. 00015 C 00016 C LIBRAR A character constant (or character variable) with the name 00017 C of the library. This will be 'SLATEC' for the SLATEC 00018 C Common Math Library. The error handling package is 00019 C general enough to be used by many libraries 00020 C simultaneously, so it is desirable for the routine that 00021 C detects and reports an error to identify the library name 00022 C as well as the routine name. 00023 C 00024 C SUBROU A character constant (or character variable) with the name 00025 C of the routine that detected the error. Usually it is the 00026 C name of the routine that is calling XERMSG. There are 00027 C some instances where a user callable library routine calls 00028 C lower level subsidiary routines where the error is 00029 C detected. In such cases it may be more informative to 00030 C supply the name of the routine the user called rather than 00031 C the name of the subsidiary routine that detected the 00032 C error. 00033 C 00034 C MESSG A character constant (or character variable) with the text 00035 C of the error or warning message. In the example below, 00036 C the message is a character constant that contains a 00037 C generic message. 00038 C 00039 C CALL XERMSG ('SLATEC', 'MMPY', 00040 C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', 00041 C *3, 1) 00042 C 00043 C It is possible (and is sometimes desirable) to generate a 00044 C specific message--e.g., one that contains actual numeric 00045 C values. Specific numeric values can be converted into 00046 C character strings using formatted WRITE statements into 00047 C character variables. This is called standard Fortran 00048 C internal file I/O and is exemplified in the first three 00049 C lines of the following example. You can also catenate 00050 C substrings of characters to construct the error message. 00051 C Here is an example showing the use of both writing to 00052 C an internal file and catenating character strings. 00053 C 00054 C CHARACTER*5 CHARN, CHARL 00055 C WRITE (CHARN,10) N 00056 C WRITE (CHARL,10) LDA 00057 C 10 FORMAT(I5) 00058 C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// 00059 C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// 00060 C * CHARL, 3, 1) 00061 C 00062 C There are two subtleties worth mentioning. One is that 00063 C the // for character catenation is used to construct the 00064 C error message so that no single character constant is 00065 C continued to the next line. This avoids confusion as to 00066 C whether there are trailing blanks at the end of the line. 00067 C The second is that by catenating the parts of the message 00068 C as an actual argument rather than encoding the entire 00069 C message into one large character variable, we avoid 00070 C having to know how long the message will be in order to 00071 C declare an adequate length for that large character 00072 C variable. XERMSG calls XERPRN to print the message using 00073 C multiple lines if necessary. If the message is very long, 00074 C XERPRN will break it into pieces of 72 characters (as 00075 C requested by XERMSG) for printing on multiple lines. 00076 C Also, XERMSG asks XERPRN to prefix each line with ' * ' 00077 C so that the total line length could be 76 characters. 00078 C Note also that XERPRN scans the error message backwards 00079 C to ignore trailing blanks. Another feature is that 00080 C the substring '$$' is treated as a new line sentinel 00081 C by XERPRN. If you want to construct a multiline 00082 C message without having to count out multiples of 72 00083 C characters, just use '$$' as a separator. '$$' 00084 C obviously must occur within 72 characters of the 00085 C start of each line to have its intended effect since 00086 C XERPRN is asked to wrap around at 72 characters in 00087 C addition to looking for '$$'. 00088 C 00089 C NERR An integer value that is chosen by the library routine's 00090 C author. It must be in the range -99 to 999 (three 00091 C printable digits). Each distinct error should have its 00092 C own error number. These error numbers should be described 00093 C in the machine readable documentation for the routine. 00094 C The error numbers need be unique only within each routine, 00095 C so it is reasonable for each routine to start enumerating 00096 C errors from 1 and proceeding to the next integer. 00097 C 00098 C LEVEL An integer value in the range 0 to 2 that indicates the 00099 C level (severity) of the error. Their meanings are 00100 C 00101 C -1 A warning message. This is used if it is not clear 00102 C that there really is an error, but the user's attention 00103 C may be needed. An attempt is made to only print this 00104 C message once. 00105 C 00106 C 0 A warning message. This is used if it is not clear 00107 C that there really is an error, but the user's attention 00108 C may be needed. 00109 C 00110 C 1 A recoverable error. This is used even if the error is 00111 C so serious that the routine cannot return any useful 00112 C answer. If the user has told the error package to 00113 C return after recoverable errors, then XERMSG will 00114 C return to the Library routine which can then return to 00115 C the user's routine. The user may also permit the error 00116 C package to terminate the program upon encountering a 00117 C recoverable error. 00118 C 00119 C 2 A fatal error. XERMSG will not return to its caller 00120 C after it receives a fatal error. This level should 00121 C hardly ever be used; it is much better to allow the 00122 C user a chance to recover. An example of one of the few 00123 C cases in which it is permissible to declare a level 2 00124 C error is a reverse communication Library routine that 00125 C is likely to be called repeatedly until it integrates 00126 C across some interval. If there is a serious error in 00127 C the input such that another step cannot be taken and 00128 C the Library routine is called again without the input 00129 C error having been corrected by the caller, the Library 00130 C routine will probably be called forever with improper 00131 C input. In this case, it is reasonable to declare the 00132 C error to be fatal. 00133 C 00134 C Each of the arguments to XERMSG is input; none will be modified by 00135 C XERMSG. A routine may make multiple calls to XERMSG with warning 00136 C level messages; however, after a call to XERMSG with a recoverable 00137 C error, the routine should return to the user. Do not try to call 00138 C XERMSG with a second recoverable error after the first recoverable 00139 C error because the error package saves the error number. The user 00140 C can retrieve this error number by calling another entry point in 00141 C the error handling package and then clear the error number when 00142 C recovering from the error. Calling XERMSG in succession causes the 00143 C old error number to be overwritten by the latest error number. 00144 C This is considered harmless for error numbers associated with 00145 C warning messages but must not be done for error numbers of serious 00146 C errors. After a call to XERMSG with a recoverable error, the user 00147 C must be given a chance to call NUMXER or XERCLR to retrieve or 00148 C clear the error number. 00149 C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC 00150 C Error-handling Package, SAND82-0800, Sandia 00151 C Laboratories, 1982. 00152 C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE 00153 C***REVISION HISTORY (YYMMDD) 00154 C 880101 DATE WRITTEN 00155 C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. 00156 C THERE ARE TWO BASIC CHANGES. 00157 C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO 00158 C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES 00159 C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS 00160 C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE 00161 C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER 00162 C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY 00163 C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE 00164 C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. 00165 C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE 00166 C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE 00167 C OF LOWER CASE. 00168 C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. 00169 C THE PRINCIPAL CHANGES ARE 00170 C 1. CLARIFY COMMENTS IN THE PROLOGUES 00171 C 2. RENAME XRPRNT TO XERPRN 00172 C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES 00173 C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / 00174 C CHARACTER FOR NEW RECORDS. 00175 C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO 00176 C CLEAN UP THE CODING. 00177 C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN 00178 C PREFIX. 00179 C 891013 REVISED TO CORRECT COMMENTS. 00180 C 891214 Prologue converted to Version 4.0 format. (WRB) 00181 C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but 00182 C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added 00183 C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and 00184 C XERCTL to XERCNT. (RWC) 00185 C 920501 Reformatted the REFERENCES section. (WRB) 00186 C***END PROLOGUE XERMSG 00187 CHARACTER*(*) LIBRAR, SUBROU, MESSG 00188 CHARACTER*8 XLIBR, XSUBR 00189 CHARACTER*72 TEMP 00190 CHARACTER*20 LFIRST 00191 C***FIRST EXECUTABLE STATEMENT XERMSG 00192 LKNTRL = J4SAVE (2, 0, .FALSE.) 00193 MAXMES = J4SAVE (4, 0, .FALSE.) 00194 C 00195 C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. 00196 C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE 00197 C SHOULD BE PRINTED. IF MAXMES IS LESS THAN ZERO, THERE IS 00198 C NO LIMIT. 00199 C 00200 C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN 00201 C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, 00202 C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. 00203 C 00204 IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. 00205 * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN 00206 CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // 00207 * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// 00208 * 'JOB ABORT DUE TO FATAL ERROR.', 72) 00209 CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) 00210 CALL XERHLT (' ***XERMSG -- INVALID INPUT') 00211 RETURN 00212 ENDIF 00213 C 00214 C RECORD THE MESSAGE. 00215 C 00216 I = J4SAVE (1, NERR, .TRUE.) 00217 CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) 00218 C 00219 C HANDLE PRINT-ONCE WARNING MESSAGES. 00220 C 00221 IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN 00222 C 00223 C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. 00224 C 00225 XLIBR = LIBRAR 00226 XSUBR = SUBROU 00227 LFIRST = MESSG 00228 LERR = NERR 00229 LLEVEL = LEVEL 00230 CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) 00231 C 00232 LKNTRL = MAX(-2, MIN(2,LKNTRL)) 00233 MKNTRL = ABS(LKNTRL) 00234 C 00235 C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS 00236 C ZERO AND THE ERROR IS NOT FATAL. 00237 C 00238 IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 00239 IF (LEVEL.EQ.0 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES) GO TO 30 00240 IF (LEVEL.EQ.1 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES 00241 * .AND. MKNTRL.EQ.1) GO TO 30 00242 IF (LEVEL.EQ.2 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAX(1,MAXMES)) 00243 * GO TO 30 00244 C 00245 C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A 00246 C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) 00247 C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG 00248 C IS NOT ZERO. 00249 C 00250 IF (LKNTRL .NE. 0) THEN 00251 TEMP(1:21) = 'MESSAGE FROM ROUTINE ' 00252 I = MIN(LEN(SUBROU), 16) 00253 TEMP(22:21+I) = SUBROU(1:I) 00254 TEMP(22+I:33+I) = ' IN LIBRARY ' 00255 LTEMP = 33 + I 00256 I = MIN(LEN(LIBRAR), 16) 00257 TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) 00258 TEMP(LTEMP+I+1:LTEMP+I+1) = '.' 00259 LTEMP = LTEMP + I + 1 00260 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) 00261 ENDIF 00262 C 00263 C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE 00264 C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE 00265 C FROM EACH OF THE FOLLOWING THREE OPTIONS. 00266 C 1. LEVEL OF THE MESSAGE 00267 C 'INFORMATIVE MESSAGE' 00268 C 'POTENTIALLY RECOVERABLE ERROR' 00269 C 'FATAL ERROR' 00270 C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE 00271 C 'PROG CONTINUES' 00272 C 'PROG ABORTED' 00273 C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK 00274 C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS 00275 C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) 00276 C 'TRACEBACK REQUESTED' 00277 C 'TRACEBACK NOT REQUESTED' 00278 C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT 00279 C EXCEED 74 CHARACTERS. 00280 C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. 00281 C 00282 IF (LKNTRL .GT. 0) THEN 00283 C 00284 C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. 00285 C 00286 IF (LEVEL .LE. 0) THEN 00287 TEMP(1:20) = 'INFORMATIVE MESSAGE,' 00288 LTEMP = 20 00289 ELSEIF (LEVEL .EQ. 1) THEN 00290 TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' 00291 LTEMP = 30 00292 ELSE 00293 TEMP(1:12) = 'FATAL ERROR,' 00294 LTEMP = 12 00295 ENDIF 00296 C 00297 C THEN WHETHER THE PROGRAM WILL CONTINUE. 00298 C 00299 IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. 00300 * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN 00301 TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' 00302 LTEMP = LTEMP + 14 00303 ELSE 00304 TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' 00305 LTEMP = LTEMP + 16 00306 ENDIF 00307 C 00308 C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. 00309 C 00310 IF (LKNTRL .GT. 0) THEN 00311 TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' 00312 LTEMP = LTEMP + 20 00313 ELSE 00314 TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' 00315 LTEMP = LTEMP + 24 00316 ENDIF 00317 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) 00318 ENDIF 00319 C 00320 C NOW SEND OUT THE MESSAGE. 00321 C 00322 CALL XERPRN (' * ', -1, MESSG, 72) 00323 C 00324 C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A 00325 C TRACEBACK. 00326 C 00327 IF (LKNTRL .GT. 0) THEN 00328 WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR 00329 DO 10 I=16,22 00330 IF (TEMP(I:I) .NE. ' ') GO TO 20 00331 10 CONTINUE 00332 C 00333 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) 00334 CALL FDUMP 00335 ENDIF 00336 C 00337 C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. 00338 C 00339 IF (LKNTRL .NE. 0) THEN 00340 CALL XERPRN (' * ', -1, ' ', 72) 00341 CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) 00342 CALL XERPRN (' ', 0, ' ', 72) 00343 ENDIF 00344 C 00345 C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE 00346 C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. 00347 C 00348 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN 00349 C 00350 C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A 00351 C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR 00352 C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. 00353 C 00354 IF (LKNTRL.GT.0 00355 * .AND. (MAXMES.LT.0 .OR. KOUNT.LT.MAX(1,MAXMES))) THEN 00356 IF (LEVEL .EQ. 1) THEN 00357 CALL XERPRN 00358 * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) 00359 ELSE 00360 CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) 00361 ENDIF 00362 CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) 00363 CALL XERHLT (' ') 00364 ELSE 00365 CALL XERHLT (MESSG) 00366 ENDIF 00367 RETURN 00368 END
1.7.1
