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