INTEGRATOR.f

C==========================================================================================
C==========================================================================================
C==========================================================================================
C========================================================================================== 

      SUBROUTINE UGLNR(A,B,ALPHA,N,X,W)
C========================================================================================== 
C     PURPOSE: 
C     THIS SUBROUTINE COMPUTES A UNSCALED N-POINT GAUSS-LAGUERRE QUADRATURE RULE. 
C     THE SUBROUTINE  IS BASED ON A CODE WRITTEN BY JOHN BURKARDT
C
C     THE INTEGRAL TO BE APPROXIMATED HAS THE FORM
C     
C     INTEGRAL ( -OO < X < +OO ) F(X) RHO(X) DX
C     
C     WHERE THE WEIGHT RHO(X) IS:
C     
C     RHO(X) = EXP ( - B * ( X - A ) ) DX
C     
C     AND A AND B ARE PARAMETERS.
C
C    INPUT,  DOUBLE PRECISION A, THE CENTER POINT.
C    INPUT,  DOUBLE PRECISION B, THE SCALE.
C    INPUT,  DOUBLE PRECISION ALPHA, A PARAMETER WE SET TO ZERO.
C    INPUT,  INTEGER N, THE NUMBER OF POINTS IN THE RULE.
C    OUTPUT, DOUBLE PRECISION X(N), THE KNOTS.
C    OUTPUT, DOUBLE PRECISION W(N), THE WEIGHTS.
C========================================================================================== 
C
      IMPLICIT NONE
      DOUBLE PRECISION A,B,ALPHA,BETA,X(N),W(N),WF(2*N),IWF(2*N+1)
      INTEGER N,KIND,SCALE,NWF,NIWF,IER,LO,I
C
C  CONSTRUCT THE RULE.
C
      LO = 0
      KIND = 5
      NWF = 2*N
      NIWF = NWF+1
      BETA = 0.0D0
      CALL CGQF(N,X,W,KIND,ALPHA,BETA,A,B,LO,NWF,WF,NIWF,IWF,IER)
      IF(IER.GT.0) THEN
         WRITE(*,*)'ERROR IN SUBROUTINE UGLNR: IER =', IER
         WRITE(*,*)'SEE SUBROUTINE UGLNR FOR ERROR DESCRIPTION'
         WRITE(*,*)'COMPUTATIONS ABORTED'
         STOP
      ENDIF
C
      RETURN
      END

C==========================================================================================
C==========================================================================================
C==========================================================================================
C========================================================================================== 

      SUBROUTINE SGLNR(A,B,ALPHA,N,X,W)
C========================================================================================== 
C     PURPOSE: 
C     THIS SUBROUTINE COMPUTES A SCALED N-POINT GAUSS-LAGUERRE QUADRATURE RULE. 
C     THE SUBROUTINE  IS BASED ON A CODE WRITTEN BY JOHN BURKARDT
C
C     THE INTEGRAL TO BE APPROXIMATED HAS THE FORM
C     
C     INTEGRAL ( -OO < X < +OO ) F(X) RHO(X) DX
C     
C     WHERE THE WEIGHT RHO(X) IS:
C     
C     RHO(X) = EXP ( - B * ( X - A ) ) * SQRT ( B / PI ) DX
C     
C     AND A AND B ARE PARAMETERS.
C
C    INPUT,  DOUBLE PRECISION A, THE CENTER POINT.
C    INPUT,  DOUBLE PRECISION B, THE SCALE.
C    INPUT,  DOUBLE PRECISION ALPHA, A PARAMETER WE SET TO ZERO.
C    INPUT,  INTEGER N, THE NUMBER OF POINTS IN THE RULE.
C    OUTPUT, DOUBLE PRECISION X(N), THE KNOTS.
C    OUTPUT, DOUBLE PRECISION W(N), THE WEIGHTS.
C========================================================================================== 
C
      IMPLICIT NONE
      DOUBLE PRECISION A,B,ALPHA,BETA,X(N),W(N),WF(2*N),IWF(2*N+1),PI
      INTEGER N,KIND,SCALE,NWF,NIWF,IER,LO,I
      PARAMETER (PI = 3.14159265358979323846264338327950D0)
C
C  CONSTRUCT THE RULE.
C
      LO = 0
      KIND = 5
      NWF = 2*N
      NIWF = NWF+1
      BETA = 0.0D0
      CALL CGQF(N,X,W,KIND,ALPHA,BETA,A,B,LO,NWF,WF,NIWF,IWF,IER)
      IF(IER.GT.0) THEN
         WRITE(*,*)'ERROR IN SUBROUTINE SGLNR: IER =', IER
         WRITE(*,*)'SEE SUBROUTINE SGLNR FOR ERROR DESCRIPTION'
         WRITE(*,*)'COMPUTATIONS ABORTED'
         STOP
      ENDIF
C
C  NORMALIZE THE RULE SO THAT THE WEIGHTS ADD UP TO 1.
C
      DO I = 1, N
         W(I) = W(I)*DSQRT(B)/DSQRT(PI)
      END DO
C
      RETURN
      END

C==========================================================================================
C==========================================================================================
C==========================================================================================
C========================================================================================== 

      SUBROUTINE SGHNR(A,B,ALPHA,N,X,W)
C========================================================================================== 
C     PURPOSE: 
C     THIS SUBROUTINE COMPUTES A SCALED N-POINT GAUSS-HERMITE QUADRATURE RULE. 
C     THE SUBROUTINE  IS BASED ON A CODE WRITTEN BY JOHN BURKARDT
C
C     THE INTEGRAL TO BE APPROXIMATED HAS THE FORM
C     
C     INTEGRAL ( -OO < X < +OO ) F(X) RHO(X) DX
C     
C     WHERE THE WEIGHT RHO(X) IS:
C     
C     RHO(X) = EXP ( - B * ( X - A )^2 ) * SQRT ( B / PI ) DX
C     
C     AND A AND B ARE PARAMETERS.
C
C    INPUT,  DOUBLE PRECISION A, THE CENTER POINT.
C    INPUT,  DOUBLE PRECISION B, THE SCALE.
C    INPUT,  DOUBLE PRECISION ALPHA, A PARAMETER WE SET TO ZERO.
C    INPUT,  DOUBLE PRECISION BETA, A PARAMETER WE SET TO ZERO.
C    INPUT,  INTEGER N, THE NUMBER OF POINTS IN THE RULE.
C    INPUT,  INTEGER SCALE, THE NORMALIZATION OPTION. SCALE = 1 IF THE WEIGHTS ARE TO BE NORMALIZED
C    OUTPUT, DOUBLE PRECISION X(N), THE KNOTS.
C    OUTPUT, DOUBLE PRECISION W(N), THE WEIGHTS.
C========================================================================================== 
C
      IMPLICIT NONE
      DOUBLE PRECISION A,B,ALPHA,BETA,X(N),W(N),WF(2*N),IWF(2*N+1),PI
      INTEGER N,KIND,SCALE,NWF,NIWF,IER,LO,I
      PARAMETER (PI = 3.14159265358979323846264338327950D0)
C
C  CONSTRUCT THE RULE.
C
      LO = 0
      KIND = 6
      NWF = 2*N
      NIWF = NWF+1
      BETA = 0.0D0
      CALL CGQF(N,X,W,KIND,ALPHA,BETA,A,B,LO,NWF,WF,NIWF,IWF,IER)
      IF(IER.GT.0) THEN
         WRITE(*,*)'ERROR IN SUBROUTINE SGHNR: IER =', IER
         WRITE(*,*)'SEE SUBROUTINE CGQF FOR ERROR DESCRIPTION'
         WRITE(*,*)'COMPUTATIONS ABORTED'
         STOP
      ENDIF
C
C  NORMALIZE THE RULE SO THAT THE WEIGHTS ADD UP TO 1.
C
      DO I = 1, N
         W(I) = W(I)*DSQRT(B)/DSQRT(PI)
      END DO
C
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 
C
C     THE FOLLOWING SUBROUTINES AND THEIR DEPENDENCIES ARE PART OF THE
C     IPACK LIBRARY. THE SOURCE WAS OBTAINED FROM http://netlib.org/
C
C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

C            IQPACK - FORTRAN SUBROUTINES FOR THE WEIGHTS OF
C                       INTERPOLATORY QUADRATURES
C
C     FOR A DETAILED DESCRIPTION OF THESE ROUTINES SEE THE PAPER
C     WITH THE ABOVE TITLE -
C
C     GIVEN A SET OF DISTINCT KNOTS, T, AND THEIR MULTIPLICITIES MLT,
C     THIS PACKAGE COMPUTES THE WEIGHTS D    OF THE INTERPOLATORY
C                                        J,I
C     QUADRATURE FORMULA
C
C                                            (I)
C                 SUM       SUM        D    F   (T(J)),
C               J=1,NT   I=0,MLT(J)-1   J,I
C
C            (I)
C     WHERE F    IS THE I-TH DERIVATIVE OF F, WHERE THE QUADRATURE
C     IS TO APPROXIMATE
C
C                     INTEGRAL  F(T)W(T) DT,
C                      ÕA,Bå
C
C     AND WHERE W(T) IS A WEIGHT FUNCTION. FOR CERTAIN CLASSICAL WEIGHT
C     FUNCTIONS, LISTED BELOW, NO OTHER INFORMATION IS NEEDED. HOWEVER
C     THE PACKAGE CAN COMPUTE THE QUADRATURE WEIGHTS CORRESPONDING TO
C     ANY W(T) FOR WHICH THE ZERO-TH MOMENT AND THE (TRIDIAGONAL
C     SYMMETRIC) JACOBI MATRIX ASSOCIATED WITH THE POLYNOMIALS
C     ORTHOGONAL ON ÕA,Bå WITH RESPECT TO W(T), ARE KNOWN. (A UTILITY
C     ROUTINE IS SUPPLIED TO PROVIDE THIS INFORMATION FOR CLASSICAL
C     WEIGHT FUNCTIONS). KNOTS AND WEIGHTS OF GAUSS QUADRATURES
C     WITH NO MULTIPLE KNOTS CAN ALSO BE COMPUTED.
C
C     THE PACKAGE IS AN IMPLEMENTATION OF THE METHOD DESCRIBED IN
C
C     "CALCULATION OF THE WEIGHTS OF INTERPOLATORY QUADRATURES",
C     J. KAUTSKY AND S. ELHAY,  NUMER MATH 40 (1982) 407-422,
C
C     TOGETHER WITH VARIOUS UTILITY ROUTINES. WEIGHTS TO SOME OR ALL THE
C     KNOTS CAN BE COMPUTED.
C
C           TABLE OF CLASSICAL WEIGHT FUNCTIONS
C
C      KIND  INTERVAL       WEIGHT FUNCTION               NAME
C        1    (A,B)              ONE                    LEGENDRE
C        2    (A,B)      ((B-X)*(X-A))**(-HALF)         CHEBYSHEV
C        3    (A,B)      ((B-X)*(X-A))**ALPHA           GEGENBAUER
C        4    (A,B)    (B-X)**ALPHA*(X-A)**BETA          JACOBI
C        5   (A,INF)   (X-A)**ALPHA*EXP(-B*(X-A))      GEN LAGUERRE
C        6  (-INF,INF) ABS(X-A)**ALFA*EXP(-B*(X-A)**2) GEN HERMITE
C        7    (A,B)      ABS(X-(A+B)/TWO)**ALFA         EXPONENTIAL
C        8   (A,INF)    (X-A)**ALFA*(B+X)**BETA          RATIONAL
C
C     THE VALUES B=1 AND
C                         A=-1 FOR WEIGHT FUNCTIONS 1,2,3,4,7
C                         A= 0  FOR WEIGHT FUNCTIONS 5,6,8
C     WILL BE REFERRED TO AS THE DEFAULT VALUES.
C
C     WE ALSO DEFINE DEL AS
C                         (A+B)/2 FOR WEIGHT FUNCTIONS 1,2,3,4,7
C                           A     FOR WEIGHT FUNCTIONS 5,6,8
C
C   IQPACK INDEX
C   ------------
C
C   LEGEND
C   ------
C   GENERALLY I = THIS QUANTITY IS INPUT TO THIS ROUTINE
C             O = THIS QUANTITY IS OUTPUT FROM THIS ROUTINE
C   KNOTS -   M = MULTIPLE KNOTS ALLOWED
C             S = ONLY SIMPLE KNOTS ALLOWED
C   WEIGHTS - C = COMPUTED
C   QF -      I = ANY INTERPOLATORY QUADRATURE FORMULA
C             G = GAUSSIAN QUADRATURE FORMULA
C   EVAL -    Y = THE QUADRATURE SUM IS FORMED
C             N = THE QUADRATURE SUM IS NOT FORMED
C   PRINT -   Y = THE KNOTS AND WEIGHTS OF THE QUADRATURE FORMULA ARE
C                 OPTIONALLY PRINTED AND A CHECK OF THE MOMENTS IS
C                 OPTIONALLY PRINTED
C             N = NO PRINTING POSSIBLE
C   A,B -     A = ANY VALID VALUES OF THE WEIGHT FUNCTION PARAMETERS A,B
C                 ALLOWED
C             D = ONLY THE DEFAULT VALUES OF A,B ALLOWED
C
C   USER ROUTINES
C   -------------
C         NAME       KNOTS  WEIGHTS  QF  EVAL  PRINT  A,B
C         ------
C         CEGQF      SO     C        G   Y     N      A
C         CEGQFS     SO     C        G   Y     N      D
C         CGQF       SO     OC       G   N     Y      A
C         CGQFS      SO     OC       G   N     Y      D
C         CDGQF      SO     OC       G   N     N      D
C         SGQF       SO     OC       G   N     N      -
C         CLIQF      SI     OC       I   N     Y      A
C         CLIQFS     SI     OC       I   N     Y      D
C         CEIQF      MI     C        I   Y     N      A
C         CEIQFS     MI     C        I   Y     N      D
C         CIQF       MI     CO       I   N     Y      A
C         CIQFS      MI     CO       I   N     Y      D
C         EIQF       MI     I        I   Y     N      -
C         EIQFS      SI     I        I   Y     N      -
C         CAWIQ      MI     C        I   N     N      D
C
C   UTILITY AND AUXILLIARY ROUTINES
C   -------------------------------
C         CLASS      COMPUTE THE ZERO-TH MOMENT AND JACOBI MATRIX FOR
C                    A CLASSICAL WEIGHT FUNCTION
C         WM         COMPUTE THE MOMENTS OF A CLASSICAL WEIGHT FUNCTION
C         PARCHK     CHECK THAT THE PARAMETER VALUES ARE VALID FOR THIS
C                    WEIGHT FUNCTION
C         CHKQFS     CHECK AND OPTIONALLY PRINT A MOMENTS CHECK OF A QF
C                    AND OPTIONALLY PRINT THE KNOTS AND WEIGHTS. DEFAULT
C                    VALUES OF A,B ONLY
C         CHKQF      CHECK AND OPTIONALLY PRINT A MOMENTS CHECK OF A QF
C                    AND OPTIONALLY PRINT THE KNOTS AND WEIGHTS. ANY
C                    VALID VALUES OF A,B ALLOWED
C         SCT        SCALE THE KNOTS OF A QF FOR ANY VALID A,B TO THOSE
C                    FOR THE DEFAULT VALUES OF A,B
C         SCQF       SCALE A CLASSICAL WEIGHT FUNCTION QF WITH DEFAULT
C                    VALUES FOR A,B TO THOSE FOR ANY VALID A,B
C         SCMM       SCALE THE MOMENTS OF A CLASSICAL WEIGHT FUNCTION
C                    WITH DEFAULT VALUES FOR A,B TO THOSE FOR ANY VALID
C                    A,B
C         WTFN       COMPUTE THE VALUES OF A CLASSICAL WEIGHT FUNCTION
C                    AT GIVEN POINTS
C         CWIQD      FIND ALL THE WEIGHTS TO 1 MULTIPLE KNOT OF A QF
C         IMTQLX     ORTHOGONALLY DIAGONALIZE A JACOBI MATRIX
C         MACHEP     COMPUTE MACHINE EPSILON
C         DGAMMA     COMPUTE DOUBLE PRECISION GAMMA FUNCTION
C
C     THE FOLLOWING IS A LIST OF PARAMETERS USED THROUGHOUT THE PACKAGE
C     WHICH ALWAYS HAVE THE SAME MEANING.
C
C NT    NUMBER OF DISTINCT KNOTS. MUST BE .GE.1.
C T     KNOT ARRAY.
C MLT   MULTIPLICITY ARRAY. T(J) HAS MULTIPLICITY MLT(J).
C NWTS  DIMENSION OF THE ARRAY CONTAINING THE WEIGHTS.
C WTS   ARRAY CONTAINING THE WEIGHTS.
C NDX   FLAGS AND POINTERS ARRAY.  THE PACKAGE HAS BEEN DESIGNED TO
C       (1) TREAT ALL OR ONLY SOME OF THE KNOTS SUPPLIED AS INCLUDED IN
C           THE QUADRATURE,
C       (2) COMPUTE THE WEIGHTS FOR ALL OR ONLY SOME OF THE KNOTS
C           INCLUDED IN THE QUADRATURE,
C       (3) TO PACK THE WEIGHTS IN THE OUTPUT ARRAY IN VARIOUS (POSSIBLY
C           FOUR) DIFFERENT WAYS.
C       NDX INDICATES THE STATUS OF EACH KNOT AND POINTS TO THE LOCATION
C       OF THAT KNOT IN THE WTS ARRAY. ITS USE IS DESCRIBED IN CAWIQ.
C       IN MOST STRAIGHTFORWARD APPLICATIONS THE USER WILL ONLY NEED TO
C       DIMENSION THE ARRAY. THE PACKAGE WILL DO THE REST.
C KEY   WEIGHTS ARRAY STRUCTURE FLAG. WILL USUALLY BE SET 1. USE
C       DESCRIBED IN CAWIQ.
C KIND  AN INTEGER 0.LE.KIND.LE.8 SPECIFYING WHICH WEIGHT FUNCTION
C       IS TO BE USED. KIND=0 INDICATES THAT THE WEIGHT FUNCTION IS OF A
C       TYPE NOT LISTED IN THE TABLE BELOW OF CLASSICAL WEIGHT
C       FUNCTIONS. FOR KIND=0 THE USER MUST SUPPLY THE
C       JACOBI MATRIX AND ANY MOMENTS WHICH ARE REQUIRED.
C ALPHA
C BETA
C A
C B     THE WEIGHT FUNCTION AND/OR INTERVAL PARAMETERS. ANY ONE MAY
C       BE REPLACED BY A DUMMY VARIABLE IF THE WEIGHT FUNCTION IS
C       INDEPENDENT OF IT.
C NWF   AN INTEGER SPECIFYING THE DIMENSION OF THE WORKFIELD WF.
C       MINIMUM VALUES FOR NWF ARE GIVEN IN THE DESCRIPTION OF EACH
C       ROUTINE THAT USES A WORKFIELD.
C WF    FLOATING POINT WORKFIELD ARRAY TO BE SUPPLIED BY THE USER.
C NIWF  AN INTEGER SPECIFYING THE DIMENSION OF IWF
C IWF   INTEGER TYPE WORKFIELD ARRAY TO BE SUPPLIED BY THE USER.
C QFSUM VARIABLE RETURNING THE VALUE OF THE QUADRATURE SUM.
C F     A USER SUPPLIED FUNCTION INVOKED BY A STATEMENT LIKE Y=F(X,I).
C       IT RETURNS THE VALUE OF THE I-TH DERIVATIVE OF F AT X (ZERO-TH
C       DERIVATIVE=FUNCTION). THE FUNCTION SHOULD BE CAPABLE
C       OF RETURNING DERIVATIVES OF ALL ORDERS UP TO MMAX-1 WHERE
C       MMAX IS THE MAXIMUM MULTIPLICITY USED AT THE KNOTS. THE ACTUAL
C       PARAMETER USED IN THE CALL TO ROUTINE EIQF, EIQFS, CEIQF AND
C       CEIQFS MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE CALLING
C       PROGRAM
C LO    INTEGER VARIABLE USED TO CONTROL OUTPUT. IF LO IS SET TO ZERO
C       THEN THERE WILL BE NO OUTPUT PRINTED. IF LO IS NON-ZERO THEN
C       ABS(LO) WILL BE THE LOGICAL UNIT NUMBER TO WHICH ALL OUTPUT
C       IS DIRECTED.  WHEN LO IS NEGATIVE WEIGHTS ONLY WILL BE PRINTED
C       AND WHEN LO IS POSITIVE THE WEIGHTS AND A CHECK OF THE MOMENTS
C       WILL BE PRINTED. IN SOME ROUTINES LO.EQ.0 WILL CAUSE A MOMENTS
C       CHECK TO BE COMPUTED EVEN THOUGH THERE IS NO PRINT WHILE IN
C       OTHERS LO.EQ.0 WILL CAUSE ONLY THE WEIGHTS TO BE COMPUTED. SEE
C       INDIVIDUAL ROUTINES FOR DETAILS.
C
C     THROUGHOUT THE COMMENTS IN THIS PACKAGE
C          N...IS THE NUMBER OF KNOTS COUNTED ACCORDING TO THEIR
C              MULTIPLICITIES,
C          MMAX...MAXIMUM OF THE MLT(J)
C          RMAX...MAXIMUM OF 2*MMAX AND N+1
C          NSTAR...INTEGER PART OF (N+1)/2
C
C     ERROR CONDITIONS ARE INDICATED BY THE VARIABLE IER BEING
C     RETURNED WITH A NON-ZERO VALUE.
C
C     IER =    1        ALPHA.GT.-1 FALSE
C              2        FOR KIND.LT.8 BETA.GT.-1 IS FALSE
C              3        FOR KIND=8 NEED BETA.LT.(ALPHA+BETA+2*N).LT.0
C                           TO COMPUTE N ELEMENTS OF THE JACOBI MATRIX.
C              4        UNKNOWN WEIGHT FUNCTION. CANNOT GENERATE
C                           JACOBI MATRIX
C              5        GAMMA FUNCTION AND MACHINE PARAMETERS ARE NOT
C                           MATCHED IN ACCURACY
C              6        ZERO LENGTH INTERVAL (KIND=1,2,3,4,7)
C              7        B.LE.0 FOR KIND=5,6
C              8        A+B.LE.0 FOR KIND=8
C              9        NOT ENOUGH  INTEGER WORKFIELD. NIWF=2*NT WILL DO
C             10        DIMENSION OF WEIGHTS ARRAY TOO SMALL
C             11        JACOBI MATRIX NOT DIAGONALIZED SUCCESSFULLY
C             12        SIZE OF JACOBI MATRIX TOO SMALL FOR NUMBER OF
C                           WEIGHTS
C             13        ZERO-TH MOMENT OF WEIGHTS FUNCTION IS NOT > 0
C             14        KNOTS NOT DISTINCT
C             15        SOME KNOT HAS MULTIPLICITY < 1
C             16        POINTERS FOR WGHTS ARRAY CONTRADICTORY
C             17        0 < ABS(KEY) < 5 FALSE (SEE CAWIQ OR EIQF)
C             18        NUMBER OF KNOTS < 1
C             -K,K>0    AT LEAST K LOCATIONS ARE REQUIRED IN THE
C                       FLOATING-POINT WORKFIELD IN ORDER TO COMPLETE
C                       THE CURRENT TASK.
C
C                SUBROUTINES AND THEIR CALL SEQUENCES
C
C      CALL CEGQFS(NT,KIND,ALPHA,BETA,F,QFSUM,
C     1                 NWF,WF,NIWF,IWF,IER)
C      CALL CEGQF(NT,KIND,ALPHA,BETA,A,B,F,QFSUM,
C     1                 NWF,WF,NIWF,IWF,IER)
C      CALL CGQF(NT,T,WTS,KIND,ALPHA,BETA,A,B,LO,
C     1                 NWF,WF,NIWF,IWF,IER)
C      CALL CGQFS(NT,T,WTS,KIND,ALPHA,BETA,LO,
C     1                 NWF,WF,NIWF,IWF,IER)
C      CALL CDGQF(NT,T,WTS,KIND,ALPHA,BETA,NWF,WF,IER)
C      CALL SGQF(NT,T,WTS,AJ,BJ,ZEMU,IER)
C      CALL CLIQFS(NT,T,WTS,KIND,ALPHA,BETA,
C     1                 LO,NWF,WF,NIWF,IWF,IER)
C      CALL CLIQF(NT,T,WTS,KIND,ALPHA,BETA,A,B,
C     1                 LO,NWF,WF,NIWF,IWF,IER)
C      CALL CEIQFS(NT,T,MLT,KIND,ALPHA,BETA,F,QFSUM
C     1                 ,NWF,WF,NIWF,IWF,IER)
C      CALL CEIQF(NT,T,MLT,KIND,ALPHA,BETA,A,B,F,QFSUM
C     1                 ,NWF,WF,NIWF,IWF,IER)
C      CALL CIQFS(NT,T,MLT,NWTS,WTS,NDX,KEY,KIND,ALPHA,BETA
C     1                 ,LO,NWF,WF,IER)
C      CALL CIQF(NT,T,MLT,NWTS,WTS,NDX,KEY,KIND,ALPHA,BETA,A,B
C     1                 ,LO,NWF,WF,IER)
C      CALL EIQF(NT,T,MLT,WTS,NWTS,NDX,KEY,F,QFSUM,IER)
C      CALL EIQFS(NT,T,WTS,F,QFSUM,IER)
C      CALL CAWIQ(NT,T,MLT,NWTS,WTS,NDX,KEY
C     1                 ,NST,AJ,BJ,JDF,ZEMU,NWF,WF,IER)
C      CALL CWIQD(M,NM,L,V,XK,NSTAR,PHI,A,WF,Y,R,Z,D)
C      CALL CLASS(KIND,M,ALPHA,BETA,BJ,AJ,ZEMU,IER)
C      CALL WM(W,M,KIND,ALPHA,BETA,IER)
C      CALL PARCHK(KIND,M,ALPHA,BETA,IER)
C      CALL CHKQFS(T,WTS,MLT,NT,NWTS,NDX,KEY,W,MOP,MEX,
C     1                 KIND,ALPHA,BETA,LO,E,ER,QM,IER)
C      CALL CHKQF(T,WTS,MLT,NT,NWTS,NDX,KEY,WF,MOP,MEX,KIND,
C     1                  ALPHA,BETA,LO,E,ER,QM,NWF,A,B,IER)
C      CALL SCT(NT,T,ST,KIND,A,B,IER)
C      CALL SCQF(NT,T,MLT,WTS,NWTS,NDX,SWTS,ST,
C     1                  KIND,ALPHA,BETA,A,B,IER)
C      CALL SCMM(W,M,KIND,ALPHA,BETA,A,B,IER)
C      CALL WTFN(T,W,NT,KIND,ALPHA,BETA,IER)
C      CALL IMTQLX(N,D,E,Z,IER)
C      CALL MACHEP (X)
C      Y=DGAMMA(X)
C
C----------------------------------------------------------------------
C
C      IN THE DESCRIPTIONS OF THE ROUTINES BELOW ALL
C      THE INPUT AND OUTPUT PARAMETERS ARE INDICATED BY
C      THE SINGLE LETTER I OR O ALIGNED TO EACH VARIABLE IN THE
C      CALLING SEQUENCE. A * INDICATES THAT THE VARIABLE IS
C      SOMETIMES SET ON INPUT AND SOMETIMES SET BY THE ROUTINE.
C
      SUBROUTINE CEGQF(NT,KIND,ALPHA,BETA,A,B,F,QFSUM
     1,NWF,WF,NIWF,IWF,IER)
C     ROUTINE TO:
C     1.    COMPUTE ALL THE KNOTS AND WEIGHTS OF CLASSICAL WEIGHT
C           FUNCTION GAUSS QUADRATURE FORMULA WITH ALL SIMPLE KNOTS
C           FOR ANY VALID VALUES OF A AND B
C     2.    EVALUATE THE QUADRATURE SUM
C
C     INPUT AND OUTPUT VARIABLES -
C
C                       I  I    I     I    I I I O
C      SUBROUTINE CEGQF(NT,KIND,ALPHA,BETA,A,B,F,QFSUM
C     1,NWF,WF,NIWF,IWF,IER)
C       I   O  I    O   O
C
C     THE USER SUPPLIES A FUNCTION F, WHICH MUST BE DECLARED IN AN
C     EXTERNAL STATEMENT IN THE CALLING PROGRAM, AND WHICH RETURNS
C     VALUES OF F.
C
C     NEED NWF .GE. 2*NT
C         NIWF .GE. 2*NT
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CGQF EIQFS F
      DOUBLE PRECISION A,ALPHA,B,BETA,QFSUM,WF,F
      INTEGER IER,KIND,LU,NA,NB,NC,NIWF,NT,NWF,IWF
      DIMENSION WF(NWF),IWF(NIWF)
      EXTERNAL F
      IER=0
      IF(NIWF.LT.2*NT) THEN
         IER=9
                                              RETURN
      ENDIF
      IF(NWF.LT.2*NT) THEN
         IER=-2*NT
                                              RETURN
      ENDIF
C     SET WORKFIELD FOR WEIGHTS AND KNOTS
   10 LU=0
      NA=1
      NB=NA+NT
      NC=NB+NT+1
      CALL CGQF(NT,WF(NB),WF(NA),KIND,ALPHA,BETA,
     1                 A,B,LU,NWF-NC,WF(NC),NIWF,IWF,IER)
      IF(IER.NE.0)                            RETURN
C     EVALUATE THE QUADRATURE SUM
      CALL EIQFS(NT,WF(NB),WF(NA),F,QFSUM,IER)
                                              RETURN
      END
      SUBROUTINE CEGQFS(NT,KIND,ALPHA,BETA,F,QFSUM
     1,NWF,WF,NIWF,IWF,IER)
C
C     ROUTINE TO:
C     1.    COMPUTE ALL THE KNOTS AND WEIGHTS OF CLASSICAL WEIGHT
C           FUNCTION GAUSS QUADRATURE FORMULA WITH ALL SIMPLE KNOTS
C           FOR THE DEFAULT VALUES OF A AND B
C     2.    EVALUATE THE QUADRATURE SUM
C
C     INPUT AND OUTPUT VARIABLES -
C
C                        I  I    I     I    I O
C      SUBROUTINE CEGQFS(NT,KIND,ALPHA,BETA,F,QFSUM
C    1,NWF,WF,NIWF,IWF,IER)
C      I   O  I    O   O
C
C     F MUST BE DECLARED IN AN EXTERNAL STATEMENT
C     IN THE CALLING PROGRAM.
C
C     NEED NWF .GE. 2*NT
C         NIWF .GE. 2*NT
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CGQFS EIQFS F
      DOUBLE PRECISION ALPHA,BETA,QFSUM,WF,F
      INTEGER IER,KIND,LU,NA,NB,NC,NIWF,NT,NWF,IWF
      DIMENSION WF(NWF),IWF(NIWF)
      EXTERNAL F
C     CHECK THERE IS ENOUGH FLOATING POINT AND INTEGER WORKSPACE
      IER=0
      IF(NIWF.LT.2*NT) THEN
         IER=9
                                              RETURN
      ENDIF
      IF(NWF.LT.2*NT) THEN
         IER=-2*NT
                                              RETURN
      ENDIF
C     ASSIGN WORKSPACE FOR KNOTS AND WEIGHTS
   10 LU=0
      NA=1
      NB=NA+NT
      NC=NB+NT+1
      CALL CGQFS(NT,WF(NB),WF(NA),KIND,ALPHA,BETA,LU,
     1                 NWF-NC,WF(NC),NIWF,IWF,IER)
      IF(IER.NE.0)                            RETURN
C     EVALUATE THE QUADRATURE SUM
      CALL EIQFS(NT,WF(NB),WF(NA),F,QFSUM,IER)
                                              RETURN
      END
      SUBROUTINE CGQF(NT,T,WTS,KIND,ALPHA,BETA,A,B,LO,
     1NWF,WF,NIWF,IWF,IER)
