*> \brief \b DGSVTS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
*                          LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
*                          LWORK, RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P
*       ..
*       .. Array Arguments ..
*       INTEGER            IWORK( * )
*       DOUBLE PRECISION   A( LDA, * ), AF( LDA, * ), ALPHA( * ),
*      $                   B( LDB, * ), BETA( * ), BF( LDB, * ),
*      $                   Q( LDQ, * ), R( LDR, * ), RESULT( 6 ),
*      $                   RWORK( * ), U( LDU, * ), V( LDV, * ),
*      $                   WORK( LWORK )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGSVTS tests DGGSVD, which computes the GSVD of an M-by-N matrix A
*> and a P-by-N matrix B:
*>              U'*A*Q = D1*R and V'*B*Q = D2*R.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is INTEGER
*>          The number of rows of the matrix B.  P >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrices A and B.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,M)
*>          The M-by-N matrix A.
*> \endverbatim
*>
*> \param[out] AF
*> \verbatim
*>          AF is DOUBLE PRECISION array, dimension (LDA,N)
*>          Details of the GSVD of A and B, as returned by DGGSVD,
*>          see DGGSVD for further details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the arrays A and AF.
*>          LDA >= max( 1,M ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,P)
*>          On entry, the P-by-N matrix B.
*> \endverbatim
*>
*> \param[out] BF
*> \verbatim
*>          BF is DOUBLE PRECISION array, dimension (LDB,N)
*>          Details of the GSVD of A and B, as returned by DGGSVD,
*>          see DGGSVD for further details.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the arrays B and BF.
*>          LDB >= max(1,P).
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*>          U is DOUBLE PRECISION array, dimension(LDU,M)
*>          The M by M orthogonal matrix U.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U. LDU >= max(1,M).
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*>          V is DOUBLE PRECISION array, dimension(LDV,M)
*>          The P by P orthogonal matrix V.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*>          LDV is INTEGER
*>          The leading dimension of the array V. LDV >= max(1,P).
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is DOUBLE PRECISION array, dimension(LDQ,N)
*>          The N by N orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*>          LDQ is INTEGER
*>          The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[out] ALPHA
*> \verbatim
*>          ALPHA is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*>          BETA is DOUBLE PRECISION array, dimension (N)
*>
*>          The generalized singular value pairs of A and B, the
*>          ``diagonal'' matrices D1 and D2 are constructed from
*>          ALPHA and BETA, see subroutine DGGSVD for details.
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*>          R is DOUBLE PRECISION array, dimension(LDQ,N)
*>          The upper triangular matrix R.
*> \endverbatim
*>
*> \param[in] LDR
*> \verbatim
*>          LDR is INTEGER
*>          The leading dimension of the array R. LDR >= max(1,N).
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK,
*>          LWORK >= max(M,P,N)*max(M,P,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (max(M,P,N))
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION array, dimension (6)
*>          The test ratios:
*>          RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP)
*>          RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP)
*>          RESULT(3) = norm( I - U'*U ) / ( M*ULP )
*>          RESULT(4) = norm( I - V'*V ) / ( P*ULP )
*>          RESULT(5) = norm( I - Q'*Q ) / ( N*ULP )
*>          RESULT(6) = 0        if ALPHA is in decreasing order;
*>                    = ULPINV   otherwise.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
     $                   LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
     $                   LWORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDA, * ), ALPHA( * ),
     $                   B( LDB, * ), BETA( * ), BF( LDB, * ),
     $                   Q( LDQ, * ), R( LDR, * ), RESULT( 6 ),
     $                   RWORK( * ), U( LDU, * ), V( LDV, * ),
     $                   WORK( LWORK )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, J, K, L
      DOUBLE PRECISION   ANORM, BNORM, RESID, TEMP, ULP, ULPINV, UNFL
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANSY
      EXTERNAL           DLAMCH, DLANGE, DLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGGSVD, DLACPY, DLASET, DSYRK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      ULP = DLAMCH( 'Precision' )
      ULPINV = ONE / ULP
      UNFL = DLAMCH( 'Safe minimum' )
*
*     Copy the matrix A to the array AF.
*
      CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
      CALL DLACPY( 'Full', P, N, B, LDB, BF, LDB )
*
      ANORM = MAX( DLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
      BNORM = MAX( DLANGE( '1', P, N, B, LDB, RWORK ), UNFL )
*
*     Factorize the matrices A and B in the arrays AF and BF.
*
      CALL DGGSVD( 'U', 'V', 'Q', M, N, P, K, L, AF, LDA, BF, LDB,
     $             ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK,
     $             INFO )
*
*     Copy R
*
      DO 20 I = 1, MIN( K+L, M )
         DO 10 J = I, K + L
            R( I, J ) = AF( I, N-K-L+J )
   10    CONTINUE
   20 CONTINUE
*
      IF( M-K-L.LT.0 ) THEN
         DO 40 I = M + 1, K + L
            DO 30 J = I, K + L
               R( I, J ) = BF( I-K, N-K-L+J )
   30       CONTINUE
   40    CONTINUE
      END IF
*
*     Compute A:= U'*A*Q - D1*R
*
      CALL DGEMM( 'No transpose', 'No transpose', M, N, N, ONE, A, LDA,
     $            Q, LDQ, ZERO, WORK, LDA )
*
      CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, U, LDU,
     $            WORK, LDA, ZERO, A, LDA )
*
      DO 60 I = 1, K
         DO 50 J = I, K + L
            A( I, N-K-L+J ) = A( I, N-K-L+J ) - R( I, J )
   50    CONTINUE
   60 CONTINUE
*
      DO 80 I = K + 1, MIN( K+L, M )
         DO 70 J = I, K + L
            A( I, N-K-L+J ) = A( I, N-K-L+J ) - ALPHA( I )*R( I, J )
   70    CONTINUE
   80 CONTINUE
*
*     Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) .
*
      RESID = DLANGE( '1', M, N, A, LDA, RWORK )
*
      IF( ANORM.GT.ZERO ) THEN
         RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M, N ) ) ) / ANORM ) /
     $                 ULP
      ELSE
         RESULT( 1 ) = ZERO
      END IF
*
*     Compute B := V'*B*Q - D2*R
*
      CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, B, LDB,
     $            Q, LDQ, ZERO, WORK, LDB )
*
      CALL DGEMM( 'Transpose', 'No transpose', P, N, P, ONE, V, LDV,
     $            WORK, LDB, ZERO, B, LDB )
*
      DO 100 I = 1, L
         DO 90 J = I, L
            B( I, N-L+J ) = B( I, N-L+J ) - BETA( K+I )*R( K+I, K+J )
   90    CONTINUE
  100 CONTINUE
*
*     Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) .
*
      RESID = DLANGE( '1', P, N, B, LDB, RWORK )
      IF( BNORM.GT.ZERO ) THEN
         RESULT( 2 ) = ( ( RESID / DBLE( MAX( 1, P, N ) ) ) / BNORM ) /
     $                 ULP
      ELSE
         RESULT( 2 ) = ZERO
      END IF
*
*     Compute I - U'*U
*
      CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDQ )
      CALL DSYRK( 'Upper', 'Transpose', M, M, -ONE, U, LDU, ONE, WORK,
     $            LDU )
*
*     Compute norm( I - U'*U ) / ( M * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', M, WORK, LDU, RWORK )
      RESULT( 3 ) = ( RESID / DBLE( MAX( 1, M ) ) ) / ULP
*
*     Compute I - V'*V
*
      CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDV )
      CALL DSYRK( 'Upper', 'Transpose', P, P, -ONE, V, LDV, ONE, WORK,
     $            LDV )
*
*     Compute norm( I - V'*V ) / ( P * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', P, WORK, LDV, RWORK )
      RESULT( 4 ) = ( RESID / DBLE( MAX( 1, P ) ) ) / ULP
*
*     Compute I - Q'*Q
*
      CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, LDQ )
      CALL DSYRK( 'Upper', 'Transpose', N, N, -ONE, Q, LDQ, ONE, WORK,
     $            LDQ )
