diff --git a/bin/Makefile b/bin/Makefile new file mode 100644 index 0000000..ecdf68c --- /dev/null +++ b/bin/Makefile @@ -0,0 +1,32 @@ +#$Id: Makefile $ + +.SUFFIXES: .f90 .o + +# Compilers + +# Laptop: +FC = gfortran +FFLAGS = -fstack-check -g -O2 +LIBS = -L/usr/local/lib -llapack +#LIBS = -L/usr/local/lib -llapack -lrefblas + +MAIN1 = beta_and_derivatives.o +OBJS1 = secant.o quadpack_double.o +MODS1 = module.o +EXEC1 = beta_and_derivatives + +MAIN2 = schmidt_decomposition.o +OBJS2 = diasym.o SVD.o inverse_matrice.o +EXEC2 = schmidt_decomposition + +##################### End of Configurable Options ############### +all: beta_and_derivatives schmidt_decomposition + +beta_and_derivatives: ${MODS1} ${OBJS1} ${MAIN1} Makefile + ${FC} ${FFLAGS} -o ${EXEC1} ${MAIN1} ${OBJS1} ${MODS1} ${LIBS} + +schmidt_decomposition: ${OBJS2} ${MAIN2} Makefile + ${FC} ${FFLAGS} -o ${EXEC2} ${MAIN2} ${OBJS2} ${LIBS} + +.f90.o: ${MODS1} Makefile + ${FC} ${FFLAGS} -c $< diff --git a/bin/SVD.f90 b/bin/SVD.f90 new file mode 100644 index 0000000..2318f9f --- /dev/null +++ b/bin/SVD.f90 @@ -0,0 +1,38 @@ + SUBROUTINE SVD(A,U,S,S_matrix,V,M,N) + DOUBLE PRECISION:: A(M,N),U(M,M),VT(N,N),S(N),V(N,N),S_matrix(M,M) +! +! Program computes the matrix singular value decomposition. +! Using Lapack library. +! +! Programmed by sukhbinder Singh +! 14th January 2011 +! + + + DOUBLE PRECISION,ALLOCATABLE :: WORK(:) + INTEGER LDA,M,N,LWORK,LDVT,INFO + CHARACTER JOBU, JOBVT + + JOBU='A' + JOBVT='A' + LDA=M + LDU=M + LDVT=N + + LWORK=MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) + + ALLOCATE(work(lwork)) + + CALL DGESVD(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,WORK, & + LWORK, INFO ) + + DO I=1,LDVT + DO J=1,LDVT + V(I,J)=VT(J,I) + END DO + END DO + S_matrix=0 + DO I=1,LDU + S_matrix(I,I)=S(I) + ENDDO + END SUBROUTINE SVD diff --git a/bin/beta_and_derivatives.f90 b/bin/beta_and_derivatives.f90 new file mode 100644 index 0000000..d2d67b7 --- /dev/null +++ b/bin/beta_and_derivatives.f90 @@ -0,0 +1,57 @@ +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +program beta_and_derivatives + +!---------------! + ! + ! ==== Global Data ==== + ! + USE beta_module + ! + ! ==== Local Data ==== + ! + +real(dp) :: a +real(dp) :: b +real(dp) :: U,t +real(dp) :: x,beta,dbetadt,dbetadU +real(dp),parameter :: tol=1.0e-9_dp +integer,parameter :: maxiter=300 +integer :: iter +integer :: ier + +read(*,*) U,t + +a = 1.0_dp +b = 2.0_dp + +U_tmp=U +t_tmp=t +call secant(f,a,b,x,tol,maxiter,iter,ier) +beta = x + +a = 1.0_dp +b = 2.0_dp +U_tmp=U+0.000001_dp +t_tmp=t +call secant(f,a,b,x,tol,maxiter,iter,ier) +dbetadU=(x-beta)/0.000001_dp +U_tmp=U + +open (97, file='beta_dbetadU.dat',access='sequential') + write(97,15) beta,dbetadU +close(97) + + 15 format(f15.10,f15.10,f15.10) +end program diff --git a/bin/diasym.f90 b/bin/diasym.f90 new file mode 100644 index 0000000..08f9ad5 --- /dev/null +++ b/bin/diasym.f90 @@ -0,0 +1,19 @@ +!---------------------------------------------------------! +!Calls the LAPACK diagonalization subroutine DSYEV ! +!input: a(n,n) = real symmetric matrix to be diagonalized! +! n = size of a ! +!output: a(n,n) = orthonormal eigenvectors of a ! +! eig(n) = eigenvalues of a in ascending order ! +!---------------------------------------------------------! +!--------------------------! + subroutine diasym(a,eig,n) + implicit none + + integer n,l,inf + real*8 a(n,n),eig(n),work(n*(3+n/2)) + + l=n*(3+n/2) + call dsyev('V','U',n,a,n,eig,work,l,inf) + + end subroutine diasym +!---------------------! diff --git a/bin/inverse_matrice.f90 b/bin/inverse_matrice.f90 new file mode 100644 index 0000000..01b4e17 --- /dev/null +++ b/bin/inverse_matrice.f90 @@ -0,0 +1,79 @@ +subroutine inverse(a,c,n) +!============================================================ +! Inverse matrix +! Method: Based on Doolittle LU factorization for Ax=b +! Alex G. December 2009 +!----------------------------------------------------------- +! input ... +! a(n,n) - array of coefficients for matrix A +! n - dimension +! output ... +! c(n,n) - inverse matrix of A +! comments ... +! the original matrix a(n,n) will be destroyed +! during the calculation +!=========================================================== +implicit none +integer n +double precision a(n,n), c(n,n) +double precision L(n,n), U(n,n), b(n), d(n), x(n) +double precision coeff +integer i, j, k + +! step 0: initialization for matrices L and U and b +! Fortran 90/95 aloows such operations on matrices +L=0.0 +U=0.0 +b=0.0 + +! step 1: forward elimination +do k=1, n-1 + do i=k+1,n + coeff=a(i,k)/a(k,k) + L(i,k) = coeff + do j=k+1,n + a(i,j) = a(i,j)-coeff*a(k,j) + end do + end do +end do + +! Step 2: prepare L and U matrices +! L matrix is a matrix of the elimination coefficient +! + the diagonal elements are 1.0 +do i=1,n + L(i,i) = 1.0 +end do +! U matrix is the upper triangular part of A +do j=1,n + do i=1,j + U(i,j) = a(i,j) + end do +end do + +! Step 3: compute columns of the inverse matrix C +do k=1,n + b(k)=1.0 + d(1) = b(1) +! Step 3a: Solve Ld=b using the forward substitution + do i=2,n + d(i)=b(i) + do j=1,i-1 + d(i) = d(i) - L(i,j)*d(j) + end do + end do +! Step 3b: Solve Ux=d using the back substitution + x(n)=d(n)/U(n,n) + do i = n-1,1,-1 + x(i) = d(i) + do j=n,i+1,-1 + x(i)=x(i)-U(i,j)*x(j) + end do + x(i) = x(i)/u(i,i) + end do +! Step 3c: fill the solutions x(n) into column k of C + do i=1,n + c(i,k) = x(i) + end do + b(k)=0.0 +end do +end subroutine inverse diff --git a/bin/module.f90 b/bin/module.f90 new file mode 100644 index 0000000..0c2bb9b --- /dev/null +++ b/bin/module.f90 @@ -0,0 +1,50 @@ +module beta_module + +integer,parameter :: dp=kind(1.d0) +real, parameter :: Pi=3.14159265358979323846264338327950288419716939937510 +real(dp) :: t_tmp,U_tmp + +contains +function integrand(x) result(res) + +real(dp),intent(in) :: x +real(dp) :: res +real(dp) :: num,den + +num = bessel_j0(x)*bessel_j1(x) +den = x*(1.0_dp + exp(x*U_tmp/2.0_dp/t_tmp)) + +res = num/den + +end function + +function f(x) result(res) + +real(dp),intent(in) :: x +real(dp) :: res +real(dp) :: a,b + +integer,parameter :: limit=1000 +integer,parameter :: lenw=limit*4 +real(dp) :: abserr +real(dp),parameter :: epsabs=0.0_dp +real(dp),parameter :: epsrel=0.00001_dp +integer :: ier +integer :: iwork(limit) +integer,parameter :: inf=1 +integer :: last +integer :: neval +real(dp) :: work(lenw) + +! double, quadrature de Gauss pour integrer de 0 a inf. (inf = 1 +! equivaut a infini +call dqagi(integrand,0.0_dp,inf,epsabs,epsrel,a,abserr,neval, & + ier,limit,lenw,last,iwork,work) + +b = -sin(Pi/x)*2.0_dp*t_tmp*x/Pi + +res = b + 4.0_dp*t_tmp*a + +end function + +end module beta_module diff --git a/bin/quadpack_double.f90 b/bin/quadpack_double.f90 new file mode 100644 index 0000000..1312342 --- /dev/null +++ b/bin/quadpack_double.f90 @@ -0,0 +1,8848 @@ +subroutine dgtsl ( n, c, d, e, b, info ) + +!*****************************************************************************80 +! +!! DGTSL solves a general tridiagonal linear system. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 May 2005 +! +! Author: +! +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, +! LINPACK User's Guide, +! SIAM, 1979, +! ISBN13: 978-0-898711-72-1, +! LC: QA214.L56. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the order of the tridiagonal matrix. +! +! Input/output, real ( kind = 8 ) C(N), contains the subdiagonal of the +! tridiagonal matrix in entries C(2:N). On output, C is destroyed. +! +! Input/output, real ( kind = 8 ) D(N). On input, the diagonal of the +! matrix. On output, D is destroyed. +! +! Input/output, real ( kind = 8 ) E(N), contains the superdiagonal of the +! tridiagonal matrix in entries E(1:N-1). On output E is destroyed. +! +! Input/output, real ( kind = 8 ) B(N). On input, the right hand side. +! On output, the solution. +! +! Output, integer ( kind = 4 ) INFO, error flag. +! 0, normal value. +! K, the K-th element of the diagonal becomes exactly zero. The +! routine returns if this error condition is detected. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) b(n) + real ( kind = 8 ) c(n) + real ( kind = 8 ) d(n) + real ( kind = 8 ) e(n) + integer ( kind = 4 ) info + integer ( kind = 4 ) k + real ( kind = 8 ) t + + info = 0 + c(1) = d(1) + + if ( 2 <= n ) then + + d(1) = e(1) + e(1) = 0.0D+00 + e(n) = 0.0D+00 + + do k = 1, n - 1 +! +! Find the larger of the two rows. +! + if ( abs ( c(k) ) <= abs ( c(k+1) ) ) then +! +! Interchange rows. +! + t = c(k+1) + c(k+1) = c(k) + c(k) = t + + t = d(k+1) + d(k+1) = d(k) + d(k) = t + + t = e(k+1) + e(k+1) = e(k) + e(k) = t + + t = b(k+1) + b(k+1) = b(k) + b(k) = t + + end if +! +! Zero elements. +! + if ( c(k) == 0.0D+00 ) then + info = k + return + end if + + t = -c(k+1) / c(k) + c(k+1) = d(k+1) + t * d(k) + d(k+1) = e(k+1) + t * e(k) + e(k+1) = 0.0D+00 + b(k+1) = b(k+1) + t * b(k) + + end do + + end if + + if ( c(n) == 0.0D+00 ) then + info = n + return + end if +! +! Back solve. +! + b(n) = b(n) / c(n) + + if ( 1 < n ) then + + b(n-1) = ( b(n-1) - d(n-1) * b(n) ) / c(n-1) + + do k = n-2, 1, -1 + b(k) = ( b(k) - d(k) * b(k+1) - e(k) * b(k+2) ) / c(k) + end do + + end if + + return +end +subroutine dqage ( f, a, b, epsabs, epsrel, key, limit, result, abserr, & + neval, ier, alist, blist, rlist, elist, iord, last ) + +!*****************************************************************************80 +! +!! DQAGE estimates a definite integral. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-reslt).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! key - integer ( kind = 4 ) +! key for choice of local integration rule +! a gauss-kronrod pair is used with +! 7 - 15 points if key.lt.2, +! 10 - 21 points if key = 2, +! 15 - 31 points if key = 3, +! 20 - 41 points if key = 4, +! 25 - 51 points if key = 5, +! 30 - 61 points if key.gt.5. +! +! limit - integer ( kind = 4 ) +! gives an upperbound on the number of subintervals +! in the partition of (a,b), limit.ge.1. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for result and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value +! of limit. +! however, if this yields no improvement it +! is rather advised to analyze the integrand +! in order to determine the integration +! difficulties. if the position of a local +! difficulty can be determined(e.g. +! singularity, discontinuity within the +! interval) one will probably gain from +! splitting up the interval at this point +! and calling the integrator on the +! subranges. if possible, an appropriate +! special-purpose integrator should be used +! which is designed for handling the type of +! difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 6 the input is invalid, because +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! result, abserr, neval, last, rlist(1) , +! elist(1) and iord(1) are set to zero. +! alist(1) and blist(1) are set to a and b +! respectively. +! +! alist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the left +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! blist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the right +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! rlist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the +! integral approximations on the subintervals +! +! elist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! iord - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which are pointers to the +! error estimates over the subintervals, +! such that elist(iord(1)), ..., +! elist(iord(k)) form a decreasing sequence, +! with k = last if last.le.(limit/2+2), and +! k = limit+1-last otherwise +! +! last - integer ( kind = 4 ) +! number of subintervals actually produced in the +! subdivision process +! +! Local Parameters: +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest +! error estimate +! errmax - elist(maxerr) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,abserr,alist,area,area1,area12,area2,a1,a2,b, & + blist,b1,b2,defabs,defab1,defab2,elist,epmach, & + epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f, & + resabs,result,rlist,uflow + integer ( kind = 4 ) ier,iord,iroff1,iroff2,k,key,keyf,last,limit, & + maxerr, nrmax, neval + + dimension alist(limit),blist(limit),elist(limit),iord(limit), & + rlist(limit) + + external f + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) +! +! test on validity of parameters +! + ier = 0 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0D+00 + elist(1) = 0.0D+00 + iord(1) = 0 + + if(epsabs.le.0.0D+00.and. & + epsrel.lt. max ( 0.5D+02*epmach,0.5d-28)) then + ier = 6 + return + end if +! +! first approximation to the integral +! + keyf = key + if(key.le.0) keyf = 1 + if(key.ge.7) keyf = 6 + neval = 0 + if(keyf.eq.1) call dqk15(f,a,b,result,abserr,defabs,resabs) + if(keyf.eq.2) call dqk21(f,a,b,result,abserr,defabs,resabs) + if(keyf.eq.3) call dqk31(f,a,b,result,abserr,defabs,resabs) + if(keyf.eq.4) call dqk41(f,a,b,result,abserr,defabs,resabs) + if(keyf.eq.5) call dqk51(f,a,b,result,abserr,defabs,resabs) + if(keyf.eq.6) call dqk61(f,a,b,result,abserr,defabs,resabs) + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 +! +! test on accuracy. +! + errbnd = max ( epsabs, epsrel* abs ( result ) ) + + if(abserr.le.0.5D+02* epmach * defabs .and. & + abserr.gt.errbnd) then + ier = 2 + end if + + if(limit.eq.1) then + ier = 1 + end if + + if ( ier .ne. 0 .or. & + (abserr .le. errbnd .and. abserr .ne. resabs ) .or. & + abserr .eq. 0.0D+00 ) then + + if(keyf.ne.1) then + neval = (10*keyf+1)*(2*neval+1) + else + neval = 30*neval+15 + end if + + return + + end if +! +! initialization +! + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 +! +! main do-loop +! + do last = 2, limit +! +! bisect the subinterval with the largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5D+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + + if(keyf.eq.1) call dqk15(f,a1,b1,area1,error1,resabs,defab1) + if(keyf.eq.2) call dqk21(f,a1,b1,area1,error1,resabs,defab1) + if(keyf.eq.3) call dqk31(f,a1,b1,area1,error1,resabs,defab1) + if(keyf.eq.4) call dqk41(f,a1,b1,area1,error1,resabs,defab1) + if(keyf.eq.5) call dqk51(f,a1,b1,area1,error1,resabs,defab1) + if(keyf.eq.6) call dqk61(f,a1,b1,area1,error1,resabs,defab1) + + if(keyf.eq.1) call dqk15(f,a2,b2,area2,error2,resabs,defab2) + if(keyf.eq.2) call dqk21(f,a2,b2,area2,error2,resabs,defab2) + if(keyf.eq.3) call dqk31(f,a2,b2,area2,error2,resabs,defab2) + if(keyf.eq.4) call dqk41(f,a2,b2,area2,error2,resabs,defab2) + if(keyf.eq.5) call dqk51(f,a2,b2,area2,error2,resabs,defab2) + if(keyf.eq.6) call dqk61(f,a2,b2,area2,error2,resabs,defab2) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + neval = neval+1 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + + if ( defab1 .ne. error1 .and. defab2 .ne. error2 ) then + + if( abs ( rlist(maxerr)-area12).le.0.1D-04* abs ( area12) & + .and. erro12.ge.0.99D+00*errmax) then + iroff1 = iroff1+1 + end if + + if(last.gt.10.and.erro12.gt.errmax) then + iroff2 = iroff2+1 + end if + + end if + + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = max ( epsabs,epsrel* abs ( area)) + + if ( errbnd .lt. errsum ) then +! +! test for roundoff error and eventually set error flag. +! + if(iroff1.ge.6.or.iroff2.ge.20) then + ier = 2 + end if +! +! set error flag in the case that the number of subintervals +! equals limit. +! + if(last.eq.limit) then + ier = 1 + end if +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if( max ( abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03* & + epmach)*( abs ( a2)+0.1D+04*uflow)) then + ier = 3 + end if + + end if +! +! append the newly-created intervals to the list. +! + if(error2.le.error1) then + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + else + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + end if +! +! call dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with the largest error estimate (to be bisected next). +! + call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + + if(ier.ne.0.or.errsum.le.errbnd) then + exit + end if + + end do +! +! compute final result. +! + result = 0.0D+00 + do k=1,last + result = result+rlist(k) + end do + abserr = errsum + + if(keyf.ne.1) then + neval = (10*keyf+1)*(2*neval+1) + else + neval = 30*neval+15 + end if + + return +end +subroutine dqag ( f, a, b, epsabs, epsrel, key, result, abserr, neval, ier, & + limit, lenw, last, iwork, work ) + +!*****************************************************************************80 +! +!! DQAG approximates an integral over a finite interval. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result)le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! f - real ( kind = 8 ) +! function subprogam defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! epsabs - real ( kind = 8 ) +! absolute accoracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! key - integer ( kind = 4 ) +! key for choice of local integration rule +! a gauss-kronrod pair is used with +! 7 - 15 points if key.lt.2, +! 10 - 21 points if key = 2, +! 15 - 31 points if key = 3, +! 20 - 41 points if key = 4, +! 25 - 51 points if key = 5, +! 30 - 61 points if key.gt.5. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for result and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yield no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulaties. +! if the position of a local difficulty can +! be determined (i.e.singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 6 the input is invalid, because +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or limit.lt.1 or lenw.lt.limit*4. +! result, abserr, neval, last are set +! to zero. +! except when lenw is invalid, iwork(1), +! work(limit*2+1) and work(limit*3+1) are +! set to zero, work(1) is set to a and +! work(limit+1) to b. +! +! dimensioning parameters +! limit - integer ( kind = 4 ) +! dimensioning parameter for iwork +! limit determines the maximum number of subintervals +! in the partition of the given integration interval +! (a,b), limit.ge.1. +! if limit.lt.1, the routine will end with ier = 6. +! +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw.lt.limit*4, the routine will end with +! ier = 6. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of subintervals +! produced in the subdivision process, which +! determines the number of significant elements +! actually in the work arrays. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which contain pointers to the error +! estimates over the subintervals, such that +! work(limit*3+iwork(1)),... , work(limit*3+iwork(k)) +! form a decreasing sequence with k = last if +! last.le.(limit/2+2), and k = limit+1-last otherwise +! +! work - real ( kind = 8 ) +! vector of dimension at least lenw +! on return +! work(1), ..., work(last) contain the left end +! points of the subintervals in the partition of +! (a,b), +! work(limit+1), ..., work(limit+last) contain the +! right end points, +! work(limit*2+1), ..., work(limit*2+last) contain +! the integral approximations over the subintervals, +! work(limit*3+1), ..., work(limit*3+last) contain +! the error estimates. +! + implicit none + + integer ( kind = 4 ) lenw + integer ( kind = 4 ) limit + + real ( kind = 8 ) a + real ( kind = 8 ) abserr + real ( kind = 8 ) b + real ( kind = 8 ) epsabs + real ( kind = 8 ) epsrel + real ( kind = 8 ), external :: f + integer ( kind = 4 ) ier + integer ( kind = 4 ) iwork(limit) + integer ( kind = 4 ) key + integer ( kind = 4 ) last + integer ( kind = 4 ) lvl + integer ( kind = 4 ) l1 + integer ( kind = 4 ) l2 + integer ( kind = 4 ) l3 + integer ( kind = 4 ) neval + real ( kind = 8 ) result + real ( kind = 8 ) work(lenw) +! +! check validity of lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +! +! prepare call for dqage. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + + call dqage(f,a,b,epsabs,epsrel,key,limit,result,abserr,neval, & + ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 +10 continue + + if(ier.eq.6) lvl = 1 + if(ier.ne.0) call xerror('abnormal return from dqag ',26,ier,lvl) + + return +end +subroutine dqagie ( f, bound, inf, epsabs, epsrel, limit, result, abserr, & + neval, ier, alist, blist, rlist, elist, iord, last ) + +!*****************************************************************************80 +! +!! DQAGIE estimates an integral over a semi-infinite or infinite interval. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! integral i = integral of f over (bound,+infinity) +! or i = integral of f over (-infinity,bound) +! or i = integral of f over (-infinity,+infinity), +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)) +! +! Parameters: +! +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! bound - real ( kind = 8 ) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - real ( kind = 8 ) +! indicating the kind of integration range involved +! inf = 1 corresponds to (bound,+infinity), +! inf = -1 to (-infinity,bound), +! inf = 2 to (-infinity,+infinity). +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! limit - integer ( kind = 4 ) +! gives an upper bound on the number of subintervals +! in the partition of (a,b), limit.ge.1 +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! - ier.gt.0 abnormal termination of the routine. the +! estimates for result and error are less +! reliable. it is assumed that the requested +! accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however,if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. +! if the position of a local difficulty can +! be determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is assumed that the requested tolerance +! cannot be achieved, and that the returned +! result is the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! result, abserr, neval, last, rlist(1), +! elist(1) and iord(1) are set to zero. +! alist(1) and blist(1) are set to 0 +! and 1 respectively. +! +! alist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the left +! end points of the subintervals in the partition +! of the transformed integration range (0,1). +! +! blist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the right +! end points of the subintervals in the partition +! of the transformed integration range (0,1). +! +! rlist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! iord - integer ( kind = 4 ) +! vector of dimension limit, the first k +! elements of which are pointers to the +! error estimates over the subintervals, +! such that elist(iord(1)), ..., elist(iord(k)) +! form a decreasing sequence, with k = last +! if last.le.(limit/2+2), and k = limit+1-last +! otherwise +! +! last - integer ( kind = 4 ) +! number of subintervals actually produced +! in the subdivision process +! +! Local Parameters: +! +! the dimension of rlist2 is determined by the value of +! limexp in routine dqelg. +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least (limexp+2), +! containing the part of the epsilon table +! wich is still needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements currently in rlist2. if an +! appropriate approximation to the compounded +! integral has been obtained, it is put in +! rlist2(numrl2) after numrl2 has been increased +! by one. +! small - length of the smallest interval considered up +! to now, multiplied by 1.5 +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine +! is attempting to perform extrapolation. i.e. +! before subdividing the smallest interval we +! try to decrease the value of erlarg. +! noext - logical variable denoting that extrapolation +! is no longer allowed (true-value) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! + implicit none + + real ( kind = 8 ) abseps,abserr,alist,area,area1,area12,area2,a1, & + a2,blist,boun,bound,b1,b2,correc,defabs,defab1,defab2, & + dres,elist,epmach,epsabs,epsrel,erlarg,erlast, & + errbnd,errmax,error1,error2,erro12,errsum,ertest,f,oflow,resabs, & + reseps,result,res3la,rlist,rlist2,small,uflow + integer ( kind = 4 ) id,ier,ierro,inf,iord,iroff1,iroff2, & + iroff3,jupbnd,k,ksgn, & + ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 + logical extrap,noext + dimension alist(limit),blist(limit),elist(limit),iord(limit), & + res3la(3),rlist(limit),rlist2(52) + + external f + + epmach = epsilon ( epmach ) +! +! test on validity of parameters +! + ier = 0 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + alist(1) = 0.0D+00 + blist(1) = 0.1D+01 + rlist(1) = 0.0D+00 + elist(1) = 0.0D+00 + iord(1) = 0 + + if(epsabs.le.0.0D+00.and.epsrel.lt. max ( 0.5D+02*epmach,0.5D-28)) then + ier = 6 + end if + + if(ier.eq.6) then + return + end if +! +! first approximation to the integral +! +! determine the interval to be mapped onto (0,1). +! if inf = 2 the integral is computed as i = i1+i2, where +! i1 = integral of f over (-infinity,0), +! i2 = integral of f over (0,+infinity). +! + boun = bound + if(inf.eq.2) boun = 0.0D+00 + call dqk15i(f,boun,inf,0.0D+00,0.1D+01,result,abserr, & + defabs,resabs) +! +! test on accuracy +! + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + dres = abs ( result) + errbnd = max ( epsabs,epsrel*dres) + if(abserr.le.1.0D+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. & + abserr.eq.0.0D+00) go to 130 +! +! initialization +! + uflow = tiny ( uflow ) + oflow = huge ( oflow ) + rlist2(1) = result + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + abserr = oflow + nrmax = 1 + nres = 0 + ktmin = 0 + numrl2 = 2 + extrap = .false. + noext = .false. + ierro = 0 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if(dres.ge.(0.1D+01-0.5D+02*epmach)*defabs) ksgn = 1 +! +! main do-loop +! + do 90 last = 2,limit +! +! bisect the subinterval with nrmax-th largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5D+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk15i(f,boun,inf,a1,b1,area1,error1,resabs,defab1) + call dqk15i(f,boun,inf,a2,b2,area2,error2,resabs,defab2) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2)go to 15 + if( abs ( rlist(maxerr)-area12).gt.0.1D-04* abs ( area12) & + .or.erro12.lt.0.99D+00*errmax) go to 10 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 15 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = max ( epsabs,epsrel* abs ( area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last.eq.limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at some points of the integration range. +! + if( max ( abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03*epmach)* & + ( abs ( a2)+0.1D+04*uflow)) then + ier = 4 + end if +! +! append the newly-created intervals to the list. +! + if(error2.gt.error1) go to 20 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 30 + 20 continue + + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +! +! call dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum.le.errbnd) go to 115 + if(ier.ne.0) go to 100 + if(last.eq.2) go to 80 + if(noext) go to 90 + erlarg = erlarg-erlast + if( abs ( b1-a1).gt.small) erlarg = erlarg+erro12 + if(extrap) go to 40 +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if( abs ( blist(maxerr)-alist(maxerr)).gt.small) go to 90 + extrap = .true. + nrmax = 2 + 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over the +! larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if( abs ( blist(maxerr)-alist(maxerr)).gt.small) go to 90 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + 60 numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1D-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 70 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = max ( epsabs,epsrel* abs ( reseps)) + if(abserr.le.ertest) go to 100 +! +! prepare bisection of the smallest interval. +! + 70 if(numrl2.eq.1) noext = .true. + if(ier.eq.5) go to 100 + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5D+00 + erlarg = errsum + go to 90 + 80 small = 0.375D+00 + erlarg = errsum + ertest = errbnd + rlist2(2) = area + 90 continue +! +! set final result and error estimate. +! + 100 if(abserr.eq.oflow) go to 115 + if((ier+ierro).eq.0) go to 110 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0D+00.and.area.ne.0.0D+00)go to 105 + if(abserr.gt.errsum)go to 115 + if(area.eq.0.0D+00) go to 130 + go to 110 + 105 if(abserr/ abs ( result).gt.errsum/ abs ( area))go to 115 +! +! test on divergence +! + 110 continue + + if ( ksgn .eq. (-1) .and. & + max ( abs ( result), abs ( area)) .le. defabs*0.1D-01 ) then + go to 130 + end if + + if ( 0.1D-01 .gt. (result/area) .or. & + (result/area) .gt. 0.1D+03 .or. & + errsum .gt. abs ( area) ) then + ier = 6 + end if + + go to 130 +! +! compute global integral sum. +! + 115 result = 0.0D+00 + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + + neval = 30*last-15 + if(inf.eq.2) neval = 2*neval + if(ier.gt.2) ier=ier-1 + + return +end +subroutine dqagi ( f, bound, inf, epsabs, epsrel, result, abserr, neval, & + ier,limit,lenw,last,iwork,work) + +!*****************************************************************************80 +! +!! DQAGI estimates an integral over a semi-infinite or infinite interval. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! integral i = integral of f over (bound,+infinity) +! or i = integral of f over (-infinity,bound) +! or i = integral of f over (-infinity,+infinity) +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! bound - real ( kind = 8 ) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - integer ( kind = 4 ) +! indicating the kind of integration range involved +! inf = 1 corresponds to (bound,+infinity), +! inf = -1 to (-infinity,bound), +! inf = 2 to (-infinity,+infinity). +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! - ier.gt.0 abnormal termination of the routine. the +! estimates for result and error are less +! reliable. it is assumed that the requested +! accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is assumed that the requested tolerance +! cannot be achieved, and that the returned +! result is the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or limit.lt.1 or leniw.lt.limit*4. +! result, abserr, neval, last are set to +! zero. exept when limit or leniw is +! invalid, iwork(1), work(limit*2+1) and +! work(limit*3+1) are set to zero, work(1) +! is set to a and work(limit+1) to b. +! +! dimensioning parameters +! limit - integer ( kind = 4 ) +! dimensioning parameter for iwork +! limit determines the maximum number of subintervals +! in the partition of the given integration interval +! (a,b), limit.ge.1. +! if limit.lt.1, the routine will end with ier = 6. +! +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw.lt.limit*4, the routine will end +! with ier = 6. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of subintervals +! produced in the subdivision process, which +! determines the number of significant elements +! actually in the work arrays. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension at least limit, the first +! k elements of which contain pointers +! to the error estimates over the subintervals, +! such that work(limit*3+iwork(1)),... , +! work(limit*3+iwork(k)) form a decreasing +! sequence, with k = last if last.le.(limit/2+2), and +! k = limit+1-last otherwise +! +! work - real ( kind = 8 ) +! vector of dimension at least lenw +! on return +! work(1), ..., work(last) contain the left +! end points of the subintervals in the +! partition of (a,b), +! work(limit+1), ..., work(limit+last) contain +! the right end points, +! work(limit*2+1), ...,work(limit*2+last) contain the +! integral approximations over the subintervals, +! work(limit*3+1), ..., work(limit*3) +! contain the error estimates. +! + implicit none + + real ( kind = 8 ) abserr,bound,epsabs,epsrel,f,result,work + integer ( kind = 4 ) ier,inf,iwork,last,lenw,limit,lvl,l1,l2,l3,neval + + dimension iwork(limit),work(lenw) + + external f +! +! check validity of limit and lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +! +! prepare call for dqagie. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + + call dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, & + neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 +10 if(ier.eq.6) lvl = 1 + + if(ier.ne.0) then + call xerror('abnormal return from dqagi',26,ier,lvl) + end if + + return +end +subroutine dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, & + abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin, & + last) + +!*****************************************************************************80 +! +!! DQAGPE computes a definite integral. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), hopefully +! satisfying following claim for accuracy abs(i-result).le. +! max(epsabs,epsrel*abs(i)). break points of the integration +! interval, where local difficulties of the integrand may +! occur(e.g. singularities,discontinuities),provided by user. +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! npts2 - integer ( kind = 4 ) +! number equal to two more than the number of +! user-supplied break points within the integration +! range, npts2.ge.2. +! if npts2.lt.2, the routine will end with ier = 6. +! +! points - real ( kind = 8 ) +! vector of dimension npts2, the first (npts2-2) +! elements of which are the user provided break +! points. if these points do not constitute an +! ascending sequence there will be an automatic +! sorting. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! limit - integer ( kind = 4 ) +! gives an upper bound on the number of subintervals +! in the partition of (a,b), limit.ge.npts2 +! if limit.lt.npts2, the routine will end with +! ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine. +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (i.e. singularity, +! discontinuity within the interval), it +! should be supplied to the routine as an +! element of the vector points. if necessary +! an appropriate special-purpose integrator +! must be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. it is presumed that +! the requested tolerance cannot be +! achieved, and that the returned result is +! the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier.gt.0. +! = 6 the input is invalid because +! npts2.lt.2 or +! break points are specified outside +! the integration range or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or limit.lt.npts2. +! result, abserr, neval, last, rlist(1), +! and elist(1) are set to zero. alist(1) and +! blist(1) are set to a and b respectively. +! +! alist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the left end points +! of the subintervals in the partition of the given +! integration range (a,b) +! +! blist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the right end points +! of the subintervals in the partition of the given +! integration range (a,b) +! +! rlist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! pts - real ( kind = 8 ) +! vector of dimension at least npts2, containing the +! integration limits and the break points of the +! interval in ascending sequence. +! +! level - integer ( kind = 4 ) +! vector of dimension at least limit, containing the +! subdivision levels of the subinterval, i.e. if +! (aa,bb) is a subinterval of (p1,p2) where p1 as +! well as p2 is a user-provided break point or +! integration limit, then (aa,bb) has level l if +! abs(bb-aa) = abs(p2-p1)*2**(-l). +! +! ndin - integer ( kind = 4 ) +! vector of dimension at least npts2, after first +! integration over the intervals (pts(i)),pts(i+1), +! i = 0,1, ..., npts2-2, the error estimates over +! some of the intervals may have been increased +! artificially, in order to put their subdivision +! forward. if this happens for the subinterval +! numbered k, ndin(k) is put to 1, otherwise +! ndin(k) = 0. +! +! iord - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which are pointers to the +! error estimates over the subintervals, +! such that elist(iord(1)), ..., elist(iord(k)) +! form a decreasing sequence, with k = last +! if last.le.(limit/2+2), and k = limit+1-last +! otherwise +! +! last - integer ( kind = 4 ) +! number of subintervals actually produced in the +! subdivisions process +! +! Local Parameters: +! +! the dimension of rlist2 is determined by the value of +! limexp in routine epsalg (rlist2 should be of dimension +! (limexp+2) at least). +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least limexp+2 +! containing the part of the epsilon table which +! is still needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements in rlist2. if an appropriate +! approximation to the compounded integral has +! been obtained, it is put in rlist2(numrl2) after +! numrl2 has been increased by one. +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine +! is attempting to perform extrapolation. i.e. +! before subdividing the smallest interval we +! try to decrease the value of erlarg. +! noext - logical variable denoting that extrapolation is +! no longer allowed (true-value) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,abseps,abserr,alist,area,area1,area12,area2,a1, & + a2,b,blist,b1,b2,correc,defabs,defab1,defab2, & + dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, & + errmax,error1,erro12,error2,errsum,ertest,f,oflow,points,pts, & + resa,resabs,reseps,result,res3la,rlist,rlist2,sgn,temp,uflow + integer ( kind = 4 ) i,id,ier,ierro,ind1,ind2,iord,ip1, & + iroff1,iroff2,iroff3,j, & + jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax,limit,maxerr, & + ndin,neval,nint,nintp1,npts,npts2,nres,nrmax,numrl2 + logical extrap,noext + + dimension alist(limit),blist(limit),elist(limit),iord(limit), & + level(limit),ndin(npts2),points(npts2),pts(npts2),res3la(3), & + rlist(limit),rlist2(52) + + external f + + epmach = epsilon ( epmach ) +! +! test on validity of parameters +! + ier = 0 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0D+00 + elist(1) = 0.0D+00 + iord(1) = 0 + level(1) = 0 + npts = npts2-2 + if(npts2.lt.2.or.limit.le.npts.or.(epsabs.le.0.0D+00.and. & + epsrel.lt. max ( 0.5D+02*epmach,0.5d-28))) ier = 6 + + if(ier.eq.6) then + return + end if +! +! if any break points are provided, sort them into an +! ascending sequence. +! + sgn = 1.0D+00 + if(a.gt.b) sgn = -1.0D+00 + pts(1) = min (a,b) + if(npts.eq.0) go to 15 + do i = 1,npts + pts(i+1) = points(i) + end do + 15 pts(npts+2) = max ( a,b) + nint = npts+1 + a1 = pts(1) + if(npts.eq.0) go to 40 + nintp1 = nint+1 + do i = 1,nint + ip1 = i+1 + do j = ip1,nintp1 + if(pts(i).gt.pts(j)) then + temp = pts(i) + pts(i) = pts(j) + pts(j) = temp + end if + end do + end do + if(pts(1).ne. min (a,b).or.pts(nintp1).ne. max ( a,b)) ier = 6 + + if(ier.eq.6) then + return + end if +! +! compute first integral and error approximations. +! + 40 resabs = 0.0D+00 + + do i = 1,nint + b1 = pts(i+1) + call dqk21(f,a1,b1,area1,error1,defabs,resa) + abserr = abserr+error1 + result = result+area1 + ndin(i) = 0 + if(error1.eq.resa.and.error1.ne.0.0D+00) ndin(i) = 1 + resabs = resabs+defabs + level(i) = 0 + elist(i) = error1 + alist(i) = a1 + blist(i) = b1 + rlist(i) = area1 + iord(i) = i + a1 = b1 + end do + + errsum = 0.0D+00 + do i = 1,nint + if(ndin(i).eq.1) elist(i) = abserr + errsum = errsum+elist(i) + end do +! +! test on accuracy. +! + last = nint + neval = 21*nint + dres = abs ( result) + errbnd = max ( epsabs,epsrel*dres) + if(abserr.le.0.1D+03*epmach*resabs.and.abserr.gt.errbnd) ier = 2 + if(nint.eq.1) go to 80 + + do i = 1,npts + jlow = i+1 + ind1 = iord(i) + do j = jlow,nint + ind2 = iord(j) + if(elist(ind1).le.elist(ind2)) then + ind1 = ind2 + k = j + end if + end do + if(ind1.ne.iord(i)) then + iord(k) = iord(i) + iord(i) = ind1 + end if + end do + + if(limit.lt.npts2) ier = 1 + 80 if(ier.ne.0.or.abserr.le.errbnd) go to 210 +! +! initialization +! + rlist2(1) = result + maxerr = iord(1) + errmax = elist(maxerr) + area = result + nrmax = 1 + nres = 0 + numrl2 = 1 + ktmin = 0 + extrap = .false. + noext = .false. + erlarg = errsum + ertest = errbnd + levmax = 1 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ierro = 0 + uflow = tiny ( uflow ) + oflow = huge ( oflow ) + abserr = oflow + ksgn = -1 + if(dres.ge.(0.1D+01-0.5D+02*epmach)*resabs) ksgn = 1 +! +! main do-loop +! + do 160 last = npts2,limit +! +! bisect the subinterval with the nrmax-th largest error estimate. +! + levcur = level(maxerr)+1 + a1 = alist(maxerr) + b1 = 0.5D+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk21(f,a1,b1,area1,error1,resa,defab1) + call dqk21(f,a2,b2,area2,error2,resa,defab2) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + neval = neval+42 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 95 + if( abs ( rlist(maxerr)-area12).gt.0.1D-04* abs ( area12) & + .or.erro12.lt.0.99D+00*errmax) go to 90 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 90 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 95 level(maxerr) = levcur + level(last) = levcur + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = max ( epsabs,epsrel* abs ( area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last.eq.limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range +! + if( max ( abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03*epmach)* & + ( abs ( a2)+0.1D+04*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2.gt.error1) go to 100 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 110 + 100 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +! +! call dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + 110 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum.le.errbnd) go to 190 + if(ier.ne.0) go to 170 + if(noext) go to 160 + erlarg = erlarg-erlast + if(levcur+1.le.levmax) erlarg = erlarg+erro12 + if(extrap) go to 120 +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(level(maxerr)+1.le.levmax) go to 160 + extrap = .true. + nrmax = 2 + 120 if(ierro.eq.3.or.erlarg.le.ertest) go to 140 +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over +! the larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(level(maxerr)+1.le.levmax) go to 160 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + 140 numrl2 = numrl2+1 + rlist2(numrl2) = area + if(numrl2.le.2) go to 155 + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1D-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 150 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = max ( epsabs,epsrel* abs ( reseps)) + if(abserr.lt.ertest) go to 170 +! +! prepare bisection of the smallest interval. +! + 150 if(numrl2.eq.1) noext = .true. + if(ier.ge.5) go to 170 + 155 maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + levmax = levmax+1 + erlarg = errsum + 160 continue +! +! set the final result. +! + 170 continue + + if(abserr.eq.oflow) go to 190 + if((ier+ierro).eq.0) go to 180 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0D+00.and.area.ne.0.0D+00)go to 175 + if(abserr.gt.errsum)go to 190 + if(area.eq.0.0D+00) go to 210 + go to 180 + 175 if(abserr/ abs ( result).gt.errsum/ abs ( area))go to 190 +! +! test on divergence. +! + 180 if(ksgn.eq.(-1).and. max ( abs ( result), abs ( area)).le. & + resabs*0.1D-01) go to 210 + if(0.1D-01.gt.(result/area).or.(result/area).gt.0.1D+03.or. & + errsum.gt. abs ( area)) ier = 6 + go to 210 +! +! compute global integral sum. +! + 190 result = 0.0D+00 + do k = 1,last + result = result+rlist(k) + end do + + abserr = errsum + 210 if(ier.gt.2) ier = ier-1 + result = result*sgn + + return +end +subroutine dqagp ( f, a, b, npts2, points, epsabs, epsrel, result, abserr, & + neval, ier, leniw, lenw, last, iwork, work ) + +!*****************************************************************************80 +! +!! DQAGP computes a definite integral. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! break points of the integration interval, where local +! difficulties of the integrand may occur (e.g. +! singularities, discontinuities), are provided by the user. +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! npts2 - integer ( kind = 4 ) +! number equal to two more than the number of +! user-supplied break points within the integration +! range, npts.ge.2. +! if npts2.lt.2, the routine will end with ier = 6. +! +! points - real ( kind = 8 ) +! vector of dimension npts2, the first (npts2-2) +! elements of which are the user provided break +! points. if these points do not constitute an +! ascending sequence there will be an automatic +! sorting. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine. +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (i.e. singularity, +! discontinuity within the interval), it +! should be supplied to the routine as an +! element of the vector points. if necessary +! an appropriate special-purpose integrator +! must be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is presumed that the requested +! tolerance cannot be achieved, and that +! the returned result is the best which +! can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier.gt.0. +! = 6 the input is invalid because +! npts2.lt.2 or +! break points are specified outside +! the integration range or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! result, abserr, neval, last are set to +! zero. exept when leniw or lenw or npts2 is +! invalid, iwork(1), iwork(limit+1), +! work(limit*2+1) and work(limit*3+1) +! are set to zero. +! work(1) is set to a and work(limit+1) +! to b (where limit = (leniw-npts2)/2). +! +! dimensioning parameters +! leniw - integer ( kind = 4 ) +! dimensioning parameter for iwork +! leniw determines limit = (leniw-npts2)/2, +! which is the maximum number of subintervals in the +! partition of the given integration interval (a,b), +! leniw.ge.(3*npts2-2). +! if leniw.lt.(3*npts2-2), the routine will end with +! ier = 6. +! +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least leniw*2-npts2. +! if lenw.lt.leniw*2-npts2, the routine will end +! with ier = 6. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of subintervals +! produced in the subdivision process, which +! determines the number of significant elements +! actually in the work arrays. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension at least leniw. on return, +! the first k elements of which contain +! pointers to the error estimates over the +! subintervals, such that work(limit*3+iwork(1)),..., +! work(limit*3+iwork(k)) form a decreasing +! sequence, with k = last if last.le.(limit/2+2), and +! k = limit+1-last otherwise +! iwork(limit+1), ...,iwork(limit+last) contain the +! subdivision levels of the subintervals, i.e. +! if (aa,bb) is a subinterval of (p1,p2) +! where p1 as well as p2 is a user-provided +! break point or integration limit, then (aa,bb) has +! level l if abs(bb-aa) = abs(p2-p1)*2**(-l), +! iwork(limit*2+1), ..., iwork(limit*2+npts2) have +! no significance for the user, +! note that limit = (leniw-npts2)/2. +! +! work - real ( kind = 8 ) +! vector of dimension at least lenw +! on return +! work(1), ..., work(last) contain the left +! end points of the subintervals in the +! partition of (a,b), +! work(limit+1), ..., work(limit+last) contain +! the right end points, +! work(limit*2+1), ..., work(limit*2+last) contain +! the integral approximations over the subintervals, +! work(limit*3+1), ..., work(limit*3+last) +! contain the corresponding error estimates, +! work(limit*4+1), ..., work(limit*4+npts2) +! contain the integration limits and the +! break points sorted in an ascending sequence. +! note that limit = (leniw-npts2)/2. +! + implicit none + + real ( kind = 8 ) a,abserr,b,epsabs,epsrel,f,points,result,work + integer ( kind = 4 ) ier,iwork,last,leniw,lenw,limit,lvl,l1,l2,l3, & + l4,neval,npts2 + + dimension iwork(leniw),points(npts2),work(lenw) + + external f +! +! check validity of limit and lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(leniw.lt.(3*npts2-2).or.lenw.lt.(leniw*2-npts2).or.npts2.lt.2) & + go to 10 +! +! prepare call for dqagpe. +! + limit = (leniw-npts2)/2 + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + l4 = limit+l3 + + call dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,abserr, & + neval,ier,work(1),work(l1),work(l2),work(l3),work(l4), & + iwork(1),iwork(l1),iwork(l2),last) +! +! call error handler if necessary. +! + lvl = 0 +10 if(ier.eq.6) lvl = 1 + + if(ier.ne.0) then + call xerror('abnormal return from dqagp',26,ier,lvl) + end if + + return +end +subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, & + ier,alist,blist,rlist,elist,iord,last) + +!*****************************************************************************80 +! +!! DQAGSE estimates the integral of a function. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! limit - integer ( kind = 4 ) +! gives an upperbound on the number of subintervals +! in the partition of (a,b) +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of limit +! (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour +! occurs at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is presumed that the requested +! tolerance cannot be achieved, and that the +! returned result is the best which can be +! obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28). +! result, abserr, neval, last, rlist(1), +! iord(1) and elist(1) are set to zero. +! alist(1) and blist(1) are set to a and b +! respectively. +! +! alist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the left end points +! of the subintervals in the partition of the +! given integration range (a,b) +! +! blist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the right end points +! of the subintervals in the partition of the given +! integration range (a,b) +! +! rlist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! iord - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which are pointers to the +! error estimates over the subintervals, +! such that elist(iord(1)), ..., elist(iord(k)) +! form a decreasing sequence, with k = last +! if last.le.(limit/2+2), and k = limit+1-last +! otherwise +! +! last - integer ( kind = 4 ) +! number of subintervals actually produced in the +! subdivision process +! +! Local parameters: +! +! the dimension of rlist2 is determined by the value of +! limexp in routine dqelg (rlist2 should be of dimension +! (limexp+2) at least). +! +! list of major variables +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least limexp+2 containing +! the part of the epsilon table which is still +! needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left interval +! *****2 - variable for the right interval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements currently in rlist2. if an +! appropriate approximation to the compounded +! integral has been obtained it is put in +! rlist2(numrl2) after numrl2 has been increased +! by one. +! small - length of the smallest interval considered up +! to now, multiplied by 1.5 +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine is +! attempting to perform extrapolation i.e. before +! subdividing the smallest interval we try to +! decrease the value of erlarg. +! noext - logical variable denoting that extrapolation +! is no longer allowed (true value) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,abseps,abserr,alist,area,area1,area12,area2,a1, & + a2,b,blist,b1,b2,correc,defabs,defab1,defab2, & + dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,f,oflow,resabs,reseps,result, & + res3la,rlist,rlist2,small,uflow + integer ( kind = 4 ) id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd, & + k,ksgn,ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 + logical extrap,noext + dimension alist(limit),blist(limit),elist(limit),iord(limit), & + res3la(3),rlist(limit),rlist2(52) + + external f + + epmach = epsilon ( epmach ) +! +! test on validity of parameters +! + ier = 0 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0D+00 + elist(1) = 0.0D+00 + + if(epsabs.le.0.0D+00.and.epsrel.lt. max ( 0.5D+02*epmach,0.5d-28)) then + ier = 6 + return + end if +! +! first approximation to the integral +! + uflow = tiny ( uflow ) + oflow = huge ( oflow ) + ierro = 0 + call dqk21(f,a,b,result,abserr,defabs,resabs) +! +! test on accuracy. +! + dres = abs ( result) + errbnd = max ( epsabs,epsrel*dres) + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + if(abserr.le.1.0D+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. & + abserr.eq.0.0D+00) go to 140 +! +! initialization +! + rlist2(1) = result + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + abserr = oflow + nrmax = 1 + nres = 0 + numrl2 = 2 + ktmin = 0 + extrap = .false. + noext = .false. + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if(dres.ge.(0.1D+01-0.5D+02*epmach)*defabs) ksgn = 1 +! +! main do-loop +! + do 90 last = 2,limit +! +! bisect the subinterval with the nrmax-th largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5D+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk21(f,a1,b1,area1,error1,resabs,defab1) + call dqk21(f,a2,b2,area2,error2,resabs,defab2) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 15 + if( abs ( rlist(maxerr)-area12).gt.0.1D-04* abs ( area12) & + .or.erro12.lt.0.99D+00*errmax) go to 10 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 15 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = max ( epsabs,epsrel* abs ( area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +! +! set error flag in the case that the number of subintervals +! equals limit. +! + if(last.eq.limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if( max ( abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03*epmach)* & + ( abs ( a2)+0.1D+04*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2.gt.error1) go to 20 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 30 + 20 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +! +! call dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum.le.errbnd) go to 115 + if(ier.ne.0) go to 100 + if(last.eq.2) go to 80 + if(noext) go to 90 + erlarg = erlarg-erlast + if( abs ( b1-a1).gt.small) erlarg = erlarg+erro12 + if(extrap) go to 40 +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if( abs ( blist(maxerr)-alist(maxerr)).gt.small) go to 90 + extrap = .true. + nrmax = 2 + 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over the +! larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if( abs ( blist(maxerr)-alist(maxerr)).gt.small) go to 90 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + 60 numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1D-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 70 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = max ( epsabs,epsrel* abs ( reseps)) + if(abserr.le.ertest) go to 100 +! +! prepare bisection of the smallest interval. +! + 70 if(numrl2.eq.1) noext = .true. + if(ier.eq.5) go to 100 + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5D+00 + erlarg = errsum + go to 90 + 80 small = abs ( b-a)*0.375D+00 + erlarg = errsum + ertest = errbnd + rlist2(2) = area + 90 continue +! +! set final result and error estimate. +! + 100 if(abserr.eq.oflow) go to 115 + if(ier+ierro.eq.0) go to 110 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0D+00.and.area.ne.0.0D+00) go to 105 + if(abserr.gt.errsum) go to 115 + if(area.eq.0.0D+00) go to 130 + go to 110 + 105 if(abserr/ abs ( result).gt.errsum/ abs ( area)) go to 115 +! +! test on divergence. +! + 110 if(ksgn.eq.(-1).and. max ( abs ( result), abs ( area)).le. & + defabs*0.1D-01) go to 130 + if(0.1D-01.gt.(result/area).or.(result/area).gt.0.1D+03 & + .or.errsum.gt. abs ( area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 result = 0.0D+00 + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 if(ier.gt.2) ier = ier-1 + 140 neval = 42*last-21 + + return +end +subroutine dqags ( f, a, b, epsabs, epsrel, result, abserr, neval, ier, & + limit, lenw, last, iwork, work ) + +!*****************************************************************************80 +! +!! DQAGS estimates the integral of a function. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of limit +! (and taking the according dimension +! adjustments into account. however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour +! occurs at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. it is presumed that +! the requested tolerance cannot be +! achieved, and that the returned result is +! the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28) +! or limit.lt.1 or lenw.lt.limit*4. +! result, abserr, neval, last are set to +! zero.except when limit or lenw is invalid, +! iwork(1), work(limit*2+1) and +! work(limit*3+1) are set to zero, work(1) +! is set to a and work(limit+1) to b. +! +! dimensioning parameters +! limit - integer ( kind = 4 ) +! dimensioning parameter for iwork +! limit determines the maximum number of subintervals +! in the partition of the given integration interval +! (a,b), limit.ge.1. +! if limit.lt.1, the routine will end with ier = 6. +! +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw.lt.limit*4, the routine will end +! with ier = 6. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of subintervals +! produced in the subdivision process, detemines the +! number of significant elements actually in the work +! arrays. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which contain pointers +! to the error estimates over the subintervals +! such that work(limit*3+iwork(1)),... , +! work(limit*3+iwork(k)) form a decreasing +! sequence, with k = last if last.le.(limit/2+2), +! and k = limit+1-last otherwise +! +! work - real ( kind = 8 ) +! vector of dimension at least lenw +! on return +! work(1), ..., work(last) contain the left +! end-points of the subintervals in the +! partition of (a,b), +! work(limit+1), ..., work(limit+last) contain +! the right end-points, +! work(limit*2+1), ..., work(limit*2+last) contain +! the integral approximations over the subintervals, +! work(limit*3+1), ..., work(limit*3+last) +! contain the error estimates. +! + implicit none + + real ( kind = 8 ) a,abserr,b,epsabs,epsrel,f,result,work + integer ( kind = 4 ) ier,iwork,last,lenw,limit,lvl,l1,l2,l3,neval + dimension iwork(limit),work(lenw) + + external f +! +! check validity of limit and lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +! +! prepare call for dqagse. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + + call dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, & + ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) call xerror('abnormal return from dqags',26,ier,lvl) + + return +end +subroutine dqawce(f,a,b,c,epsabs,epsrel,limit,result,abserr,neval, & + ier,alist,blist,rlist,elist,iord,last) + +!*****************************************************************************80 +! +!! DQAWCE computes a Cauchy principal value. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!*** purpose the routine calculates an approximation result to a +! cauchy principal value i = integral of f*w over (a,b) +! (w(x) = 1/(x-c), (c.ne.a, c.ne.b), hopefully satisfying +! following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)) +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! c - real ( kind = 8 ) +! parameter in the weight function, c.ne.a, c.ne.b +! if c = a or c = b, the routine will end with +! ier = 6. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! limit - integer ( kind = 4 ) +! gives an upper bound on the number of subintervals +! in the partition of (a,b), limit.ge.1 +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of +! limit. however, if this yields no +! improvement it is advised to analyze the +! the integrand, in order to determine the +! the integration difficulties. if the +! position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling +! appropriate integrators on the subranges. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! = 3 extremely bad integrand behaviour +! occurs at some interior points of +! the integration interval. +! = 6 the input is invalid, because +! c = a or c = b or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or limit.lt.1. +! result, abserr, neval, rlist(1), elist(1), +! iord(1) and last are set to zero. alist(1) +! and blist(1) are set to a and b +! respectively. +! +! alist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the left +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! blist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the right +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! rlist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - real ( kind = 8 ) +! vector of dimension limit, the first last +! elements of which are the moduli of the absolute +! error estimates on the subintervals +! +! iord - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which are pointers to the error +! estimates over the subintervals, so that +! elist(iord(1)), ..., elist(iord(k)) with k = last +! if last.le.(limit/2+2), and k = limit+1-last +! otherwise, form a decreasing sequence +! +! last - integer ( kind = 4 ) +! number of subintervals actually produced in +! the subdivision process +! +! Local Parameters: +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest +! error estimate +! errmax - elist(maxerr) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,aa,abserr,alist,area,area1,area12,area2,a1,a2, & + b,bb,blist,b1,b2,c,elist,epmach,epsabs,epsrel, & + errbnd,errmax,error1,erro12,error2,errsum,f,result,rlist,uflow + integer ( kind = 4 ) ier,iord,iroff1,iroff2,k,krule,last,limit,& + maxerr, nev, & + neval,nrmax + dimension alist(limit),blist(limit),rlist(limit),elist(limit), & + iord(limit) + + external f + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) +! +! test on validity of parameters +! + ier = 6 + neval = 0 + last = 0 + alist(1) = a + blist(1) = b + rlist(1) = 0.0D+00 + elist(1) = 0.0D+00 + iord(1) = 0 + result = 0.0D+00 + abserr = 0.0D+00 + + if ( c.eq.a .or. & + c.eq.b .or. & + (epsabs.le.0.0D+00 .and. epsrel.lt. max ( 0.5D+02*epmach,0.5d-28)) ) then + ier = 6 + return + end if +! +! first approximation to the integral +! + if ( a <= b ) then + aa=a + bb=b + else + aa=b + bb=a + end if + + ier=0 + krule = 1 + call dqc25c(f,aa,bb,c,result,abserr,krule,neval) + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + alist(1) = a + blist(1) = b +! +! test on accuracy +! + errbnd = max ( epsabs,epsrel* abs ( result)) + if(limit.eq.1) ier = 1 + + if(abserr.lt. min (0.1D-01* abs ( result),errbnd) & + .or.ier.eq.1) go to 70 +! +! initialization +! + alist(1) = aa + blist(1) = bb + rlist(1) = result + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 +! +! main do-loop +! + do 40 last = 2,limit +! +! bisect the subinterval with nrmax-th largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5D+00*(alist(maxerr)+blist(maxerr)) + b2 = blist(maxerr) + if(c.le.b1.and.c.gt.a1) b1 = 0.5D+00*(c+b2) + if(c.gt.b1.and.c.lt.b2) b1 = 0.5D+00*(a1+c) + a2 = b1 + krule = 2 + call dqc25c(f,a1,b1,c,area1,error1,krule,nev) + neval = neval+nev + call dqc25c(f,a2,b2,c,area2,error2,krule,nev) + neval = neval+nev +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if( abs ( rlist(maxerr)-area12).lt.0.1D-04* abs ( area12) & + .and.erro12.ge.0.99D+00*errmax.and.krule.eq.0) & + iroff1 = iroff1+1 + if(last.gt.10.and.erro12.gt.errmax.and.krule.eq.0) & + iroff2 = iroff2+1 + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = max ( epsabs,epsrel* abs ( area)) + if(errsum.le.errbnd) go to 15 +! +! test for roundoff error and eventually set error flag. +! + if(iroff1.ge.6.and.iroff2.gt.20) ier = 2 +! +! set error flag in the case that number of interval bisections exceeds limit. +! + if(last.eq.limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if( max ( abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03*epmach) & + *( abs ( a2)+0.1D+04*uflow)) ier = 3 +! +! append the newly-created intervals to the list. +! + 15 continue + + if ( error2 .le. error1 ) then + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + else + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + end if +! +! call dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + + if(ier.ne.0.or.errsum.le.errbnd) go to 50 + + 40 continue +! +! compute final result. +! + 50 continue + + result = 0.0D+00 + do k=1,last + result = result+rlist(k) + end do + + abserr = errsum + 70 if (aa.eq.b) result=-result + + return +end +subroutine dqawc ( f, a, b, c, epsabs, epsrel, result, abserr, neval, ier, & + limit, lenw, last, iwork, work ) + +!*****************************************************************************80 +! +!! DQAWC computes a Cauchy principal value. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a +! cauchy principal value i = integral of f*w over (a,b) +! (w(x) = 1/((x-c), c.ne.a, c.ne.b), hopefully satisfying +! following claim for accuracy +! abs(i-result).le.max(epsabe,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! under limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! c - parameter in the weight function, c.ne.a, c.ne.b. +! if c = a or c = b, the routine will end with +! ier = 6 . +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate or the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of limit +! (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. +! if the position of a local difficulty +! can be determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling +! appropriate integrators on the subranges. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 6 the input is invalid, because +! c = a or c = b or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or limit.lt.1 or lenw.lt.limit*4. +! result, abserr, neval, last are set to +! zero. exept when lenw or limit is invalid, +! iwork(1), work(limit*2+1) and +! work(limit*3+1) are set to zero, work(1) +! is set to a and work(limit+1) to b. +! +! dimensioning parameters +! limit - integer ( kind = 4 ) +! dimensioning parameter for iwork +! limit determines the maximum number of subintervals +! in the partition of the given integration interval +! (a,b), limit.ge.1. +! if limit.lt.1, the routine will end with ier = 6. +! +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw.lt.limit*4, the routine will end with +! ier = 6. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of subintervals +! produced in the subdivision process, which +! determines the number of significant elements +! actually in the work arrays. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which contain pointers +! to the error estimates over the subintervals, +! such that work(limit*3+iwork(1)), ... , +! work(limit*3+iwork(k)) form a decreasing +! sequence, with k = last if last.le.(limit/2+2), +! and k = limit+1-last otherwise +! +! work - real ( kind = 8 ) +! vector of dimension at least lenw +! on return +! work(1), ..., work(last) contain the left +! end points of the subintervals in the +! partition of (a,b), +! work(limit+1), ..., work(limit+last) contain +! the right end points, +! work(limit*2+1), ..., work(limit*2+last) contain +! the integral approximations over the subintervals, +! work(limit*3+1), ..., work(limit*3+last) +! contain the error estimates. +! + implicit none + + real ( kind = 8 ) a,abserr,b,c,epsabs,epsrel,f,result,work + integer ( kind = 4 ) ier,iwork,last,lenw,limit,lvl,l1,l2,l3,neval + dimension iwork(limit),work(lenw) + + external f +! +! check validity of limit and lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +! +! prepare call for dqawce. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + call dqawce(f,a,b,c,epsabs,epsrel,limit,result,abserr,neval,ier, & + work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 +10 if(ier.eq.6) lvl = 1 + + if(ier.ne.0) then + call xerror('abnormal return from dqawc',26,ier,lvl) + end if + + return +end +subroutine dqawfe(f,a,omega,integr,epsabs,limlst,limit,maxp1, & + result,abserr,neval,ier,rslst,erlst,ierlst,lst,alist,blist, & + rlist,elist,iord,nnlog,chebmo) + +!*****************************************************************************80 +! +!! DQAWFE computes Fourier integrals. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a +! given fourier integal +! i = integral of f(x)*w(x) over (a,infinity) +! where w(x)=cos(omega*x) or w(x)=sin(omega*x), +! hopefully satisfying following claim for accuracy +! abs(i-result).le.epsabs. +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to +! be declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! omega - real ( kind = 8 ) +! parameter in the weight function +! +! integr - integer ( kind = 4 ) +! indicates which weight function is used +! integr = 1 w(x) = cos(omega*x) +! integr = 2 w(x) = sin(omega*x) +! if integr.ne.1.and.integr.ne.2, the routine will +! end with ier = 6. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested, epsabs.gt.0 +! if epsabs.le.0, the routine will end with ier = 6. +! +! limlst - integer ( kind = 4 ) +! limlst gives an upper bound on the number of +! cycles, limlst.ge.1. +! if limlst.lt.3, the routine will end with ier = 6. +! +! limit - integer ( kind = 4 ) +! gives an upper bound on the number of subintervals +! allowed in the partition of each cycle, limit.ge.1 +! each cycle, limit.ge.1. +! +! maxp1 - integer ( kind = 4 ) +! gives an upper bound on the number of +! chebyshev moments which can be stored, i.e. +! for the intervals of lengths abs(b-a)*2**(-l), +! l=0,1, ..., maxp1-2, maxp1.ge.1 +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral x +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - ier = 0 normal and reliable termination of +! the routine. it is assumed that the +! requested accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine. the +! estimates for integral and error are less +! reliable. it is assumed that the requested +! accuracy has not been achieved. +! error messages +! if omega.ne.0 +! ier = 1 maximum number of cycles allowed +! has been achieved., i.e. of subintervals +! (a+(k-1)c,a+kc) where +! c = (2*int(abs(omega))+1)*pi/abs(omega), +! for k = 1, 2, ..., lst. +! one can allow more cycles by increasing +! the value of limlst (and taking the +! according dimension adjustments into +! account). +! examine the array iwork which contains +! the error flags on the cycles, in order to +! look for eventual local integration +! difficulties. if the position of a local +! difficulty can be determined (e.g. +! singularity, discontinuity within the +! interval) one will probably gain from +! splitting up the interval at this point +! and calling appropriate integrators on +! the subranges. +! = 4 the extrapolation table constructed for +! convergence acceleration of the series +! formed by the integral contributions over +! the cycles, does not converge to within +! the requested accuracy. as in the case of +! ier = 1, it is advised to examine the +! array iwork which contains the error +! flags on the cycles. +! = 6 the input is invalid because +! (integr.ne.1 and integr.ne.2) or +! epsabs.le.0 or limlst.lt.3. +! result, abserr, neval, lst are set +! to zero. +! = 7 bad integrand behaviour occurs within one +! or more of the cycles. location and type +! of the difficulty involved can be +! determined from the vector ierlst. here +! lst is the number of cycles actually +! needed (see below). +! ierlst(k) = 1 the maximum number of +! subdivisions (= limit) has +! been achieved on the k th +! cycle. +! = 2 occurrence of roundoff error +! is detected and prevents the +! tolerance imposed on the +! k th cycle, from being +! achieved. +! = 3 extremely bad integrand +! behaviour occurs at some +! points of the k th cycle. +! = 4 the integration procedure +! over the k th cycle does +! not converge (to within the +! required accuracy) due to +! roundoff in the +! extrapolation procedure +! invoked on this cycle. it +! is assumed that the result +! on this interval is the +! best which can be obtained. +! = 5 the integral over the k th +! cycle is probably divergent +! or slowly convergent. it +! must be noted that +! divergence can occur with +! any other value of +! ierlst(k). +! if omega = 0 and integr = 1, +! the integral is calculated by means of dqagie +! and ier = ierlst(1) (with meaning as described +! for ierlst(k), k = 1). +! +! rslst - real ( kind = 8 ) +! vector of dimension at least limlst +! rslst(k) contains the integral contribution +! over the interval (a+(k-1)c,a+kc) where +! c = (2*int(abs(omega))+1)*pi/abs(omega), +! k = 1, 2, ..., lst. +! note that, if omega = 0, rslst(1) contains +! the value of the integral over (a,infinity). +! +! erlst - real ( kind = 8 ) +! vector of dimension at least limlst +! erlst(k) contains the error estimate corresponding +! with rslst(k). +! +! ierlst - integer ( kind = 4 ) +! vector of dimension at least limlst +! ierlst(k) contains the error flag corresponding +! with rslst(k). for the meaning of the local error +! flags see description of output parameter ier. +! +! lst - integer ( kind = 4 ) +! number of subintervals needed for the integration +! if omega = 0 then lst is set to 1. +! +! alist, blist, rlist, elist - real ( kind = 8 ) +! vector of dimension at least limit, +! +! iord, nnlog - integer ( kind = 4 ) +! vector of dimension at least limit, providing +! space for the quantities needed in the subdivision +! process of each cycle +! +! chebmo - real ( kind = 8 ) +! array of dimension at least (maxp1,25), providing +! space for the chebyshev moments needed within the +! cycles +! +! Local Parameters: +! +! the dimension of psum is determined by the value of +! limexp in routine dqelg (psum must be of dimension +! (limexp+2) at least). +! +! c1, c2 - end points of subinterval (of length cycle) +! cycle - (2*int(abs(omega))+1)*pi/abs(omega) +! psum - vector of dimension at least (limexp+2) +! (see routine dqelg) +! psum contains the part of the epsilon table +! which is still needed for further computations. +! each element of psum is a partial sum of the +! series which should sum to the value of the +! integral. +! errsum - sum of error estimates over the subintervals, +! calculated cumulatively +! epsa - absolute tolerance requested over current +! subinterval +! chebmo - array containing the modified chebyshev +! moments (see also routine dqc25f) +! + implicit none + + real ( kind = 8 ) a,abseps,abserr,alist,blist,chebmo,correc,cycle, & + c1,c2,dl,dla,drl,elist,erlst,ep,eps,epsa, & + epsabs,errsum,f,fact,omega,p,pi,p1,psum,reseps,result,res3la, & + rlist,rslst,uflow + integer ( kind = 4 ) ier,ierlst,integr,iord,ktmin,l,last,lst,limit + integer ( kind = 4 ) limlst + integer ( kind = 4 ) ll + integer ( kind = 4 ) maxp1,momcom,nev,neval,nnlog,nres,numrl2 + + dimension alist(limit),blist(limit),chebmo(maxp1,25),elist(limit), & + erlst(limlst),ierlst(limlst),iord(limit),nnlog(limit),psum(52), & + res3la(3),rlist(limit),rslst(limlst) + + external f + + data p / 0.9D+00 / + data pi / 3.14159265358979323846264338327950D+00 / +! +! test on validity of parameters +! + result = 0.0D+00 + abserr = 0.0D+00 + neval = 0 + lst = 0 + ier = 0 + + if((integr.ne.1.and.integr.ne.2).or.epsabs.le.0.0D+00.or. & + limlst.lt.3) then + ier = 6 + return + end if + + if(omega.ne.0.0D+00) go to 10 +! +! integration by dqagie if omega is zero +! + if(integr.eq.1) then + call dqagie(f,0.0D+00,1,epsabs,0.0D+00,limit, & + result,abserr,neval,ier,alist,blist,rlist,elist,iord,last) + end if + + rslst(1) = result + erlst(1) = abserr + ierlst(1) = ier + lst = 1 + go to 999 +! +! initializations +! + 10 l = abs ( omega) + dl = 2*l+1 + cycle = dl*pi/ abs ( omega) + ier = 0 + ktmin = 0 + neval = 0 + numrl2 = 0 + nres = 0 + c1 = a + c2 = cycle+a + p1 = 0.1D+01-p + uflow = tiny ( uflow ) + eps = epsabs + if(epsabs.gt.uflow/p1) eps = epsabs*p1 + ep = eps + fact = 0.1D+01 + correc = 0.0D+00 + abserr = 0.0D+00 + errsum = 0.0D+00 +! +! main do-loop +! + do lst = 1,limlst +! +! integrate over current subinterval. +! + dla = lst + epsa = eps*fact + call dqawoe(f,c1,c2,omega,integr,epsa,0.0D+00,limit,lst,maxp1, & + rslst(lst),erlst(lst),nev,ierlst(lst),last,alist,blist,rlist, & + elist,iord,nnlog,momcom,chebmo) + neval = neval+nev + fact = fact*p + errsum = errsum+erlst(lst) + drl = 0.5D+02* abs ( rslst(lst)) +! +! test on accuracy with partial sum +! + if((errsum+drl).le.epsabs.and.lst.ge.6) go to 80 + correc = max ( correc,erlst(lst)) + if(ierlst(lst).ne.0) eps = max ( ep,correc*p1) + if(ierlst(lst).ne.0) ier = 7 + if(ier.eq.7.and.(errsum+drl).le.correc*0.1D+02.and. & + lst.gt.5) go to 80 + numrl2 = numrl2+1 + if(lst.gt.1) go to 20 + psum(1) = rslst(1) + go to 40 + 20 psum(numrl2) = psum(ll)+rslst(lst) + if(lst.eq.2) go to 40 +! +! test on maximum number of subintervals +! + if(lst.eq.limlst) ier = 1 +! +! perform new extrapolation +! + call dqelg(numrl2,psum,reseps,abseps,res3la,nres) +! +! test whether extrapolated result is influenced by roundoff +! + ktmin = ktmin+1 + if(ktmin.ge.15.and.abserr.le.0.1D-02*(errsum+drl)) ier = 4 + if(abseps.gt.abserr.and.lst.ne.3) go to 30 + abserr = abseps + result = reseps + ktmin = 0 +! +! if ier is not 0, check whether direct result (partial sum) +! or extrapolated result yields the best integral +! approximation +! + if((abserr+0.1D+02*correc).le.epsabs.or. & + (abserr.le.epsabs.and.0.1D+02*correc.ge.epsabs)) go to 60 + 30 if(ier.ne.0.and.ier.ne.7) go to 60 + 40 ll = numrl2 + c1 = c2 + c2 = c2+cycle + end do +! +! set final result and error estimate +! + 60 abserr = abserr+0.1D+02*correc + if(ier.eq.0) go to 999 + if(result.ne.0.0D+00.and.psum(numrl2).ne.0.0D+00) go to 70 + if(abserr.gt.errsum) go to 80 + if(psum(numrl2).eq.0.0D+00) go to 999 + 70 if(abserr/ abs ( result).gt.(errsum+drl)/ abs ( psum(numrl2))) & + go to 80 + if(ier.ge.1.and.ier.ne.7) abserr = abserr+drl + go to 999 + 80 result = psum(numrl2) + abserr = errsum+drl + 999 continue + + return +end +subroutine dqawf ( f, a, omega, integr, epsabs, result, abserr, neval, ier, & + limlst, lst, leniw, maxp1, lenw, iwork, work ) + +!*****************************************************************************80 +! +!! DQAWF computes Fourier integrals over the interval [ A, +Infinity ). +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! fourier integral i=integral of f(x)*w(x) over (a,infinity) +! where w(x) = cos(omega*x) or w(x) = sin(omega*x). +! hopefully satisfying following claim for accuracy +! abs(i-result).le.epsabs. +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! omega - real ( kind = 8 ) +! parameter in the integrand weight function +! +! integr - integer ( kind = 4 ) +! indicates which of the weight functions is used +! integr = 1 w(x) = cos(omega*x) +! integr = 2 w(x) = sin(omega*x) +! if integr.ne.1.and.integr.ne.2, the routine +! will end with ier = 6. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested, epsabs.gt.0. +! if epsabs.le.0, the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine. +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! if omega.ne.0 +! ier = 1 maximum number of cycles allowed +! has been achieved, i.e. of subintervals +! (a+(k-1)c,a+kc) where +! c = (2*int(abs(omega))+1)*pi/abs(omega), +! for k = 1, 2, ..., lst. +! one can allow more cycles by increasing +! the value of limlst (and taking the +! according dimension adjustments into +! account). examine the array iwork which +! contains the error flags on the cycles, in +! order to look for eventual local +! integration difficulties. +! if the position of a local difficulty +! can be determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling +! appropriate integrators on the subranges. +! = 4 the extrapolation table constructed for +! convergence accelaration of the series +! formed by the integral contributions over +! the cycles, does not converge to within +! the requested accuracy. +! as in the case of ier = 1, it is advised +! to examine the array iwork which contains +! the error flags on the cycles. +! = 6 the input is invalid because +! (integr.ne.1 and integr.ne.2) or +! epsabs.le.0 or limlst.lt.1 or +! leniw.lt.(limlst+2) or maxp1.lt.1 or +! lenw.lt.(leniw*2+maxp1*25). +! result, abserr, neval, lst are set to +! zero. +! = 7 bad integrand behaviour occurs within +! one or more of the cycles. location and +! type of the difficulty involved can be +! determined from the first lst elements of +! vector iwork. here lst is the number of +! cycles actually needed (see below). +! iwork(k) = 1 the maximum number of +! subdivisions (=(leniw-limlst) +! /2) has been achieved on the +! k th cycle. +! = 2 occurrence of roundoff error +! is detected and prevents the +! tolerance imposed on the k th +! cycle, from being achieved +! on this cycle. +! = 3 extremely bad integrand +! behaviour occurs at some +! points of the k th cycle. +! = 4 the integration procedure +! over the k th cycle does +! not converge (to within the +! required accuracy) due to +! roundoff in the extrapolation +! procedure invoked on this +! cycle. it is assumed that the +! result on this interval is +! the best which can be +! obtained. +! = 5 the integral over the k th +! cycle is probably divergent +! or slowly convergent. it must +! be noted that divergence can +! occur with any other value of +! iwork(k). +! if omega = 0 and integr = 1, +! the integral is calculated by means of dqagie, +! and ier = iwork(1) (with meaning as described +! for iwork(k),k = 1). +! +! dimensioning parameters +! limlst - integer ( kind = 4 ) +! limlst gives an upper bound on the number of +! cycles, limlst.ge.3. +! if limlst.lt.3, the routine will end with ier = 6. +! +! lst - integer ( kind = 4 ) +! on return, lst indicates the number of cycles +! actually needed for the integration. +! if omega = 0, then lst is set to 1. +! +! leniw - integer ( kind = 4 ) +! dimensioning parameter for iwork. on entry, +! (leniw-limlst)/2 equals the maximum number of +! subintervals allowed in the partition of each +! cycle, leniw.ge.(limlst+2). +! if leniw.lt.(limlst+2), the routine will end with +! ier = 6. +! +! maxp1 - integer ( kind = 4 ) +! maxp1 gives an upper bound on the number of +! chebyshev moments which can be stored, i.e. for +! the intervals of lengths abs(b-a)*2**(-l), +! l = 0,1, ..., maxp1-2, maxp1.ge.1. +! if maxp1.lt.1, the routine will end with ier = 6. +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least leniw*2+maxp1*25. +! if lenw.lt.(leniw*2+maxp1*25), the routine will +! end with ier = 6. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension at least leniw +! on return, iwork(k) for k = 1, 2, ..., lst +! contain the error flags on the cycles. +! +! work - real ( kind = 8 ) +! vector of dimension at least lenw +! on return, +! work(1), ..., work(lst) contain the integral +! approximations over the cycles, +! work(limlst+1), ..., work(limlst+lst) contain +! the error extimates over the cycles. +! further elements of work have no specific +! meaning for the user. +! + implicit none + + integer ( kind = 4 ) leniw + integer ( kind = 4 ) lenw + + real ( kind = 8 ) a + real ( kind = 8 ) abserr + real ( kind = 8 ) epsabs + real ( kind = 8 ), external :: f + integer ( kind = 4 ) ier + integer ( kind = 4 ) integr + integer ( kind = 4 ) iwork(leniw) + integer ( kind = 4 ) last + integer ( kind = 4 ) limit + integer ( kind = 4 ) limlst + integer ( kind = 4 ) ll2 + integer ( kind = 4 ) lst + integer ( kind = 4 ) lvl + integer ( kind = 4 ) l1 + integer ( kind = 4 ) l2 + integer ( kind = 4 ) l3 + integer ( kind = 4 ) l4 + integer ( kind = 4 ) l5 + integer ( kind = 4 ) l6 + integer ( kind = 4 ) maxp1 + integer ( kind = 4 ) neval + real ( kind = 8 ) omega + real ( kind = 8 ) result + real ( kind = 8 ) work(lenw) +! +! check validity of limlst, leniw, maxp1 and lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(limlst.lt.3.or.leniw.lt.(limlst+2).or.maxp1.lt.1.or.lenw.lt. & + (leniw*2+maxp1*25)) go to 10 +! +! prepare call for dqawfe +! + limit = (leniw-limlst)/2 + l1 = limlst+1 + l2 = limlst+l1 + l3 = limit+l2 + l4 = limit+l3 + l5 = limit+l4 + l6 = limit+l5 + ll2 = limit+l1 + call dqawfe(f,a,omega,integr,epsabs,limlst,limit,maxp1,result, & + abserr,neval,ier,work(1),work(l1),iwork(1),lst,work(l2), & + work(l3),work(l4),work(l5),iwork(l1),iwork(ll2),work(l6)) +! +! call error handler if necessary +! + lvl = 0 +10 continue + + if(ier.eq.6) lvl = 1 + if(ier.ne.0) call xerror('abnormal return from dqawf',26,ier,lvl) + + return +end +subroutine dqawoe ( f, a, b, omega, integr, epsabs, epsrel, limit, icall, & + maxp1, result, abserr, neval, ier, last, alist, blist, rlist, elist, iord, & + nnlog, momcom, chebmo ) + +!*****************************************************************************80 +! +!! DQAWOE computes the integrals of oscillatory integrands. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral +! i = integral of f(x)*w(x) over (a,b) +! where w(x) = cos(omega*x) or w(x)=sin(omega*x), +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! omega - real ( kind = 8 ) +! parameter in the integrand weight function +! +! integr - integer ( kind = 4 ) +! indicates which of the weight functions is to be +! used +! integr = 1 w(x) = cos(omega*x) +! integr = 2 w(x) = sin(omega*x) +! if integr.ne.1 and integr.ne.2, the routine +! will end with ier = 6. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! limit - integer ( kind = 4 ) +! gives an upper bound on the number of subdivisions +! in the partition of (a,b), limit.ge.1. +! +! icall - integer ( kind = 4 ) +! if dqawoe is to be used only once, icall must +! be set to 1. assume that during this call, the +! chebyshev moments (for clenshaw-curtis integration +! of degree 24) have been computed for intervals of +! lenghts (abs(b-a))*2**(-l), l=0,1,2,...momcom-1. +! if icall.gt.1 this means that dqawoe has been +! called twice or more on intervals of the same +! length abs(b-a). the chebyshev moments already +! computed are then re-used in subsequent calls. +! if icall.lt.1, the routine will end with ier = 6. +! +! maxp1 - integer ( kind = 4 ) +! gives an upper bound on the number of chebyshev +! moments which can be stored, i.e. for the +! intervals of lenghts abs(b-a)*2**(-l), +! l=0,1, ..., maxp1-2, maxp1.ge.1. +! if maxp1.lt.1, the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the +! requested accuracy has been achieved. +! - ier.gt.0 abnormal termination of the routine. +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand, in order to +! determine the integration difficulties. +! if the position of a local difficulty can +! be determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is presumed that the requested +! tolerance cannot be achieved due to +! roundoff in the extrapolation table, +! and that the returned result is the +! best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier.gt.0. +! = 6 the input is invalid, because +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or (integr.ne.1 and integr.ne.2) or +! icall.lt.1 or maxp1.lt.1. +! result, abserr, neval, last, rlist(1), +! elist(1), iord(1) and nnlog(1) are set +! to zero. alist(1) and blist(1) are set +! to a and b respectively. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of +! subintervals produces in the subdivision +! process, which determines the number of +! significant elements actually in the +! work arrays. +! alist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the left +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! blist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the right +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! rlist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! iord - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! elements of which are pointers to the error +! estimates over the subintervals, +! such that elist(iord(1)), ..., +! elist(iord(k)) form a decreasing sequence, with +! k = last if last.le.(limit/2+2), and +! k = limit+1-last otherwise. +! +! nnlog - integer ( kind = 4 ) +! vector of dimension at least limit, containing the +! subdivision levels of the subintervals, i.e. +! iwork(i) = l means that the subinterval +! numbered i is of length abs(b-a)*2**(1-l) +! +! on entry and return +! momcom - integer ( kind = 4 ) +! indicating that the chebyshev moments +! have been computed for intervals of lengths +! (abs(b-a))*2**(-l), l=0,1,2, ..., momcom-1, +! momcom.lt.maxp1 +! +! chebmo - real ( kind = 8 ) +! array of dimension (maxp1,25) containing the +! chebyshev moments +! +! Local Parameters: +! +! the dimension of rlist2 is determined by the value of +! limexp in routine dqelg (rlist2 should be of +! dimension (limexp+2) at least). +! +! list of major variables +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least limexp+2 +! containing the part of the epsilon table +! which is still needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest +! error estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements in rlist2. if an appropriate +! approximation to the compounded integral has +! been obtained it is put in rlist2(numrl2) after +! numrl2 has been increased by one +! small - length of the smallest interval considered +! up to now, multiplied by 1.5 +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine is +! attempting to perform extrapolation, i.e. before +! subdividing the smallest interval we try to +! decrease the value of erlarg +! noext - logical variable denoting that extrapolation +! is no longer allowed (true value) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,abseps,abserr,alist,area,area1,area12,area2,a1, & + a2,b,blist,b1,b2,chebmo,correc,defab1,defab2,defabs, & + domega,dres,elist,epmach,epsabs,epsrel,erlarg,erlast, & + errbnd,errmax,error1,erro12,error2,errsum,ertest,f,oflow, & + omega,resabs,reseps,result,res3la,rlist,rlist2,small,uflow,width + integer ( kind = 4 ) icall,id,ier,ierro,integr,iord,iroff1,iroff2 + integer ( kind = 4 ) iroff3 + integer ( kind = 4 ) jupbnd + integer ( kind = 4 ) k,ksgn,ktmin,last,limit,maxerr,maxp1,momcom,nev,neval, & + nnlog,nres,nrmax,nrmom,numrl2 + logical extrap,noext,extall + + dimension alist(limit),blist(limit),rlist(limit),elist(limit), & + iord(limit),rlist2(52),res3la(3),chebmo(maxp1,25),nnlog(limit) + external f + + epmach = epsilon ( epmach ) +! +! test on validity of parameters +! + ier = 0 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0D+00 + elist(1) = 0.0D+00 + iord(1) = 0 + nnlog(1) = 0 + if((integr.ne.1.and.integr.ne.2).or.(epsabs.le.0.0D+00.and. & + epsrel.lt. max ( 0.5D+02*epmach,0.5D-28)).or.icall.lt.1.or. & + maxp1.lt.1) ier = 6 + if(ier.eq.6) go to 999 +! +! first approximation to the integral +! + domega = abs ( omega) + nrmom = 0 + if (icall.gt.1) go to 5 + momcom = 0 + 5 call dqc25f(f,a,b,domega,integr,nrmom,maxp1,0,result,abserr, & + neval,defabs,resabs,momcom,chebmo) +! +! test on accuracy. +! + dres = abs ( result) + errbnd = max ( epsabs,epsrel*dres) + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + if(abserr.le.0.1D+03*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.abserr.le.errbnd) go to 200 +! +! initializations +! + uflow = tiny ( uflow ) + oflow = huge ( oflow ) + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + abserr = oflow + nrmax = 1 + extrap = .false. + noext = .false. + ierro = 0 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ktmin = 0 + small = abs ( b-a)*0.75D+00 + nres = 0 + numrl2 = 0 + extall = .false. + if(0.5D+00* abs ( b-a)*domega.gt.0.2D+01) go to 10 + numrl2 = 1 + extall = .true. + rlist2(1) = result + 10 if(0.25D+00* abs ( b-a)*domega.le.0.2D+01) extall = .true. + ksgn = -1 + if(dres.ge.(0.1D+01-0.5D+02*epmach)*defabs) ksgn = 1 +! +! main do-loop +! + do 140 last = 2,limit +! +! bisect the subinterval with the nrmax-th largest error estimate. +! + nrmom = nnlog(maxerr)+1 + a1 = alist(maxerr) + b1 = 0.5D+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqc25f(f,a1,b1,domega,integr,nrmom,maxp1,0, & + area1,error1,nev,resabs,defab1,momcom,chebmo) + neval = neval+nev + call dqc25f(f,a2,b2,domega,integr,nrmom,maxp1,1, & + area2,error2,nev,resabs,defab2,momcom,chebmo) + neval = neval+nev +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 25 + if( abs ( rlist(maxerr)-area12).gt.0.1D-04* abs ( area12) & + .or.erro12.lt.0.99D+00*errmax) go to 20 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 20 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 25 rlist(maxerr) = area1 + rlist(last) = area2 + nnlog(maxerr) = nrmom + nnlog(last) = nrmom + errbnd = max ( epsabs,epsrel* abs ( area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last.eq.limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if( max ( abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03*epmach) & + *( abs ( a2)+0.1D+04*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2.gt.error1) go to 30 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 40 + 30 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +! +! call dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to bisected next). +! + 40 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum.le.errbnd) go to 170 + if(ier.ne.0) go to 150 + if(last.eq.2.and.extall) go to 120 + if(noext) go to 140 + if(.not.extall) go to 50 + erlarg = erlarg-erlast + if( abs ( b1-a1).gt.small) erlarg = erlarg+erro12 + if(extrap) go to 70 +! +! test whether the interval to be bisected next is the +! smallest interval. +! + 50 width = abs ( blist(maxerr)-alist(maxerr)) + if(width.gt.small) go to 140 + if(extall) go to 60 +! +! test whether we can start with the extrapolation procedure +! (we do this if we integrate over the next interval with +! use of a gauss-kronrod rule - see routine dqc25f). +! + small = small*0.5D+00 + if(0.25D+00*width*domega.gt.0.2D+01) go to 140 + extall = .true. + go to 130 + 60 extrap = .true. + nrmax = 2 + 70 if(ierro.eq.3.or.erlarg.le.ertest) go to 90 +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over +! the larger intervals (erlarg) and perform extrapolation. +! + jupbnd = last + if (last.gt.(limit/2+2)) jupbnd = limit+3-last + id = nrmax + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if( abs ( blist(maxerr)-alist(maxerr)).gt.small) go to 140 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + 90 numrl2 = numrl2+1 + rlist2(numrl2) = area + if(numrl2.lt.3) go to 110 + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1D-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 100 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = max ( epsabs,epsrel* abs ( reseps)) + if(abserr.le.ertest) go to 150 +! +! prepare bisection of the smallest interval. +! + 100 if(numrl2.eq.1) noext = .true. + if(ier.eq.5) go to 150 + 110 maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5D+00 + erlarg = errsum + go to 140 + 120 small = small*0.5D+00 + numrl2 = numrl2+1 + rlist2(numrl2) = area + 130 ertest = errbnd + erlarg = errsum + 140 continue +! +! set the final result.- +! + 150 if(abserr.eq.oflow.or.nres.eq.0) go to 170 + if(ier+ierro.eq.0) go to 165 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0D+00.and.area.ne.0.0D+00) go to 160 + if(abserr.gt.errsum) go to 170 + if(area.eq.0.0D+00) go to 190 + go to 165 + 160 if(abserr/ abs ( result).gt.errsum/ abs ( area)) go to 170 +! +! test on divergence. +! + 165 if(ksgn.eq.(-1).and. max ( abs ( result), abs ( area)).le. & + defabs*0.1D-01) go to 190 + if(0.1D-01.gt.(result/area).or.(result/area).gt.0.1D+03 & + .or.errsum.ge. abs ( area)) ier = 6 + go to 190 +! +! compute global integral sum. +! + 170 result = 0.0D+00 + do k=1,last + result = result+rlist(k) + end do + abserr = errsum + 190 if (ier.gt.2) ier=ier-1 + 200 if (integr.eq.2.and.omega.lt.0.0D+00) result=-result + 999 continue + + return +end +subroutine dqawo ( f, a, b, omega, integr, epsabs, epsrel, result, abserr, & + neval, ier, leniw, maxp1, lenw, last, iwork, work ) + +!*****************************************************************************80 +! +!! DQAWO computes the integrals of oscillatory integrands. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i=integral of f(x)*w(x) over (a,b) +! where w(x) = cos(omega*x) +! or w(x) = sin(omega*x), +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the function +! f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! omega - real ( kind = 8 ) +! parameter in the integrand weight function +! +! integr - integer ( kind = 4 ) +! indicates which of the weight functions is used +! integr = 1 w(x) = cos(omega*x) +! integr = 2 w(x) = sin(omega*x) +! if integr.ne.1.and.integr.ne.2, the routine will +! end with ier = 6. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! - ier.gt.0 abnormal termination of the routine. +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! (= leniw/2) has been achieved. one can +! allow more subdivisions by increasing the +! value of leniw (and taking the according +! dimension adjustments into account). +! however, if this yields no improvement it +! is advised to analyze the integrand in +! order to determine the integration +! difficulties. if the position of a local +! difficulty can be determined (e.g. +! singularity, discontinuity within the +! interval) one will probably gain from +! splitting up the interval at this point +! and calling the integrator on the +! subranges. if possible, an appropriate +! special-purpose integrator should be used +! which is designed for handling the type of +! difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some interior points of the +! integration interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. it is presumed that +! the requested tolerance cannot be achieved +! due to roundoff in the extrapolation +! table, and that the returned result is +! the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or (integr.ne.1 and integr.ne.2), +! or leniw.lt.2 or maxp1.lt.1 or +! lenw.lt.leniw*2+maxp1*25. +! result, abserr, neval, last are set to +! zero. except when leniw, maxp1 or lenw are +! invalid, work(limit*2+1), work(limit*3+1), +! iwork(1), iwork(limit+1) are set to zero, +! work(1) is set to a and work(limit+1) to +! b. +! +! dimensioning parameters +! leniw - integer ( kind = 4 ) +! dimensioning parameter for iwork. +! leniw/2 equals the maximum number of subintervals +! allowed in the partition of the given integration +! interval (a,b), leniw.ge.2. +! if leniw.lt.2, the routine will end with ier = 6. +! +! maxp1 - integer ( kind = 4 ) +! gives an upper bound on the number of chebyshev +! moments which can be stored, i.e. for the +! intervals of lengths abs(b-a)*2**(-l), +! l=0,1, ..., maxp1-2, maxp1.ge.1 +! if maxp1.lt.1, the routine will end with ier = 6. +! +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least leniw*2+maxp1*25. +! if lenw.lt.(leniw*2+maxp1*25), the routine will +! end with ier = 6. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of subintervals +! produced in the subdivision process, which +! determines the number of significant elements +! actually in the work arrays. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension at least leniw +! on return, the first k elements of which contain +! pointers to the error estimates over the +! subintervals, such that work(limit*3+iwork(1)), .. +! work(limit*3+iwork(k)) form a decreasing +! sequence, with limit = lenw/2 , and k = last +! if last.le.(limit/2+2), and k = limit+1-last +! otherwise. +! furthermore, iwork(limit+1), ..., iwork(limit+ +! last) indicate the subdivision levels of the +! subintervals, such that iwork(limit+i) = l means +! that the subinterval numbered i is of length +! abs(b-a)*2**(1-l). +! +! work - real ( kind = 8 ) +! vector of dimension at least lenw +! on return +! work(1), ..., work(last) contain the left +! end points of the subintervals in the +! partition of (a,b), +! work(limit+1), ..., work(limit+last) contain +! the right end points, +! work(limit*2+1), ..., work(limit*2+last) contain +! the integral approximations over the +! subintervals, +! work(limit*3+1), ..., work(limit*3+last) +! contain the error estimates. +! work(limit*4+1), ..., work(limit*4+maxp1*25) +! provide space for storing the chebyshev moments. +! note that limit = lenw/2. +! + implicit none + + real ( kind = 8 ) a,abserr,b,epsabs,epsrel,f,omega,result,work + integer ( kind = 4 ) ier,integr,iwork,last,limit,lenw,leniw,lvl,l + integer ( kind = 4 ) l1 + integer ( kind = 4 ) l2 + integer ( kind = 4 ) l3 + integer ( kind = 4 ) l4 + integer ( kind = 4 ) maxp1,momcom,neval + dimension iwork(leniw),work(lenw) + + external f +! +! check validity of leniw, maxp1 and lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(leniw.lt.2.or.maxp1.lt.1.or.lenw.lt.(leniw*2+maxp1*25)) & + go to 10 +! +! prepare call for dqawoe +! + limit = leniw/2 + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + l4 = limit+l3 + call dqawoe(f,a,b,omega,integr,epsabs,epsrel,limit,1,maxp1,result, & + abserr,neval,ier,last,work(1),work(l1),work(l2),work(l3), & + iwork(1),iwork(l1),momcom,work(l4)) +! +! call error handler if necessary +! + lvl = 0 +10 if(ier.eq.6) lvl = 0 + if(ier.ne.0) call xerror('abnormal return from dqawo',26,ier,lvl) + + return +end +subroutine dqawse(f,a,b,alfa,beta,integr,epsabs,epsrel,limit, & + result,abserr,neval,ier,alist,blist,rlist,elist,iord,last) + +!*****************************************************************************80 +! +!! DQAWSE estimates integrals with algebraico-logarithmic end singularities. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f*w over (a,b), +! (where w shows a singular behaviour at the end points, +! see parameter integr). +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration, b.gt.a +! if b.le.a, the routine will end with ier = 6. +! +! alfa - real ( kind = 8 ) +! parameter in the weight function, alfa.gt.(-1) +! if alfa.le.(-1), the routine will end with +! ier = 6. +! +! beta - real ( kind = 8 ) +! parameter in the weight function, beta.gt.(-1) +! if beta.le.(-1), the routine will end with +! ier = 6. +! +! integr - integer ( kind = 4 ) +! indicates which weight function is to be used +! = 1 (x-a)**alfa*(b-x)**beta +! = 2 (x-a)**alfa*(b-x)**beta*log(x-a) +! = 3 (x-a)**alfa*(b-x)**beta*log(b-x) +! = 4 (x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x) +! if integr.lt.1 or integr.gt.4, the routine +! will end with ier = 6. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! limit - integer ( kind = 4 ) +! gives an upper bound on the number of subintervals +! in the partition of (a,b), limit.ge.2 +! if limit.lt.2, the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for the integral and error +! are less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit. however, if this yields no +! improvement, it is advised to analyze the +! integrand in order to determine the +! integration difficulties which prevent the +! requested tolerance from being achieved. +! in case of a jump discontinuity or a local +! singularity of algebraico-logarithmic type +! at one or more interior points of the +! integration range, one should proceed by +! splitting up the interval at these +! points and calling the integrator on the +! subranges. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 6 the input is invalid, because +! b.le.a or alfa.le.(-1) or beta.le.(-1), or +! integr.lt.1 or integr.gt.4, or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! or limit.lt.2. +! result, abserr, neval, rlist(1), elist(1), +! iord(1) and last are set to zero. alist(1) +! and blist(1) are set to a and b +! respectively. +! +! alist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the left +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! blist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the right +! end points of the subintervals in the partition +! of the given integration range (a,b) +! +! rlist - real ( kind = 8 ) +! vector of dimension at least limit,the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - real ( kind = 8 ) +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! iord - integer ( kind = 4 ) +! vector of dimension at least limit, the first k +! of which are pointers to the error +! estimates over the subintervals, so that +! elist(iord(1)), ..., elist(iord(k)) with k = last +! if last.le.(limit/2+2), and k = limit+1-last +! otherwise form a decreasing sequence +! +! last - integer ( kind = 4 ) +! number of subintervals actually produced in +! the subdivision process +! +! Local parameters: +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest +! error estimate +! errmax - elist(maxerr) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,abserr,alfa,alist,area,area1,area12,area2,a1, & + a2,b,beta,blist,b1,b2,centre,elist,epmach, & + epsabs,epsrel,errbnd,errmax,error1,erro12,error2,errsum,f, & + resas1,resas2,result,rg,rh,ri,rj,rlist,uflow + integer ( kind = 4 ) ier,integr,iord,iroff1,iroff2,k,last,limit + integer ( kind = 4 )maxerr + integer ( kind = 4 ) nev + integer ( kind = 4 ) neval,nrmax + + external f + + dimension alist(limit),blist(limit),rlist(limit),elist(limit), & + iord(limit),ri(25),rj(25),rh(25),rg(25) + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) +! +! test on validity of parameters +! + neval = 0 + last = 0 + rlist(1) = 0.0D+00 + elist(1) = 0.0D+00 + iord(1) = 0 + result = 0.0D+00 + abserr = 0.0D+00 + + if ( b.le.a .or. & + (epsabs.eq.0.0D+00 .and. epsrel .lt. max ( 0.5D+02*epmach,0.5D-28) ) .or. & + alfa .le. (-0.1D+01) .or. & + beta .le. (-0.1D+01) .or. & + integr.lt.1 .or. & + integr.gt.4 .or. & + limit.lt.2 ) then + ier = 6 + return + end if + + ier = 0 +! +! compute the modified chebyshev moments. +! + call dqmomo(alfa,beta,ri,rj,rg,rh,integr) +! +! integrate over the intervals (a,(a+b)/2) and ((a+b)/2,b). +! + centre = 0.5D+00*(b+a) + call dqc25s(f,a,b,a,centre,alfa,beta,ri,rj,rg,rh,area1, & + error1,resas1,integr,nev) + neval = nev + call dqc25s(f,a,b,centre,b,alfa,beta,ri,rj,rg,rh,area2, & + error2,resas2,integr,nev) + last = 2 + neval = neval+nev + result = area1+area2 + abserr = error1+error2 +! +! test on accuracy. +! + errbnd = max ( epsabs,epsrel* abs ( result)) +! +! initialization +! + if ( error2 .le. error1 ) then + alist(1) = a + alist(2) = centre + blist(1) = centre + blist(2) = b + rlist(1) = area1 + rlist(2) = area2 + elist(1) = error1 + elist(2) = error2 + else + alist(1) = centre + alist(2) = a + blist(1) = b + blist(2) = centre + rlist(1) = area2 + rlist(2) = area1 + elist(1) = error2 + elist(2) = error1 + end if + + iord(1) = 1 + iord(2) = 2 + if(limit.eq.2) ier = 1 + + if(abserr.le.errbnd.or.ier.eq.1) then + return + end if + + errmax = elist(1) + maxerr = 1 + nrmax = 1 + area = result + errsum = abserr + iroff1 = 0 + iroff2 = 0 +! +! main do-loop +! + do 60 last = 3,limit +! +! bisect the subinterval with largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5D+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + + call dqc25s(f,a,b,a1,b1,alfa,beta,ri,rj,rg,rh,area1, & + error1,resas1,integr,nev) + neval = neval+nev + call dqc25s(f,a,b,a2,b2,alfa,beta,ri,rj,rg,rh,area2, & + error2,resas2,integr,nev) + neval = neval+nev +! +! improve previous approximations integral and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(a.eq.a1.or.b.eq.b2) go to 30 + if(resas1.eq.error1.or.resas2.eq.error2) go to 30 +! +! test for roundoff error. +! + if( abs ( rlist(maxerr)-area12).lt.0.1D-04* abs ( area12) & + .and.erro12.ge.0.99D+00*errmax) iroff1 = iroff1+1 + if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1 + 30 rlist(maxerr) = area1 + rlist(last) = area2 +! +! test on accuracy. +! + errbnd = max ( epsabs,epsrel* abs ( area)) + if(errsum.le.errbnd) go to 35 +! +! set error flag in the case that the number of interval +! bisections exceeds limit. +! + if(last.eq.limit) ier = 1 +! +! set error flag in the case of roundoff error. +! + if(iroff1.ge.6.or.iroff2.ge.20) ier = 2 +! +! set error flag in the case of bad integrand behaviour +! at interior points of integration range. +! + if( max ( abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03*epmach)* & + ( abs ( a2)+0.1D+04*uflow)) ier = 3 +! +! append the newly-created intervals to the list. +! + 35 if(error2.gt.error1) go to 40 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 50 + + 40 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +! +! call dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with largest error estimate (to be bisected next). +! + 50 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if (ier.ne.0.or.errsum.le.errbnd) go to 70 + 60 continue +! +! compute final result. +! + 70 continue + + result = 0.0D+00 + do k=1,last + result = result+rlist(k) + end do + + abserr = errsum + 999 continue + + return +end +subroutine dqaws ( f, a, b, alfa, beta, integr, epsabs, epsrel, result, & + abserr, neval, ier, limit, lenw, last, iwork, work ) + +!*****************************************************************************80 +! +!! DQAWS estimates integrals with algebraico-logarithmic endpoint singularities. +! +! Modified: +! +! 12 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f*w over (a,b), +! (where w shows a singular behaviour at the end points +! see parameter integr). +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration, b.gt.a +! if b.le.a, the routine will end with ier = 6. +! +! alfa - real ( kind = 8 ) +! parameter in the integrand function, alfa.gt.(-1) +! if alfa.le.(-1), the routine will end with +! ier = 6. +! +! beta - real ( kind = 8 ) +! parameter in the integrand function, beta.gt.(-1) +! if beta.le.(-1), the routine will end with +! ier = 6. +! +! integr - integer ( kind = 4 ) +! indicates which weight function is to be used +! = 1 (x-a)**alfa*(b-x)**beta +! = 2 (x-a)**alfa*(b-x)**beta*log(x-a) +! = 3 (x-a)**alfa*(b-x)**beta*log(b-x) +! = 4 (x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x) +! if integr.lt.1 or integr.gt.4, the routine +! will end with ier = 6. +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - integer ( kind = 4 ) +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine +! the estimates for the integral and error +! are less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand, in order to +! determine the integration difficulties +! which prevent the requested tolerance from +! being achieved. in case of a jump +! discontinuity or a local singularity +! of algebraico-logarithmic type at one or +! more interior points of the integration +! range, one should proceed by splitting up +! the interval at these points and calling +! the integrator on the subranges. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 6 the input is invalid, because +! b.le.a or alfa.le.(-1) or beta.le.(-1) or +! or integr.lt.1 or integr.gt.4 or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or limit.lt.2 or lenw.lt.limit*4. +! result, abserr, neval, last are set to +! zero. except when lenw or limit is invalid +! iwork(1), work(limit*2+1) and +! work(limit*3+1) are set to zero, work(1) +! is set to a and work(limit+1) to b. +! +! dimensioning parameters +! limit - integer ( kind = 4 ) +! dimensioning parameter for iwork +! limit determines the maximum number of +! subintervals in the partition of the given +! integration interval (a,b), limit.ge.2. +! if limit.lt.2, the routine will end with ier = 6. +! +! lenw - integer ( kind = 4 ) +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw.lt.limit*4, the routine will end +! with ier = 6. +! +! last - integer ( kind = 4 ) +! on return, last equals the number of +! subintervals produced in the subdivision process, +! which determines the significant number of +! elements actually in the work arrays. +! +! work arrays +! iwork - integer ( kind = 4 ) +! vector of dimension limit, the first k +! elements of which contain pointers +! to the error estimates over the subintervals, +! such that work(limit*3+iwork(1)), ..., +! work(limit*3+iwork(k)) form a decreasing +! sequence with k = last if last.le.(limit/2+2), +! and k = limit+1-last otherwise +! +! work - real ( kind = 8 ) +! vector of dimension lenw +! on return +! work(1), ..., work(last) contain the left +! end points of the subintervals in the +! partition of (a,b), +! work(limit+1), ..., work(limit+last) contain +! the right end points, +! work(limit*2+1), ..., work(limit*2+last) +! contain the integral approximations over +! the subintervals, +! work(limit*3+1), ..., work(limit*3+last) +! contain the error estimates. +! + implicit none + + real ( kind = 8 ) a,abserr,alfa,b,beta,epsabs,epsrel,f,result,work + integer ( kind = 4 ) ier,integr,iwork,last,lenw,limit,lvl,l1,l2,l3 + integer ( kind = 4 ) neval + dimension iwork(limit),work(lenw) + + external f +! +! check validity of limit and lenw. +! + ier = 6 + neval = 0 + last = 0 + result = 0.0D+00 + abserr = 0.0D+00 + if(limit.lt.2.or.lenw.lt.limit*4) go to 10 +! +! prepare call for dqawse. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + + call dqawse(f,a,b,alfa,beta,integr,epsabs,epsrel,limit,result, & + abserr,neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) call xerror('abnormal return from dqaws',26,ier,lvl) + + return +end +subroutine dqc25c(f,a,b,c,result,abserr,krul,neval) + +!*****************************************************************************80 +! +!! DQC25C returns integration rules for Cauchy Principal Value integrals. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f*w over (a,b) with +! error estimate, where w(x) = 1/(x-c) +! +! Parameters: +! +! f - real ( kind = 8 ) +! function subprogram defining the integrand function +! f(x). the actual name for f needs to be declared +! e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! left end point of the integration interval +! +! b - real ( kind = 8 ) +! right end point of the integration interval, b.gt.a +! +! c - real ( kind = 8 ) +! parameter in the weight function +! +! result - real ( kind = 8 ) +! approximation to the integral +! result is computed by using a generalized +! clenshaw-curtis method if c lies within ten percent +! of the integration interval. in the other case the +! 15-point kronrod rule obtained by optimal addition +! of abscissae to the 7-point gauss rule, is applied. +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! krul - integer ( kind = 4 ) +! key which is decreased by 1 if the 15-point +! gauss-kronrod scheme has been used +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! Local Parameters: +! +! fval - value of the function f at the points +! cos(k*pi/24), k = 0, ..., 24 +! cheb12 - chebyshev series expansion coefficients, +! for the function f, of degree 12 +! cheb24 - chebyshev series expansion coefficients, +! for the function f, of degree 24 +! res12 - approximation to the integral corresponding +! to the use of cheb12 +! res24 - approximation to the integral corresponding +! to the use of cheb24 +! dqwgtc - external function subprogram defining +! the weight function +! hlgth - half-length of the interval +! centr - mid point of the interval +! +! the vector x contains the values cos(k*pi/24), +! k = 1, ..., 11, to be used for the chebyshev series +! expansion of f +! + implicit none + + real ( kind = 8 ) a,abserr,ak22,amom0,amom1,amom2,b,c,cc,centr, & + cheb12,cheb24,dqwgtc,f,fval,hlgth,p2,p3,p4,resabs, & + resasc,result,res12,res24,u,x + integer ( kind = 4 ) i,isym,k,kp,krul,neval + dimension x(11),fval(25),cheb12(13),cheb24(25) + + external f + external dqwgtc + + data x(1) / 0.991444861373810411144557526928563d0 / + data x(2) / 0.965925826289068286749743199728897d0 / + data x(3) / 0.923879532511286756128183189396788d0 / + data x(4) / 0.866025403784438646763723170752936d0 / + data x(5) / 0.793353340291235164579776961501299d0 / + data x(6) / 0.707106781186547524400844362104849d0 / + data x(7) / 0.608761429008720639416097542898164d0 / + data x(8) / 0.500000000000000000000000000000000d0 / + data x(9) / 0.382683432365089771728459984030399d0 / + data x(10) / 0.258819045102520762348898837624048d0 / + data x(11) / 0.130526192220051591548406227895489d0 / +! +! check the position of c. +! + cc = (0.2D+01*c-b-a)/(b-a) + if( abs ( cc).lt.0.11D+01) go to 10 +! +! apply the 15-point gauss-kronrod scheme. +! + krul = krul-1 + call dqk15w(f,dqwgtc,c,p2,p3,p4,kp,a,b,result,abserr, & + resabs,resasc) + neval = 15 + if (resasc.eq.abserr) krul = krul+1 + go to 50 +! +! use the generalized clenshaw-curtis method. +! + 10 hlgth = 0.5D+00*(b-a) + centr = 0.5D+00*(b+a) + neval = 25 + fval(1) = 0.5D+00*f(hlgth+centr) + fval(13) = f(centr) + fval(25) = 0.5D+00*f(centr-hlgth) + + do i=2,12 + u = hlgth*x(i-1) + isym = 26-i + fval(i) = f(u+centr) + fval(isym) = f(centr-u) + end do +! +! compute the chebyshev series expansion. +! + call dqcheb(x,fval,cheb12,cheb24) +! +! the modified chebyshev moments are computed by forward +! recursion, using amom0 and amom1 as starting values. +! + amom0 = log ( abs ( (0.1D+01-cc)/(0.1D+01+cc))) + amom1 = 0.2D+01+cc*amom0 + res12 = cheb12(1)*amom0+cheb12(2)*amom1 + res24 = cheb24(1)*amom0+cheb24(2)*amom1 + + do k=3,13 + amom2 = 0.2D+01*cc*amom1-amom0 + ak22 = (k-2)*(k-2) + if((k/2)*2.eq.k) amom2 = amom2-0.4D+01/(ak22-0.1D+01) + res12 = res12+cheb12(k)*amom2 + res24 = res24+cheb24(k)*amom2 + amom0 = amom1 + amom1 = amom2 + end do + + do k=14,25 + amom2 = 0.2D+01*cc*amom1-amom0 + ak22 = (k-2)*(k-2) + if((k/2)*2.eq.k) amom2 = amom2-0.4D+01/(ak22-0.1D+01) + res24 = res24+cheb24(k)*amom2 + amom0 = amom1 + amom1 = amom2 + end do + + result = res24 + abserr = abs ( res24-res12) + 50 continue + + return +end +subroutine dqc25f(f,a,b,omega,integr,nrmom,maxp1,ksave,result, & + abserr,neval,resabs,resasc,momcom,chebmo) + +!*****************************************************************************80 +! +!! DQC25F returns integration rules for functions with a COS or SIN factor. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute the integral i=integral of f(x) over (a,b) +! where w(x) = cos(omega*x) or w(x)=sin(omega*x) and to +! compute j = integral of abs(f) over (a,b). for small value +! of omega or small intervals (a,b) the 15-point gauss-kronro +! rule is used. otherwise a generalized clenshaw-curtis +! method is used. +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to +! be declared e x t e r n a l in the calling program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! omega - real ( kind = 8 ) +! parameter in the weight function +! +! integr - integer ( kind = 4 ) +! indicates which weight function is to be used +! integr = 1 w(x) = cos(omega*x) +! integr = 2 w(x) = sin(omega*x) +! +! nrmom - integer ( kind = 4 ) +! the length of interval (a,b) is equal to the length +! of the original integration interval divided by +! 2**nrmom (we suppose that the routine is used in an +! adaptive integration process, otherwise set +! nrmom = 0). nrmom must be zero at the first call. +! +! maxp1 - integer ( kind = 4 ) +! gives an upper bound on the number of chebyshev +! moments which can be stored, i.e. for the +! intervals of lengths abs(bb-aa)*2**(-l), +! l = 0,1,2, ..., maxp1-2. +! +! ksave - integer ( kind = 4 ) +! key which is one when the moments for the +! current interval have been computed +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute +! error, which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs(f-i/(b-a)) +! +! on entry and return +! momcom - integer ( kind = 4 ) +! for each interval length we need to compute the +! chebyshev moments. momcom counts the number of +! intervals for which these moments have already been +! computed. if nrmom.lt.momcom or ksave = 1, the +! chebyshev moments for the interval (a,b) have +! already been computed and stored, otherwise we +! compute them and we increase momcom. +! +! chebmo - real ( kind = 8 ) +! array of dimension at least (maxp1,25) containing +! the modified chebyshev moments for the first momcom +! momcom interval lengths +! +! Local Parameters: +! +! the vector x contains the values cos(k*pi/24) +! k = 1, ...,11, to be used for the chebyshev expansion of f +! +! centr - mid point of the integration interval +! hlgth - half-length of the integration interval +! fval - value of the function f at the points +! (b-a)*0.5*cos(k*pi/12) + (b+a)*0.5, k = 0, ..., 24 +! cheb12 - coefficients of the chebyshev series expansion +! of degree 12, for the function f, in the +! interval (a,b) +! cheb24 - coefficients of the chebyshev series expansion +! of degree 24, for the function f, in the +! interval (a,b) +! resc12 - approximation to the integral of +! cos(0.5*(b-a)*omega*x)*f(0.5*(b-a)*x+0.5*(b+a)) +! over (-1,+1), using the chebyshev series +! expansion of degree 12 +! resc24 - approximation to the same integral, using the +! chebyshev series expansion of degree 24 +! ress12 - the analogue of resc12 for the sine +! ress24 - the analogue of resc24 for the sine +! +! +! machine dependent constant +! +! oflow is the largest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,abserr,ac,an,an2,as,asap,ass,b,centr,chebmo, & + cheb12,cheb24,conc,cons,cospar,d,dqwgtf,d1, & + d2,estc,ests,f,fval,hlgth,oflow,omega,parint,par2,par22, & + p2,p3,p4,resabs,resasc,resc12,resc24,ress12,ress24,result, & + sinpar,v,x + integer ( kind = 4 ) i,iers,integr,isym,j,k,ksave,m,momcom,neval, maxp1,& + noequ,noeq1,nrmom + dimension chebmo(maxp1,25),cheb12(13),cheb24(25),d(25),d1(25), & + d2(25),fval(25),v(28),x(11) + + external f,dqwgtf + + data x(1) / 0.991444861373810411144557526928563d0 / + data x(2) / 0.965925826289068286749743199728897d0 / + data x(3) / 0.923879532511286756128183189396788d0 / + data x(4) / 0.866025403784438646763723170752936d0 / + data x(5) / 0.793353340291235164579776961501299d0 / + data x(6) / 0.707106781186547524400844362104849d0 / + data x(7) / 0.608761429008720639416097542898164d0 / + data x(8) / 0.500000000000000000000000000000000d0 / + data x(9) / 0.382683432365089771728459984030399d0 / + data x(10) / 0.258819045102520762348898837624048d0 / + data x(11) / 0.130526192220051591548406227895489d0 / + + oflow = huge ( oflow ) + centr = 0.5D+00*(b+a) + hlgth = 0.5D+00*(b-a) + parint = omega*hlgth +! +! compute the integral using the 15-point gauss-kronrod +! formula if the value of the parameter in the integrand is small. +! + if( abs ( parint).gt.0.2D+01) go to 10 + call dqk15w(f,dqwgtf,omega,p2,p3,p4,integr,a,b,result, & + abserr,resabs,resasc) + neval = 15 + go to 170 +! +! compute the integral using the generalized clenshaw- +! curtis method. +! + 10 conc = hlgth*dcos(centr*omega) + cons = hlgth*dsin(centr*omega) + resasc = oflow + neval = 25 +! +! check whether the chebyshev moments for this interval +! have already been computed. +! + if(nrmom.lt.momcom.or.ksave.eq.1) go to 120 +! +! compute a new set of chebyshev moments. +! + m = momcom+1 + par2 = parint*parint + par22 = par2+0.2D+01 + sinpar = dsin(parint) + cospar = dcos(parint) +! +! compute the chebyshev moments with respect to cosine. +! + v(1) = 0.2D+01*sinpar/parint + v(2) = (0.8D+01*cospar+(par2+par2-0.8D+01)*sinpar/parint)/par2 + v(3) = (0.32D+02*(par2-0.12D+02)*cospar+(0.2D+01* & + ((par2-0.80D+02)*par2+0.192D+03)*sinpar)/parint)/(par2*par2) + ac = 0.8D+01*cospar + as = 0.24D+02*parint*sinpar + if( abs ( parint).gt.0.24D+02) go to 30 +! +! compute the chebyshev moments as the solutions of a +! boundary value problem with 1 initial value (v(3)) and 1 +! end value (computed using an asymptotic formula). +! + noequ = 25 + noeq1 = noequ-1 + an = 0.6D+01 + + do k = 1,noeq1 + an2 = an*an + d(k) = -0.2D+01*(an2-0.4D+01)*(par22-an2-an2) + d2(k) = (an-0.1D+01)*(an-0.2D+01)*par2 + d1(k+1) = (an+0.3D+01)*(an+0.4D+01)*par2 + v(k+3) = as-(an2-0.4D+01)*ac + an = an+0.2D+01 + end do + + an2 = an*an + d(noequ) = -0.2D+01*(an2-0.4D+01)*(par22-an2-an2) + v(noequ+3) = as-(an2-0.4D+01)*ac + v(4) = v(4)-0.56D+02*par2*v(3) + ass = parint*sinpar + asap = (((((0.210D+03*par2-0.1D+01)*cospar-(0.105D+03*par2 & + -0.63D+02)*ass)/an2-(0.1D+01-0.15D+02*par2)*cospar & + +0.15D+02*ass)/an2-cospar+0.3D+01*ass)/an2-cospar)/an2 + v(noequ+3) = v(noequ+3)-0.2D+01*asap*par2*(an-0.1D+01)* & + (an-0.2D+01) +! +! solve the tridiagonal system by means of gaussian +! elimination with partial pivoting. +! + call dgtsl(noequ,d1,d,d2,v(4),iers) + go to 50 +! +! compute the chebyshev moments by means of forward recursion. +! + 30 an = 0.4D+01 + + do i = 4,13 + an2 = an*an + v(i) = ((an2-0.4D+01)*(0.2D+01*(par22-an2-an2)*v(i-1)-ac) & + +as-par2*(an+0.1D+01)*(an+0.2D+01)*v(i-2))/ & + (par2*(an-0.1D+01)*(an-0.2D+01)) + an = an+0.2D+01 + end do + + 50 continue + + do j = 1,13 + chebmo(m,2*j-1) = v(j) + end do +! +! compute the chebyshev moments with respect to sine. +! + v(1) = 0.2D+01*(sinpar-parint*cospar)/par2 + v(2) = (0.18D+02-0.48D+02/par2)*sinpar/par2 & + +(-0.2D+01+0.48D+02/par2)*cospar/parint + ac = -0.24D+02*parint*cospar + as = -0.8D+01*sinpar + if( abs ( parint).gt.0.24D+02) go to 80 +! +! compute the chebyshev moments as the solutions of a boundary +! value problem with 1 initial value (v(2)) and 1 end value +! (computed using an asymptotic formula). +! + an = 0.5D+01 + + do k = 1,noeq1 + an2 = an*an + d(k) = -0.2D+01*(an2-0.4D+01)*(par22-an2-an2) + d2(k) = (an-0.1D+01)*(an-0.2D+01)*par2 + d1(k+1) = (an+0.3D+01)*(an+0.4D+01)*par2 + v(k+2) = ac+(an2-0.4D+01)*as + an = an+0.2D+01 + end do + + an2 = an*an + d(noequ) = -0.2D+01*(an2-0.4D+01)*(par22-an2-an2) + v(noequ+2) = ac+(an2-0.4D+01)*as + v(3) = v(3)-0.42D+02*par2*v(2) + ass = parint*cospar + asap = (((((0.105D+03*par2-0.63D+02)*ass+(0.210D+03*par2 & + -0.1D+01)*sinpar)/an2+(0.15D+02*par2-0.1D+01)*sinpar- & + 0.15D+02*ass)/an2-0.3D+01*ass-sinpar)/an2-sinpar)/an2 + v(noequ+2) = v(noequ+2)-0.2D+01*asap*par2*(an-0.1D+01) & + *(an-0.2D+01) +! +! solve the tridiagonal system by means of gaussian +! elimination with partial pivoting. +! + call dgtsl(noequ,d1,d,d2,v(3),iers) + go to 100 +! +! compute the chebyshev moments by means of forward recursion. +! + 80 an = 0.3D+01 + + do i = 3,12 + an2 = an*an + v(i) = ((an2-0.4D+01)*(0.2D+01*(par22-an2-an2)*v(i-1)+as) & + +ac-par2*(an+0.1D+01)*(an+0.2D+01)*v(i-2)) & + /(par2*(an-0.1D+01)*(an-0.2D+01)) + an = an+0.2D+01 + end do + + 100 continue + + do j = 1,12 + chebmo(m,2*j) = v(j) + end do + + 120 if (nrmom.lt.momcom) m = nrmom+1 + if (momcom.lt.(maxp1-1).and.nrmom.ge.momcom) momcom = momcom+1 +! +! compute the coefficients of the chebyshev expansions +! of degrees 12 and 24 of the function f. +! + fval(1) = 0.5D+00*f(centr+hlgth) + fval(13) = f(centr) + fval(25) = 0.5D+00*f(centr-hlgth) + do i = 2,12 + isym = 26-i + fval(i) = f(hlgth*x(i-1)+centr) + fval(isym) = f(centr-hlgth*x(i-1)) + end do + call dqcheb(x,fval,cheb12,cheb24) +! +! compute the integral and error estimates. +! + resc12 = cheb12(13)*chebmo(m,13) + ress12 = 0.0D+00 + k = 11 + do j = 1,6 + resc12 = resc12+cheb12(k)*chebmo(m,k) + ress12 = ress12+cheb12(k+1)*chebmo(m,k+1) + k = k-2 + end do + resc24 = cheb24(25)*chebmo(m,25) + ress24 = 0.0D+00 + resabs = abs ( cheb24(25)) + k = 23 + do j = 1,12 + resc24 = resc24+cheb24(k)*chebmo(m,k) + ress24 = ress24+cheb24(k+1)*chebmo(m,k+1) + resabs = abs ( cheb24(k))+ abs ( cheb24(k+1)) + k = k-2 + end do + estc = abs ( resc24-resc12) + ests = abs ( ress24-ress12) + resabs = resabs* abs ( hlgth) + if(integr.eq.2) go to 160 + result = conc*resc24-cons*ress24 + abserr = abs ( conc*estc)+ abs ( cons*ests) + go to 170 + 160 result = conc*ress24+cons*resc24 + abserr = abs ( conc*ests)+ abs ( cons*estc) + 170 continue + + return +end +subroutine dqc25s(f,a,b,bl,br,alfa,beta,ri,rj,rg,rh,result, & + abserr,resasc,integr,nev) + +!*****************************************************************************80 +! +!! DQC25S returns rules for algebraico-logarithmic end point singularities. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f*w over (bl,br), with error +! estimate, where the weight function w has a singular +! behaviour of algebraico-logarithmic type at the points +! a and/or b. (bl,br) is a part of (a,b). +! +! Parameters: +! +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! f(x). the actual name for f needs to be declared +! e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! left end point of the original interval +! +! b - real ( kind = 8 ) +! right end point of the original interval, b.gt.a +! +! bl - real ( kind = 8 ) +! lower limit of integration, bl.ge.a +! +! br - real ( kind = 8 ) +! upper limit of integration, br.le.b +! +! alfa - real ( kind = 8 ) +! parameter in the weight function +! +! beta - real ( kind = 8 ) +! parameter in the weight function +! +! ri,rj,rg,rh - real ( kind = 8 ) +! modified chebyshev moments for the application +! of the generalized clenshaw-curtis +! method (computed in routine dqmomo) +! +! result - real ( kind = 8 ) +! approximation to the integral +! result is computed by using a generalized +! clenshaw-curtis method if b1 = a or br = b. +! in all other cases the 15-point kronrod +! rule is applied, obtained by optimal addition of +! abscissae to the 7-point gauss rule. +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs(f*w-i/(b-a)) +! +! integr - integer ( kind = 4 ) +! which determines the weight function +! = 1 w(x) = (x-a)**alfa*(b-x)**beta +! = 2 w(x) = (x-a)**alfa*(b-x)**beta*log(x-a) +! = 3 w(x) = (x-a)**alfa*(b-x)**beta*log(b-x) +! = 4 w(x) = (x-a)**alfa*(b-x)**beta*log(x-a)* +! log(b-x) +! +! nev - integer ( kind = 4 ) +! number of integrand evaluations +! +! Local Parameters: +! +! the vector x contains the values cos(k*pi/24) +! k = 1, ..., 11, to be used for the computation of the +! chebyshev series expansion of f. +! +! fval - value of the function f at the points +! (br-bl)*0.5*cos(k*pi/24)+(br+bl)*0.5 +! k = 0, ..., 24 +! cheb12 - coefficients of the chebyshev series expansion +! of degree 12, for the function f, in the +! interval (bl,br) +! cheb24 - coefficients of the chebyshev series expansion +! of degree 24, for the function f, in the +! interval (bl,br) +! res12 - approximation to the integral obtained from cheb12 +! res24 - approximation to the integral obtained from cheb24 +! dqwgts - external function subprogram defining +! the four possible weight functions +! hlgth - half-length of the interval (bl,br) +! centr - mid point of the interval (bl,br) +! + implicit none + + real ( kind = 8 ) a,abserr,alfa,b,beta,bl,br,centr,cheb12,cheb24, & + dc,f,factor,fix,fval,hlgth,resabs,resasc,result,res12, & + res24,rg,rh,ri,rj,u,dqwgts,x + integer ( kind = 4 ) i,integr,isym,nev + + dimension cheb12(13),cheb24(25),fval(25),rg(25),rh(25),ri(25), & + rj(25),x(11) + + external f,dqwgts + + data x(1) / 0.991444861373810411144557526928563d0 / + data x(2) / 0.965925826289068286749743199728897d0 / + data x(3) / 0.923879532511286756128183189396788d0 / + data x(4) / 0.866025403784438646763723170752936d0 / + data x(5) / 0.793353340291235164579776961501299d0 / + data x(6) / 0.707106781186547524400844362104849d0 / + data x(7) / 0.608761429008720639416097542898164d0 / + data x(8) / 0.500000000000000000000000000000000d0 / + data x(9) / 0.382683432365089771728459984030399d0 / + data x(10) / 0.258819045102520762348898837624048d0 / + data x(11) / 0.130526192220051591548406227895489d0 / + + nev = 25 + if(bl.eq.a.and.(alfa.ne.0.0D+00.or.integr.eq.2.or.integr.eq.4)) & + go to 10 + if(br.eq.b.and.(beta.ne.0.0D+00.or.integr.eq.3.or.integr.eq.4)) & + go to 140 +! +! if a.gt.bl and b.lt.br, apply the 15-point gauss-kronrod scheme. +! +! + call dqk15w(f,dqwgts,a,b,alfa,beta,integr,bl,br, & + result,abserr,resabs,resasc) + nev = 15 + go to 270 +! +! this part of the program is executed only if a = bl. +! +! compute the chebyshev series expansion of the +! following function +! f1 = (0.5*(b+b-br-a)-0.5*(br-a)*x)**beta +! *f(0.5*(br-a)*x+0.5*(br+a)) +! + 10 hlgth = 0.5D+00*(br-bl) + centr = 0.5D+00*(br+bl) + fix = b-centr + fval(1) = 0.5D+00*f(hlgth+centr)*(fix-hlgth)**beta + fval(13) = f(centr)*(fix**beta) + fval(25) = 0.5D+00*f(centr-hlgth)*(fix+hlgth)**beta + do i=2,12 + u = hlgth*x(i-1) + isym = 26-i + fval(i) = f(u+centr)*(fix-u)**beta + fval(isym) = f(centr-u)*(fix+u)**beta + end do + + factor = hlgth**(alfa+0.1D+01) + result = 0.0D+00 + abserr = 0.0D+00 + res12 = 0.0D+00 + res24 = 0.0D+00 + if(integr.gt.2) go to 70 + call dqcheb(x,fval,cheb12,cheb24) +! +! integr = 1 (or 2) +! + do i=1,13 + res12 = res12+cheb12(i)*ri(i) + res24 = res24+cheb24(i)*ri(i) + end do + + do i=14,25 + res24 = res24+cheb24(i)*ri(i) + end do + + if(integr.eq.1) go to 130 +! +! integr = 2 +! + dc = log (br-bl) + result = res24*dc + abserr = abs ( (res24-res12)*dc) + res12 = 0.0D+00 + res24 = 0.0D+00 + do i=1,13 + res12 = res12+cheb12(i)*rg(i) + res24 = res12+cheb24(i)*rg(i) + end do + do i=14,25 + res24 = res24+cheb24(i)*rg(i) + end do + go to 130 +! +! compute the chebyshev series expansion of the +! following function +! f4 = f1*log(0.5*(b+b-br-a)-0.5*(br-a)*x) +! + 70 fval(1) = fval(1)* log (fix-hlgth) + fval(13) = fval(13)* log (fix) + fval(25) = fval(25)* log (fix+hlgth) + do i=2,12 + u = hlgth*x(i-1) + isym = 26-i + fval(i) = fval(i)* log (fix-u) + fval(isym) = fval(isym)* log (fix+u) + end do + call dqcheb(x,fval,cheb12,cheb24) +! +! integr = 3 (or 4) +! + do i=1,13 + res12 = res12+cheb12(i)*ri(i) + res24 = res24+cheb24(i)*ri(i) + end do + + do i=14,25 + res24 = res24+cheb24(i)*ri(i) + end do + if(integr.eq.3) go to 130 +! +! integr = 4 +! + dc = log (br-bl) + result = res24*dc + abserr = abs ( (res24-res12)*dc) + res12 = 0.0D+00 + res24 = 0.0D+00 + do i=1,13 + res12 = res12+cheb12(i)*rg(i) + res24 = res24+cheb24(i)*rg(i) + end do + do i=14,25 + res24 = res24+cheb24(i)*rg(i) + end do + 130 result = (result+res24)*factor + abserr = (abserr+ abs ( res24-res12))*factor + go to 270 +! +! this part of the program is executed only if b = br. +! +! compute the chebyshev series expansion of the following function: +! +! f2 = (0.5*(b+bl-a-a)+0.5*(b-bl)*x)**alfa*f(0.5*(b-bl)*x+0.5*(b+bl)) +! + 140 hlgth = 0.5D+00*(br-bl) + centr = 0.5D+00*(br+bl) + fix = centr-a + fval(1) = 0.5D+00*f(hlgth+centr)*(fix+hlgth)**alfa + fval(13) = f(centr)*(fix**alfa) + fval(25) = 0.5D+00*f(centr-hlgth)*(fix-hlgth)**alfa + do i=2,12 + u = hlgth*x(i-1) + isym = 26-i + fval(i) = f(u+centr)*(fix+u)**alfa + fval(isym) = f(centr-u)*(fix-u)**alfa + end do + factor = hlgth**(beta+0.1D+01) + result = 0.0D+00 + abserr = 0.0D+00 + res12 = 0.0D+00 + res24 = 0.0D+00 + if(integr.eq.2.or.integr.eq.4) go to 200 +! +! integr = 1 (or 3) +! + call dqcheb(x,fval,cheb12,cheb24) + + do i=1,13 + res12 = res12+cheb12(i)*rj(i) + res24 = res24+cheb24(i)*rj(i) + end do + + do i=14,25 + res24 = res24+cheb24(i)*rj(i) + end do + + if(integr.eq.1) go to 260 +! +! integr = 3 +! + dc = log (br-bl) + result = res24*dc + abserr = abs ( (res24-res12)*dc) + res12 = 0.0D+00 + res24 = 0.0D+00 + do i=1,13 + res12 = res12+cheb12(i)*rh(i) + res24 = res24+cheb24(i)*rh(i) + end do + + do i=14,25 + res24 = res24+cheb24(i)*rh(i) + end do + go to 260 +! +! compute the chebyshev series expansion of the +! following function +! f3 = f2*log(0.5*(b-bl)*x+0.5*(b+bl-a-a)) +! + 200 fval(1) = fval(1)* log (hlgth+fix) + fval(13) = fval(13)* log (fix) + fval(25) = fval(25)* log (fix-hlgth) + do i=2,12 + u = hlgth*x(i-1) + isym = 26-i + fval(i) = fval(i)* log (u+fix) + fval(isym) = fval(isym)* log (fix-u) + end do + call dqcheb(x,fval,cheb12,cheb24) +! +! integr = 2 (or 4) +! + do i=1,13 + res12 = res12+cheb12(i)*rj(i) + res24 = res24+cheb24(i)*rj(i) + end do + + do i=14,25 + res24 = res24+cheb24(i)*rj(i) + end do + + if(integr.eq.2) go to 260 + dc = log (br-bl) + result = res24*dc + abserr = abs ( (res24-res12)*dc) + res12 = 0.0D+00 + res24 = 0.0D+00 +! +! integr = 4 +! + do i=1,13 + res12 = res12+cheb12(i)*rh(i) + res24 = res24+cheb24(i)*rh(i) + end do + + do i=14,25 + res24 = res24+cheb24(i)*rh(i) + end do + + 260 result = (result+res24)*factor + abserr = (abserr+ abs ( res24-res12))*factor + 270 return +end +subroutine dqcheb ( x, fval, cheb12, cheb24 ) + +!*****************************************************************************80 +! +!! DQCHEB computes the Chebyshev series expansion. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose this routine computes the chebyshev series expansion +! of degrees 12 and 24 of a function using a +! fast fourier transform method +! f(x) = sum(k=1,..,13) (cheb12(k)*t(k-1,x)), +! f(x) = sum(k=1,..,25) (cheb24(k)*t(k-1,x)), +! where t(k,x) is the chebyshev polynomial of degree k. +! +! Parameters: +! +! on entry +! x - real ( kind = 8 ) +! vector of dimension 11 containing the +! values cos(k*pi/24), k = 1, ..., 11 +! +! fval - real ( kind = 8 ) +! vector of dimension 25 containing the +! function values at the points +! (b+a+(b-a)*cos(k*pi/24))/2, k = 0, ...,24, +! where (a,b) is the approximation interval. +! fval(1) and fval(25) are divided by two +! (these values are destroyed at output). +! +! on return +! cheb12 - real ( kind = 8 ) +! vector of dimension 13 containing the +! chebyshev coefficients for degree 12 +! +! cheb24 - real ( kind = 8 ) +! vector of dimension 25 containing the +! chebyshev coefficients for degree 24 +! + implicit none + + real ( kind = 8 ) alam,alam1,alam2,cheb12,cheb24,fval,part1,part2, & + part3,v,x + integer ( kind = 4 ) i,j + + dimension cheb12(13),cheb24(25),fval(25),v(12),x(11) + + do i=1,12 + j = 26-i + v(i) = fval(i)-fval(j) + fval(i) = fval(i)+fval(j) + end do + + alam1 = v(1)-v(9) + alam2 = x(6)*(v(3)-v(7)-v(11)) + cheb12(4) = alam1+alam2 + cheb12(10) = alam1-alam2 + alam1 = v(2)-v(8)-v(10) + alam2 = v(4)-v(6)-v(12) + alam = x(3)*alam1+x(9)*alam2 + cheb24(4) = cheb12(4)+alam + cheb24(22) = cheb12(4)-alam + alam = x(9)*alam1-x(3)*alam2 + cheb24(10) = cheb12(10)+alam + cheb24(16) = cheb12(10)-alam + part1 = x(4)*v(5) + part2 = x(8)*v(9) + part3 = x(6)*v(7) + alam1 = v(1)+part1+part2 + alam2 = x(2)*v(3)+part3+x(10)*v(11) + cheb12(2) = alam1+alam2 + cheb12(12) = alam1-alam2 + alam = x(1)*v(2)+x(3)*v(4)+x(5)*v(6)+x(7)*v(8) & + +x(9)*v(10)+x(11)*v(12) + cheb24(2) = cheb12(2)+alam + cheb24(24) = cheb12(2)-alam + alam = x(11)*v(2)-x(9)*v(4)+x(7)*v(6)-x(5)*v(8) & + +x(3)*v(10)-x(1)*v(12) + cheb24(12) = cheb12(12)+alam + cheb24(14) = cheb12(12)-alam + alam1 = v(1)-part1+part2 + alam2 = x(10)*v(3)-part3+x(2)*v(11) + cheb12(6) = alam1+alam2 + cheb12(8) = alam1-alam2 + alam = x(5)*v(2)-x(9)*v(4)-x(1)*v(6) & + -x(11)*v(8)+x(3)*v(10)+x(7)*v(12) + cheb24(6) = cheb12(6)+alam + cheb24(20) = cheb12(6)-alam + alam = x(7)*v(2)-x(3)*v(4)-x(11)*v(6)+x(1)*v(8) & + -x(9)*v(10)-x(5)*v(12) + cheb24(8) = cheb12(8)+alam + cheb24(18) = cheb12(8)-alam + + do i=1,6 + j = 14-i + v(i) = fval(i)-fval(j) + fval(i) = fval(i)+fval(j) + end do + + alam1 = v(1)+x(8)*v(5) + alam2 = x(4)*v(3) + cheb12(3) = alam1+alam2 + cheb12(11) = alam1-alam2 + cheb12(7) = v(1)-v(5) + alam = x(2)*v(2)+x(6)*v(4)+x(10)*v(6) + cheb24(3) = cheb12(3)+alam + cheb24(23) = cheb12(3)-alam + alam = x(6)*(v(2)-v(4)-v(6)) + cheb24(7) = cheb12(7)+alam + cheb24(19) = cheb12(7)-alam + alam = x(10)*v(2)-x(6)*v(4)+x(2)*v(6) + cheb24(11) = cheb12(11)+alam + cheb24(15) = cheb12(11)-alam + + do i=1,3 + j = 8-i + v(i) = fval(i)-fval(j) + fval(i) = fval(i)+fval(j) + end do + + cheb12(5) = v(1)+x(8)*v(3) + cheb12(9) = fval(1)-x(8)*fval(3) + alam = x(4)*v(2) + cheb24(5) = cheb12(5)+alam + cheb24(21) = cheb12(5)-alam + alam = x(8)*fval(2)-fval(4) + cheb24(9) = cheb12(9)+alam + cheb24(17) = cheb12(9)-alam + cheb12(1) = fval(1)+fval(3) + alam = fval(2)+fval(4) + cheb24(1) = cheb12(1)+alam + cheb24(25) = cheb12(1)-alam + cheb12(13) = v(1)-v(3) + cheb24(13) = cheb12(13) + alam = 0.1D+01/0.6D+01 + + do i=2,12 + cheb12(i) = cheb12(i)*alam + end do + + alam = 0.5D+00*alam + cheb12(1) = cheb12(1)*alam + cheb12(13) = cheb12(13)*alam + + do i=2,24 + cheb24(i) = cheb24(i)*alam + end do + + cheb24(1) = 0.5D+00*alam*cheb24(1) + cheb24(25) = 0.5D+00*alam*cheb24(25) + + return +end +subroutine dqelg ( n, epstab, result, abserr, res3la, nres ) + +!*****************************************************************************80 +! +!! DQELG carries out the Epsilon extrapolation algorithm. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine determines the limit of a given sequence of +! approximations, by means of the epsilon algorithm of +! p.wynn. an estimate of the absolute error is also given. +! the condensed epsilon table is computed. only those +! elements needed for the computation of the next diagonal +! are preserved. +! +! Parameters: +! +! n - integer ( kind = 4 ) +! epstab(n) contains the new element in the +! first column of the epsilon table. +! +! epstab - real ( kind = 8 ) +! vector of dimension 52 containing the elements +! of the two lower diagonals of the triangular +! epsilon table. the elements are numbered +! starting at the right-hand corner of the +! triangle. +! +! result - real ( kind = 8 ) +! resulting approximation to the integral +! +! abserr - real ( kind = 8 ) +! estimate of the absolute error computed from +! result and the 3 previous results +! +! res3la - real ( kind = 8 ) +! vector of dimension 3 containing the last 3 +! results +! +! nres - integer ( kind = 4 ) +! number of calls to the routine +! (should be zero at first call) +! +! Local Parameters: +! +! e0 - the 4 elements on which the computation of a new +! e1 element in the epsilon table is based +! e2 +! e3 e0 +! e3 e1 new +! e2 +! newelm - number of elements to be computed in the new +! diagonal +! error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) +! result - the element in the new diagonal with least value +! of error +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! oflow is the largest positive magnitude. +! limexp is the maximum number of elements the epsilon +! table can contain. if this number is reached, the upper +! diagonal of the epsilon table is deleted. +! + implicit none + + real ( kind = 8 ) abserr,delta1,delta2,delta3, & + epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3, & + oflow,res,result,res3la,ss,tol1,tol2,tol3 + integer ( kind = 4 ) i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm + integer ( kind = 4 ) nres + integer ( kind = 4 ) num + dimension epstab(52),res3la(3) + + epmach = epsilon ( epmach ) + oflow = huge ( oflow ) + nres = nres+1 + abserr = oflow + result = epstab(n) + if(n.lt.3) go to 100 + limexp = 50 + epstab(n+2) = epstab(n) + newelm = (n-1)/2 + epstab(n) = oflow + num = n + k1 = n + + do 40 i = 1,newelm + + k2 = k1-1 + k3 = k1-2 + res = epstab(k1+2) + e0 = epstab(k3) + e1 = epstab(k2) + e2 = res + e1abs = abs ( e1) + delta2 = e2-e1 + err2 = abs ( delta2) + tol2 = max ( abs ( e2),e1abs)*epmach + delta3 = e1 - e0 + err3 = abs ( delta3) + tol3 = max ( e1abs, abs ( e0))*epmach + if(err2.gt.tol2.or.err3.gt.tol3) go to 10 +! +! if e0, e1 and e2 are equal to machine accuracy, convergence is assumed. +! + result = res + abserr = err2+err3 + go to 100 + 10 e3 = epstab(k1) + epstab(k1) = e1 + delta1 = e1-e3 + err1 = abs ( delta1) + tol1 = max ( e1abs, abs ( e3))*epmach +! +! if two elements are very close to each other, omit +! a part of the table by adjusting the value of n +! + if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20 + ss = 0.1D+01/delta1+0.1D+01/delta2-0.1D+01/delta3 + epsinf = abs ( ss*e1) +! +! test to detect irregular behaviour in the table, and +! eventually omit a part of the table adjusting the value +! of n. +! + if(epsinf.gt.0.1D-03) go to 30 + 20 n = i+i-1 + go to 50 +! +! compute a new element and eventually adjust +! the value of result. +! + 30 res = e1+0.1D+01/ss + epstab(k1) = res + k1 = k1-2 + error = err2 + abs ( res-e2 ) + err3 + + if ( error .le. abserr ) then + abserr = error + result = res + end if + + 40 continue +! +! shift the table. +! + 50 if(n.eq.limexp) n = 2*(limexp/2)-1 + ib = 1 + if((num/2)*2.eq.num) ib = 2 + ie = newelm+1 + do i=1,ie + ib2 = ib+2 + epstab(ib) = epstab(ib2) + ib = ib2 + end do + if(num.eq.n) go to 80 + indx = num-n+1 + do i = 1,n + epstab(i)= epstab(indx) + indx = indx+1 + end do + 80 if(nres.ge.4) go to 90 + res3la(nres) = result + abserr = oflow + go to 100 +! +! compute error estimate +! + 90 abserr = abs ( result-res3la(3))+ abs ( result-res3la(2)) & + + abs ( result-res3la(1)) + res3la(1) = res3la(2) + res3la(2) = res3la(3) + res3la(3) = result + 100 continue + + abserr = max ( abserr, 0.5D+01*epmach* abs ( result)) + + return +end +subroutine dqk15(f,a,b,result,abserr,resabs,resasc) + +!*****************************************************************************80 +! +!! DQK15 carries out a 15 point Gauss-Kronrod quadrature rule. +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 15-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 7-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 7-point gauss rule +! +! wgk - weights of the 15-point kronrod rule +! +! wg - weights of the 7-point gauss rule +! +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f over (a,b), with error +! estimate +! j = integral of abs(f) over (a,b) +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 15-point +! kronrod rule (resk) obtained by optimal addition +! of abscissae to the7-point gauss rule(resg). +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +! Local Parameters: +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc - abscissa +! fval* - function value +! resg - result of the 7-point gauss formula +! resk - result of the 15-point kronrod formula +! reskh - approximation to the mean value of f over (a,b), +! i.e. to i/(b-a) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,abserr,b,centr,dhlgth, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, & + resg,resk,reskh,result,uflow,wg,wgk,xgk + integer ( kind = 4 ) j,jtw,jtwm1 + external f + dimension fv1(7),fv2(7),wg(4),wgk(8),xgk(8) + + data wg ( 1) / 0.129484966168869693270611432679082d0 / + data wg ( 2) / 0.279705391489276667901467771423780d0 / + data wg ( 3) / 0.381830050505118944950369775488975d0 / + data wg ( 4) / 0.417959183673469387755102040816327d0 / + + data xgk ( 1) / 0.991455371120812639206854697526329d0 / + data xgk ( 2) / 0.949107912342758524526189684047851d0 / + data xgk ( 3) / 0.864864423359769072789712788640926d0 / + data xgk ( 4) / 0.741531185599394439863864773280788d0 / + data xgk ( 5) / 0.586087235467691130294144838258730d0 / + data xgk ( 6) / 0.405845151377397166906606412076961d0 / + data xgk ( 7) / 0.207784955007898467600689403773245d0 / + data xgk ( 8) / 0.000000000000000000000000000000000d0 / + + data wgk ( 1) / 0.022935322010529224963732008058970d0 / + data wgk ( 2) / 0.063092092629978553290700663189204d0 / + data wgk ( 3) / 0.104790010322250183839876322541518d0 / + data wgk ( 4) / 0.140653259715525918745189590510238d0 / + data wgk ( 5) / 0.169004726639267902826583426598550d0 / + data wgk ( 6) / 0.190350578064785409913256402421014d0 / + data wgk ( 7) / 0.204432940075298892414161999234649d0 / + data wgk ( 8) / 0.209482141084727828012999174891714d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + centr = 0.5D+00*(a+b) + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) +! +! compute the 15-point kronrod approximation to +! the integral, and estimate the absolute error. +! + fc = f(centr) + resg = fc*wg(4) + resk = fc*wgk(8) + resabs = abs ( resk) + + do j=1,3 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2)) + end do + + do j = 1,4 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(8)* abs ( fc-reskh) + do j=1,7 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) & + abserr = resasc* min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max & + ((epmach*0.5D+02)*resabs,abserr) + + return +end +subroutine dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc) + +!*****************************************************************************80 +! +!! DQK15I applies a 15 point Gauss-Kronrod quadrature on an infinite interval. +! +! +! the abscissae and weights are supplied for the interval +! (-1,1). because of symmetry only the positive abscissae and +! their corresponding weights are given. +! +! xgk - abscissae of the 15-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 7-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 7-point gauss rule +! +! wgk - weights of the 15-point kronrod rule +! +! wg - weights of the 7-point gauss rule, corresponding +! to the abscissae xgk(2), xgk(4), ... +! wg(1), wg(3), ... are set to zero. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the original (infinite integration range is mapped +! onto the interval (0,1) and (a,b) is a part of (0,1). +! it is the purpose to compute +! i = integral of transformed integrand over (a,b), +! j = integral of abs(transformed integrand) over (a,b). +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! fuction subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! boun - real ( kind = 8 ) +! finite bound of original integration +! range (set to zero if inf = +2) +! +! inf - integer ( kind = 4 ) +! if inf = -1, the original interval is +! (-infinity,bound), +! if inf = +1, the original interval is +! (bound,+infinity), +! if inf = +2, the original interval is +! (-infinity,+infinity) and +! the integral is computed as the sum of two +! integrals, one over (-infinity,0) and one over +! (0,+infinity). +! +! a - real ( kind = 8 ) +! lower limit for integration over subrange +! of (0,1) +! +! b - real ( kind = 8 ) +! upper limit for integration over subrange +! of (0,1) +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 15-point +! kronrod rule(resk) obtained by optimal addition +! of abscissae to the 7-point gauss rule(resg). +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integral of +! abs((transformed integrand)-i/(b-a)) over (a,b) +! +! Local Parameters: +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc* - abscissa +! tabsc* - transformed abscissa +! fval* - function value +! resg - result of the 7-point gauss formula +! resk - result of the 15-point kronrod formula +! reskh - approximation to the mean value of the transformed +! integrand over (a,b), i.e. to i/(b-a) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,absc1,absc2,abserr,b,boun,centr,dinf, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth, & + resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2,uflow,wg,wgk, & + xgk + integer ( kind = 4 ) inf,j + external f + dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8) + + data wg(1) / 0.0d0 / + data wg(2) / 0.129484966168869693270611432679082d0 / + data wg(3) / 0.0d0 / + data wg(4) / 0.279705391489276667901467771423780d0 / + data wg(5) / 0.0d0 / + data wg(6) / 0.381830050505118944950369775488975d0 / + data wg(7) / 0.0d0 / + data wg(8) / 0.417959183673469387755102040816327d0 / + + data xgk(1) / 0.991455371120812639206854697526329d0 / + data xgk(2) / 0.949107912342758524526189684047851d0 / + data xgk(3) / 0.864864423359769072789712788640926d0 / + data xgk(4) / 0.741531185599394439863864773280788d0 / + data xgk(5) / 0.586087235467691130294144838258730d0 / + data xgk(6) / 0.405845151377397166906606412076961d0 / + data xgk(7) / 0.207784955007898467600689403773245d0 / + data xgk(8) / 0.000000000000000000000000000000000d0 / + + data wgk(1) / 0.022935322010529224963732008058970d0 / + data wgk(2) / 0.063092092629978553290700663189204d0 / + data wgk(3) / 0.104790010322250183839876322541518d0 / + data wgk(4) / 0.140653259715525918745189590510238d0 / + data wgk(5) / 0.169004726639267902826583426598550d0 / + data wgk(6) / 0.190350578064785409913256402421014d0 / + data wgk(7) / 0.204432940075298892414161999234649d0 / + data wgk(8) / 0.209482141084727828012999174891714d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + dinf = min ( 1, inf ) + centr = 0.5D+00*(a+b) + hlgth = 0.5D+00*(b-a) + tabsc1 = boun+dinf*(0.1D+01-centr)/centr + fval1 = f(tabsc1) + if(inf.eq.2) fval1 = fval1+f(-tabsc1) + fc = (fval1/centr)/centr +! +! compute the 15-point kronrod approximation to +! the integral, and estimate the error. +! + resg = wg(8)*fc + resk = wgk(8)*fc + resabs = abs ( resk) + + do j=1,7 + absc = hlgth*xgk(j) + absc1 = centr-absc + absc2 = centr+absc + tabsc1 = boun+dinf*(0.1D+01-absc1)/absc1 + tabsc2 = boun+dinf*(0.1D+01-absc2)/absc2 + fval1 = f(tabsc1) + fval2 = f(tabsc2) + if(inf.eq.2) fval1 = fval1+f(-tabsc1) + if(inf.eq.2) fval2 = fval2+f(-tabsc2) + fval1 = (fval1/absc1)/absc1 + fval2 = (fval2/absc2)/absc2 + fv1(j) = fval1 + fv2(j) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(j)*fsum + resabs = resabs+wgk(j)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(8)* abs ( fc-reskh) + + do j=1,7 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resasc = resasc*hlgth + resabs = resabs*hlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.d0) abserr = resasc* & + min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max & + ((epmach*0.5D+02)*resabs,abserr) + + return +end +subroutine dqk15w(f,w,p1,p2,p3,p4,kp,a,b,result,abserr, resabs,resasc) + +!*****************************************************************************80 +! +!! DQK15W applies a 15 point Gauss-Kronrod rule for a weighted integrand. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f*w over (a,b), with error +! estimate +! j = integral of abs(f*w) over (a,b) +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! w - real ( kind = 8 ) +! function subprogram defining the integrand +! weight function w(x). the actual name for w +! needs to be declared e x t e r n a l in the +! calling program. +! +! p1, p2, p3, p4 - real ( kind = 8 ) +! parameters in the weight function +! +! kp - integer ( kind = 4 ) +! key for indicating the type of weight function +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 15-point +! kronrod rule (resk) obtained by optimal addition +! of abscissae to the 7-point gauss rule (resg). +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral of abs(f) +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs(f-i/(b-a)) +! +! Local Parameters: +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 15-point gauss-kronrod rule +! xgk(2), xgk(4), ... abscissae of the 7-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 7-point gauss rule +! +! wgk - weights of the 15-point gauss-kronrod rule +! +! wg - weights of the 7-point gauss rule +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc* - abscissa +! fval* - function value +! resg - result of the 7-point gauss formula +! resk - result of the 15-point kronrod formula +! reskh - approximation to the mean value of f*w over (a,b), +! i.e. to i/(b-a) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,absc1,absc2,abserr,b,centr,dhlgth, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth, & + p1,p2,p3,p4,resabs,resasc,resg,resk,reskh,result,uflow,w,wg,wgk, & + xgk + integer ( kind = 4 ) j,jtw,jtwm1,kp + external f,w + + dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(4) + + data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),xgk(8)/ & + 0.9914553711208126D+00, 0.9491079123427585D+00, & + 0.8648644233597691D+00, 0.7415311855993944D+00, & + 0.5860872354676911D+00, 0.4058451513773972D+00, & + 0.2077849550078985D+00, 0.0000000000000000D+00/ + + data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),wgk(8)/ & + 0.2293532201052922D-01, 0.6309209262997855D-01, & + 0.1047900103222502D+00, 0.1406532597155259D+00, & + 0.1690047266392679D+00, 0.1903505780647854D+00, & + 0.2044329400752989D+00, 0.2094821410847278D+00/ + + data wg(1),wg(2),wg(3),wg(4)/ & + 0.1294849661688697D+00, 0.2797053914892767D+00, & + 0.3818300505051889D+00, 0.4179591836734694D+00/ + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + centr = 0.5D+00*(a+b) + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) +! +! compute the 15-point kronrod approximation to the +! integral, and estimate the error. +! + fc = f(centr)*w(centr,p1,p2,p3,p4,kp) + resg = wg(4)*fc + resk = wgk(8)*fc + resabs = abs ( resk) + + do j=1,3 + jtw = j*2 + absc = hlgth*xgk(jtw) + absc1 = centr-absc + absc2 = centr+absc + fval1 = f(absc1)*w(absc1,p1,p2,p3,p4,kp) + fval2 = f(absc2)*w(absc2,p1,p2,p3,p4,kp) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2)) + end do + + do j=1,4 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + absc1 = centr-absc + absc2 = centr+absc + fval1 = f(absc1)*w(absc1,p1,p2,p3,p4,kp) + fval2 = f(absc2)*w(absc2,p1,p2,p3,p4,kp) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(8)* abs ( fc-reskh) + + do j=1,7 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) & + abserr = resasc* min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max ( (epmach* & + 0.5D+02)*resabs,abserr) + + return +end +subroutine dqk21(f,a,b,result,abserr,resabs,resasc) + +!*****************************************************************************80 +! +!! DQK21 carries out a 21 point Gauss-Kronrod quadrature rule. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f over (a,b), with error +! estimate +! j = integral of abs(f) over (a,b) +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 21-point +! kronrod rule (resk) obtained by optimal addition +! of abscissae to the 10-point gauss rule (resg). +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +! Local Parameters: +! +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 21-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 10-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 10-point gauss rule +! +! wgk - weights of the 21-point kronrod rule +! +! wg - weights of the 10-point gauss rule +! +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc - abscissa +! fval* - function value +! resg - result of the 10-point gauss formula +! resk - result of the 21-point kronrod formula +! reskh - approximation to the mean value of f over (a,b), +! i.e. to i/(b-a) +! +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,abserr,b,centr,dhlgth, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, & + resg,resk,reskh,result,uflow,wg,wgk,xgk + integer ( kind = 4 ) j,jtw,jtwm1 + external f + dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11) + + data wg ( 1) / 0.066671344308688137593568809893332d0 / + data wg ( 2) / 0.149451349150580593145776339657697d0 / + data wg ( 3) / 0.219086362515982043995534934228163d0 / + data wg ( 4) / 0.269266719309996355091226921569469d0 / + data wg ( 5) / 0.295524224714752870173892994651338d0 / + + data xgk ( 1) / 0.995657163025808080735527280689003d0 / + data xgk ( 2) / 0.973906528517171720077964012084452d0 / + data xgk ( 3) / 0.930157491355708226001207180059508d0 / + data xgk ( 4) / 0.865063366688984510732096688423493d0 / + data xgk ( 5) / 0.780817726586416897063717578345042d0 / + data xgk ( 6) / 0.679409568299024406234327365114874d0 / + data xgk ( 7) / 0.562757134668604683339000099272694d0 / + data xgk ( 8) / 0.433395394129247190799265943165784d0 / + data xgk ( 9) / 0.294392862701460198131126603103866d0 / + data xgk ( 10) / 0.148874338981631210884826001129720d0 / + data xgk ( 11) / 0.000000000000000000000000000000000d0 / + + data wgk ( 1) / 0.011694638867371874278064396062192d0 / + data wgk ( 2) / 0.032558162307964727478818972459390d0 / + data wgk ( 3) / 0.054755896574351996031381300244580d0 / + data wgk ( 4) / 0.075039674810919952767043140916190d0 / + data wgk ( 5) / 0.093125454583697605535065465083366d0 / + data wgk ( 6) / 0.109387158802297641899210590325805d0 / + data wgk ( 7) / 0.123491976262065851077958109831074d0 / + data wgk ( 8) / 0.134709217311473325928054001771707d0 / + data wgk ( 9) / 0.142775938577060080797094273138717d0 / + data wgk ( 10) / 0.147739104901338491374841515972068d0 / + data wgk ( 11) / 0.149445554002916905664936468389821d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + centr = 0.5D+00*(a+b) + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) +! +! compute the 21-point kronrod approximation to +! the integral, and estimate the absolute error. +! + resg = 0.0D+00 + fc = f(centr) + resk = wgk(11)*fc + resabs = abs ( resk) + do j=1,5 + jtw = 2*j + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2)) + end do + + do j = 1,5 + jtwm1 = 2*j-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(11)* abs ( fc-reskh) + + do j=1,10 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) & + abserr = resasc*min(0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max & + ((epmach*0.5D+02)*resabs,abserr) + + return +end +subroutine dqk31(f,a,b,result,abserr,resabs,resasc) + +!*****************************************************************************80 +! +!! DQK31 carries out a 31 point Gauss-Kronrod quadrature rule. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f over (a,b) with error +! estimate +! j = integral of abs(f) over (a,b) +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 31-point +! gauss-kronrod rule (resk), obtained by optimal +! addition of abscissae to the 15-point gauss +! rule (resg). +! +! abserr - double precison +! estimate of the modulus of the modulus, +! which should not exceed abs(i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +! Local Parameters: +! +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 31-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 15-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 15-point gauss rule +! +! wgk - weights of the 31-point kronrod rule +! +! wg - weights of the 15-point gauss rule +! +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc - abscissa +! fval* - function value +! resg - result of the 15-point gauss formula +! resk - result of the 31-point kronrod formula +! reskh - approximation to the mean value of f over (a,b), +! i.e. to i/(b-a) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,abserr,b,centr,dhlgth, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, & + resg,resk,reskh,result,uflow,wg,wgk,xgk + integer ( kind = 4 ) j,jtw,jtwm1 + external f + + dimension fv1(15),fv2(15),xgk(16),wgk(16),wg(8) + + data wg ( 1) / 0.030753241996117268354628393577204d0 / + data wg ( 2) / 0.070366047488108124709267416450667d0 / + data wg ( 3) / 0.107159220467171935011869546685869d0 / + data wg ( 4) / 0.139570677926154314447804794511028d0 / + data wg ( 5) / 0.166269205816993933553200860481209d0 / + data wg ( 6) / 0.186161000015562211026800561866423d0 / + data wg ( 7) / 0.198431485327111576456118326443839d0 / + data wg ( 8) / 0.202578241925561272880620199967519d0 / + + data xgk ( 1) / 0.998002298693397060285172840152271d0 / + data xgk ( 2) / 0.987992518020485428489565718586613d0 / + data xgk ( 3) / 0.967739075679139134257347978784337d0 / + data xgk ( 4) / 0.937273392400705904307758947710209d0 / + data xgk ( 5) / 0.897264532344081900882509656454496d0 / + data xgk ( 6) / 0.848206583410427216200648320774217d0 / + data xgk ( 7) / 0.790418501442465932967649294817947d0 / + data xgk ( 8) / 0.724417731360170047416186054613938d0 / + data xgk ( 9) / 0.650996741297416970533735895313275d0 / + data xgk ( 10) / 0.570972172608538847537226737253911d0 / + data xgk ( 11) / 0.485081863640239680693655740232351d0 / + data xgk ( 12) / 0.394151347077563369897207370981045d0 / + data xgk ( 13) / 0.299180007153168812166780024266389d0 / + data xgk ( 14) / 0.201194093997434522300628303394596d0 / + data xgk ( 15) / 0.101142066918717499027074231447392d0 / + data xgk ( 16) / 0.000000000000000000000000000000000d0 / + + data wgk ( 1) / 0.005377479872923348987792051430128d0 / + data wgk ( 2) / 0.015007947329316122538374763075807d0 / + data wgk ( 3) / 0.025460847326715320186874001019653d0 / + data wgk ( 4) / 0.035346360791375846222037948478360d0 / + data wgk ( 5) / 0.044589751324764876608227299373280d0 / + data wgk ( 6) / 0.053481524690928087265343147239430d0 / + data wgk ( 7) / 0.062009567800670640285139230960803d0 / + data wgk ( 8) / 0.069854121318728258709520077099147d0 / + data wgk ( 9) / 0.076849680757720378894432777482659d0 / + data wgk ( 10) / 0.083080502823133021038289247286104d0 / + data wgk ( 11) / 0.088564443056211770647275443693774d0 / + data wgk ( 12) / 0.093126598170825321225486872747346d0 / + data wgk ( 13) / 0.096642726983623678505179907627589d0 / + data wgk ( 14) / 0.099173598721791959332393173484603d0 / + data wgk ( 15) / 0.100769845523875595044946662617570d0 / + data wgk ( 16) / 0.101330007014791549017374792767493d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + centr = 0.5D+00*(a+b) + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) +! +! compute the 31-point kronrod approximation to +! the integral, and estimate the absolute error. +! + fc = f(centr) + resg = wg(8)*fc + resk = wgk(16)*fc + resabs = abs ( resk) + + do j=1,7 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2)) + end do + + do j = 1,8 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(16)* abs ( fc-reskh) + + do j=1,15 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) & + abserr = resasc* min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max & + ((epmach*0.5D+02)*resabs,abserr) + + return +end +subroutine dqk41 ( f, a, b, result, abserr, resabs, resasc ) + +!*****************************************************************************80 +! +!! DQK41 carries out a 41 point Gauss-Kronrod quadrature rule. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f over (a,b), with error +! estimate +! j = integral of abs(f) over (a,b) +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 41-point +! gauss-kronrod rule (resk) obtained by optimal +! addition of abscissae to the 20-point gauss +! rule (resg). +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integal of abs(f-i/(b-a)) +! over (a,b) +! +! Local Parameters: +! +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 41-point gauss-kronrod rule +! xgk(2), xgk(4), ... abscissae of the 20-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 20-point gauss rule +! +! wgk - weights of the 41-point gauss-kronrod rule +! +! wg - weights of the 20-point gauss rule +! +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc - abscissa +! fval* - function value +! resg - result of the 20-point gauss formula +! resk - result of the 41-point kronrod formula +! reskh - approximation to mean value of f over (a,b), i.e. +! to i/(b-a) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,abserr,b,centr,dhlgth, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, & + resg,resk,reskh,result,uflow,wg,wgk,xgk + integer ( kind = 4 ) j,jtw,jtwm1 + external f + + dimension fv1(20),fv2(20),xgk(21),wgk(21),wg(10) + + data wg ( 1) / 0.017614007139152118311861962351853d0 / + data wg ( 2) / 0.040601429800386941331039952274932d0 / + data wg ( 3) / 0.062672048334109063569506535187042d0 / + data wg ( 4) / 0.083276741576704748724758143222046d0 / + data wg ( 5) / 0.101930119817240435036750135480350d0 / + data wg ( 6) / 0.118194531961518417312377377711382d0 / + data wg ( 7) / 0.131688638449176626898494499748163d0 / + data wg ( 8) / 0.142096109318382051329298325067165d0 / + data wg ( 9) / 0.149172986472603746787828737001969d0 / + data wg ( 10) / 0.152753387130725850698084331955098d0 / + + data xgk ( 1) / 0.998859031588277663838315576545863d0 / + data xgk ( 2) / 0.993128599185094924786122388471320d0 / + data xgk ( 3) / 0.981507877450250259193342994720217d0 / + data xgk ( 4) / 0.963971927277913791267666131197277d0 / + data xgk ( 5) / 0.940822633831754753519982722212443d0 / + data xgk ( 6) / 0.912234428251325905867752441203298d0 / + data xgk ( 7) / 0.878276811252281976077442995113078d0 / + data xgk ( 8) / 0.839116971822218823394529061701521d0 / + data xgk ( 9) / 0.795041428837551198350638833272788d0 / + data xgk ( 10) / 0.746331906460150792614305070355642d0 / + data xgk ( 11) / 0.693237656334751384805490711845932d0 / + data xgk ( 12) / 0.636053680726515025452836696226286d0 / + data xgk ( 13) / 0.575140446819710315342946036586425d0 / + data xgk ( 14) / 0.510867001950827098004364050955251d0 / + data xgk ( 15) / 0.443593175238725103199992213492640d0 / + data xgk ( 16) / 0.373706088715419560672548177024927d0 / + data xgk ( 17) / 0.301627868114913004320555356858592d0 / + data xgk ( 18) / 0.227785851141645078080496195368575d0 / + data xgk ( 19) / 0.152605465240922675505220241022678d0 / + data xgk ( 20) / 0.076526521133497333754640409398838d0 / + data xgk ( 21) / 0.000000000000000000000000000000000d0 / + + data wgk ( 1) / 0.003073583718520531501218293246031d0 / + data wgk ( 2) / 0.008600269855642942198661787950102d0 / + data wgk ( 3) / 0.014626169256971252983787960308868d0 / + data wgk ( 4) / 0.020388373461266523598010231432755d0 / + data wgk ( 5) / 0.025882133604951158834505067096153d0 / + data wgk ( 6) / 0.031287306777032798958543119323801d0 / + data wgk ( 7) / 0.036600169758200798030557240707211d0 / + data wgk ( 8) / 0.041668873327973686263788305936895d0 / + data wgk ( 9) / 0.046434821867497674720231880926108d0 / + data wgk ( 10) / 0.050944573923728691932707670050345d0 / + data wgk ( 11) / 0.055195105348285994744832372419777d0 / + data wgk ( 12) / 0.059111400880639572374967220648594d0 / + data wgk ( 13) / 0.062653237554781168025870122174255d0 / + data wgk ( 14) / 0.065834597133618422111563556969398d0 / + data wgk ( 15) / 0.068648672928521619345623411885368d0 / + data wgk ( 16) / 0.071054423553444068305790361723210d0 / + data wgk ( 17) / 0.073030690332786667495189417658913d0 / + data wgk ( 18) / 0.074582875400499188986581418362488d0 / + data wgk ( 19) / 0.075704497684556674659542775376617d0 / + data wgk ( 20) / 0.076377867672080736705502835038061d0 / + data wgk ( 21) / 0.076600711917999656445049901530102d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + centr = 0.5D+00*(a+b) + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) +! +! compute the 41-point gauss-kronrod approximation to +! the integral, and estimate the absolute error. +! + resg = 0.0D+00 + fc = f(centr) + resk = wgk(21)*fc + resabs = abs ( resk) + + do j=1,10 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2)) + end do + + do j = 1,10 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(21)* abs ( fc-reskh) + + do j=1,20 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.D+00) & + abserr = resasc* min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max & + ((epmach*0.5D+02)*resabs,abserr) + + return +end +subroutine dqk51(f,a,b,result,abserr,resabs,resasc) + +!*****************************************************************************80 +! +!! DQK51 carries out a 51 point Gauss-Kronrod quadrature rule. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f over (a,b) with error +! estimate +! j = integral of abs(f) over (a,b) +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 51-point +! kronrod rule (resk) obtained by optimal addition +! of abscissae to the 25-point gauss rule (resg). +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +! Local Parameters: +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 51-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 25-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 25-point gauss rule +! +! wgk - weights of the 51-point kronrod rule +! +! wg - weights of the 25-point gauss rule +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc - abscissa +! fval* - function value +! resg - result of the 25-point gauss formula +! resk - result of the 51-point kronrod formula +! reskh - approximation to the mean value of f over (a,b), +! i.e. to i/(b-a) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,abserr,b,centr,dhlgth, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, & + resg,resk,reskh,result,uflow,wg,wgk,xgk + integer ( kind = 4 ) j,jtw,jtwm1 + external f + + dimension fv1(25),fv2(25),xgk(26),wgk(26),wg(13) + + data wg ( 1) / 0.011393798501026287947902964113235d0 / + data wg ( 2) / 0.026354986615032137261901815295299d0 / + data wg ( 3) / 0.040939156701306312655623487711646d0 / + data wg ( 4) / 0.054904695975835191925936891540473d0 / + data wg ( 5) / 0.068038333812356917207187185656708d0 / + data wg ( 6) / 0.080140700335001018013234959669111d0 / + data wg ( 7) / 0.091028261982963649811497220702892d0 / + data wg ( 8) / 0.100535949067050644202206890392686d0 / + data wg ( 9) / 0.108519624474263653116093957050117d0 / + data wg ( 10) / 0.114858259145711648339325545869556d0 / + data wg ( 11) / 0.119455763535784772228178126512901d0 / + data wg ( 12) / 0.122242442990310041688959518945852d0 / + data wg ( 13) / 0.123176053726715451203902873079050d0 / + + data xgk ( 1) / 0.999262104992609834193457486540341d0 / + data xgk ( 2) / 0.995556969790498097908784946893902d0 / + data xgk ( 3) / 0.988035794534077247637331014577406d0 / + data xgk ( 4) / 0.976663921459517511498315386479594d0 / + data xgk ( 5) / 0.961614986425842512418130033660167d0 / + data xgk ( 6) / 0.942974571228974339414011169658471d0 / + data xgk ( 7) / 0.920747115281701561746346084546331d0 / + data xgk ( 8) / 0.894991997878275368851042006782805d0 / + data xgk ( 9) / 0.865847065293275595448996969588340d0 / + data xgk ( 10) / 0.833442628760834001421021108693570d0 / + data xgk ( 11) / 0.797873797998500059410410904994307d0 / + data xgk ( 12) / 0.759259263037357630577282865204361d0 / + data xgk ( 13) / 0.717766406813084388186654079773298d0 / + data xgk ( 14) / 0.673566368473468364485120633247622d0 / + data xgk ( 15) / 0.626810099010317412788122681624518d0 / + data xgk ( 16) / 0.577662930241222967723689841612654d0 / + data xgk ( 17) / 0.526325284334719182599623778158010d0 / + data xgk ( 18) / 0.473002731445714960522182115009192d0 / + data xgk ( 19) / 0.417885382193037748851814394594572d0 / + data xgk ( 20) / 0.361172305809387837735821730127641d0 / + data xgk ( 21) / 0.303089538931107830167478909980339d0 / + data xgk ( 22) / 0.243866883720988432045190362797452d0 / + data xgk ( 23) / 0.183718939421048892015969888759528d0 / + data xgk ( 24) / 0.122864692610710396387359818808037d0 / + data xgk ( 25) / 0.061544483005685078886546392366797d0 / + data xgk ( 26) / 0.000000000000000000000000000000000d0 / + + data wgk ( 1) / 0.001987383892330315926507851882843d0 / + data wgk ( 2) / 0.005561932135356713758040236901066d0 / + data wgk ( 3) / 0.009473973386174151607207710523655d0 / + data wgk ( 4) / 0.013236229195571674813656405846976d0 / + data wgk ( 5) / 0.016847817709128298231516667536336d0 / + data wgk ( 6) / 0.020435371145882835456568292235939d0 / + data wgk ( 7) / 0.024009945606953216220092489164881d0 / + data wgk ( 8) / 0.027475317587851737802948455517811d0 / + data wgk ( 9) / 0.030792300167387488891109020215229d0 / + data wgk ( 10) / 0.034002130274329337836748795229551d0 / + data wgk ( 11) / 0.037116271483415543560330625367620d0 / + data wgk ( 12) / 0.040083825504032382074839284467076d0 / + data wgk ( 13) / 0.042872845020170049476895792439495d0 / + data wgk ( 14) / 0.045502913049921788909870584752660d0 / + data wgk ( 15) / 0.047982537138836713906392255756915d0 / + data wgk ( 16) / 0.050277679080715671963325259433440d0 / + data wgk ( 17) / 0.052362885806407475864366712137873d0 / + data wgk ( 18) / 0.054251129888545490144543370459876d0 / + data wgk ( 19) / 0.055950811220412317308240686382747d0 / + data wgk ( 20) / 0.057437116361567832853582693939506d0 / + data wgk ( 21) / 0.058689680022394207961974175856788d0 / + data wgk ( 22) / 0.059720340324174059979099291932562d0 / + data wgk ( 23) / 0.060539455376045862945360267517565d0 / + data wgk ( 24) / 0.061128509717053048305859030416293d0 / + data wgk ( 25) / 0.061471189871425316661544131965264d0 / + data wgk ( 26) / 0.061580818067832935078759824240066d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + centr = 0.5D+00*(a+b) + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) +! +! compute the 51-point kronrod approximation to +! the integral, and estimate the absolute error. +! + fc = f(centr) + resg = wg(13)*fc + resk = wgk(26)*fc + resabs = abs ( resk) + + do j=1,12 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2)) + end do + + do j = 1,13 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(26)* abs ( fc-reskh) + + do j=1,25 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) & + abserr = resasc* min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max & + ((epmach*0.5D+02)*resabs,abserr) + + return +end +subroutine dqk61(f,a,b,result,abserr,resabs,resasc) + +!*****************************************************************************80 +! +!! DQK61 carries out a 61 point Gauss-Kronrod quadrature rule. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose to compute i = integral of f over (a,b) with error +! estimate +! j = integral of abs ( f) over (a,b) +! +! Parameters: +! +! on entry +! f - real ( kind = 8 ) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is computed by applying the 61-point +! kronrod rule (resk) obtained by optimal addition of +! abscissae to the 30-point gauss rule (resg). +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs ( i-result) +! +! resabs - real ( kind = 8 ) +! approximation to the integral j +! +! resasc - real ( kind = 8 ) +! approximation to the integral of abs ( f-i/(b-a)) +! +! Local Parameters: +! +! the abscissae and weights are given for the +! interval (-1,1). because of symmetry only the positive +! abscissae and their corresponding weights are given. +! +! xgk - abscissae of the 61-point kronrod rule +! xgk(2), xgk(4) ... abscissae of the 30-point +! gauss rule +! xgk(1), xgk(3) ... optimally added abscissae +! to the 30-point gauss rule +! +! wgk - weights of the 61-point kronrod rule +! +! wg - weigths of the 30-point gauss rule +! +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! dabsc - abscissa +! fval* - function value +! resg - result of the 30-point gauss rule +! resk - result of the 61-point kronrod rule +! reskh - approximation to the mean value of f +! over (a,b), i.e. to i/(b-a) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,dabsc,abserr,b,centr,dhlgth, & + epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, & + resg,resk,reskh,result,uflow,wg,wgk,xgk + integer ( kind = 4 ) j,jtw,jtwm1 + external f + + dimension fv1(30),fv2(30),xgk(31),wgk(31),wg(15) + + data wg ( 1) / 0.007968192496166605615465883474674d0 / + data wg ( 2) / 0.018466468311090959142302131912047d0 / + data wg ( 3) / 0.028784707883323369349719179611292d0 / + data wg ( 4) / 0.038799192569627049596801936446348d0 / + data wg ( 5) / 0.048402672830594052902938140422808d0 / + data wg ( 6) / 0.057493156217619066481721689402056d0 / + data wg ( 7) / 0.065974229882180495128128515115962d0 / + data wg ( 8) / 0.073755974737705206268243850022191d0 / + data wg ( 9) / 0.080755895229420215354694938460530d0 / + data wg ( 10) / 0.086899787201082979802387530715126d0 / + data wg ( 11) / 0.092122522237786128717632707087619d0 / + data wg ( 12) / 0.096368737174644259639468626351810d0 / + data wg ( 13) / 0.099593420586795267062780282103569d0 / + data wg ( 14) / 0.101762389748405504596428952168554d0 / + data wg ( 15) / 0.102852652893558840341285636705415d0 / + + data xgk ( 1) / 0.999484410050490637571325895705811d0 / + data xgk ( 2) / 0.996893484074649540271630050918695d0 / + data xgk ( 3) / 0.991630996870404594858628366109486d0 / + data xgk ( 4) / 0.983668123279747209970032581605663d0 / + data xgk ( 5) / 0.973116322501126268374693868423707d0 / + data xgk ( 6) / 0.960021864968307512216871025581798d0 / + data xgk ( 7) / 0.944374444748559979415831324037439d0 / + data xgk ( 8) / 0.926200047429274325879324277080474d0 / + data xgk ( 9) / 0.905573307699907798546522558925958d0 / + data xgk ( 10) / 0.882560535792052681543116462530226d0 / + data xgk ( 11) / 0.857205233546061098958658510658944d0 / + data xgk ( 12) / 0.829565762382768397442898119732502d0 / + data xgk ( 13) / 0.799727835821839083013668942322683d0 / + data xgk ( 14) / 0.767777432104826194917977340974503d0 / + data xgk ( 15) / 0.733790062453226804726171131369528d0 / + data xgk ( 16) / 0.697850494793315796932292388026640d0 / + data xgk ( 17) / 0.660061064126626961370053668149271d0 / + data xgk ( 18) / 0.620526182989242861140477556431189d0 / + data xgk ( 19) / 0.579345235826361691756024932172540d0 / + data xgk ( 20) / 0.536624148142019899264169793311073d0 / + data xgk ( 21) / 0.492480467861778574993693061207709d0 / + data xgk ( 22) / 0.447033769538089176780609900322854d0 / + data xgk ( 23) / 0.400401254830394392535476211542661d0 / + data xgk ( 24) / 0.352704725530878113471037207089374d0 / + data xgk ( 25) / 0.304073202273625077372677107199257d0 / + data xgk ( 26) / 0.254636926167889846439805129817805d0 / + data xgk ( 27) / 0.204525116682309891438957671002025d0 / + data xgk ( 28) / 0.153869913608583546963794672743256d0 / + data xgk ( 29) / 0.102806937966737030147096751318001d0 / + data xgk ( 30) / 0.051471842555317695833025213166723d0 / + data xgk ( 31) / 0.000000000000000000000000000000000d0 / + + data wgk ( 1) / 0.001389013698677007624551591226760d0 / + data wgk ( 2) / 0.003890461127099884051267201844516d0 / + data wgk ( 3) / 0.006630703915931292173319826369750d0 / + data wgk ( 4) / 0.009273279659517763428441146892024d0 / + data wgk ( 5) / 0.011823015253496341742232898853251d0 / + data wgk ( 6) / 0.014369729507045804812451432443580d0 / + data wgk ( 7) / 0.016920889189053272627572289420322d0 / + data wgk ( 8) / 0.019414141193942381173408951050128d0 / + data wgk ( 9) / 0.021828035821609192297167485738339d0 / + data wgk ( 10) / 0.024191162078080601365686370725232d0 / + data wgk ( 11) / 0.026509954882333101610601709335075d0 / + data wgk ( 12) / 0.028754048765041292843978785354334d0 / + data wgk ( 13) / 0.030907257562387762472884252943092d0 / + data wgk ( 14) / 0.032981447057483726031814191016854d0 / + data wgk ( 15) / 0.034979338028060024137499670731468d0 / + data wgk ( 16) / 0.036882364651821229223911065617136d0 / + data wgk ( 17) / 0.038678945624727592950348651532281d0 / + data wgk ( 18) / 0.040374538951535959111995279752468d0 / + data wgk ( 19) / 0.041969810215164246147147541285970d0 / + data wgk ( 20) / 0.043452539701356069316831728117073d0 / + data wgk ( 21) / 0.044814800133162663192355551616723d0 / + data wgk ( 22) / 0.046059238271006988116271735559374d0 / + data wgk ( 23) / 0.047185546569299153945261478181099d0 / + data wgk ( 24) / 0.048185861757087129140779492298305d0 / + data wgk ( 25) / 0.049055434555029778887528165367238d0 / + data wgk ( 26) / 0.049795683427074206357811569379942d0 / + data wgk ( 27) / 0.050405921402782346840893085653585d0 / + data wgk ( 28) / 0.050881795898749606492297473049805d0 / + data wgk ( 29) / 0.051221547849258772170656282604944d0 / + data wgk ( 30) / 0.051426128537459025933862879215781d0 / + data wgk ( 31) / 0.051494729429451567558340433647099d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) + centr = 0.5D+00*(b+a) + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) +! +! compute the 61-point kronrod approximation to the +! integral, and estimate the absolute error. +! + resg = 0.0D+00 + fc = f(centr) + resk = wgk(31)*fc + resabs = abs ( resk) + + do j=1,15 + jtw = j*2 + dabsc = hlgth*xgk(jtw) + fval1 = f(centr-dabsc) + fval2 = f(centr+dabsc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2)) + end do + + do j=1,15 + jtwm1 = j*2-1 + dabsc = hlgth*xgk(jtwm1) + fval1 = f(centr-dabsc) + fval2 = f(centr+dabsc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2)) + end do + + reskh = resk*0.5D+00 + resasc = wgk(31)* abs ( fc-reskh) + + do j=1,30 + resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh)) + end do + + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs ( (resk-resg)*hlgth) + if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) & + abserr = resasc* min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max & + ((epmach*0.5D+02)*resabs,abserr) + + return +end +subroutine dqmomo(alfa,beta,ri,rj,rg,rh,integr) + +!*****************************************************************************80 +! +!! DQMOMO computes modified Chebyshev moments. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose this routine computes modified chebsyshev moments. the k-th +! modified chebyshev moment is defined as the integral over +! (-1,1) of w(x)*t(k,x), where t(k,x) is the chebyshev +! polynomial of degree k. +! +! Parameters: +! +! alfa - real ( kind = 8 ) +! parameter in the weight function w(x), alfa.gt.(-1) +! +! beta - real ( kind = 8 ) +! parameter in the weight function w(x), beta.gt.(-1) +! +! ri - real ( kind = 8 ) +! vector of dimension 25 +! ri(k) is the integral over (-1,1) of +! (1+x)**alfa*t(k-1,x), k = 1, ..., 25. +! +! rj - real ( kind = 8 ) +! vector of dimension 25 +! rj(k) is the integral over (-1,1) of +! (1-x)**beta*t(k-1,x), k = 1, ..., 25. +! +! rg - real ( kind = 8 ) +! vector of dimension 25 +! rg(k) is the integral over (-1,1) of +! (1+x)**alfa*log((1+x)/2)*t(k-1,x), k = 1, ..., 25. +! +! rh - real ( kind = 8 ) +! vector of dimension 25 +! rh(k) is the integral over (-1,1) of +! (1-x)**beta*log((1-x)/2)*t(k-1,x), k = 1, ..., 25. +! +! integr - integer ( kind = 4 ) +! input parameter indicating the modified +! moments to be computed +! integr = 1 compute ri, rj +! = 2 compute ri, rj, rg +! = 3 compute ri, rj, rh +! = 4 compute ri, rj, rg, rh +! + implicit none + + real ( kind = 8 ) alfa,alfp1,alfp2,an,anm1,beta,betp1,betp2,ralf, & + rbet,rg,rh,ri,rj + integer ( kind = 4 ) i,im1,integr + dimension rg(25),rh(25),ri(25),rj(25) + + alfp1 = alfa+0.1D+01 + betp1 = beta+0.1D+01 + alfp2 = alfa+0.2D+01 + betp2 = beta+0.2D+01 + ralf = 0.2D+01**alfp1 + rbet = 0.2D+01**betp1 +! +! compute ri, rj using a forward recurrence relation. +! + ri(1) = ralf/alfp1 + rj(1) = rbet/betp1 + ri(2) = ri(1)*alfa/alfp2 + rj(2) = rj(1)*beta/betp2 + an = 0.2D+01 + anm1 = 0.1D+01 + + do i=3,25 + ri(i) = -(ralf+an*(an-alfp2)*ri(i-1))/(anm1*(an+alfp1)) + rj(i) = -(rbet+an*(an-betp2)*rj(i-1))/(anm1*(an+betp1)) + anm1 = an + an = an+0.1D+01 + end do + + if(integr.eq.1) go to 70 + if(integr.eq.3) go to 40 +! +! compute rg using a forward recurrence relation. +! + rg(1) = -ri(1)/alfp1 + rg(2) = -(ralf+ralf)/(alfp2*alfp2)-rg(1) + an = 0.2D+01 + anm1 = 0.1D+01 + im1 = 2 + + do i=3,25 + rg(i) = -(an*(an-alfp2)*rg(im1)-an*ri(im1)+anm1*ri(i))/ & + (anm1*(an+alfp1)) + anm1 = an + an = an+0.1D+01 + im1 = i + end do + + if(integr.eq.2) go to 70 +! +! compute rh using a forward recurrence relation. +! + 40 rh(1) = -rj(1)/betp1 + rh(2) = -(rbet+rbet)/(betp2*betp2)-rh(1) + an = 0.2D+01 + anm1 = 0.1D+01 + im1 = 2 + + do i=3,25 + rh(i) = -(an*(an-betp2)*rh(im1)-an*rj(im1)+ & + anm1*rj(i))/(anm1*(an+betp1)) + anm1 = an + an = an+0.1D+01 + im1 = i + end do + + do i=2,25,2 + rh(i) = -rh(i) + end do + + 70 continue + + do i=2,25,2 + rj(i) = -rj(i) + end do + + 90 continue + + return +end +subroutine dqng ( f, a, b, epsabs, epsrel, result, abserr, neval, ier ) + +!*****************************************************************************80 +! +!! DQNG estimates an integral, using non-adaptive integration. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose the routine calculates an approximation result to a +! given definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result).le.max(epsabs,epsrel*abs(i)). +! +! Parameters: +! +! f - real ( kind = 8 ) +! function subprogram defining the integrand function +! f(x). the actual name for f needs to be declared +! e x t e r n a l in the driver program. +! +! a - real ( kind = 8 ) +! lower limit of integration +! +! b - real ( kind = 8 ) +! upper limit of integration +! +! epsabs - real ( kind = 8 ) +! absolute accuracy requested +! epsrel - real ( kind = 8 ) +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! on return +! result - real ( kind = 8 ) +! approximation to the integral i +! result is obtained by applying the 21-point +! gauss-kronrod rule (res21) obtained by optimal +! addition of abscissae to the 10-point gauss rule +! (res10), or by applying the 43-point rule (res43) +! obtained by optimal addition of abscissae to the +! 21-point gauss-kronrod rule, or by applying the +! 87-point rule (res87) obtained by optimal addition +! of abscissae to the 43-point rule. +! +! abserr - real ( kind = 8 ) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer ( kind = 4 ) +! number of integrand evaluations +! +! ier - ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine. it is +! assumed that the requested accuracy has +! not been achieved. +! error messages +! ier = 1 the maximum number of steps has been +! executed. the integral is probably too +! difficult to be calculated by dqng. +! = 6 the input is invalid, because +! epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28). +! result, abserr and neval are set to zero. +! +! Local Parameters: +! +! the data statements contain the +! abscissae and weights of the integration rules used. +! +! x1 abscissae common to the 10-, 21-, 43- and 87- +! point rule +! x2 abscissae common to the 21-, 43- and 87-point rule +! x3 abscissae common to the 43- and 87-point rule +! x4 abscissae of the 87-point rule +! w10 weights of the 10-point formula +! w21a weights of the 21-point formula for abscissae x1 +! w21b weights of the 21-point formula for abscissae x2 +! w43a weights of the 43-point formula for abscissae x1, x3 +! w43b weights of the 43-point formula for abscissae x3 +! w87a weights of the 87-point formula for abscissae x1, +! x2, x3 +! w87b weights of the 87-point formula for abscissae x4 +! +! +! gauss-kronrod-patterson quadrature coefficients for use in +! quadpack routine qng. these coefficients were calculated with +! 101 decimal digit arithmetic by l. w. fullerton, bell labs, nov 1981. +! +! centr - mid point of the integration interval +! hlgth - half-length of the integration interval +! fcentr - function value at mid point +! absc - abscissa +! fval - function value +! savfun - array of function values which have already been +! computed +! res10 - 10-point gauss result +! res21 - 21-point kronrod result +! res43 - 43-point result +! res87 - 87-point result +! resabs - approximation to the integral of abs(f) +! resasc - approximation to the integral of abs(f-i/(b-a)) +! +! machine dependent constants +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! + implicit none + + real ( kind = 8 ) a,absc,abserr,b,centr,dhlgth, & + epmach,epsabs,epsrel,f,fcentr,fval,fval1,fval2,fv1,fv2, & + fv3,fv4,hlgth,result,res10,res21,res43,res87,resabs,resasc, & + reskh,savfun,uflow,w10,w21a,w21b,w43a,w43b,w87a,w87b,x1,x2,x3,x4 + integer ( kind = 4 ) ier,ipx,k,l,neval + external f + dimension fv1(5),fv2(5),fv3(5),fv4(5),x1(5),x2(5),x3(11),x4(22), & + w10(5),w21a(5),w21b(6),w43a(10),w43b(12),w87a(21),w87b(23), & + savfun(21) + + data x1 ( 1) / 0.973906528517171720077964012084452d0 / + data x1 ( 2) / 0.865063366688984510732096688423493d0 / + data x1 ( 3) / 0.679409568299024406234327365114874d0 / + data x1 ( 4) / 0.433395394129247190799265943165784d0 / + data x1 ( 5) / 0.148874338981631210884826001129720d0 / + data w10 ( 1) / 0.066671344308688137593568809893332d0 / + data w10 ( 2) / 0.149451349150580593145776339657697d0 / + data w10 ( 3) / 0.219086362515982043995534934228163d0 / + data w10 ( 4) / 0.269266719309996355091226921569469d0 / + data w10 ( 5) / 0.295524224714752870173892994651338d0 / + + data x2 ( 1) / 0.995657163025808080735527280689003d0 / + data x2 ( 2) / 0.930157491355708226001207180059508d0 / + data x2 ( 3) / 0.780817726586416897063717578345042d0 / + data x2 ( 4) / 0.562757134668604683339000099272694d0 / + data x2 ( 5) / 0.294392862701460198131126603103866d0 / + data w21a ( 1) / 0.032558162307964727478818972459390d0 / + data w21a ( 2) / 0.075039674810919952767043140916190d0 / + data w21a ( 3) / 0.109387158802297641899210590325805d0 / + data w21a ( 4) / 0.134709217311473325928054001771707d0 / + data w21a ( 5) / 0.147739104901338491374841515972068d0 / + data w21b ( 1) / 0.011694638867371874278064396062192d0 / + data w21b ( 2) / 0.054755896574351996031381300244580d0 / + data w21b ( 3) / 0.093125454583697605535065465083366d0 / + data w21b ( 4) / 0.123491976262065851077958109831074d0 / + data w21b ( 5) / 0.142775938577060080797094273138717d0 / + data w21b ( 6) / 0.149445554002916905664936468389821d0 / +! + data x3 ( 1) / 0.999333360901932081394099323919911d0 / + data x3 ( 2) / 0.987433402908088869795961478381209d0 / + data x3 ( 3) / 0.954807934814266299257919200290473d0 / + data x3 ( 4) / 0.900148695748328293625099494069092d0 / + data x3 ( 5) / 0.825198314983114150847066732588520d0 / + data x3 ( 6) / 0.732148388989304982612354848755461d0 / + data x3 ( 7) / 0.622847970537725238641159120344323d0 / + data x3 ( 8) / 0.499479574071056499952214885499755d0 / + data x3 ( 9) / 0.364901661346580768043989548502644d0 / + data x3 ( 10) / 0.222254919776601296498260928066212d0 / + data x3 ( 11) / 0.074650617461383322043914435796506d0 / + data w43a ( 1) / 0.016296734289666564924281974617663d0 / + data w43a ( 2) / 0.037522876120869501461613795898115d0 / + data w43a ( 3) / 0.054694902058255442147212685465005d0 / + data w43a ( 4) / 0.067355414609478086075553166302174d0 / + data w43a ( 5) / 0.073870199632393953432140695251367d0 / + data w43a ( 6) / 0.005768556059769796184184327908655d0 / + data w43a ( 7) / 0.027371890593248842081276069289151d0 / + data w43a ( 8) / 0.046560826910428830743339154433824d0 / + data w43a ( 9) / 0.061744995201442564496240336030883d0 / + data w43a ( 10) / 0.071387267268693397768559114425516d0 / + data w43b ( 1) / 0.001844477640212414100389106552965d0 / + data w43b ( 2) / 0.010798689585891651740465406741293d0 / + data w43b ( 3) / 0.021895363867795428102523123075149d0 / + data w43b ( 4) / 0.032597463975345689443882222526137d0 / + data w43b ( 5) / 0.042163137935191811847627924327955d0 / + data w43b ( 6) / 0.050741939600184577780189020092084d0 / + data w43b ( 7) / 0.058379395542619248375475369330206d0 / + data w43b ( 8) / 0.064746404951445885544689259517511d0 / + data w43b ( 9) / 0.069566197912356484528633315038405d0 / + data w43b ( 10) / 0.072824441471833208150939535192842d0 / + data w43b ( 11) / 0.074507751014175118273571813842889d0 / + data w43b ( 12) / 0.074722147517403005594425168280423d0 / + + data x4 ( 1) / 0.999902977262729234490529830591582d0 / + data x4 ( 2) / 0.997989895986678745427496322365960d0 / + data x4 ( 3) / 0.992175497860687222808523352251425d0 / + data x4 ( 4) / 0.981358163572712773571916941623894d0 / + data x4 ( 5) / 0.965057623858384619128284110607926d0 / + data x4 ( 6) / 0.943167613133670596816416634507426d0 / + data x4 ( 7) / 0.915806414685507209591826430720050d0 / + data x4 ( 8) / 0.883221657771316501372117548744163d0 / + data x4 ( 9) / 0.845710748462415666605902011504855d0 / + data x4 ( 10) / 0.803557658035230982788739474980964d0 / + data x4 ( 11) / 0.757005730685495558328942793432020d0 / + data x4 ( 12) / 0.706273209787321819824094274740840d0 / + data x4 ( 13) / 0.651589466501177922534422205016736d0 / + data x4 ( 14) / 0.593223374057961088875273770349144d0 / + data x4 ( 15) / 0.531493605970831932285268948562671d0 / + data x4 ( 16) / 0.466763623042022844871966781659270d0 / + data x4 ( 17) / 0.399424847859218804732101665817923d0 / + data x4 ( 18) / 0.329874877106188288265053371824597d0 / + data x4 ( 19) / 0.258503559202161551802280975429025d0 / + data x4 ( 20) / 0.185695396568346652015917141167606d0 / + data x4 ( 21) / 0.111842213179907468172398359241362d0 / + data x4 ( 22) / 0.037352123394619870814998165437704d0 / + data w87a ( 1) / 0.008148377384149172900002878448190d0 / + data w87a ( 2) / 0.018761438201562822243935059003794d0 / + data w87a ( 3) / 0.027347451050052286161582829741283d0 / + data w87a ( 4) / 0.033677707311637930046581056957588d0 / + data w87a ( 5) / 0.036935099820427907614589586742499d0 / + data w87a ( 6) / 0.002884872430211530501334156248695d0 / + data w87a ( 7) / 0.013685946022712701888950035273128d0 / + data w87a ( 8) / 0.023280413502888311123409291030404d0 / + data w87a ( 9) / 0.030872497611713358675466394126442d0 / + data w87a ( 10) / 0.035693633639418770719351355457044d0 / + data w87a ( 11) / 0.000915283345202241360843392549948d0 / + data w87a ( 12) / 0.005399280219300471367738743391053d0 / + data w87a ( 13) / 0.010947679601118931134327826856808d0 / + data w87a ( 14) / 0.016298731696787335262665703223280d0 / + data w87a ( 15) / 0.021081568889203835112433060188190d0 / + data w87a ( 16) / 0.025370969769253827243467999831710d0 / + data w87a ( 17) / 0.029189697756475752501446154084920d0 / + data w87a ( 18) / 0.032373202467202789685788194889595d0 / + data w87a ( 19) / 0.034783098950365142750781997949596d0 / + data w87a ( 20) / 0.036412220731351787562801163687577d0 / + data w87a ( 21) / 0.037253875503047708539592001191226d0 / + data w87b ( 1) / 0.000274145563762072350016527092881d0 / + data w87b ( 2) / 0.001807124155057942948341311753254d0 / + data w87b ( 3) / 0.004096869282759164864458070683480d0 / + data w87b ( 4) / 0.006758290051847378699816577897424d0 / + data w87b ( 5) / 0.009549957672201646536053581325377d0 / + data w87b ( 6) / 0.012329447652244853694626639963780d0 / + data w87b ( 7) / 0.015010447346388952376697286041943d0 / + data w87b ( 8) / 0.017548967986243191099665352925900d0 / + data w87b ( 9) / 0.019938037786440888202278192730714d0 / + data w87b ( 10) / 0.022194935961012286796332102959499d0 / + data w87b ( 11) / 0.024339147126000805470360647041454d0 / + data w87b ( 12) / 0.026374505414839207241503786552615d0 / + data w87b ( 13) / 0.028286910788771200659968002987960d0 / + data w87b ( 14) / 0.030052581128092695322521110347341d0 / + data w87b ( 15) / 0.031646751371439929404586051078883d0 / + data w87b ( 16) / 0.033050413419978503290785944862689d0 / + data w87b ( 17) / 0.034255099704226061787082821046821d0 / + data w87b ( 18) / 0.035262412660156681033782717998428d0 / + data w87b ( 19) / 0.036076989622888701185500318003895d0 / + data w87b ( 20) / 0.036698604498456094498018047441094d0 / + data w87b ( 21) / 0.037120549269832576114119958413599d0 / + data w87b ( 22) / 0.037334228751935040321235449094698d0 / + data w87b ( 23) / 0.037361073762679023410321241766599d0 / + + epmach = epsilon ( epmach ) + uflow = tiny ( uflow ) +! +! test on validity of parameters +! + result = 0.0D+00 + abserr = 0.0D+00 + neval = 0 + ier = 6 + if(epsabs.le.0.0D+00.and.epsrel.lt. max ( 0.5D+02*epmach,0.5d-28)) & + go to 80 + hlgth = 0.5D+00*(b-a) + dhlgth = abs ( hlgth) + centr = 0.5D+00*(b+a) + fcentr = f(centr) + neval = 21 + ier = 1 +! +! compute the integral using the 10- and 21-point formula. +! + do 70 l = 1,3 + + go to (5,25,45),l + + 5 res10 = 0.0D+00 + res21 = w21b(6)*fcentr + resabs = w21b(6)* abs ( fcentr) + + do k=1,5 + absc = hlgth*x1(k) + fval1 = f(centr+absc) + fval2 = f(centr-absc) + fval = fval1+fval2 + res10 = res10+w10(k)*fval + res21 = res21+w21a(k)*fval + resabs = resabs+w21a(k)*( abs ( fval1)+ abs ( fval2)) + savfun(k) = fval + fv1(k) = fval1 + fv2(k) = fval2 + end do + + ipx = 5 + + do k=1,5 + ipx = ipx+1 + absc = hlgth*x2(k) + fval1 = f(centr+absc) + fval2 = f(centr-absc) + fval = fval1+fval2 + res21 = res21+w21b(k)*fval + resabs = resabs+w21b(k)*( abs ( fval1)+ abs ( fval2)) + savfun(ipx) = fval + fv3(k) = fval1 + fv4(k) = fval2 + end do +! +! test for convergence. +! + result = res21*hlgth + resabs = resabs*dhlgth + reskh = 0.5D+00*res21 + resasc = w21b(6)* abs ( fcentr-reskh) + + do k = 1,5 + resasc = resasc+w21a(k)*( abs ( fv1(k)-reskh)+ abs ( fv2(k)-reskh)) & + +w21b(k)*( abs ( fv3(k)-reskh)+ abs ( fv4(k)-reskh)) + end do + + abserr = abs ( (res21-res10)*hlgth) + resasc = resasc*dhlgth + go to 65 +! +! compute the integral using the 43-point formula. +! +25 res43 = w43b(12)*fcentr + neval = 43 + + do k=1,10 + res43 = res43+savfun(k)*w43a(k) + end do + + do k=1,11 + ipx = ipx+1 + absc = hlgth*x3(k) + fval = f(absc+centr)+f(centr-absc) + res43 = res43+fval*w43b(k) + savfun(ipx) = fval + end do +! +! test for convergence. +! + result = res43*hlgth + abserr = abs ( (res43-res21)*hlgth) + go to 65 +! +! compute the integral using the 87-point formula. +! +45 res87 = w87b(23)*fcentr + neval = 87 + + do k=1,21 + res87 = res87+savfun(k)*w87a(k) + end do + + do k=1,22 + absc = hlgth*x4(k) + res87 = res87+w87b(k)*(f(absc+centr)+f(centr-absc)) + end do + + result = res87*hlgth + abserr = abs ( (res87-res43)*hlgth) + +65 continue + + if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) then + abserr = resasc* min (0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00) + end if + + if (resabs.gt.uflow/(0.5D+02*epmach)) then + abserr = max ((epmach*0.5D+02)*resabs,abserr) + end if + + if (abserr.le. max ( epsabs,epsrel* abs ( result))) then + ier = 0 + return + end if + +70 continue + + 80 call xerror('abnormal return from dqng ',26,ier,0) + 999 continue + + return +end +subroutine dqpsrt ( limit, last, maxerr, ermax, elist, iord, nrmax ) + +!*****************************************************************************80 +! +!! DQPSRT maintains the order of a list of local error estimates. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! +!***purpose this routine maintains the descending ordering in the +! list of the local error estimated resulting from the +! interval subdivision process. at each call two error +! estimates are inserted using the sequential search +! method, top-down for the largest error estimate and +! bottom-up for the smallest error estimate. +! +! Parameters: +! +! limit - integer ( kind = 4 ) +! maximum number of error estimates the list +! can contain +! +! last - integer ( kind = 4 ) +! number of error estimates currently in the list +! +! maxerr - integer ( kind = 4 ) +! maxerr points to the nrmax-th largest error +! estimate currently in the list +! +! ermax - real ( kind = 8 ) +! nrmax-th largest error estimate +! ermax = elist(maxerr) +! +! elist - real ( kind = 8 ) +! vector of dimension last containing +! the error estimates +! +! iord - integer ( kind = 4 ) +! vector of dimension last, the first k elements +! of which contain pointers to the error +! estimates, such that +! elist(iord(1)),..., elist(iord(k)) +! form a decreasing sequence, with +! k = last if last.le.(limit/2+2), and +! k = limit+1-last otherwise +! +! nrmax - integer ( kind = 4 ) +! maxerr = iord(nrmax) +! + implicit none + + real ( kind = 8 ) elist,ermax,errmax,errmin + integer ( kind = 4 ) i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last, & + lim + integer ( kind = 4 ) limit + integer ( kind = 4 ) maxerr + integer ( kind = 4 ) nrmax + dimension elist(last),iord(last) +! +! check whether the list contains more than +! two error estimates. +! + if(last.gt.2) go to 10 + iord(1) = 1 + iord(2) = 2 + go to 90 +! +! this part of the routine is only executed if, due to a +! difficult integrand, subdivision increased the error +! estimate. in the normal case the insert procedure should +! start after the nrmax-th largest error estimate. +! + 10 errmax = elist(maxerr) + + ido = nrmax-1 + do i = 1,ido + isucc = iord(nrmax-1) + if(errmax.le.elist(isucc)) go to 30 + iord(nrmax) = isucc + nrmax = nrmax-1 + end do +! +! compute the number of elements in the list to be maintained +! in descending order. this number depends on the number of +! subdivisions still allowed. +! + 30 jupbn = last + if(last.gt.(limit/2+2)) jupbn = limit+3-last + errmin = elist(last) +! +! insert errmax by traversing the list top-down, +! starting comparison from the element elist(iord(nrmax+1)). +! + jbnd = jupbn-1 + ibeg = nrmax+1 + + do i=ibeg,jbnd + isucc = iord(i) + if(errmax.ge.elist(isucc)) go to 60 + iord(i-1) = isucc + end do + + iord(jbnd) = maxerr + iord(jupbn) = last + go to 90 +! +! insert errmin by traversing the list bottom-up. +! + 60 iord(i-1) = maxerr + k = jbnd + + do j=i,jbnd + isucc = iord(k) + if(errmin.lt.elist(isucc)) go to 80 + iord(k+1) = isucc + k = k-1 + end do + + iord(i) = last + go to 90 + 80 iord(k+1) = last +! +! set maxerr and ermax. +! + 90 maxerr = iord(nrmax) + ermax = elist(maxerr) + + return +end +function dqwgtc ( x, c, p2, p3, p4, kp ) + +!*****************************************************************************80 +! +!! DQWGTC defines the weight function used by DQC25C. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! + implicit none + + real ( kind = 8 ) dqwgtc + real ( kind = 8 ) c,p2,p3,p4,x + integer ( kind = 4 ) kp + + dqwgtc = 0.1D+01 / ( x - c ) + + return +end +function dqwgtf(x,omega,p2,p3,p4,integr) + +!*****************************************************************************80 +! +!! DQWGTF defines the weight functions used by DQC25F. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! + implicit none + + real ( kind = 8 ) dqwgtf + real ( kind = 8 ) dcos,dsin,omega,omx,p2,p3,p4,x + integer ( kind = 4 ) integr + + omx = omega * x + + if ( integr == 1 ) then + dqwgtf = cos ( omx ) + else + dqwgtf = sin ( omx ) + end if + + return +end +function dqwgts ( x, a, b, alfa, beta, integr ) + +!*****************************************************************************80 +! +!! DQWGTS defines the weight functions used by DQC25S. +! +! Modified: +! +! 11 September 2015 +! +! Author: +! +! Robert Piessens, Elise de Doncker +! + implicit none + + real dqwgts + real ( kind = 8 ) a,alfa,b,beta,bmx,x,xma + integer ( kind = 4 ) integr + + xma = x - a + bmx = b - x + dqwgts = xma ** alfa * bmx ** beta + go to (40,10,20,30),integr + 10 dqwgts = dqwgts* log ( xma ) + go to 40 + 20 dqwgts = dqwgts* log ( bmx ) + go to 40 + 30 dqwgts = dqwgts* log ( xma ) * log ( bmx ) + 40 continue + + return +end +subroutine timestamp ( ) + +!*****************************************************************************80 +! +!! TIMESTAMP prints the current YMDHMS date as a time stamp. +! +! Example: +! +! 31 May 2001 9:45:54.872 AM +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 May 2013 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! None +! + implicit none + + character ( len = 8 ) ampm + integer ( kind = 4 ) d + integer ( kind = 4 ) h + integer ( kind = 4 ) m + integer ( kind = 4 ) mm + character ( len = 9 ), parameter, dimension(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December ' /) + integer ( kind = 4 ) n + integer ( kind = 4 ) s + integer ( kind = 4 ) values(8) + integer ( kind = 4 ) y + + call date_and_time ( values = values ) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + + if ( h < 12 ) then + ampm = 'AM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Noon' + else + ampm = 'PM' + end if + else + h = h - 12 + if ( h < 12 ) then + ampm = 'PM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Midnight' + else + ampm = 'AM' + end if + end if + end if + + write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & + d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) + + return +end +subroutine xerror ( xmess, nmess, nerr, level ) + +!*****************************************************************************80 +! +!! XERROR replaces the SLATEC XERROR routine. +! +! Modified: +! +! 12 September 2015 +! + implicit none + + integer ( kind = 4 ) level + integer ( kind = 4 ) nerr + integer ( kind = 4 ) nmess + character ( len = * ) xmess + + if ( 1 <= LEVEL ) then + WRITE ( *,'(1X,A)') XMESS(1:NMESS) + WRITE ( *,'('' ERROR NUMBER = '',I5,'', MESSAGE LEVEL = '',I5)') & + NERR,LEVEL + end if + + return +end + diff --git a/bin/schmidt_decomposition.f90 b/bin/schmidt_decomposition.f90 new file mode 100644 index 0000000..8094ef8 --- /dev/null +++ b/bin/schmidt_decomposition.f90 @@ -0,0 +1,276 @@ +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +program SOET_DMET +!---------------! + ! + ! ==== Local Data ==== + ! + implicit none + integer,parameter :: dp=kind(1.d0), OUT=99 + integer :: i,j,L,Nelec,nocc,imp + real(dp) :: t,U + DOUBLE PRECISION, allocatable :: D_SOFT(:,:),D_SOFT_diag(:,:), & + D(:,:), D_F(:,:),D_E(:,:),D_unocc_F(:,:), D_occ_E(:,:),D_unocc_E(:,:), & + U_SVD(:,:),V_SVD(:,:),S(:),D_occ_F(:,:), & + sqrt_n0(:,:),n0(:,:), sqrt_un_n0(:,:), inv_sqrt_un_n0(:,:), & + V_F(:,:),V_E(:,:),Socc(:,:),tildeC_F(:,:),C_B(:,:), & + D_provisoir(:,:),eig(:),P(:,:),Pbar(:,:) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Allocation and Initialization ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + open(10,file='mat.dat',status='old') + read(10,*)L, Nelec, U, t, imp ! #sites, #electrons, t, U, #impurities + allocate(D_F(imp,L)) + allocate(D_E(L-imp,L)) + allocate(D_SOFT(L,L)) + allocate(D_SOFT_diag(L,L)) + allocate(D(L,L)) + allocate(eig(L)) + + open ( UNIT = OUT, FILE = 'Schmidt_decomposition.out', ACCESS = 'SEQUENTIAL' ) + + write(OUT,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' + write(OUT,*)'% This program performs the Schmidt Decomposition %' + write(OUT,*)'% on the Slater determinant obtained by KS-SOFT. %' + write(OUT,*)'% It returns the embedded problem to be solved %' + write(OUT,*)'% either by DMRG for 2 or more than 2 impurities, %' + write(OUT,*)'% or analytically for a single impurity site. %' + write(OUT,*)'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' + write(OUT,*) + write(OUT,*)'Number sites :', L + write(OUT,*)'Number of impurity sites :', imp + write(OUT,*)'Number of electrons :', Nelec + write(OUT,*)'On-site Coulomb repulsion U :', U + write(OUT,*)'Hopping parameter t :', t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! READ MATRIX ELEMENTS ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + write(OUT,*) + write(OUT,*)'Step 1. Read the matrix representation of :' + write(OUT,*)' - the 1RDM of the KS-SOFT system, D_soft (size L x L)' +!!! SOFT density matrix + do i=1,L + read(10,*)(D_SOFT(i,j),j=1,L) + enddo + close(10) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Diagonalize the non-interacting Hamiltonian ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(OUT,*) + write(OUT,*)'Step 2. Diagonalize D_soft. Determine the transformation matrix D.' + write(OUT,*)' D_diag = D^T D_soft D' + +! Initialize the transformation D to be set in diasym. +! The minus sign to sort from the biggest to the lowest one. + D=-D_SOFT + call diasym(D,eig,L) + D_SOFT_diag=matmul(matmul(transpose(D),D_SOFT),D) + +! Determine nocc + nocc = 0 + do i=1,L + if (D_SOFT_diag(i,i) > 0.99999) then + nocc = nocc + 1 + endif + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Split transformation matrix into ! +! fragment (F) + environment (E) ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(OUT,*) + write(OUT,*)'Step 3. Split the transformation matrix D (L x L) into:' + write(OUT,*)' - a fragment part D_F (n_imp x L),' + write(OUT,*)' - an environment part D_E (L-n_imp x L).' + do i=1,imp + do j=1,L + D_F(i,j)=D(i,j) + enddo + enddo + + do i=1,L-imp + do j=1,L + D_E(i,j)=D(i+imp,j) + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Split transformation matrix into ! +! occupied and unoccupied ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(OUT,*) + write(OUT,*)'Step 4. Split D_F and D_E into occupied and unoccupied parts:' + write(OUT,*)' - D_occ_F (n_imp x n_occ),' + write(OUT,*)' - D_unocc_F (n_imp x L-n_occ),' + write(OUT,*)' - D_occ_E(L-n_imp x n_occ),' + write(OUT,*)' - D_unocc_E(L-n_imp x L-n_occ).' + allocate(D_occ_F(imp,nocc)) + allocate(D_unocc_F(imp,L-nocc)) + allocate(D_occ_E(L-imp,nocc)) + allocate(D_unocc_E(L-imp,L-nocc)) + + do i=1,imp + do j=1,nocc + D_occ_F(i,j)=D_F(i,j) + enddo + enddo + + do i=1,imp + do j=1,L-nocc + D_unocc_F(i,j)=D_F(i,j+nocc) + enddo + enddo + + do i=1,L-imp + do j=1,nocc + D_occ_E(i,j)=D_E(i,j) + enddo + enddo + + do i=1,L-imp + do j=1,L-nocc + D_unocc_E(i,j)=D_E(i,j+nocc) + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Singular Value Decomposition ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(OUT,*) + write(OUT,*)'Step 5. Perform a Singular Value Decomposition of D_occ_F.' + write(OUT,*)' D_occ_F = U_SVD sqrt_n0 V_SVD with size:' + write(OUT,*)' - U_SVD (n_imp x n_imp),' + write(OUT,*)' - sqrt_n0 (n_imp x n_imp),' + write(OUT,*)' - V_SVD (n_occ x n_occ).' + allocate(D_provisoir(imp,nocc)) + allocate(S(nocc)) ! temporary matrix for having sqrt_n0 in SVD calculation. + allocate(sqrt_n0(imp,imp)) + D_provisoir=D_occ_F ! because the input is destroyed in DGSEDD, and I don't want to destroy D_occ_F + allocate(U_SVD(imp,imp)) + allocate(V_SVD(nocc,nocc)) + + call SVD(D_provisoir,U_SVD,S,sqrt_n0,V_SVD,imp,nocc) + + deallocate(D_provisoir) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Decomposition of V_SVD into ! +! fragment (F) + environment (E) ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(OUT,*) + write(OUT,*)'Step 6. Decompose V_SVD into:' + write(OUT,*)' - a fragment part V_F (n_occ x n_imp),' + write(OUT,*)' - an environment part V_E (n_occ x n_occ-n_imp).' + allocate(V_F(nocc,imp)) + allocate(V_E(nocc,nocc-imp)) + + do i=1,nocc + do j=1,imp + V_F(i,j)=V_SVD(i,j) + enddo + do j=1,nocc-imp + V_E(i,j)=V_SVD(i,j+imp) + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Compute the overlap matrix Socc ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(OUT,*) + write(OUT,*)'Step 7. Compute the overlap matrix, S_occ (n_occ x n_occ)' + write(OUT,*)' S_occ = V_F n0 V_F^T, ' + write(OUT,*)' where n0 = sqrt_n0^T sqrt_n0.' + + allocate(Socc(nocc,nocc)) + allocate(n0(imp,imp)) + n0=matmul(transpose(sqrt_n0),sqrt_n0) + Socc=matmul(matmul(V_F,n0),transpose(V_F)) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Compute the Projector ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(OUT,*) + write(OUT,*)'Step 8. Compute the Projector P (L x 2n_imp):' + write(OUT,*)' P = Pbar x Block_matrix[[U_SVD^T,0],[0,U_SVD^T]],' + write(OUT,*)' where Pbar is the Projector in the basis of natural orbital:' + write(OUT,*)' Pbar = Block_matrix[[U_SVD,0],[0,C_B]],' + write(OUT,*)' C_B = D_occ_E V_F (sqrt(1 - n0))^-1.' + allocate(tildeC_F(imp,imp)) + allocate(sqrt_un_n0(imp,imp)) + allocate(inv_sqrt_un_n0(imp,imp)) + allocate(C_B(L-imp,imp)) + allocate(Pbar(L,2*imp)) + allocate(P(L,2*imp)) + allocate(D_provisoir(2*imp,2*imp)) + + tildeC_F=matmul(D_occ_F,V_F) + + sqrt_un_n0=0 + do i=1,imp + sqrt_un_n0(i,i)=sqrt(1-n0(i,i)) + enddo + + call inverse(sqrt_un_n0,inv_sqrt_un_n0,imp) + + C_B = matmul(matmul(D_occ_E,V_F),inv_sqrt_un_n0) + + Pbar=0 + do i=1,imp + do j=1,imp + Pbar(i,j)=U_SVD(i,j) + enddo + enddo + + do i=imp+1,L + do j=imp+1,2*imp + Pbar(i,j)=C_B(i-imp,j-imp) + enddo + enddo + + D_provisoir=0 + do i=1,imp + do j=1,imp + D_provisoir(i,j)=U_SVD(j,i) + D_provisoir(i+imp,j+imp)=U_SVD(j,i) + enddo + enddo + + P=matmul(Pbar,D_provisoir) + + write(OUT,*) + write(OUT,*)' Projector P :' + do i=1,L + write(OUT,10)(P(i,j),j=1,2*imp) + enddo + write(OUT,*) + write(OUT,*)'End of file.' + open (98,FILE='projector.dat',ACCESS ='SEQUENTIAL') + do i=1,L + write(98,10)(P(i,j),j=1,2*imp) + enddo + close(98) + + +close(OUT) + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Format ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 10 format(500f25.15) + + end program SOET_DMET diff --git a/bin/secant.f90 b/bin/secant.f90 new file mode 100644 index 0000000..b3e8127 --- /dev/null +++ b/bin/secant.f90 @@ -0,0 +1,44 @@ +subroutine secant(f,a,b,x,tol,maxiter,iter,ier) + +integer, parameter :: dp=kind(1.d0) +real(dp),external :: f +real(dp),intent(inout) :: a +real(dp),intent(inout) :: b +real(dp),intent(inout) :: x +real(dp),intent(in) :: tol +integer,intent(in) :: maxiter +integer,intent(out) :: iter +integer,intent(out) :: ier + +real(dp) :: fa,fb,xzero,fxzero,deltax + +fa = f(a) +fb = f(b) + +if (fa*fb .gt. 0.0_dp) then + print*,"ERROR IN SECANT METHOD !!! BAD INTERVAL !!!" +end if + +xzero = b - fb*(b - a)/(fb - fa) +fxzero = f(xzero) +iter = 1 +deltax = 1.0_dp + +do while (deltax.gt.tol.and.iter.lt.maxiter) + x = xzero - fxzero*(xzero - b)/(fxzero - fb) + deltax = abs(xzero - x) + b = xzero + xzero = x + fb = fxzero + fxzero = f(x) + iter = iter + 1 +end do + + if (iter.gt.maxiter) then + ier = 1 + print*,"ERROR IN SECANT METHOD !!! TOO MANY ITERATIONS !!!" + else + ier = 0 + end if + +end subroutine diff --git a/examples/SOFT_BALDA.py b/examples/SOFT_BALDA.py new file mode 100755 index 0000000..ea4e553 --- /dev/null +++ b/examples/SOFT_BALDA.py @@ -0,0 +1,39 @@ +#!/usr/bin/python +import numpy as np +import sys +import os +import SOFT +import random + +working_directory = os.getenv('SOFT_DIR') + "/examples/" + +n_sites = 100 +n_elec = 30 +U = 4.0 +t = 1.0 +v_choice = ["uniform","random","ABAB","power","decreasing"][3] +SCF_maxiter = 100 + +v = np.full((n_sites),1.*n_elec/(1.*n_sites)) # uniform v_choice +if v_choice == "uniform": + pass +elif v_choice == "random": + for i in range(n_sites): v[i] = random.uniform(-1,1) +elif v_choice == "ABAB": + for i in range(n_sites//2): + v[2*i] = -1. + v[2*i+1] = +1. +elif v_choice == "power": # See GAO XIANLONG et al. PHYSICAL REVIEW B 73, 165120 (2006) + l = 2 + const_V = 0.006 + for i in range(n_sites): + v[i] = const_V*(i - n_sites/2)**l +elif v_choice == "decreasing": + for i in reversed(range(n_sites)): + v[i] = 0.1*i +else: + sys.exit("The v_choice is not defined. Program terminated.") + +output_file = working_directory + "/results/L{}_N{}_U{}_t{}_{}.dat".format(n_sites,n_elec,U,t,v_choice) + +KS_orbs, E_DFT, density_exact = SOFT.run_SOFT_Hubbard(n_sites,n_elec,U,t,v,SCF_maxiter,working_directory,output_file) diff --git a/setup.py b/setup.py new file mode 100644 index 0000000..ed10ac7 --- /dev/null +++ b/setup.py @@ -0,0 +1,13 @@ +import io +from setuptools import setup, find_packages + +setup( + name='SOFT', + author='Bruno Senjean', + author_email='bruno.senjean@umontpellier.fr', + url='', + description=('Site Occupation Functional Theory'), + packages=find_packages(where='src'), + package_dir={'': 'src'}, + include_package_data=True, +) diff --git a/src/SOFT/BALDA.py b/src/SOFT/BALDA.py new file mode 100644 index 0000000..dbc8a0c --- /dev/null +++ b/src/SOFT/BALDA.py @@ -0,0 +1,43 @@ +#!/usr/bin/python +# -*- coding: utf-8 -*- + +import numpy as np + +def correlation_BALDA(U,t,n,beta,dbeta_dU): + """ + Function that generates the correlation BALDA potential and energy for one site with occupation n. + It also generates the derivative of the correlation energy with respect to U and t, which can be useful + to compute some particular quantities (like the double occupation). + """ + + ec = - 2.*t*beta*np.sin(np.pi*n/beta)/np.pi + 4.0*t*np.sin(np.pi*n/2.0)/np.pi - U*0.25*n*n + dec_dU = dbeta_dU*(-2.*t*np.sin(np.pi*n/beta)/np.pi + 2.*t*n*np.cos(np.pi*n/beta)/beta) - n*n*0.25 + dec_dn = - 2.*t*np.cos(np.pi*n/beta) + 2.*t*np.cos(np.pi*n/2.0) - U*0.5*n + + # Hole-particle symmetry: + if n > 1.0: + ec = - 2.*t*beta*np.sin(np.pi*(2.-n)/beta)/np.pi + U*(n-1.) + 4.0*t*np.sin(np.pi*(2.-n)/2.0)/np.pi - U*n*n*0.25 + dec_dU = dbeta_dU*(-2.*t*np.sin(np.pi*(2.-n)/beta)/np.pi + 2.*t*(2.-n)*np.cos(np.pi*(2.-n)/beta)/beta) + n - 1. - n*n*0.25 + dec_dn = 2.*t*np.cos(np.pi*(2.0-n)/beta) - 2.*t*np.cos(np.pi*(2.0-n)/2.0) + U - U*0.5*n + + dec_dt = ec/t - U*dec_dU/t + + return ec, dec_dU, dec_dt, dec_dn + + +def generate_potential(L,U,t,occ,beta,dbeta_dU): + """ + Function that generates the Hxc BALDA potentials and energies for the full system. + """ + + deHxc_dn = np.zeros((L),dtype=float) + deHxc_dt = np.zeros((L),dtype=float) + deHxc_dU = np.zeros((L),dtype=float) + eHxc = np.zeros((L),dtype=float) + + for i in range(L): + ec, dec_dU, dec_dt, dec_dn = correlation_BALDA(U,t,occ[i],beta,dbeta_dU) + eHxc[i] = ec + U*0.25*occ[i]*occ[i] + deHxc_dn[i] = dec_dn + U*occ[i]*0.5 + + return eHxc, deHxc_dn diff --git a/src/SOFT/SCF.py b/src/SOFT/SCF.py new file mode 100644 index 0000000..e957291 --- /dev/null +++ b/src/SOFT/SCF.py @@ -0,0 +1,145 @@ +#!/usr/bin/python +# -*- coding: utf-8 -*- + +import os +import sys +import subprocess +import numpy as np +from scipy.linalg import eigh +from scipy import optimize +import random + +sys.path.insert(0, os.getcwd()) +from .BALDA import generate_potential + +def generate_hamiltonian(L,N,t,v): + """ + Function that generates the non-interacting 1D Hubbard Hamiltonian with potential v. + """ + + H = np.zeros((L,L),dtype=float) + + for i in range(L-1): + H[i,i+1] = H[i+1,i] = -t + H[i,i] = v[i] + + if ((N//2) % 2 == 1): #periodic condition + H[L-1,0] = H[0,L-1] = -t + elif ((N//2) % 2 == 0): #antiperiodic condition + H[L-1,0] = H[0,L-1] = +t + H[L-1,L-1] = v[L-1] + + return H + +def solve_KShamiltonian(L,N,H): + """ + Function to diagonalize the Hamiltonian and extract the one-particle reduced density matrix and the orbital energies. + """ + + orb_energy,C = eigh(H) + + # One-particle reduced density matrix: + onepdm = np.zeros((L,L),dtype=float) + occ = np.zeros((L),dtype=float) + for i in range(L): + for j in range(L): + for k in range(N//2): + onepdm[i,j]+=2*C[i,k]*C[j,k] # factor 2 because we work with spatial orbitals + occ[i] = onepdm[i,i] + + return onepdm,occ,orb_energy,C + +def self_consistency(Nsites,Nelec,U,t,pot,beta,dbeta_dU,MAXIT,path_results_folder,output_file,mix_cst=0.4): + """ + Function to get the self-consistent energy and occupations. + """ + + # Start with uniform density + occ = np.full((Nsites),1.*Nelec/(1.*Nsites)) + with open(output_file,'a') as f: + f.write("*"*10 + " Initialization " + "*"*10 + "\n") + f.write(""" + L = {} + N = {} + t = {} + U = {} + v = {}\n""".format(Nsites,Nelec,t,U,pot)) + + f.write(" Initial trial sites occupation:\n{}\n\n".format(occ)) + + Etot = 0 + it = 0 + delta_E = 1 + convergence = True + while (delta_E > 1e-4 or normocc > 1e-4) and convergence: #or mix_cst < 1) and convergence: + + + # Compute the vHxc contributions + deHxc_dn = generate_potential(Nsites,U,t,occ,beta,dbeta_dU)[1] + KSpot = np.add(pot,deHxc_dn) + + # Construct and solve the KS Hamiltonian + h_SOFT = generate_hamiltonian(Nsites,Nelec,t,KSpot) + onepdm_SOFT, occ_new, KS_energies, KS_orbs = solve_KShamiltonian(Nsites,Nelec,h_SOFT) + + # compute the eHxc contribution with the new density + eHxc = generate_potential(Nsites,U,t,occ_new,beta,dbeta_dU)[0] + + # Compute the total energy + sum_occ_eKS = 0. + sum_eHxc = 0. + sum_deHxc_dn = 0. + for i in range(Nelec//2): sum_occ_eKS += 2*KS_energies[i] + for i in range(Nsites): sum_eHxc += eHxc[i] + for i in range(Nsites): sum_deHxc_dn += deHxc_dn[i]*occ_new[i] + Etot_new = sum_occ_eKS + sum_eHxc - sum_deHxc_dn + + delta_E = abs(Etot_new - Etot) + Etot = Etot_new + normocc = np.linalg.norm(occ - occ_new) + + #if (delta_E <= 1e-4 and normocc <= 1e-4): mix_cst += 0.2 + occ = (1 - mix_cst)*occ + mix_cst*occ_new + + with open(output_file,'a') as f: + f.write("*"*10 + " ITERATION {:3d} ".format(it) + "*"*10 + "\n") + f.write("mix constant : {:4.2f}".format(mix_cst) + "\n") + f.write("Energy (hartree) : {:16.8f}".format(Etot) + "\n") + f.write("Occupied KS : {}".format(KS_energies[:Nelec//2]) + "\n") + f.write("New occ : {}".format(occ_new) + "\n") + f.write("Damped occ : {}".format(occ) + "\n") + f.write("Delta Energy : {:16.8f}".format(delta_E) + "\n") + f.write("Norm Delta_occ : {:16.8f}\n".format(normocc) + "\n") + + it+=1 + + if it > MAXIT: convergence=False + + return convergence, Etot, occ, it, KS_orbs + +def run_SOFT_Hubbard(Nsites,Nelec,U,t,pot,MAXIT,code_directory,output_file): + + # Compute beta and dbeta_dU for the approximate BALDA potential + subprocess.check_call("echo " + str(U) + " " + str(t) + " | beta_and_derivatives",shell=True, cwd = code_directory) + with open(code_directory + "beta_dbetadU.dat","r") as f: + line = f.read() + beta = float(line.split()[0]) + dbeta_dU = float(line.split()[1]) + f.close() + + # Perform the self-consistent algorithm + conv, Etot, occ, it, KS_orbs = self_consistency(Nsites,Nelec,U,t,pot,beta,dbeta_dU,MAXIT,code_directory+"/results/",output_file) + + # Check convergence. + if (conv): + with open(output_file,'a') as f: + f.write("*"*10 + " SUCCESS " + "*"*10 + "\n") + f.write("Iteration : {:16d}".format(it) + "\n") + f.write("Energy (hartree) : {:16.8f}".format(Etot) + "\n") + f.write("Occupations : {}".format(occ) + "\n") + else: + with open(output_file,'a') as f: + f.write("*"*10 + " FAILURE " + "*"*10 + "\n") + f.write("Iteration > {}, NO_CONVERGENCE_REACHED".format(MAXIT) + "\n") + + return KS_orbs, Etot, occ diff --git a/src/SOFT/__init__.py b/src/SOFT/__init__.py new file mode 100644 index 0000000..696a975 --- /dev/null +++ b/src/SOFT/__init__.py @@ -0,0 +1,11 @@ +#!/usr/bin/env python3 + +from .SCF import ( + generate_hamiltonian, + solve_KShamiltonian, + self_consistency, + run_SOFT_Hubbard) + +from .BALDA import ( + correlation_BALDA, + generate_potential)