dfac

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