https://github.com/CosmicFish/CosmicFish
Tip revision: 786da254acb46a444dbb78e0a61933286a14d0be authored by Matteo Martinelli on 15 June 2017, 11:25:13 UTC
code works, results to be checked and validated
code works, results to be checked and validated
Tip revision: 786da25
001_quadpack_double.f90
!----------------------------------------------------------------------------------------
!
! This file is part of CosmicFish.
!
! Copyright (C) 2015-2017 by the CosmicFish authors
!
! The CosmicFish code is free software;
! You can use it, 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.
! The full text of the license can be found in the file LICENSE at
! the top level of the CosmicFish distribution.
!
!----------------------------------------------------------------------------------------
!> @file 001_quadpack_double.f90
!! This file contains the relevant code for the double precision QUADPACK integration library.
!! This code was developed by many authors that retain the copyright for the following code.
!! This source file was modified by Marco Raveri to use it with the CosmicFish code.
!----------------------------------------------------------------------------------------
!> This module contains the relevant code for the double precision QUADPACK integration library.
module quadpack
implicit none
contains
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dgtsl ( n, c, d, e, b, info )
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 dgtsl
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqage ( f, a, b, epsabs, epsrel, key, limit, result, abserr, &
neval, ier, alist, blist, rlist, elist, iord, last )
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 dqage
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqag ( f, a, b, epsabs, epsrel, key, result, abserr, neval, ier, &
limit, lenw, last, iwork, work )
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 dqag
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqagie ( f, bound, inf, epsabs, epsrel, limit, result, abserr, &
neval, ier, alist, blist, rlist, elist, iord, last )
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 dqagie
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqagi ( f, bound, inf, epsabs, epsrel, result, abserr, neval, &
ier,limit,lenw,last,iwork,work)
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 dqagi
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, &
abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin, &
last)
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 dqagpe
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqagp ( f, a, b, npts2, points, epsabs, epsrel, result, abserr, &
neval, ier, leniw, lenw, last, iwork, work )
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 dqagp
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, &
ier,alist,blist,rlist,elist,iord,last)
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 dqagse
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqags ( f, a, b, epsabs, epsrel, result, abserr, neval, ier, &
limit, lenw, last, iwork, work )
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 dqags
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqawce(f,a,b,c,epsabs,epsrel,limit,result,abserr,neval, &
ier,alist,blist,rlist,elist,iord,last)
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 dqawce
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqawc ( f, a, b, c, epsabs, epsrel, result, abserr, neval, ier, &
limit, lenw, last, iwork, work )
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 dqawc
!----------------------------------------------------------------------------------------
!> 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)
!!
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)
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 dqawfe
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqawf ( f, a, omega, integr, epsabs, result, abserr, neval, ier, &
limlst, lst, leniw, maxp1, lenw, iwork, work )
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 dqawf
!----------------------------------------------------------------------------------------
!> 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.
!!
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 )
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 dqawoe
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqawo ( f, a, b, omega, integr, epsabs, epsrel, result, abserr, &
neval, ier, leniw, maxp1, lenw, last, iwork, work )
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 dqawo
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqawse(f,a,b,alfa,beta,integr,epsabs,epsrel,limit, &
result,abserr,neval,ier,alist,blist,rlist,elist,iord,last)
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 dqawse
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqaws ( f, a, b, alfa, beta, integr, epsabs, epsrel, result, &
abserr, neval, ier, limit, lenw, last, iwork, work )
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 dqaws
!----------------------------------------------------------------------------------------
!> 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
!!
subroutine dqc25c(f,a,b,c,result,abserr,krul,neval)
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 dqc25c
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqc25f(f,a,b,omega,integr,nrmom,maxp1,ksave,result, &
abserr,neval,resabs,resasc,momcom,chebmo)
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 dqc25f
!----------------------------------------------------------------------------------------
!> 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)
!!
subroutine dqc25s(f,a,b,bl,br,alfa,beta,ri,rj,rg,rh,result, &
abserr,resasc,integr,nev)
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 dqc25s
!----------------------------------------------------------------------------------------
!> 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
!!
subroutine dqcheb ( x, fval, cheb12, cheb24 )
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 dqcheb
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqelg ( n, epstab, result, abserr, res3la, nres )
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 dqelg
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk15(f,a,b,result,abserr,resabs,resasc)
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 dqk15
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc)
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 dqk15i
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk15w(f,w,p1,p2,p3,p4,kp,a,b,result,abserr, resabs,resasc)
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 dqk15w
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk21(f,a,b,result,abserr,resabs,resasc)
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 dqk21
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk31(f,a,b,result,abserr,resabs,resasc)
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 dqk31
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk41 ( f, a, b, result, abserr, resabs, resasc )
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 dqk41
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk51(f,a,b,result,abserr,resabs,resasc)
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 dqk51
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqk61(f,a,b,result,abserr,resabs,resasc)
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 dqk61
!----------------------------------------------------------------------------------------
!> 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
!!
subroutine dqmomo(alfa,beta,ri,rj,rg,rh,integr)
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 dqmomo
!----------------------------------------------------------------------------------------
!> 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.
!!
subroutine dqng ( f, a, b, epsabs, epsrel, result, abserr, neval, ier )
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 dqng
!----------------------------------------------------------------------------------------
!> 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)
!!
subroutine dqpsrt ( limit, last, maxerr, ermax, elist, 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 subroutine dqpsrt
!----------------------------------------------------------------------------------------
!> DQWGTC defines the weight function used by DQC25C.
!!
!! Modified:
!!
!! 11 September 2015
!!
!! Author:
!!
!! Robert Piessens, Elise de Doncker
!!
function dqwgtc ( x, c, p2, p3, p4, kp )
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 dqwgtc
!----------------------------------------------------------------------------------------
!> DQWGTF defines the weight functions used by DQC25F.
!!
!! Modified:
!!
!! 11 September 2015
!!
!! Author:
!!
!! Robert Piessens, Elise de Doncker
!!
function dqwgtf(x,omega,p2,p3,p4,integr)
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 dqwgtf
!----------------------------------------------------------------------------------------
!> DQWGTS defines the weight functions used by DQC25S.
!!
!! Modified:
!!
!! 11 September 2015
!!
!! Author:
!!
!! Robert Piessens, Elise de Doncker
!!
function dqwgts ( x, a, b, alfa, beta, integr )
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 function dqwgts
!----------------------------------------------------------------------------------------
!> XERROR replaces the SLATEC XERROR routine.
!!
!! Modified:
!!
!! 12 September 2015
!!
subroutine xerror ( xmess, nmess, nerr, level )
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 subroutine xerror
end module quadpack
