!DECK XERMSG SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) IMPLICIT NONE !***BEGIN PROLOGUE XERMSG !***PURPOSE Process error messages for SLATEC and other libraries. !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERMSG-A) !***KEYWORDS ERROR MESSAGE, XERROR !***AUTHOR Fong, Kirby, (NMFECC at LLNL) !***DESCRIPTION ! ! XERMSG processes a diagnostic message in a manner determined by the ! value of LEVEL and the current value of the library error control ! flag, KONTRL. See subroutine XSETF for details. ! ! LIBRAR A character constant (or character variable) with the name ! of the library. This will be 'SLATEC' for the SLATEC ! Common Math Library. The error handling package is ! general enough to be used by many libraries ! simultaneously, so it is desirable for the routine that ! detects and reports an error to identify the library name ! as well as the routine name. ! ! SUBROU A character constant (or character variable) with the name ! of the routine that detected the error. Usually it is the ! name of the routine that is calling XERMSG. There are ! some instances where a user callable library routine calls ! lower level subsidiary routines where the error is ! detected. In such cases it may be more informative to ! supply the name of the routine the user called rather than ! the name of the subsidiary routine that detected the ! error. ! ! MESSG A character constant (or character variable) with the text ! of the error or warning message. In the example below, ! the message is a character constant that contains a ! generic message. ! ! CALL XERMSG ('SLATEC', 'MMPY', ! *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', ! *3, 1) ! ! It is possible (and is sometimes desirable) to generate a ! specific message--e.g., one that contains actual numeric ! values. Specific numeric values can be converted into ! character strings using formatted WRITE statements into ! character variables. This is called standard Fortran ! internal file I/O and is exemplified in the first three ! lines of the following example. You can also catenate ! substrings of characters to construct the error message. ! Here is an example showing the use of both writing to ! an internal file and catenating character strings. ! ! CHARACTER*5 CHARN, CHARL ! WRITE (CHARN,10) N ! WRITE (CHARL,10) LDA ! 10 FORMAT(I5) ! CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// ! * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// ! * CHARL, 3, 1) ! ! There are two subtleties worth mentioning. One is that ! the // for character catenation is used to construct the ! error message so that no single character constant is ! continued to the next line. This avoids confusion as to ! whether there are trailing blanks at the end of the line. ! The second is that by catenating the parts of the message ! as an actual argument rather than encoding the entire ! message into one large character variable, we avoid ! having to know how long the message will be in order to ! declare an adequate length for that large character ! variable. XERMSG calls XERPRN to print the message using ! multiple lines if necessary. If the message is very long, ! XERPRN will break it into pieces of 72 characters (as ! requested by XERMSG) for printing on multiple lines. ! Also, XERMSG asks XERPRN to prefix each line with ' * ' ! so that the total line length could be 76 characters. ! Note also that XERPRN scans the error message backwards ! to ignore trailing blanks. Another feature is that ! the substring '$$' is treated as a new line sentinel ! by XERPRN. If you want to construct a multiline ! message without having to count out multiples of 72 ! characters, just use '$$' as a separator. '$$' ! obviously must occur within 72 characters of the ! start of each line to have its intended effect since ! XERPRN is asked to wrap around at 72 characters in ! addition to looking for '$$'. ! ! NERR An integer value that is chosen by the library routine's ! author. It must be in the range -99 to 999 (three ! printable digits). Each distinct error should have its ! own error number. These error numbers should be described ! in the machine readable documentation for the routine. ! The error numbers need be unique only within each routine, ! so it is reasonable for each routine to start enumerating ! errors from 1 and proceeding to the next integer. ! ! LEVEL An integer value in the range 0 to 2 that indicates the ! level (severity) of the error. Their meanings are ! ! -1 A warning message. This is used if it is not clear ! that there really is an error, but the user's attention ! may be needed. An attempt is made to only print this ! message once. ! ! 0 A warning message. This is used if it is not clear ! that there really is an error, but the user's attention ! may be needed. ! ! 1 A recoverable error. This is used even if the error is ! so serious that the routine cannot return any useful ! answer. If the user has told the error package to ! return after recoverable errors, then XERMSG will ! return to the Library routine which can then return to ! the user's routine. The user may also permit the error ! package to terminate the program upon encountering a ! recoverable error. ! ! 2 A fatal error. XERMSG will not return to its caller ! after it receives a fatal error. This level should ! hardly ever be used; it is much better to allow the ! user a chance to recover. An example of one of the few ! cases in which it is permissible to declare a level 2 ! error is a reverse communication Library routine that ! is likely to be called repeatedly until it integrates ! across some interval. If there is a serious error in ! the input such that another step cannot be taken and ! the Library routine is called again without the input ! error having been corrected by the caller, the Library ! routine will probably be called forever with improper ! input. In this case, it is reasonable to declare the ! error to be fatal. ! ! Each of the arguments to XERMSG is input; none will be modified by ! XERMSG. A routine may make multiple calls to XERMSG with warning ! level messages; however, after a call to XERMSG with a recoverable ! error, the routine should return to the user. Do not try to call ! XERMSG with a second recoverable error after the first recoverable ! error because the error package saves the error number. The user ! can retrieve this error number by calling another entry point in ! the error handling package and then clear the error number when ! recovering from the error. Calling XERMSG in succession causes the ! old error number to be overwritten by the latest error number. ! This is considered harmless for error numbers associated with ! warning messages but must not be done for error numbers of serious ! errors. After a call to XERMSG with a recoverable error, the user ! must be given a chance to call NUMXER or XERCLR to retrieve or ! clear the error number. !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE !***REVISION HISTORY (YYMMDD) ! 880101 DATE WRITTEN ! 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. ! THERE ARE TWO BASIC CHANGES. ! 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO ! PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES ! INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS ! ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE ! ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER ! ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY ! 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE ! LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. ! 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE ! FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE ! OF LOWER CASE. ! 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. ! THE PRINCIPAL CHANGES ARE ! 1. CLARIFY COMMENTS IN THE PROLOGUES ! 2. RENAME XRPRNT TO XERPRN ! 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES ! SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / ! CHARACTER FOR NEW RECORDS. ! 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO ! CLEAN UP THE CODING. ! 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN ! PREFIX. ! 891013 REVISED TO CORRECT COMMENTS. ! 891214 Prologue converted to Version 4.0 format. (WRB) ! 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but ! NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added ! LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and ! XERCTL to XERCNT. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERMSG CHARACTER(len=*) :: LIBRAR, SUBROU, MESSG CHARACTER(len=8) :: XLIBR, XSUBR CHARACTER(len=72) :: TEMP CHARACTER(len=20) :: LFIRST INTEGER :: NERR, LEVEL, LKNTRL INTEGER :: J4SAVE, MAXMES, KDUMMY, I, KOUNT, LERR, LLEVEL INTEGER :: MKNTRL, LTEMP !***FIRST EXECUTABLE STATEMENT XERMSG LKNTRL = J4SAVE (2, 0, .FALSE.) MAXMES = J4SAVE (4, 0, .FALSE.) ! ! LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. ! MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE ! SHOULD BE PRINTED. ! ! WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN ! CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, ! AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. ! 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 ! ! RECORD THE MESSAGE. ! I = J4SAVE (1, NERR, .TRUE.) CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) ! ! HANDLE PRINT-ONCE WARNING MESSAGES. ! IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN ! ! ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. ! XLIBR = LIBRAR XSUBR = SUBROU LFIRST = MESSG LERR = NERR LLEVEL = LEVEL CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) ! LKNTRL = MAX(-2, MIN(2,LKNTRL)) MKNTRL = ABS(LKNTRL) ! ! SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS ! ZERO AND THE ERROR IS NOT FATAL. ! 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 ! ! ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A ! MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) ! AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG ! IS NOT ZERO. ! 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 ! ! IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE ! PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE ! FROM EACH OF THE FOLLOWING THREE OPTIONS. ! 1. LEVEL OF THE MESSAGE ! 'INFORMATIVE MESSAGE' ! 'POTENTIALLY RECOVERABLE ERROR' ! 'FATAL ERROR' ! 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE ! 'PROG CONTINUES' ! 'PROG ABORTED' ! 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK ! MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS ! WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) ! 'TRACEBACK REQUESTED' ! 'TRACEBACK NOT REQUESTED' ! NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT ! EXCEED 74 CHARACTERS. ! WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. ! IF (LKNTRL .GT. 0) THEN ! ! THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. ! 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 ! ! THEN WHETHER THE PROGRAM WILL CONTINUE. ! 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 ! ! FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. ! 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 ! ! NOW SEND OUT THE MESSAGE. ! CALL XERPRN (' * ', -1, MESSG, 72) ! ! IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A ! TRACEBACK. ! IF (LKNTRL .GT. 0) THEN WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR DO I=16,22 IF (TEMP(I:I) .NE. ' ') GO TO 20 END DO ! 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) CALL FDUMP ENDIF ! ! IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. ! IF (LKNTRL .NE. 0) THEN CALL XERPRN (' * ', -1, ' ', 72) CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) CALL XERPRN (' ', 0, ' ', 72) ENDIF ! ! IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE ! CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. ! 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN ! ! THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A ! FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR ! SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. ! 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 SUBROUTINE XERMSG