+++ /dev/null
-*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
git://source.jalview.org / jabaws.git / blobdiff