!
!=======================================================================
!
MODULE INTEGRATION5
!
!  This module contains Gauss quadrature routines in order to integrate 
!    a function F over the interval [A,B]. 
!
!  These routines are:
!
!        * SUBROUTINE GAUSSQ(KIND,N,ALPHA,BETA,KPTS,ENDPTS,B,T,W)
!
      USE ACCURACY_REAL
!
CONTAINS
!
!=======================================================================
!
      SUBROUTINE GAUSSQ(KIND,N,ALPHA,BETA,KPTS,ENDPTS,B,T,W)
!
!    This set of routines computes the nodes T(J) and weights
!        W(J) for Gaussian-type quadrature rules with pre-assigned
!        nodes.  these are used when one wishes to approximate
!
!                 integral (from a to b)  f(x) w(x) dx
!
!                              n
!        by                   sum w  f(t )
!                             j=1  j    j
!
!        (note w(x) and W(J) have no connection with each other.)
!        here w(x) is one of six possible non-negative weight
!        functions (listed below), and f(x) is the
!        function to be integrated.  Gaussian quadrature is particularly
!        useful on infinite intervals (with appropriate weight
!        functions), since then other techniques often fail.
!
!           Associated with each weight function w(x) is a set of
!        orthogonal polynomials.  The nodes T(J) are just the zeroes
!        of the proper n-th degree polynomial.
!
    !     input parameters (all real numbers are in double precision)
!
!        KIND     an integer between 1 and 6 giving the type of
!                 quadrature rule:
!
!        KIND = 1:  Legendre quadrature, w(x) = 1 on (-1, 1)
!
!        KIND = 2:  Chebyshev quadrature of the first kind
!                   w(x) = 1/sqrt(1 - x*x) on (-1, +1)
!
!        KIND = 3:  Chebyshev quadrature of the second kind
!                   w(x) = sqrt(1 - x*x) on (-1, 1)
!
!        KIND = 4:  Hermite quadrature, w(x) = exp(-x*x) on
!                   (-infinity, +infinity)
!
!        KIND = 5:  Jacobi quadrature, w(x) = (1-x)**ALPHA * (1+x)**
!                   BETA on (-1, 1), ALPHA, BETA .GT. -1.
!                   note: KIND=2 and 3 are a special case of this.
!
!        KIND = 6:  generalized Laguerre quadrature, w(x) = exp(-x)*
!                   x**ALPHA on (0, +infinity), ALPHA .GT. -1
!
!        N        the number of points used for the quadrature rule
!        ALPHA    real parameter used only for Gauss-Jacobi and Gauss-
!                 Laguerre quadrature (otherwise use 0.d0).
!        BETA     real parameter used only for Gauss-Jacobi quadrature--
!                 (otherwise use 0.d0)
!        KPTS     (integer) normally 0, unless the left or right end-
!                 point (or both) of the interval is required to be a
!                 node (this is called gauss-radau or Gauss-Lobatto
!                 quadrature). Then KPTS is the number of fixed
!                 endpoints (1 or 2).
!        ENDPTS   real array of length 2.  Contains the values of
!                 any fixed endpoints, if KPTS = 1 or 2.
!        B        real scratch array of length N
!
!     Output parameters (both double precision arrays of length N)
!
!        T        will contain the desired nodes.
!        W        will contain the desired weights W(J).
!
!     Underflow may sometimes occur, but is harmless.
!
!     References
!        1.  Golub, G. H., and Welsch, J. H., "Calculation of Gaussian
!            quadrature rules," Mathematics of Computation 23 (April,
!            1969), pp. 221-230.
!        2.  Golub, G. H., "Some modified matrix eigenvalue problems,"
!            SIAM Review 15 (April, 1973), pp. 318-334 (section 7).
!        3.  Stroud and Secrest, Gaussian Quadrature Formulas, Prentice-
!            Hall, Englewood Cliffs, N.J., 1966.
!
!        Original version 20 Jan 1975 from Stanford
!        Modified 21 Dec 1983 by Eric Grosse
!          IMTQL2 => GAUSQ2
!          hex constant => D1MACH (from core library)
!          compute pi using datan
!          removed accuracy claims, description of method
!          added single precision version
!
!                                    Last modified (DS) :  7 Aug 2020
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE
      USE SPECFUNC_SLATEC,  ONLY : DGAMMA
!
      IMPLICIT NONE
!
      REAL (WP)             ::  B(N),T(N),W(N)
      REAL (WP)             ::  ENDPTS(2),MUZERO,T1,GAM,ALPHA,BETA
!
      REAL (WP)             ::  DSQRT
!
      INTEGER               ::  KIND,KPTS
      INTEGER               ::  N,I,IERR
!
      CALL CLASS(KIND,N,ALPHA,BETA,B,T,MUZERO)                      !