C
C     ROUTINE TO COMPUTE ALL THE KNOTS AND WEIGHTS OF A GAUSS QF WITH
C     1. A CLASSICAL WEIGHT FUNCTION WITH ANY VALID A,B
C     2. ONLY SIMPLE KNOTS
C     3. OPTIONALLY PRINT KNOTS AND WEIGHTS AND A CHECK OF THE MOMENTS
C
C     LO.GT.0...COMPUTE AND PRINT KNOTS AND WEIGHTS. PRINT MOMENTS CHECK
C     LO.EQ.0...COMPUTE KNOTS AND WEIGHTS. PRINT NOTHING
C     LO.LT.0...COMPUTE AND PRINT KNOTS AND WEIGHTS. NO MOMENTS CHECK.
C
C     INPUT AND OUTPUT VARIABLES -
C                     I  O O   I    I     I    I I I
C     SUBROUTINE CGQF(NT,T,WTS,KIND,ALPHA,BETA,A,B,LO,
C     I   O  I    O   O
C    1NWF,WF,NIWF,IWF,IER)
C
C     NEED NWF.GE. (9*NT+13) IF LO.GT.0
C                  (2*NT)    IF LO.EQ.0
C                  (3*NT+4)  IF LO.LT.0
C     IWF...DIMENSION MUST BE .GE. 2*NT
C
C     USE ROUTINE EIQFS TO EVALUATE A QUADRATURE COMPUTED BY CGQF.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CDGQF CHKQF SCQF
      DOUBLE PRECISION A,ALPHA,B,BETA,T,WF,WTS
      INTEGER I,IER,KEY,KIND,LEX,LO,M,MEX,MMEX,MOP,NAI,NBI,NE,NER
      INTEGER NILAST,NIWF,NLAST,NQM,NT,NW,NWF,IWF
      DIMENSION T(NT),WTS(NT),WF(NWF),IWF(NIWF)
C
C     CHECK THERE IS ENOUGH WORKFIELD AND ASSIGN WORKFIELD
      IER=0
      KEY=1
      MOP=2*NT
      M=MOP+1
      MEX=M+2
      MMEX=MAX(MEX,1)
      LEX=MOP
      IF(LO.NE.0)LEX=MEX+NT+1
      IF(LO.LE.0)MEX=0
      NE=1
      NER=NE+MEX
      NQM=NER+MEX
      NW=NQM+MEX
      NLAST=NW-1
      LEX=LEX+3*MEX
C     EXIT IF INSUFFICIENT WORKFIELD
      IF(NIWF.LT.2*NT)IER=9
      IF(NWF.LT.LEX)IER=-LEX
      IF(IER.NE.0)                              RETURN
C
C     COMPUTE THE GAUSS QF FOR DEFAULT VALUES OF A,B
      CALL CDGQF(NT,T,WTS,KIND,ALPHA,BETA,
     1NWF,WF,IER)
C     EXIT IF ERROR
      IF(IER.NE.0)                               RETURN
C
C     PREPARE TO SCALE QF TO OTHER WEIGHT FUNCTION WITH VALID A,B
C     SET UP INTEGER WORK FIELDS
      NAI=1
      NBI=NAI+NT
      NILAST=NBI+NT-1
      DO 10 I=1,NT
         IWF(NAI+I-1)=1
         IWF(NBI+I-1)=I
   10 CONTINUE
C     IWF(NAI) IS THE MLT ARRAY. ALL KNOTS MULT=1
C     IWF(NBI) IS THE NDX ARRAY. NDX(I)=I
C     SCALE THE QUADRATURE
      CALL SCQF(NT,T,IWF(NAI),WTS,NT,IWF(NBI),WTS,T,
     1                   KIND,ALPHA,BETA,A,B,IER)
C
C     EXIT IF ERROR OR IF NO PRINT REQUIRED
      IF(IER.NE.0.OR.LO.EQ.0)                   RETURN
C
      CALL  CHKQF(T,WTS,IWF(NAI),NT,NT,IWF(NBI),KEY,WF(NW),MOP,MMEX,
     1  KIND,ALPHA,BETA,LO,WF(NE),WF(NER),WF(NQM),NWF-NW,A,B,IER)
                                                RETURN
      END
      SUBROUTINE CGQFS(NT,T,WTS,KIND,ALPHA,BETA,LO,
     1NWF,WF,NIWF,IWF,IER)
C
C     ROUTINE TO COMPUTE ALL THE KNOTS AND WEIGHTS OF A GAUSS QF WITH
C     1. A CLASSICAL WEIGHT FUNCTION WITH DEFAULT VALUES FOR A,B
C     2. ONLY SIMPLE KNOTS
C     3. OPTIONALLY PRINT KNOTS AND WEIGHTS AND A CHECK OF THE MOMENTS
C
C     LO.GT.0...COMPUTE AND PRINT KNOTS AND WEIGHTS. PRINT MOMENTS CHECK
C     LO.EQ.0...COMPUTE KNOTS AND WEIGHTS. PRINT NOTHING
C     LO.LT.0...COMPUTE AND PRINT KNOTS AND WEIGHTS. NO MOMENTS CHECK.
C
C      INPUT AND OUTPUT VARIABLES -
C                       I  O O   I    I     I    I
C      SUBROUTINE CGQFS(NT,T,WTS,KIND,ALPHA,BETA,LO,
C     1NWF,WF,NIWF,IWF,IER)
C      I   O   I   O   O
C
C     NEED NWF.GE. (9*NT+13) IF LO.GT.0
C                  (2*NT)    IF LO.EQ.0
C                  (3*NT+4)  IF LO.LT.0
C     IWF...DIMENSION MUST BE .GE. 2*NT
C
C     USE ROUTINE EIQFS TO EVALUATE A QUADRATURE COMPUTED BY CGQFS.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CDGQF CHKQFS
      DOUBLE PRECISION ALPHA,BETA,T,WF,WTS
      INTEGER I,IER,KEY,KIND,LEX,LO,M,MEX,MMEX,MOP,NAI,NBI,NE,NER
      INTEGER NILAST,NIWF,NLAST,NQM,NT,NW,NWF,IWF
      DIMENSION T(NT),WTS(NT),WF(NWF),IWF(NIWF)
C
C     CHECK THERE IS ENOUGH WORKFIELD AND ASSIGN WORKFIELD
      IER=0
      KEY=1
      MOP=2*NT
      M=MOP+1
      MEX=M+2
      MMEX=MAX(MEX,1)
      LEX=MOP
      IF(LO.NE.0)LEX=MEX+NT+1
      IF(LO.LE.0)MEX=0
      NE=1
      NER=NE+MEX
      NQM=NER+MEX
      NW=NQM+MEX
      NLAST=NW-1
      LEX=LEX+3*MEX
C     EXIT IF INSUFFICIENT WORKFIELD
      IF(NIWF.LT.2*NT)IER=9
      IF(NWF.LT.LEX)IER=-LEX
      IF(IER.NE.0)                              RETURN
C
C     COMPUTE THE GAUSS QF
      CALL CDGQF(NT,T,WTS,KIND,ALPHA,BETA,
     1NWF,WF,IER)
C     EXIT IF ERROR OR IF NO PRINT REQUIRED
      IF(IER.NE.0.OR.LO.EQ.0)                   RETURN
C
C     SET UP INTEGER WORK FIELDS
      NAI=1
      NBI=NAI+NT
      NILAST=NBI+NT-1
      DO 10 I=1,NT
         IWF(NAI+I-1)=1
         IWF(NBI+I-1)=I
   10 CONTINUE
C     IWF(NAI) IS THE MLT ARRAY. ALL KNOTS MULT=1
C     IWF(NBI) IS THE NDX ARRAY. NDX(I)=I
C
      CALL  CHKQFS(T,WTS,IWF(NAI),NT,NT,IWF(NBI),KEY,WF(NW),MOP,MMEX,
     1  KIND,ALPHA,BETA,LO,WF(NE),WF(NER),WF(NQM),IER)
                                                RETURN
      END
      SUBROUTINE CDGQF(NT,T,WTS,KIND,ALPHA,BETA,
     1NWF,WF,IER)
C
C     ROUTINE TO COMPUTE ALL THE KNOTS AND WEIGHTS OF A GAUSS QF WITH
C     1. A CLASSICAL WEIGHT FUNCTION WITH DEFAULT VALUES FOR A,B
C     2. ONLY SIMPLE KNOTS
C        NO MOMENTS CHECK OR PRINTING DONE.
C
C      INPUT AND OUTPUT VARIABLES -
C                       I  O O   I    I     I
C      SUBROUTINE CDGQF(NT,T,WTS,KIND,ALPHA,BETA,
C     1NWF,WF,IER)
C      I   O  O
C
C     NWF... MUST BE .GE. 2*NT
C
C     USE ROUTINE EIQFS TO EVALUATE A QUADRATURE COMPUTED BY CGQFS.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CLASS PARCHK SGQF
      DOUBLE PRECISION ALPHA,BETA,ZEMU,T,WF,WTS
      INTEGER IER,KIND,LEX,NA,NB,NLAST,NT,NWF
      DIMENSION T(NT),WTS(NT),WF(NWF)
      CALL  PARCHK(KIND,2*NT,ALPHA,BETA,IER)
C     SET UP ARRAYS FOR DIAGONAL AND SUB-DIAGONAL OF JACOBI MATRIX
      NA=1
      NB=NA+NT
      NLAST=NB+NT-1
      LEX=2*NT
      IF(NWF.LT.LEX)IER=-LEX
      IF(IER.NE.0)                              RETURN
C     GET JACOBI MATRIX AND ZERO-TH MOMENT
   10 CALL  CLASS(KIND,NT,ALPHA,BETA,WF(NB),WF(NA),ZEMU,IER)
      IF(IER.NE.0)                              RETURN
      CALL  SGQF(NT,T,WTS,WF(NA),WF(NB),ZEMU,IER)
                                                RETURN
      END
      SUBROUTINE SGQF(NT,T,WTS,AJ,BJ,ZEMU,IER)
C     ROUTINE TO COMPUTE ALL THE KNOTS AND WEIGHTS OF A GAUSS QUADRATURE
C     FORMULA (WITH SIMPLE KNOTS) FROM THE JACOBI MATRIX AND THE ZERO-TH
C     MOMENT OF THE WEIGHT FUNCTION, USING THE GOLUB-WELSCH TECHNIQUE
C
C      INPUT AND OUTPUT VARIABLES -
C                      I  O O   I  I  I    O
C      SUBROUTINE SGQF(NT,T,WTS,AJ,BJ,ZEMU,IER)
C
C     INPUT PARAMETERS
C     AJ...DIAGONAL OF JACOBI MATRIX
C     BJ...SUB-DIAGONAL OF JACOBI MATRIX ( IN BJ(1)..BJ(NT-1) )
C     ZEMU...ZERO-TH MOMENT OF WEIGHT FUNCTION
C
C     OUTPUT PARAMETERS
C     AT OUTPUT T AND WTS CONTAIN THE KNOTS AND WEIGHTS
C     THE ARRAY BJ IS OVERWRITTEN DURING EXECUTION
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - IMTQLX MACHEP SQRT
      DOUBLE PRECISION ZEMU,AJ,BJ,PREC,T,WTS
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,IER,NT
      DIMENSION T(NT),WTS(NT),AJ(NT),BJ(NT)
C
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
      COMMON /CTRLR/ PREC(10)
      IER=0
C
C     COMPUTE MACHINE EPSILON FOR IMTQLX
      CALL MACHEP(PREC(1))
C
C     EXIT IF ZERO-TH MOMENT NOT POSITIVE
      IF(ZEMU.LE.ZERO)IER=13
      IF(IER.NE.0)                           RETURN
C     SET UP VECTORS FOR IMTQLX
      DO 10 I=1,NT
         T(I)=AJ(I)
         WTS(I)=ZERO
   10 CONTINUE
      WTS(1)=SQRT(ZEMU)
C
C     DIAGONALIZE JACOBI MATRIX
      CALL IMTQLX(NT,T,BJ,WTS,IER)
C
C     CHECK FOR ERROR  RETURN FROM IMTQLX
      IF(IER.EQ.0)                            GOTO 20
      IER=11
                                              RETURN
C
   20 DO 30 I=1,NT
         WTS(I)=WTS(I)**2
   30 CONTINUE
                                              RETURN
      END
C
      SUBROUTINE CLIQFS(NT,T,WTS,KIND,ALPHA,BETA,
     1LO,NWF,WF,NIWF,IWF,IER)
C
C     ROUTINE TO COMPUTE ALL THE KNOTS AND WEIGHTS OF AN INTERPOLATORY
C     QF WITH
C     1. A CLASSICAL WEIGHT FUNCTION WITH DEFAULT VALUES FOR A,B
C     2. ONLY SIMPLE KNOTS
C     3. OPTIONALLY PRINT KNOTS AND WEIGHTS AND A CHECK OF THE MOMENTS
C
C     LO.GT.0...COMPUTE WEIGHTS. PRINT WEIGHTS. PRINT MOMENTS CHECK.
C     LO.EQ.0...COMPUTE WEIGHTS. PRINT NOTHING.
C     LO.LT.0...COMPUTE WEIGHTS. PRINT WEIGHTS.
C
C      INPUT AND OUTPUT VARIABLES -
C                        I  I O   I    I     I
C      SUBROUTINE CLIQFS(NT,T,WTS,KIND,ALPHA,BETA,
C     1LO,NWF,WF,NIWF,IWF,IER)
C      I  I   O  I    O   O
C
C     NEED NWF  .GE. (5*N+9)/2 IF LO.LE.0
C                    (9*N+25)/2 IF LO.GT.0
C          NIWF .GE. 2*NT
C
C     USE ROUTINE EIQFS TO EVALUATE A QUADRATURE COMPUTED BY CLIQFS.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CIQFS
      DOUBLE PRECISION ALPHA,BETA,T,WF,WTS
      INTEGER I,IER,KEY,KIND,LO,NA,NB,NIWF,NT,NW,NWF,IWF
      DIMENSION T(NT),WTS(NT),WF(NWF),IWF(NIWF)
C
      IER=0
      IF(NIWF.GE.2*NT)                        GOTO 10
      IER=9
                                              RETURN
   10 KEY=1
C     SET UP WORKFIELD FOR MLT,NDX
      NA=1
      NB=NA+NT
      NW=NB+NT
      DO 20 I=1,NT
         IWF(I)=1
   20 CONTINUE
      CALL CIQFS(NT,T,IWF(NA),NT,WTS,IWF(NB),KEY,KIND,ALPHA,BETA
     1,LO,NWF,WF,IER)
                                              RETURN
      END
      SUBROUTINE CLIQF(NT,T,WTS,KIND,ALPHA,BETA,A,B,
     1LO,NWF,WF,NIWF,IWF,IER)
C
C     ROUTINE TO COMPUTE ALL THE KNOTS AND WEIGHTS OF AN INTERPOLATORY
C     QF WITH
C     1. ONLY SIMPLE KNOTS AND
C     2. A CLASSICAL WEIGHT FUNCTION WITH ANY VALID A,B
C     3. OPTIONALLY PRINT KNOTS AND WEIGHTS AND A CHECK OF THE MOMENTS
C
C     LO.GT.0...COMPUTE WEIGHTS. PRINT WEIGHTS. PRINT MOMENTS CHECK.
C     LO.EQ.0...COMPUTE WEIGHTS. PRINT NOTHING.
C     LO.LT.0...COMPUTE WEIGHTS. PRINT WEIGHTS.
C
C      INPUT AND OUTPUT VARIABLES -
C                       I  I O   I    I     I    I I
C      SUBROUTINE CLIQF(NT,T,WTS,KIND,ALPHA,BETA,A,B,
C     1LO,NWF,WF,NIWF,IWF,IER)
C      I  I   O  I    O   O
C
C     NEED NWF  .GE. (5*N+9)/2 IF LO.LE.0
C                    (9*N+25)/2 IF LO.GT.0
C          NIWF .GE. 2*NT
C
C     USE ROUTINE EIQFS TO EVALUATE A QUADRATURE COMPUTED BY CLIQF.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CIQF
      DOUBLE PRECISION A,ALPHA,B,BETA,T,WF,WTS
      INTEGER I,IER,KEY,KIND,LO,NA,NB,NIWF,NT,NW,NWF,IWF
      DIMENSION T(NT),WTS(NT),WF(NWF),IWF(NIWF)
C
      IER=0
      IF(NIWF.GE.2*NT)                        GOTO 10
      IER=9
                                              RETURN
   10 KEY=1
C     SET UP WORKFIELD FOR MLT,NDX
      NA=1
      NB=NA+NT
      NW=NB+NT
      DO 20 I=1,NT
         IWF(I)=1
   20 CONTINUE
      CALL CIQF(NT,T,IWF(NA),NT,WTS,IWF(NB),KEY,KIND,ALPHA,BETA,A,B
     1,LO,NWF,WF,IER)
                                              RETURN
      END
      SUBROUTINE CEIQFS(NT,T,MLT,KIND,ALPHA,BETA,F,QFSUM
     1,NWF,WF,NIWF,IWF,IER)
C     ROUTINE TO:
C     1.    COMPUTE AN INTERPOLATORY QF FOR CLASSICAL
C           WEIGHT FUNCTION WITH DEFAULT VALUES FOR A,B
C     2.    EVALUATE THE QUADRATURE SUM
C
C      INPUT AND OUTPUT VARIABLES -
C                        I  I I   I    I     I    I O
C      SUBROUTINE CEIQFS(NT,T,MLT,KIND,ALPHA,BETA,F,QFSUM
C     1,NWF,WF,NIWF,IWF,IER)
C       I   O  I    O   O
C
C     NEED NWF .GE. NSTAR+RMAX+NT+3*(N+1)
C         NIWF .GE. NT
C
C     FUNCTION F, MUST BE DECLARED IN AN EXTERNAL STATEMENT
C     IN THE CALLING PROGRAM.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CIQFS EIQF F
      DOUBLE PRECISION ALPHA,BETA,QFSUM,T,WF,F
      INTEGER IER,IWF,J,KEY,KIND,L,LEX,LU,M,MLT,MTM,N,NA,NIWF
      INTEGER NST,NT,NW,NWF
      DIMENSION T(NT),MLT(NT),WF(NWF),IWF(NIWF)
      EXTERNAL F
C
      IER=0
      IF(NIWF.GE.NT)                          GOTO 10
      IER=9
                                              RETURN
   10 LU=0
      N=0
      MTM=MLT(1)
      DO 20 J=1,NT
         MTM=MAX(MTM,MLT(J))
   20 N=N+MLT(J)
      M=N+1
      NST=M/2
      L=MIN(2*MTM,M)
      LEX=NST+3*M+L+NT
      IF(NWF.GE.LEX)                          GOTO 30
      IER=-LEX
                                              RETURN
C     INDECIES FOR WTS,NDX,WF (RESP)
   30 NA=1
      NW=NA+N
      KEY=1
      CALL CIQFS(NT,T,MLT,N,WF(NA),IWF,KEY,KIND,ALPHA,BETA
     1,LU,NWF-NW,WF(NW),IER)
      IF(IER.NE.0)                            RETURN
      CALL EIQF(NT,T,MLT,WF(NA),N,IWF,KEY,F,QFSUM,IER)
                                              RETURN
      END
      SUBROUTINE CEIQF(NT,T,MLT,KIND,ALPHA,BETA,A,B,F,QFSUM
     1,NWF,WF,NIWF,IWF,IER)
C     ROUTINE TO:
C     1.    COMPUTE AN INTERPOLATORY QF WITH CLASSICAL
C           WEIGHT FUNCTION WITH ANY VALID A,B
C     2.    EVALUATE THE QUADRATURE SUM
C
C      INPUT AND OUTPUT VARIABLES -
C                       I  I I   I    I     I    I I I O
C      SUBROUTINE CEIQF(NT,T,MLT,KIND,ALPHA,BETA,A,B,F,QFSUM
C     1,NWF,WF,NIWF,IWF,IER)
C       I   O  I    O   O
C
C     NEED NWF  .GE. NSTAR+RMAX+NT+3*(N+1)
C          NIWF .GE. NT
C
C     FUNCTION F, MUST BE DECLARED IN AN EXTERNAL STATEMENT
C     IN THE CALLING PROGRAM.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CIQF EIQF F
      DOUBLE PRECISION A,ALPHA,B,BETA,QFSUM,T,WF,F
      INTEGER IER,IWF,J,KEY,KIND,L,LEX,LU,M,MLT,MTM,N,NA,NIWF
      INTEGER NST,NT,NW,NWF
      DIMENSION T(NT),MLT(NT),WF(NWF),IWF(NIWF)
      EXTERNAL F
C
      IER=0
      IF(NIWF.GE.NT)                          GOTO 10
      IER=9
                                              RETURN
   10 LU=0
      N=0
      MTM=MLT(1)
      DO 20 J=1,NT
         MTM=MAX(MTM,MLT(J))
   20 N=N+MLT(J)
      M=N+1
      NST=M/2
      L=MIN(2*MTM,M)
      LEX=NST+3*M+L+NT
      IF(NWF.GE.LEX)                          GOTO 30
      IER=-LEX
                                              RETURN
C     INDECIES FOR WTS,WF
   30 NA=1
      NW=NA+N
      KEY=1
      CALL CIQF(NT,T,MLT,N,WF(NA),IWF,KEY,KIND,ALPHA,BETA,A,B
     1,LU,NWF-NW,WF(NW),IER)
      IF(IER.NE.0)                            RETURN
      CALL EIQF(NT,T,MLT,WF(NA),N,IWF,KEY,F,QFSUM,IER)
                                              RETURN
      END
      SUBROUTINE CIQFS(NT,T,MLT,NWTS,WTS,NDX,KEY,KIND,ALPHA,BETA
     1,LO,NWF,WF,IER)
C     ROUTINE TO COMPUTE SOME OR ALL THE WEIGHTS OF A
C     QF FOR A CLASSICAL WEIGHT FUNCTION WITH DEFAULT VALUES OF A,B
C     AND A GIVEN SET OF KNOTS AND MULTIPLICITIES. THE WEIGHTS MAY BE
C     PACKED INTO THE OUTPUT ARRAY WTS ACCORDING TO A USER-DEFINED
C     PATTERN OR SEQUENTIALLY. THE ROUTINE WILL ALSO
C     OPTIONALLY PRINT KNOTS AND WEIGHTS AND A CHECK OF THE MOMENTS
C
C     LO.GT.0...COMPUTE WEIGHTS. PRINT WEIGHTS. PRINT MOMENTS CHECK.
C     LO.EQ.0...COMPUTE WEIGHTS. PRINT NOTHING. NO MOMENTS CHECK.
C     LO.LT.0...COMPUTE WEIGHTS. PRINT WEIGHTS. NO MOMENTS CHECK.
C
C      INPUT AND OUTPUT VARIABLES -
C                       I  I I   I    O   *   I   I    I     I
C      SUBROUTINE CIQFS(NT,T,MLT,NWTS,WTS,NDX,KEY,KIND,ALPHA,BETA
C     1,LO,NWF,WF,IER)
C       I  I   O  O
C
C     NEED NWF.GE.NSTAR+RMAX+2*(N+1) IF NO MOMENTS CHECK REQUIRED
C                 NSTAR+RMAX+2*(2*N+5)IF A MOMENTS CHECK REQUIRED
C     KEY...AN INTEGER VARIABLE INDICATING THE STRUCTURE OF THE WTS
C           ARRAY. IT WILL NORMALLY BE SET TO 1. FOR MORE DETAILS SEE
C           THE COMMENTS IN CAWIQ.
C     NDX...AN INTEGER ARRAY OF DIMENSION NT USED TO INDEX THE OUTPUT
C           ARRAY WTS. IF KEY=1 NDX NEED NOT BE PRESET. FOR MORE
C           DETAILS SEE THE COMMENTS IN CAWIQ.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CAWIQ CHKQFS CLASS
      DOUBLE PRECISION ALPHA,BETA,T,WF,WTS,ZEMU
      INTEGER IER,IFL,J,JDF,K,KEY,KIND,L,LEX,LO,M,MEX,MLT,MMEX
      INTEGER MTM,N,NA,NB,ND,NDX,NE,NF,NST,NT,NW,NWF,NWTS
      DIMENSION T(NT),MLT(NT),WTS(NWTS),WF(NWF),NDX(NT)
C
      IER=0
      JDF=0
      N=0
      MTM=MLT(1)
      L=ABS(KEY)
      DO 20 J=1,NT
         IF(L.EQ.1)                              GOTO 10
         IF(ABS(NDX(J)).EQ.0)                    GOTO 20
   10    MTM=MAX(MTM,MLT(J))
         N=N+MLT(J)
   20 CONTINUE
C     N KNOTS WHEN COUNTED ACCORDING TO MULT
      IF(NWTS.GE.N)                              GOTO 30
      IER=10
                                                 RETURN
   30 M=N+1
      MEX=2+M
      NST=M/2
      IFL=1
      IF(LO.LE.0)IFL=0
      L=MIN(2*MTM,M)
      K=MAX(M,3*(MEX)*IFL)
      LEX=NST+M+L+K
      IF(NWF.GE.LEX)                            GOTO 40
      IER=-LEX
                                                RETURN
C
C     SET UP WORK FIELD INDECIES FOR CLASS AND CAWIQ
   40 NA=1
      NB=NA+NST
      NW=NB+NST
C
C     GET JACOBI MATRIX
      CALL CLASS(KIND,NST,ALPHA,BETA,WF(NB),WF(NA),ZEMU,IER)
      IF(IER.NE.0)                              RETURN
C
C     CALL WEIGHTS ROUTINE
      CALL CAWIQ(NT,T,MLT,N,WTS,NDX,KEY
     1,NST,WF(NA),WF(NB),JDF,ZEMU,NWF-NW,WF(NW),IER)
C     RETURN IF NO PRINTING OR CHECKING REQUIRED
   50 IF(IER.NE.0.OR.LO.EQ.0)                   RETURN
      MMEX=MEX*IFL
      ND=1
      NE=ND+MMEX
      NF=NE+MMEX
      NW=NF+MMEX
C     CALL CHECKING ROUTINE
      CALL CHKQFS(T,WTS,MLT,NT,N,NDX,KEY,WF(NW),M-1,MEX,KIND,
     1           ALPHA,BETA,LO,WF(ND),WF(NE),WF(NF),IER)
                                                RETURN
      END
      SUBROUTINE CIQF(NT,T,MLT,NWTS,WTS,NDX,KEY,KIND,ALPHA,BETA,A,B
     1,LO,NWF,WF,IER)
C     ROUTINE TO COMPUTE SOME OR ALL THE WEIGHTS OF A
C     QF FOR A CLASSICAL WEIGHT FUNCTION WITH ANY VALID A,B AND
C     A GIVEN SET OF KNOTS AND MULTIPLICITIES. THE WEIGHTS MAY BE
C     PACKED INTO THE OUTPUT ARRAY WTS ACCORDING TO A USER-DEFINED
C     PATTERN OR SEQUENTIALLY. THE ROUTINE WILL ALSO
C     OPTIONALLY PRINT KNOTS AND WEIGHTS AND A CHECK OF THE MOMENTS
C
C     LO.GT.0...COMPUTE WEIGHTS. PRINT WEIGHTS. PRINT MOMENTS CHECK.
C     LO.EQ.0...COMPUTE WEIGHTS. PRINT NOTHING. NO MOMENTS CHECK.
C     LO.LT.0...COMPUTE WEIGHTS. PRINT WEIGHTS. NO MOMENTS CHECK.
C
C      INPUT AND OUTPUT VARIABLES -
C                      I  I I   I    O   *   I   I    I     I    I I
C      SUBROUTINE CIQF(NT,T,MLT,NWTS,WTS,NDX,KEY,KIND,ALPHA,BETA,A,B
C     1,LO,NWF,WF,IER)
C       I  I   O  O
C
C     NEED NWF.GE.NSTAR+RMAX+2*(N+1) IF NO MOMENTS CHECK REQUIRED
C                 NSTAR+RMAX+5*N+NT+13 IF A MOMENTS CHECK IS REQUIRED
C     KEY...AN INTEGER VARIABLE INDICATING THE STRUCTURE OF THE WTS
C           ARRAY. IT WILL NORMALLY BE SET TO 1. THIS WILL CAUSE THE
C           WEIGHTS TO BE PACKED SEQUENTIALLY IN ARRAY WTS.
C           FOR MORE DETAILS SEE THE COMMENTS IN CAWIQ.
C     NDX...AN INTEGER ARRAY OF DIMENSION NT USED TO INDEX THE OUTPUT
C           ARRAY WTS. IF KEY=1 NDX NEED NOT BE PRESET. FOR MORE
C           DETAILS SEE THE COMMENTS IN CAWIQ.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CHKQF CIQFS SCQF SCT
      DOUBLE PRECISION A,ALPHA,B,BETA,T,WF,WTS
      INTEGER IER,IFL,J,K,KEY,KIND,L,LEX,LO,LU,M,MEX,MMEX,MLT,MTM
      INTEGER ND,NDX,NE,NF,NST,NT,NW,NWF,NWTS
      DIMENSION T(NT),MLT(NT),WTS(NWTS),WF(NWF),NDX(NT)
C
      IER=0
      M=1
      MTM=1
      L=ABS(KEY)
      DO 20 J=1,NT
         IF(L.EQ.1)                            GOTO 10
         IF(ABS(NDX(J)).EQ.0)                  GOTO 20
   10    MTM=MAX(MTM,MLT(J))
         M=M+MLT(J)
   20 CONTINUE
      IF(NWTS+1.GE.M)                          GOTO 30
      IER=10
                                               RETURN
   30 NST=M/2
      MEX=2+M
      IFL=1
      IF(LO.LE.0)IFL=0
      L=MIN(2*MTM,M)
      K=MAX(M,3*MEX*IFL)
      LEX=NST+L+K+M+(MEX+NT)*IFL
      IF(NWF.GE.LEX)                           GOTO 40
      IER=-LEX
                                               RETURN
   40 CONTINUE
      NST=1
      NF=NST+NT
C     SCALE THE KNOTS TO DEFAULT A,B
      CALL SCT(NT,T,WF(NST),KIND,A,B,IER)
      IF(IER.NE.0)                             RETURN
      LU=0
      CALL CIQFS(NT,WF(NST),MLT,NWTS,WTS,NDX,KEY,
     1KIND,ALPHA,BETA,LU,NWF-NF+1,WF(NF),IER)
      IF(IER.NE.0)                             RETURN
C     DON'T SCALE USER'S KNOTS - ONLY SCALE WEIGHTS
      CALL SCQF(NT,WF(NST),MLT,WTS,NWTS,NDX,WTS,WF(NST),
     1KIND,ALPHA,BETA,A,B,IER)
      IF(IER.NE.0.OR.LO.EQ.0)                  RETURN
      MMEX=MEX*IFL
      ND=1
      NE=ND+MMEX
      NF=NE+MMEX
      NW=NF+MMEX
      CALL CHKQF(T,WTS,MLT,NT,NWTS,NDX,KEY,WF(NW),M-1,MEX,KIND,
     1           ALPHA,BETA,LO,WF(ND),WF(NE),WF(NF),NWF-NW,A,B,IER)
                                               RETURN
      END
      SUBROUTINE EIQF(NT,T,MLT,WTS,NWTS,NDX,KEY,F,QFSUM,IER)
C     ROUTINE TO EVALUATE AN INTERPOLATORY QF WITH KNOTS, WEIGHTS
C     AND INTEGRAND SUPPLIED.
C     ALL KNOTS FOR WHICH NDX(I).NE.0 ARE USED.
C      INPUT AND OUTPUT VARIABLES -
C                      I  I I   I   I    I   I   I O     O
C      SUBROUTINE EIQF(NT,T,MLT,WTS,NWTS,NDX,KEY,F,QFSUM,IER)
C
C     **************************************************************
C     *
C     *  F.......A FUNCTION WITH 2 PARAMETERS F(X,I)
C     *  TO BE SUPPLIED BY THE USER.  IT MUST RETURN THE I-TH
C     *  DERIVATIVE OF F, THE FUNCTION BEING INTEGRATED, AT X.
C     *  I MUST RANGE FROM 0 (FOR THE FUNCTION VALUES) UP TO
C     *  (THE MAXIMUM VALUE IN MLT)-1. THIS FUNCTION WILL ONLY
C     *  BE CALLED WITH F AND ITS DERIVATIVES AT THE KNOTS SUPPLIED
C     *  SO IT CAN GENERATE THE VALUES FOR F BY TABLE LOOKUP.
C     *  THIS CAN BE ACHIEVED BY REPLACING THE LINE
C     *           QFSUM=QFSUM+WTS(L+I-1)*F(T(J),I-1)/P
C     *  WITH
C     *           QFSUM=QFSUM+WTS(L+I-1)*F(T,J,I-1)/P
C     *  WHERE THE FUNCTION F HAS THE KNOTS ARRAY T AS A PARAMETER
C     *  AND THE REQUIRED KNOT IS INDICATED BY THE INDEX J. F IS
C     *  CALLED ONLY FROM THIS ROUTINE AND EIQFS.
C     *
C     **************************************************************
C     FUNCTIONS AND SUBROUTINES REFERENCED -  F
      DOUBLE PRECISION P,QFSUM,T,WTS,F
      INTEGER I,IER,J,KEY,L,MLT,NDX,NT,NWTS
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      DIMENSION T(NT),MLT(NT),WTS(NWTS),NDX(NT)
      EXTERNAL F
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
      IER=0
      L=ABS(KEY)
      IF(L.GE.1.AND.L.LE.4)                     GOTO 10
      IER=17
                                                RETURN
   10 QFSUM=ZERO
      DO 30 J=1,NT
         L=ABS(NDX(J))
         IF(L.EQ.0)                             GOTO 30
         P=ONE
         DO 20 I=1,MLT(J)
            QFSUM=QFSUM+WTS(L+I-1)*F(T(J),I-1)/P
            IF(KEY.GT.0)                        GOTO 20
            P=P*I
   20    CONTINUE
   30 CONTINUE
                                                RETURN
      END
      SUBROUTINE EIQFS(NT,T,WTS,F,QFSUM,IER)