*
*     Compute norm( I - Q'*Q ) / ( N * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', N, WORK, LDQ, RWORK )
      RESULT( 5 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / ULP
*
*     Check sorting
*
      CALL DCOPY( N, ALPHA, 1, WORK, 1 )
      DO 110 I = K + 1, MIN( K+L, M )
         J = IWORK( I )
         IF( I.NE.J ) THEN
            TEMP = WORK( I )
            WORK( I ) = WORK( J )
            WORK( J ) = TEMP
         END IF
  110 CONTINUE
*
      RESULT( 6 ) = ZERO
      DO 120 I = K + 1, MIN( K+L, M ) - 1
         IF( WORK( I ).LT.WORK( I+1 ) )
     $      RESULT( 6 ) = ULPINV
  120 CONTINUE
*
      RETURN
*
*     End of DGSVTS
*
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This is a module which reads the k points from
! the output of the wien2k package
!
!
! Let us define \mathcal{S}, the set of real 3x3 matrices describing the symmetry operations of the crystal
! with respect to a real Cartesian basis. Furthernore, {k_i^ir} denotes the irreduciable k-mesh, i.e.
! the reduced mesh when the symmetry operations of \mathcal{S} are exploited, with the corresponding mapping
! m_s(n) = n_s such than n labels a k-point in full mesh and n_s label a k-point in irreduciable k-mesh.
! If one replaces all vertices m of the full tetrahedral \mathcal{T} by their reduced vertices m_s(m), one formally
! obtains the new tetrahedral mesh \mathcal{T'}_s. Note that \mathcal{T'}_s might include
! elements that do not correspond to real tetrahedra
! but have e.g. equal nodes when multiple vertices of a element of T \in \mathcal{T}
! have been mapped onto same k-point in the reduced
! set. After mapping \mathcal{T} --> \mathcal{T}'_s there are in general multiple occurrences of an element.
! Then the irreducible tetrahedral \mathcal{T}_s
! denotes the reduced symmetrized mesh, i.e. all elements T_s \in \mathcal{T}_s are only considered once
! and the weigth w_{T_s} accounts for the volume and the multiplicity of T_S.
!
! For scalar integrand      g = \sum_{T \in \mathcal{T}} g^T = \sum_{T_s \in \mathcal{T}_s} w_{T_s} g^{T_s}
! for tensorial integrand   g = \sum_{T \in \mathcal{T}} g^T =
!                               (1/|\mathcal{S}|)\sum_{s \in \mathcal{S}} \sum_{T_s \in \mathcal{T}_s} w_{T_s}  S^+ g^{T_s} S
! Therefore the integrand is only computed for irreducible mesh, but summation is on full k-mesh. Note that in this case
! (1/|\mathcal{S}|)\sum_{s \in \mathcal{S}} w_{T_s} only accounts  for the volume of tetrahedra.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
 module KpointsMod
  use PrecisionMod
  implicit none
!
  real(dp)                                    :: UnitCellVolume
  real(dp), dimension(3,3)                    :: ReciprocalVectors
  integer(i4b)                                :: NumIrKpoints
  integer(i4b)                                :: NumIrTetrahedra
  real(dp)                                    :: TetrahedraVolume               ! All tetrahedra have same volume
  integer(i4b), dimension(:,:), allocatable   :: IrTetrahedra                   ! Different tetrahedra in Irreducible part of BZ
  integer(i4b), dimension(:), allocatable     :: IrTetrahedraMultiplicity
!
  integer(i4b)                            :: NumSymmetryOperations
  real(dp), dimension(:,:,:), allocatable :: SymmetryOperations
!
  integer(i4b), dimension(:), allocatable :: StartKP, EndKP
!
  contains
!------------------------------------------------
   subroutine KpointsInit(casename)
    use MathConstantsMod
    use ParallelMod, only : NPE
    implicit none
!
    character(len=100) :: casename
!
    character(len=100) :: filename
    integer(i4b), parameter :: NUnitIn = 1111
    logical(lgt) :: i_exist
    integer(i4b) :: n, i, j, error, step
!
!   read-in information about reciprocal basis
    filename = './Input/'//trim(casename)//'.kpoints'
    inquire(file=trim(filename), exist=i_exist)
    if(.not. i_exist) then
      stop 'KpointsReader: file case.kpoints does not exsit'
    end if
    open(NUnitIn, file=trim(filename), position='rewind', action='read')
!
    write(*,'(/,a40)')'Reciprocal unit vectors in 2*pi*bohr^-1:'
    do j = 1, 3
       read(NUnitIn,*) (ReciprocalVectors(j,i), i = 1, 3)
       write(*,'(3f10.6)') ReciprocalVectors(j,1:3)
    enddo
!
!   compute unit cell volume in bohr^3
    UnitCellVolume = ReciprocalVectors(1,1)*(ReciprocalVectors(2,2)*ReciprocalVectors(3,3)-ReciprocalVectors(3,2)*ReciprocalVectors(2,3)) &
                   + ReciprocalVectors(1,2)*(ReciprocalVectors(2,3)*ReciprocalVectors(3,1)-ReciprocalVectors(3,3)*ReciprocalVectors(2,1)) &
                   + ReciprocalVectors(1,3)*(ReciprocalVectors(2,1)*ReciprocalVectors(3,2)-ReciprocalVectors(3,1)*ReciprocalVectors(2,2))
    UnitCellVolume = one/UnitCellVolume*(two*pi_d)**3
    write(*,'(/,a27,3x,f10.6)')'Unit cell volume in bohr^3:', UnitCellVolume
!
   read(NUnitIn,*)  numIrKPoints
   write(*,'(/,a20,4x,i10)')'Number of Irkpoints:', numIrKPoints
!
   read(NUnitIn, *) NumIrtetrahedra
   if (NumIrtetrahedra .ne. 0) then
     read(NUnitIn, *) TetrahedraVolume
     write(*,'(a24,x,i10)')' Number of Irtetrahedra:', NumIrtetrahedra
     write(*,'(a30,x,f10.6)')' Normalized Tetrahedra volume:', TetrahedraVolume
     read(NUnitIn, *)
     allocate(IrTetrahedra(4,NumIrtetrahedra), IrTetrahedraMultiplicity(NumIrtetrahedra), stat=error)
     if(error .ne. 0) stop 'KpointsInit: unable to allocate TetrahedraMultiplicity'
     do j = 1, NumIrtetrahedra
       read(NUnitIn, *) IrTetrahedraMultiplicity(j), (IrTetrahedra(i,j), i=1,4)
     end do
!
     read(NUnitIn, *)
     read(NUnitIn, *) NumSymmetryOperations
     allocate(SymmetryOperations(NumSymmetryOperations,3,3), stat=error)
     if (error .ne. 0) stop 'KpointsInit: unable to allocate SymmetryOperations'
     do i = 1, NumSymmetryOperations
       do j = 1, 3
         read(NUnitIn, *) SymmetryOperations(i,j,1:3)
       end do
       read(NUnitIn, *)
     end do
   end if
!
   close(NUnitIn)
!
!
!  find startkp and endkp for parallel camputation
   allocate(startKP(0:NPE-1), endKP(0:NPE-1))
   step = numIrKPoints/NPE
   endKP(NPE-1) = numIrKPoints
   startKP(NPE-1) = EndKP(NPE-1) - step + 1
   do n = NPE-2, 0, -1
     endKP(n) = startKP(n+1) - 1
     startKP(n) = EndKP(n) - step + 1
     if(n .eq. 0) StartKP(n) = 1
   end do
!
   write(*,'(/,a17, 2x, i8)') 'Number of kpoints', numIrKPoints
   do n=0, NPE-1
     write(*,'(a29)') 'Process, startkp, endkp, load'
     write(*,'(i3, 2x, 3i8)') n, startKP(n), endKP(n), endKP(n)-startKP(n)+1
   end do
!
  end subroutine KpointsInit
!
!------------------------------------------------
   subroutine kPointsDestroy()
    implicit none
!
    integer(i4b) :: error
    if(allocated(IrTetrahedra)) then
      deallocate(IrTetrahedra, IrTetrahedraMultiplicity, stat=error)
      if(error .ne. 0) stop 'KpointsDestroy: unable to deallocate IrTetrahedraMultiplicity'
      deallocate(SymmetryOperations, stat=error)
      if(error .ne. 0) stop 'KpointsDestroy: unable to deallocate SymmetryOperations'
    end if
!
    deallocate(startKP, endKP, stat=error)
    if(error .ne. 0) stop 'KpointsDestroy: unable to deallocate startKP'
!
   end subroutine kPointsDestroy
!------------------------------------------------
 end module KpointsMod


program P2869
    implicit none
    integer :: climb, slide, height
    integer :: days
    read *, climb, slide, height
    days = 1
    height = height - climb
    days = days + (height + climb - slide - 1) / (climb - slide)
    write (*, '(I0)') days
end program P2869


      subroutine scurv(x1,x2,x3,x4,x5,x6)
c
c     + + + PURPOSE + + +
c     Computes constants for an S-curve given the (X,Y) coordinates
c     of points represented by: (x3,x1), (x4,x2).
c
c     Implements a modification of EPIC equation 2.254, in the form:
c
c                              tmin
c          y = 100 * -------------------------   ;   tmin < -1.0;
c                     tmin + exp(a + b * tmin)
c
c
c   where:
c          the "100" is the upper limit (asymptote) of the curve,
c          "tmin" is the minimum daily temperature (Celsius), and
c          "a" and "b" are the constants computed by SCURV.
c
c      The "a" & "b" returned by SCURVE (x5 & x6) force the curve through
c      the points: (x3, x1) and (x4, x2); ie, (tmin1, y1) and (tmin2, y2).
c      The "100" is a scaling factor which alters the curvature *between*
c      those points.
c
c     FOR EXAMPLE:
c        For TMIN's of -5 and -15, with associated biomass loss
c        fractions of 0.01 and 0.95 respectively,
c        setting x1=0.01, x2=0.95, x3=5.0, x4=15.0
c        yields: x5=12.55, x6=0.3465 as values for "a" & "b" respectively.
c
c     Note: The values entered for TMIN's are the ABSOLUTE VALUES
c           of the actual TMIN's; ie, they are POSITIVE NUMBERS.
c           (TMIN is constrained to be less than -1 degrees Celsius.)
c           THIS SHOULD BE CHANGED IN "SCURV" AND IN "PTGRP" AND
c           "RANGE".
c
c
c     Called from RANGE, PTGRP, and PRGRA.
c     Author(s): Williams, Arnold, Weltz, Ferris, Meyer
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 92.25.
c     Date recoded: 07/02/92.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real x1, x2, x3, x4, x5, x6
c
c     + + + ARGUMENT DEFINITIONS + + +
c     x1     - frost damage fraction for 1st point.
c     x2     - frost damage fraction for 2nd point.
c     x3     - temperature associated with 1st point.
c     x4     - temperature associated with 2nd point.
c     x5     - 1st constant computed by SCURV.
c     x6     - 2nd constant computed by SCURV.
c
c     + + + LOCAL VARIABLES + + +
      real xx, yy
c
c     + + + END SPECIFICATIONS + + +
c
c
      xx = alog(x3/(x1/100.)-x3)
      yy = alog(x4/(x2/100.)-x4)
      x6 = ((xx-yy)/(x4-x3))
      x5 = (xx+x3*x6)
      return
      end


c
c	This program exercises this subroutine in 1D along a field line

c
	real*4 outn(4)
	real*4 r,al,alatr,amlt,akp
	integer*4 itime(2)

      itime(1)=2002185
      ihr=12
      imin=0
      isec=0
      itime(2)=(ihr*3600 + imin*60 + isec) * 1000
	akp=0.7
	open(unit=3,file='test_fieldaligned.txt')

      amlt=23.74
      al=1.107226364
      alatmax=acos(sqrt(1.014/al))

	  print*,'maximum latitude:',alatmax/3.1415927*180.0
	do alatr=-alatmax,alatmax,0.001
c      do alt=400.0,410.1,10.0
        alatd=alatr/3.1415927*180.0
	  r=al*cos(alatr)**2
c        r=(6371.0+alt)/6371.0
c        alatr=acos(sqrt(r/al))
c        alatd=alatr/3.1415927*180.0
        call gcpm_v24(itime,r,amlt,alatr,akp,outn)
        write(3,*) alatd,r,outn(1)
  	  print*,alatd,r,outn(1)
	enddo
      close(unit=3)

	stop
	end


MODULE CalculateWeights

  ! mbp 12/2018, based on much older subroutine
  ! Given
  !    x(*)    abscissas
  !    xTab(*) points for tabulation
  !    Nx      number of x    points
  !    NxTab   number of xTab points

  ! Compute
  !    w(*)    weights for linear interpolation
  !    Ix(*)   indices for    "         "
  !
  ! If xTab is outside the domain of x, assumes extrapolation will be done

  IMPLICIT NONE

  INTERFACE Weight
     MODULE PROCEDURE Weight_sngl, Weight_dble
  END INTERFACE Weight

CONTAINS
  SUBROUTINE Weight_sngl( x, Nx, xTab, NxTab, w, Ix )

    INTEGER, INTENT( IN  ) :: Nx, NxTab
    INTEGER, INTENT( OUT ) :: Ix( NxTab )
    REAL,    INTENT( IN  ) :: x( Nx ), xTab( NxTab )
    REAL,    INTENT( OUT ) :: w( NxTab )
    INTEGER                :: L, IxTab

    ! Quick return if just one X value for interpolation
    IF ( Nx == 1 ) THEN
       w(  1 ) = 0.0
       Ix( 1 ) = 1
       RETURN
    ENDIF

    L = 1

    DO IxTab = 1, NxTab   ! Loop over each point for which the weights are needed

       ! search for index, L, such that [ x( L ), x( L+1 ) ] brackets rcvr depth
       DO WHILE ( xTab( IxTab ) > x( L + 1 ) .AND. L < Nx - 1 )
          L = L + 1
       END DO

       ! make note of index, L, and associated weight for interpolation
       Ix( IxTab ) = L
       w(  IxTab ) = ( xTab( IxTab ) - x( L ) ) / ( x( L + 1 ) - x( L ) )

       ! special code for case of a bottom following receiver
!!$     IF ( w( IxTab ) /= 0.0 ) THEN
!!$        Ix( IxTab ) = MIN( 2, NxTab )   ! use second depth in the mode file, or first depth if only one
!!$        w( IxTab )  = 0.0               ! assert that it's a perfect match to the requested depth
!!$     END IF
    END DO

  END SUBROUTINE Weight_sngl

  SUBROUTINE Weight_dble( x, Nx, xTab, NxTab, w, Ix )

    INTEGER,       INTENT( IN  ) :: Nx, NxTab
    INTEGER,       INTENT( OUT ) :: Ix( NxTab )
    REAL (KIND=8), INTENT( IN  ) :: x( Nx ), xTab( NxTab )
    REAL (KIND=8), INTENT( OUT ) :: w( NxTab )
    INTEGER                      :: L, IxTab

    ! Quick return if just one X value for interpolation
    IF ( Nx == 1 ) THEN
       w(  1 ) = 0.0
       Ix( 1 ) = 1
       RETURN
    ENDIF

    L = 1

    DO IxTab = 1, NxTab   ! Loop over each point for which the weights are needed

       ! search for index, L, such that [ x( L ), x( L+1 ) ] brackets rcvr depth
       DO WHILE ( xTab( IxTab ) > x( L + 1 ) .AND. L < Nx - 1 )
          L = L + 1
       END DO

       ! make note of index, L, and associated weight for interpolation
       Ix( IxTab ) = L
       w(  IxTab ) = ( xTab( IxTab ) - x( L ) ) / ( x( L + 1 ) - x( L ) )

       ! special code for case of a bottom following receiver
!!$     IF ( w( IxTab ) /= 0.0 ) THEN
!!$        Ix( IxTab ) = MIN( 2, NxTab )   ! use second depth in the mode file, or first depth if only one
!!$        w( IxTab )  = 0.0               ! assert that it's a perfect match to the requested depth
!!$     END IF
    END DO

  END SUBROUTINE Weight_dble
END MODULE CalculateWeights


cc Copyright (C) 2009-2011: Leslie Greengard and Zydrunas Gimbutas
cc Modified 2019: Leslie Greengard
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    $Date: 2011-02-22 17:34:23 -0500 (Tue, 22 Feb 2011) $
c    $Revision: 1670 $
c
c     Computation of  Bessel functions via recurrence
c
c**********************************************************************
      subroutine jbessel2d(nterms,z,rscale,fjs,ifder,fjder)
      implicit real *8 (a-h,o-z)
c**********************************************************************
c
c     PURPOSE:
c
c     This subroutine evaluates the first NTERMS  Bessel
c     functions and if required, their derivatives.
c     It incorporates a scaling parameter SCALE so that
c
c	fjs_n(z)= j_n(z)/RSCALE^n
c	fjder_n(z)= \frac{\partial fjs_n(z)}{\partial z}
c
c     NOTE: The scaling parameter RSCALE is meant to be used when
c           abs(z) < 1, in which case we recommend setting
c	    RSCALE = abs(z). This prevents the fjs_n from
c           underflowing too rapidly. Otherwise, set RSCALE=1.
c	    Do not set RSCALE = abs(z) if z could take on the
c           value zero.
c           In an FMM, when forming an expansion from a collection of
c           sources, set RSCALE = min( abs(k*r), 1)
c           where k is the Helmholtz parameter and r is the box dimension
c           at the relevant level.
c
c    INPUT:
c
c    nterms    (integer): order of expansion of output array fjs
c                         nterms should be greater than 1.
c    z     (complex *16): argument of the  Bessel functions
c    rscale     (real *8): scaling factor (discussed above)
c    ifder     (integer): flag indicating whether to calculate "fjder"
c		          0	NO
c		          1	YES
c    OUTPUT:
c
c    fjs   (complex *16): array of scaled Bessel functions.
c    fjder (complex *16): array of derivs of scaled Bessel functions.
c
c
c    INTERNAL VARIABLES
c    lextra   lextra is buffer large enough to run the
c             recurrence from nterms upward until
c             the value of fjs has blown up by a factor
c             of 1.0d40 (a parameter hardwired as
c             upbound2 below). lextra should be much larger
c             than nterms. It is set below to 1000
c             If that is not sufficient, an error code is returned (ier=8).
c
c    iscale   integer workspace used to keep track of
c             internal scaling
c
c
      integer, allocatable :: iscale(:)
      complex *16, allocatable :: fjtemp(:)
      complex *16 wavek,fjs(0:nterms),fjder(0:nterms)
      complex *16 z,zinv,com,zscale,ztmp
      complex *16 psi,zmul,zsn,zmulinv
      complex *16 ima,ffn,ffnm1,ffnp1
      data ima/(0.0d0,1.0d0)/
c
      data upbound/1.0d+32/, upbound2/1.0d+40/, upbound2inv/1.0d-40/
      data tiny/1.0d-200/,done/1.0d0/,zero/0.0d0/
c
c ... Initializing ...
c
      ier=0
ccc      call prinf(' ifder is *',ifder,1)
c
c     set to asymptotic values if argument is sufficiently small
c
      if (abs(z).lt.tiny) then
         fjs(0) = done
         do i = 1, nterms
            fjs(i) = zero
	 enddo
c
	 if (ifder.eq.1) then
	    do i=0,nterms
	       fjder(i)=zero
	    enddo
	    fjder(1)=done/(2*rscale)
	 endif
c
         RETURN
      endif
c
c ... Step 1: carry out upward recursion starting at nterms until the
c     magnitude has grown by uppound2 = 10^40. The top value of
c     the index is stored as NTOP. That becomes the point from which
c     the downward recurrence begins.
c
      ntop=nterms+nextra
      zinv=done/z
      ffn = done
      ffnm1 = zero
c
      nextra = 10000
      do 1200 i=nterms,nterms+nextra
         dcoef=2*i
         ztmp=dcoef*zinv*ffn-ffnm1
         ffnp1=ztmp
c
         dd = dreal(ztmp)**2 + dimag(ztmp)**2
         if (dd .gt. upbound2) then
            ntop=i+1
            goto 1300
         endif
         ffnm1 = ffn
         ffn = ffnp1
 1200 continue
 1300 continue
      allocate(iscale(0:ntop))
      allocate(fjtemp(0:ntop))
c
c ... Step 2: Recursion back down to generate the unscaled jfuns:
c             This is the stable but growing direction for the recurrence.
c             To avoid overflow, if the magnitude exceeds UPBOUND2,
c             we rescale and continue the recursion (saving the order
c             at which rescaling occurred in array iscale for subsequent
c             correction).
c
      do i=0,ntop
         iscale(i)=0
      enddo
c
      fjtemp(ntop)=zero
      fjtemp(ntop-1)=done
      do i=ntop-1,1,-1
	 dcoef=2*i
         ztmp=dcoef*zinv*fjtemp(i)-fjtemp(i+1)
         fjtemp(i-1)=ztmp
c
         dd = dreal(ztmp)**2 + dimag(ztmp)**2
         if (dd.gt.upbound2) then
            fjtemp(i) = fjtemp(i)*upbound2inv
            fjtemp(i-1) = fjtemp(i-1)*upbound2inv
            iscale(i) = 1
         endif
      enddo
c
c ...  Step 3: go back up to the top and make sure that all
c              Bessel functions are scaled by the same factor
c              (i.e. the net total of times rescaling was invoked
c              on the way down in the previous loop).
c              At the same time, add scaling to fjs array.
c
      ncntr=0
      scalinv=done/rscale
      sctot = 1.0d0
      do i=1,ntop
         sctot = sctot*scalinv
         if(iscale(i-1).eq.1) sctot=sctot*upbound2inv
         fjtemp(i)=fjtemp(i)*sctot
      enddo
c
c ... Determine the normalization parameter:
c
c     From Abramowitz and Stegun (9.1.47) and (9.1.48), Euler's identity
c
        psi = 0d0
c
        if (dimag(z) .lt. 0) zmul = +ima
        if (dimag(z) .ge. 0) zmul = -ima
        zsn = zmul**(mod(ntop,4))
c
        zmulinv=1/zmul
        do i = ntop,1,-1
           psi = rscale*psi+fjtemp(i)*zsn
           zsn = zsn*zmulinv
        enddo
        psi = 2*psi*rscale+fjtemp(0)
c
        if (dimag(z) .lt. 0) zscale = cdexp(+ima*z) / psi
        if (dimag(z) .ge. 0) zscale = cdexp(-ima*z) / psi
c
c
c ... Scale the jfuns by zscale:
c
      ztmp=zscale
      do i=0,nterms
         fjs(i)=fjtemp(i)*ztmp
      enddo
c
c ... Finally, calculate the derivatives if desired:
c
      if (ifder.eq.1) then
         fjs(nterms+1)=fjtemp(nterms+1)*ztmp
c
         fjder(0)=-fjs(1)*rscale
         dc1=0.5d0
         dc2=done-dc1
         dc1=dc1*scalinv
         dc2=dc2*rscale
         do i=1,nterms
            fjder(i)=dc1*fjs(i-1)-dc2*fjs(i+1)
         enddo
      endif
      return
      end
c


      subroutine init_rpsi(ctfm,Nx,amp,deltx,x0,res)
      implicit none
      integer i
      integer Nx
      real*8 amp
      real*8 deltx
      real*8 x0
      real*8 ctfm(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = amp * exp(-0.1D1 * (ctfm(i) - 0.1D1 * x0) ** 2 / deltx ** 2)
      res(i)=qb
      end do
      END


MODULE Eigen_symmetric_banded
! Calculate eigenvalues & vectors of symmetric banded matrices

! Code converted using TO_F90 by Alan Miller
! Date: 2000-07-18  Time: 23:59:29

IMPLICIT NONE
INTEGER, PARAMETER             :: dp = SELECTED_REAL_KIND(12, 60)
REAL (dp), PARAMETER, PRIVATE  :: one = 1.0_dp, zero = 0.0_dp

CONTAINS

SUBROUTINE rsb(nm, n, mb, a, w, matz, z, ierr)

! N.B. Arguments FV1 & FV2 have been removed.

INTEGER, INTENT(IN)        :: nm
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: mb
REAL (dp), INTENT(IN OUT)  :: a(:,:)   ! a(nm,mb)
REAL (dp), INTENT(IN OUT)  :: w(:)
INTEGER, INTENT(IN)        :: matz
REAL (dp), INTENT(IN OUT)  :: z(:,:)   ! z(nm,n)
INTEGER, INTENT(OUT)       :: ierr

! Local variables

LOGICAL    :: tf
REAL (dp)  :: fv1(n), fv2(n)

!  This subroutine calls the recommended sequence of subroutines from the
!  eigensystem subroutine package (eispack) to find the eigenvalues and
!  eigenvectors (if desired) of a real symmetric band matrix.

!  on input

!     nm  must be set to the row dimension of the two-dimensional array
!     parameters as declared in the calling program dimension statement.

!     n  is the order of the matrix  a.

!     mb  is the half band width of the matrix, defined as the number of
!     adjacent diagonals, including the principal diagonal, required to
!     specify the non-zero portion of the lower triangle of the matrix.

!     a  contains the lower triangle of the real symmetric band matrix.
!     Its lowest subdiagonal is stored in the last  n+1-mb  positions of the
!     first column, its next subdiagonal in the last  n+2-mb  positions of the
!     second column, further subdiagonals similarly, and finally its principal
!     diagonal in the  n  positions of the last column.
!     Contents of storages not part of the matrix are arbitrary.

!     matz  is an integer variable set equal to zero if only eigenvalues are
!     desired.   Otherwise it is set to any non-zero integer for both
!     eigenvalues and eigenvectors.

!  on output

!     w  contains the eigenvalues in ascending order.

!     z  contains the eigenvectors if matz is not zero.

!     ierr  is an integer output variable set equal to an error completion
!        code described in the documentation for tqlrat and tql2.
!        The normal completion code is zero.

!     fv1  and  fv2  are temporary storage arrays.

!  questions and comments should be directed to burton s. garbow,
!  mathematics and computer science div, argonne national laboratory

!  this version dated august 1983.

!  ------------------------------------------------------------------

IF (n > nm) THEN
  ierr = 10 * n
ELSE
  IF (mb <= 0) THEN
    ierr = 12 * n
  ELSE
    IF (mb > n) THEN
      ierr = 12 * n
    ELSE

      IF (matz == 0) THEN
!     .......... find eigenvalues only ..........
        tf = .false.
        CALL bandr(n, mb, a, w, fv1, fv2, tf, z)
        CALL tqlrat(n, w, fv2, ierr)
      ELSE
!     .......... find both eigenvalues and eigenvectors ..........
        tf = .true.
        CALL bandr(n, mb, a, w, fv1, fv1, tf, z)
        CALL tql2(n, w, fv1, z, ierr)
      END IF
    END IF
  END IF
END IF

RETURN
END SUBROUTINE rsb

SUBROUTINE bandr(n, mb, a, d, e, e2, matz, z)

! N.B. Argument NM has been removed.

!  REFORMULATED S2 IN LOOP 500 TO AVOID OVERFLOW. (9/29/89 BSG)

INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: mb
REAL (dp), INTENT(IN OUT)  :: a(:,:)   ! a(nm,mb)
REAL (dp), INTENT(OUT)     :: d(:)
REAL (dp), INTENT(OUT)     :: e(:)
REAL (dp), INTENT(OUT)     :: e2(:)
LOGICAL, INTENT(IN)        :: matz
REAL (dp), INTENT(OUT)     :: z(:,:)   ! z(nm,n)

! Local variables

INTEGER    :: j, k, l, r, i1, i2, j1, j2, kr, mr, m1, n2, r1, ugl, maxl, maxr
REAL (dp)  :: g, u, b1, b2, c2, f1, f2, s2, dmin, dminrt

!  this subroutine is a translation of the algol procedure bandrd,
!  num. math. 12, 231-241(1968) by schwarz.
!  handbook for auto. comp., vol.ii-linear algebra, 273-283(1971).

!  this subroutine reduces a real symmetric band matrix
!  to a symmetric tridiagonal matrix using and optionally
!  accumulating orthogonal similarity transformations.

!  on input

!     nm must be set to the row dimension of two-dimensional array
!       parameters as declared in the calling program dimension statement.

!     n is the order of the matrix.

!     mb is the (half) band width of the matrix, defined as the number of
!       adjacent diagonals, including the principal diagonal, required to
!       specify the non-zero portion of the lower triangle of the matrix.

!     a contains the lower triangle of the symmetric band input
!       matrix stored as an n by mb array.  its lowest subdiagonal
!       is stored in the last n+1-mb positions of the first column,
!       its next subdiagonal in the last n+2-mb positions of the
!       second column, further subdiagonals similarly, and finally
!       its principal diagonal in the n positions of the last column.
!       contents of storages not part of the matrix are arbitrary.

!     matz should be set to .true. if the transformation matrix is
!       to be accumulated, and to .false. otherwise.

!  on output

!     a has been destroyed, except for its last two columns which
!       contain a copy of the tridiagonal matrix.

!     d contains the diagonal elements of the tridiagonal matrix.

!     e contains the subdiagonal elements of the tridiagonal
!       matrix in its last n-1 positions.  e(1) is set to zero.

!     e2 contains the squares of the corresponding elements of e.
!       e2 may coincide with e if the squares are not needed.

!     z contains the orthogonal transformation matrix produced in the
!       reduction if matz has been set to .true.  Otherwise, z is not
!       referenced.

!  questions and comments should be directed to burton s. garbow,
!  mathematics and computer science div, argonne national laboratory

!  this version dated september 1989.

!  ------------------------------------------------------------------

dmin = EPSILON(one)
dminrt = SQRT(dmin)
!     .......... initialize diagonal scaling matrix ..........
d(1:n) = one

IF (matz) THEN

  DO  j = 1, n

    z(j,1:n) = zero

    z(j,j) = one
  END DO
END IF

m1 = mb - 1
IF (m1 < 1) THEN
  GO TO 230
ELSE IF (m1 == 1) THEN
  GO TO 180
END IF
n2 = n - 2

DO  k = 1, n2
  maxr = MIN(m1,n-k)
!     .......... for r=maxr step -1 until 2 do -- ..........
  loop120:  DO  r1 = 2, maxr
    r = maxr + 2 - r1
    kr = k + r
    mr = mb - r
    g = a(kr,mr)
    a(kr-1,1) = a(kr-1,mr+1)
    ugl = k

    DO  j = kr, n, m1
      j1 = j - 1
      j2 = j1 - 1
      IF (g == zero) CYCLE loop120
      b1 = a(j1,1) / g
      b2 = b1 * d(j1) / d(j)
      IF (ABS(b1) > one) THEN
        u = one / b1
        s2 = u / (u+b2)
      ELSE
        s2 = one / (one+b1*b2)
      END IF

      IF (s2 < 0.5D0) THEN
        b1 = g / a(j1,1)
        b2 = b1 * d(j) / d(j1)
        c2 = one - s2
        d(j1) = c2 * d(j1)
        d(j) = c2 * d(j)
        f1 = 2.0D0 * a(j,m1)
        f2 = b1 * a(j1,mb)
        a(j,m1) = -b2 * (b1*a(j,m1) - a(j,mb)) - f2 + a(j,m1)
        a(j1,mb) = b2 * (b2*a(j,mb) + f1) + a(j1,mb)
        a(j,mb) = b1 * (f2-f1) + a(j,mb)

        DO  l = ugl, j2
          i2 = mb - j + l
          u = a(j1,i2+1) + b2 * a(j,i2)
          a(j,i2) = -b1 * a(j1,i2+1) + a(j,i2)
          a(j1,i2+1) = u
        END DO

        ugl = j
        a(j1,1) = a(j1,1) + b2 * g
        IF (j /= n) THEN
          maxl = MIN(m1,n-j1)

          DO  l = 2, maxl
            i1 = j1 + l
            i2 = mb - l
            u = a(i1,i2) + b2 * a(i1,i2+1)
            a(i1,i2+1) = -b1 * a(i1,i2) + a(i1,i2+1)
            a(i1,i2) = u
          END DO

          i1 = j + m1
          IF (i1 <= n) THEN
            g = b2 * a(i1,1)
          END IF
        END IF
        IF (.NOT.matz) CYCLE

        DO  l = 1, n
          u = z(l,j1) + b2 * z(l,j)
          z(l,j) = -b1 * z(l,j1) + z(l,j)
          z(l,j1) = u
        END DO

      ELSE

        u = d(j1)
        d(j1) = s2 * d(j)
        d(j) = s2 * u
        f1 = 2.0D0 * a(j,m1)
        f2 = b1 * a(j,mb)
        u = b1 * (f2-f1) + a(j1,mb)
        a(j,m1) = b2 * (b1*a(j,m1) - a(j1,mb)) + f2 - a(j,m1)
        a(j1,mb) = b2 * (b2*a(j1,mb) + f1) + a(j,mb)
        a(j,mb) = u

        DO  l = ugl, j2
          i2 = mb - j + l
          u = b2 * a(j1,i2+1) + a(j,i2)
          a(j,i2) = -a(j1,i2+1) + b1 * a(j,i2)
          a(j1,i2+1) = u
        END DO

        ugl = j
        a(j1,1) = b2 * a(j1,1) + g
        IF (j /= n) THEN
          maxl = MIN(m1,n-j1)

          DO  l = 2, maxl
            i1 = j1 + l
            i2 = mb - l
            u = b2 * a(i1,i2) + a(i1,i2+1)
            a(i1,i2+1) = -a(i1,i2) + b1 * a(i1,i2+1)
            a(i1,i2) = u
          END DO

          i1 = j + m1
          IF (i1 <= n) THEN
            g = a(i1,1)
            a(i1,1) = b1 * a(i1,1)
          END IF
        END IF
        IF (matz) THEN

          DO  l = 1, n
            u = b2 * z(l,j1) + z(l,j)
            z(l,j) = -z(l,j1) + b1 * z(l,j)
            z(l,j1) = u
          END DO
        END IF
      END IF

    END DO

  END DO loop120

  IF (MOD(k,64) == 0) THEN
!     .......... rescale to avoid underflow or overflow ..........
    DO  j = k, n
      IF (d(j) < dmin) THEN
        maxl = MAX(1,mb+1-j)

        DO  l = maxl, m1
          a(j,l) = dminrt * a(j,l)
        END DO

        IF (j /= n) THEN
          maxl = MIN(m1,n-j)

          DO  l = 1, maxl
            i1 = j + l
            i2 = mb - l
            a(i1,i2) = dminrt * a(i1,i2)
          END DO
        END IF

        IF (matz) THEN

          DO  l = 1, n
            z(l,j) = dminrt * z(l,j)
          END DO
        END IF

        a(j,mb) = dmin * a(j,mb)
        d(j) = d(j) / dmin
      END IF
    END DO
  END IF

END DO
!     .......... form square root of scaling matrix ..........
180 DO  j = 2, n
  e(j) = SQRT(d(j))
END DO

IF (matz) THEN

  DO  j = 1, n
    z(j,2:n) = e(2:n) * z(j,2:n)
  END DO
END IF

u = one

DO  j = 2, n
  a(j,m1) = u * e(j) * a(j,m1)
  u = e(j)
  e2(j) = a(j,m1) ** 2
  a(j,mb) = d(j) * a(j,mb)
  d(j) = a(j,mb)
  e(j) = a(j,m1)
END DO

d(1) = a(1,mb)
e(1) = zero
e2(1) = zero
GO TO 250

230 DO  j = 1, n
  d(j) = a(j,mb)
  e(j) = zero
  e2(j) = zero
END DO

250 RETURN
END SUBROUTINE bandr

SUBROUTINE tqlrat(n, d, e2, ierr)

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: d(:)
REAL (dp), INTENT(OUT)     :: e2(:)
INTEGER, INTENT(OUT)       :: ierr

! Local variables

INTEGER    :: i, j, l, m, ii, l1, mml
REAL (dp)  :: b, c, f, g, h, p, r, s, t

!  this subroutine is a translation of the algol procedure tqlrat,
!  algorithm 464, comm. acm 16, 689(1973) by reinsch.

!  this subroutine finds the eigenvalues of a symmetric
!  tridiagonal matrix by the rational ql method.

!  on input

!     n is the order of the matrix.

!     d contains the diagonal elements of the input matrix.

!     e2 contains the squares of the subdiagonal elements of the
!       input matrix in its last n-1 positions.  e2(1) is arbitrary.

!   on output

!     d contains the eigenvalues in ascending order.  if an
!       error exit is made, the eigenvalues are correct and
!       ordered for indices 1,2,...ierr-1, but may not be
!       the smallest eigenvalues.

!     e2 has been destroyed.

!     ierr is set to
!       zero       for normal return,
!       j          if the j-th eigenvalue has not been
!                  determined after 30 iterations.

!  calls pythag for  SQRT(a*a + b*b) .

!  questions and comments should be directed to burton s. garbow,
!  mathematics and computer science div, argonne national laboratory

!  this version dated august 1983.

!  ------------------------------------------------------------------

ierr = 0
IF (n /= 1) THEN

  DO  i = 2, n
    e2(i-1) = e2(i)
  END DO

  f = zero
  t = zero
  e2(n) = zero

  DO  l = 1, n
    j = 0
    h = ABS(d(l)) + SQRT(e2(l))
    IF (t <= h) THEN
      t = h
      b = ABS(t) * EPSILON(one)
      c = b * b
    END IF
!     .......... look for small squared sub-diagonal element ..........
    DO  m = l, n
      IF (e2(m) <= c) GO TO 30
!     .......... e2(n) is always zero, so there is no exit
!                through the bottom of the loop ..........
    END DO

    30 IF (m /= l) THEN
      40 IF (j == 30) GO TO 100
      j = j + 1
!     .......... form shift ..........
      l1 = l + 1
      s = SQRT(e2(l))
      g = d(l)
      p = (d(l1)-g) / (2.0D0*s)
      r = pythag(p, one)
      d(l) = s / (p + SIGN(r,p))
      h = g - d(l)

      DO  i = l1, n
        d(i) = d(i) - h
      END DO

      f = f + h
!     .......... rational ql transformation ..........
      g = d(m)
      IF (g == zero) g = b
      h = g
      s = zero
      mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
      DO  ii = 1, mml
        i = m - ii
        p = g * h
        r = p + e2(i)
        e2(i+1) = s * r
        s = e2(i) / r
        d(i+1) = h + s * (h+d(i))
        g = d(i) - e2(i) / g
        IF (g == zero) g = b
        h = g * p / r
      END DO

      e2(l) = s * g
      d(l) = h
!     .......... guard against underflow in convergence test ..........
      IF (h /= zero) THEN
        IF (ABS(e2(l)) > ABS(c/h)) THEN
          e2(l) = h * e2(l)
          IF (e2(l) /= zero) GO TO 40
        END IF
      END IF
    END IF
    p = d(l) + f
!     .......... order eigenvalues ..........
    IF (l /= 1) THEN
!     .......... for i=l step -1 until 2 do -- ..........
      DO  ii = 2, l
        i = l + 2 - ii
        IF (p >= d(i-1)) GO TO 80
        d(i) = d(i-1)
      END DO
    END IF

    i = 1
    80 d(i) = p
  END DO

  GO TO 110
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
  100 ierr = l
END IF

110 RETURN
END SUBROUTINE tqlrat

FUNCTION pythag(a, b) RESULT(fn_val)

REAL (dp), INTENT(IN)  :: a, b
REAL (dp)              :: fn_val

!     finds sqrt(a**2 + b**2) without overflow or destructive underflow

REAL (dp) :: r, s, t, u

fn_val = MAX(ABS(a), ABS(b))
IF (fn_val /= zero) THEN
  r = (MIN(ABS(a), ABS(b))/fn_val) ** 2
  DO
    t = 4.0_dp + r
    IF (t /= 4.0_dp) THEN
      s = r / t
      u = one + 2.0_dp * s
      fn_val = u * fn_val
      r = (s/u) ** 2 * r
      CYCLE
    END IF
    EXIT
  END DO
END IF

RETURN
END FUNCTION pythag

SUBROUTINE tql2(n, d, e, z, ierr)

! N.B. Argument NM has been removed.

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: d(:)
REAL (dp), INTENT(OUT)     :: e(:)
REAL (dp), INTENT(IN OUT)  :: z(:,:)   ! z(nm,n)
INTEGER, INTENT(OUT)       :: ierr

! Local variables

INTEGER    :: i, j, k, l, m, ii, l1, l2, mml
REAL (dp)  :: c, c2, c3, dl1, el1, f, g, h, p, r, s, s2, tst1, tst2

!  this subroutine is a translation of the algol procedure tql2,
!  num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and wilkinson.
!  handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).

!  this subroutine finds the eigenvalues and eigenvectors of a symmetric
!  tridiagonal matrix by the ql method.  The eigenvectors of a full symmetric
!  matrix can also be found if  tred2  has been used to reduce this full
!  matrix to tridiagonal form.

!  on input

!     nm must be set to the row dimension of two-dimensional array parameters
!       as declared in the calling program dimension statement.

!     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 last n-1 positions.  e(1) is arbitrary.

!     z contains the transformation matrix produced in the reduction by
!       tred2, if performed.  If the eigenvectors of the tridiagonal matrix
!       are desired, z must contain 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 orthonormal eigenvectors of the symmetric
!       tridiagonal (or full) 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.

!  calls pythag for  SQRT(a*a + b*b) .

!  questions and comments should be directed to burton s. garbow,
!  mathematics and computer science div, argonne national laboratory

!  this version dated august 1983.

!  ------------------------------------------------------------------

ierr = 0
IF (n /= 1) THEN

  DO  i = 2, n
    e(i-1) = e(i)
  END DO

  f = zero
  tst1 = zero
  e(n) = zero

  DO  l = 1, n
    j = 0
    h = ABS(d(l)) + ABS(e(l))
    IF (tst1 < h) tst1 = h
!     .......... look for small sub-diagonal element ..........
    DO  m = l, n
      tst2 = tst1 + ABS(e(m))
      IF (tst2 == tst1) GO TO 30
!     .......... e(n) is always zero, so there is no exit
!                through the bottom of the loop ..........
    END DO

    30 IF (m /= l) THEN
      40 IF (j == 30) GO TO 120
      j = j + 1
!     .......... form shift ..........
      l1 = l + 1
      l2 = l1 + 1
      g = d(l)
      p = (d(l1)-g) / (2.0_dp*e(l))
      r = pythag(p,one)
      d(l) = e(l) / (p + SIGN(r,p))
      d(l1) = e(l) * (p + SIGN(r,p))
      dl1 = d(l1)
      h = g - d(l)
      IF (l2 <= n) THEN

        DO  i = l2, n
          d(i) = d(i) - h
        END DO
      END IF

      f = f + h
!     .......... ql transformation ..........
      p = d(m)
      c = one
      c2 = c
      el1 = e(l1)
      s = zero
      mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
      DO  ii = 1, mml
        c3 = c2
        c2 = c
        s2 = s
        i = m - ii
        g = c * e(i)
        h = c * p
        r = pythag(p,e(i))
        e(i+1) = s * r
        s = e(i) / r
        c = p / r
        p = c * d(i) - s * g
        d(i+1) = h + s * (c*g+s*d(i))
!     .......... form vector ..........
        DO  k = 1, n
          h = z(k,i+1)
          z(k,i+1) = s * z(k,i) + c * h
          z(k,i) = c * z(k,i) - s * h
        END DO

      END DO

      p = -s * s2 * c3 * el1 * e(l) / dl1
      e(l) = s * p
      d(l) = c * p
      tst2 = tst1 + ABS(e(l))
      IF (tst2 > tst1) GO TO 40
    END IF
    d(l) = d(l) + f
  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) THEN
        k = j
        p = d(j)
      END IF
    END DO

    IF (k /= i) THEN
      d(k) = d(i)
      d(i) = p

      DO  j = 1, n
        p = z(j,i)
        z(j,i) = z(j,k)
        z(j,k) = p
      END DO
    END IF

  END DO

  GO TO 130
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
  120 ierr = l