!
!           The matrix of coefficients is assumed to be symmetric.
!           The array T contains the diagonal elements, the array
!           B the off-diagonal elements.
!           Make appropriate changes in the lower right 2 by 2
!           submatrix.
!
      IF (KPTS == 0)  GO TO 100                                     !
      IF (KPTS == 2)  GO TO  50                                     !
!
!           if KPTS=1, only T(N) must be changed
!
      T(N) = SOLVE(ENDPTS(1),N,T,B)*B(N-1)**2 + ENDPTS(1)           !
      GO TO 100                                                     !
!
!           if KPTS=2, T(N) and B(N-1) must be recomputed
!
   50 GAM = SOLVE(ENDPTS(1),N,T,B)                                  !
      T1 = ((ENDPTS(1) - ENDPTS(2))/(SOLVE(ENDPTS(2),N,T,B) - GAM)) !
      B(N-1) = DSQRT(T1)                                            !
      T(N) = ENDPTS(1) + GAM*T1                                     !
!
!           Note that the indices of the elements of B run from 1 to n-1
!           and thus the value of B(N) is arbitrary.
!           Now compute the eigenvalues of the symmetric tridiagonal
!           matrix, which has been modified as necessary.
!           the method used is a ql-type method with origin shifting
!
  100 W(1) = ONE                                                    !
!
      DO I=2,N                                                      !
         W(I) = ZERO                                                !
      END DO                                                        !
!
      CALL GAUSQ2(N,T,B,W,IERR)                                     !
!
      DO I=1,N                                                      !
         W(I) = MUZERO * W(I) * W(I)                                !
      END DO                                                        !
!
      END SUBROUTINE GAUSSQ
!
!=======================================================================
!
      FUNCTION SOLVE(SHIFT,N,A,B)
!
!       This procedure performs elimination to solve for the
!       n-th component of the solution delta to the equation
!
!             (jn - shift*identity) * delta  = en,
!
!       where en is the vector of all zeroes except for 1 in
!       the n-th position.
!
!       The matrix jn is symmetric tridiagonal, with diagonal
!       elements A(I), off-diagonal elements B(I).  This equation
!       must be solved to obtain the appropriate changes in the lower
!       2 by 2 submatrix of coefficients for orthogonal polynomials.
!
!                                    Last modified (DS) :  7 Aug 2020
!
      USE REAL_NUMBERS,     ONLY : ONE
!
      IMPLICIT NONE
!
      REAL (WP)             ::  SOLVE
      REAL (WP)             ::  SHIFT,A(N),B(N),ALPHA
!
      INTEGER               ::  N,NM1,I
!
      ALPHA = A(1) - SHIFT                                          !
      NM1   = N - 1                                                 !
!
      DO I=2,NM1                                                    !
         ALPHA = A(I) - SHIFT - B(I-1)**2/ALPHA                     !
      END DO                                                        !
      SOLVE = ONE/ALPHA                                             !
!
      END FUNCTION SOLVE
!
!=======================================================================
!
      SUBROUTINE CLASS(KIND,N,ALPHA,BETA,B,A,MUZERO)
!
!      This procedure supplies the coefficients A(J), B(J) of the
!        recurrence relation
!
!             b p (x) = (x - a ) p   (x) - b   p   (x)
!              j j            j   j-1       j-1 j-2
!
!        for the various classical (normalized) orthogonal polynomials,
!        and the zero-th moment
!
!             muzero = integral w(x) dx
!
!        of the given polynomial's weight function w(x).  Since the
!        polynomials are orthonormalized, the tridiagonal matrix is
!        guaranteed to be symmetric.
!
!      The input parameter ALPHA is used only for Laguerre and
!        Jacobi polynomials, and the parameter BETA is used only for
!        Jacobi polynomials.  The Laguerre and Jacobi polynomials
!        require the Gamma function.
!
!                                    Last modified (DS) :  4 Jun 2020
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO,FOUR,  &
                                   HALF
!
      IMPLICIT NONE
!
      REAL (WP)             ::  A(N),B(N)
      REAL (WP)             ::  MUZERO,ALPHA,BETA
      REAL (WP)             ::  ABI,A2B2,DGAMMA,PI,AB
!
      REAL (WP)             ::  DATAN,DFLOAT,DSQRT
!
      INTEGER               ::  KIND,N
      INTEGER               ::  NM1,I
!
      PI  = FOUR * DATAN(ONE)                                       !
      NM1 = N - 1                                                   !
!
      IF(KIND == 1)  THEN                                           !