C     ROUTINE TO EVALUATE AN INTERPOLATORY QF WITH ALL KNOTS SIMPLE AND
C     ALL KNOTS INCLUDED IN THE QUADRATURE. THIS ROUTINE WILL BE USED
C     TYPICALLY AFTER CLIQF OR CLIQFS HAVE BEEN CALLED.
C      INPUT AND OUTPUT VARIABLES -
C                       I  I I   I O     O
C      SUBROUTINE EIQFS(NT,T,WTS,F,QFSUM,IER)
C
C     **************************************************************
C     *
C     *  F.......A FUNCTION WITH 2 PARAMETERS F(X,I) TO BE SUPPLIED
C     *  BY THE USER.  F MUST RETURN THE VALUE OF F,
C     *  THE FUNCTION BEING INTEGRATED, AT X.
C     *  I MAY BE A DUMMY VARIABLE BUT IS INCLUDED TO MAKE THIS
C     *  DEFINITION CONFORM WITH THAT FOR F ELSEWHERE. THIS FUNCTION
C     *  WILL ONLY BE CALLED WITH F AND ITS DERIVATIVES AT THE KNOTS
C     *  SUPPLIED SO IT CAN GENERATE THE VALUES FOR F BY TABLE LOOKUP.
C     *  THIS CAN BE ACHIEVED BY REPLACING THE LINE
C     *               QFSUM=QFSUM+WTS(J)*F(T(J),0)
C     *  WITH
C     *              QFSUM=QFSUM+WTS(J)*F(T,J,0)
C     *  WHERE THE FUNCTION F HAS THE KNOTS ARRAY T AS A PARAMETER
C     *  AND THE REQUIRED KNOT IS INDICATED BY THE INDEX J. F IS
C     *  CALLED ONLY FROM THIS ROUTINE AND EIQF.
C     *
C     **************************************************************
C     FUNCTIONS AND SUBROUTINES REFERENCED -  F
      DOUBLE PRECISION QFSUM,T,WTS,F
      INTEGER IER,J,NT
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      DIMENSION T(NT),WTS(NT)
      EXTERNAL F
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
      IER=0
      QFSUM=ZERO
      DO 10 J=1,NT
         QFSUM=QFSUM+WTS(J)*F(T(J),0)
   10 CONTINUE
                                                RETURN
      END
      SUBROUTINE CAWIQ(NT,T,MLT,NWTS,WTS,NDX,KEY
     1,NST,AJ,BJ,JDF,ZEMU,NWF,WF,IER)
C
C     THIS ROUTINE, GIVEN A SET OF DISTINCT KNOTS, T, THEIR
C     MULTIPLICITIES MLT, THE JACOBI MATRIX ASSOCIATED WITH THE
C     POLYNOMIALS ORTHOGONAL WITH RESPECT TO THE WEIGHT FUNCTION W(X),
C     AND THE ZERO-TH MOMENT OF W(X) COMPUTES THE WEIGHTS OF THE
C     QUADRATURE
C
C                                       (I)
C         SUM          SUM         D   F   (T(J))
C       J=1,NT     I=0,MLT(J)-1     J,I
C
C       WHICH IS TO APPROXIMATE
C
C       INTEGRAL  F(T)W(T) DT
C        ÕA,Bå
C
C     THE ROUTINE MAKES VARIOUS CHECKS, AS INDICATED BELOW, SETS UP
C     VARIOUS VECTORS AND, IF NECESSARY, CALLS FOR THE DIAGONALIZATION
C     OF THE JACOBI MATRIX THAT IS ASSOCIATED WITH THE POLYNOMIALS
C     ORTHOGONAL WITH RESPECT TO W(X) ON ÕA,Bå. THEN FOR EACH KNOT, THE
C     WEIGHTS OF WHICH ARE REQUIRED, IT CALLS THE ROUTINE CWIQD WHICH
C     COMPUTES ALL THE WEIGHTS FOR ANY GIVEN KNOT.
C
C      INPUT AND OUTPUT VARIABLES -
C                       I  I I   I    O   *   I
C      SUBROUTINE CAWIQ(NT,T,MLT,NWTS,WTS,NDX,KEY
C     1,NST,AJ,BJ,JDF,ZEMU,NWF,WF,IER)
C       I   I  I  I   I    I   O  O
C
C     PARAMETERS MARKED WITH A * MAY BE CHANGED BY THE SUBROUTINE
C
C    *NDX     THIS ARRAY ASSOCIATES WITH EACH DISTINCT KNOT T(J),
C             AN INTEGER NDX(J) WHICH IS SUCH THAT THE WEIGHT TO THE
C             I-TH DERIV VALUE OF F AT THE J-TH KNOT, IS STORED IN
C
C                      WTS(ABS(NDX(J))+I) J=1,2,...,NT,
C                                         I=0,1,2,...,MLT(J)-1
C             ALSO:
C             NDX     > 0 MEANS WEIGHTS ARE WANTED FOR THIS KNOT
C                     < 0 MEANS WEIGHTS NOT WANTED FOR THIS KNOT BUT THE
C                               KNOT IS TO BE INCLUDED IN THE QUADRATURE
C                     = 0 MEANS IGNORE THIS KNOT COMPLETELY
C     KEY     SWITCH INDICATING STRUCTURE OF OUTPUT ARRAYS WTS
C             AND NDX.
C
C             ABS(KEY)=    1      SET UP POINTERS IN NDX FOR ALL KNOTS
C                                 IN T ARRAY (ROUTINE CAWIQ DOES THIS).
C                                 THE CONTENTS OF NDX ARE NOT TESTED
C                                 ON INPUT AND WEIGHTS ARE PACKED
C                                 SEQUENTIALLY IN WTS AS INDICATED
C                                 ABOVE
C                          2      SET UP POINTERS ONLY FOR KNOTS WHICH
C                                 HAVE NDX.NE.0 ON INPUT. ALL KNOTS
C                                 WHICH HAVE A NON-ZERO FLAG ARE
C                                 ALLOCATED SPACE IN WTS
C                          3      SET UP POINTERS ONLY FOR KNOTS WHICH
C                                 HAVE NDX.GT.0 ON INPUT. SPACE IN WTS
C                                 ALLOCATED ONLY FOR KNOTS WITH
C                                 NDX > 0
C                          4      NDX ASSUMED TO BE PRESET AS POINTER
C                                 ARRAY ON INPUT
C
C              AND KEY>0 FOR WEIGHTS WTS(J) REQUIRED IN STANDARD FORM
C                  KEY<0 FOR J]WTS(J) REQUIRED
C
C     NST     DIMENSION OF JACOBI MATRIX. NST SHOULD BE BETWEEN (N+1)/2
C             AND N. THE USUAL CHOICE WILL BE (N+1)/2
C    *JDF     FLAG TO INDICATE WHETHER JACOBI MATRIX NEEDS
C             DIAGONALIZING OR NOT
C                   JDF=      0      DIAGONALIZATION REQUIRED
C                             1      DIAGONALIZATION NOT REQUIRED
C
C    *AJ,BJ   IT IS ASSUMED ON INPUT THAT
C             IF JDF = 0 THEN       AJ CONTAINS THE  DIAGONAL OF THE
C                                   JACOBI MATRIX AND
C                                   BJ CONTAINS THE SUBDIAGONAL.
C
C                                   NOTE THAT BJ(NST) IS ALSO
C                                   DEFINED BUT NOT USED.
C
C             IF JDF = 1            AJ CONTAINS THE EIGENVALUES OF
C                                   THE JACOBI MATRIX AND
C                                   BJ CONTAINS THE SQUARES OF THE
C                                   ELEMENTS OF THE 1ST ROW OF U THE
C                                   ORTHOGONAL MATRIX DIAGONALIZING THE
C                                                          T
C                                   JACOBI MATRIX AS  U D U .
C     ZEMU    ZERO-TH MOMENT OF THE WEIGHT FUNCTION W(X)
C     NWF     DIMENSION OF WORK FIELD. MUST HAVE NWF.GE.NST+RMAX+N
C    *IER     ERROR FLAG: CODED AS FOLLOWS
C             10        NWTS TOO SMALL
C             11        JACOBI MATRIX NOT DIAGONALIZED SUCCESSFULLY
C             12        NST TOO SMALL FOR N
C             13        ZEMU > 0 FALSE
C             14        KNOTS NOT DISTINCT
C             15        MLT(J)<1 FOR SOME J
C             16        POINTERS FOR WTS CONTRADICTORY
C             17        0 < ABS(KEY) < 5 FALSE
C             18        NT < 1
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CWIQD IMTQLX MACHEP SIGN
      DOUBLE PRECISION AJ,BJ,P,PREC,T,TMP,WF,WTS,ZEMU
      INTEGER I,IER,IERRX,IP,IPM,J,JDF,JJ,JP,K,KEY,L,M,MLT,MNM,MTJ,MTM
      INTEGER N,NDX,NK,NM,NMAX,NR,NST,NT,NW,NWF,NWTS,NY,NZ
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      DIMENSION T(NT),MLT(NT),WTS(NWTS)
     1,NDX(NT),AJ(NST),BJ(NST),WF(NWF)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
      COMMON /CTRLR/ PREC(10)
C
C     COMPUTE MACHINE EPSILON
      CALL MACHEP(PREC(1))
C
C     EXIT IF NT < 1
      IER=18
      IF(NT.LT.1)                               RETURN
      IER=0
C
C     CHECK FOR INDISTINCT KNOTS
      IF(NT.EQ.1)                               GOTO 20
      K=NT-1
      DO 10 I=1,K
         TMP=T(I)
         L=I+1
         DO 10 J=L,NT
            IF( ABS(TMP-T(J)).GT.PREC(1))       GOTO 10
            IER=14
                                                RETURN
   10 CONTINUE
C
C     CHECK MULTIPLICITIES,
C     SET UP VARIOUS USEFUL PARAMETERS AND
C     SET UP OR CHECK POINTERS TO WTS ARRAY
   20 L=ABS(KEY)
      IF(L.GE.1.AND.L.LE.4)                     GOTO 30
      IER=17
                                                RETURN
   30 K=1
      GOTO(40,60,60,100),L
   40 DO 50 I=1,NT
         NDX(I)=K
         IF(MLT(I).LT.1)                        GOTO 90
         K=K+MLT(I)
   50 CONTINUE
      N=K-1
                                                GOTO 140
   60 N=0
      DO 80 I=1,NT
         IF(NDX(I).EQ.0)                        GOTO 80
         IF(MLT(I).LT.1)                        GOTO 90
         N=N+MLT(I)
         IF(NDX(I).LT.0.AND.L.EQ.3)             GOTO 80
   70    NDX(I)= SIGN(K,NDX(I))
         K=K+MLT(I)
   80 CONTINUE
      IF(K.LE.NWTS+1)                           GOTO 140
      IER=10
                                                RETURN
   90 CONTINUE
      IER=15
                                                RETURN
  100 CONTINUE
      DO 120 I=1,NT
         IP=ABS(NDX(I))
         IF(IP.EQ.0)                            GOTO 120
         IPM=IP+MLT(I)
         IF(IPM.GT.NWTS)                        GOTO 130
         IF(I.EQ.NT)                            GOTO 140
         L=I+1
         DO 110 J=L,NT
            JP=ABS(NDX(J))
            IF(JP.EQ.0)                         GOTO 110
            IF(JP.LE.IPM.AND.IP.LE.JP+MLT(J))   GOTO 130
  110    CONTINUE
  120 CONTINUE
                                                GOTO 140
  130 IER=16
                                                RETURN
C
C     GET MAXIMUM MULTIPLICITY TO SEE IF ENOUGH STORE
C     IS AVAILABLE
  140 MTM=1
      DO 150 I=1,NT
         IF(NDX(I).GT.0)MTM=MAX(MTM,MLT(I))
  150 CONTINUE
C
C     SET UP WORK FIELDS AND TEST SOME PARAMETERS
      IF(NST.LT.(N+1)/2)IER=12
      NMAX=N+NST+MIN(2*MTM,N+1)
      IF(ZEMU.LE.ZERO)IER=13
      IF(NMAX.GT.NWF)IER=-NMAX
      IF(IER.NE.0)                              RETURN
C
C     TREAT A QF WITH 1 SIMPLE KNOT FIRST.
      IF(N.GT.1)                                GOTO 180
      DO 160 I=1,NT
         IF(NDX(I).GT.0)                        GOTO 170
  160 CONTINUE
C     WEIGHT NOT WANTED]  DO NOTHING.
                                                RETURN
  170 WTS(ABS(NDX(I)))=ZEMU
                                                RETURN
C     SKIP DIAGONALIZATION IF ALREADY DONE
  180 IF(JDF.NE.0)                              GOTO 230
      NW=1
C
C     SET UNIT VECTOR IN WORK FIELD TO GET BACK 1ST ROW OF Q
      DO 190 I=1,NST
         K=NW+I-1
         WF(K)=ZERO
  190 CONTINUE
      WF(NW)=ONE
  200 IERRX=0
C
C     DIAGONALIZE JACOBI MATRIX
      CALL IMTQLX(NST,AJ,BJ,WF(NW),IERRX)
C
C     CHECK FOR ERROR
      IF(IERRX.EQ.0)                            GOTO 210
      IER=11
                                                RETURN
C
C     SIGNAL JACOBI MATRIX NOW DIAGONALIZED SUCCESSFULLY AND SAVE
C     SQUARES OF 1ST ROW OF U IN SUBDIAGONAL ARRAY
C
  210 JDF=1
      DO 220 I=1,NST
         L=I+NW-1
         BJ(I)=WF(L)**2
  220 CONTINUE
C
C     FIND ALL THE WEIGHTS FOR EACH KNOT FLAGGED
  230 CONTINUE
      DO 280 I=1,NT
         IF(NDX(I).LE.0)                        GOTO 280
         M=MLT(I)
         NM=N-M
         MNM=MAX(NM,1)
         L=MIN(M,NM+1)
C
C        SET UP INDECIES FOR WORK FIELDS
         NK=NW+NST
         NY=NK+MNM
         NR=NY+M
         NZ=NR+L
C
C     SET UP K-HAT MATRIX (FOR CWIQD) WITH KNOTS ACCORDING TO
C     THEIR MULTIPLICITIES
         K=NK
         DO 250 J=1,NT
            IF(NDX(J).EQ.0)                     GOTO 250
            IF(J.EQ.I)                          GOTO 250
            MTJ=MLT(J)
            DO 240 JJ=1,MTJ
               WF(K)=T(J)
               K=K+1
  240       CONTINUE
  250    CONTINUE
C
C        SET UP RIGHT PRINCIPAL VECTOR ARRAY FOR WEIGHTS ROUTINE
         WF(NR)=ONE/ZEMU
         DO 260 J=2,L
            K=NR+J-1
            WF(K)=ZERO
  260    CONTINUE
C
C        PICK UP POINTER FOR THE LOCATION OF THE WEIGHTS TO
C        BE OUTPUT
         K=NDX(I)
C
C        FIND ALL THE WEIGHTS FOR THIS KNOT
C
         CALL CWIQD(M,MNM,L,T(I),WF(NK),NST,AJ,BJ,
     1WF(NW),WF(NY),WF(NR),WF(NZ),WTS(K))
         IF(KEY.LT.0)                           GOTO 280
C
C        DIVIDE BY FACTORIALS FOR WEIGHTS IN STANDARD FORM
         IF(M.LT.2)                             GOTO 280
         TMP=ONE
         IP=M-1
         DO 270 J=2,IP
            P=J
            TMP=TMP*P
            L=K+J
            WTS(L)=WTS(L)/TMP
  270    CONTINUE
  280 CONTINUE
                                                RETURN
      END
      SUBROUTINE CWIQD(M,NM,L,V,XK,NSTAR,PHI,A,WF,Y,R,Z,D)
C     ROUTINE TO COMPUTE ALL THE WEIGHTS TO A GIVEN KNOT.
C     FOR DETAILS SEE:
C     KAUTSKY AND ELHAY "CALCULATION OF THE WEIGHTS OF INTERPOLATORY
C     QUADRATURES", NUMER MATH 40 (1982) 407-422.
C
C     VARIABLES NAMES USED CORRESPOND CLOSELY WITH THOSE IN THE ABOVE
C     MENTIONED PAPER
C      INPUT AND OUTPUT VARIABLES -
C                       I I  I I I  I     I   I O  O O O O
C      SUBROUTINE CWIQD(M,NM,L,V,XK,NSTAR,PHI,A,WF,Y,R,Z,D)
C
C            M      MULTIPLICITY OF THE KNOT IN QUESTION
C            NM     MAX(N-M,1). N=NUMBER OF KNOTS USED COUNTED
C                   ACCORDING TO MULTIPLICITY
C            L      MIN(M,N-M+1)
C            V      THE KNOT IN QUESTION
C            XK     ALL BUT THE LAST M ENTRIES IN THE DIAGONAL OF K-HAT
C            NSTAR  DIMENSION OF THE JACOBI MATRIX
C            PHI    THE EIGENVALUES OF THE JACOBI MATRIX J
C            A      THE SQUARE OF THE 1ST ROW OF THE ORTHOGONAL
C                   MATRIX DIAGONALIZING J
C            WF     WORK FIELD
C            Y      Y-HAT
C            R      VECTOR USED TO COMPUTE THE RIGHT PRINCIPAL VECTORS
C            Z      VECTOR USED TO COMPUTE THE LEFT PRINCIPAL VECTORS
C            D      OUTPUT ARRAY FOR THE WEIGHTS
C     OTHER VARIABLES ARE FOR TEMPORARY USE ONLY
C
      DOUBLE PRECISION SUM,TMP,V,A,D,PHI,R,WF,XK,Y,Z
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,J,JR,K,L,LAST,M,MINIL,NM,NSTAR
      DIMENSION XK(NM),PHI(NSTAR),A(NSTAR),WF(NSTAR),Y(M),
     1R(L),Z(M),D(M)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
C     COMPUTE PRODUCTS REQUIRED FOR Y-HAT
      DO20J=1,NSTAR
         WF(J)=A(J)
         IF(NM.LT.1)                            GOTO 20
         DO10I=1,NM
            WF(J)=WF(J)*(PHI(J)-XK(I))
   10    CONTINUE
   20 CONTINUE
C     COMPUTE Y-HAT
      DO40I=1,M
         SUM=ZERO
         DO30J=1,NSTAR
            SUM=SUM+WF(J)
            WF(J)=WF(J)*(PHI(J)-V)
   30    CONTINUE
         Y(I)=SUM
   40 CONTINUE
C     IF N=1 THE RIGHT PRINCIPAL VECTOR IS ALREADY IN R.
      IF(NM.EQ.0)                               GOTO 80
C     OTHERWISE COMPUTE THE R-PRINCIPAL VECTOR OF GRADE M-1
      DO70I=1,NM
         TMP=V-XK(I)
         IF(L.EQ.1)                             GOTO 60
         LAST=MIN(L,I+1)
         DO50JR=2,LAST
            J=LAST-JR+2
            R(J)=TMP*R(J)+R(J-1)
   50    CONTINUE
   60    R(1)=TMP*R(1)
   70 CONTINUE
C     COMPUTE LEFT PRINCIPAL VECTOR(S) AND WEIGHT FOR HIGHEST DERIV
C     THE FOLLOWING STATEMENT CONTAINS THE ONLY DIVISION IN THIS
C     ROUTINE. ANY TEST FOR OVERFLOW SHOULD BE MADE AFTER IT.
   80 Z(1)=ONE/R(1)
      D(M)=Y(M)*Z(1)
      IF(M.EQ.1)                                RETURN
C     COMPUTE L-PRINCIPAL VECTOR
      DO110I=2,M
         SUM=ZERO
         IF(L.EQ.1)                              GOTO 100
         MINIL=MIN(I,L)
         DO90J=2,MINIL
            K=I-J+1
            SUM=SUM+R(J)*Z(K)
   90    CONTINUE
  100    Z(I)=-SUM*Z(1)
  110 CONTINUE
C     ACCUMULATE WEIGHTS
      DO130I=2,M
         SUM=ZERO
         DO120J=1,I
            K=M-I+J
            SUM=SUM+Z(J)*Y(K)
  120    CONTINUE
         K=M-I+1
  130 D(K)=SUM
                                                RETURN
      END
      SUBROUTINE CLASS(KIND,M,ALPHA,BETA,BJ,AJ,ZEMU,IER)
