mirror of
https://github.com/pfloos/quack
synced 2024-11-06 22:24:03 +01:00
dfac
This commit is contained in:
parent
7562686ea3
commit
1b93413299
508
src/utils/dfac.f
Normal file
508
src/utils/dfac.f
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user