!
!              KIND = 1:  Legendre polynomials p(x)
!              on (-1, +1), w(x) = 1.
!
        MUZERO = TWO                                                !
        DO I=1,NM1                                                  !
          A(I) = ZERO                                               !
          ABI  = DFLOAT(I)                                          !
          B(I) = ABI/DSQRT(FOUR*ABI*ABI - ONE)
        END DO                                                      !
        A(N)  = ZERO                                                !
        RETURN                                                      !
!
      ELSE IF(KIND == 2)  THEN                                      !
!
!              KIND = 2:  Chebyshev polynomials of the first kind t(x)
!              on (-1, +1), w(x) = 1 / sqrt(1 - x*x)
!
        MUZERO = PI                                                 !
!
        DO I=1,NM1                                                  !
          A(I) = ZERO                                               !
          B(I) = HALF                                               !
        END DO                                                      !
!
        B(1)   = DSQRT(HALF)                                        !
        A(N)   = ZERO                                               !
!
        RETURN                                                      !
!
      ELSE IF(KIND == 3)  THEN                                      !
!
!              KIND = 3:  Chebyshev polynomials of the second kind u(x)
!              on (-1, +1), w(x) = sqrt(1 - x*x)
!
        MUZERO = PI/TWO                                             !
!
        DO I=1,NM1                                                  !
          A(I) = ZERO                                               !
          B(I) = HALF                                               !
        END DO                                                      !
!
        A(N)   = ZERO                                               !
!
        RETURN                                                      !
!
      ELSE IF(KIND == 4)  THEN                                      !
!
!              KIND = 4:  Hermite polynomials h(x) on (-infinity,
!              +infinity), w(x) = exp(-x**2)
!
        MUZERO = DSQRT(PI)                                          !
!
        DO I=1,NM1                                                  !
          A(I) = ZERO                                               !
          B(I) = DSQRT( DFLOAT(I)/TWO )                             !
        END DO                                                      !
!
        A(N)   = ZERO                                               !
!
        RETURN                                                      !
!
      ELSE IF(KIND == 5)  THEN                                      !
!
!              KIND = 5:  Jacobi polynomials p(alpha, beta)(x) on
!              (-1, +1), w(x) = (1-x)**alpha + (1+x)**beta, alpha and
!              beta greater than -1
!
        AB     = ALPHA + BETA                                       !
        ABI    = TWO + AB                                           !
        MUZERO = TWO ** (AB + ONE) * DGAMMA(ALPHA + ONE) *        & !
                 DGAMMA(BETA + ONE) / DGAMMA(ABI)                   !
        A(1)   = (BETA - ALPHA) / ABI                               !
        B(1)   = DSQRT( FOUR*(ONE + ALPHA)*(ONE + BETA) /         & !
                        ((ABI + ONE)* ABI*ABI)                    & !
                      )                                             !
        A2B2   = BETA*BETA - ALPHA*ALPHA                            !
!
        DO I=2,NM1                                                  !
          ABI  = TWO*I + AB                                         !
          A(I) = A2B2/((ABI - TWO)*ABI)                             !
          B(I) = DSQRT( FOUR*DFLOAT(I)*(DFLOAT(I) + ALPHA) *      & !
                        (DFLOAT(I) + BETA)*(DFLOAT(I) + AB) /     & !
                        ((ABI*ABI - ONE)*ABI*ABI)                 & !
                      )                                             !
        END DO                                                      !
!
        ABI    = TWO*N + AB                                         !
        A(N)   = A2B2/((ABI - TWO)*ABI)                             !
!
        RETURN                                                      !
!
      ELSE IF(KIND == 6)  THEN                                      !
!
!              KIND = 6:  Laguerre polynomials l(alpha)(x) on
!              (0, +infinity), w(x) = exp(-x) * x**alpha, alpha greater
!              than -1.
!
        MUZERO = DGAMMA(ALPHA + ONE)                                !
!
        DO I = 1, NM1                                               !
          A(I) = TWO*DFLOAT(I) - ONE + ALPHA                        !
          B(I) = DSQRT( DFLOAT(I)*(DFLOAT(I) + ALPHA) )             !
        END DO                                                      !
!
        A(N)   = TWO*DFLOAT(N) - ONE + ALPHA                        !
!
        RETURN                                                      !
!
      END IF                                                        !
!
      END SUBROUTINE CLASS
!
!=======================================================================
!
      SUBROUTINE GAUSQ2(N,D,E,Z,IERR)