C     ROUTINE TO COMPUTE THE DIAGONAL (AJ) AND SUB-DIAGONAL (BJ)
C     ELEMENTS OF THE ORDER M (TRIDIAGONAL SYMMETRIC) JACOBI MATRIX
C     ASSOCIATED WITH THE POLYNOMIALS ORTHOGONAL WITH RESPECT TO
C     THE WEIGHT FUNCTION SPECIFIED BY KIND.
C     FOR WEIGHT FUNCTIONS 1-7 M ELEMENTS ARE DEFINED IN BJ EVEN
C     THOUGH ONLY M-1 ARE NEEDED. FOR WEIGHT FUNCTION 8 BJ(M) IS
C     SET TO ZERO.
C     THE ZERO-TH MOMENT OF THE WEIGHT FUNCTION IS RETURNED IN
C     ZEMU.
C      INPUT AND OUTPUT VARIABLES -
C                       I    I I     I    O  O  O    O
C      SUBROUTINE CLASS(KIND,M,ALPHA,BETA,BJ,AJ,ZEMU,IER)
C
C     ERROR CODES ARE:
C     IER=1,2,3 PARAMETER RANGES ARE WRONG
C     IER=4 WEIGHT FUNCTION OF UNKNOWN TYPE. CANNOT GENERATE JACOBI
C           MATRIX
C     IER=5 GAMMA FUNCTION DOES NOT MATCH MACHINE PARAMETERS
C           IN ACCURACY
C
C     FUNCTIONS AND SUBROUTINES REFERENCED -  DGAMMA MACHEP SQRT PARCHK
      DOUBLE PRECISION AJ,BJ,A2B2,AB,ABA,ABI,ABJ,ABTI,ALPHA
      DOUBLE PRECISION APONE,BETA,TEMP,ZEMU,DGAMMA
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      DOUBLE PRECISION THREE,FOUR
      DOUBLE PRECISION PI
      INTEGER I,IER,KIND,M
      DIMENSION AJ(M),BJ(M)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
      PARAMETER (THREE=3.0D0,FOUR=4.0D0)
      PARAMETER (PI=3.14159 26535 89793 23846 26433 83279 50 D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
CS    PARAMETER (THREE=3.0E0,FOUR=4.0E0)
CS    PARAMETER (PI=3.14159 26535 89793 23846 26433 83279 50 E0)
C
      CALL MACHEP(TEMP)
      CALL PARCHK(KIND,2*M-1,ALPHA,BETA,IER)
      IF(ABS(DGAMMA(HALF)**2-PI).GT.5.0D2*TEMP)IER=5
      IF(IER.NE.0)                              RETURN
C
C           LEG,CHEB,GEG,JAC,LAG,HERM,EXP,RAT
      GO TO( 20,  50, 70, 90,110, 130, 10,150),KIND
   10 AB=ALPHA
                                                GOTO 30
   20 AB=ZERO
   30 ZEMU=TWO/(AB+ONE)
      DO 40 I=1,M
         AJ(I)=ZERO
         ABI=I+AB*MOD(I,2)
         ABJ=2*I+AB
   40 BJ(I)=ABI*ABI/(ABJ*ABJ-ONE)
                                                GOTO 170
   50 ZEMU=PI
      DO 60 I=1,M
         AJ(I)=ZERO
   60 BJ(I)=HALF
      BJ(1)= SQRT(HALF)
                                                RETURN
   70 AB=ALPHA*TWO
      ZEMU=TWO**(AB+ONE)*DGAMMA(ALPHA+ONE)**2/DGAMMA(AB+TWO)
      AJ(1)=ZERO
      BJ(1)=ONE/(TWO*ALPHA+THREE)
      DO 80 I=2,M
         AJ(I)=ZERO
   80 BJ(I)=I*(I+AB)/(FOUR*(I+ALPHA)**2-ONE)
                                                GOTO 170
   90 AB=ALPHA+BETA
      ABI=TWO+AB
      ZEMU=TWO**(AB+ONE)*DGAMMA(ALPHA+ONE)*DGAMMA(BETA+ONE)/
     1  DGAMMA(ABI)
      AJ(1)=(BETA-ALPHA)/ABI
      BJ(1)=FOUR*(ONE+ALPHA)*(ONE+BETA)/((ABI+ONE)*ABI*ABI)
      A2B2=BETA*BETA-ALPHA*ALPHA
      DO 100 I=2,M
         ABI=TWO*I+AB
         AJ(I)=A2B2/((ABI-TWO)*ABI)
         ABI=ABI**2
  100 BJ(I)=FOUR*I*(I+ALPHA)*(I+BETA)*(I+AB)/((ABI-ONE)*ABI)
                                                GOTO 170
  110 ZEMU=DGAMMA(ALPHA+ONE)
      DO 120 I=1,M
         AJ(I)=TWO*I-ONE+ALPHA
  120 BJ(I)=I*(I+ALPHA)
                                                GOTO 170
  130 ZEMU=DGAMMA((ALPHA+ONE)/TWO)
      DO 140 I=1,M
         AJ(I)=ZERO
  140 BJ(I)=(I+ALPHA*MOD(I,2))/TWO
                                                GOTO 170
  150 AB=ALPHA+BETA
      ZEMU=DGAMMA(ALPHA+ONE)*DGAMMA(-(AB+ONE))/DGAMMA(-BETA)
      APONE=ALPHA+ONE
      ABA=AB*APONE
      AJ(1)=-APONE/(AB+TWO)
      BJ(1)=-AJ(1)*(BETA+ONE)/(AB+TWO)/(AB+THREE)
      DO 160 I=2,M
         ABTI=AB+TWO*I
         AJ(I)=ABA+TWO*(AB+I)*(I-1)
  160  AJ(I)=-AJ(I)/ABTI/(ABTI-TWO)
      DO 165 I=2,M-1
         ABTI=AB+TWO*I
  165 BJ(I)=I*(ALPHA+I)/(ABTI-ONE)*(BETA+I)/
     1                       (ABTI**2)*(AB+I)/(ABTI+ONE)
      BJ(M)=ZERO
  170 DO 180 I=1,M
         BJ(I)= SQRT(BJ(I))
  180 CONTINUE
                                                RETURN
      END
      SUBROUTINE WM(W,M,KIND,ALPHA,BETA,IER)
C
C     ROUTINE TO EVALUATE THE FIRST M MOMENTS OF CLASSICAL WEIGHT
C     FUNCTIONS
C      INPUT AND OUTPUT VARIABLES -
C                    O I I    I     I    O
C      SUBROUTINE WM(W,M,KIND,ALPHA,BETA,IER)
C
C     FUNCTIONS AND SUBROUTINES REFERENCED -  DGAMMA SQRT PARCHK
      DOUBLE PRECISION ALPHA,ALS,BETA,SUM,TMPA,TMPB,TRM,W,DGAMMA
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      DOUBLE PRECISION THREE,FOUR
      DOUBLE PRECISION PI
      INTEGER I,IER,JA,JB,K,KIND,M
      DIMENSION W(M)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
      PARAMETER (THREE=3.0D0,FOUR=4.0D0)
      PARAMETER (PI=3.14159 26535 89793 23846 26433 83279 50 D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
CS    PARAMETER (THREE=3.0E0,FOUR=4.0E0)
CS    PARAMETER (PI=3.14159 26535 89793 23846 26433 83279 50 E0)
C
      CALL PARCHK(KIND,M,ALPHA,BETA,IER)
      IF(IER.NE.0)                              RETURN
      DO 10 K=2,M,2
   10 W(K)=ZERO
C           LEG,CHEB,GEG, JAC,LAG,HERM,EXP,RAT
      GO TO( 30, 60 , 80, 100,160, 180,20 ,200),KIND
   20 ALS=ALPHA
                                                GOTO 40
   30 ALS=ZERO
   40 DO 50 K=1,M,2
   50 W(K)=TWO/(K+ALS)
                                                RETURN
   60 W(1)=PI
      DO 70 K=3,M,2
   70 W(K)=W(K-2)*(K-TWO)/(K-ONE)
                                                RETURN
   80 W(1)=SQRT(PI)*DGAMMA(ALPHA+ONE)/DGAMMA(ALPHA+THREE/TWO)
      DO 90 K=3,M,2
   90 W(K)=W(K-2)*(K-TWO)/(TWO*ALPHA+K)
                                                RETURN
  100 ALS=ALPHA+BETA+ONE
      W(1)=TWO**ALS*DGAMMA(ALPHA+ONE)/DGAMMA(ALS+ONE)
     1   *DGAMMA(BETA+ONE)
      DO 150 K=2,M
         SUM=ZERO
         TRM=ONE
         DO 130 I=0,(K-2)/2
            TMPA=TRM
            DO 110 JA=1,2*I
  110       TMPA=TMPA*(ALPHA+JA)/(ALS+JA)
            DO 120 JB=1,K-2*I-1
  120       TMPA=TMPA*(BETA+JB)/(ALS+2*I+JB)
            TMPA=TMPA/(2*I+ONE)*
     1      (2*I*(BETA+ALPHA)+BETA-(K-ONE)*ALPHA)/(BETA+K-2*I-ONE)
            SUM=SUM+TMPA
            TRM=TRM*(K-2*I-ONE)/(2*I+ONE)*(K-2*I-TWO)/(2*I+TWO)
  130    CONTINUE
         IF(MOD(K,2).EQ.0)                      GOTO 150
         TMPB=ONE
         DO 140 I=1,K-1
  140    TMPB=TMPB*(ALPHA+I)/(ALS+I)
         SUM=SUM+TMPB
  150 W(K)=SUM*W(1)
                                                RETURN
  160 W(1)=DGAMMA(ALPHA+ONE)
      DO 170 K=2,M
  170 W(K)=(ALPHA+K-ONE)*W(K-1)
                                                RETURN
  180 W(1)=DGAMMA((ALPHA+ONE)/TWO)
      DO 190 K=3,M,2
  190 W(K)=W(K-2)*(ALPHA+K-TWO)/TWO
                                                RETURN
  200 W(1)=DGAMMA(ALPHA+ONE)*DGAMMA(-ALPHA-BETA-ONE)/DGAMMA(-BETA)
      DO 210 K=2,M
  210 W(K)=-W(K-1)*(ALPHA+K-ONE)/(ALPHA+BETA+K)
                                                RETURN
      END
      SUBROUTINE PARCHK(KIND,M,ALPHA,BETA,IER)
C     ROUTINE TO CHECK RANGES OF PARAMETERS ALPHA, BETA FOR CLASSICAL
C     WEIGHT FUNCTIONS. M IS THE ORDER OF THE JACOBI MATRIX
C     REQUIRED AND IS CONSTRAINED BY ALPHA AND BETA FOR THE RATIONAL
C     WEIGHT FUNCTION (SEE BELOW). M CAN BE REPLACED BY A DUMMY FOR
C     OTHER WEIGHT FUNCTIONS.
C      INPUT AND OUTPUT VARIABLES -
C                        I    I I     I    O
C      SUBROUTINE PARCHK(KIND,M,ALPHA,BETA,IER)
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - WM
      DOUBLE PRECISION ALPHA,BETA,TMP
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER IER,KIND,M
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C     CONSTRAINTS ON ALPHA,BETA:-
C            1      ALPHA.GT.-1
C            2      FOR KIND.LT.8 NEED BETA.GT.-1
C            3      FOR KIND.EQ.8 NEED BETA.LT.(ALPHA+BETA+2*M).LT.0 TO
C                   COMPUTE M ELEMENTS OF THE JACOBI MATRIX.
C      INPUT:
C      KIND...1-8 FOR CLASSICAL WEIGHT FUNCTION, 0 FOR UNKNOWN)
C      ALPHA,BETA...AS IN CLASS
C      M...ORDER OF HIGHEST MOMENT TO BE CALCULATED
C      OUTPUT:
C      IER...ERROR INDICATOR - CODED AS FOLLOWS
C            1...ALPHA.LE.-1
C            2...BETA.LE.-1
C            3...ALPHA,BETA COMBINATION WRONG FOR RATIONAL WEIGHT
C                FUNCTION
C            4...KIND=0. PARAMETERS CANNOT BE CHECKED AND JACOBI MATRIX
C                IS NOT OF CLASSICAL TYPE
      IER=0
      IF(KIND.LE.0)IER=4
C     CHECK GEGENBAUER,JACOBI,LAGUERRE,HERMITE, EXPONENTIAL
      IF(KIND.GE.3.AND.(ALPHA.LE.-ONE))IER=1
C
C     CHECK BETA FOR JACOBI
      IF(KIND.EQ.4.AND.BETA.LE.-ONE)IER=2
C
C     CHECK RANGE FOR RATIONAL
      IF(KIND.LT.8)                             RETURN
      TMP=ALPHA+BETA+M+ONE
      IF(TMP.GE.ZERO.OR.TMP.LE.BETA)IER=3
                                                RETURN
      END
      SUBROUTINE CHKQFS(T,WTS,MLT,NT,NWTS,NDX,KEY,W,MOP,MEX,
     1                 KIND,ALPHA,BETA,LO,E,ER,QM,IER)
C
C      ROUTINE TO CHECK THE POLYNOMIAL ACCURACY OF A QUADRATURE FORMULA.
C      IT WILL OPTIONALLY PRINT WEIGHTS, AND RESULTS OF A MOMENTS TEST.
C
C      INPUT AND OUTPUT VARIABLES -
C                        I I   I   I  I    I   I   * I   I
C      SUBROUTINE CHKQFS(T,WTS,MLT,NT,NWTS,NDX,KEY,W,MOP,MEX,
C     1                 KIND,ALPHA,BETA,LO,E,ER,QM,IER)
C                       I    I     I    I  O O  O  O
C
C      T...ARRAY OF DISTINCT KNOTS
C      W...MOMENTS ARRAY OF LENGTH MEX
C      MOP...THE EXPECTED ORDER OF PRECISION OF THE QF
C      MEX...THE TOTAL NUMBER (.GT.1) OF MOMENTS REQUIRED TO BE TESTED
C            SET MEX=1 AND LO.LT.0 FOR NO MOMENTS CHECK
C      KIND...KIND OF CLASSICAL FORMULA.
C             KIND=0 MEANS UNKNOWN WEIGHT FUNCTION.
C             THE FIRST MEX MOMENTS MUST BE SET UP
C             IN ARRAY W BY THE USER FOR THIS CASE.
C      LO...PRINTING (IF ANY) IS DONE ON UNIT ABS(LO). LO IS CODED
C          AS FOLLOWS:-
C          LO.GT.0 MEANS PRINT WEIGHTS AND MOMENT TESTS
C          LO.EQ.0 MEANS PRINT NOTHING. COMPUTE MOMENT TEST
C          LO.LT.0 MEANS PRINT WEIGHTS ONLY. DON'T COMPUTE MOMENT TESTS
C      E,ER...ABSOLUTE AND RELATIVE ERRORS OF THE QF APPLIED
C             TO (X-DEL)**N
C      QM...VALUES OF THE QF APPLIED TO (X-DEL)**N
C      IER...ERROR INDICATOR. ANY ERROR RETURN COMES FROM WM.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - WM
      DOUBLE PRECISION ALPHA,BETA,E,EK,EMN,EMX,EREST,ERN,ERX,ER,PX
      DOUBLE PRECISION TMP,TMPX,PREC,QM,T,W,WTS
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,IER,J,JL,K,KEY,KIND,KINDP,KJL,L,LO,LU,M,MEX,MLT
      INTEGER MOP,MX,NDX,NT,NWTS
      DIMENSION T(NT),WTS(NWTS),MLT(NT),W(MEX),NDX(NT)
      DIMENSION E(MEX),ER(MEX),QM(MEX)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
      COMMON /CTRLR/ PREC(10)
      CHARACTER*72 TXT1(10)
      DATA TXT1/
     1'          INTERPOLATORY QUADRATURE FORMULA',
     2' TYPE  INTERVAL     WEIGHT FUNCTION        NAME',
     3'   1    (-1,1)           ONE             LEGENDRE',
     4'   2    (-1,1)     (1-X**2)**(-HALF)     CHEBYSHEV',
     5'   3    (-1,1)      (1-X**2)**ALPHA      GEGENBAUER',
     6'   4    (-1,1)  (1-X)**ALPHA*(1+X)**BETA  JACOBI',
     7'   5   (0,INF)      X**ALPHA*EXP(-X)     GEN LAGUERRE',
     8'   6  (-INF,INF) ABS(X)**ALFA*EXP(-X**2) GEN HERMITE',
     9'   7    (-1,1)       ABS(X)**ALFA        EXPONENTIAL',
     1'   8   (0,INF)    X**ALFA*(1+X)**BETA     RATIONAL'/
      LU=ABS(LO)
C     KIND MAY BE SET TO -1 TO ALLOW PRINTING OF MOMENTS ONLY
C     THIS FEATURE IS ONLY USED INTERNALLY (BY CHKQF)
      KINDP=MAX(0,KIND)
      IF(LO.EQ.0.OR.KIND.EQ.-1)                 GOTO 40
C
      IF(KINDP.EQ.0)                            GOTO 10
      WRITE (LU,150)TXT1(1),TXT1(2),TXT1(KINDP+2)
      IF(KINDP.GE.3) WRITE (LU,160) ALPHA
      IF(KINDP.EQ.4.OR.KINDP.EQ.8) WRITE (LU,170) BETA
   10 IF(KIND.NE.-1) WRITE(LU,180)PREC(1)
C
      WRITE(LU,210)
      DO30 I=1,NT
         K=ABS(NDX(I))
         IF(K.EQ.0)                             GOTO 30
         WRITE(LU,190)I,T(I),MLT(I),WTS(K)
         DO 20 J=K+1,K+MLT(I)-1
            WRITE(LU,200)WTS(J)
   20    CONTINUE
   30 CONTINUE
   40 IF(LO.LT.0)                               RETURN
      IER=0
      IF(KINDP.NE.0)CALL WM(W,MEX,KINDP,ALPHA,BETA,IER)
      IF(IER.NE.0)                              RETURN
   50 DO 60 K=1,MEX
         QM(K)=ZERO
   60 CONTINUE
      EREST=ZERO
      DO 90 K=1,NT
         TMP=ONE
         L=ABS(NDX(K))
         IF(L.EQ.0)                             GOTO 90
         EREST=EREST+ABS(WTS(L))
         DO 80 J=1,MEX
            QM(J)=QM(J)+TMP*WTS(L)
            TMPX=TMP
            PX=ONE
            DO 70 JL=2,MIN(MLT(K),MEX-J+1)
               KJL=J+JL-1
               TMPX=TMPX*(KJL-1)
               QM(KJL)=QM(KJL)+TMPX*WTS(L+JL-1)/PX
               IF(KEY.GT.0)                     GOTO 70
               PX=PX*JL
   70       CONTINUE
            TMP=TMP*T(K)
   80    CONTINUE
   90 CONTINUE
      DO 100 K=1,MEX
         E(K)=W(K)-QM(K)
         ER(K)=E(K)/(ABS(W(K))+ONE)
  100 CONTINUE
C     FOR SOME STRANGE WEIGHT FUNCTIONS W(1) MAY VANISH
      EREST=EREST/(ABS(W(1))+ONE)
C     EXIT IF USER DOES NOT WANT PRINTED OUTPUT
      IF(LO.EQ.0)                               RETURN
      EMX=ABS(E(1))
      EMN=EMX
      ERX=ABS(ER(1))
      ERN=ERX
      M=MOP+1
      MX=MIN(MOP,MEX)
      DO 110 K=2,MX
         EMX=MAX(ABS(E(K)),EMX)
         EMN=MIN(ABS(E(K)),EMN)
         ERX=MAX(ABS(ER(K)),ERX)
         ERN=MIN(ABS(ER(K)),ERN)
  110 CONTINUE
      WRITE(LU,220) MOP,EMN,ERN,EMX,ERX,EREST
      IF(MEX.LT.M)                              GOTO 140
  120 EK=E(M)
      DO 130 J=1,MOP
         EK=EK/J
  130 CONTINUE
      WRITE(LU,230) MOP,E(M),EK
  140 WRITE (LU,240)
      WRITE (LU,250) (J,W(J),QM(J),E(J),ER(J),J=1,MX)
      WRITE (LU,250)
      IF(MEX.GE.M)WRITE (LU,250) (J,W(J),QM(J),E(J),ER(J),J=M,MEX)
  150 FORMAT(1H1,(8X,A72/))
  160 FORMAT(/24H   PARAMETER(S) ALPHA      ,F12.5)
  170 FORMAT( 24H                BETA       ,F12.5)
  180 FORMAT(/23H   MACHINE PRECISION   ,D13.1)
  190 FORMAT(2(I4,D26.17))
  200 FORMAT(37X,D26.17)
  210 FORMAT(/11X,5HKNOTS,15X,10HMULT      ,10X,7HWEIGHTS/)
  220 FORMAT(//' COMPARISON OF MOMENTS',//
     1,' ORDER OF PRECISION',I4,//
     2,'  ERRORS :    ABSOLUTE    RELATIVE'/
     3,'---------+-------------------------'/
     4,' MINIMUM :',2D12.3/
     5,' MAXIMUM :',2D12.3//
     6,' WEIGHTS RATIO          ',D13.3)
  230 FORMAT(' ERROR FOR ',I3,'-TH POWER ',D13.3/
     1      ,' ERROR CONSTANT         ',D13.3,/)
  240 FORMAT (/12H   MOMENTS:   /12X,4HTRUE ,12X,
     1 9HFROM Q.F. ,9X,5HERROR ,5X,8HRELATIVE  /)
  250 FORMAT (I4,2D19.10,2D12.3)
                                                RETURN
      END
      SUBROUTINE CHKQF(T,WTS,MLT,NT,NWTS,NDX,KEY,WF,MOP,MEX,KIND,
     1                  ALPHA,BETA,LO,E,ER,QM,NWF,A,B,IER)
C     ROUTINE TO COMPUTE AND PRINT THE MOMENTS OF A QF FOR
C     A CLASICAL WEIGHT FUNCTION WITH ANY VALID A,B
C     NO CHECK CAN BE MADE FOR NON-CLASSICAL WEIGHT FUNCTIONS
C
C      INPUT AND OUTPUT VARIABLES -
C                       I I   I   I  I    I   I   O  I   I   I
C      SUBROUTINE CHKQF(T,WTS,MLT,NT,NWTS,NDX,KEY,WF,MOP,MEX,KIND,
C     1                  ALPHA,BETA,LO,E,ER,QM,NWF,A,B,IER)
C                        I     I    I  O O  O  I   I I O
C
C      NWF...SIZE OF WORKFIELD ARRAY. MUST BE .GE. MEX+NT
C      MOP...THE EXPECTED ORDER OF PRECISION OF THE QF.
C      MEX...THE TOTAL NUMBER (.GT.1) OF MOMENTS REQUIRED TO BE TESTED
C            SET MEX=1 AND LO.LT.0 FOR NO MOMENTS CHECK
C      LO...PRINTING (IF ANY) IS DONE ON UNIT ABS(LO). LO IS CODED
C          AS FOLLOWS:-
C          LO.GT.0 MEANS PRINT WEIGHTS AND MOMENT TESTS
C          LO.EQ.0 MEANS PRINT NOTHING. COMPUTE MOMENT TEST
C          LO.LT.0 MEANS PRINT WEIGHTS ONLY. DON'T COMPUTE MOMENT TESTS
C      E,ER...ABSOLUTE AND RELATIVE ERRORS OF THE QF APPLIED
C             TO (X-DEL)**N
C      QM...VALUES OF THE QF APPLIED TO (X-DEL)**N
C      IER...ERROR INDICATOR. ANY ERROR RETURN COMES FROM WM.
C
C     IER CODES -
C     1-4       ERROR RETURN FROM PARCHK: ALPHA, BETA WRONG
C                     SEE ROUTINE PARCHECK
C       6       ZERO LENGTH INTERVAL (KIND=1,2,3,4,7)
C       7       B.LE.0 FOR (KIND=5,6)
C       8       A+B.LE.0 (KIND=8)
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - CHKQFS PARCHK SCMM
      DOUBLE PRECISION A,ALPHA,B,BETA,E,ER,PREC,QM,T,TMP,WF,WTS
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,IER,IZERO,KEY,KIND,LEX,LO,LU,MEX,MOP,NA,NEG,NT,NWF
      INTEGER NWTS,MLT,NDX
      DIMENSION T(NT),MLT(NT),WTS(NWTS),NDX(NT),WF(NWF)
      DIMENSION E(MEX),ER(MEX),QM(MEX)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
      COMMON /CTRLR/ PREC(10)
      CHARACTER*72 TXT2(10)
      DATA TXT2/
     1'          INTERPOLATORY QUADRATURE FORMULA',
     2'  TYPE  INTERVAL       WEIGHT FUNCTION               NAME',
     3'    1    (A,B)              ONE                    LEGENDRE',
     4'    2    (A,B)      ((B-X)*(X-A))**(-HALF)         CHEBYSHEV',
     5'    3    (A,B)      ((B-X)*(X-A))**ALPHA           GEGENBAUER',
     6'    4    (A,B)    (B-X)**ALPHA*(X-A)**BETA          JACOBI',
     7'    5   (A,INF)   (X-A)**ALPHA*EXP(-B*(X-A))      GEN LAGUERRE',
     8'    6  (-INF,INF) ABS(X-A)**ALFA*EXP(-B*(X-A)**2) GEN HERMITE',
     9'    7    (A,B)      ABS(X-(A+B)/TWO)**ALFA         EXPONENTIAL',
     1'    8   (A,INF)    (X-A)**ALFA*(B+X)**BETA          RATIONAL'/
C
      CALL PARCHK(KIND,MEX,ALPHA,BETA,IER)
      IF(IER.NE.0)                              RETURN
      IF(LO.EQ.0)                               GOTO 10
C     PRINT WEIGHTS
      IZERO=0
      LU=ABS(LO)
      WRITE (LU,50)TXT2(1),TXT2(2),TXT2(KIND+2)
      WRITE (LU,80) A
      WRITE (LU,90) B
      IF (KIND.GE.3) WRITE (LU,60) ALPHA
      IF (KIND.EQ.4.OR.KIND.EQ.8) WRITE (LU,70) BETA
      CALL CHKQFS(T,WTS,MLT,NT,NWTS,NDX,KEY,WF,MOP,MEX,IZERO,
     1           ALPHA,BETA,-LU,E,ER,QM,IER)
      IF (IER.NE.0.OR.LO.LT.0)                  RETURN
   10 LEX=MEX+NT
      IF(NWF.GE.LEX)                            GOTO 20
      IER=-LEX
                                                RETURN
   20 CONTINUE
      CALL SCMM(WF,MEX,KIND,ALPHA,BETA,A,B,IER)
      IF (IER.NE.0)                             RETURN
   30 NA=MEX+1
      TMP=(B+A)/TWO
      IF(KIND.EQ.5.OR.KIND.EQ.6.OR.KIND.EQ.8)TMP=A
      DO 40 I=1,NT
         WF(NA+I-1)=T(I)-TMP
   40 CONTINUE
      NEG=-1
C     CHECK MOMENTS
      CALL CHKQFS(WF(NA),WTS,MLT,NT,NWTS,NDX,KEY,WF,MOP,MEX,NEG,
     1           ALPHA,BETA,LO,E,ER,QM,IER)
                                                RETURN
   50 FORMAT(1H1,(8X,A72/))
   60 FORMAT ( '                  ALPHA      ',F12.5)
   70 FORMAT ( '                  BETA       ',F12.5)
   80 FORMAT ( '     PARAMETERS   A          ',F12.5)
   90 FORMAT ( '                  B          ',F12.5)
  100 FORMAT (/23H   MACHINE PRECISION   ,D13.1)
      END
      SUBROUTINE SCT(NT,T,ST,KIND,A,B,IER)
C
C     ROUTINE TO SCALE DISTINCT KNOTS FOR ANY VALID A,B TO THOSE FOR
C     THE DEFAULT VALUES OF A,B. ARRAYS T AND ST MAY COINCIDE.
C     ALL KNOTS IN THE T ARRAY ARE SCALED AND ARE OUTPUT IN ST.
C
C      INPUT AND OUTPUT VARIABLES -
C                     I  I O  I    I I O
C      SUBROUTINE SCT(NT,T,ST,KIND,A,B,IER)
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - MACHEP
      DOUBLE PRECISION A,B,BMA,SHFT,SLP,TMP,ST,T
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,IER,KIND,NT
      DIMENSION T(NT),ST(NT)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
      IER=0
      IF(KIND.LE.0.OR.KIND.GT.8) THEN
         IER=4
                                                      RETURN
      ENDIF
C           LEG,CHEB,GEG,JAC,LAG,HERM,EXP,RAT
10    GO TO( 20,  20, 20, 20, 30,  40, 20, 50),KIND
20    CONTINUE
      CALL MACHEP(TMP)
      BMA=B-A
      IF(BMA.GT.TMP) THEN
         SLP=TWO/BMA
         SHFT=-(A+B)/BMA
      ELSE
         IER=6
                                                      RETURN
      ENDIF
                                                      GOTO 60
30    CONTINUE
      IF(B.LT.ZERO) THEN
         IER=7
                                                      RETURN
      ENDIF
      SLP=B
      SHFT=-A*B
                                                      GOTO 60
40    CONTINUE
      IF(B.LT.ZERO) THEN
         IER=7
                                                      RETURN
      ENDIF
      SLP=SQRT(B)
      SHFT=-A*SLP
                                                      GOTO 60
50    CONTINUE
      SLP=ONE/(A+B)
      IF(SLP.LE.ZERO) THEN
         IER=8
                                                      RETURN
      ENDIF
      SHFT=-A*SLP
60    CONTINUE
      DO 70 I=1,NT
         ST(I)=SHFT+SLP*T(I)
70    CONTINUE
                                                      RETURN
      END
      SUBROUTINE SCQF(NT,T,MLT,WTS,NWTS,NDX,SWTS,ST,
     1                  KIND,ALPHA,BETA,A,B,IER)
C     ROUTINE TO SCALE WEIGHTS AND KNOTS FOR CLASSICAL WEIGHT FUNCTION
C     WITH DEFAULT VALUES FOR A AND B TO THOSE FOR ANY VALID A,B
C
C      INPUT AND OUTPUT VARIABLES -
C                      I  I I   I   I    I   O    O
C      SUBROUTINE SCQF(NT,T,MLT,WTS,NWTS,NDX,SWTS,ST,
C     1                  KIND,ALPHA,BETA,A,B,IER)
C                        I    I     I    I I O
C
C     THE ARRAYS WTS AND SWTS MAY COINCIDE
C     THE ARRAYS T AND ST MAY COINCIDE
C     IER CODES -
C     1-4       ERROR RETURN FROM PARCHK: ALPHA, BETA WRONG
C                     SEE ROUTINE PARCHECK
C       6       ZERO LENGTH INTERVAL (KIND=1,2,3,4,7)
C       7       B.LE.0 FOR (KIND=5,6)
C       8       A+B.LE.0 (KIND=8)
C
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - MACHEP SQRT PARCHK
      DOUBLE PRECISION A,AL,ALPHA,B,BE,BETA,P,SHFT,SLP,TEMP
      DOUBLE PRECISION TMP,ST,SWTS,T,WTS
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,IER,K,KIND,L,NT,NWTS,MLT,NDX
      DIMENSION T(NT),MLT(NT),WTS(NWTS),NDX(NT),SWTS(NWTS),ST(NT)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
      CALL MACHEP(TEMP)
      CALL PARCHK(KIND,1,ALPHA,BETA,IER)
      IF(IER.NE.0)                              RETURN
C
C           LEG,CHEB,GEG,JAC,LAG,HERM,EXP,RAT
   10 GO TO( 20,  30, 40, 50, 90, 110, 60,130),KIND
   20 AL=ZERO
      BE=ZERO
                                                GOTO 70
   30 AL=-HALF
      BE=-HALF
                                                GOTO 70
   40 AL=ALPHA
      BE=ALPHA
                                                GOTO 70
   50 AL=ALPHA
      BE=BETA
                                                GOTO 70
   60 AL=ALPHA
      BE=ZERO
   70 IF((B-A).GT.TEMP)                         GOTO 80
      IER=6
                                                RETURN
   80 SHFT=(A + B)/TWO
      SLP=(B - A)/TWO
                                                GOTO 150
   90 IF(B.GT.ZERO)                             GOTO 100
      IER=7
                                                RETURN
  100 SHFT=A
      SLP=ONE/B
      AL=ALPHA
      BE=ZERO
                                                GOTO 150
  110 IF(B.GT.ZERO)                             GOTO 120
      IER=7
                                                RETURN
  120 SHFT=A
      SLP=ONE/SQRT(B)
      AL=ALPHA
      BE=ZERO
                                                GOTO 150
  130 IF(A+B.GT.ZERO)                           GOTO 140
      IER=8
                                                RETURN
  140 SHFT=A
      SLP=A + B
      AL=ALPHA
      BE=BETA
  150 CONTINUE
      P=SLP**(AL+BE+ONE)
      DO 170 K=1,NT
         ST(K)=SHFT + SLP*T(K)
         L=ABS(NDX(K))
         IF(L.EQ.0)                             GOTO 170
         TMP=P
         DO 160 I=L,L+MLT(K)-1
            SWTS(I)=WTS(I)*TMP
  160    TMP=TMP*SLP
  170 CONTINUE
                                                RETURN
      END
      SUBROUTINE SCMM(W,M,KIND,ALPHA,BETA,A,B,IER)
C     ROUTINE TO COMPUTE MOMENTS OF CLASSICAL WEIGHT FUNCTION WITH
C     DEFAULT VALUES FOR A,B AND SCALE THEM TO THOSE FOR ANY VALID A,B
C      INPUT AND OUTPUT VARIABLES -
C                      O I I    I     I    I I O
C      SUBROUTINE SCMM(W,M,KIND,ALPHA,BETA,A,B,IER)
C
C     MOMENTS ARE OUTPUT TO W
C     FUNCTIONS AND SUBROUTINES REFERENCED - MACHEP SQRT WM
      DOUBLE PRECISION A,AL,ALPHA,B,BE,BETA,P,Q,TEMP,TMP,W
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,IER,KIND,M
      DIMENSION W(M)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
      CALL MACHEP(TEMP)
C
C           LEG,CHEB,GEG,JAC,LAG,HERM,EXP, RAT
   10 GO TO( 20,  30, 40, 50, 90, 110, 60, 130),KIND
   20 AL=ZERO
      BE=ZERO
                                                GOTO 70
   30 AL=-HALF
      BE=-HALF
                                                GOTO 70
   40 AL=ALPHA
      BE=ALPHA
                                                GOTO 70
   50 AL=ALPHA
      BE=BETA
                                                GOTO 70
   60 AL=ALPHA
      BE=ZERO
   70 IF((B-A).GT.TEMP)                         GOTO 80
      IER=6
                                                RETURN
   80 Q=(B-A)/TWO
      P=Q**(AL+BE+ONE)
                                                GOTO 150
   90 IF(B.GT.ZERO)                             GOTO 100
      IER=7
                                                RETURN
  100 Q=ONE/B
      P=Q**(ALPHA+ONE)
                                                GOTO 150
  110 IF(B.GT.ZERO)                             GOTO 120
      IER=7
                                                RETURN
  120 Q=ONE/SQRT(B)
      P=Q**(ALPHA+ONE)
                                                GOTO 150
  130 IF(A+B.GT.ZERO)                           GOTO 140
      IER=8
                                                RETURN
  140 CONTINUE
      Q=A+B
      P=Q**(ALPHA+BETA+ONE)
  150 CALL WM(W,M,KIND,ALPHA,BETA,IER)
      IF(IER.EQ.0)                              GOTO 160
                                                RETURN
  160 TMP=P
      DO 170 I=1,M
         W(I)=W(I)*TMP
         TMP=TMP*Q
  170 CONTINUE
                                                RETURN
      END
      SUBROUTINE WTFN(T,W,NT,KIND,ALPHA,BETA,IER)
C
C     ROUTINE TO EVALUATE THE CLASSICAL WEIGHT FUNCTIONS AT THE POINTS
C     GIVEN IN ARRAY T. THE INPUT, T, AND OUTPUT, W, ARRAYS MAY BE THE
C     SAME.
C      INPUT AND OUTPUT VARIABLES -
C                      I O I  I    I     I    O
C      SUBROUTINE WTFN(T,W,NT,KIND,ALPHA,BETA,IER)
C
C     *******WARNING*******
C     NO CHECK IS MADE
C        (1) THAT THE WEIGHT FUNCTION IS DEFINED FOR THE POINTS IN T.
C        (2) THAT THE POINTS ARE IN THE APPROPRIATE INTERVAL.
C     HOWEVER THE PARAMETERS ALPHA AND BETA ARE CHECKED FOR THE
C     CLASSICAL WEIGHT FUNCTIONS.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED -  EXP SQRT PARCHK
      DOUBLE PRECISION ALPHA,BETA,T,W
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER IER,K,KIND,NT
      DIMENSION W(NT),T(NT)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
      CALL PARCHK(KIND,1,ALPHA,BETA,IER)
      IF(IER.NE.0)                              RETURN
C           LEG,CHEB,GEG,JAC,LAG,HERM,EXP,RAT
      GO TO( 30, 50 , 70, 90,130, 160,10 ,190),KIND
   10 IF (ALPHA.EQ.ZERO) GOTO 30
      DO 20 K=1,NT
   20 W(K)=ABS(T(K))**ALPHA
                                                RETURN
   30 DO 40 K=1,NT
   40 W(K)=ONE
                                                RETURN
   50 DO 60 K=1,NT
   60 W(K)=ONE/SQRT((ONE-T(K))*(ONE+T(K)))
                                                RETURN
   70 IF (ALPHA.EQ.ZERO) GOTO 30
      DO 80 K=1,NT
   80 W(K)=((ONE-T(K))*(ONE+T(K)))**ALPHA
                                                RETURN
   90 DO 100 K=1,NT
  100 W(K)=ONE
      IF (ALPHA.NE.ZERO) THEN
         DO 110 K=1,NT
  110    W(K)=W(K)*(ONE-T(K))**ALPHA
      END IF
      IF (BETA.NE.ZERO) THEN
         DO 120 K=1,NT
  120    W(K)=W(K)*(ONE+T(K))**BETA
      END IF
                                                RETURN
  130 DO 140 K=1,NT
  140 W(K)=EXP(-T(K))
      IF (ALPHA.NE.ZERO) THEN
         DO 150 K=1,NT
  150    W(K)=W(K)*T(K)**ALPHA
      END IF
                                                RETURN
  160 DO 170 K=1,NT
  170 W(K)=EXP(-T(K)**2)
      IF (ALPHA.NE.ZERO) THEN
         DO 180 K=1,NT
  180    W(K)=W(K)*ABS(T(K))**ALPHA
      END IF
                                                RETURN
  190 DO 200 K=1,NT
  200 W(K)=ONE
      IF (ALPHA.NE.ZERO) THEN
         DO 210 K=1,NT
  210    W(K)=W(K)*T(K)**ALPHA
      END IF
      IF (BETA.NE.ZERO) THEN
         DO 220 K=1,NT
  220    W(K)=W(K)*(ONE+T(K))**BETA
      END IF
                                                RETURN
      END
      SUBROUTINE IMTQLX(N,D,E,Z,IER)
C     THIS ROUTINE IS A SLIGHTLY MODIFIED VERSION OF THE EISPACK
C     ROUTINE TO PERFORM THE IMPLICIT QL ALGORITHM ON A SYMMETRIC
C     TRIDIAGONAL MATRIX. THE AUTHORS THANK THE AUTHORS OF EISPACK
C     FOR PERMISSION TO USE THIS ROUTINE. FOR DETAILS SEE
C     MARTIN AND WILKINSON: THE IMPLICIT QL ALGORITHM, NUMER MATH
C     12, 277-383 (1968). IT HAS BEEN MODIFIED TO PRODUCE THE
C              T
C     PRODUCT Q Z, WHERE Z IS AN INPUT VECTOR AND Q IS THE
C     ORTHOGONAL MATRIX DIAGONALIZING THE INPUT MATRIX. THE CHANGES
C     CONSIST (ESSENTIALY) OF APPLYING THE ORTHOGONAL TRANSFORMATIONS
C     DIRECTLY TO Z AS THEY ARE GENERATED. SEE REFERENCES TO Z NEAR
C     STATEMENT 60.
C
C     FUNCTIONS AND SUBROUTINES REFERENCED - SIGN SQRT
      DOUBLE PRECISION B,C,F,G,P,R,S,D,E,PREC,Z
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      INTEGER I,IER,II,J,K,L,M,MML,N
      INTEGER ITN
      DIMENSION D(N),E(N),Z(N)
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
      PARAMETER (ITN=30)
      COMMON/CTRLR/PREC(10)
      IER=0
      IF(N.EQ.1)                                GOTO 110
      E(N)=ZERO
      DO 70 L=1,N
         J=0
   10    DO 20 M=L,N
            IF(M.EQ.N)                          GOTO 30
            IF( ABS(E(M)).LE.PREC(1)*( ABS(D(M))+ ABS(D(M+1)))) GOTO 30
   20    CONTINUE
   30    P=D(L)
         IF(M.EQ.L)                             GOTO 70
         IF(J.EQ.ITN)                        GOTO 100
         J=J+1
         G=(D(L+1)-P)/(TWO*E(L))
         R= SQRT(G*G+ONE)
         G=D(M)-P+E(L)/(G+ SIGN(R,G))
         S=ONE
         C=ONE
         P=ZERO
         MML=M-L
         DO 60 II=1,MML
            I=M-II
            F=S*E(I)
            B=C*E(I)
            IF( ABS(F).LT. ABS(G))              GOTO 40
            C=G/F
            R= SQRT(C*C+ONE)
            E(I+1)=F*R
            S=ONE/R
            C=C*S
                                                GOTO 50
   40       S=F/G
            R= SQRT(S*S+ONE)
            E(I+1)=G*R
            C=ONE/R
            S=S*C
   50       G=D(I+1)-P
            R=(D(I)-G)*S+TWO*C*B
            P=S*R
            D(I+1)=G+P
            G=C*R-B
            F=Z(I+1)
            Z(I+1)=S*Z(I)+C*F
   60    Z(I)=C*Z(I)-S*F
         D(L)=D(L)-P
         E(L)=G
         E(M)=ZERO
                                                GOTO 10
   70 CONTINUE
      DO 90 II=2,N
         I=II-1
         K=I
         P=D(I)
         DO 80 J=II,N
            IF(D(J).GE.P)                       GOTO 80
            K=J
            P=D(J)
   80    CONTINUE
         IF(K.EQ.I)                             GOTO 90
         D(K)=D(I)
         D(I)=P
         P=Z(I)
         Z(I)=Z(K)
         Z(K)=P
   90 CONTINUE
                                                GOTO 110
  100 IER=L
  110                                           RETURN
      END
      SUBROUTINE MACHEP (X)
C     ROUTINE TO COMPUTE MACHINE EPSILON,
C     DEFINED AS THE SMALLEST FLOATING POINT NUMBER SUCH THAT
C     FLOAT(1.0+EPS) > 1.0.  OUTPUT GOES TO X
      DOUBLE PRECISION X,Y
      DOUBLE PRECISION ZERO,HALF,ONE,TWO
      PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
CS    PARAMETER (ZERO=0.0E0,HALF=0.5E0,ONE=1.0E0,TWO=2.0E0)
C
      Y=ONE
10    IF (Y+ONE.NE.ONE) THEN
         X=Y
         Y=Y/TWO
                                                GOTO 10
      END IF
                                                RETURN
      END

C***************************************************************************
C     NOTE BY AHMAD EL SAYED: 
C     FUNCTION DGAMMA (BELOW) IS PART OF IPACK
C     IT WAS COMMENTED BECAUSE A DUPLICATE FUNCTION WRITTEN BY 
C     Fullerton, W. (LANL) IS AVAILABLE IN MATHUTIL.f
C***************************************************************************

c$$$      DOUBLE PRECISION FUNCTION DGAMMA(X)
c$$$CS    REAL FUNCTION GAMMA(X)
c$$$C----------------------------------------------------------------------
c$$$C
c$$$C THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X.
c$$$C     COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN W. J. CODY,
c$$$C     'AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL FUNCTIONS',
c$$$C     LECTURE NOTES IN MATHEMATICS, 506, NUMERICAL ANALYSIS DUNDEE,
c$$$C     1975, G. A. WATSON (ED.), SPRINGER VERLAG, BERLIN, 1976.  THE
c$$$C     PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
c$$$C     FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS.  COEFFICIENTS
c$$$C     FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
c$$$C     THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM HART, ET. AL.,
c$$$C     COMPUTER APPROXIMATIONS, WILEY AND SONS, NEW YORK, 1968.  LOWER
c$$$C     ORDER APPROXIMATIONS CAN BE SUBSTITUTED FOR THESE ON MACHINES
c$$$C     WITH LESS PRECISE ARITHMETIC.
c$$$C
c$$$C
c$$$C*******************************************************************
c$$$C*******************************************************************
c$$$C
c$$$C EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
c$$$C
c$$$C EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
c$$$C          1.0 + EPS .GT. 1.0
c$$$C XBIG   - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE
c$$$C          IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
c$$$C                  GAMMA(XBIG) = XINF.
c$$$C XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
c$$$C          1/XMININ IS MACHINE REPRESENTABLE.
c$$$C XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER.
c$$$C
c$$$C     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
c$$$C
c$$$C         IBM/195    CDC/7600  UNIVAC/1108   VAX 11/780 (UNIX)
c$$$C          (D.P.)  (S.P.,RNDG)    (D.P.)     (S.P.)     (D.P.)
c$$$C
c$$$C EPS     2.221D-16  3.553E-15   1.735D-18   5.961E-08  1.388D-16
c$$$C XBIG    57.574     177.802     171.489     34.844     34.844
c$$$C XMININ  1.382D-76  3.132E-294  1.113D-308  5.883E-39  5.883D-39
c$$$C XINF    7.23D+75   1.26E+322   8.98D+307   1.70E+38   1.70D+38
c$$$C
c$$$C*******************************************************************
c$$$C*******************************************************************
c$$$C
c$$$C
c$$$C ERROR RETURNS
c$$$C
c$$$C  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
c$$$C     WHEN OVERFLOW WOULD OCCUR.  THE COMPUTATION IS BELIEVED
c$$$C     TO BE FREE OF UNDERFLOW AND OVERFLOW.
c$$$C
c$$$C
c$$$C
c$$$C OTHER SUBPROGRAMS REQUIRED (SINGLE PRECISION VERSION)
c$$$C
c$$$C     ALOG,EXP,FLOAT,IFIX,SIN
c$$$C
c$$$C OTHER SUBPROGRAMS REQUIRED (DOUBLE PRECISION VERSION)
c$$$C
c$$$C     DBLE,DEXP,DLOG,DSIN,FLOAT,IFIX,SNGL
c$$$C
c$$$C
c$$$C
c$$$C  AUTHOR: W. J. CODY
c$$$C          APPLIED MATHEMATICS DIVISION
c$$$C          ARGONNE NATIONAL LABORATORY
c$$$C          ARGONNE, IL 60439
c$$$C
c$$$C  LATEST MODIFICATION: MAY 18, 1982
c$$$C
c$$$C----------------------------------------------------------------------
c$$$CS    REAL C,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,
c$$$CS   1     SUM,TWELVE,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
c$$$      DOUBLE PRECISION C, EPS, FACT, HALF, ONE, P, PI, Q, RES, SQRTPI,
c$$$     * SUM, TWELVE, X, XBIG, XDEN, XINF, XMININ, XNUM, Y, Y1, YSQ, Z,
c$$$     * ZERO
c$$$      INTEGER I, J, N
c$$$      LOGICAL PARITY
c$$$      DIMENSION C(7), P(8), Q(8)
c$$$C----------------------------------------------------------------------
c$$$C  MATHEMATICAL CONSTANTS
c$$$C----------------------------------------------------------------------
c$$$CS    DATA ONE,HALF,TWELVE,ZERO/1.0E0,0.5E0,12.0E0,0.0E0/
c$$$CS    DATA SQRTPI/0.9189385332046727417803297E0/
c$$$CS    DATA PI/3.1415926535897932384626434E0/
c$$$      DATA ONE, HALF, TWELVE, ZERO /1.0D0,0.5D0,12.0D0,0.0D0/
c$$$      DATA SQRTPI /0.9189385332046727417803297D0/
c$$$      DATA PI /3.1415926535897932384626434D0/
c$$$C----------------------------------------------------------------------
c$$$C  MACHINE DEPENDENT PARAMETERS   (VAX 11/780 DP)
c$$$C----------------------------------------------------------------------
c$$$CS    DATA XBIG,XMININ,EPS/34.844E0,5.883E-39,5.961E-08/
c$$$CS    DATA XINF/1.7014E38/
c$$$      DATA XBIG, XMININ, EPS /34.844D0,5.883D-39,1.388D-17/
c$$$      DATA XINF /1.7014D38/
c$$$C----------------------------------------------------------------------
c$$$C  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
c$$$C     APPROXIMATION OVER (1,2).
c$$$C----------------------------------------------------------------------
c$$$CS    DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,
c$$$CS   1       -3.79804256470945635097577E+2,6.29331155312818442661052E+2,
c$$$CS   2       8.66966202790413211295064E+2,-3.14512729688483675254357E+4,
c$$$CS   3       -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
c$$$CS    DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,
c$$$CS   1      -1.01515636749021914166146E+3,-3.10777167157231109440444E+3,
c$$$CS   2        2.25381184209801510330112E+4,4.75584627752788110767815E+3,
c$$$CS   3      -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
c$$$      DATA P /-1.71618513886549492533811D+0,2.47656508055759199108314D+1
c$$$     * ,-3.79804256470945635097577D+2,6.29331155312818442661052D+2,
c$$$     * 8.66966202790413211295064D+2,-3.14512729688483675254357D+4,
c$$$     * -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
c$$$      DATA Q /-3.08402300119738975254353D+1,3.15350626979604161529144D+2
c$$$     * ,-1.01515636749021914166146D+3,-3.10777167157231109440444D+3,
c$$$     * 2.25381184209801510330112D+4,4.75584627752788110767815D+3,
c$$$     * -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
c$$$C----------------------------------------------------------------------
c$$$C  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
c$$$C----------------------------------------------------------------------
c$$$CS    DATA C/-1.910444077728E-03,8.4171387781295E-04,
c$$$CS   1     -5.952379913043012E-04,7.93650793500350248E-04,
c$$$CS   2     -2.777777777777681622553E-03,8.333333333333333331554247E-02,
c$$$CS   3      5.7083835261E-03/
c$$$      DATA C /-1.910444077728D-03,8.4171387781295D-04,
c$$$     * -5.952379913043012D-04,7.93650793500350248D-04,
c$$$     * -2.777777777777681622553D-03,8.333333333333333331554247D-02,
c$$$     * 5.7083835261D-03/
c$$$C----------------------------------------------------------------------
c$$$      PARITY = .FALSE.
c$$$      FACT = ONE
c$$$      N = 0
c$$$      Y = X
c$$$      IF (Y.GT.ZERO) GO TO 10
c$$$C----------------------------------------------------------------------
c$$$C  ARGUMENT IS NEGATIVE
c$$$C----------------------------------------------------------------------
c$$$      Y = -X
c$$$CS    J = IFIX(Y)
c$$$      J = IFIX(SNGL(Y))
c$$$CS    RES = Y - FLOAT(J)
c$$$      RES = Y - DBLE(FLOAT(J))
c$$$      IF (RES.EQ.ZERO) GO TO 100
c$$$      IF (J.NE.(J/2)*2) PARITY = .TRUE.
c$$$CS    FACT = -PI / SIN(PI*RES)
c$$$      FACT = -PI/DSIN(PI*RES)
c$$$      Y = Y + ONE
c$$$C----------------------------------------------------------------------
c$$$C  ARGUMENT IS POSITIVE
c$$$C----------------------------------------------------------------------
c$$$   10 IF (Y.LT.EPS) GO TO 90
c$$$      IF (Y.GE.TWELVE) GO TO 70
c$$$      Y1 = Y
c$$$      IF (Y.GE.ONE) GO TO 20
c$$$C----------------------------------------------------------------------
c$$$C  0.0 .LT. ARGUMENT .LT. 1.0
c$$$C----------------------------------------------------------------------
c$$$      Z = Y
c$$$      Y = Y + ONE
c$$$      GO TO 30
c$$$C----------------------------------------------------------------------
c$$$C  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
c$$$C----------------------------------------------------------------------
c$$$CS 20 N = IFIX(Y) - 1
c$$$   20 N = IFIX(SNGL(Y)) - 1
c$$$CS    Y = Y - FLOAT(N)
c$$$      Y = Y - DBLE(FLOAT(N))
c$$$      Z = Y - ONE
c$$$C----------------------------------------------------------------------
c$$$C  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
c$$$C----------------------------------------------------------------------
c$$$   30 XNUM = ZERO
c$$$      XDEN = ONE
c$$$      DO 40 I=1,8
c$$$        XNUM = (XNUM+P(I))*Z
c$$$        XDEN = XDEN*Z + Q(I)
c$$$   40 CONTINUE
c$$$      RES = XNUM/XDEN + ONE
c$$$      IF (Y.EQ.Y1) GO TO 110
c$$$      IF (Y1.GT.Y) GO TO 50
c$$$C----------------------------------------------------------------------
c$$$C  ADJUST RESULT FOR CASE  0.0 .LT. ARGUMENT .LT. 1.0
c$$$C----------------------------------------------------------------------
c$$$      RES = RES/Y1
c$$$      GO TO 110
c$$$C----------------------------------------------------------------------
c$$$C  ADJUST RESULT FOR CASE  2.0 .LT. ARGUMENT .LT. 12.0
c$$$C----------------------------------------------------------------------
c$$$   50 DO 60 I=1,N
c$$$        RES = RES*Y
c$$$        Y = Y + ONE
c$$$   60 CONTINUE
c$$$      GO TO 110
c$$$C----------------------------------------------------------------------
c$$$C  EVALUATE FOR ARGUMENT .GE. 12.0,
c$$$C----------------------------------------------------------------------
c$$$   70 IF (Y.GT.XBIG) GO TO 100
c$$$      YSQ = Y*Y
c$$$      SUM = C(7)
c$$$      DO 80 I=1,6
c$$$        SUM = SUM/YSQ + C(I)
c$$$   80 CONTINUE
c$$$      SUM = SUM/Y - Y + SQRTPI
c$$$CS    SUM = SUM + (Y-HALF)*ALOG(Y)
c$$$      SUM = SUM + (Y-HALF)*DLOG(Y)
c$$$CS    RES = EXP(SUM)
c$$$      RES = DEXP(SUM)
c$$$      GO TO 110
c$$$C----------------------------------------------------------------------
c$$$C  ARGUMENT .LT. EPS
c$$$C----------------------------------------------------------------------
c$$$   90 IF (Y.LT.XMININ) GO TO 100
c$$$      RES = ONE/Y
c$$$      GO TO 110
c$$$C----------------------------------------------------------------------
c$$$C  RETURN FOR SINGULARITIES, EXTREME ARGUMENTS, ETC.
c$$$C----------------------------------------------------------------------
c$$$CS100 GAMMA = XINF
c$$$  100 DGAMMA = XINF
c$$$      GO TO 120
c$$$C----------------------------------------------------------------------
c$$$C  FINAL ADJUSTMENTS AND RETURN
c$$$C----------------------------------------------------------------------
c$$$  110 IF (PARITY) RES = -RES
c$$$      IF (FACT.NE.ONE) RES = FACT/RES
c$$$CS    GAMMA = RES
c$$$      DGAMMA = RES
c$$$  120 RETURN
c$$$C ---------- LAST CARD OF GAMMA ----------
c$$$      END


C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 
C
C     THE FOLLOWING SUBROUTINES AND THEIR DEPENDENCIES ARE PART OF THE
C     QUADPACK LIBRARY. THE SOURCE WAS OBTAINED FROM http://netlib.org/
C
C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 


C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 
      SUBROUTINE DQAWS(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,
     *   ABSERR,NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK)
C***BEGIN PROLOGUE  DQAWS
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A2A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, SPECIAL-PURPOSE,
C             ALGEBRAICO-LOGARITHMIC END-POINT SINGULARITIES,
C             CLENSHAW-CURTIS, GLOBALLY ADAPTIVE
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. -K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL I = INTEGRAL OF F*W OVER (A,B),
C            (WHERE W SHOWS A SINGULAR BEHAVIOUR AT THE END POINTS
C            SEE PARAMETER INTEGR).
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***DESCRIPTION
C
C        INTEGRATION OF FUNCTIONS HAVING ALGEBRAICO-LOGARITHMIC
C        END POINT SINGULARITIES
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION, B.GT.A
C                     IF B.LE.A, THE ROUTINE WILL END WITH IER = 6.
C
C            ALFA   - DOUBLE PRECISION
C                     PARAMETER IN THE INTEGRAND FUNCTION, ALFA.GT.(-1)
C                     IF ALFA.LE.(-1), THE ROUTINE WILL END WITH
C                     IER = 6.
C
C            BETA   - DOUBLE PRECISION
C                     PARAMETER IN THE INTEGRAND FUNCTION, BETA.GT.(-1)
C                     IF BETA.LE.(-1), THE ROUTINE WILL END WITH
C                     IER = 6.
C
C            INTEGR - INTEGER
C                     INDICATES WHICH WEIGHT FUNCTION IS TO BE USED
C                     = 1  (X-A)**ALFA*(B-X)**BETA
C                     = 2  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)
C                     = 3  (X-A)**ALFA*(B-X)**BETA*LOG(B-X)
C                     = 4  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X)
C                     IF INTEGR.LT.1 OR INTEGR.GT.4, THE ROUTINE
C                     WILL END WITH IER = 6.
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TEP
INATION OF THE ROUTINE
C                             THE ESTIMATES FOR THE INTEGRAL AND ERROR
C                             ARE LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND, IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES
C                             WHICH PREVENT THE REQUESTED TOLERANCE FROM
C                             BEING ACHIEVED. IN CASE OF A JUMP
C                             DISCONTINUITY OR A LOCAL SINGULARITY
C                             OF ALGEBRAICO-LOGARITHMIC TYPE AT ONE OR
C                             MORE INTERIOR POINTS OF THE INTEGRATION
C                             RANGE, ONE SHOULD PROCEED BY SPLITTING UP
C                             THE INTERVAL AT THESE POINTS AND CALLING
C                             THE INTEGRATOR ON THE SUBRANGES.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             B.LE.A OR ALFA.LE.(-1) OR BETA.LE.(-1) OR
C                             OR INTEGR.LT.1 OR INTEGR.GT.4 OR
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             OR LIMIT.LT.2 OR LENW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST ARE SET TO
C                             ZERO. EXCEPT WHEN LENW OR LIMIT IS INVALID
C                             IWORK(1), WORK(LIMIT*2+1) AND
C                             WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1)
C                             IS SET TO A AND WORK(LIMIT+1) TO B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT  - INTEGER
C                     DIMENSIONING PARAMETER FOR IWORK
C                     LIMIT DETERMINES THE MAXIMUM NUMBER OF
C                     SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                     INTEGRATION INTERVAL (A,B), LIMIT.GE.2.
C                     IF LIMIT.LT.2, THE ROUTINE WILL END WITH IER = 6.
C
C            LENW   - INTEGER
C                     DIMENSIONING PARAMETER FOR WORK
C                     LENW MUST BE AT LEAST LIMIT*4.
C                     IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                     WITH IER = 6.
C
C            LAST   - INTEGER
C                     ON RETURN, LAST EQUALS THE NUMBER OF
C                     SUBINTERVALS PRODUCED IN THE SUBDIVISION PROCESS,
C                     WHICH DETERMINES THE SIGNIFICANT NUMBER OF
C                     ELEMENTS ACTUALLY IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK  - INTEGER
C                     VECTOR OF DIMENSION LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH CONTAIN POINTERS
C                     TO THE ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT WORK(LIMIT*3+IWORK(1)), ...,
C                     WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                     SEQUENCE WITH K = LAST IF LAST.LE.(LIMIT/2+2),
C                     AND K = LIMIT+1-LAST OTHERWISE
C
C            WORK   - DOUBLE PRECISION
C                     VECTOR OF DIMENSION LENW
C                     ON RETURN
C                     WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                      END POINTS OF THE SUBINTERVALS IN THE
C                      PARTITION OF (A,B),
C                     WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                      THE RIGHT END POINTS,
C                     WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST)
C                      CONTAIN THE INTEGRAL APPROXIMATIONS OVER
C                      THE SUBINTERVALS,
C                     WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                      CONTAIN THE ERROR ESTIMATES.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQAWSE,XERROR
C***END PROLOGUE  DQAWS
C
      DOUBLE PRECISION A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,INTEGR,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(LIMIT),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQAWS
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LIMIT.LT.2.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR DQAWSE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
C
      CALL DQAWSE(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,LIMIT,RESULT,
     *  ABSERR,NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF(IER.NE.0) CALL XERROR(26HABNORMAL RETURN FROM DQAWS,26,IER,LVL)
      RETURN
      END      

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 
      
      SUBROUTINE DQAWSE(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,LIMIT,
     *   RESULT,ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C***BEGIN PROLOGUE  DQAWSE
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A2A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, SPECIAL-PURPOSE,
C             ALGEBRAICO-LOGARITHMIC END POINT SINGULARITIES,
C             CLENSHAW-CURTIS METHOD
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL I = INTEGRAL OF F*W OVER (A,B),
C            (WHERE W SHOWS A SINGULAR BEHAVIOUR AT THE END POINTS,
C            SEE PARAMETER INTEGR).
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***DESCRIPTION
C
C        INTEGRATION OF FUNCTIONS HAVING ALGEBRAICO-LOGARITHMIC
C        END POINT SINGULARITIES
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION, B.GT.A
C                     IF B.LE.A, THE ROUTINE WILL END WITH IER = 6.
C
C            ALFA   - DOUBLE PRECISION
C                     PARAMETER IN THE WEIGHT FUNCTION, ALFA.GT.(-1)
C                     IF ALFA.LE.(-1), THE ROUTINE WILL END WITH
C                     IER = 6.
C
C            BETA   - DOUBLE PRECISION
C                     PARAMETER IN THE WEIGHT FUNCTION, BETA.GT.(-1)
C                     IF BETA.LE.(-1), THE ROUTINE WILL END WITH
C                     IER = 6.
C
C            INTEGR - INTEGER
C                     INDICATES WHICH WEIGHT FUNCTION IS TO BE USED
C                     = 1  (X-A)**ALFA*(B-X)**BETA
C                     = 2  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)
C                     = 3  (X-A)**ALFA*(B-X)**BETA*LOG(B-X)
C                     = 4  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X)
C                     IF INTEGR.LT.1 OR INTEGR.GT.4, THE ROUTINE
C                     WILL END WITH IER = 6.
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS
C                     IN THE PARTITION OF (A,B), LIMIT.GE.2
C                     IF LIMIT.LT.2, THE ROUTINE WILL END WITH IER = 6.
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR THE INTEGRAL AND ERROR
C                             ARE LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                         = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT. HOWEVER, IF THIS YIELDS NO
C                             IMPROVEMENT, IT IS ADVISED TO ANALYZE THE
C                             INTEGRAND IN ORDER TO DETERMINE THE
C                             INTEGRATION DIFFICULTIES WHICH PREVENT THE
C                             REQUESTED TOLERANCE FROM BEING ACHIEVED.
C                             IN CASE OF A JUMP DISCONTINUITY OR A LOCAL
C                             SINGULARITY OF ALGEBRAICO-LOGARITHMIC TYPE
C                             AT ONE OR MORE INTERIOR POINTS OF THE
C                             INTEGRATION RANGE, ONE SHOULD PROCEED BY
C                             SPLITTING UP THE INTERVAL AT THESE
C                             POINTS AND CALLING THE INTEGRATOR ON THE
C                             SUBRANGES.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             B.LE.A OR ALFA.LE.(-1) OR BETA.LE.(-1), OR
C                             INTEGR.LT.1 OR INTEGR.GT.4, OR
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                             OR LIMIT.LT.2.
C                             RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1),
C                             IORD(1) AND LAST ARE SET TO ZERO. ALIST(1)
C                             AND BLIST(1) ARE SET TO A AND B
C                             RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE GIVEN INTEGRATION RANGE (A,B)
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE GIVEN INTEGRATION RANGE (A,B)
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT,THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI OF THE
C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     OF WHICH ARE POINTERS TO THE ERROR
C                     ESTIMATES OVER THE SUBINTERVALS, SO THAT
C                     ELIST(IORD(1)), ..., ELIST(IORD(K)) WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE FORM A DECREASING SEQUENCE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN
C                     THE SUBDIVISION PROCESS
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH,DQC25S,DQMOMO,DQPSRT
C***END PROLOGUE  DQAWSE
C
      DOUBLE PRECISION A,ABSERR,ALFA,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     *  A2,B,BETA,BLIST,B1,B2,CENTRE,DABS,DMAX1,D1MACH,ELIST,EPMACH,
     *  EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,F,
     *  RESAS1,RESAS2,RESULT,RG,RH,RI,RJ,RLIST,UFLOW
      INTEGER IER,INTEGR,IORD,IROFF1,IROFF2,K,LAST,LIMIT,MAXERR,NEV,
     *  NEVAL,NRMAX
