From 1b934132999742ba9980044f076cb6badcfa032e Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Tue, 13 Oct 2020 21:22:56 +0200 Subject: [PATCH] dfac --- src/utils/dfac.f | 508 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 508 insertions(+) create mode 100644 src/utils/dfac.f diff --git a/src/utils/dfac.f b/src/utils/dfac.f new file mode 100644 index 0000000..64cbb10 --- /dev/null +++ b/src/utils/dfac.f @@ -0,0 +1,508 @@ +*DECK DFAC + DOUBLE PRECISION FUNCTION DFAC (N) +C***BEGIN PROLOGUE DFAC +C***PURPOSE Compute the factorial function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C1 +C***TYPE DOUBLE PRECISION (FAC-S, DFAC-D) +C***KEYWORDS FACTORIAL, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DFAC(N) calculates the double precision factorial for integer +C argument N. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D9LGMC, DGAMLM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DFAC + DOUBLE PRECISION FACN(31), SQ2PIL, X, XMAX, XMIN, D9LGMC + SAVE FACN, SQ2PIL, NMAX + DATA FACN ( 1) / +.1000000000 0000000000 0000000000 000 D+1 / + DATA FACN ( 2) / +.1000000000 0000000000 0000000000 000 D+1 / + DATA FACN ( 3) / +.2000000000 0000000000 0000000000 000 D+1 / + DATA FACN ( 4) / +.6000000000 0000000000 0000000000 000 D+1 / + DATA FACN ( 5) / +.2400000000 0000000000 0000000000 000 D+2 / + DATA FACN ( 6) / +.1200000000 0000000000 0000000000 000 D+3 / + DATA FACN ( 7) / +.7200000000 0000000000 0000000000 000 D+3 / + DATA FACN ( 8) / +.5040000000 0000000000 0000000000 000 D+4 / + DATA FACN ( 9) / +.4032000000 0000000000 0000000000 000 D+5 / + DATA FACN ( 10) / +.3628800000 0000000000 0000000000 000 D+6 / + DATA FACN ( 11) / +.3628800000 0000000000 0000000000 000 D+7 / + DATA FACN ( 12) / +.3991680000 0000000000 0000000000 000 D+8 / + DATA FACN ( 13) / +.4790016000 0000000000 0000000000 000 D+9 / + DATA FACN ( 14) / +.6227020800 0000000000 0000000000 000 D+10 / + DATA FACN ( 15) / +.8717829120 0000000000 0000000000 000 D+11 / + DATA FACN ( 16) / +.1307674368 0000000000 0000000000 000 D+13 / + DATA FACN ( 17) / +.2092278988 8000000000 0000000000 000 D+14 / + DATA FACN ( 18) / +.3556874280 9600000000 0000000000 000 D+15 / + DATA FACN ( 19) / +.6402373705 7280000000 0000000000 000 D+16 / + DATA FACN ( 20) / +.1216451004 0883200000 0000000000 000 D+18 / + DATA FACN ( 21) / +.2432902008 1766400000 0000000000 000 D+19 / + DATA FACN ( 22) / +.5109094217 1709440000 0000000000 000 D+20 / + DATA FACN ( 23) / +.1124000727 7776076800 0000000000 000 D+22 / + DATA FACN ( 24) / +.2585201673 8884976640 0000000000 000 D+23 / + DATA FACN ( 25) / +.6204484017 3323943936 0000000000 000 D+24 / + DATA FACN ( 26) / +.1551121004 3330985984 0000000000 000 D+26 / + DATA FACN ( 27) / +.4032914611 2660563558 4000000000 000 D+27 / + DATA FACN ( 28) / +.1088886945 0418352160 7680000000 000 D+29 / + DATA FACN ( 29) / +.3048883446 1171386050 1504000000 000 D+30 / + DATA FACN ( 30) / +.8841761993 7397019545 4361600000 000 D+31 / + DATA FACN ( 31) / +.2652528598 1219105863 6308480000 000 D+33 / + DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / + DATA NMAX / 0 / +C***FIRST EXECUTABLE STATEMENT DFAC + IF (NMAX.NE.0) GO TO 10 + CALL DGAMLM (XMIN, XMAX) + NMAX = XMAX - 1.D0 +C + 10 IF (N .LT. 0) CALL XERMSG ('SLATEC', 'DFAC', + + 'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2) +C + IF (N.LE.30) DFAC = FACN(N+1) + IF (N.LE.30) RETURN +C + IF (N .GT. NMAX) CALL XERMSG ('SLATEC', 'DFAC', + + 'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2) +C + X = N + 1 + DFAC = EXP ((X-0.5D0)*LOG(X) - X + SQ2PIL + D9LGMC(X) ) +C + RETURN + END + + +*DECK DGAMLM + SUBROUTINE DGAMLM (XMIN, XMAX) +C***BEGIN PROLOGUE DGAMLM +C***PURPOSE Compute the minimum and maximum bounds for the argument in +C the Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A, R2 +C***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) +C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Calculate the minimum and maximum legal bounds for X in gamma(X). +C XMIN and XMAX are not the only bounds, but they are the only non- +C trivial ones to calculate. +C +C Output Arguments -- +C XMIN double precision minimum legal value of X in gamma(X). Any +C smaller value of X might result in underflow. +C XMAX double precision maximum legal value of X in gamma(X). Any +C larger value of X might cause overflow. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DGAMLM + DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH +C***FIRST EXECUTABLE STATEMENT DGAMLM + ALNSML = LOG(D1MACH(1)) + XMIN = -ALNSML + DO 10 I=1,10 + XOLD = XMIN + XLN = LOG(XMIN) + XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) + 1 / (XMIN*XLN+0.5D0) + IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 + 10 CONTINUE + CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2) +C + 20 XMIN = -XMIN + 0.01D0 +C + ALNBIG = LOG (D1MACH(2)) + XMAX = ALNBIG + DO 30 I=1,10 + XOLD = XMAX + XLN = LOG(XMAX) + XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) + 1 / (XMAX*XLN-0.5D0) + IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 + 30 CONTINUE + CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2) +C + 40 XMAX = XMAX - 0.01D0 + XMIN = MAX (XMIN, -XMAX+1.D0) +C + RETURN + END + + + +*DECK XERMSG + SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) +C***BEGIN PROLOGUE XERMSG +C***PURPOSE Process error messages for SLATEC and other libraries. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERMSG-A) +C***KEYWORDS ERROR MESSAGE, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C XERMSG processes a diagnostic message in a manner determined by the +C value of LEVEL and the current value of the library error control +C flag, KONTRL. See subroutine XSETF for details. +C +C LIBRAR A character constant (or character variable) with the name +C of the library. This will be 'SLATEC' for the SLATEC +C Common Math Library. The error handling package is +C general enough to be used by many libraries +C simultaneously, so it is desirable for the routine that +C detects and reports an error to identify the library name +C as well as the routine name. +C +C SUBROU A character constant (or character variable) with the name +C of the routine that detected the error. Usually it is the +C name of the routine that is calling XERMSG. There are +C some instances where a user callable library routine calls +C lower level subsidiary routines where the error is +C detected. In such cases it may be more informative to +C supply the name of the routine the user called rather than +C the name of the subsidiary routine that detected the +C error. +C +C MESSG A character constant (or character variable) with the text +C of the error or warning message. In the example below, +C the message is a character constant that contains a +C generic message. +C +C CALL XERMSG ('SLATEC', 'MMPY', +C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', +C *3, 1) +C +C It is possible (and is sometimes desirable) to generate a +C specific message--e.g., one that contains actual numeric +C values. Specific numeric values can be converted into +C character strings using formatted WRITE statements into +C character variables. This is called standard Fortran +C internal file I/O and is exemplified in the first three +C lines of the following example. You can also catenate +C substrings of characters to construct the error message. +C Here is an example showing the use of both writing to +C an internal file and catenating character strings. +C +C CHARACTER*5 CHARN, CHARL +C WRITE (CHARN,10) N +C WRITE (CHARL,10) LDA +C 10 FORMAT(I5) +C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// +C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// +C * CHARL, 3, 1) +C +C There are two subtleties worth mentioning. One is that +C the // for character catenation is used to construct the +C error message so that no single character constant is +C continued to the next line. This avoids confusion as to +C whether there are trailing blanks at the end of the line. +C The second is that by catenating the parts of the message +C as an actual argument rather than encoding the entire +C message into one large character variable, we avoid +C having to know how long the message will be in order to +C declare an adequate length for that large character +C variable. XERMSG calls XERPRN to print the message using +C multiple lines if necessary. If the message is very long, +C XERPRN will break it into pieces of 72 characters (as +C requested by XERMSG) for printing on multiple lines. +C Also, XERMSG asks XERPRN to prefix each line with ' * ' +C so that the total line length could be 76 characters. +C Note also that XERPRN scans the error message backwards +C to ignore trailing blanks. Another feature is that +C the substring '$$' is treated as a new line sentinel +C by XERPRN. If you want to construct a multiline +C message without having to count out multiples of 72 +C characters, just use '$$' as a separator. '$$' +C obviously must occur within 72 characters of the +C start of each line to have its intended effect since +C XERPRN is asked to wrap around at 72 characters in +C addition to looking for '$$'. +C +C NERR An integer value that is chosen by the library routine's +C author. It must be in the range -99 to 999 (three +C printable digits). Each distinct error should have its +C own error number. These error numbers should be described +C in the machine readable documentation for the routine. +C The error numbers need be unique only within each routine, +C so it is reasonable for each routine to start enumerating +C errors from 1 and proceeding to the next integer. +C +C LEVEL An integer value in the range 0 to 2 that indicates the +C level (severity) of the error. Their meanings are +C +C -1 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. An attempt is made to only print this +C message once. +C +C 0 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. +C +C 1 A recoverable error. This is used even if the error is +C so serious that the routine cannot return any useful +C answer. If the user has told the error package to +C return after recoverable errors, then XERMSG will +C return to the Library routine which can then return to +C the user's routine. The user may also permit the error +C package to terminate the program upon encountering a +C recoverable error. +C +C 2 A fatal error. XERMSG will not return to its caller +C after it receives a fatal error. This level should +C hardly ever be used; it is much better to allow the +C user a chance to recover. An example of one of the few +C cases in which it is permissible to declare a level 2 +C error is a reverse communication Library routine that +C is likely to be called repeatedly until it integrates +C across some interval. If there is a serious error in +C the input such that another step cannot be taken and +C the Library routine is called again without the input +C error having been corrected by the caller, the Library +C routine will probably be called forever with improper +C input. In this case, it is reasonable to declare the +C error to be fatal. +C +C Each of the arguments to XERMSG is input; none will be modified by +C XERMSG. A routine may make multiple calls to XERMSG with warning +C level messages; however, after a call to XERMSG with a recoverable +C error, the routine should return to the user. Do not try to call +C XERMSG with a second recoverable error after the first recoverable +C error because the error package saves the error number. The user +C can retrieve this error number by calling another entry point in +C the error handling package and then clear the error number when +C recovering from the error. Calling XERMSG in succession causes the +C old error number to be overwritten by the latest error number. +C This is considered harmless for error numbers associated with +C warning messages but must not be done for error numbers of serious +C errors. After a call to XERMSG with a recoverable error, the user +C must be given a chance to call NUMXER or XERCLR to retrieve or +C clear the error number. +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE +C***REVISION HISTORY (YYMMDD) +C 880101 DATE WRITTEN +C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. +C THERE ARE TWO BASIC CHANGES. +C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO +C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES +C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS +C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE +C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER +C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY +C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE +C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. +C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE +C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE +C OF LOWER CASE. +C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. +C THE PRINCIPAL CHANGES ARE +C 1. CLARIFY COMMENTS IN THE PROLOGUES +C 2. RENAME XRPRNT TO XERPRN +C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES +C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / +C CHARACTER FOR NEW RECORDS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C CLEAN UP THE CODING. +C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN +C PREFIX. +C 891013 REVISED TO CORRECT COMMENTS. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but +C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added +C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and +C XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERMSG + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 XLIBR, XSUBR + CHARACTER*72 TEMP + CHARACTER*20 LFIRST +C***FIRST EXECUTABLE STATEMENT XERMSG + LKNTRL = J4SAVE (2, 0, .FALSE.) + MAXMES = J4SAVE (4, 0, .FALSE.) +C +C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. +C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE +C SHOULD BE PRINTED. +C +C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN +C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, +C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. +C + IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. + * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN + CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // + * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// + * 'JOB ABORT DUE TO FATAL ERROR.', 72) + CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) + CALL XERHLT (' ***XERMSG -- INVALID INPUT') + RETURN + ENDIF +C +C RECORD THE MESSAGE. +C + I = J4SAVE (1, NERR, .TRUE.) + CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) +C +C HANDLE PRINT-ONCE WARNING MESSAGES. +C + IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN +C +C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. +C + XLIBR = LIBRAR + XSUBR = SUBROU + LFIRST = MESSG + LERR = NERR + LLEVEL = LEVEL + CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) +C + LKNTRL = MAX(-2, MIN(2,LKNTRL)) + MKNTRL = ABS(LKNTRL) +C +C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS +C ZERO AND THE ERROR IS NOT FATAL. +C + IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 + IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 + IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 + IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 +C +C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A +C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) +C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG +C IS NOT ZERO. +C + IF (LKNTRL .NE. 0) THEN + TEMP(1:21) = 'MESSAGE FROM ROUTINE ' + I = MIN(LEN(SUBROU), 16) + TEMP(22:21+I) = SUBROU(1:I) + TEMP(22+I:33+I) = ' IN LIBRARY ' + LTEMP = 33 + I + I = MIN(LEN(LIBRAR), 16) + TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) + TEMP(LTEMP+I+1:LTEMP+I+1) = '.' + LTEMP = LTEMP + I + 1 + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE +C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE +C FROM EACH OF THE FOLLOWING THREE OPTIONS. +C 1. LEVEL OF THE MESSAGE +C 'INFORMATIVE MESSAGE' +C 'POTENTIALLY RECOVERABLE ERROR' +C 'FATAL ERROR' +C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE +C 'PROG CONTINUES' +C 'PROG ABORTED' +C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK +C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS +C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) +C 'TRACEBACK REQUESTED' +C 'TRACEBACK NOT REQUESTED' +C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT +C EXCEED 74 CHARACTERS. +C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. +C + IF (LKNTRL .GT. 0) THEN +C +C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. +C + IF (LEVEL .LE. 0) THEN + TEMP(1:20) = 'INFORMATIVE MESSAGE,' + LTEMP = 20 + ELSEIF (LEVEL .EQ. 1) THEN + TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' + LTEMP = 30 + ELSE + TEMP(1:12) = 'FATAL ERROR,' + LTEMP = 12 + ENDIF +C +C THEN WHETHER THE PROGRAM WILL CONTINUE. +C + IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. + * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN + TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' + LTEMP = LTEMP + 14 + ELSE + TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' + LTEMP = LTEMP + 16 + ENDIF +C +C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' + LTEMP = LTEMP + 20 + ELSE + TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' + LTEMP = LTEMP + 24 + ENDIF + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C NOW SEND OUT THE MESSAGE. +C + CALL XERPRN (' * ', -1, MESSG, 72) +C +C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A +C TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR + DO 10 I=16,22 + IF (TEMP(I:I) .NE. ' ') GO TO 20 + 10 CONTINUE +C + 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) + CALL FDUMP + ENDIF +C +C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. +C + IF (LKNTRL .NE. 0) THEN + CALL XERPRN (' * ', -1, ' ', 72) + CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) + CALL XERPRN (' ', 0, ' ', 72) + ENDIF +C +C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE +C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. +C + 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN +C +C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A +C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR +C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. +C + IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN + IF (LEVEL .EQ. 1) THEN + CALL XERPRN + * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) + ELSE + CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) + ENDIF + CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) + CALL XERHLT (' ') + ELSE + CALL XERHLT (MESSG) + ENDIF + RETURN + END