Changeset 5115


Ignore:
Timestamp:
Jul 24, 2024, 1:42:39 PM (7 weeks ago)
Author:
abarral
Message:

Move misc/xer* into lmdz_xer
Note: Why tf do we have 1000 lines of code just to print error messages in an old math module ????....

Location:
LMDZ6/branches/Amaury_dev/libf/misc
Files:
7 deleted
1 edited
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_libmath_pch.f90

    r5113 r5115  
    22
    33MODULE lmdz_libmath_pch
     4  USE lmdz_xer, ONLY: xermsg
    45  IMPLICIT NONE; PRIVATE
    56  PUBLIC pchfe_95, pchsp_95

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_xer.f90

    r5106 r5115  
    1 !DECK XERMSG
    2 SUBROUTINE 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<-9999999 .OR. NERR>99999999 .OR. NERR==0 .OR. &
    208         LEVEL<-1 .OR. LEVEL>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==-1 .AND. KOUNT>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<2 .AND. LKNTRL==0) GO TO 30
    242   IF (LEVEL==0 .AND. KOUNT>MAXMES) GO TO 30
    243   IF (LEVEL==1 .AND. KOUNT>MAXMES .AND. MKNTRL==1) GO TO 30
    244   IF (LEVEL==2 .AND. KOUNT>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 /= 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 > 0) THEN
    284   !
    285   !   THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
    286   !
    287      IF (LEVEL <= 0) THEN
     1! Contains "legacy" xer* functions required by some other very old external code
     2
     3! Amaury (07/24) WTF ??? We have 1000+ lines of code JUST to allow calling xermsg to print some error message !!??
     4! Get rid of this 🤢
     5
     6MODULE lmdz_xer
     7  IMPLICIT NONE; PRIVATE
     8  PUBLIC xermsg
     9CONTAINS
     10
     11  !DECK XERMSG
     12  SUBROUTINE XERMSG(LIBRAR, SUBROU, MESSG, NERR, LEVEL)
     13    IMPLICIT NONE
     14    !***BEGIN PROLOGUE  XERMSG
     15    !***PURPOSE  Process error messages for SLATEC and other libraries.
     16    !***LIBRARY   SLATEC (XERROR)
     17    !***CATEGORY  R3C
     18    !***TYPE      ALL (XERMSG-A)
     19    !***KEYWORDS  ERROR MESSAGE, XERROR
     20    !***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
     21    !***DESCRIPTION
     22    !
     23    !   XERMSG processes a diagnostic message in a manner determined by the
     24    !   value of LEVEL and the current value of the library error control
     25    !   flag, KONTRL.  See SUBROUTINE XSETF for details.
     26    !
     27    !    LIBRAR   A character constant (or character variable) with the name
     28    !         of the library.  This will be 'SLATEC' for the SLATEC
     29    !         Common Math Library.  The error handling package is
     30    !         general enough to be used by many libraries
     31    !         simultaneously, so it is desirable for the routine that
     32    !         detects and reports an error to identify the library name
     33    !         as well as the routine name.
     34    !
     35    !    SUBROU   A character constant (or character variable) with the name
     36    !             of the routine that detected the error.  Usually it is the
     37    !         name of the routine that is calling XERMSG.  There are
     38    !         some instances where a user callable library routine calls
     39    !         lower level subsidiary routines where the error is
     40    !         detected.  In such cases it may be more informative to
     41    !         supply the name of the routine the user called rather than
     42    !         the name of the subsidiary routine that detected the
     43    !         error.
     44    !
     45    !    MESSG    A character constant (or character variable) with the text
     46    !         of the error or warning message.  In the example below,
     47    !         the message is a character constant that contains a
     48    !         generic message.
     49    !
     50    !               CALL XERMSG ('SLATEC', 'MMPY',
     51    !              *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
     52    !              *3, 1)
     53    !
     54    !         It is possible (and is sometimes desirable) to generate a
     55    !         specific message--e.g., one that contains actual numeric
     56    !         values.  Specific numeric values can be converted into
     57    !         character strings using formatted WRITE statements into
     58    !         character variables.  This is called standard Fortran
     59    !         internal file I/O and is exemplified in the first three
     60    !         lines of the following example.  You can also catenate
     61    !         substrings of characters to construct the error message.
     62    !         Here is an example showing the use of both writing to
     63    !         an internal file and catenating character strings.
     64    !
     65    !               CHARACTER*5 CHARN, CHARL
     66    !               WRITE (CHARN,10) N
     67    !               WRITE (CHARL,10) LDA
     68    !            10 FORMAT(I5)
     69    !               CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
     70    !              *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
     71    !              *   CHARL, 3, 1)
     72    !
     73    !         There are two subtleties worth mentioning.  One is that
     74    !         the // for character catenation is used to construct the
     75    !         error message so that no single character constant is
     76    !         continued to the next line.  This avoids confusion as to
     77    !         whether there are trailing blanks at the end of the line.
     78    !         The second is that by catenating the parts of the message
     79    !             as an actual argument rather than encoding the entire
     80    !         message into one large character variable, we avoid
     81    !         having to know how long the message will be in order to
     82    !         declare an adequate length for that large character
     83    !         variable.  XERMSG calls XERPRN to print the message using
     84    !         multiple lines if necessary.  If the message is very long,
     85    !         XERPRN will break it into pieces of 72 characters (as
     86    !         requested by XERMSG) for printing on multiple lines.
     87    !         Also, XERMSG asks XERPRN to prefix each line with ' *  '
     88    !         so that the total line length could be 76 characters.
     89    !         Note also that XERPRN scans the error message backwards
     90    !         to ignore trailing blanks.  Another feature is that
     91    !         the substring '$$' is treated as a new line sentinel
     92    !         by XERPRN.  If you want to construct a multiline
     93    !         message without having to count out multiples of 72
     94    !         characters, just use '$$' as a separator.  '$$'
     95    !         obviously must occur within 72 characters of the
     96    !         start of each line to have its intended effect since
     97    !         XERPRN is asked to wrap around at 72 characters in
     98    !         addition to looking for '$$'.
     99    !
     100    !    NERR     An integer value that is chosen by the library routine's
     101    !         author.  It must be in the range -99 to 999 (three
     102    !         printable digits).  Each distinct error should have its
     103    !         own error number.  These error numbers should be described
     104    !         in the machine readable documentation for the routine.
     105    !         The error numbers need be unique only within each routine,
     106    !         so it is reasonable for each routine to start enumerating
     107    !         errors from 1 and proceeding to the next integer.
     108    !
     109    !    LEVEL    An integer value in the range 0 to 2 that indicates the
     110    !         level (severity) of the error.  Their meanings are
     111    !
     112    !        -1  A warning message.  This is used if it is not clear
     113    !            that there really is an error, but the user's attention
     114    !            may be needed.  An attempt is made to only print this
     115    !            message once.
     116    !
     117    !         0  A warning message.  This is used if it is not clear
     118    !            that there really is an error, but the user's attention
     119    !            may be needed.
     120    !
     121    !         1  A recoverable error.  This is used even if the error is
     122    !            so serious that the routine cannot return any useful
     123    !            answer.  If the user has told the error package to
     124    !            return after recoverable errors, then XERMSG will
     125    !            return to the Library routine which can then return to
     126    !            the user's routine.  The user may also permit the error
     127    !            package to terminate the program upon encountering a
     128    !            recoverable error.
     129    !
     130    !         2  A fatal error.  XERMSG will not return to its caller
     131    !            after it receives a fatal error.  This level should
     132    !            hardly ever be used; it is much better to allow the
     133    !            user a chance to recover.  An example of one of the few
     134    !            cases in which it is permissible to declare a level 2
     135    !            error is a reverse communication Library routine that
     136    !            is likely to be called repeatedly until it integrates
     137    !            across some interval.  If there is a serious error in
     138    !            the input such that another step cannot be taken and
     139    !            the Library routine is called again without the input
     140    !            error having been corrected by the caller, the Library
     141    !            routine will probably be called forever with improper
     142    !            input.  In this case, it is reasonable to declare the
     143    !            error to be fatal.
     144    !
     145    !    Each of the arguments to XERMSG is input; none will be modified by
     146    !    XERMSG.  A routine may make multiple calls to XERMSG with warning
     147    !    level messages; however, after a CALL to XERMSG with a recoverable
     148    !    error, the routine should return to the user.  Do not try to call
     149    !    XERMSG with a second recoverable error after the first recoverable
     150    !    error because the error package saves the error number.  The user
     151    !    can retrieve this error number by calling another entry point in
     152    !    the error handling package and then clear the error number when
     153    !    recovering from the error.  Calling XERMSG in succession causes the
     154    !    old error number to be overwritten by the latest error number.
     155    !    This is considered harmless for error numbers associated with
     156    !    warning messages but must not be done for error numbers of serious
     157    !    errors.  After a CALL to XERMSG with a recoverable error, the user
     158    !    must be given a chance to CALL NUMXER or XERCLR to retrieve or
     159    !    clear the error number.
     160    !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
     161    !             Error-handling Package, SAND82-0800, Sandia
     162    !             Laboratories, 1982.
     163    !***ROUTINES CALLED  FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
     164    !***REVISION HISTORY  (YYMMDD)
     165    !   880101  DATE WRITTEN
     166    !   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
     167    !       THERE ARE TWO BASIC CHANGES.
     168    !       1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
     169    !           PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
     170    !           INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
     171    !           ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
     172    !           ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
     173    !           ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
     174    !           72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
     175    !           LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
     176    !       2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
     177    !           FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
     178    !           OF LOWER CASE.
     179    !   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
     180    !       THE PRINCIPAL CHANGES ARE
     181    !       1.  CLARIFY COMMENTS IN THE PROLOGUES
     182    !       2.  RENAME XRPRNT TO XERPRN
     183    !       3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
     184    !           SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
     185    !           CHARACTER FOR NEW RECORDS.
     186    !   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
     187    !       CLEAN UP THE CODING.
     188    !   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
     189    !       PREFIX.
     190    !   891013  REVISED TO CORRECT COMMENTS.
     191    !   891214  Prologue converted to Version 4.0 format.  (WRB)
     192    !   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
     193    !       NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
     194    !       LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
     195    !       XERCTL to XERCNT.  (RWC)
     196    !   920501  Reformatted the REFERENCES section.  (WRB)
     197    !***END PROLOGUE  XERMSG
     198    CHARACTER(len = *) :: LIBRAR, SUBROU, MESSG
     199    CHARACTER(len = 8) :: XLIBR, XSUBR
     200    CHARACTER(len = 72) :: TEMP
     201    CHARACTER(len = 20) :: LFIRST
     202    INTEGER :: NERR, LEVEL, LKNTRL
     203    INTEGER :: J4SAVE, MAXMES, KDUMMY, I, KOUNT, LERR, LLEVEL
     204    INTEGER :: MKNTRL, LTEMP
     205    !***FIRST EXECUTABLE STATEMENT  XERMSG
     206    LKNTRL = J4SAVE (2, 0, .FALSE.)
     207    MAXMES = J4SAVE (4, 0, .FALSE.)
     208    !
     209    !   LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
     210    !   MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
     211    !      SHOULD BE PRINTED.
     212    !
     213    !   WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
     214    !      CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
     215    !      AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
     216    !
     217    IF (NERR<-9999999 .OR. NERR>99999999 .OR. NERR==0 .OR. &
     218            LEVEL<-1 .OR. LEVEL>2) THEN
     219      CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // &
     220              'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ ' // &
     221              'JOB ABORT DUE TO FATAL ERROR.', 72)
     222      CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
     223      CALL XERHLT (' ***XERMSG -- INVALID INPUT')
     224      RETURN
     225    ENDIF
     226    !
     227    !   RECORD THE MESSAGE.
     228    !
     229    I = J4SAVE (1, NERR, .TRUE.)
     230    CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
     231    !
     232    !   HANDLE PRINT-ONCE WARNING MESSAGES.
     233    !
     234    IF (LEVEL==-1 .AND. KOUNT>1) RETURN
     235    !
     236    !   ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
     237    !
     238    XLIBR = LIBRAR
     239    XSUBR = SUBROU
     240    LFIRST = MESSG
     241    LERR = NERR
     242    LLEVEL = LEVEL
     243    CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
     244    !
     245    LKNTRL = MAX(-2, MIN(2, LKNTRL))
     246    MKNTRL = ABS(LKNTRL)
     247    !
     248    !   SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
     249    !   ZERO AND THE ERROR IS NOT FATAL.
     250    !
     251    IF (LEVEL<2 .AND. LKNTRL==0) GO TO 30
     252    IF (LEVEL==0 .AND. KOUNT>MAXMES) GO TO 30
     253    IF (LEVEL==1 .AND. KOUNT>MAXMES .AND. MKNTRL==1) GO TO 30
     254    IF (LEVEL==2 .AND. KOUNT>MAX(1, MAXMES)) GO TO 30
     255    !
     256    !   ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
     257    !   MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
     258    !   AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
     259    !   IS NOT ZERO.
     260    !
     261    IF (LKNTRL /= 0) THEN
     262      TEMP(1:21) = 'MESSAGE FROM ROUTINE '
     263      I = MIN(LEN(SUBROU), 16)
     264      TEMP(22:21 + I) = SUBROU(1:I)
     265      TEMP(22 + I:33 + I) = ' IN LIBRARY '
     266      LTEMP = 33 + I
     267      I = MIN(LEN(LIBRAR), 16)
     268      TEMP(LTEMP + 1:LTEMP + I) = LIBRAR (1:I)
     269      TEMP(LTEMP + I + 1:LTEMP + I + 1) = '.'
     270      LTEMP = LTEMP + I + 1
     271      CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
     272    ENDIF
     273    !
     274    !   IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
     275    !   PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
     276    !   FROM EACH OF THE FOLLOWING THREE OPTIONS.
     277    !   1.  LEVEL OF THE MESSAGE
     278    !          'INFORMATIVE MESSAGE'
     279    !          'POTENTIALLY RECOVERABLE ERROR'
     280    !          'FATAL ERROR'
     281    !   2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
     282    !          'PROG CONTINUES'
     283    !          'PROG ABORTED'
     284    !   3.  WHETHER OR NOT A TRACEBACK WAS REQUESTED.  (THE TRACEBACK
     285    !       MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
     286    !       WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
     287    !          'TRACEBACK REQUESTED'
     288    !          'TRACEBACK NOT REQUESTED'
     289    !   NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
     290    !   EXCEED 74 CHARACTERS.
     291    !   WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
     292    !
     293    IF (LKNTRL > 0) THEN
     294      !
     295      !   THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
     296      !
     297      IF (LEVEL <= 0) THEN
    288298        TEMP(1:20) = 'INFORMATIVE MESSAGE,'
    289299        LTEMP = 20
    290      ELSEIF (LEVEL == 1) THEN
     300      ELSEIF (LEVEL == 1) THEN
    291301        TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
    292302        LTEMP = 30
    293      ELSE
     303      ELSE
    294304        TEMP(1:12) = 'FATAL ERROR,'
    295305        LTEMP = 12
    296      ENDIF
    297   !
    298   !   THEN WHETHER THE PROGRAM WILL CONTINUE.
    299   !
    300      IF ((MKNTRL==2 .AND. LEVEL>=1) .OR. &
    301            (MKNTRL==1 .AND. LEVEL==2)) THEN
    302         TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,'
     306      ENDIF
     307      !
     308      !   THEN WHETHER THE PROGRAM WILL CONTINUE.
     309      !
     310      IF ((MKNTRL==2 .AND. LEVEL>=1) .OR. &
     311              (MKNTRL==1 .AND. LEVEL==2)) THEN
     312        TEMP(LTEMP + 1:LTEMP + 14) = ' PROG ABORTED,'
    303313        LTEMP = LTEMP + 14
    304      ELSE
    305         TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,'
     314      ELSE
     315        TEMP(LTEMP + 1:LTEMP + 16) = ' PROG CONTINUES,'
    306316        LTEMP = LTEMP + 16
    307      ENDIF
    308   !
    309   !   FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
    310   !
    311      IF (LKNTRL > 0) THEN
    312         TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED'
     317      ENDIF
     318      !
     319      !   FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
     320      !
     321      IF (LKNTRL > 0) THEN
     322        TEMP(LTEMP + 1:LTEMP + 20) = ' TRACEBACK REQUESTED'
    313323        LTEMP = LTEMP + 20
    314      ELSE
    315         TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'
     324      ELSE
     325        TEMP(LTEMP + 1:LTEMP + 24) = ' TRACEBACK NOT REQUESTED'
    316326        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 > 0) THEN
    329      WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
    330      DO I=16,22
     327      ENDIF
     328      CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
     329    ENDIF
     330    !
     331    !   NOW SEND OUT THE MESSAGE.
     332    !
     333    CALL XERPRN (' *  ', -1, MESSG, 72)
     334    !
     335    !   IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
     336    !      TRACEBACK.
     337    !
     338    IF (LKNTRL > 0) THEN
     339      WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
     340      DO I = 16, 22
    331341        IF (TEMP(I:I) /= ' ') 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 /= 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<=0 .OR. (LEVEL==1 .AND. MKNTRL<=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>0 .AND. KOUNT<MAX(1,MAXMES)) THEN
    356      IF (LEVEL == 1) THEN
     342      END DO
     343      !
     344      20   CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
     345    ENDIF
     346    !
     347    !   IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
     348    !
     349    IF (LKNTRL /= 0) THEN
     350      CALL XERPRN (' *  ', -1, ' ', 72)
     351      CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
     352      CALL XERPRN ('    ', 0, ' ', 72)
     353    ENDIF
     354    !
     355    !   IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
     356    !   CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
     357    !
     358    30   IF (LEVEL<=0 .OR. (LEVEL==1 .AND. MKNTRL<=1)) RETURN
     359    !
     360    !   THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
     361    !   FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
     362    !   SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
     363    !
     364    IF (LKNTRL>0 .AND. KOUNT<MAX(1, MAXMES)) THEN
     365      IF (LEVEL == 1) THEN
    357366        CALL XERPRN &
    358               (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
    359      ELSE
     367                (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
     368      ELSE
    360369        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 
    368 END SUBROUTINE XERMSG
     370      ENDIF
     371      CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
     372      CALL XERHLT (' ')
     373    ELSE
     374      CALL XERHLT (MESSG)
     375    ENDIF
     376
     377  END SUBROUTINE XERMSG
     378
     379  !DECK I1MACH
     380  INTEGER FUNCTION I1MACH(I)
     381    IMPLICIT NONE
     382    !***BEGIN PROLOGUE  I1MACH
     383    !***PURPOSE  Return integer machine dependent constants.
     384    !***LIBRARY   SLATEC
     385    !***CATEGORY  R1
     386    !***TYPE      INTEGER (I1MACH-I)
     387    !***KEYWORDS  MACHINE CONSTANTS
     388    !***AUTHOR  Fox, P. A., (Bell Labs)
     389    ! Hall, A. D., (Bell Labs)
     390    ! Schryer, N. L., (Bell Labs)
     391    !***DESCRIPTION
     392    !
     393    !   I1MACH can be used to obtain machine-dependent parameters for the
     394    !   local machine environment.  It is a function subprogram with one
     395    !   (input) argument and can be referenced as follows:
     396    !
     397    !    K = I1MACH(I)
     398    !
     399    !   where I=1,...,16.  The (output) value of K above is determined by
     400    !   the (input) value of I.  The results for various values of I are
     401    !   discussed below.
     402    !
     403    !   I/O unit numbers:
     404    ! I1MACH( 1) = the standard input unit.
     405    ! I1MACH( 2) = the standard output unit.
     406    ! I1MACH( 3) = the standard punch unit.
     407    ! I1MACH( 4) = the standard error message unit.
     408    !
     409    !   Words:
     410    ! I1MACH( 5) = the number of bits per integer storage unit.
     411    ! I1MACH( 6) = the number of characters per integer storage unit.
     412    !
     413    !   Integers:
     414    ! assume integers are represented in the S-digit, base-A form
     415    !
     416    !            sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
     417    !
     418    !            where 0 .LE. X(I) .LT. A for I=0,...,S-1.
     419    ! I1MACH( 7) = A, the base.
     420    ! I1MACH( 8) = S, the number of base-A digits.
     421    ! I1MACH( 9) = A**S - 1, the largest magnitude.
     422    !
     423    !   Floating-Point Numbers:
     424    ! Assume floating-point numbers are represented in the T-digit,
     425    ! base-B form
     426    !            sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
     427    !
     428    !            where 0 .LE. X(I) .LT. B for I=1,...,T,
     429    !            0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
     430    ! I1MACH(10) = B, the base.
     431    !
     432    !   Single-Precision:
     433    ! I1MACH(11) = T, the number of base-B digits.
     434    ! I1MACH(12) = EMIN, the smallest exponent E.
     435    ! I1MACH(13) = EMAX, the largest exponent E.
     436    !
     437    !   Double-Precision:
     438    ! I1MACH(14) = T, the number of base-B digits.
     439    ! I1MACH(15) = EMIN, the smallest exponent E.
     440    ! I1MACH(16) = EMAX, the largest exponent E.
     441    !
     442    !   To alter this function for a particular environment, the desired
     443    !   set of DATA statements should be activated by removing the C from
     444    !   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
     445    !   checked for consistency with the local operating system.
     446    !
     447    !***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
     448    !             a portable library, ACM Transactions on Mathematical
     449    !             Software 4, 2 (June 1978), pp. 177-188.
     450    !***ROUTINES CALLED  (NONE)
     451    !***REVISION HISTORY  (YYMMDD)
     452    !   750101  DATE WRITTEN
     453    !   891012  Added VAX G-floating constants.  (WRB)
     454    !   891012  REVISION DATE from Version 3.2
     455    !   891214  Prologue converted to Version 4.0 format.  (BAB)
     456    !   900618  Added DEC RISC constants.  (WRB)
     457    !   900723  Added IBM RS 6000 constants.  (WRB)
     458    !   901009  Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
     459    !       (RWC)
     460    !   910710  Added HP 730 constants.  (SMR)
     461    !   911114  Added Convex IEEE constants.  (WRB)
     462    !   920121  Added SUN -r8 compiler option constants.  (WRB)
     463    !   920229  Added Touchstone Delta i860 constants.  (WRB)
     464    !   920501  Reformatted the REFERENCES section.  (WRB)
     465    !   920625  Added Convex -p8 and -pd8 compiler option constants.
     466    !       (BKS, WRB)
     467    !   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
     468    !   930618  Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
     469    !       options.  (DWL, RWC and WRB).
     470    !   100623  Use Fortran 95 intrinsic functions (Lionel GUEZ)
     471    !***END PROLOGUE  I1MACH
     472    !
     473    INTEGER :: IMACH(16), OUTPUT
     474    SAVE IMACH
     475    EQUIVALENCE (IMACH(4), OUTPUT)
     476    INTEGER :: I
     477    !***FIRST EXECUTABLE STATEMENT  I1MACH
     478    IMACH(1) = 5
     479    IMACH(2) = 6
     480    IMACH(3) = 6
     481    IMACH(4) = 6
     482    IMACH(5) = bit_size(0)
     483    IMACH(6) = IMACH(5) / 8
     484    IMACH(7) = radix(0)
     485    IMACH(8) = digits(0)
     486    IMACH(9) = huge(0)
     487    IMACH(10) = radix(0.)
     488    IMACH(11) = digits(0.)
     489    IMACH(12) = minexponent(0.)
     490    IMACH(13) = maxexponent(0.)
     491    IMACH(14) = digits(0d0)
     492    IMACH(15) = minexponent(0d0)
     493    IMACH(16) = maxexponent(0d0)
     494    IF (I < 1  .OR.  I > 16) GO TO 10
     495    !
     496    I1MACH = IMACH(I)
     497    RETURN
     498    !
     499    10   CONTINUE
     500    WRITE (UNIT = OUTPUT, FMT = 9000)
     501    9000   FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
     502    !
     503    ! CALL FDUMP
     504    !
     505    STOP
     506  END FUNCTION I1MACH
     507
     508  !DECK XGETUA
     509  SUBROUTINE XGETUA(IUNITA, N)
     510    IMPLICIT NONE
     511    !***BEGIN PROLOGUE  XGETUA
     512    !***PURPOSE  Return unit number(s) to which error messages are being
     513    ! sent.
     514    !***LIBRARY   SLATEC (XERROR)
     515    !***CATEGORY  R3C
     516    !***TYPE      ALL (XGETUA-A)
     517    !***KEYWORDS  ERROR, XERROR
     518    !***AUTHOR  Jones, R. E., (SNLA)
     519    !***DESCRIPTION
     520    !
     521    ! Abstract
     522    !    XGETUA may be called to determine the unit number or numbers
     523    !    to which error messages are being sent.
     524    !    These unit numbers may have been set by a CALL to XSETUN,
     525    !    or a CALL to XSETUA, or may be a default value.
     526    !
     527    ! Description of Parameters
     528    !  --Output--
     529    !    IUNIT - an array of one to five unit numbers, depending
     530    !            on the value of N.  A value of zero refers to the
     531    !            default unit, as defined by the I1MACH machine
     532    !            constant routine.  Only IUNIT(1),...,IUNIT(N) are
     533    !            defined by XGETUA.  The values of IUNIT(N+1),...,
     534    !            IUNIT(5) are not defined (for N .LT. 5) or altered
     535    !            in any way by XGETUA.
     536    !    N     - the number of units to which copies of the
     537    !            error messages are being sent.  N will be in the
     538    !            range from 1 to 5.
     539    !
     540    !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
     541    !             Error-handling Package, SAND82-0800, Sandia
     542    !             Laboratories, 1982.
     543    !***ROUTINES CALLED  J4SAVE
     544    !***REVISION HISTORY  (YYMMDD)
     545    !   790801  DATE WRITTEN
     546    !   861211  REVISION DATE from Version 3.2
     547    !   891214  Prologue converted to Version 4.0 format.  (BAB)
     548    !   920501  Reformatted the REFERENCES section.  (WRB)
     549    !***END PROLOGUE  XGETUA
     550    DIMENSION IUNITA(5)
     551    INTEGER :: IUNITA, N, J4SAVE, INDEX, I
     552    !***FIRST EXECUTABLE STATEMENT  XGETUA
     553    N = J4SAVE(5, 0, .FALSE.)
     554    DO I = 1, N
     555      INDEX = I + 4
     556      IF (I==1) INDEX = 3
     557      IUNITA(I) = J4SAVE(INDEX, 0, .FALSE.)
     558    END DO
     559
     560  END SUBROUTINE XGETUA
     561
     562  !DECK XERSVE
     563  SUBROUTINE XERSVE(LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, &
     564          ICOUNT)
     565    IMPLICIT NONE
     566    !***BEGIN PROLOGUE  XERSVE
     567    !***SUBSIDIARY
     568    !***PURPOSE  Record that an error has occurred.
     569    !***LIBRARY   SLATEC (XERROR)
     570    !***CATEGORY  R3
     571    !***TYPE      ALL (XERSVE-A)
     572    !***KEYWORDS  ERROR, XERROR
     573    !***AUTHOR  Jones, R. E., (SNLA)
     574    !***DESCRIPTION
     575    !
     576    ! *Usage:
     577    !
     578    !    INTEGER  KFLAG, NERR, LEVEL, ICOUNT
     579    !    CHARACTER * (len) LIBRAR, SUBROU, MESSG
     580    !
     581    !    CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
     582    !
     583    ! *Arguments:
     584    !
     585    !    LIBRAR :IN    is the library that the message is from.
     586    !    SUBROU :IN    is the SUBROUTINE that the message is from.
     587    !    MESSG  :IN    is the message to be saved.
     588    !    KFLAG  :IN    indicates the action to be performed.
     589    !                  when KFLAG > 0, the message in MESSG is saved.
     590    !                  when KFLAG=0 the tables will be dumped and
     591    !                  cleared.
     592    !                  when KFLAG < 0, the tables will be dumped and
     593    !                  not cleared.
     594    !    NERR   :IN    is the error number.
     595    !    LEVEL  :IN    is the error severity.
     596    !    ICOUNT :OUT   the number of times this message has been seen,
     597    !                  or zero if the table has overflowed and does not
     598    !                  contain this message specifically.  When KFLAG=0,
     599    !                  ICOUNT will not be altered.
     600    !
     601    ! *Description:
     602    !
     603    !   Record that this error occurred and possibly dump and clear the
     604    !   tables.
     605    !
     606    !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
     607    !             Error-handling Package, SAND82-0800, Sandia
     608    !             Laboratories, 1982.
     609    !***ROUTINES CALLED  I1MACH, XGETUA
     610    !***REVISION HISTORY  (YYMMDD)
     611    !   800319  DATE WRITTEN
     612    !   861211  REVISION DATE from Version 3.2
     613    !   891214  Prologue converted to Version 4.0 format.  (BAB)
     614    !   900413  Routine modified to remove reference to KFLAG.  (WRB)
     615    !   900510  Changed to add LIBRARY NAME and SUBROUTINE to calling
     616    !       sequence, use IF-THEN-ELSE, make number of saved entries
     617    !       easily changeable, changed routine name from XERSAV to
     618    !       XERSVE.  (RWC)
     619    !   910626  Added LIBTAB and SUBTAB to SAVE statement.  (BKS)
     620    !   920501  Reformatted the REFERENCES section.  (WRB)
     621    !***END PROLOGUE  XERSVE
     622    INTEGER, PARAMETER :: LENTAB = 10
     623    INTEGER :: LUN(5)
     624    CHARACTER(len = *) :: LIBRAR, SUBROU, MESSG
     625    CHARACTER(len = 8) :: LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
     626    CHARACTER(len = 20) :: MESTAB(LENTAB), MES
     627    DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
     628    SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
     629    DATA KOUNTX/0/, NMSG/0/
     630    INTEGER :: NERR, LEVEL, KONTRL
     631    INTEGER :: NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
     632    INTEGER :: KFLAG, ICOUNT, NUNIT, KUNIT, IUNIT, I1MACH, I
     633    !***FIRST EXECUTABLE STATEMENT  XERSVE
     634    !
     635    IF (KFLAG<=0) THEN
     636      !
     637      !    Dump the table.
     638      !
     639      IF (NMSG==0) RETURN
     640      !
     641      !    Print to each unit.
     642      !
     643      CALL XGETUA (LUN, NUNIT)
     644      DO KUNIT = 1, NUNIT
     645        IUNIT = LUN(KUNIT)
     646        IF (IUNIT==0) IUNIT = I1MACH(4)
     647        !
     648        !       Print the table header.
     649        !
     650        WRITE (IUNIT, 9000)
     651        !
     652        !       Print body of table.
     653        !
     654        DO I = 1, NMSG
     655          WRITE (IUNIT, 9010) LIBTAB(I), SUBTAB(I), MESTAB(I), &
     656                  NERTAB(I), LEVTAB(I), KOUNT(I)
     657        END DO
     658        !
     659        !       Print number of other errors.
     660        !
     661        IF (KOUNTX/=0) WRITE (IUNIT, 9020) KOUNTX
     662        WRITE (IUNIT, 9030)
     663      END DO
     664      !
     665      !    Clear the error tables.
     666      !
     667      IF (KFLAG==0) THEN
     668        NMSG = 0
     669        KOUNTX = 0
     670      ENDIF
     671    ELSE
     672      !
     673      !    PROCESS A MESSAGE...
     674      !    SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
     675      !    OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
     676      !
     677      LIB = LIBRAR
     678      SUB = SUBROU
     679      MES = MESSG
     680      DO I = 1, NMSG
     681        IF (LIB==LIBTAB(I) .AND. SUB==SUBTAB(I) .AND. &
     682                MES==MESTAB(I) .AND. NERR==NERTAB(I) .AND. &
     683                LEVEL==LEVTAB(I)) THEN
     684          KOUNT(I) = KOUNT(I) + 1
     685          ICOUNT = KOUNT(I)
     686          RETURN
     687        ENDIF
     688      END DO
     689      !
     690      IF (NMSG<LENTAB) THEN
     691        !
     692        !       Empty slot found for new message.
     693        !
     694        NMSG = NMSG + 1
     695        LIBTAB(I) = LIB
     696        SUBTAB(I) = SUB
     697        MESTAB(I) = MES
     698        NERTAB(I) = NERR
     699        LEVTAB(I) = LEVEL
     700        KOUNT (I) = 1
     701        ICOUNT = 1
     702      ELSE
     703        !
     704        !       Table is full.
     705        !
     706        KOUNTX = KOUNTX + 1
     707        ICOUNT = 0
     708      ENDIF
     709    ENDIF
     710    RETURN
     711    !
     712    ! Formats.
     713    !
     714    9000   FORMAT ('0          ERROR MESSAGE SUMMARY' / &
     715            ' LIBRARY    SUBROUTINE MESSAGE START             NERR', &
     716            '     LEVEL     COUNT')
     717    9010   FORMAT (1X, A, 3X, A, 3X, A, 3I10)
     718    9020   FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
     719    9030   FORMAT (1X)
     720  END SUBROUTINE XERSVE
     721
     722  !DECK XERPRN
     723  SUBROUTINE XERPRN(PREFIX, NPREF, MESSG, NWRAP)
     724    IMPLICIT NONE
     725    !***BEGIN PROLOGUE  XERPRN
     726    !***SUBSIDIARY
     727    !***PURPOSE  Print error messages processed by XERMSG.
     728    !***LIBRARY   SLATEC (XERROR)
     729    !***CATEGORY  R3C
     730    !***TYPE      ALL (XERPRN-A)
     731    !***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
     732    !***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
     733    !***DESCRIPTION
     734    !
     735    ! This routine sends one or more lines to each of the (up to five)
     736    ! logical units to which error messages are to be sent.  This routine
     737    ! is called several times by XERMSG, sometimes with a single line to
     738    ! print and sometimes with a (potentially very long) message that may
     739    ! wrap around into multiple lines.
     740    !
     741    ! PREFIX  Input argument of type CHARACTER.  This argument contains
     742    !     characters to be put at the beginning of each line before
     743    !     the body of the message.  No more than 16 characters of
     744    !     PREFIX will be used.
     745    !
     746    ! NPREF   Input argument of type INTEGER.  This argument is the number
     747    !     of characters to use from PREFIX.  If it is negative, the
     748    !     intrinsic function LEN is used to determine its length.  If
     749    !         it is zero, PREFIX is not used.  If it exceeds 16 or if
     750    !     LEN(PREFIX) exceeds 16, only the first 16 characters will be
     751    !     used.  If NPREF is positive and the length of PREFIX is less
     752    !     than NPREF, a copy of PREFIX extended with blanks to length
     753    !     NPREF will be used.
     754    !
     755    ! MESSG   Input argument of type CHARACTER.  This is the text of a
     756    !     message to be printed.  If it is a long message, it will be
     757    !     broken into pieces for printing on multiple lines.  Each line
     758    !     will start with the appropriate prefix and be followed by a
     759    !     piece of the message.  NWRAP is the number of characters per
     760    !     piece; that is, after each NWRAP characters, we break and
     761    !     start a new line.  In addition the characters '$$' embedded
     762    !     in MESSG are a sentinel for a new line.  The counting of
     763    !     characters up to NWRAP starts over for each new line.  The
     764    !     value of NWRAP typically used by XERMSG is 72 since many
     765    !     older error messages in the SLATEC Library are laid out to
     766    !     rely on wrap-around every 72 characters.
     767    !
     768    ! NWRAP   Input argument of type INTEGER.  This gives the maximum size
     769    !     piece into which to break MESSG for printing on multiple
     770    !     lines.  An embedded '$$' ends a line, and the count restarts
     771    !     at the following character.  If a line break does not occur
     772    !     on a blank (it would split a word) that word is moved to the
     773    !     next line.  Values of NWRAP less than 16 will be treated as
     774    !     16.  Values of NWRAP greater than 132 will be treated as 132.
     775    !     The actual line length will be NPREF + NWRAP after NPREF has
     776    !     been adjusted to fall between 0 and 16 and NWRAP has been
     777    !     adjusted to fall between 16 and 132.
     778    !
     779    !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
     780    !             Error-handling Package, SAND82-0800, Sandia
     781    !             Laboratories, 1982.
     782    !***ROUTINES CALLED  I1MACH, XGETUA
     783    !***REVISION HISTORY  (YYMMDD)
     784    !   880621  DATE WRITTEN
     785    !   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
     786    !       JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
     787    !       THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
     788    !       SLASH CHARACTER IN FORMAT STATEMENTS.
     789    !   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
     790    !       STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
     791    !       LINES TO BE PRINTED.
     792    !   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
     793    !       CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
     794    !   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
     795    !   891214  Prologue converted to Version 4.0 format.  (WRB)
     796    !   900510  Added code to break messages between words.  (RWC)
     797    !   920501  Reformatted the REFERENCES section.  (WRB)
     798    !***END PROLOGUE  XERPRN
     799    CHARACTER(len = *) :: PREFIX, MESSG
     800    INTEGER :: NPREF, NWRAP
     801    CHARACTER(len = 148) :: CBUFF
     802    INTEGER :: IU(5), NUNIT
     803    CHARACTER(len = 2) :: NEWLIN
     804    PARAMETER (NEWLIN = '$$')
     805    INTEGER :: N, I1MACH, I, LPREF, LWRAP, LENMSG, NEXTC
     806    INTEGER :: LPIECE, IDELTA
     807    !***FIRST EXECUTABLE STATEMENT  XERPRN
     808    CALL XGETUA(IU, NUNIT)
     809    !
     810    !   A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
     811    !   ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
     812    !   ERROR MESSAGE UNIT.
     813    !
     814    N = I1MACH(4)
     815    DO I = 1, NUNIT
     816      IF (IU(I) == 0) IU(I) = N
     817    END DO
     818    !
     819    !   LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
     820    !   BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
     821    !   THE REST OF THIS ROUTINE.
     822    !
     823    IF (NPREF < 0) THEN
     824      LPREF = LEN(PREFIX)
     825    ELSE
     826      LPREF = NPREF
     827    ENDIF
     828    LPREF = MIN(16, LPREF)
     829    IF (LPREF /= 0) CBUFF(1:LPREF) = PREFIX
     830    !
     831    !   LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
     832    !   TIME FROM MESSG TO PRINT ON ONE LINE.
     833    !
     834    LWRAP = MAX(16, MIN(132, NWRAP))
     835    !
     836    !   SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
     837    !
     838    LENMSG = LEN(MESSG)
     839    N = LENMSG
     840    DO I = 1, N
     841      IF (MESSG(LENMSG:LENMSG) /= ' ') GO TO 30
     842      LENMSG = LENMSG - 1
     843    END DO
     844    30   CONTINUE
     845    !
     846    !   IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
     847    !
     848    IF (LENMSG == 0) THEN
     849      CBUFF(LPREF + 1:LPREF + 1) = ' '
     850      DO I = 1, NUNIT
     851        WRITE(IU(I), '(A)') CBUFF(1:LPREF + 1)
     852      END DO
     853      RETURN
     854    ENDIF
     855    !
     856    !   SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
     857    !   STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
     858    !   WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
     859    !   WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
     860    !
     861    !   WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
     862    !   INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
     863    !   OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
     864    !   OF THE SECOND ARGUMENT.
     865    !
     866    !   THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
     867    !   FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
     868    !   OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
     869    !   POSITION NEXTC.
     870    !
     871    !   LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
     872    !                   REMAINDER OF THE CHARACTER STRING.  LPIECE
     873    !                   SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
     874    !                   WHICHEVER IS LESS.
     875    !
     876    !   LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
     877    !                   NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
     878    !                   PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
     879    !                   BLANK LINES.  THIS TAKES CARE OF THE SITUATION
     880    !                   WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
     881    !                   EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
     882    !                   SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
     883    !                   SHOULD BE INCREMENTED BY 2.
     884    !
     885    !   LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
     886    !
     887    !   ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
     888    !                   RESET LPIECE = LPIECE-1.  NOTE THAT THIS
     889    !                   PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
     890    !                   LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
     891    !                   AT THE END OF A LINE.
     892    !
     893    NEXTC = 1
     894    50   LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
     895    IF (LPIECE == 0) THEN
     896      !
     897      !   THERE WAS NO NEW LINE SENTINEL FOUND.
     898      !
     899      IDELTA = 0
     900      LPIECE = MIN(LWRAP, LENMSG + 1 - NEXTC)
     901      IF (LPIECE < LENMSG + 1 - NEXTC) THEN
     902        DO I = LPIECE + 1, 2, -1
     903          IF (MESSG(NEXTC + I - 1:NEXTC + I - 1) == ' ') THEN
     904            LPIECE = I - 1
     905            IDELTA = 1
     906            GOTO 54
     907          ENDIF
     908        END DO
     909      ENDIF
     910      54   CBUFF(LPREF + 1:LPREF + LPIECE) = MESSG(NEXTC:NEXTC + LPIECE - 1)
     911      NEXTC = NEXTC + LPIECE + IDELTA
     912    ELSEIF (LPIECE == 1) THEN
     913      !
     914      !   WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
     915      !   DON'T PRINT A BLANK LINE.
     916      !
     917      NEXTC = NEXTC + 2
     918      GO TO 50
     919    ELSEIF (LPIECE > LWRAP + 1) THEN
     920      !
     921      !   LPIECE SHOULD BE SET DOWN TO LWRAP.
     922      !
     923      IDELTA = 0
     924      LPIECE = LWRAP
     925      DO I = LPIECE + 1, 2, -1
     926        IF (MESSG(NEXTC + I - 1:NEXTC + I - 1) == ' ') THEN
     927          LPIECE = I - 1
     928          IDELTA = 1
     929          GOTO 58
     930        ENDIF
     931      END DO
     932      58   CBUFF(LPREF + 1:LPREF + LPIECE) = MESSG(NEXTC:NEXTC + LPIECE - 1)
     933      NEXTC = NEXTC + LPIECE + IDELTA
     934    ELSE
     935      !
     936      !   IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
     937      !   WE SHOULD DECREMENT LPIECE BY ONE.
     938      !
     939      LPIECE = LPIECE - 1
     940      CBUFF(LPREF + 1:LPREF + LPIECE) = MESSG(NEXTC:NEXTC + LPIECE - 1)
     941      NEXTC = NEXTC + LPIECE + 2
     942    ENDIF
     943    !
     944    !   PRINT
     945    !
     946    DO I = 1, NUNIT
     947      WRITE(IU(I), '(A)') CBUFF(1:LPREF + LPIECE)
     948    END DO
     949    !
     950    IF (NEXTC <= LENMSG) GO TO 50
     951
     952  END SUBROUTINE XERPRN
     953
     954  !DECK XERHLT
     955  SUBROUTINE XERHLT(MESSG)
     956    !***BEGIN PROLOGUE  XERHLT
     957    !***SUBSIDIARY
     958    !***PURPOSE  Abort program execution and print error message.
     959    !***LIBRARY   SLATEC (XERROR)
     960    !***CATEGORY  R3C
     961    !***TYPE      ALL (XERHLT-A)
     962    !***KEYWORDS  ABORT PROGRAM EXECUTION, ERROR, XERROR
     963    !***AUTHOR  Jones, R. E., (SNLA)
     964    !***DESCRIPTION
     965    !
     966    ! Abstract
     967    !    ***Note*** machine dependent routine
     968    !    XERHLT aborts the execution of the program.
     969    !    The error message causing the abort is given in the calling
     970    !    sequence, in case one needs it for printing on a dayfile,
     971    !    for example.
     972    !
     973    ! Description of Parameters
     974    !    MESSG is as in XERMSG.
     975    !
     976    !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
     977    !             Error-handling Package, SAND82-0800, Sandia
     978    !             Laboratories, 1982.
     979    !***ROUTINES CALLED  (NONE)
     980    !***REVISION HISTORY  (YYMMDD)
     981    !   790801  DATE WRITTEN
     982    !   861211  REVISION DATE from Version 3.2
     983    !   891214  Prologue converted to Version 4.0 format.  (BAB)
     984    !   900206  Routine changed from user-callable to subsidiary.  (WRB)
     985    !   900510  Changed calling sequence to delete length of character
     986    !       and changed routine name from XERABT to XERHLT.  (RWC)
     987    !   920501  Reformatted the REFERENCES section.  (WRB)
     988    !***END PROLOGUE  XERHLT
     989    CHARACTER(len = *) :: MESSG
     990    !***FIRST EXECUTABLE STATEMENT  XERHLT
     991    STOP
     992  END SUBROUTINE XERHLT
     993
     994  !DECK XERCNT
     995  SUBROUTINE XERCNT(LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
     996    IMPLICIT NONE
     997    !***BEGIN PROLOGUE  XERCNT
     998    !***SUBSIDIARY
     999    !***PURPOSE  Allow user control over handling of errors.
     1000    !***LIBRARY   SLATEC (XERROR)
     1001    !***CATEGORY  R3C
     1002    !***TYPE      ALL (XERCNT-A)
     1003    !***KEYWORDS  ERROR, XERROR
     1004    !***AUTHOR  Jones, R. E., (SNLA)
     1005    !***DESCRIPTION
     1006    !
     1007    ! Abstract
     1008    !    Allows user control over handling of individual errors.
     1009    !    Just after each message is recorded, but before it is
     1010    !    processed any further (i.e., before it is printed or
     1011    !    a decision to abort is made), a CALL is made to XERCNT.
     1012    !    If the user has provided his own version of XERCNT, he
     1013    !    can then override the value of KONTROL used in processing
     1014    !    this message by redefining its value.
     1015    !    KONTRL may be set to any value from -2 to 2.
     1016    !    The meanings for KONTRL are the same as in XSETF, except
     1017    !    that the value of KONTRL changes only for this message.
     1018    !    If KONTRL is set to a value outside the range from -2 to 2,
     1019    !    it will be moved back into that range.
     1020    !
     1021    ! Description of Parameters
     1022    !
     1023    !  --Input--
     1024    !    LIBRAR - the library that the routine is in.
     1025    !    SUBROU - the SUBROUTINE that XERMSG is being called from
     1026    !    MESSG  - the first 20 characters of the error message.
     1027    !    NERR   - same as in the CALL to XERMSG.
     1028    !    LEVEL  - same as in the CALL to XERMSG.
     1029    !    KONTRL - the current value of the control flag as set
     1030    !             by a CALL to XSETF.
     1031    !
     1032    !  --Output--
     1033    !    KONTRL - the new value of KONTRL.  If KONTRL is not
     1034    !             defined, it will remain at its original value.
     1035    !             This changed value of control affects only
     1036    !             the current occurrence of the current message.
     1037    !
     1038    !***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
     1039    !             Error-handling Package, SAND82-0800, Sandia
     1040    !             Laboratories, 1982.
     1041    !***ROUTINES CALLED  (NONE)
     1042    !***REVISION HISTORY  (YYMMDD)
     1043    !   790801  DATE WRITTEN
     1044    !   861211  REVISION DATE from Version 3.2
     1045    !   891214  Prologue converted to Version 4.0 format.  (BAB)
     1046    !   900206  Routine changed from user-callable to subsidiary.  (WRB)
     1047    !   900510  Changed calling sequence to include LIBRARY and SUBROUTINE
     1048    !       names, changed routine name from XERCTL to XERCNT.  (RWC)
     1049    !   920501  Reformatted the REFERENCES section.  (WRB)
     1050    !***END PROLOGUE  XERCNT
     1051    CHARACTER(len = *) :: LIBRAR, SUBROU, MESSG
     1052    INTEGER :: NERR, LEVEL, KONTRL
     1053    !***FIRST EXECUTABLE STATEMENT  XERCNT
     1054
     1055  END SUBROUTINE XERCNT
     1056
     1057
     1058END MODULE lmdz_xer
Note: See TracChangeset for help on using the changeset viewer.