C
      EXTERNAL F
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),RLIST(LIMIT),ELIST(LIMIT),
     *  IORD(LIMIT),RI(25),RJ(25),RH(25),RG(25)
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST
C                       ERROR ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQAWSE
      EPMACH = D1MACH(4)
      UFLOW = D1MACH(1)
C
C           TEST ON VALIDITY OF PARAMETERS
C           ------------------------------
C
      IER = 6
      NEVAL = 0
      LAST = 0
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IORD(1) = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(B.LE.A.OR.(EPSABS.EQ.0.0D+00.AND.
     *  EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28)).OR.ALFA.LE.(-0.1D+01).
     *  OR.BETA.LE.(-0.1D+01).OR.INTEGR.LT.1.OR.INTEGR.GT.4.OR.
     *  LIMIT.LT.2) GO TO 999
      IER = 0
C
C           COMPUTE THE MODIFIED CHEBYSHEV MOMENTS.
C
      CALL DQMOMO(ALFA,BETA,RI,RJ,RG,RH,INTEGR)
C
C           INTEGRATE OVER THE INTERVALS (A,(A+B)/2) AND ((A+B)/2,B).
C
      CENTRE = 0.5D+00*(B+A)
      CALL DQC25S(F,A,B,A,CENTRE,ALFA,BETA,RI,RJ,RG,RH,AREA1,
     *  ERROR1,RESAS1,INTEGR,NEV)
      NEVAL = NEV
      CALL DQC25S(F,A,B,CENTRE,B,ALFA,BETA,RI,RJ,RG,RH,AREA2,
     *  ERROR2,RESAS2,INTEGR,NEV)
      LAST = 2
      NEVAL = NEVAL+NEV
      RESULT = AREA1+AREA2
      ABSERR = ERROR1+ERROR2
C
C           TEST ON ACCURACY.
C
      ERRBND = DMAX1(EPSABS,EPSREL*DABS(RESULT))
C
C           INITIALIZATION
C           --------------
C
      IF(ERROR2.GT.ERROR1) GO TO 10
      ALIST(1) = A
      ALIST(2) = CENTRE
      BLIST(1) = CENTRE
      BLIST(2) = B
      RLIST(1) = AREA1
      RLIST(2) = AREA2
      ELIST(1) = ERROR1
      ELIST(2) = ERROR2
      GO TO 20
   10 ALIST(1) = CENTRE
      ALIST(2) = A
      BLIST(1) = B
      BLIST(2) = CENTRE
      RLIST(1) = AREA2
      RLIST(2) = AREA1
      ELIST(1) = ERROR2
      ELIST(2) = ERROR1
   20 IORD(1) = 1
      IORD(2) = 2
      IF(LIMIT.EQ.2) IER = 1
      IF(ABSERR.LE.ERRBND.OR.IER.EQ.1) GO TO 999
      ERRMAX = ELIST(1)
      MAXERR = 1
      NRMAX = 1
      AREA = RESULT
      ERRSUM = ABSERR
      IROFF1 = 0
      IROFF2 = 0
C
C            MAIN DO-LOOP
C            ------------
C
      DO 60 LAST = 3,LIMIT
C
C           BISECT THE SUBINTERVAL WITH LARGEST ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
C
        CALL DQC25S(F,A,B,A1,B1,ALFA,BETA,RI,RJ,RG,RH,AREA1,
     *  ERROR1,RESAS1,INTEGR,NEV)
        NEVAL = NEVAL+NEV
        CALL DQC25S(F,A,B,A2,B2,ALFA,BETA,RI,RJ,RG,RH,AREA2,
     *  ERROR2,RESAS2,INTEGR,NEV)
        NEVAL = NEVAL+NEV
C
C           IMPROVE PREVIOUS APPROXIMATIONS INTEGRAL AND ERROR
C           AND TEST FOR ACCURACY.
C
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(A.EQ.A1.OR.B.EQ.B2) GO TO 30
        IF(RESAS1.EQ.ERROR1.OR.RESAS2.EQ.ERROR2) GO TO 30
C
C           TEST FOR ROUNDOFF ERROR.
C
        IF(DABS(RLIST(MAXERR)-AREA12).LT.0.1D-04*DABS(AREA12)
     *  .AND.ERRO12.GE.0.99D+00*ERRMAX) IROFF1 = IROFF1+1
        IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF2 = IROFF2+1
   30   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
C
C           TEST ON ACCURACY.
C
        ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA))
        IF(ERRSUM.LE.ERRBND) GO TO 35
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF INTERVAL
C           BISECTIONS EXCEEDS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C
C           SET ERROR FLAG IN THE CASE OF ROUNDOFF ERROR.
C
        IF(IROFF1.GE.6.OR.IROFF2.GE.20) IER = 2
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT INTERIOR POINTS OF INTEGRATION RANGE.
C
        IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
     *  (DABS(A2)+0.1D+04*UFLOW)) IER = 3
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
   35   IF(ERROR2.GT.ERROR1) GO TO 40
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 50
   40   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   50   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF (IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 70
   60 CONTINUE
C
C           COMPUTE FINAL RESULT.
C           ---------------------
C
   70 RESULT = 0.0D+00
      DO 80 K=1,LAST
        RESULT = RESULT+RLIST(K)
   80 CONTINUE
      ABSERR = ERRSUM
  999 RETURN
      END      

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQC25S(F,A,B,BL,BR,ALFA,BETA,RI,RJ,RG,RH,RESULT,
     *   ABSERR,RESASC,INTEGR,NEV)
C***BEGIN PROLOGUE  DQC25S
C***DATE WRITTEN   810101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A2A2
C***KEYWORDS  25-POINT CLENSHAW-CURTIS INTEGRATION
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  TO COMPUTE I = INTEGRAL OF F*W OVER (BL,BR), WITH ERROR
C            ESTIMATE, WHERE THE WEIGHT FUNCTION W HAS A SINGULAR
C            BEHAVIOUR OF ALGEBRAICO-LOGARITHMIC TYPE AT THE POINTS
C            A AND/OR B. (BL,BR) IS A PART OF (A,B).
C***DESCRIPTION
C
C        INTEGRATION RULES FOR INTEGRANDS HAVING ALGEBRAICO-LOGARITHMIC
C        END POINT SINGULARITIES
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C           F      - DOUBLE PRECISION
C                    FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                    F(X). THE ACTUAL NAME FOR F NEEDS TO BE DECLARED
C                    E X T E R N A L  IN THE DRIVER PROGRAM.
C
C           A      - DOUBLE PRECISION
C                    LEFT END POINT OF THE ORIGINAL INTERVAL
C
C           B      - DOUBLE PRECISION
C                    RIGHT END POINT OF THE ORIGINAL INTERVAL, B.GT.A
C
C           BL     - DOUBLE PRECISION
C                    LOWER LIMIT OF INTEGRATION, BL.GE.A
C
C           BR     - DOUBLE PRECISION
C                    UPPER LIMIT OF INTEGRATION, BR.LE.B
C
C           ALFA   - DOUBLE PRECISION
C                    PARAMETER IN THE WEIGHT FUNCTION
C
C           BETA   - DOUBLE PRECISION
C                    PARAMETER IN THE WEIGHT FUNCTION
C
C           RI,RJ,RG,RH - DOUBLE PRECISION
C                    MODIFIED CHEBYSHEV MOMENTS FOR THE APPLICATION
C                    OF THE GENERALIZED CLENSHAW-CURTIS
C                    METHOD (COMPUTED IN SUBROUTINE DQMOMO)
C
C           RESULT - DOUBLE PRECISION
C                    APPROXIMATION TO THE INTEGRAL
C                    RESULT IS COMPUTED BY USING A GENERALIZED
C                    CLENSHAW-CURTIS METHOD IF B1 = A OR BR = B.
C                    IN ALL OTHER CASES THE 15-POINT KRONROD
C                    RULE IS APPLIED, OBTAINED BY OPTIMAL ADDITION OF
C                    ABSCISSAE TO THE 7-POINT GAUSS RULE.
C
C           ABSERR - DOUBLE PRECISION
C                    ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                    WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C           RESASC - DOUBLE PRECISION
C                    APPROXIMATION TO THE INTEGRAL OF ABS(F*W-I/(B-A))
C
C           INTEGR - INTEGER
C                    WHICH DETERMINES THE WEIGHT FUNCTION
C                    = 1   W(X) = (X-A)**ALFA*(B-X)**BETA
C                    = 2   W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)
C                    = 3   W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(B-X)
C                    = 4   W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*
C                                 LOG(B-X)
C
C           NEV    - INTEGER
C                    NUMBER OF INTEGRAND EVALUATIONS
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQCHEB,DQK15W
C***END PROLOGUE  DQC25S
C
      DOUBLE PRECISION A,ABSERR,ALFA,B,BETA,BL,BR,CENTR,CHEB12,CHEB24,
     *  DABS,DC,DLOG,F,FACTOR,FIX,FVAL,HLGTH,RESABS,RESASC,RESULT,RES12,
     *  RES24,RG,RH,RI,RJ,U,DQWGTS,X
      INTEGER I,INTEGR,ISYM,NEV
C
      DIMENSION CHEB12(13),CHEB24(25),FVAL(25),RG(25),RH(25),RI(25),
     *  RJ(25),X(11)
C
      EXTERNAL F,DQWGTS
C
C           THE VECTOR X CONTAINS THE VALUES COS(K*PI/24)
C           K = 1, ..., 11, TO BE USED FOR THE COMPUTATION OF THE
C           CHEBYSHEV SERIES EXPANSION OF F.
C
      DATA X(1) / 0.9914448613 7381041114 4557526928 563D0 /
      DATA X(2) / 0.9659258262 8906828674 9743199728 897D0 /
      DATA X(3) / 0.9238795325 1128675612 8183189396 788D0 /
      DATA X(4) / 0.8660254037 8443864676 3723170752 936D0 /
      DATA X(5) / 0.7933533402 9123516457 9776961501 299D0 /
      DATA X(6) / 0.7071067811 8654752440 0844362104 849D0 /
      DATA X(7) / 0.6087614290 0872063941 6097542898 164D0 /
      DATA X(8) / 0.5000000000 0000000000 0000000000 000D0 /
      DATA X(9) / 0.3826834323 6508977172 8459984030 399D0 /
      DATA X(10) / 0.2588190451 0252076234 8898837624 048D0 /
      DATA X(11) / 0.1305261922 2005159154 8406227895 489D0 /
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           FVAL   - VALUE OF THE FUNCTION F AT THE POINTS
C                    (BR-BL)*0.5*COS(K*PI/24)+(BR+BL)*0.5
C                    K = 0, ..., 24
C           CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 12, FOR THE FUNCTION F, IN THE
C                    INTERVAL (BL,BR)
C           CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 24, FOR THE FUNCTION F, IN THE
C                    INTERVAL (BL,BR)
C           RES12  - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB12
C           RES24  - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB24
C           DQWGTS - EXTERNAL FUNCTION SUBPROGRAM DEFINING
C                    THE FOUR POSSIBLE WEIGHT FUNCTIONS
C           HLGTH  - HALF-LENGTH OF THE INTERVAL (BL,BR)
C           CENTR  - MID POINT OF THE INTERVAL (BL,BR)
C
C***FIRST EXECUTABLE STATEMENT  DQC25S
      NEV = 25
      IF(BL.EQ.A.AND.(ALFA.NE.0.0D+00.OR.INTEGR.EQ.2.OR.INTEGR.EQ.4))
     * GO TO 10
      IF(BR.EQ.B.AND.(BETA.NE.0.0D+00.OR.INTEGR.EQ.3.OR.INTEGR.EQ.4))
     * GO TO 140
C
C           IF A.GT.BL AND B.LT.BR, APPLY THE 15-POINT GAUSS-KRONROD
C           SCHEME.
C
C
      CALL DQK15W(F,DQWGTS,A,B,ALFA,BETA,INTEGR,BL,BR,
     *    RESULT,ABSERR,RESABS,RESASC)
      NEV = 15
      GO TO 270