!
!   This subroutine is a translation of an Algol procedure,
!     Num. Math. 12, 377-383(1968) by Martin and Wilkinson,
!     as modified in Num. Math. 15, 450(1970) by Dubrulle.
!   Handbook for Auto. Comp., vol.ii-Linear Algebra, 241-248(1971).
!   This is a modified version of the 'EISPACK' routine IMTQL2.
!
!   This subroutine finds the eigenvalues and first components of the
!     eigenvectors of a symmetric tridiagonal matrix by the implicit ql
!     method.
!
!   On input:
!
!        N is the order of the matrix;
!
!        D contains the diagonal elements of the input matrix;
!
!        E contains the subdiagonal elements of the input matrix
!          in its first N-1 positions.  E(N) is arbitrary;
!
!        Z contains the first row of the identity matrix.
!
!    On output:
!
!        D contains the eigenvalues in ascending order.  If an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1, 2, ..., ierr-1;
!
!        E has been destroyed;
!
!        Z contains the first components of the orthonormal eigenvectors
!          of the symmetric tridiagonal matrix.  If an error exit is
!          made, Z contains the eigenvectors associated with the stored
!          eigenvalues;
!
!        IERR is set to
!          ZERO       for normal return,
!          J          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     ------------------------------------------------------------------
!
!                                    Last modified (DS) : 11 Aug 2020
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO
      USE MACHINE_ACCURACY, ONLY : D1MACH
!
      IMPLICIT NONE
!
      REAL (WP)             ::  D(N),E(N),Z(N)
      REAL (WP)             ::  B,C,F,G,P,R,S,MACHEP
!
      REAL (WP)             ::  DSQRT,DABS,DSIGN
!
      INTEGER               ::  I,J,K,L,M,N,II,MML,IERR
!
      MACHEP=D1MACH(4)                                              !
!
      IERR = 0                                                      !
      IF(N == 1) GO TO 1001                                         !
!
      E(N) = ZERO                                                   !
      DO L=1,N                                                      !
!
         J = 0                                                      !
!
!     :::::::::: look for small sub-diagonal element ::::::::::
!
  105    DO M=L,N                                                   !              
            IF(M  ==  N) GO TO 120                                  !
            IF( DABS(E(M)) <= MACHEP * (DABS(D(M)) + DABS(D(M+1)))& !
              ) GO TO 120                                           !
         END DO                                                     !
!
  120    P = D(L)                                                   !
         IF(M == L)  GO TO 240                                      !
         IF(J == 30) GO TO 1000                                     !
         J = J + 1
!
!     :::::::::: form shift ::::::::::
!
         G = (D(L+1) - P) / (TWO * E(L))                            !
         R = DSQRT(G*G+ONE)                                         !
         G = D(M) - P + E(L) / (G + DSIGN(R,G))                     !
         S = ONE                                                    !
         C = ONE                                                    !
         P = ZERO                                                   !
         MML = M - L                                                !
!
!     :::::::::: for i=m-1 step -1 until l do -- ::::::::::
!
         DO II=1,MML
            I      = M - II                                         !
            F      = S * E(I)                                       !
            B      = C * E(I)                                       !
!
            IF(DABS(F) < DABS(G)) GO TO 150                         !
!
            C      = G / F                                          !
            R      = DSQRT(C*C+ONE)                                 !
            E(I+1) = F * R                                          !
            S      = ONE / R                                        !
            C      = C * S                                          !
            GO TO 160                                               !
!
  150       S      = F / G                                          !
            R      = DSQRT(S*S+ONE)                                 !
            E(I+1) = G * R                                          !
            C      = ONE / R                                        !
            S      = S * C                                          !
!
  160       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                                      !
!
!     :::::::::: form first component of vector ::::::::::
!
            F      = Z(I+1)                                         !
            Z(I+1) = S * Z(I) + C * F                               !
            Z(I)   = C * Z(I) - S * F                               !
!
         END DO                                                     !
!
         D(L) = D(L) - P                                            !                                         !
         E(L) = G                                                   !
         E(M) = ZERO                                                !
         GO TO 105                                                  !
!
  240    CONTINUE                                                   !
!
      END DO                                                        !
!
!     :::::::::: order eigenvalues and eigenvectors ::::::::::
!
      DO II=2,N                                                     !
!
         I = II - 1                                                 !
         K = I                                                      !
         P = D(I)                                                   !
!
         DO J=II,N                                                  !
            IF (D(J) >= P) GO TO 260                                !
            K = J                                                   !
            P = D(J)                                                !
  260       CONTINUE                                                !
         END DO                                                     !
!
         IF(K == I) GO TO 300                                       !
         D(K) = D(I)                                                !
         D(I) = P                                                   !
         P    = Z(I)                                                !
         Z(I) = Z(K)                                                !
         Z(K) = P                                                   !
!
  300    CONTINUE                                                   !
!
      END DO                                                        !
!
      GO TO 1001                                                    !
!
!     :::::::::: set error -- no convergence to an
!                eigenvalue after 30 iterations ::::::::::
!
 1000 IERR = L                                                      !
 1001 RETURN                                                        !
!
!     :::::::::: last card of GAUSQ2 ::::::::::
!
      END SUBROUTINE GAUSQ2
!
END MODULE INTEGRATION5