END IF

130 RETURN
END SUBROUTINE tql2

END MODULE Eigen_symmetric_banded

PROGRAM Test_Eigen_symmetric_banded
USE Eigen_symmetric_banded
IMPLICIT NONE

INTEGER    :: i, ierr, mb, nrows
REAL (dp)  :: sumeig
REAL (dp), ALLOCATABLE  :: a(:,:), eigenval(:), eigenvector(:,:)

WRITE(*, '(a)', ADVANCE='NO') ' Enter number of rows in matrix: '
READ(*, *) nrows
WRITE(*, '(a)', ADVANCE='NO') ' Enter number of bands on and below diagonal: '
READ(*, *) mb
IF (mb >= nrows/2) THEN
  WRITE(*, *) ' ** Number of bands must be less than half the number of rows'
  STOP
END IF

ALLOCATE( a(nrows,mb), eigenval(nrows), eigenvector(nrows,nrows) )

DO i = 1, mb
  a(1:nrows,i) = i
END DO

CALL rsb(nrows, nrows, mb, a, eigenval, 1, eigenvector, ierr)
WRITE(*, *) 'IERR = ', ierr
sumeig = SUM(eigenval)
WRITE(*, '(a, g16.8)') ' Sum of eigenvalues = ', sumeig

DO i = 1, nrows
  WRITE(*, '(a, i3, a, g16.8)') ' Eigenvalue', i, ' = ', eigenval(i)
  IF (ABS(eigenval(i)) < 1.0e-10_dp) CYCLE
  WRITE(*, *) 'Eigenvector'
  WRITE(*, '(" ", 6g13.5)') eigenvector(:,i)
  WRITE(*, *)