C
C           THIS PART OF THE PROGRAM IS EXECUTED ONLY IF A = BL.
C           ----------------------------------------------------
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F1 = (0.5*(B+B-BR-A)-0.5*(BR-A)*X)**BETA
C                  *F(0.5*(BR-A)*X+0.5*(BR+A))
C
   10 HLGTH = 0.5D+00*(BR-BL)
      CENTR = 0.5D+00*(BR+BL)
      FIX = B-CENTR
      FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX-HLGTH)**BETA
      FVAL(13) = F(CENTR)*(FIX**BETA)
      FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX+HLGTH)**BETA
      DO 20 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = F(U+CENTR)*(FIX-U)**BETA
        FVAL(ISYM) = F(CENTR-U)*(FIX+U)**BETA
   20 CONTINUE
      FACTOR = HLGTH**(ALFA+0.1D+01)
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      IF(INTEGR.GT.2) GO TO 70
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           INTEGR = 1  (OR 2)
C
      DO 30 I=1,13
        RES12 = RES12+CHEB12(I)*RI(I)
        RES24 = RES24+CHEB24(I)*RI(I)
   30 CONTINUE
      DO 40 I=14,25
        RES24 = RES24+CHEB24(I)*RI(I)
   40 CONTINUE
      IF(INTEGR.EQ.1) GO TO 130
C
C           INTEGR = 2
C
      DC = DLOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = DABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      DO 50 I=1,13
        RES12 = RES12+CHEB12(I)*RG(I)
        RES24 = RES12+CHEB24(I)*RG(I)
   50 CONTINUE
      DO 60 I=14,25
        RES24 = RES24+CHEB24(I)*RG(I)
   60 CONTINUE
      GO TO 130
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F4 = F1*LOG(0.5*(B+B-BR-A)-0.5*(BR-A)*X)
C
   70 FVAL(1) = FVAL(1)*DLOG(FIX-HLGTH)
      FVAL(13) = FVAL(13)*DLOG(FIX)
      FVAL(25) = FVAL(25)*DLOG(FIX+HLGTH)
      DO 80 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = FVAL(I)*DLOG(FIX-U)
        FVAL(ISYM) = FVAL(ISYM)*DLOG(FIX+U)
   80 CONTINUE
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           INTEGR = 3  (OR 4)
C
      DO 90 I=1,13
        RES12 = RES12+CHEB12(I)*RI(I)
        RES24 = RES24+CHEB24(I)*RI(I)
   90 CONTINUE
      DO 100 I=14,25
        RES24 = RES24+CHEB24(I)*RI(I)
  100 CONTINUE
      IF(INTEGR.EQ.3) GO TO 130
C
C           INTEGR = 4
C
      DC = DLOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = DABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      DO 110 I=1,13
        RES12 = RES12+CHEB12(I)*RG(I)
        RES24 = RES24+CHEB24(I)*RG(I)
  110 CONTINUE
      DO 120 I=14,25
        RES24 = RES24+CHEB24(I)*RG(I)
  120 CONTINUE
  130 RESULT = (RESULT+RES24)*FACTOR
      ABSERR = (ABSERR+DABS(RES24-RES12))*FACTOR
      GO TO 270
C
C           THIS PART OF THE PROGRAM IS EXECUTED ONLY IF B = BR.
C           ----------------------------------------------------
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F2 = (0.5*(B+BL-A-A)+0.5*(B-BL)*X)**ALFA
C                *F(0.5*(B-BL)*X+0.5*(B+BL))
C
  140 HLGTH = 0.5D+00*(BR-BL)
      CENTR = 0.5D+00*(BR+BL)
      FIX = CENTR-A
      FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX+HLGTH)**ALFA
      FVAL(13) = F(CENTR)*(FIX**ALFA)
      FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX-HLGTH)**ALFA
      DO 150 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = F(U+CENTR)*(FIX+U)**ALFA
        FVAL(ISYM) = F(CENTR-U)*(FIX-U)**ALFA
  150 CONTINUE
      FACTOR = HLGTH**(BETA+0.1D+01)
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      IF(INTEGR.EQ.2.OR.INTEGR.EQ.4) GO TO 200
C
C           INTEGR = 1  (OR 3)
C
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
      DO 160 I=1,13
        RES12 = RES12+CHEB12(I)*RJ(I)
        RES24 = RES24+CHEB24(I)*RJ(I)
  160 CONTINUE
      DO 170 I=14,25
        RES24 = RES24+CHEB24(I)*RJ(I)
  170 CONTINUE
      IF(INTEGR.EQ.1) GO TO 260
C
C           INTEGR = 3
C
      DC = DLOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = DABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
      DO 180 I=1,13
        RES12 = RES12+CHEB12(I)*RH(I)
        RES24 = RES24+CHEB24(I)*RH(I)
  180 CONTINUE
      DO 190 I=14,25
        RES24 = RES24+CHEB24(I)*RH(I)
  190 CONTINUE
      GO TO 260
C
C           COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE
C           FOLLOWING FUNCTION
C           F3 = F2*LOG(0.5*(B-BL)*X+0.5*(B+BL-A-A))
C
  200 FVAL(1) = FVAL(1)*DLOG(HLGTH+FIX)
      FVAL(13) = FVAL(13)*DLOG(FIX)
      FVAL(25) = FVAL(25)*DLOG(FIX-HLGTH)
      DO 210 I=2,12
        U = HLGTH*X(I-1)
        ISYM = 26-I
        FVAL(I) = FVAL(I)*DLOG(U+FIX)
        FVAL(ISYM) = FVAL(ISYM)*DLOG(FIX-U)
  210 CONTINUE
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           INTEGR = 2  (OR 4)
C
      DO 220 I=1,13
        RES12 = RES12+CHEB12(I)*RJ(I)
        RES24 = RES24+CHEB24(I)*RJ(I)
  220 CONTINUE
      DO 230 I=14,25
        RES24 = RES24+CHEB24(I)*RJ(I)
  230 CONTINUE
      IF(INTEGR.EQ.2) GO TO 260
      DC = DLOG(BR-BL)
      RESULT = RES24*DC
      ABSERR = DABS((RES24-RES12)*DC)
      RES12 = 0.0D+00
      RES24 = 0.0D+00
C
C           INTEGR = 4
C
      DO 240 I=1,13
        RES12 = RES12+CHEB12(I)*RH(I)
        RES24 = RES24+CHEB24(I)*RH(I)
  240 CONTINUE
      DO 250 I=14,25
        RES24 = RES24+CHEB24(I)*RH(I)
  250 CONTINUE
  260 RESULT = (RESULT+RES24)*FACTOR
      ABSERR = (ABSERR+DABS(RES24-RES12))*FACTOR
  270 RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQCHEB(X,FVAL,CHEB12,CHEB24)
C***BEGIN PROLOGUE  DQCHEB
C***REFER TO  DQC25C,DQC25F,DQC25S
C***ROUTINES CALLED  (NONE)
C***REVISION DATE  830518   (YYMMDD)
C***KEYWORDS  CHEBYSHEV SERIES EXPANSION, FAST FOURIER TRANSFORM
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THIS ROUTINE COMPUTES THE CHEBYSHEV SERIES EXPANSION
C            OF DEGREES 12 AND 24 OF A FUNCTION USING A
C            FAST FOURIER TRANSFORM METHOD
C            F(X) = SUM(K=1,..,13) (CHEB12(K)*T(K-1,X)),
C            F(X) = SUM(K=1,..,25) (CHEB24(K)*T(K-1,X)),
C            WHERE T(K,X) IS THE CHEBYSHEV POLYNOMIAL OF DEGREE K.
C***DESCRIPTION
C
C        CHEBYSHEV SERIES EXPANSION
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C          ON ENTRY
C           X      - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 11 CONTAINING THE
C                    VALUES COS(K*PI/24), K = 1, ..., 11
C
C           FVAL   - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 25 CONTAINING THE
C                    FUNCTION VALUES AT THE POINTS
C                    (B+A+(B-A)*COS(K*PI/24))/2, K = 0, ...,24,
C                    WHERE (A,B) IS THE APPROXIMATION INTERVAL.
C                    FVAL(1) AND FVAL(25) ARE DIVIDED BY TWO
C                    (THESE VALUES ARE DESTROYED AT OUTPUT).
C
C          ON RETURN
C           CHEB12 - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 13 CONTAINING THE
C                    CHEBYSHEV COEFFICIENTS FOR DEGREE 12
C
C           CHEB24 - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 25 CONTAINING THE
C                    CHEBYSHEV COEFFICIENTS FOR DEGREE 24
C
C***END PROLOGUE  DQCHEB
C
      DOUBLE PRECISION ALAM,ALAM1,ALAM2,CHEB12,CHEB24,FVAL,PART1,PART2,
     *  PART3,V,X
      INTEGER I,J
C
      DIMENSION CHEB12(13),CHEB24(25),FVAL(25),V(12),X(11)
C
C***FIRST EXECUTABLE STATEMENT  DQCHEB
      DO 10 I=1,12
        J = 26-I
        V(I) = FVAL(I)-FVAL(J)
        FVAL(I) = FVAL(I)+FVAL(J)
   10 CONTINUE
      ALAM1 = V(1)-V(9)
      ALAM2 = X(6)*(V(3)-V(7)-V(11))
      CHEB12(4) = ALAM1+ALAM2
      CHEB12(10) = ALAM1-ALAM2
      ALAM1 = V(2)-V(8)-V(10)
      ALAM2 = V(4)-V(6)-V(12)
      ALAM = X(3)*ALAM1+X(9)*ALAM2
      CHEB24(4) = CHEB12(4)+ALAM
      CHEB24(22) = CHEB12(4)-ALAM
      ALAM = X(9)*ALAM1-X(3)*ALAM2
      CHEB24(10) = CHEB12(10)+ALAM
      CHEB24(16) = CHEB12(10)-ALAM
      PART1 = X(4)*V(5)
      PART2 = X(8)*V(9)
      PART3 = X(6)*V(7)
      ALAM1 = V(1)+PART1+PART2
      ALAM2 = X(2)*V(3)+PART3+X(10)*V(11)
      CHEB12(2) = ALAM1+ALAM2
      CHEB12(12) = ALAM1-ALAM2
      ALAM = X(1)*V(2)+X(3)*V(4)+X(5)*V(6)+X(7)*V(8)
     *  +X(9)*V(10)+X(11)*V(12)
      CHEB24(2) = CHEB12(2)+ALAM
      CHEB24(24) = CHEB12(2)-ALAM
      ALAM = X(11)*V(2)-X(9)*V(4)+X(7)*V(6)-X(5)*V(8)
     *  +X(3)*V(10)-X(1)*V(12)
      CHEB24(12) = CHEB12(12)+ALAM
      CHEB24(14) = CHEB12(12)-ALAM
      ALAM1 = V(1)-PART1+PART2
      ALAM2 = X(10)*V(3)-PART3+X(2)*V(11)
      CHEB12(6) = ALAM1+ALAM2
      CHEB12(8) = ALAM1-ALAM2
      ALAM = X(5)*V(2)-X(9)*V(4)-X(1)*V(6)
     *  -X(11)*V(8)+X(3)*V(10)+X(7)*V(12)
      CHEB24(6) = CHEB12(6)+ALAM
      CHEB24(20) = CHEB12(6)-ALAM
      ALAM = X(7)*V(2)-X(3)*V(4)-X(11)*V(6)+X(1)*V(8)
     *  -X(9)*V(10)-X(5)*V(12)
      CHEB24(8) = CHEB12(8)+ALAM
      CHEB24(18) = CHEB12(8)-ALAM
      DO 20 I=1,6
        J = 14-I
        V(I) = FVAL(I)-FVAL(J)
        FVAL(I) = FVAL(I)+FVAL(J)
   20 CONTINUE
      ALAM1 = V(1)+X(8)*V(5)
      ALAM2 = X(4)*V(3)
      CHEB12(3) = ALAM1+ALAM2
      CHEB12(11) = ALAM1-ALAM2
      CHEB12(7) = V(1)-V(5)
      ALAM = X(2)*V(2)+X(6)*V(4)+X(10)*V(6)
      CHEB24(3) = CHEB12(3)+ALAM
      CHEB24(23) = CHEB12(3)-ALAM
      ALAM = X(6)*(V(2)-V(4)-V(6))
      CHEB24(7) = CHEB12(7)+ALAM
      CHEB24(19) = CHEB12(7)-ALAM
      ALAM = X(10)*V(2)-X(6)*V(4)+X(2)*V(6)
      CHEB24(11) = CHEB12(11)+ALAM
      CHEB24(15) = CHEB12(11)-ALAM
      DO 30 I=1,3
        J = 8-I
        V(I) = FVAL(I)-FVAL(J)
        FVAL(I) = FVAL(I)+FVAL(J)
   30 CONTINUE
      CHEB12(5) = V(1)+X(8)*V(3)
      CHEB12(9) = FVAL(1)-X(8)*FVAL(3)
      ALAM = X(4)*V(2)
      CHEB24(5) = CHEB12(5)+ALAM
      CHEB24(21) = CHEB12(5)-ALAM
      ALAM = X(8)*FVAL(2)-FVAL(4)
      CHEB24(9) = CHEB12(9)+ALAM
      CHEB24(17) = CHEB12(9)-ALAM
      CHEB12(1) = FVAL(1)+FVAL(3)
      ALAM = FVAL(2)+FVAL(4)
      CHEB24(1) = CHEB12(1)+ALAM
      CHEB24(25) = CHEB12(1)-ALAM
      CHEB12(13) = V(1)-V(3)
      CHEB24(13) = CHEB12(13)
      ALAM = 0.1D+01/0.6D+01
      DO 40 I=2,12
        CHEB12(I) = CHEB12(I)*ALAM
   40 CONTINUE
      ALAM = 0.5D+00*ALAM
      CHEB12(1) = CHEB12(1)*ALAM
      CHEB12(13) = CHEB12(13)*ALAM
      DO 50 I=2,24
        CHEB24(I) = CHEB24(I)*ALAM
   50 CONTINUE
      CHEB24(1) = 0.5D+00*ALAM*CHEB24(1)
      CHEB24(25) = 0.5D+00*ALAM*CHEB24(25)
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQK15W(F,W,P1,P2,P3,P4,KP,A,B,RESULT,ABSERR,
     *   RESABS,RESASC)
C***BEGIN PROLOGUE  DQK15W
C***DATE WRITTEN   810101   (YYMMDD)
C***REVISION DATE  830518   (MMDDYY)
C***CATEGORY NO.  H2A2A2
C***KEYWORDS  15-POINT GAUSS-KRONROD RULES
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  TO COMPUTE I = INTEGRAL OF F*W OVER (A,B), WITH ERROR
C                           ESTIMATE
C                       J = INTEGRAL OF ABS(F*W) OVER (A,B)
C***DESCRIPTION
C
C           INTEGRATION RULES
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS
C             ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              W      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       WEIGHT FUNCTION W(X). THE ACTUAL NAME FOR W
C                       NEEDS TO BE DECLARED E X T E R N A L IN THE
C                       CALLING PROGRAM.
C
C              P1, P2, P3, P4 - DOUBLE PRECISION
C                       PARAMETERS IN THE WEIGHT FUNCTION
C
C              KP     - INTEGER
C                       KEY FOR INDICATING THE TYPE OF WEIGHT FUNCTION
C
C              A      - DOUBLE PRECISION
C                       LOWER LIMIT OF INTEGRATION
C
C              B      - DOUBLE PRECISION
C                       UPPER LIMIT OF INTEGRATION
C
C            ON RETURN
C              RESULT - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 15-POINT
C                       KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION
C                       OF ABSCISSAE TO THE 7-POINT GAUSS RULE (RESG).
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C              RESABS - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF ABS(F)
C
C              RESASC - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH
C***END PROLOGUE  DQK15W
C
      DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,CENTR,DABS,DHLGTH,
     *  DMAX1,DMIN1,D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,
     *  P1,P2,P3,P4,RESABS,RESASC,RESG,RESK,RESKH,RESULT,UFLOW,W,WG,WGK,
     *  XGK
      INTEGER J,JTW,JTWM1,KP
      EXTERNAL F,W
C
      DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(4)
C
C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
C           CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 15-POINT GAUSS-KRONROD RULE
C                    XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 7-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 15-POINT GAUSS-KRONROD RULE
C
C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE
C
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8)/
     *     0.9914553711208126D+00,     0.9491079123427585D+00,
     *     0.8648644233597691D+00,     0.7415311855993944D+00,
     *     0.5860872354676911D+00,     0.4058451513773972D+00,
     *     0.2077849550078985D+00,     0.0000000000000000D+00/
C
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8)/
     *     0.2293532201052922D-01,     0.6309209262997855D-01,
     *     0.1047900103222502D+00,     0.1406532597155259D+00,
     *     0.1690047266392679D+00,     0.1903505780647854D+00,
     *     0.2044329400752989D+00,     0.2094821410847278D+00/
C
      DATA WG(1),WG(2),WG(3),WG(4)/
     *     0.1294849661688697D+00,    0.2797053914892767D+00,
     *     0.3818300505051889D+00,    0.4179591836734694D+00/
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC*  - ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F*W OVER (A,B),
C                    I.E. TO I/(B-A)
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQK15W
      EPMACH = D1MACH(4)
      UFLOW = D1MACH(1)
C
      CENTR = 0.5D+00*(A+B)
      HLGTH = 0.5D+00*(B-A)
      DHLGTH = DABS(HLGTH)
C
C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE
C           INTEGRAL, AND ESTIMATE THE ERROR.
C
      FC = F(CENTR)*W(CENTR,P1,P2,P3,P4,KP)
      RESG = WG(4)*FC
      RESK = WGK(8)*FC
      RESABS = DABS(RESK)
      DO 10 J=1,3
        JTW = J*2
        ABSC = HLGTH*XGK(JTW)
        ABSC1 = CENTR-ABSC
        ABSC2 = CENTR+ABSC
        FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP)
        FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP)
        FV1(JTW) = FVAL1
        FV2(JTW) = FVAL2
        FSUM = FVAL1+FVAL2
        RESG = RESG+WG(J)*FSUM
        RESK = RESK+WGK(JTW)*FSUM
        RESABS = RESABS+WGK(JTW)*(DABS(FVAL1)+DABS(FVAL2))
   10 CONTINUE
      DO 15 J=1,4
        JTWM1 = J*2-1
        ABSC = HLGTH*XGK(JTWM1)
        ABSC1 = CENTR-ABSC
        ABSC2 = CENTR+ABSC
        FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP)
        FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP)
        FV1(JTWM1) = FVAL1
        FV2(JTWM1) = FVAL2
        FSUM = FVAL1+FVAL2
        RESK = RESK+WGK(JTWM1)*FSUM
        RESABS = RESABS+WGK(JTWM1)*(DABS(FVAL1)+DABS(FVAL2))
   15 CONTINUE
      RESKH = RESK*0.5D+00
      RESASC = WGK(8)*DABS(FC-RESKH)
      DO 20 J=1,7
        RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESABS = RESABS*DHLGTH
      RESASC = RESASC*DHLGTH
      ABSERR = DABS((RESK-RESG)*HLGTH)
      IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
     *  ABSERR = RESASC*DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
      IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1((EPMACH*
     *  0.5D+02)*RESABS,ABSERR)
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQMOMO(ALFA,BETA,RI,RJ,RG,RH,INTEGR)
C***BEGIN PROLOGUE  DQMOMO
C***DATE WRITTEN   820101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A2A1,C3A2
C***KEYWORDS  MODIFIED CHEBYSHEV MOMENTS
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THIS ROUTINE COMPUTES MODIFIED CHEBSYSHEV MOMENTS. THE K-TH
C            MODIFIED CHEBYSHEV MOMENT IS DEFINED AS THE INTEGRAL OVER
C            (-1,1) OF W(X)*T(K,X), WHERE T(K,X) IS THE CHEBYSHEV
C            POLYNOMIAL OF DEGREE K.
C***DESCRIPTION
C
C        MODIFIED CHEBYSHEV MOMENTS
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C           ALFA   - DOUBLE PRECISION
C                    PARAMETER IN THE WEIGHT FUNCTION W(X), ALFA.GT.(-1)
C
C           BETA   - DOUBLE PRECISION
C                    PARAMETER IN THE WEIGHT FUNCTION W(X), BETA.GT.(-1)
C
C           RI     - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 25
C                    RI(K) IS THE INTEGRAL OVER (-1,1) OF
C                    (1+X)**ALFA*T(K-1,X), K = 1, ..., 25.
C
C           RJ     - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 25
C                    RJ(K) IS THE INTEGRAL OVER (-1,1) OF
C                    (1-X)**BETA*T(K-1,X), K = 1, ..., 25.
C
C           RG     - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 25
C                    RG(K) IS THE INTEGRAL OVER (-1,1) OF
C                    (1+X)**ALFA*LOG((1+X)/2)*T(K-1,X), K = 1, ..., 25.
C
C           RH     - DOUBLE PRECISION
C                    VECTOR OF DIMENSION 25
C                    RH(K) IS THE INTEGRAL OVER (-1,1) OF
C                    (1-X)**BETA*LOG((1-X)/2)*T(K-1,X), K = 1, ..., 25.
C
C           INTEGR - INTEGER
C                    INPUT PARAMETER INDICATING THE MODIFIED
C                    MOMENTS TO BE COMPUTED
C                    INTEGR = 1 COMPUTE RI, RJ
C                           = 2 COMPUTE RI, RJ, RG
C                           = 3 COMPUTE RI, RJ, RH
C                           = 4 COMPUTE RI, RJ, RG, RH
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DQMOMO
C
      DOUBLE PRECISION ALFA,ALFP1,ALFP2,AN,ANM1,BETA,BETP1,BETP2,RALF,
     *  RBET,RG,RH,RI,RJ
      INTEGER I,IM1,INTEGR
C
      DIMENSION RG(25),RH(25),RI(25),RJ(25)
C
C
C***FIRST EXECUTABLE STATEMENT  DQMOMO
      ALFP1 = ALFA+0.1D+01
      BETP1 = BETA+0.1D+01
      ALFP2 = ALFA+0.2D+01
      BETP2 = BETA+0.2D+01
      RALF = 0.2D+01**ALFP1
      RBET = 0.2D+01**BETP1
C
C           COMPUTE RI, RJ USING A FORWARD RECURRENCE RELATION.
C
      RI(1) = RALF/ALFP1
      RJ(1) = RBET/BETP1
      RI(2) = RI(1)*ALFA/ALFP2
      RJ(2) = RJ(1)*BETA/BETP2
      AN = 0.2D+01
      ANM1 = 0.1D+01
      DO 20 I=3,25
        RI(I) = -(RALF+AN*(AN-ALFP2)*RI(I-1))/(ANM1*(AN+ALFP1))
        RJ(I) = -(RBET+AN*(AN-BETP2)*RJ(I-1))/(ANM1*(AN+BETP1))
        ANM1 = AN
        AN = AN+0.1D+01
   20 CONTINUE
      IF(INTEGR.EQ.1) GO TO 70
      IF(INTEGR.EQ.3) GO TO 40
C
C           COMPUTE RG USING A FORWARD RECURRENCE RELATION.
C
      RG(1) = -RI(1)/ALFP1
      RG(2) = -(RALF+RALF)/(ALFP2*ALFP2)-RG(1)
      AN = 0.2D+01
      ANM1 = 0.1D+01
      IM1 = 2
      DO 30 I=3,25
        RG(I) = -(AN*(AN-ALFP2)*RG(IM1)-AN*RI(IM1)+ANM1*RI(I))/
     *  (ANM1*(AN+ALFP1))
        ANM1 = AN
        AN = AN+0.1D+01
        IM1 = I
   30 CONTINUE
      IF(INTEGR.EQ.2) GO TO 70
C
C           COMPUTE RH USING A FORWARD RECURRENCE RELATION.
C
   40 RH(1) = -RJ(1)/BETP1
      RH(2) = -(RBET+RBET)/(BETP2*BETP2)-RH(1)
      AN = 0.2D+01
      ANM1 = 0.1D+01
      IM1 = 2
      DO 50 I=3,25
        RH(I) = -(AN*(AN-BETP2)*RH(IM1)-AN*RJ(IM1)+
     *  ANM1*RJ(I))/(ANM1*(AN+BETP1))
        ANM1 = AN
        AN = AN+0.1D+01
        IM1 = I
   50 CONTINUE
      DO 60 I=2,25,2
        RH(I) = -RH(I)
   60 CONTINUE
   70 DO 80 I=2,25,2
        RJ(I) = -RJ(I)
   80 CONTINUE
   90 RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      DOUBLE PRECISION FUNCTION DQWGTS(X,A,B,ALFA,BETA,INTEGR)
C***BEGIN PROLOGUE  DQWGTS
C***REFER TO DQK15W
C***ROUTINES CALLED  (NONE)
C***REVISION DATE  810101   (YYMMDD)
C***KEYWORDS  WEIGHT FUNCTION, ALGEBRAICO-LOGARITHMIC
C             END-POINT SINGULARITIES
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THIS FUNCTION SUBPROGRAM IS USED TOGETHER WITH THE
C            ROUTINE DQAWS AND DEFINES THE WEIGHT FUNCTION.
C***END PROLOGUE  DQWGTS
C
      DOUBLE PRECISION A,ALFA,B,BETA,BMX,DLOG,X,XMA
      INTEGER INTEGR
C***FIRST EXECUTABLE STATEMENT  DQWGTS
      XMA = X-A
      BMX = B-X
      DQWGTS = XMA**ALFA*BMX**BETA
      GO TO (40,10,20,30),INTEGR
   10 DQWGTS = DQWGTS*DLOG(XMA)
      GO TO 40
   20 DQWGTS = DQWGTS*DLOG(BMX)
      GO TO 40
   30 DQWGTS = DQWGTS*DLOG(XMA)*DLOG(BMX)
   40 RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C==================================================================================

      SUBROUTINE DQAGP(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,
     *   NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK)
C***BEGIN PROLOGUE  DQAGP
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A2A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, GENERAL-PURPOSE,
C             SINGULARITIES AT USER SPECIFIED POINTS,
C             EXTRAPOLATION, GLOBALLY ADAPTIVE
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            BREAK POINTS OF THE INTEGRATION INTERVAL, WHERE LOCAL
C            DIFFICULTIES OF THE INTEGRAND MAY OCCUR (E.G.
C            SINGULARITIES, DISCONTINUITIES), ARE PROVIDED BY THE USER.
C***DESCRIPTION
C
C        COMPUTATION OF A DEFINITE INTEGRAL
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            NPTS2  - INTEGER
C                     NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF
C                     USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION
C                     RANGE, NPTS.GE.2.
C                     IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6.
C
C            POINTS - DOUBLE PRECISION
C                     VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2)
C                     ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK
C                     POINTS. IF THESE POINTS DO NOT CONSTITUTE AN
C                     ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC
C                     SORTING.
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE.
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (I.E. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL), IT
C                             SHOULD BE SUPPLIED TO THE ROUTINE AS AN
C                             ELEMENT OF THE VECTOR POINTS. IF NECESSARY
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             MUST BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT
C                             THE RETURNED RESULT IS THE BEST WHICH
C                             CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.GT.0.
C                         = 6 THE INPUT IS INVALID BECAUSE
C                             NPTS2.LT.2 OR
C                             BREAK POINTS ARE SPECIFIED OUTSIDE
C                             THE INTEGRATION RANGE OR
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             RESULT, ABSERR, NEVAL, LAST ARE SET TO
C                             ZERO. EXEPT WHEN LENIW OR LENW OR NPTS2 IS
C                             INVALID, IWORK(1), IWORK(LIMIT+1),
C                             WORK(LIMIT*2+1) AND WORK(LIMIT*3+1)
C                             ARE SET TO ZERO.
C                             WORK(1) IS SET TO A AND WORK(LIMIT+1)
C                             TO B (WHERE LIMIT = (LENIW-NPTS2)/2).
C
C         DIMENSIONING PARAMETERS
C            LENIW - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LENIW DETERMINES LIMIT = (LENIW-NPTS2)/2,
C                    WHICH IS THE MAXIMUM NUMBER OF SUBINTERVALS IN THE
C                    PARTITION OF THE GIVEN INTEGRATION INTERVAL (A,B),
C                    LENIW.GE.(3*NPTS2-2).
C                    IF LENIW.LT.(3*NPTS2-2), THE ROUTINE WILL END WITH
C                    IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LENIW*2-NPTS2.
C                    IF LENW.LT.LENIW*2-NPTS2, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
C                    PRODUCED IN THE SUBDIVISION PROCESS, WHICH
C                    DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS
C                    ACTUALLY IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LENIW. ON RETURN,
C                    THE FIRST K ELEMENTS OF WHICH CONTAIN
C                    POINTERS TO THE ERROR ESTIMATES OVER THE
C                    SUBINTERVALS, SUCH THAT WORK(LIMIT*3+IWORK(1)),...,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                    K = LIMIT+1-LAST OTHERWISE
C                    IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) CONTAIN THE
C                     SUBDIVISION LEVELS OF THE SUBINTERVALS, I.E.
C                     IF (AA,BB) IS A SUBINTERVAL OF (P1,P2)
C                     WHERE P1 AS WELL AS P2 IS A USER-PROVIDED
C                     BREAK POINT OR INTEGRATION LIMIT, THEN (AA,BB) HAS
C                     LEVEL L IF ABS(BB-AA) = ABS(P2-P1)*2**(-L),
C                    IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) HAVE
C                     NO SIGNIFICANCE FOR THE USER,
C                    NOTE THAT LIMIT = (LENIW-NPTS2)/2.
C
C            WORK  - DOUBLE PRECISION
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN
C                     THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE CORRESPONDING ERROR ESTIMATES,
C                    WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2)
C                     CONTAIN THE INTEGRATION LIMITS AND THE
C                     BREAK POINTS SORTED IN AN ASCENDING SEQUENCE.
C                    NOTE THAT LIMIT = (LENIW-NPTS2)/2.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQAGPE,XERROR
C***END PROLOGUE  DQAGP
C
      DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK
      INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,NEVAL,
     *  NPTS2
C
      DIMENSION IWORK(LENIW),POINTS(NPTS2),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQAGP
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LENIW.LT.(3*NPTS2-2).OR.LENW.LT.(LENIW*2-NPTS2).OR.NPTS2.LT.2)
     *  GO TO 10
C
C         PREPARE CALL FOR DQAGPE.
C
      LIMIT = (LENIW-NPTS2)/2
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
      L4 = LIMIT+L3
C
      CALL DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4),
     *  IWORK(1),IWORK(L1),IWORK(L2),LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF(IER.NE.0) CALL XERROR(26HABNORMAL RETURN FROM DQAGP,26,IER,LVL)
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,
     *   ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,PTS,IORD,LEVEL,NDIN,
     *   LAST)
C***BEGIN PROLOGUE  DQAGPE
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A2A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, GENERAL-PURPOSE,
C             SINGULARITIES AT USER SPECIFIED POINTS,
C             EXTRAPOLATION, GLOBALLY ADAPTIVE.
C***AUTHOR  PIESSENS,ROBERT ,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), HOPEFULLY
C            SATISFYING FOLLOWING CLAIM FOR ACCURACY ABS(I-RESULT).LE.
C            MAX(EPSABS,EPSREL*ABS(I)). BREAK POINTS OF THE INTEGRATION
C            INTERVAL, WHERE LOCAL DIFFICULTIES OF THE INTEGRAND MAY
C            OCCUR(E.G. SINGULARITIES,DISCONTINUITIES),PROVIDED BY USER.
C***DESCRIPTION
C
C        COMPUTATION OF A DEFINITE INTEGRAL
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            NPTS2  - INTEGER
C                     NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF
C                     USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION
C                     RANGE, NPTS2.GE.2.
C                     IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6.
C
C            POINTS - DOUBLE PRECISION
C                     VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2)
C                     ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK
C                     POINTS. IF THESE POINTS DO NOT CONSTITUTE AN
C                     ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC
C                     SORTING.
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS
C                     IN THE PARTITION OF (A,B), LIMIT.GE.NPTS2
C                     IF LIMIT.LT.NPTS2, THE ROUTINE WILL END WITH
C                     IER = 6.
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE.
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (I.E. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL), IT
C                             SHOULD BE SUPPLIED TO THE ROUTINE AS AN
C                             ELEMENT OF THE VECTOR POINTS. IF NECESSARY
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             MUST BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE. IT IS PRESUMED THAT
C                             THE REQUESTED TOLERANCE CANNOT BE
C                             ACHIEVED, AND THAT THE RETURNED RESULT IS
C                             THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.GT.0.
C                         = 6 THE INPUT IS INVALID BECAUSE
C                             NPTS2.LT.2 OR
C                             BREAK POINTS ARE SPECIFIED OUTSIDE
C                             THE INTEGRATION RANGE OR
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             OR LIMIT.LT.NPTS2.
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             AND ELIST(1) ARE SET TO ZERO. ALIST(1) AND
C                             BLIST(1) ARE SET TO A AND B RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                     INTEGRATION RANGE (A,B)
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                     INTEGRATION RANGE (A,B)
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI OF THE
C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
C
C            PTS    - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST NPTS2, CONTAINING THE
C                     INTEGRATION LIMITS AND THE BREAK POINTS OF THE
C                     INTERVAL IN ASCENDING SEQUENCE.
C
C            LEVEL  - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, CONTAINING THE
C                     SUBDIVISION LEVELS OF THE SUBINTERVAL, I.E. IF
C                     (AA,BB) IS A SUBINTERVAL OF (P1,P2) WHERE P1 AS
C                     WELL AS P2 IS A USER-PROVIDED BREAK POINT OR
C                     INTEGRATION LIMIT, THEN (AA,BB) HAS LEVEL L IF
C                     ABS(BB-AA) = ABS(P2-P1)*2**(-L).
C
C            NDIN   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST NPTS2, AFTER FIRST
C                     INTEGRATION OVER THE INTERVALS (PTS(I)),PTS(I+1),
C                     I = 0,1, ..., NPTS2-2, THE ERROR ESTIMATES OVER
C                     SOME OF THE INTERVALS MAY HAVE BEEN INCREASED
C                     ARTIFICIALLY, IN ORDER TO PUT THEIR SUBDIVISION
C                     FORWARD. IF THIS HAPPENS FOR THE SUBINTERVAL
C                     NUMBERED K, NDIN(K) IS PUT TO 1, OTHERWISE
C                     NDIN(K) = 0.
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
C                     SUBDIVISIONS PROCESS
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH,DQELG,DQK21,DQPSRT
C***END PROLOGUE  DQAGPE
      DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     *  A2,B,BLIST,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,DMAX1,DMIN1,
     *  DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,
     *  ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW,POINTS,PTS,
     *  RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP,UFLOW
      INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2,IROFF3,J,
     *  JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX,LIMIT,MAXERR,
     *  NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     *  LEVEL(LIMIT),NDIN(NPTS2),POINTS(NPTS2),PTS(NPTS2),RES3LA(3),
     *  RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION
C            (LIMEXP+2) AT LEAST).
C
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST LIMEXP+2
C                       CONTAINING THE PART OF THE EPSILON TABLE WHICH
C                       IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE
C                       APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS
C                       BEEN OBTAINED, IT IS PUT IN RLIST2(NUMRL2) AFTER
C                       NUMRL2 HAS BEEN INCREASED BY ONE.
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
C                       TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS
C                       NO LONGER ALLOWED (TRUE-VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQAGPE
      EPMACH = D1MACH(4)
C
C            TEST ON VALIDITY OF PARAMETERS
C            -----------------------------
C
      IER = 0
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IORD(1) = 0
      LEVEL(1) = 0
      NPTS = NPTS2-2
      IF(NPTS2.LT.2.OR.LIMIT.LE.NPTS.OR.(EPSABS.LE.0.0D+00.AND.
     *  EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))) IER = 6
      IF(IER.EQ.6) GO TO 999
C
C            IF ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN
C            ASCENDING SEQUENCE.
C
      SIGN = 1.0D+00
      IF(A.GT.B) SIGN = -1.0D+00
      PTS(1) = DMIN1(A,B)
      IF(NPTS.EQ.0) GO TO 15
      DO 10 I = 1,NPTS
        PTS(I+1) = POINTS(I)
   10 CONTINUE
   15 PTS(NPTS+2) = DMAX1(A,B)
      NINT = NPTS+1
      A1 = PTS(1)
      IF(NPTS.EQ.0) GO TO 40
      NINTP1 = NINT+1
      DO 20 I = 1,NINT
        IP1 = I+1
        DO 20 J = IP1,NINTP1
          IF(PTS(I).LE.PTS(J)) GO TO 20
          TEMP = PTS(I)
          PTS(I) = PTS(J)
          PTS(J) = TEMP
   20 CONTINUE
      IF(PTS(1).NE.DMIN1(A,B).OR.PTS(NINTP1).NE.DMAX1(A,B)) IER = 6
      IF(IER.EQ.6) GO TO 999
C
C            COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS.
C            ------------------------------------------------
C
   40 RESABS = 0.0D+00
      DO 50 I = 1,NINT
        B1 = PTS(I+1)
        CALL DQK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA)
        ABSERR = ABSERR+ERROR1
        RESULT = RESULT+AREA1
        NDIN(I) = 0
        IF(ERROR1.EQ.RESA.AND.ERROR1.NE.0.0D+00) NDIN(I) = 1
        RESABS = RESABS+DEFABS
        LEVEL(I) = 0
        ELIST(I) = ERROR1
        ALIST(I) = A1
        BLIST(I) = B1
        RLIST(I) = AREA1
        IORD(I) = I
        A1 = B1
   50 CONTINUE
      ERRSUM = 0.0D+00
      DO 55 I = 1,NINT
        IF(NDIN(I).EQ.1) ELIST(I) = ABSERR
        ERRSUM = ERRSUM+ELIST(I)
   55 CONTINUE
C
C           TEST ON ACCURACY.
C
      LAST = NINT
      NEVAL = 21*NINT
      DRES = DABS(RESULT)
      ERRBND = DMAX1(EPSABS,EPSREL*DRES)
      IF(ABSERR.LE.0.1D+03*EPMACH*RESABS.AND.ABSERR.GT.ERRBND) IER = 2
      IF(NINT.EQ.1) GO TO 80
      DO 70 I = 1,NPTS
        JLOW = I+1
        IND1 = IORD(I)
        DO 60 J = JLOW,NINT
          IND2 = IORD(J)
          IF(ELIST(IND1).GT.ELIST(IND2)) GO TO 60
          IND1 = IND2
          K = J
   60   CONTINUE
        IF(IND1.EQ.IORD(I)) GO TO 70
        IORD(K) = IORD(I)
        IORD(I) = IND1
   70 CONTINUE
      IF(LIMIT.LT.NPTS2) IER = 1
   80 IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 210
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      MAXERR = IORD(1)
      ERRMAX = ELIST(MAXERR)
      AREA = RESULT
      NRMAX = 1
      NRES = 0
      NUMRL2 = 1
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      ERLARG = ERRSUM
      ERTEST = ERRBND
      LEVMAX = 1
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      IERRO = 0
      UFLOW = D1MACH(1)
      OFLOW = D1MACH(2)
      ABSERR = OFLOW
      KSGN = -1
      IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*RESABS) KSGN = 1
C
C           MAIN DO-LOOP
C           ------------
C
      DO 160 LAST = NPTS2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR
C           ESTIMATE.
C
        LEVCUR = LEVEL(MAXERR)+1
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1)
        CALL DQK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        NEVAL = NEVAL+42
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 95
        IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12)
     *  .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 90
        IF(EXTRAP) IROFF2 = IROFF2+1
        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
   90   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
   95   LEVEL(MAXERR) = LEVCUR
        LEVEL(LAST) = LEVCUR
        RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
        IF(IROFF2.GE.5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE
C
        IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
     *  (DABS(A2)+0.1D+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF(ERROR2.GT.ERROR1) GO TO 100
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 110
  100   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
  110   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(ERRSUM.LE.ERRBND) GO TO 190
C ***JUMP OUT OF DO-LOOP
        IF(IER.NE.0) GO TO 170
        IF(NOEXT) GO TO 160
        ERLARG = ERLARG-ERLAST
        IF(LEVCUR+1.LE.LEVMAX) ERLARG = ERLARG+ERRO12
        IF(EXTRAP) GO TO 120
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160
        EXTRAP = .TRUE.
        NRMAX = 2
  120   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 140
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER
C           THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
        DO 130 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160
          NRMAX = NRMAX+1
  130   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
  140   NUMRL2 = NUMRL2+1
        RLIST2(NUMRL2) = AREA
        IF(NUMRL2.LE.2) GO TO 155
        CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES)
        KTMIN = KTMIN+1
        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5
        IF(ABSEPS.GE.ABSERR) GO TO 150
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF(ABSERR.LT.ERTEST) GO TO 170
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
  150   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
        IF(IER.GE.5) GO TO 170
  155   MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        LEVMAX = LEVMAX+1
        ERLARG = ERRSUM
  160 CONTINUE
C
C           SET THE FINAL RESULT.
C           ---------------------
C
C
  170 IF(ABSERR.EQ.OFLOW) GO TO 190
      IF((IER+IERRO).EQ.0) GO TO 180
      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
      IF(IER.EQ.0) IER = 3
      IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 175
      IF(ABSERR.GT.ERRSUM)GO TO 190
      IF(AREA.EQ.0.0D+00) GO TO 210
      GO TO 180
  175 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 190
C
C           TEST ON DIVERGENCE.
C
  180 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE.
     *  RESABS*0.1D-01) GO TO 210
      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.OR.
     *  ERRSUM.GT.DABS(AREA)) IER = 6
      GO TO 210
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  190 RESULT = 0.0D+00
      DO 200 K = 1,LAST
        RESULT = RESULT+RLIST(K)
  200 CONTINUE
      ABSERR = ERRSUM
  210 IF(IER.GT.2) IER = IER-1
      RESULT = RESULT*SIGN
  999 RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQAGI(F,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,
     *     IER,LIMIT,LENW,LAST,IWORK,WORK)
C***BEGIN PROLOGUE  DQAGI
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A3A1,H2A4A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, INFINITE INTERVALS,
C             GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION,
C             GLOBALLY ADAPTIVE
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. -K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            INTEGRAL   I = INTEGRAL OF F OVER (BOUND,+INFINITY)
C            OR I = INTEGRAL OF F OVER (-INFINITY,BOUND)
C            OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY)
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***DESCRIPTION
C
C        INTEGRATION OVER INFINITE INTERVALS
C        STANDARD FORTRAN SUBROUTINE
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            BOUND  - DOUBLE PRECISION
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            INF    - INTEGER
C                     INDICATING THE KIND OF INTEGRATION RANGE INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                              OR LIMIT.LT.1 OR LENIW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST ARE SET TO
C                             ZERO. EXEPT WHEN LIMIT OR LENIW IS
C                             INVALID, IWORK(1), WORK(LIMIT*2+1) AND
C                             WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1)
C                             IS SET TO A AND WORK(LIMIT+1) TO B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS
C                    IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL
C                    (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*4.
C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
C                    PRODUCED IN THE SUBDIVISION PROCESS, WHICH
C                    DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS
C                    ACTUALLY IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                    K ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS,
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                    K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - DOUBLE PRECISION
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END POINTS,
C                    WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) CONTAIN THE
C                     INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3)
C                     CONTAIN THE ERROR ESTIMATES.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQAGIE,XERROR
C***END PROLOGUE  DQAGI
C
      DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(LIMIT),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQAGI
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR DQAGIE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
C
      CALL DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
       LVL = 0
10    IF(IER.EQ.6) LVL = 1
      !IF(IER.NE.0) CALL XERROR(26HABNORMAL RETURN FROM DQAGI,26,IER,LVL)
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *   NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C***BEGIN PROLOGUE  DQAGIE
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A3A1,H2A4A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, INFINITE INTERVALS,
C             GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION,
C             GLOBALLY ADAPTIVE
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH & PROGR. DIV - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH & PROGR. DIV - K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            INTEGRAL   I = INTEGRAL OF F OVER (BOUND,+INFINITY)
C            OR I = INTEGRAL OF F OVER (-INFINITY,BOUND)
C            OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I))
C***DESCRIPTION
C
C INTEGRATION OVER INFINITE INTERVALS
C STANDARD FORTRAN SUBROUTINE
C
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            BOUND  - DOUBLE PRECISION
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            INF    - DOUBLE PRECISION
C                     INDICATING THE KIND OF INTEGRATION RANGE INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS
C                     IN THE PARTITION OF (A,B), LIMIT.GE.1
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER,IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES.
C                             IF THE POSITION OF A LOCAL DIFFICULTY CAN
C                             BE DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             ELIST(1) AND IORD(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO 0
C                             AND 1 RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT,  THE FIRST
C                     LAST ELEMENTS OF WHICH ARE THE MODULI OF THE
C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED
C                     IN THE SUBDIVISION PROCESS
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH,DQELG,DQK15I,DQPSRT
C***END PROLOGUE  DQAGIE
      DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     *  A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,
     *  DMAX1,DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,
     *  ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS,
     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW
      INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     *  RES3LA(3),RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE DQELG.
C
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST (LIMEXP+2),
C                       CONTAINING THE PART OF THE EPSILON TABLE
C                       WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
C                       INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN
C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
C                       BY ONE.
C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP
C                       TO NOW, MULTIPLIED BY 1.5
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
C                       TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
C                       IS NO LONGER ALLOWED (TRUE-VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQAGIE
       EPMACH = D1MACH(4)
C
C           TEST ON VALIDITY OF PARAMETERS
C           -----------------------------
C
      IER = 0
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      ALIST(1) = 0.0D+00
      BLIST(1) = 0.1D+01
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IORD(1) = 0
      IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))
     *  IER = 6
       IF(IER.EQ.6) GO TO 999
C
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
C           DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1).
C           IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE
C           I1 = INTEGRAL OF F OVER (-INFINITY,0),
C           I2 = INTEGRAL OF F OVER (0,+INFINITY).
C
      BOUN = BOUND
      IF(INF.EQ.2) BOUN = 0.0D+00
      CALL DQK15I(F,BOUN,INF,0.0D+00,0.1D+01,RESULT,ABSERR,
     *  DEFABS,RESABS)
C
C           TEST ON ACCURACY
C
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      DRES = DABS(RESULT)
      ERRBND = DMAX1(EPSABS,EPSREL*DRES)
      IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2
      IF(LIMIT.EQ.1) IER = 1
      IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR.
     *  ABSERR.EQ.0.0D+00) GO TO 130
C
C           INITIALIZATION
C           --------------
C
      UFLOW = D1MACH(1)
      OFLOW = D1MACH(2)
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      NRMAX = 1
      NRES = 0
      KTMIN = 0
      NUMRL2 = 2
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IERRO = 0
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        CALL DQK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15
        IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12)
     *  .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10
        IF(EXTRAP) IROFF2 = IROFF2+1
        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
   10   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
        IF(IROFF2.GE.5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT SOME POINTS OF THE INTEGRATION RANGE.
C
        IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
     *  (DABS(A2)+0.1D+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF(ERROR2.GT.ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   30   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
        IF(ERRSUM.LE.ERRBND) GO TO 115
        IF(IER.NE.0) GO TO 100
        IF(LAST.EQ.2) GO TO 80
        IF(NOEXT) GO TO 90
        ERLARG = ERLARG-ERLAST
        IF(DABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12
        IF(EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE
C           LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
          IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
          NRMAX = NRMAX+1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2+1
        RLIST2(NUMRL2) = AREA
        CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES)
        KTMIN = KTMIN+1
        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5
        IF(ABSEPS.GE.ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS))
        IF(ABSERR.LE.ERTEST) GO TO 100
C
C            PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
        IF(IER.EQ.5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5D+00
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = 0.375D+00
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF(ABSERR.EQ.OFLOW) GO TO 115
      IF((IER+IERRO).EQ.0) GO TO 110
      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
      IF(IER.EQ.0) IER = 3
      IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 105
      IF(ABSERR.GT.ERRSUM)GO TO 115
      IF(AREA.EQ.0.0D+00) GO TO 130
      GO TO 110
  105 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 115
C
C           TEST ON DIVERGENCE
C
  110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE.
     * DEFABS*0.1D-01) GO TO 130
      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.
     *OR.ERRSUM.GT.DABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0D+00
      DO 120 K = 1,LAST
        RESULT = RESULT+RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 NEVAL = 30*LAST-15
      IF(INF.EQ.2) NEVAL = 2*NEVAL
      IF(IER.GT.2) IER=IER-1
  999 RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQELG(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES)
C***BEGIN PROLOGUE  DQELG
C***REFER TO  DQAGIE,DQAGOE,DQAGPE,DQAGSE
C***ROUTINES CALLED  D1MACH
C***REVISION DATE  830518   (YYMMDD)
C***KEYWORDS  EPSILON ALGORITHM, CONVERGENCE ACCELERATION,
C             EXTRAPOLATION
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF
C            APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM OF
C            P.WYNN. AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN.
C            THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE
C            ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL
C            ARE PRESERVED.
C***DESCRIPTION
C
C           EPSILON ALGORITHM
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS
C              N      - INTEGER
C                       EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE
C                       FIRST COLUMN OF THE EPSILON TABLE.
C
C              EPSTAB - DOUBLE PRECISION
C                       VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS
C                       OF THE TWO LOWER DIAGONALS OF THE TRIANGULAR
C                       EPSILON TABLE. THE ELEMENTS ARE NUMBERED
C                       STARTING AT THE RIGHT-HAND CORNER OF THE
C                       TRIANGLE.
C
C              RESULT - DOUBLE PRECISION
C                       RESULTING APPROXIMATION TO THE INTEGRAL
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM
C                       RESULT AND THE 3 PREVIOUS RESULTS
C
C              RES3LA - DOUBLE PRECISION
C                       VECTOR OF DIMENSION 3 CONTAINING THE LAST 3
C                       RESULTS
C
C              NRES   - INTEGER
C                       NUMBER OF CALLS TO THE ROUTINE
C                       (SHOULD BE ZERO AT FIRST CALL)
C
C***END PROLOGUE  DQELG
C
      DOUBLE PRECISION ABSERR,DABS,DELTA1,DELTA2,DELTA3,DMAX1,D1MACH,
     *  EPMACH,EPSINF,EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3,
     *  OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3
      INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM
      DIMENSION EPSTAB(52),RES3LA(3)
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           E0     - THE 4 ELEMENTS ON WHICH THE COMPUTATION OF A NEW
C           E1       ELEMENT IN THE EPSILON TABLE IS BASED
C           E2
C           E3                 E0
C                        E3    E1    NEW
C                              E2
C           NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW
C                    DIAGONAL
C           ERROR  - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2)
C           RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE
C                    OF ERROR
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C           LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON
C           TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER
C           DIAGONAL OF THE EPSILON TABLE IS DELETED.
C
C***FIRST EXECUTABLE STATEMENT  DQELG
      EPMACH = D1MACH(4)
      OFLOW = D1MACH(2)
      NRES = NRES+1
      ABSERR = OFLOW
      RESULT = EPSTAB(N)
      IF(N.LT.3) GO TO 100
      LIMEXP = 50
      EPSTAB(N+2) = EPSTAB(N)
      NEWELM = (N-1)/2
      EPSTAB(N) = OFLOW
      NUM = N
      K1 = N
      DO 40 I = 1,NEWELM
        K2 = K1-1
        K3 = K1-2
        RES = EPSTAB(K1+2)
        E0 = EPSTAB(K3)
        E1 = EPSTAB(K2)
        E2 = RES
        E1ABS = DABS(E1)
        DELTA2 = E2-E1
        ERR2 = DABS(DELTA2)
        TOL2 = DMAX1(DABS(E2),E1ABS)*EPMACH
        DELTA3 = E1-E0
        ERR3 = DABS(DELTA3)
        TOL3 = DMAX1(E1ABS,DABS(E0))*EPMACH
        IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10
C
C           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE
C           ACCURACY, CONVERGENCE IS ASSUMED.
C           RESULT = E2
C           ABSERR = ABS(E1-E0)+ABS(E2-E1)
C
        RESULT = RES
        ABSERR = ERR2+ERR3
C ***JUMP OUT OF DO-LOOP
        GO TO 100
   10   E3 = EPSTAB(K1)
        EPSTAB(K1) = E1
        DELTA1 = E1-E3
        ERR1 = DABS(DELTA1)
        TOL1 = DMAX1(E1ABS,DABS(E3))*EPMACH
C
C           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
C           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N
C
        IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20
        SS = 0.1D+01/DELTA1+0.1D+01/DELTA2-0.1D+01/DELTA3
        EPSINF = DABS(SS*E1)
C
C           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND
C           EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE
C           OF N.
C
        IF(EPSINF.GT.0.1D-03) GO TO 30
   20   N = I+I-1
C ***JUMP OUT OF DO-LOOP
        GO TO 50
C
C           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST
C           THE VALUE OF RESULT.
C
   30   RES = E1+0.1D+01/SS
        EPSTAB(K1) = RES
        K1 = K1-2
        ERROR = ERR2+DABS(RES-E2)+ERR3
        IF(ERROR.GT.ABSERR) GO TO 40
        ABSERR = ERROR
        RESULT = RES
   40 CONTINUE
C
C           SHIFT THE TABLE.
C
   50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1
      IB = 1
      IF((NUM/2)*2.EQ.NUM) IB = 2
      IE = NEWELM+1
      DO 60 I=1,IE
        IB2 = IB+2
        EPSTAB(IB) = EPSTAB(IB2)
        IB = IB2
   60 CONTINUE
      IF(NUM.EQ.N) GO TO 80
      INDX = NUM-N+1
      DO 70 I = 1,N
        EPSTAB(I)= EPSTAB(INDX)
        INDX = INDX+1
   70 CONTINUE
   80 IF(NRES.GE.4) GO TO 90
      RES3LA(NRES) = RESULT
      ABSERR = OFLOW
      GO TO 100
C
C           COMPUTE ERROR ESTIMATE
C
   90 ABSERR = DABS(RESULT-RES3LA(3))+DABS(RESULT-RES3LA(2))
     *  +DABS(RESULT-RES3LA(1))
      RES3LA(1) = RES3LA(2)
      RES3LA(2) = RES3LA(3)
      RES3LA(3) = RESULT
  100 ABSERR = DMAX1(ABSERR,0.5D+01*EPMACH*DABS(RESULT))
      RETURN
      END
C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQK15I(F,BOUN,INF,A,B,RESULT,ABSERR,RESABS,RESASC)
C***BEGIN PROLOGUE  DQK15I
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A3A2,H2A4A2
C***KEYWORDS  15-POINT TRANSFORMED GAUSS-KRONROD RULES
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THE ORIGINAL (INFINITE INTEGRATION RANGE IS MAPPED
C            ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1).
C            IT IS THE PURPOSE TO COMPUTE
C            I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B),
C            J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B).
C***DESCRIPTION
C
C           INTEGRATION RULE
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE CALLING PROGRAM.
C
C              BOUN   - DOUBLE PRECISION
C                       FINITE BOUND OF ORIGINAL INTEGRATION
C                       RANGE (SET TO ZERO IF INF = +2)
C
C              INF    - INTEGER
C                       IF INF = -1, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,BOUND),
C                       IF INF = +1, THE ORIGINAL INTERVAL IS
C                                   (BOUND,+INFINITY),
C                       IF INF = +2, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,+INFINITY) AND
C                       THE INTEGRAL IS COMPUTED AS THE SUM OF TWO
C                       INTEGRALS, ONE OVER (-INFINITY,0) AND ONE OVER
C                       (0,+INFINITY).
C
C              A      - DOUBLE PRECISION
C                       LOWER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C              B      - DOUBLE PRECISION
C                       UPPER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C            ON RETURN
C              RESULT - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 15-POINT
C                       KRONROD RULE(RESK) OBTAINED BY OPTIMAL ADDITION
C                       OF ABSCISSAE TO THE 7-POINT GAUSS RULE(RESG).
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C              RESABS - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF
C                       ABS((TRANSFORMED INTEGRAND)-I/(B-A)) OVER (A,B)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH
C***END PROLOGUE  DQK15I
C
      DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DABS,DINF,
     *  DMAX1,DMIN1,D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,
     *  RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,UFLOW,WG,WGK,
     *  XGK
      INTEGER INF,J
      EXTERNAL F
C
      DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8)
C
C           THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL
C           (-1,1).  BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND
C           THEIR CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 15-POINT KRONROD RULE
C                    XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 7-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 15-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING
C                    TO THE ABSCISSAE XGK(2), XGK(4), ...
C                    WG(1), WG(3), ... ARE SET TO ZERO.
C
      DATA WG(1) / 0.0D0 /
      DATA WG(2) / 0.1294849661 6886969327 0611432679 082D0 /
      DATA WG(3) / 0.0D0 /
      DATA WG(4) / 0.2797053914 8927666790 1467771423 780D0 /
      DATA WG(5) / 0.0D0 /
      DATA WG(6) / 0.3818300505 0511894495 0369775488 975D0 /
      DATA WG(7) / 0.0D0 /
      DATA WG(8) / 0.4179591836 7346938775 5102040816 327D0 /
C
      DATA XGK(1) / 0.9914553711 2081263920 6854697526 329D0 /
      DATA XGK(2) / 0.9491079123 4275852452 6189684047 851D0 /
      DATA XGK(3) / 0.8648644233 5976907278 9712788640 926D0 /
      DATA XGK(4) / 0.7415311855 9939443986 3864773280 788D0 /
      DATA XGK(5) / 0.5860872354 6769113029 4144838258 730D0 /
      DATA XGK(6) / 0.4058451513 7739716690 6606412076 961D0 /
      DATA XGK(7) / 0.2077849550 0789846760 0689403773 245D0 /
      DATA XGK(8) / 0.0000000000 0000000000 0000000000 000D0 /
C
      DATA WGK(1) / 0.0229353220 1052922496 3732008058 970D0 /
      DATA WGK(2) / 0.0630920926 2997855329 0700663189 204D0 /
      DATA WGK(3) / 0.1047900103 2225018383 9876322541 518D0 /
      DATA WGK(4) / 0.1406532597 1552591874 5189590510 238D0 /
      DATA WGK(5) / 0.1690047266 3926790282 6583426598 550D0 /
      DATA WGK(6) / 0.1903505780 6478540991 3256402421 014D0 /
      DATA WGK(7) / 0.2044329400 7529889241 4161999234 649D0 /
      DATA WGK(8) / 0.2094821410 8472782801 2999174891 714D0 /
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC*  - ABSCISSA
C           TABSC* - TRANSFORMED ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED
C                    INTEGRAND OVER (A,B), I.E. TO I/(B-A)
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQK15I
      EPMACH = D1MACH(4)
      UFLOW = D1MACH(1)
      DINF = MIN0(1,INF)
C
      CENTR = 0.5D+00*(A+B)
      HLGTH = 0.5D+00*(B-A)
      TABSC1 = BOUN+DINF*(0.1D+01-CENTR)/CENTR
      FVAL1 = F(TABSC1)
      IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1)
      FC = (FVAL1/CENTR)/CENTR
C
C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ERROR.
C
      RESG = WG(8)*FC
      RESK = WGK(8)*FC
      RESABS = DABS(RESK)
      DO 10 J=1,7
        ABSC = HLGTH*XGK(J)
        ABSC1 = CENTR-ABSC
        ABSC2 = CENTR+ABSC
        TABSC1 = BOUN+DINF*(0.1D+01-ABSC1)/ABSC1
        TABSC2 = BOUN+DINF*(0.1D+01-ABSC2)/ABSC2
        FVAL1 = F(TABSC1)
        FVAL2 = F(TABSC2)
        IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1)
        IF(INF.EQ.2) FVAL2 = FVAL2+F(-TABSC2)
        FVAL1 = (FVAL1/ABSC1)/ABSC1
        FVAL2 = (FVAL2/ABSC2)/ABSC2
        FV1(J) = FVAL1
        FV2(J) = FVAL2
        FSUM = FVAL1+FVAL2
        RESG = RESG+WG(J)*FSUM
        RESK = RESK+WGK(J)*FSUM
        RESABS = RESABS+WGK(J)*(DABS(FVAL1)+DABS(FVAL2))
   10 CONTINUE
      RESKH = RESK*0.5D+00
      RESASC = WGK(8)*DABS(FC-RESKH)
      DO 20 J=1,7
        RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESASC = RESASC*HLGTH
      RESABS = RESABS*HLGTH
      ABSERR = DABS((RESK-RESG)*HLGTH)
      IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.D0) ABSERR = RESASC*
     * DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
      IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1
     * ((EPMACH*0.5D+02)*RESABS,ABSERR)
      RETURN
      END

C=============================================================================
C=============================================================================
C=============================================================================
C============================================================================= 
      SUBROUTINE DQAGS(F,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER,
     *   LIMIT,LENW,LAST,IWORK,WORK)
C***BEGIN PROLOGUE  DQAGS
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A1A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, GENERAL-PURPOSE,
C             (END-POINT) SINGULARITIES, EXTRAPOLATION,
C             GLOBALLY ADAPTIVE
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROG. DIV. - K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL  I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***DESCRIPTION
C
C        COMPUTATION OF A DEFINITE INTEGRAL
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT. HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE. IT IS PRESUMED THAT
C                             THE REQUESTED TOLERANCE CANNOT BE
C                             ACHIEVED, AND THAT THE RETURNED RESULT IS
C                             THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)
C                             OR LIMIT.LT.1 OR LENW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST ARE SET TO
C                             ZERO.EXCEPT WHEN LIMIT OR LENW IS INVALID,
C                             IWORK(1), WORK(LIMIT*2+1) AND
C                             WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1)
C                             IS SET TO A AND WORK(LIMIT+1) TO B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS
C                    IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL
C                    (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*4.
C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
C                    PRODUCED IN THE SUBDIVISION PROCESS, DETEMINES THE
C                    NUMBER OF SIGNIFICANT ELEMENTS ACTUALLY IN THE WORK
C                    ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                    ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2),
C                    AND K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - DOUBLE PRECISION
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END-POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END-POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN
C                     THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQAGSE,XERROR
C***END PROLOGUE  DQAGS
C
C
      DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(LIMIT),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQAGS
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR DQAGSE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
C
      CALL DQAGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,
     *  IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF(IER.NE.0) CALL XERROR(26HABNORMAL RETURN FROM DQAGS,26,IER,LVL)
      RETURN
      END

C=============================================================================
C=============================================================================
C=============================================================================
C============================================================================= 
      SUBROUTINE DQAGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,
     *   IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C***BEGIN PROLOGUE  DQAGSE
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A1A1
C***KEYWORDS  AUTOMATIC INTEGRATOR, GENERAL-PURPOSE,
C             (END POINT) SINGULARITIES, EXTRAPOLATION,
C             GLOBALLY ADAPTIVE
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***DESCRIPTION
C
C        COMPUTATION OF A DEFINITE INTEGRAL
C        STANDARD FORTRAN SUBROUTINE
C        DOUBLE PRECISION VERSION
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPERBOUND ON THE NUMBER OF SUBINTERVALS
C                     IN THE PARTITION OF (A,B)
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                         = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             EPSABS.LE.0 AND
C                             EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28).
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             IORD(1) AND ELIST(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO A AND B
C                             RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE
C                     GIVEN INTEGRATION RANGE (A,B)
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                     INTEGRATION RANGE (A,B)
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI OF THE
C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
C                     SUBDIVISION PROCESS
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH,DQELG,DQK21,DQPSRT
C***END PROLOGUE  DQAGSE
C
      DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     *  A2,B,BLIST,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,D1MACH,DMAX1,
     *  DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX,
     *  ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS,RESEPS,RESULT,
     *  RES3LA,RLIST,RLIST2,SMALL,UFLOW
      INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     * RES3LA(3),RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE DQELG (RLIST2 SHOULD BE OF DIMENSION
C            (LIMEXP+2) AT LEAST).
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST LIMEXP+2 CONTAINING
C                       THE PART OF THE EPSILON TABLE WHICH IS STILL
C                       NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT INTERVAL
C           *****2    - VARIABLE FOR THE RIGHT INTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
C                       INTEGRAL HAS BEEN OBTAINED IT IS PUT IN
C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
C                       BY ONE.
C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP
C                       TO NOW, MULTIPLIED BY 1.5
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS
C                       ATTEMPTING TO PERFORM EXTRAPOLATION I.E. BEFORE
C                       SUBDIVIDING THE SMALLEST INTERVAL WE TRY TO
C                       DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
C                       IS NO LONGER ALLOWED (TRUE VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQAGSE
      EPMACH = D1MACH(4)
C
C            TEST ON VALIDITY OF PARAMETERS
C            ------------------------------
      IER = 0
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))
     *   IER = 6
      IF(IER.EQ.6) GO TO 999
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      UFLOW = D1MACH(1)
      OFLOW = D1MACH(2)
      IERRO = 0
      CALL DQK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS)
