Ignore:
Timestamp:
Oct 21, 2024, 2:58:45 PM (11 days ago)
Author:
abarral
Message:

Convert fixed-form to free-form sources .F -> .{f,F}90
(WIP: some .F remain, will be handled in subsequent commits)

File:
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/trunk/libf/misc/xermsg.f90

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