END DO

STOP
END PROGRAM Test_Eigen_symmetric_banded


!===============================================================================
program test_transform_M
!===============================================================================
! Make sure that the CIJ_transform_M routines give the same results.
! Also compare them in terms of speed

   use anisotropy_ajn

   implicit none

   integer,parameter :: rs = 8
   real(rs), dimension(6,6) :: C,CT,Cflip,Crot
   real(rs) :: M(3,3),a
   real(rs) :: rh
   real(rs), parameter :: tol = 1.d-5
   character(len=250) :: file_orig,file_flipped,file_rot

   if (command_argument_count() /= 3) then
      write(*,'(a)') 'Usage: test_flip [original ecs .ecs] [flipped ecs .ecs] [rotated ecs .ecs]'
      stop
   endif

   call get_command_argument(1,file_orig)
   call get_command_argument(2,file_flipped)
   call get_command_argument(3,file_rot)

   ! An average kimberlite from Mainprice and Silver, PEPI, 1993
   C(1,1) = 230.88e9
   C(1,2) = 85.14e9;  C(2,1) = 85.14e9
   C(1,3) = 88.53e9;  C(3,1) = 88.53e9
   C(1,4) = 0.00e9;   C(4,1) = 0.00e9
   C(1,5) = 0.88e9;   C(5,1) = 0.88e9
   C(1,6) = -1.29e9;  C(6,1) = -1.29e9
   C(2,2) = 252.33e9
   C(2,3) = 85.93e9;  C(3,2) = 85.93e9
   C(2,4) = 0.41e9;   C(4,2) = 0.41e9
   C(2,5) = 0.56e9;   C(5,2) = 0.56e9
   C(2,6) = -1.42e9;  C(6,2) = -1.42e9
   C(3,3) = 237.65e9
   C(3,4) = -1.14e9;  C(4,3) = -1.14e9
   C(3,5) = 1.11e9;   C(5,3) = 1.11e9
   C(3,6) = -0.01e9;  C(6,3) = -0.01e9
   C(4,4) = 76.97e9
   C(4,5) = -0.68e9;  C(5,4) = -0.68e9
   C(4,6) = 0.68e9;   C(6,4) = 0.68e9
   C(5,5) = 72.49e9
   C(5,6) = -0.34e9;  C(6,5) = -0.34e9
   C(6,6) = 74.75e9
   rh = 3333.0

   ! Save original
   call CIJ_save(file_orig,C,rh)

   ! Flip across the x=0 plane
   Cflip = CIJ_flipx(C)
   call CIJ_save(trim(file_flipped)//'.ref',Cflip,rh)

   ! Do it the Bower way
   M = 0._rs; M(1,1) = -1._rs; M(2,2) = 1._rs; M(3,3) = 1._rs
   CT = CIJ_transform_M(C,M)
   write(*,'(a)',advance='no') 'Explicit v Bower flip: '
   call CIJ_save(trim(file_flipped)//'.2',CT,rh)
   call check(Cflip,CT,tol)

   ! Rotate about the x axis 30 degrees
   a = 30._rs
   call CIJ_rot3_old(C,a,0._rs,0._rs,Crot)
   call CIJ_save(file_rot,Crot,rh)

   ! Do it the Bower way
   call CIJ_rot3(C,a,0._rs,0._rs,CT)
   call CIJ_save(trim(file_rot)//'.2',CT,rh)
   write(*,'(a)',advance='no') 'Old v Bower rotation: '
   call check(Crot,CT,tol)

end program test_transform_M
!-------------------------------------------------------------------------------

!===============================================================================
subroutine check(A,B,tol)
!===============================================================================
   implicit none
   real(8), intent(in) :: A(6,6),B(6,6),tol
   if (any(2._8*abs(A-B)/(A+B) > tol)) then
      write(*,'(a,e7.1)') 'Two matrices do not agree to +/- ',tol
   else
      write(*,'(a)') 'Two matrices agree'
   endif
end subroutine check
!-------------------------------------------------------------------------------


PROGRAM subl1
!****************************************************************
!      *this code solves the l1 best subset problem*
!      *submitted to acm trans.spring 1982*
!       *last revised mar. 12, 1984*
!****************************************************************

USE toms615
IMPLICIT NONE

INTEGER   :: i, idex(210), ifault, istat(20), iter, j, jmin, k, l,  &
             minin, mmax, n, nmax, nprob
REAL (dp) :: bval(210), popt, x(300,20), y(300), zl(20)

INTEGER   :: unitgo, unitin

!-----unitin    is the input unit number
!-----unitgo    is the output unit number

CHARACTER (LEN=72) :: imt
CHARACTER (LEN=40) :: name

!-----imt       is used to store the input format
!-----name      saves the problem name

unitin = 5
unitgo = 6
nmax = 300
mmax = 30
nprob = 0

!-----k        stores the number of parameters in the full model

10 READ (unitin, 70, END=60) k, name
WRITE (unitgo, 70) k, name
IF (k == 0) STOP
WRITE (unitgo, 80) name

!-----n          stores the number of observations
!-----minin      stores the minimum number of parameters considered
!-----popt       deviation from optimality allowed

READ (unitin, 140) n, minin, popt
20   FORMAT ('    Number of observation =', i5/,  &
             '    Number of parameters =', i5/  &
             '    Minimum number of parameters considered =', i5/  &
             '    Percentage deviation from optimality allowed =', f6.2/  &
             '        ** best subset lav program')
WRITE (unitgo, 20) n, k, minin, popt
READ (unitin, 150) imt
DO i = 1, n
  READ (unitin, FMT=imt) y(i), (x(i,j),j=1,k)

!        write (unitgo, FMT=imt) y(i), (x(i,j),j=1,k)

END DO

READ (unitin, 90) istat(1:k)

iter = 0

!******call the routine to find the best subsets

CALL kbest (x, y, k, n, iter, ifault, popt, minin, nmax, mmax,  &
            bval, idex, istat, zl)

WRITE (unitgo, 100) ifault

!     write the final best subset solution

j = k*(k+1)/2
jmin = (minin-1)*(minin)/2
j = j - jmin
DO i = minin,k
  WRITE (unitgo, 130) i
  WRITE (unitgo, 120) zl(i)
  DO l = 1,i
    WRITE (unitgo, 110) idex(j), bval(j)
    j = j - 1
  END DO
END DO

nprob = nprob + 1
WRITE (unitgo,160) iter
GO TO 10

60 STOP

70   FORMAT (i5, A)
80   FORMAT ('        ','problem title ', '  ', A)
90   FORMAT (10I2)
100  FORMAT (' ifault=', i3)
110  FORMAT (/' beta(', i3, ')', f15.3)
120  FORMAT ('    ', 14('*'), 'sum of absolute values = ', f15.3)
130  FORMAT (//'   best results for lav subset of size = ', i3)
140  FORMAT (i5, i2, f6.2)
150  FORMAT (A)
160  FORMAT (//'     iteration count = ', i7)

END PROGRAM subl1


!mm
      subroutine matrix_multiplication('Add the arguments')

      implicit none

      'Define the arguments'

      integer :: i, j

      !$OMP PARALLEL DO
      do i = 1, n
          do j = 1, n
              C(j,i) = sum(A(:,j) * B(i,:))
          enddo
      enddo
      !$OMP END PARALLEL DO

      end subroutine matrix_multiplication


module mod_scal
  use mod_types
  implicit none
  private
  public scal
  contains
  subroutine scal(nx,ny,nz,dxi,dyi,dzi,dzci,dzfi,visc,u,v,w,s,dsdt)
    !
    !
    !
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi,dzi,visc
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), dimension(0:,0:,0:), intent(in) :: u,v,w,s
    real(rp), dimension(:,:,:), intent(out) :: dsdt
    integer :: i,j,k
    real(rp) :: usip,usim,vsjp,vsjm,wskp,wskm
    real(rp) :: dsdxp,dsdxm,dsdyp,dsdym,dsdzp,dsdzm
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(usip,usim,vsjp,vsjm,wskp,wskm) &
    !$OMP PRIVATE(dsdxp,dsdxm,dsdyp,dsdym,dsdzp,dsdzm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzi,visc,u,v,w,s,dsdt,dzci,dzfi)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          usim  = 0.5*( s(i-1,j,k)+s(i,j,k) )*u(i-1,j,k)
          usip  = 0.5*( s(i+1,j,k)+s(i,j,k) )*u(i  ,j,k)
          vsjm  = 0.5*( s(i,j-1,k)+s(i,j,k) )*v(i,j-1,k)
          vsjp  = 0.5*( s(i,j+1,k)+s(i,j,k) )*v(i,j  ,k)
          wskm  = 0.5*( s(i,j,k-1)+s(i,j,k) )*w(i,j,k-1)
          wskp  = 0.5*( s(i,j,k+1)+s(i,j,k) )*w(i,j,k  )
          dsdxp = (s(i+1,j,k)-s(i  ,j,k))*dxi
          dsdxm = (s(i  ,j,k)-s(i-1,j,k))*dxi
          dsdyp = (s(i,j+1,k)-s(i,j  ,k))*dyi
          dsdym = (s(i,j  ,k)-s(i,j-1,k))*dyi
          dsdzp = (s(i,j,k+1)-s(i,j,k  ))*dzci(k  )
          dsdzm = (s(i,j,k  )-s(i,j,k-1))*dzci(k-1)
          !
          dsdt(i,j,k) = dxi*(     -usip + usim ) + (dsdxp-dsdxm)*visc*dxi + &
                        dyi*(     -vsjp + vsjm ) + (dsdyp-dsdym)*visc*dyi + &
                        dzfi(k)*( -wskp + wskm ) + (dsdzp-dsdzm)*visc*dzfi(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
    return
  end subroutine scal
end module mod_scal


module quadrature
  public :: cdgqf, cgqf
  private :: gamma_func, class_matrix, imtqlx, parchk, scqf, sgqf

  contains

  subroutine cdgqf ( nt, rule, alpha, beta, t, wts )

  !*****************************************************************************80
  !
  !! CDGQF computes a Gauss quadrature formula with default A, B and simple knots.
  !
  !  Discussion:
  !
  !    This routine computes all the knots and weights of a Gauss quadrature
  !    formula with a classical weight function with default values for A and B,
  !    and only simple knots.
  !
  !    There are no moments checks and no printing is done.
  !
  !    Use routine EIQFS to evaluate a quadrature computed by CGQFS.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    04 January 2010
  !
  !  Author:
  !
  !    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    Sylvan Elhay, Jaroslav Kautsky,
  !    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
  !    Interpolatory Quadrature,
  !    ACM Transactions on Mathematical Software,
  !    Volume 13, Number 4, December 1987, pages 399-415.
  !
  !  Parameters:
  !
  !    Input, integer ( kind = 4 ) NT, the number of knots.
  !
  !    Input, integer ( kind = 4 ) RULE, the rule.
  !    1, Legendre,             (a,b)       1.0
  !    2, Chebyshev,            (a,b)       ((b-x)*(x-a))^(-0.5)
  !    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
  !    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
  !    5, Generalized Laguerre, (a,inf)     (x-a)^alpha*exp(-b*(x-a))
  !    6, Generalized Hermite,  (-inf,inf)  |x-a|^alpha*exp(-b*(x-a)^2)
  !    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
  !    8, Rational,             (a,inf)     (x-a)^alpha*(x+b)^beta
  !
  !    Input, real ( kind = 8 ) ALPHA, the value of Alpha, if needed.
  !
  !    Input, real ( kind = 8 ) BETA, the value of Beta, if needed.
  !
  !    Output, real ( kind = 8 ) T(NT), the knots.
  !
  !    Output, real ( kind = 8 ) WTS(NT), the weights.
  !
    implicit none

    integer ( kind = 4 ) nt

    real ( kind = 8 ) aj(nt)
    real ( kind = 8 ) alpha
    real ( kind = 8 ) beta
    real ( kind = 8 ) bj(nt)
    integer ( kind = 4 ) rule
    real ( kind = 8 ) t(nt)
    real ( kind = 8 ) wts(nt)
    real ( kind = 8 ) zemu

    call parchk ( rule, 2 * nt, alpha, beta )
  !
  !  Get the Jacobi matrix and zero-th moment.
  !
    call class_matrix ( rule, nt, alpha, beta, aj, bj, zemu )
  !
  !  Compute the knots and weights.
  !
    call sgqf ( nt, aj, bj, zemu, t, wts )

    return
  end subroutine cdgqf

  subroutine cgqf ( nt, rule, alpha, beta, a, b, t, wts )

  !*****************************************************************************80
  !
  !! CGQF computes knots and weights of a Gauss quadrature formula.
  !
  !  Discussion:
  !
  !    The user may specify the interval (A,B).
  !
  !    Only simple knots are produced.
  !
  !    Use routine EIQFS to evaluate this quadrature formula.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    16 February 2010
  !
  !  Author:
  !
  !    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    Sylvan Elhay, Jaroslav Kautsky,
  !    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
  !    Interpolatory Quadrature,
  !    ACM Transactions on Mathematical Software,
  !    Volume 13, Number 4, December 1987, pages 399-415.
  !
  !  Parameters:
  !
  !    Input, integer ( kind = 4 ) NT, the number of knots.
  !
  !    Input, integer ( kind = 4 ) rule, the rule.
  !    1, Legendre,             (a,b)       1.0
  !    2, Chebyshev Type 1,     (a,b)       ((b-x)*(x-a))^-0.5)
  !    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
  !    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
  !    5, Generalized Laguerre, (a,+oo)     (x-a)^alpha*exp(-b*(x-a))
  !    6, Generalized Hermite,  (-oo,+oo)   |x-a|^alpha*exp(-b*(x-a)^2)
  !    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
  !    8, Rational,             (a,+oo)     (x-a)^alpha*(x+b)^beta
  !    9, Chebyshev Type 2,     (a,b)       ((b-x)*(x-a))^(+0.5)
  !
  !    Input, real ( kind = 8 ) ALPHA, the value of Alpha, if needed.
  !
  !    Input, real ( kind = 8 ) BETA, the value of Beta, if needed.
  !
  !    Input, real ( kind = 8 ) A, B, the interval endpoints, or
  !    other parameters.
  !
  !    Output, real ( kind = 8 ) T(NT), the knots.
  !
  !    Output, real ( kind = 8 ) WTS(NT), the weights.
  !
    implicit none

    integer ( kind = 4 ) nt

    real ( kind = 8 ) a
    real ( kind = 8 ) alpha
    real ( kind = 8 ) b
    real ( kind = 8 ) beta
    integer ( kind = 4 ) i
    integer ( kind = 4 ) rule
    integer ( kind = 4 ), allocatable :: mlt(:)
    integer ( kind = 4 ), allocatable :: ndx(:)
    real ( kind = 8 ) t(nt)
    real ( kind = 8 ) wts(nt)
  !
  !  Compute the Gauss quadrature formula for default values of A and B.
  !
    call cdgqf ( nt, rule, alpha, beta, t, wts )
  !
  !  Prepare to scale the quadrature formula to other weight function with
  !  valid A and B.
  !
    allocate ( mlt(1:nt) )

    mlt(1:nt) = 1

    allocate ( ndx(1:nt) )

    do i = 1, nt
      ndx(i) = i
    end do

    call scqf ( nt, t, mlt, wts, nt, ndx, wts, t, rule, alpha, beta, a, b )

    deallocate ( mlt )
    deallocate ( ndx )

    return
  end subroutine cgqf

  function gamma_func ( x )
  !*****************************************************************************80
  !
  !! GAMMA_FUNC evaluates Gamma(X) for a real argument.
  !
  !  Discussion:
  !
  !    This routine calculates the gamma function for a real argument X.
  !
  !    Computation is based on an algorithm outlined in reference 1.
  !    The program uses rational functions that approximate the gamma
  !    function to at least 20 significant decimal digits.  Coefficients
  !    for the approximation over the interval (1,2) are unpublished.
  !    Those for the approximation for 12 <= X are from reference 2.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    11 February 2008
  !
  !  Author:
  !
  !    Original FORTRAN77 version by William Cody, Laura Stoltz.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    William Cody,
  !    An Overview of Software Development for Special Functions,
  !    in Numerical Analysis Dundee, 1975,
  !    edited by GA Watson,
  !    Lecture Notes in Mathematics 506,
  !    Springer, 1976.
  !
  !    John Hart, Ward Cheney, Charles Lawson, Hans Maehly,
  !    Charles Mesztenyi, John Rice, Henry Thatcher,
  !    Christoph Witzgall,
  !    Computer Approximations,
  !    Wiley, 1968,
  !    LC: QA297.C64.
  !
  !  Parameters:
  !
  !    Input, real ( kind = 8 ) X, the argument of the function.
  !
  !    Output, real ( kind = 8 ) gamma_func, the value of the function.
  !
    implicit none
    real ( kind = 8 ), dimension ( 7 ) :: c = (/ &
     -1.910444077728D-03, &
      8.4171387781295D-04, &
     -5.952379913043012D-04, &
      7.93650793500350248D-04, &
     -2.777777777777681622553D-03, &
      8.333333333333333331554247D-02, &
      5.7083835261D-03 /)
    real ( kind = 8 ), parameter :: eps = 2.22D-16
    real ( kind = 8 ) fact
    integer ( kind = 4 ) i
    integer ( kind = 4 ) n
    real ( kind = 8 ), dimension ( 8 ) :: p = (/ &
      -1.71618513886549492533811D+00, &
       2.47656508055759199108314D+01, &
      -3.79804256470945635097577D+02, &
       6.29331155312818442661052D+02, &
       8.66966202790413211295064D+02, &
      -3.14512729688483675254357D+04, &
      -3.61444134186911729807069D+04, &
       6.64561438202405440627855D+04 /)
    logical parity
    real ( kind = 8 ), parameter :: pi = 3.1415926535897932384626434D+00
    real ( kind = 8 ), dimension ( 8 ) :: q = (/ &
      -3.08402300119738975254353D+01, &
       3.15350626979604161529144D+02, &
      -1.01515636749021914166146D+03, &
      -3.10777167157231109440444D+03, &
       2.25381184209801510330112D+04, &
       4.75584627752788110767815D+03, &
      -1.34659959864969306392456D+05, &
      -1.15132259675553483497211D+05 /)
    real ( kind = 8 ) gamma_func
    real ( kind = 8 ) res
    real ( kind = 8 ), parameter :: sqrtpi = 0.9189385332046727417803297D+00
    real ( kind = 8 ) sum
    real ( kind = 8 ) x
    real ( kind = 8 ), parameter :: xbig = 171.624D+00
    real ( kind = 8 ) xden
    real ( kind = 8 ), parameter :: xinf = 1.0D+30
    real ( kind = 8 ), parameter :: xminin = 2.23D-308
    real ( kind = 8 ) xnum
    real ( kind = 8 ) y
    real ( kind = 8 ) y1
    real ( kind = 8 ) ysq
    real ( kind = 8 ) z

    parity = .false.
    fact = 1.0D+00
    n = 0
    y = x
  !
  !  Argument is negative.
  !
    if ( y <= 0.0D+00 ) then

      y = - x
      y1 = aint ( y )
      res = y - y1

      if ( res /= 0.0D+00 ) then

        if ( y1 /= aint ( y1 * 0.5D+00 ) * 2.0D+00 ) then
          parity = .true.
        end if

        fact = - pi / sin ( pi * res )
        y = y + 1.0D+00

      else

        res = xinf
        gamma_func = res
        return

      end if

    end if
  !
  !  Argument is positive.
  !
    if ( y < eps ) then
  !
  !  Argument < EPS.
  !
      if ( xminin <= y ) then
        res = 1.0D+00 / y
      else
        res = xinf
        gamma_func = res
        return
      end if

    else if ( y < 12.0D+00 ) then

      y1 = y
  !
  !  0.0 < argument < 1.0.
  !
      if ( y < 1.0D+00 ) then

        z = y
        y = y + 1.0D+00
  !
  !  1.0 < argument < 12.0.
  !  Reduce argument if necessary.
  !
      else

        n = int ( y ) - 1
        y = y - real ( n, kind = 8 )
        z = y - 1.0D+00

      end if
  !
  !  Evaluate approximation for 1.0 < argument < 2.0.
  !
      xnum = 0.0D+00
      xden = 1.0D+00
      do i = 1, 8
        xnum = ( xnum + p(i) ) * z
        xden = xden * z + q(i)
      end do

      res = xnum / xden + 1.0D+00
  !
  !  Adjust result for case  0.0 < argument < 1.0.
  !
      if ( y1 < y ) then

        res = res / y1
  !
  !  Adjust result for case 2.0 < argument < 12.0.
  !
      else if ( y < y1 ) then

        do i = 1, n
          res = res * y
          y = y + 1.0D+00
        end do

      end if

    else
  !
  !  Evaluate for 12.0 <= argument.
  !
      if ( y <= xbig ) then

        ysq = y * y
        sum = c(7)
        do i = 1, 6
          sum = sum / ysq + c(i)
        end do
        sum = sum / y - y + sqrtpi
        sum = sum + ( y - 0.5D+00 ) * log ( y )
        res = exp ( sum )

      else

        res = xinf
        gamma_func = res
        return

      end if

    end if
  !
  !  Final adjustments and return.
  !
    if ( parity ) then
      res = - res
    end if

    if ( fact /= 1.0D+00 ) then
      res = fact / res
    end if

    gamma_func = res

    return
  end function gamma_func

  subroutine class_matrix ( rule, m, alpha, beta, aj, bj, zemu )

  !*****************************************************************************80
  !
  !! CLASS_MATRIX computes the Jacobi matrix for a quadrature rule.
  !
  !  Discussion:
  !
  !    This routine computes the diagonal AJ and sub-diagonal BJ
  !    elements of the order M tridiagonal symmetric Jacobi matrix
  !    associated with the polynomials orthogonal with respect to
  !    the weight function specified by rule.
  !
  !    For weight functions 1-7, M elements are defined in BJ even
  !    though only M-1 are needed.  For weight function 8, BJ(M) is
  !    set to zero.
  !
  !    The zero-th moment of the weight function is returned in ZEMU.
  !
  !    Thanks to Larz White for pointing out that "class_matrix" had somehow
  !    been damaged to 'atrix', 02 February 2013.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    27 December 2009
  !
  !  Author:
  !
  !    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    Sylvan Elhay, Jaroslav Kautsky,
  !    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
  !    Interpolatory Quadrature,
  !    ACM Transactions on Mathematical Software,
  !    Volume 13, Number 4, December 1987, pages 399-415.
  !
  !  Parameters:
  !
  !    Input, integer ( kind = 4 ) rule, the rule.
  !    1, Legendre,             (a,b)       1.0
  !    2, Chebyshev,            (a,b)       ((b-x)*(x-a))^(-0.5)
  !    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
  !    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
  !    5, Generalized Laguerre, (a,inf)     (x-a)^alpha*exp(-b*(x-a))
  !    6, Generalized Hermite,  (-inf,inf)  |x-a|^alpha*exp(-b*(x-a)^2)
  !    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
  !    8, Rational,             (a,inf)     (x-a)^alpha*(x+b)^beta
  !
  !    Input, integer ( kind = 4 ) M, the order of the Jacobi matrix.
  !
  !    Input, real ( kind = 8 ) ALPHA, the value of Alpha, if needed.
  !
  !    Input, real ( kind = 8 ) BETA, the value of Beta, if needed.
  !
  !    Output, real ( kind = 8 ) AJ(M), BJ(M), the diagonal and subdiagonal
  !    of the Jacobi matrix.
  !
  !    Output, real ( kind = 8 ) ZEMU, the zero-th moment.
  !
    implicit none

    integer ( kind = 4 ) m

    real ( kind = 8 ) a2b2
    real ( kind = 8 ) ab
    real ( kind = 8 ) aba
    real ( kind = 8 ) abi
    real ( kind = 8 ) abj
    real ( kind = 8 ) abti
    real ( kind = 8 ) aj(m)
    real ( kind = 8 ) alpha
    real ( kind = 8 ) apone
    real ( kind = 8 ) beta
    real ( kind = 8 ) bj(m)
    integer ( kind = 4 ) i
    integer ( kind = 4 ) rule
    real ( kind = 8 ), parameter :: pi = 3.14159265358979323846264338327950D+00
    real ( kind = 8 ) temp
    real ( kind = 8 ) temp2
    real ( kind = 8 ) zemu

    temp = epsilon ( temp )

    call parchk ( rule, 2 * m - 1, alpha, beta )

    temp2 = gamma_func ( 0.5D+00 )

    if ( 500.0D+00 * temp < abs ( temp2 * temp2 - pi ) ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CLASS_MATRIX - Fatal error!'
      write ( *, '(a)' ) '  Gamma function does not match machine parameters.'
      stop
    end if

    if ( rule == 1 ) then

      ab = 0.0D+00

      zemu = 2.0D+00 / ( ab + 1.0D+00 )

      aj(1:m) = 0.0D+00

      do i = 1, m
        abi = i + ab * mod ( i, 2 )
        abj = 2 * i + ab
        bj(i) = abi * abi / ( abj * abj - 1.0D+00 )
      end do
      bj(1:m) =  sqrt ( bj(1:m) )

    else if ( rule == 2 ) then

      zemu = pi

      aj(1:m) = 0.0D+00

      bj(1) =  sqrt ( 0.5D+00 )
      bj(2:m) = 0.5D+00

    else if ( rule == 3 ) then

      ab = alpha * 2.0D+00
      zemu = 2.0D+00**( ab + 1.0D+00 ) * ( gamma_func ( alpha + 1.0D+00 ) )**2 &
        / gamma_func ( ab + 2.0D+00 )

      aj(1:m) = 0.0D+00
      bj(1) = 1.0D+00 / ( 2.0D+00 * alpha + 3.0D+00 )
      do i = 2, m
        bj(i) = i * ( i + ab ) &
          / ( 4.0D+00 * ( i + alpha ) * ( i + alpha ) - 1.0D+00 )
      end do
      bj(1:m) =  sqrt ( bj(1:m) )

    else if ( rule == 4 ) then

      ab = alpha + beta
      abi = 2.0D+00 + ab
      zemu = 2.0D+00**( ab + 1.0D+00 ) * gamma_func ( alpha + 1.0D+00 ) &
        * gamma_func ( beta + 1.0D+00 ) / gamma_func ( abi )
      aj(1) = ( beta - alpha ) / abi
      bj(1) = 4.0D+00 * ( 1.0 + alpha ) * ( 1.0D+00 + beta ) &
        / ( ( abi + 1.0D+00 ) * abi * abi )
      a2b2 = beta * beta - alpha * alpha

      do i = 2, m
        abi = 2.0D+00 * i + ab
        aj(i) = a2b2 / ( ( abi - 2.0D+00 ) * abi )
        abi = abi * abi
        bj(i) = 4.0D+00 * i * ( i + alpha ) * ( i + beta ) * ( i + ab ) &
          / ( ( abi - 1.0D+00 ) * abi )
      end do
      bj(1:m) =  sqrt ( bj(1:m) )

    else if ( rule == 5 ) then

      zemu = gamma_func ( alpha + 1.0D+00 )

      do i = 1, m
        aj(i) = 2.0D+00 * i - 1.0D+00 + alpha
        bj(i) = i * ( i + alpha )
      end do
      bj(1:m) =  sqrt ( bj(1:m) )

    else if ( rule == 6 ) then

      zemu = gamma_func ( ( alpha + 1.0D+00 ) / 2.0D+00 )

      aj(1:m) = 0.0D+00

      do i = 1, m
        bj(i) = ( i + alpha * mod ( i, 2 ) ) / 2.0D+00
      end do
      bj(1:m) =  sqrt ( bj(1:m) )

    else if ( rule == 7 ) then

      ab = alpha
      zemu = 2.0D+00 / ( ab + 1.0D+00 )

      aj(1:m) = 0.0D+00

      do i = 1, m
        abi = i + ab * mod ( i, 2 )
        abj = 2 * i + ab
        bj(i) = abi * abi / ( abj * abj - 1.0D+00 )
      end do
      bj(1:m) =  sqrt ( bj(1:m) )

    else if ( rule == 8 ) then

      ab = alpha + beta
      zemu = gamma_func ( alpha + 1.0D+00 ) * gamma_func ( - ( ab + 1.0D+00 ) ) &
        / gamma_func ( - beta )
      apone = alpha + 1.0D+00
      aba = ab * apone
      aj(1) = - apone / ( ab + 2.0D+00 )
      bj(1) = - aj(1) * ( beta + 1.0D+00 ) / ( ab + 2.0D+00 ) / ( ab + 3.0D+00 )
      do i = 2, m
        abti = ab + 2.0D+00 * i
        aj(i) = aba + 2.0D+00 * ( ab + i ) * ( i - 1 )
        aj(i) = - aj(i) / abti / ( abti - 2.0D+00 )
      end do

      do i = 2, m - 1
        abti = ab + 2.0D+00 * i
        bj(i) = i * ( alpha + i ) / ( abti - 1.0D+00 ) * ( beta + i ) &
          / ( abti * abti ) * ( ab + i ) / ( abti + 1.0D+00 )
      end do

      bj(m) = 0.0D+00
      bj(1:m) =  sqrt ( bj(1:m) )

    end if

    return
  end subroutine class_matrix

  subroutine imtqlx ( n, d, e, z )

  !*****************************************************************************80
  !
  !! IMTQLX diagonalizes a symmetric tridiagonal matrix.
  !
  !  Discussion:
  !
  !    This routine is a slightly modified version of the EISPACK routine to
  !    perform the implicit QL algorithm on a symmetric tridiagonal matrix.
  !
  !    The authors thank the authors of EISPACK for permission to use this
  !    routine.
  !
  !    It has been modified to produce the product Q' * Z, where Z is an input
  !    vector and Q is the orthogonal matrix diagonalizing the input matrix.
  !    The changes consist (essentially) of applying the orthogonal
  !    transformations directly to Z as they are generated.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    27 December 2009
  !
  !  Author:
  !
  !    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    Sylvan Elhay, Jaroslav Kautsky,
  !    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
  !    Interpolatory Quadrature,
  !    ACM Transactions on Mathematical Software,
  !    Volume 13, Number 4, December 1987, pages 399-415.
  !
  !    Roger Martin, James Wilkinson,
  !    The Implicit QL Algorithm,
  !    Numerische Mathematik,
  !    Volume 12, Number 5, December 1968, pages 377-383.
  !
  !  Parameters:
  !
  !    Input, integer ( kind = 4 ) N, the order of the matrix.
  !
  !    Input/output, real ( kind = 8 ) D(N), the diagonal entries of the matrix.
  !    On output, the information in D has been overwritten.
  !
  !    Input/output, real ( kind = 8 ) E(N), the subdiagonal entries of the
  !    matrix, in entries E(1) through E(N-1).  On output, the information in
  !    E has been overwritten.
  !
  !    Input/output, real ( kind = 8 ) Z(N).  On input, a vector.  On output,
  !    the value of Q' * Z, where Q is the matrix that diagonalizes the
  !    input symmetric tridiagonal matrix.
  !
    implicit none

    integer ( kind = 4 ) n

    real ( kind = 8 ) b
    real ( kind = 8 ) c
    real ( kind = 8 ) d(n)
    real ( kind = 8 ) e(n)
    real ( kind = 8 ) f
    real ( kind = 8 ) g
    integer ( kind = 4 ) i
    integer ( kind = 4 ) ii
    integer ( kind = 4 ), parameter :: itn = 30
    integer ( kind = 4 ) j
    integer ( kind = 4 ) k
    integer ( kind = 4 ) l
    integer ( kind = 4 ) m
    integer ( kind = 4 ) mml
    real ( kind = 8 ) p
    real ( kind = 8 ) prec
    real ( kind = 8 ) r
    real ( kind = 8 ) s
    real ( kind = 8 ) z(n)

    prec = epsilon ( prec )

    if ( n == 1 ) then
      return
    end if

    e(n) = 0.0D+00

    do l = 1, n

      j = 0

      do

        do m = l, n

          if ( m == n ) then
            exit
          end if

          if ( abs ( e(m) ) <= prec * ( abs ( d(m) ) + abs ( d(m+1) ) ) ) then
            exit
          end if

        end do

        p = d(l)

        if ( m == l ) then
          exit
        end if

        if ( itn <= j ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'IMTQLX - Fatal error!'
          write ( *, '(a)' ) '  Iteration limit exceeded.'
          write ( *, '(a,i8)' ) '  J = ', j
          write ( *, '(a,i8)' ) '  L = ', l
          write ( *, '(a,i8)' ) '  M = ', m
          write ( *, '(a,i8)' ) '  N = ', n
          stop
        end if

        j = j + 1
        g = ( d(l+1) - p ) / ( 2.0D+00 * e(l) )
        r =  sqrt ( g * g + 1.0D+00 )
        g = d(m) - p + e(l) / ( g + sign ( r, g ) )
        s = 1.0D+00
        c = 1.0D+00
        p = 0.0D+00
        mml = m - l

        do ii = 1, mml

          i = m - ii
          f = s * e(i)
          b = c * e(i)

          if ( abs ( g ) <= abs ( f ) ) then
            c = g / f
            r =  sqrt ( c * c + 1.0D+00 )
            e(i+1) = f * r
            s = 1.0D+00 / r
            c = c * s
          else
            s = f / g
            r =  sqrt ( s * s + 1.0D+00 )
            e(i+1) = g * r
            c = 1.0D+00 / r
            s = s * c
          end if

          g = d(i+1) - p
          r = ( d(i) - g ) * s + 2.0D+00 * 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
          z(i) = c * z(i) - s * f

        end do

        d(l) = d(l) - p
        e(l) = g
        e(m) = 0.0D+00

      end do

    end do
  !
  !  Sorting.
  !
    do ii = 2, n

      i = ii - 1
      k = i
      p = d(i)

      do j = ii, n
        if ( d(j) < p ) then
          k = j
          p = d(j)
        end if
      end do

      if ( k /= i ) then
        d(k) = d(i)
        d(i) = p
        p = z(i)
        z(i) = z(k)
        z(k) = p
      end if

    end do

    return
  end subroutine imtqlx

  subroutine parchk ( rule, m, alpha, beta )

  !*****************************************************************************80
  !
  !! PARCHK checks parameters ALPHA and BETA for classical weight functions.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    27 December 2009
  !
  !  Author:
  !
  !    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    Sylvan Elhay, Jaroslav Kautsky,
  !    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
  !    Interpolatory Quadrature,
  !    ACM Transactions on Mathematical Software,
  !    Volume 13, Number 4, December 1987, pages 399-415.
  !
  !  Parameters:
  !
  !    Input, integer ( kind = 4 ) rule, the rule.
  !    1, Legendre,             (a,b)       1.0
  !    2, Chebyshev,            (a,b)       ((b-x)*(x-a))^(-0.5)
  !    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
  !    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
  !    5, Generalized Laguerre, (a,inf)     (x-a)^alpha*exp(-b*(x-a))
  !    6, Generalized Hermite,  (-inf,inf)  |x-a|^alpha*exp(-b*(x-a)^2)
  !    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
  !    8, Rational,             (a,inf)     (x-a)^alpha*(x+b)^beta
  !
  !    Input, integer ( kind = 4 ) M, the order of the highest moment to
  !    be calculated.  This value is only needed when KIND = 8.
  !
  !    Input, real ( kind = 8 ) ALPHA, BETA, the parameters, if required
  !    by the value of KIND.
  !
    implicit none

    real ( kind = 8 ) alpha
    real ( kind = 8 ) beta
    integer ( kind = 4 ) rule
    integer ( kind = 4 ) m
    real ( kind = 8 ) tmp

    if ( rule <= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'PARCHK - Fatal error!'
      write ( *, '(a)' ) '  rule <= 0.'
      stop
    end if
  !
  !  Check ALPHA for Gegenbauer, Jacobi, Laguerre, Hermite, Exponential.
  !
    if ( 3 <= rule .and. alpha <= -1.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'PARCHK - Fatal error!'
      write ( *, '(a)' ) '  3 <= rule and ALPHA <= -1.'
      stop
    end if
  !
  !  Check BETA for Jacobi.
  !
    if ( rule == 4 .and. beta <= -1.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'PARCHK - Fatal error!'
      write ( *, '(a)' ) '  rule == 4 and BETA <= -1.0.'
      stop
    end if
  !
  !  Check ALPHA and BETA for rational.
  !
    if ( rule == 8 ) then
      tmp = alpha + beta + m + 1.0D+00
      if ( 0.0D+00 <= tmp .or. tmp <= beta ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'PARCHK - Fatal error!'
        write ( *, '(a)' ) '  rule == 8 but condition on ALPHA and BETA fails.'
        stop
      end if
    end if

    return
  end subroutine parchk

  subroutine scqf ( nt, t, mlt, wts, nwts, ndx, swts, st, rule, alpha, beta, a, &
    b )

  !*****************************************************************************80
  !
  !! SCQF scales a quadrature formula to a nonstandard interval.
  !
  !  Discussion:
  !
  !    The arrays WTS and SWTS may coincide.
  !
  !    The arrays T and ST may coincide.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    27 December 2009
  !
  !  Author:
  !
  !    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    Sylvan Elhay, Jaroslav Kautsky,
  !    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
  !    Interpolatory Quadrature,
  !    ACM Transactions on Mathematical Software,
  !    Volume 13, Number 4, December 1987, pages 399-415.
  !
  !  Parameters:
  !
  !    Input, integer ( kind = 4 ) NT, the number of knots.
  !
  !    Input, real ( kind = 8 ) T(NT), the original knots.
  !
  !    Input, integer ( kind = 4 ) MLT(NT), the multiplicity of the knots.
  !
  !    Input, real ( kind = 8 ) WTS(NWTS), the weights.
  !
  !    Input, integer ( kind = 4 ) NWTS, the number of weights.
  !
  !    Input, integer ( kind = 4 ) NDX(NT), used to index the array WTS.
  !    For more details see the comments in CAWIQ.
  !
  !    Output, real ( kind = 8 ) SWTS(NWTS), the scaled weights.
  !
  !    Output, real ( kind = 8 ) ST(NT), the scaled knots.
  !
  !    Input, integer ( kind = 4 ) rule, the rule.
  !    1, Legendre,             (a,b)       1.0
  !    2, Chebyshev Type 1,     (a,b)       ((b-x)*(x-a))^(-0.5)
  !    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
  !    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
  !    5, Generalized Laguerre, (a,+oo)     (x-a)^alpha*exp(-b*(x-a))
  !    6, Generalized Hermite,  (-oo,+oo)   |x-a|^alpha*exp(-b*(x-a)^2)
  !    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
  !    8, Rational,             (a,+oo)     (x-a)^alpha*(x+b)^beta
  !    9, Chebyshev Type 2,     (a,b)       ((b-x)*(x-a))^(+0.5)
  !
  !    Input, real ( kind = 8 ) ALPHA, the value of Alpha, if needed.
  !
  !    Input, real ( kind = 8 ) BETA, the value of Beta, if needed.
  !
  !    Input, real ( kind = 8 ) A, B, the interval endpoints.
  !
    implicit none

    integer ( kind = 4 ) nt
    integer ( kind = 4 ) nwts

    real ( kind = 8 ) a
    real ( kind = 8 ) al
    real ( kind = 8 ) alpha
    real ( kind = 8 ) b
    real ( kind = 8 ) be
    real ( kind = 8 ) beta
    integer ( kind = 4 ) i
    integer ( kind = 4 ) k
    integer ( kind = 4 ) rule
    integer ( kind = 4 ) l
    integer ( kind = 4 ) mlt(nt)
    integer ( kind = 4 ) ndx(nt)
    real ( kind = 8 ) p
    real ( kind = 8 ) shft
    real ( kind = 8 ) slp
    real ( kind = 8 ) st(nt)
    real ( kind = 8 ) swts(nwts)
    real ( kind = 8 ) t(nt)
    real ( kind = 8 ) temp
    real ( kind = 8 ) tmp
    real ( kind = 8 ) wts(nwts)

    temp = epsilon ( temp )

    call parchk ( rule, 1, alpha, beta )

    if ( rule == 1 ) then

      al = 0.0D+00
      be = 0.0D+00

      if ( abs ( b - a ) <= temp ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  |B - A| too small.'
        stop
      end if

      shft = ( a + b ) / 2.0D+00
      slp = ( b - a ) / 2.0D+00

    else if ( rule == 2 ) then

      al = -0.5D+00
      be = -0.5D+00

      if ( abs ( b - a ) <= temp ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  |B - A| too small.'
        stop
      end if

      shft = ( a + b ) / 2.0D+00
      slp = ( b - a ) / 2.0D+00

    else if ( rule == 3 ) then

      al = alpha
      be = alpha

      if ( abs ( b - a ) <= temp ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  |B - A| too small.'
        stop
      end if

      shft = ( a + b ) / 2.0D+00
      slp = ( b - a ) / 2.0D+00

    else if ( rule == 4 ) then

      al = alpha
      be = beta

      if ( abs ( b - a ) <= temp ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  |B - A| too small.'
        stop
      end if

      shft = ( a + b ) / 2.0D+00
      slp = ( b - a ) / 2.0D+00

    else if ( rule == 5 ) then

      if ( b <= 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  B <= 0'
        stop
      end if

      shft = a
      slp = 1.0D+00 / b
      al = alpha
      be = 0.0D+00

    else if ( rule == 6 ) then

      if ( b <= 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  B <= 0.'
        stop
      end if

      shft = a
      slp = 1.0D+00 / sqrt ( b )
      al = alpha
      be = 0.0D+00

    else if ( rule == 7 ) then

      al = alpha
      be = 0.0D+00

      if ( abs ( b - a ) <= temp ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  |B - A| too small.'
        stop
      end if

      shft = ( a + b ) / 2.0D+00
      slp = ( b - a ) / 2.0D+00

    else if ( rule == 8 ) then

      if ( a + b <= 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  A + B <= 0.'
        stop
      end if

      shft = a
      slp = a + b
      al = alpha
      be = beta

    else if ( rule == 9 ) then

      al = 0.5D+00
      be = 0.5D+00

      if ( abs ( b - a ) <= temp ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'SCQF - Fatal error!'
        write ( *, '(a)' ) '  |B - A| too small.'
        stop
      end if

      shft = ( a + b ) / 2.0D+00
      slp = ( b - a ) / 2.0D+00

    end if

    p = slp**( al + be + 1.0D+00 )

    do k = 1, nt

      st(k) = shft + slp * t(k)
      l = abs ( ndx(k) )

      if ( l /= 0 ) then
        tmp = p
        do i = l, l + mlt(k) - 1
          swts(i) = wts(i) * tmp
          tmp = tmp * slp
        end do
      end if

    end do

    return
  end subroutine scqf

  subroutine sgqf ( nt, aj, bj, zemu, t, wts )

  !*****************************************************************************80
  !
  !! SGQF computes knots and weights of a Gauss Quadrature formula.
  !
  !  Discussion:
  !
  !    This routine computes all the knots and weights of a Gauss quadrature
  !    formula with simple knots from the Jacobi matrix and the zero-th
  !    moment of the weight function, using the Golub-Welsch technique.
  !
  !  Licensing:
  !
  !    This code is distributed under the GNU LGPL license.
  !
  !  Modified:
  !
  !    04 January 2010
  !
  !  Author:
  !
  !    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
  !    FORTRAN90 version by John Burkardt.
  !
  !  Reference:
  !
  !    Sylvan Elhay, Jaroslav Kautsky,
  !    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
  !    Interpolatory Quadrature,
  !    ACM Transactions on Mathematical Software,
  !    Volume 13, Number 4, December 1987, pages 399-415.
  !
  !  Parameters:
  !
  !    Input, integer ( kind = 4 ) NT, the number of knots.
  !
  !    Input, real ( kind = 8 ) AJ(NT), the diagonal of the Jacobi matrix.
  !
  !    Input/output, real ( kind = 8 ) BJ(NT), the subdiagonal of the Jacobi
  !    matrix, in entries 1 through NT-1.  On output, BJ has been overwritten.
  !
  !    Input, real ( kind = 8 ) ZEMU, the zero-th moment of the weight function.
  !
  !    Output, real ( kind = 8 ) T(NT), the knots.
  !
  !    Output, real ( kind = 8 ) WTS(NT), the weights.
  !
    implicit none

    integer ( kind = 4 ) nt

    real ( kind = 8 ) aj(nt)
    real ( kind = 8 ) bj(nt)
    integer ( kind = 4 ) i
    real ( kind = 8 ) t(nt)
    real ( kind = 8 ) wts(nt)
    real ( kind = 8 ) zemu
  !
  !  Exit if the zero-th moment is not positive.
  !
    if ( zemu <= 0.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SGQF - Fatal error!'
      write ( *, '(a)' ) '  ZEMU <= 0.'
      stop
    end if
  !
  !  Set up vectors for IMTQLX.
  !
    t(1:nt) = aj(1:nt)

    wts(1) = sqrt ( zemu )
    wts(2:nt) = 0.0D+00
  !
  !  Diagonalize the Jacobi matrix.
  !
    call imtqlx ( nt, t, bj, wts )

    wts(1:nt) = wts(1:nt)**2

    return
  end subroutine sgqf
end module quadrature


module p_e1      ! Модуль рассчёта E_1 на четверной точности
implicit none

contains

real(16) function e141_r16(x)           ! Функция e141(x) вычисляет для
implicit none                           ! аргумента (x) значение первой
real(16) x,w,g                          ! интегрально-показательной
data g /.57721566490153286061_16 /      ! функции E1(x).
if (x .ge. 5.0_16) then                 ! Расчёт ведется на основе известных
        w=e141c_r16(x)/x*exp(-x)        ! разложений E1(x) в ряд по полиномам
else                                    ! Чебышева (см. книгу Люка:
        if (x .gt. 0.0_16) then         ! Специальные математические
                w=e141a_r16(x)-g-log(x) !  функции и их аппроксимации.
        else                            ! Издательство "МИР". Москва, 1980.
        w=1.0_16                        ! стр. 112-113 (таблица 4.1).
        endif
endif
e141_r16=w
end function e141_r16

real(16) function e141a_r16(x)        ! Функция e141a(x) вычисляет для заданного аргумента
implicit none                         ! ( 0 <= x <= 8 ) значение E1(x)+gamma+ln(x) через
real(16) x                            ! разложение в ряд по смещенным полиномам Чебышева.
real(16) a(0:24)                      ! Коэффициенты разложения взяты из книги  Ю.Люка
real(16) w,z                          ! Специальные математические функции и их
real(16) b0, b1, b2                   ! аппроксимации. Издательство "МИР". Москва, 1980.
integer  i                            !                          стр. 112 (таблица 4.1).

data a / 1.67391435474272057853_16, &
      &  1.22849447854715595018_16, & ! Здесь:
      & -0.31786989829837361369_16, & !     E1(x) - первая интегрально-
      &  0.09274603919729219112_16, & !             показательная
      & -0.02602736316900119930_16, & !             функция;
      &  0.00674815309464228057_16, &
      & -0.00159897068934225285_16, & ! gamma=0.57721566490153286061
      &  0.00034594453880095403_16, & ! (постоянная Эйлера)
      & -0.00006853652682011094_16, &
      &  0.00001248593239173701_16, &
      & -0.00000210134463871704_16, &
      &  0.00000032818447981081_16, &
      & -0.00000004776878645154_16, &
      &  0.00000000650581688192_16, &
      & -0.00000000083210193692_16, &
      &  0.00000000010028101125_16, &
      & -0.00000000001142229304_16, &
      &  0.00000000000123307945_16, &
      & -0.00000000000012648523_16, &
      &  0.00000000000001235706_16, &
      & -0.00000000000000115226_16, &
      &  0.00000000000000010276_16, &
      & -0.00000000000000000878_16, &
      &  0.00000000000000000072_16, &
      & -0.00000000000000000006_16 /

w=0.125_16*x
z=4.0_16*w-2.0_16
b0=0.0_16
b1=0.0_16

do i=24, 0, -1
        b2=b1
        b1=b0
        b0=z*b1-b2+a(i)
enddo

e141a_r16=b0-b1*z/2.0_16

end function e141a_r16

real(16) function e141c_r16(x)        ! Функция e141c(x) вычисляет для заданного аргумента
implicit none                         ! ( x >= 5 ) значение выражения E1(x)*exp(x)*x через
real(16) x                            ! его разложение в ряд по смещённым полиномам Чебышева.
real(16) c(0:30)                      ! Коэффициенты разложения взяты из книги
real(16) w,z                          ! Ю.Люка  Специальные математические функции и их
real(16) b0,b1,b2                     ! аппроксимации. Издательство "МИР". Москва, 1980.
integer i                             !                          стр. 112-113 (таблица 4.1 (c)).

data c / 0.92078514445389391645_16, &
      & -0.07343411783162128775_16, &
      &  0.00520981196727232977_16, &
      & -0.00050214071989599012_16, &
      &  0.00005920796937926337_16, &
      & -0.00000808564513097880_16, &
      &  0.00000123720385647926_16, &
      & -0.00000020750176860703_16, &
      &  0.00000003756005474022_16, &
      & -0.00000000725410976004_16, &
      &  0.00000000148181601182_16, &
      & -0.00000000031795682863_16, &
      &  0.00000000007126935828_16, &
      & -0.00000000001661231319_16, &
      &  0.00000000000401155069_16, &
      & -0.00000000000100038792_16, &
      &  0.00000000000025693341_16, &
      & -0.00000000000006780374_16, &
      &  0.00000000000001834785_16, &
      & -0.00000000000000508209_16, &
      &  0.00000000000000143861_16, &
      & -0.00000000000000041560_16, &
      &  0.00000000000000012238_16, &
      & -0.00000000000000003669_16, &
      &  0.00000000000000001119_16, &
      & -0.00000000000000000347_16, &
      &  0.00000000000000000109_16, &
      & -0.00000000000000000035_16, &
      &  0.00000000000000000011_16, &
      & -0.00000000000000000004_16, &
      &  0.00000000000000000001_16 /

w=5.0_16/x
z=4.0_16*w-2.0_16
b0=0.0_16
b1=0.0_16

do i=30, 0, -1
        b2=b1
        b1=b0
        b0=z*b1-b2+c(i)
enddo

e141c_r16=b0-b1*z/2.0_16

end function e141c_r16

end module p_e1


program test_randint
  integer(16) :: test, randint, num1, num2
  num1 = 1
  num2 = 100

  test = randint(num1, num2)

  print *, test, " is the random number that was generated"

end program test_randint

function randint(from, to) result (random_int)
    implicit none
    integer(16), intent(in) :: from, to
    integer(16) :: random_int
    real :: RNG1

    call random_seed()
    call random_number(RNG1)

    random_int = int(from + int(RNG1 * (to - from + 1)))

end function randint