C
C           TEST ON ACCURACY.
C
      DRES = DABS(RESULT)
      ERRBND = DMAX1(EPSABS,EPSREL*DRES)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2
      IF(LIMIT.EQ.1) IER = 1
      IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR.
     *  ABSERR.EQ.0.0D+00) GO TO 140
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      NRMAX = 1
      NRES = 0
      NUMRL2 = 2
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR
C           ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        CALL DQK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 15
        IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12)
     *  .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10
        IF(EXTRAP) IROFF2 = IROFF2+1
        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
   10   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
        IF(IROFF2.GE.5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS
C           EQUALS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
     *  (DABS(A2)+0.1D+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF(ERROR2.GT.ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   30   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(ERRSUM.LE.ERRBND) GO TO 115
C ***JUMP OUT OF DO-LOOP
        IF(IER.NE.0) GO TO 100
        IF(LAST.EQ.2) GO TO 80
        IF(NOEXT) GO TO 90
        ERLARG = ERLARG-ERLAST
        IF(DABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12
        IF(EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE
C           LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
          NRMAX = NRMAX+1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2+1
        RLIST2(NUMRL2) = AREA
        CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES)
        KTMIN = KTMIN+1
        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5
        IF(ABSEPS.GE.ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF(ABSERR.LE.ERTEST) GO TO 100
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
        IF(IER.EQ.5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5D+00
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = DABS(B-A)*0.375D+00
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF(ABSERR.EQ.OFLOW) GO TO 115
      IF(IER+IERRO.EQ.0) GO TO 110
      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
      IF(IER.EQ.0) IER = 3
      IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00) GO TO 105
      IF(ABSERR.GT.ERRSUM) GO TO 115
      IF(AREA.EQ.0.0D+00) GO TO 130
      GO TO 110
  105 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE.
C
  110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE.
     * DEFABS*0.1D-01) GO TO 130
      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03
     * .OR.ERRSUM.GT.DABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0D+00
      DO 120 K = 1,LAST
         RESULT = RESULT+RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 IF(IER.GT.2) IER = IER-1
  140 NEVAL = 42*LAST-21
  999 RETURN
      END

C=============================================================================
C=============================================================================
C=============================================================================
C============================================================================= 
      SUBROUTINE DQK21(F,A,B,RESULT,ABSERR,RESABS,RESASC)
C***BEGIN PROLOGUE  DQK21
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A1A2
C***KEYWORDS  21-POINT GAUSS-KRONROD RULES
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                           ESTIMATE
C                       J = INTEGRAL OF ABS(F) OVER (A,B)
C***DESCRIPTION
C
C           INTEGRATION RULES
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              A      - DOUBLE PRECISION
C                       LOWER LIMIT OF INTEGRATION
C
C              B      - DOUBLE PRECISION
C                       UPPER LIMIT OF INTEGRATION
C
C            ON RETURN
C              RESULT - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 21-POINT
C                       KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION
C                       OF ABSCISSAE TO THE 10-POINT GAUSS RULE (RESG).
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD NOT EXCEED ABS(I-RESULT)
C
C              RESABS - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C                       OVER (A,B)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH
C***END PROLOGUE  DQK21
C
      DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DABS,DHLGTH,DMAX1,DMIN1,
     *  D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC,
     *  RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK
      INTEGER J,JTW,JTWM1
      EXTERNAL F
C
      DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11)
C
C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
C           CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 21-POINT KRONROD RULE
C                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 10-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 10-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 21-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 10-POINT GAUSS RULE
C
C
C GAUSS QUADRATURE WEIGHTS AND KRONRON QUADRATURE ABSCISSAE AND WEIGHTS
C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON,
C BELL LABS, NOV. 1981.
C
      DATA WG  (  1) / 0.0666713443 0868813759 3568809893 332 D0 /
      DATA WG  (  2) / 0.1494513491 5058059314 5776339657 697 D0 /
      DATA WG  (  3) / 0.2190863625 1598204399 5534934228 163 D0 /
      DATA WG  (  4) / 0.2692667193 0999635509 1226921569 469 D0 /
      DATA WG  (  5) / 0.2955242247 1475287017 3892994651 338 D0 /
C
      DATA XGK (  1) / 0.9956571630 2580808073 5527280689 003 D0 /
      DATA XGK (  2) / 0.9739065285 1717172007 7964012084 452 D0 /
      DATA XGK (  3) / 0.9301574913 5570822600 1207180059 508 D0 /
      DATA XGK (  4) / 0.8650633666 8898451073 2096688423 493 D0 /
      DATA XGK (  5) / 0.7808177265 8641689706 3717578345 042 D0 /
      DATA XGK (  6) / 0.6794095682 9902440623 4327365114 874 D0 /
      DATA XGK (  7) / 0.5627571346 6860468333 9000099272 694 D0 /
      DATA XGK (  8) / 0.4333953941 2924719079 9265943165 784 D0 /
      DATA XGK (  9) / 0.2943928627 0146019813 1126603103 866 D0 /
      DATA XGK ( 10) / 0.1488743389 8163121088 4826001129 720 D0 /
      DATA XGK ( 11) / 0.0000000000 0000000000 0000000000 000 D0 /
C
      DATA WGK (  1) / 0.0116946388 6737187427 8064396062 192 D0 /
      DATA WGK (  2) / 0.0325581623 0796472747 8818972459 390 D0 /
      DATA WGK (  3) / 0.0547558965 7435199603 1381300244 580 D0 /
      DATA WGK (  4) / 0.0750396748 1091995276 7043140916 190 D0 /
      DATA WGK (  5) / 0.0931254545 8369760553 5065465083 366 D0 /
      DATA WGK (  6) / 0.1093871588 0229764189 9210590325 805 D0 /
      DATA WGK (  7) / 0.1234919762 6206585107 7958109831 074 D0 /
      DATA WGK (  8) / 0.1347092173 1147332592 8054001771 707 D0 /
      DATA WGK (  9) / 0.1427759385 7706008079 7094273138 717 D0 /
      DATA WGK ( 10) / 0.1477391049 0133849137 4841515972 068 D0 /
      DATA WGK ( 11) / 0.1494455540 0291690566 4936468389 821 D0 /
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC   - ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 10-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 21-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
C                    I.E. TO I/(B-A)
C
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQK21
      EPMACH = D1MACH(4)
      UFLOW = D1MACH(1)
C
      CENTR = 0.5D+00*(A+B)
      HLGTH = 0.5D+00*(B-A)
      DHLGTH = DABS(HLGTH)
C
C           COMPUTE THE 21-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
C
      RESG = 0.0D+00
      FC = F(CENTR)
      RESK = WGK(11)*FC
      RESABS = DABS(RESK)
      DO 10 J=1,5
        JTW = 2*J
        ABSC = HLGTH*XGK(JTW)
        FVAL1 = F(CENTR-ABSC)
        FVAL2 = F(CENTR+ABSC)
        FV1(JTW) = FVAL1
        FV2(JTW) = FVAL2
        FSUM = FVAL1+FVAL2
        RESG = RESG+WG(J)*FSUM
        RESK = RESK+WGK(JTW)*FSUM
        RESABS = RESABS+WGK(JTW)*(DABS(FVAL1)+DABS(FVAL2))
   10 CONTINUE
      DO 15 J = 1,5
        JTWM1 = 2*J-1
        ABSC = HLGTH*XGK(JTWM1)
        FVAL1 = F(CENTR-ABSC)
        FVAL2 = F(CENTR+ABSC)
        FV1(JTWM1) = FVAL1
        FV2(JTWM1) = FVAL2
        FSUM = FVAL1+FVAL2
        RESK = RESK+WGK(JTWM1)*FSUM
        RESABS = RESABS+WGK(JTWM1)*(DABS(FVAL1)+DABS(FVAL2))
   15 CONTINUE
      RESKH = RESK*0.5D+00
      RESASC = WGK(11)*DABS(FC-RESKH)
      DO 20 J=1,10
        RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESABS = RESABS*DHLGTH
      RESASC = RESASC*DHLGTH
      ABSERR = DABS((RESK-RESG)*HLGTH)
      IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
     *  ABSERR = RESASC*DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
      IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1
     *  ((EPMACH*0.5D+02)*RESABS,ABSERR)
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
C***BEGIN PROLOGUE  DQPSRT
C***REFER TO  DQAGE,DQAGIE,DQAGPE,DQAWSE
C***ROUTINES CALLED  (NONE)
C***REVISION DATE  810101   (YYMMDD)
C***KEYWORDS  SEQUENTIAL SORTING
C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
C***PURPOSE  THIS ROUTINE MAINTAINS THE DESCENDING ORDERING IN THE
C            LIST OF THE LOCAL ERROR ESTIMATED RESULTING FROM THE
C            INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR
C            ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH
C            METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE AND
C            BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE.
C***DESCRIPTION
C
C           ORDERING ROUTINE
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS (MEANING AT OUTPUT)
C              LIMIT  - INTEGER
C                       MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST
C                       CAN CONTAIN
C
C              LAST   - INTEGER
C                       NUMBER OF ERROR ESTIMATES CURRENTLY IN THE LIST
C
C              MAXERR - INTEGER
C                       MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR
C                       ESTIMATE CURRENTLY IN THE LIST
C
C              ERMAX  - DOUBLE PRECISION
C                       NRMAX-TH LARGEST ERROR ESTIMATE
C                       ERMAX = ELIST(MAXERR)
C
C              ELIST  - DOUBLE PRECISION
C                       VECTOR OF DIMENSION LAST CONTAINING
C                       THE ERROR ESTIMATES
C
C              IORD   - INTEGER
C                       VECTOR OF DIMENSION LAST, THE FIRST K ELEMENTS
C                       OF WHICH CONTAIN POINTERS TO THE ERROR
C                       ESTIMATES, SUCH THAT
C                       ELIST(IORD(1)),...,  ELIST(IORD(K))
C                       FORM A DECREASING SEQUENCE, WITH
C                       K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                       K = LIMIT+1-LAST OTHERWISE
C
C              NRMAX  - INTEGER
C                       MAXERR = IORD(NRMAX)
C
C***END PROLOGUE  DQPSRT
C
      DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN
      INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR,
     *  NRMAX
      DIMENSION ELIST(LAST),IORD(LAST)
C
C           CHECK WHETHER THE LIST CONTAINS MORE THAN
C           TWO ERROR ESTIMATES.
C
C***FIRST EXECUTABLE STATEMENT  DQPSRT
      IF(LAST.GT.2) GO TO 10
      IORD(1) = 1
      IORD(2) = 2
      GO TO 90
C
C           THIS PART OF THE ROUTINE IS ONLY EXECUTED IF, DUE TO A
C           DIFFICULT INTEGRAND, SUBDIVISION INCREASED THE ERROR
C           ESTIMATE. IN THE NORMAL CASE THE INSERT PROCEDURE SHOULD
C           START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE.
C
   10 ERRMAX = ELIST(MAXERR)
      IF(NRMAX.EQ.1) GO TO 30
      IDO = NRMAX-1
      DO 20 I = 1,IDO
        ISUCC = IORD(NRMAX-1)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30
        IORD(NRMAX) = ISUCC
        NRMAX = NRMAX-1
   20    CONTINUE
C
C           COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO BE MAINTAINED
C           IN DESCENDING ORDER. THIS NUMBER DEPENDS ON THE NUMBER OF
C           SUBDIVISIONS STILL ALLOWED.
C
   30 JUPBN = LAST
      IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST
      ERRMIN = ELIST(LAST)
C
C           INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN,
C           STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)).
C
      JBND = JUPBN-1
      IBEG = NRMAX+1
      IF(IBEG.GT.JBND) GO TO 50
      DO 40 I=IBEG,JBND
        ISUCC = IORD(I)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60
        IORD(I-1) = ISUCC
   40 CONTINUE
   50 IORD(JBND) = MAXERR
      IORD(JUPBN) = LAST
      GO TO 90
C
C           INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP.
C
   60 IORD(I-1) = MAXERR
      K = JBND
      DO 70 J=I,JBND
        ISUCC = IORD(K)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80
        IORD(K+1) = ISUCC
        K = K-1
   70 CONTINUE
      IORD(I) = LAST
      GO TO 90
   80 IORD(K+1) = LAST
C
C           SET MAXERR AND ERMAX.
C
   90 MAXERR = IORD(NRMAX)
      ERMAX = ELIST(MAXERR)
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL)
C
C     ABSTRACT
C        XERROR PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER
C        DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE
C        OF THE LIBRARY ERROR CONTROL FLAG, KONTRL.
C        (SEE SUBROUTINE XSETF FOR DETAILS.)
C
C     DESCRIPTION OF PARAMETERS
C      --INPUT--
C        MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED, CONTAINING
C                NO MORE THAN 72 CHARACTERS.
C        NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG.
C        NERR  - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE.
C                NERR MUST NOT BE ZERO.
C        LEVEL - ERROR CATEGORY.
C                =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR.
C                =1 MEANS THIS IS A RECOVERABLE ERROR.  (I.E., IT IS
C                   NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.)
C                =0 MEANS THIS IS A WARNING MESSAGE ONLY.
C                =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE
C                   PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY
C                   TIMES THIS CALL IS EXECUTED.
C
C     EXAMPLES
C        CALL XERROR(23HSMOOTH -- NUM WAS ZERO.,23,1,2)
C        CALL XERROR(43HINTEG  -- LESS THAN FULL ACCURACY ACHIEVED.,
C                    43,2,1)
C        CALL XERROR(65HROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL
C    1 FULLY COLLAPSED.,65,3,0)
C        CALL XERROR(39HEXP    -- UNDERFLOWS BEING SET TO ZERO.,39,1,-1)
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  7 FEB 1979
C
      DIMENSION MESSG(NMESSG)
      CALL XERRWV(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.)
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE XERRWV(MESSG,NMESSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2)
C
C     ABSTRACT
C        XERRWV PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER
C        DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE
C        OF THE LIBRARY ERROR CONTROL FLAG, KONTRL.
C        (SEE SUBROUTINE XSETF FOR DETAILS.)
C        IN ADDITION, UP TO TWO INTEGER VALUES AND TWO REAL
C        VALUES MAY BE PRINTED ALONG WITH THE MESSAGE.
C
C     DESCRIPTION OF PARAMETERS
C      --INPUT--
C        MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED.
C        NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG.
C        NERR  - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE.
C                NERR MUST NOT BE ZERO.
C        LEVEL - ERROR CATEGORY.
C                =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR.
C                =1 MEANS THIS IS A RECOVERABLE ERROR.  (I.E., IT IS
C                   NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.)
C                =0 MEANS THIS IS A WARNING MESSAGE ONLY.
C                =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE
C                   PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY
C                   TIMES THIS CALL IS EXECUTED.
C        NI    - NUMBER OF INTEGER VALUES TO BE PRINTED. (O TO 2)
C        I1    - FIRST INTEGER VALUE.
C        I2    - SECOND INTEGER VALUE.
C        NR    - NUMBER OF REAL VALUES TO BE PRINTED. (0 TO 2)
C        R1    - FIRST REAL VALUE.
C        R2    - SECOND REAL VALUE.
C
C     EXAMPLES
C        CALL XERROR(29HSMOOTH -- NUM (=I1) WAS ZERO.,29,1,2,
C    1   1,NUM,0,0,0.,0.)
C        CALL XERRWV(54HQUADXY -- REQUESTED ERROR (R1) LESS THAN MINIMUM
C    1 (R2).,54,77,1,0,0,0,2,ERRREQ,ERRMIN)
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  19 MAR 1980
C
      DIMENSION MESSG(NMESSG),LUN(5)
C     GET FLAGS
      LKNTRL = J4SAVE(2,0,.FALSE.)
      MAXMES = J4SAVE(4,0,.FALSE.)
C     CHECK FOR VALID INPUT
      IF ((NMESSG.GT.0).AND.(NERR.NE.0).AND.
     1    (LEVEL.GE.(-1)).AND.(LEVEL.LE.2)) GO TO 10
         IF (LKNTRL.GT.0) CALL XERPRT(17HFATAL ERROR IN...,17)
         CALL XERPRT(23HXERROR -- INVALID INPUT,23)
         IF (LKNTRL.GT.0) CALL FDUMP
         IF (LKNTRL.GT.0) CALL XERPRT(29HJOB ABORT DUE TO FATAL ERROR.,
     1   29)
         IF (LKNTRL.GT.0) CALL XERSAV(1H ,0,0,0,KDUMMY)
         CALL XERABT(23HXERROR -- INVALID INPUT,23)
         RETURN
   10 CONTINUE
C     RECORD MESSAGE
      JUNK = J4SAVE(1,NERR,.TRUE.)
      CALL XERSAV(MESSG,NMESSG,NERR,LEVEL,KOUNT)
C     LET USER OVERRIDE
      LFIRST = MESSG(1)
      LMESSG = NMESSG
      LERR = NERR
      LLEVEL = LEVEL
      CALL XERCTL(LFIRST,LMESSG,LERR,LLEVEL,LKNTRL)
C     RESET TO ORIGINAL VALUES
      LMESSG = NMESSG
      LERR = NERR
      LLEVEL = LEVEL
      LKNTRL = MAX0(-2,MIN0(2,LKNTRL))
      MKNTRL = IABS(LKNTRL)
C     DECIDE WHETHER TO PRINT MESSAGE
      IF ((LLEVEL.LT.2).AND.(LKNTRL.EQ.0)) GO TO 100
      IF (((LLEVEL.EQ.(-1)).AND.(KOUNT.GT.MIN0(1,MAXMES)))
     1.OR.((LLEVEL.EQ.0)   .AND.(KOUNT.GT.MAXMES))
     2.OR.((LLEVEL.EQ.1)   .AND.(KOUNT.GT.MAXMES).AND.(MKNTRL.EQ.1))
     3.OR.((LLEVEL.EQ.2)   .AND.(KOUNT.GT.MAX0(1,MAXMES)))) GO TO 100
         IF (LKNTRL.LE.0) GO TO 20
            CALL XERPRT(1H ,1)
C           INTRODUCTION
            IF (LLEVEL.EQ.(-1)) CALL XERPRT
     1(57HWARNING MESSAGE...THIS MESSAGE WILL ONLY BE PRINTED ONCE.,57)
            IF (LLEVEL.EQ.0) CALL XERPRT(13HWARNING IN...,13)
            IF (LLEVEL.EQ.1) CALL XERPRT
     1      (23HRECOVERABLE ERROR IN...,23)
            IF (LLEVEL.EQ.2) CALL XERPRT(17HFATAL ERROR IN...,17)
   20    CONTINUE
C        MESSAGE
         CALL XERPRT(MESSG,LMESSG)
         CALL XGETUA(LUN,NUNIT)
         DO 50 KUNIT=1,NUNIT
            IUNIT = LUN(KUNIT)
            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
            IF (NI.GE.1) WRITE (IUNIT,22) I1
            IF (NI.GE.2) WRITE (IUNIT,23) I2
            IF (NR.GE.1) WRITE (IUNIT,24) R1
            IF (NR.GE.2) WRITE (IUNIT,25) R2
   22       FORMAT (11X,21HIN ABOVE MESSAGE, I1=,I10)
   23       FORMAT (11X,21HIN ABOVE MESSAGE, I2=,I10)
   24       FORMAT (11X,21HIN ABOVE MESSAGE, R1=,E20.10)
   25       FORMAT (11X,21HIN ABOVE MESSAGE, R2=,E20.10)
            IF (LKNTRL.LE.0) GO TO 40
C              ERROR NUMBER
               WRITE (IUNIT,30) LERR
   30          FORMAT (15H ERROR NUMBER =,I10)
   40       CONTINUE
   50    CONTINUE
C        TRACE-BACK
         IF (LKNTRL.GT.0) CALL FDUMP
  100 CONTINUE
      IFATAL = 0
      IF ((LLEVEL.EQ.2).OR.((LLEVEL.EQ.1).AND.(MKNTRL.EQ.2)))
     1IFATAL = 1
C     QUIT HERE IF MESSAGE IS NOT FATAL
      IF (IFATAL.LE.0) RETURN
      IF ((LKNTRL.LE.0).OR.(KOUNT.GT.MAX0(1,MAXMES))) GO TO 120
C        PRINT REASON FOR ABORT
         IF (LLEVEL.EQ.1) CALL XERPRT
     1   (35HJOB ABORT DUE TO UNRECOVERED ERROR.,35)
         IF (LLEVEL.EQ.2) CALL XERPRT
     1   (29HJOB ABORT DUE TO FATAL ERROR.,29)
C        PRINT ERROR SUMMARY
         CALL XERSAV(1H ,-1,0,0,KDUMMY)
  120 CONTINUE
C     ABORT
      IF ((LLEVEL.EQ.2).AND.(KOUNT.GT.MAX0(1,MAXMES))) LMESSG = 0
      CALL XERABT(MESSG,LMESSG)
      RETURN
      END



C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE XERPRT(MESSG,NMESSG)
C
C     ABSTRACT
C        PRINT THE HOLLERITH MESSAGE IN MESSG, OF LENGTH MESSG,
C        ON EACH FILE INDICATED BY XGETUA.
C        THIS VERSION PRINTS EXACTLY THE RIGHT NUMBER OF CHARACTERS,
C        NOT A NUMBER OF WORDS, AND THUS SHOULD WORK ON MACHINES
C        WHICH DO NOT BLANK FILL THE LAST WORD OF THE HOLLERITH.
C
C     RON JONES, JUNE 1980
C
      INTEGER F(10),G(14),LUN(5)
      DIMENSION MESSG(NMESSG)
      DATA F(1),F(2),F(3),F(4),F(5),F(6),F(7),F(8),F(9),F(10)
     1   / 1H( ,1H1 ,1HX ,1H, ,1H  ,1H  ,1HA ,1H  ,1H  ,1H) /
      DATA G(1),G(2),G(3),G(4),G(5),G(6),G(7),G(8),G(9),G(10)
     1   / 1H( ,1H1 ,1HX ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  ,1H  /
      DATA G(11),G(12),G(13),G(14)
     1   / 1H   ,1H   ,1H   ,1H)  /
      DATA LA/1HA/,LCOM/1H,/,LBLANK/1H /
C     PREPARE FORMAT FOR WHOLE LINES
      NCHAR = I1MACH(6)
      NFIELD = 72/NCHAR
      CALL S88FMT(2,NFIELD,F(5))
      CALL S88FMT(2,NCHAR,F(8))
C     PREPARE FORMAT FOR LAST, PARTIAL LINE, IF NEEDED
      NCHARL = NFIELD*NCHAR
      NLINES = NMESSG/NCHARL
      NWORD  = NLINES*NFIELD
      NCHREM = NMESSG - NLINES*NCHARL
      IF (NCHREM.LE.0) GO TO 40
         DO 10 I=4,13
10          G(I) = LBLANK
         NFIELD = NCHREM/NCHAR
         IF (NFIELD.LE.0) GO TO 20
C        PREPARE WHOLE WORD FIELDS
            G(4) = LCOM
            CALL S88FMT(2,NFIELD,G(5))
            G(7) = LA
            CALL S88FMT(2,NCHAR,G(8))
20       CONTINUE
         NCHLST = MOD(NCHREM,NCHAR)
         IF (NCHLST.LE.0) GO TO 30
C        PREPARE PARTIAL WORD FIELD
            G(10) = LCOM
            G(11) = LA
            CALL S88FMT(2,NCHLST,G(12))
30       CONTINUE
40    CONTINUE
C     PRINT THE MESSAGE
      NWORD1 = NWORD+1
      NWORD2 = (NMESSG+NCHAR-1)/NCHAR
      CALL XGETUA(LUN,NUNIT)
      DO 50 KUNIT = 1,NUNIT
         IUNIT = LUN(KUNIT)
         IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
         IF (NWORD.GT.0) WRITE (IUNIT,F) (MESSG(I),I=1,NWORD)
         IF (NCHREM.GT.0) WRITE (IUNIT,G) (MESSG(I),I=NWORD1,NWORD2)
50    CONTINUE
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT)
C
C     ABSTRACT
C        RECORD THAT THIS ERROR OCCURRED.
C
C     DESCRIPTION OF PARAMETERS
C     --INPUT--
C       MESSG, NMESSG, NERR, LEVEL ARE AS IN XERROR,
C       EXCEPT THAT WHEN NMESSG=0 THE TABLES WILL BE
C       DUMPED AND CLEARED, AND WHEN NMESSG IS LESS THAN ZERO THE
C       TABLES WILL BE DUMPED AND NOT CLEARED.
C     --OUTPUT--
C       ICOUNT WILL BE THE NUMBER OF TIMES THIS MESSAGE HAS
C       BEEN SEEN, OR ZERO IF THE TABLE HAS OVERFLOWED AND
C       DOES NOT CONTAIN THIS MESSAGE SPECIFICALLY.
C       WHEN NMESSG=0, ICOUNT WILL NOT BE ALTERED.
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  19 MAR 1980
C
      INTEGER F(17),LUN(5)
      DIMENSION MESSG(NMESSG)
      DIMENSION MESTAB(10),NERTAB(10),LEVTAB(10),KOUNT(10)
C     NEXT THREE DATA STATEMENTS ARE NEEDED MERELY TO SATISFY
C     CERTAIN CONVENTIONS FOR COMPILERS WHICH DYNAMICALLY
C     ALLOCATE STORAGE.
      DATA MESTAB(1),MESTAB(2),MESTAB(3),MESTAB(4),MESTAB(5),
     1     MESTAB(6),MESTAB(7),MESTAB(8),MESTAB(9),MESTAB(10)
     2     /0,0,0,0,0,0,0,0,0,0/
      DATA NERTAB(1),NERTAB(2),NERTAB(3),NERTAB(4),NERTAB(5),
     1     NERTAB(6),NERTAB(7),NERTAB(8),NERTAB(9),NERTAB(10)
     2     /0,0,0,0,0,0,0,0,0,0/
      DATA LEVTAB(1),LEVTAB(2),LEVTAB(3),LEVTAB(4),LEVTAB(5),
     1     LEVTAB(6),LEVTAB(7),LEVTAB(8),LEVTAB(9),LEVTAB(10)
     2     /0,0,0,0,0,0,0,0,0,0/
C     NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK
C     ERROR TABLE INITIALLY
      DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5),
     1     KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10)
     2     /0,0,0,0,0,0,0,0,0,0/
      DATA KOUNTX/0/
C     NEXT DATA STATEMENT SETS UP OUTPUT FORMAT
      DATA F(1),F(2),F(3),F(4),F(5),F(6),F(7),F(8),F(9),F(10),
     1     F(11),F(12),F(13),F(14),F(15),F(16),F(17)
     2     /1H( ,1H1 ,1HX ,1H, ,1HA ,1H  ,1H  ,1H, ,1HI ,1H  ,
     3      1H  ,1H, ,1H2 ,1HI ,1H1 ,1H0 ,1H) /
      IF (NMESSG.GT.0) GO TO 80
C     DUMP THE TABLE
         IF (KOUNT(1).EQ.0) RETURN
C        PREPARE FORMAT
         NCHAR = I1MACH(6)
         CALL S88FMT(2,NCHAR,F(6))
         NCOL = 20 - NCHAR
         CALL S88FMT(2,NCOL,F(10))
C        PRINT TO EACH UNIT
         CALL XGETUA(LUN,NUNIT)
         DO 60 KUNIT=1,NUNIT
            IUNIT = LUN(KUNIT)
            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
C           PRINT TABLE HEADER
            WRITE (IUNIT,10)
   10       FORMAT (32H0          ERROR MESSAGE SUMMARY/
     1              41H FIRST WORD      NERR     LEVEL     COUNT)
C           PRINT BODY OF TABLE
            DO 20 I=1,10
               IF (KOUNT(I).EQ.0) GO TO 30
               WRITE (IUNIT,F) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I)
   20       CONTINUE
   30       CONTINUE
C           PRINT NUMBER OF OTHER ERRORS
            IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX
   40       FORMAT (41H0OTHER ERRORS NOT INDIVIDUALLY TABULATED=,I10)
            WRITE (IUNIT,50)
   50       FORMAT (1X)
   60    CONTINUE
         IF (NMESSG.LT.0) RETURN
C        CLEAR THE ERROR TABLES
         DO 70 I=1,10
   70       KOUNT(I) = 0
         KOUNTX = 0
         RETURN
   80 CONTINUE
C     PROCESS A MESSAGE...
C     SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
C     OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
      DO 90 I=1,10
         II = I
         IF (KOUNT(I).EQ.0) GO TO 110
         IF (MESSG(1).NE.MESTAB(I)) GO TO 90
         IF (NERR.NE.NERTAB(I)) GO TO 90
         IF (LEVEL.NE.LEVTAB(I)) GO TO 90
         GO TO 100
   90 CONTINUE
C     THREE POSSIBLE CASES...
C     TABLE IS FULL
         KOUNTX = KOUNTX+1
         ICOUNT = 1
         RETURN
C     MESSAGE FOUND IN TABLE
  100    KOUNT(II) = KOUNT(II) + 1
         ICOUNT = KOUNT(II)
         RETURN
C     EMPTY SLOT FOUND FOR NEW MESSAGE
  110    MESTAB(II) = MESSG(1)
         NERTAB(II) = NERR
         LEVTAB(II) = LEVEL
         KOUNT(II)  = 1
         ICOUNT = 1
         RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE XERABT(MESSG,NMESSG)
C***BEGIN PROLOGUE  XERABT
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  ABORTS PROGRAM EXECUTION AND PRINTS ERROR MESSAGE.
C***DESCRIPTION
C     ABSTRACT
C        ***NOTE*** MACHINE DEPENDENT ROUTINE
C        XERABT ABORTS THE EXECUTION OF THE PROGRAM.
C        THE ERROR MESSAGE CAUSING THE ABORT IS GIVEN IN THE CALLING
C        SEQUENCE, IN CASE ONE NEEDS IT FOR PRINTING ON A DAYFILE,
C        FOR EXAMPLE.
C
C     DESCRIPTION OF PARAMETERS
C        MESSG AND NMESSG ARE AS IN XERROR, EXCEPT THAT NMESSG MAY
C        BE ZERO, IN WHICH CASE NO MESSAGE IS BEING SUPPLIED.
C
C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
C     LATEST REVISION ---  19 MAR 1980
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  XERABT
      CHARACTER*(*) MESSG
C***FIRST EXECUTABLE STATEMENT  XERABT
	IF(NMESSG.NE.0) THEN
		WRITE(I1MACH(4),100)MESSG
100		FORMAT(' XERABT:',A)
	ENDIF
      STOP
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE XERCTL(MESSG1,NMESSG,NERR,LEVEL,KONTRL)
C***BEGIN PROLOGUE  XERCTL
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  ALLOWS USER CONTROL OVER HANDLING OF INDIVIDUAL ERRORS.
C***DESCRIPTION
C     ABSTRACT
C        ALLOWS USER CONTROL OVER HANDLING OF INDIVIDUAL ERRORS.
C        JUST AFTER EACH MESSAGE IS RECORDED, BUT BEFORE IT IS
C        PROCESSED ANY FURTHER (I.E., BEFORE IT IS PRINTED OR
C        A DECISION TO ABORT IS MADE), A CALL IS MADE TO XERCTL.
C        IF THE USER HAS PROVIDED HIS OWN VERSION OF XERCTL, HE
C        CAN THEN OVERRIDE THE VALUE OF KONTROL USED IN PROCESSING
C        THIS MESSAGE BY REDEFINING ITS VALUE.
C        KONTRL MAY BE SET TO ANY VALUE FROM -2 TO 2.
C        THE MEANINGS FOR KONTRL ARE THE SAME AS IN XSETF, EXCEPT
C        THAT THE VALUE OF KONTRL CHANGES ONLY FOR THIS MESSAGE.
C        IF KONTRL IS SET TO A VALUE OUTSIDE THE RANGE FROM -2 TO 2,
C        IT WILL BE MOVED BACK INTO THAT RANGE.
C
C     DESCRIPTION OF PARAMETERS
C
C      --INPUT--
C        MESSG1 - THE FIRST WORD (ONLY) OF THE ERROR MESSAGE.
C        NMESSG - SAME AS IN THE CALL TO XERROR OR XERRWV.
C        NERR   - SAME AS IN THE CALL TO XERROR OR XERRWV.
C        LEVEL  - SAME AS IN THE CALL TO XERROR OR XERRWV.
C        KONTRL - THE CURRENT VALUE OF THE CONTROL FLAG AS SET
C                 BY A CALL TO XSETF.
C
C      --OUTPUT--
C        KONTRL - THE NEW VALUE OF KONTRL.  IF KONTRL IS NOT
C                 DEFINED, IT WILL REMAIN AT ITS ORIGINAL VALUE.
C                 THIS CHANGED VALUE OF CONTROL AFFECTS ONLY
C                 THE CURRENT OCCURRENCE OF THE CURRENT MESSAGE.
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  XERCTL
      CHARACTER*20 MESSG1
C***FIRST EXECUTABLE STATEMENT  XERCTL
      RETURN
      END

C==================================================================================
C==================================================================================
C==================================================================================
C================================================================================== 

      SUBROUTINE S88FMT(N,IVALUE,IFMT)
C
C     ABSTRACT
C        S88FMT REPLACES IFMT(1), ... ,IFMT(N) WITH THE
C        CHARACTERS CORRESPONDING TO THE N LEAST SIGNIFICANT
C        DIGITS OF IVALUE.
C
C     TAKEN FROM THE BELL LABORATORIES PORT LIBRARY ERROR HANDLER
C     LATEST REVISION ---  7 JUNE 1978
C
      DIMENSION IFMT(N),IDIGIT(10)
      DATA IDIGIT(1),IDIGIT(2),IDIGIT(3),IDIGIT(4),IDIGIT(5),
     1     IDIGIT(6),IDIGIT(7),IDIGIT(8),IDIGIT(9),IDIGIT(10)
     2     /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
      NT = N
      IT = IVALUE
   10    IF (NT .EQ. 0) RETURN
         INDEX = MOD(IT,10)
         IFMT(NT) = IDIGIT(INDEX+1)
         IT = IT/10
         NT = NT - 1
         GO TO 10
      END