Changeset 5115
- Timestamp:
- Jul 24, 2024, 1:42:39 PM (7 weeks ago)
- 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 2 2 3 3 MODULE lmdz_libmath_pch 4 USE lmdz_xer, ONLY: xermsg 4 5 IMPLICIT NONE; PRIVATE 5 6 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 6 MODULE lmdz_xer 7 IMPLICIT NONE; PRIVATE 8 PUBLIC xermsg 9 CONTAINS 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 288 298 TEMP(1:20) = 'INFORMATIVE MESSAGE,' 289 299 LTEMP = 20 290 ELSEIF (LEVEL == 1) THEN300 ELSEIF (LEVEL == 1) THEN 291 301 TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' 292 302 LTEMP = 30 293 ELSE303 ELSE 294 304 TEMP(1:12) = 'FATAL ERROR,' 295 305 LTEMP = 12 296 ENDIF297 !298 ! THEN WHETHER THE PROGRAM WILL CONTINUE.299 !300 IF ((MKNTRL==2 .AND. LEVEL>=1) .OR. &301 (MKNTRL==1 .AND. LEVEL==2)) THEN302 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,' 303 313 LTEMP = LTEMP + 14 304 ELSE305 TEMP(LTEMP +1:LTEMP+16) = ' PROG CONTINUES,'314 ELSE 315 TEMP(LTEMP + 1:LTEMP + 16) = ' PROG CONTINUES,' 306 316 LTEMP = LTEMP + 16 307 ENDIF308 !309 ! FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.310 !311 IF (LKNTRL > 0) THEN312 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' 313 323 LTEMP = LTEMP + 20 314 ELSE315 TEMP(LTEMP +1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'324 ELSE 325 TEMP(LTEMP + 1:LTEMP + 24) = ' TRACEBACK NOT REQUESTED' 316 326 LTEMP = LTEMP + 24 317 ENDIF318 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)319 ENDIF320 !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 A326 ! TRACEBACK.327 !328 IF (LKNTRL > 0) THEN329 WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR330 DO I=16,22327 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 331 341 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 357 366 CALL XERPRN & 358 (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)359 ELSE367 (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) 368 ELSE 360 369 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 1058 END MODULE lmdz_xer
Note: See TracChangeset
for help on using the changeset viewer.