From 139f42fee23d2eab00f254f976343d06f74b3d01 Mon Sep 17 00:00:00 2001 From: Lorenzo Figini Date: Fri, 12 Jun 2015 10:25:18 +0000 Subject: [PATCH] grayl split in several f90 modules. only spline routines missing. --- Makefile | 26 +- src/conical.f90 | 853 ++++++ src/dispersion.f90 | 236 +- src/dqagmv.f | 1696 ------------ src/gray.f | 27 +- src/grayl.f | 6131 ------------------------------------------ src/green_func_p.f90 | 1 + src/math.f90 | 125 + src/minpack.f90 | 1401 ++++++++++ src/numint.f90 | 257 ++ src/quadpack.f90 | 4541 +++++++++++++++++++++++++++++++ src/reflections.f90 | 88 +- src/utils.f90 | 249 ++ 13 files changed, 7680 insertions(+), 7951 deletions(-) create mode 100644 src/conical.f90 delete mode 100644 src/dqagmv.f create mode 100644 src/math.f90 create mode 100644 src/minpack.f90 create mode 100644 src/numint.f90 create mode 100644 src/quadpack.f90 create mode 100644 src/utils.f90 diff --git a/Makefile b/Makefile index c76cb49..7797e36 100644 --- a/Makefile +++ b/Makefile @@ -3,9 +3,11 @@ EXE=gray # Objects list MAINOBJ=gray.o -OTHOBJ=dispersion.o eierf.o dqagmv.o grayl.o reflections.o green_func_p.o \ - const_and_precisions.o graydata_flags.o graydata_par.o graydata_anequil.o \ - magsurf_data.o interp_eqprof.o +OTHOBJ=conical.o const_and_precisions.o dispersion.o eierf.o \ + graydata_flags.o graydata_par.o graydata_anequil.o grayl.o \ + green_func_p.o interp_eqprof.o magsurf_data.o math.o minpack.o \ + numint.o quadpack.o reflections.o utils.o + # Alternative search paths vpath %.f90 src @@ -24,16 +26,24 @@ $(EXE): $(MAINOBJ) $(OTHOBJ) $(FC) $(FFLAGS) -o $@ $^ # Dependencies on modules -gray.o: dispersion.o dqagmv.o green_func_p.o reflections.o const_and_precisions.o \ - graydata_flags.o graydata_par.o graydata_anequil.o magsurf_data.o interp_eqprof.o -green_func_p.o: const_and_precisions.o -reflections.o: const_and_precisions.o -dispersion.o: const_and_precisions.o eierf.o dqagmv.o +gray.o: const_and_precisions.o conical.o dispersion.o green_func_p.o \ + graydata_flags.o graydata_par.o graydata_anequil.o interp_eqprof.o \ + magsurf_data.o math.o minpack.o numint.o quadpack.o reflections.o \ + utils.o +grayl.o: const_and_precisions.o +green_func_p.o: const_and_precisions.o numint.o +numint.o: const_and_precisions.o +reflections.o: const_and_precisions.o utils.o +conical.o: const_and_precisions.o +dispersion.o: const_and_precisions.o eierf.o math.o quadpack.o +math.o: const_and_precisions.o +minpack.o: const_and_precisions.o graydata_flags.o: const_and_precisions.o graydata_par.o: const_and_precisions.o graydata_anequil.o: const_and_precisions.o magsurf_data.o: const_and_precisions.o interp_eqprof.o: const_and_precisions.o +utils.o: const_and_precisions.o # General object compilation command %.o: %.f90 diff --git a/src/conical.f90 b/src/conical.f90 new file mode 100644 index 0000000..ff7195b --- /dev/null +++ b/src/conical.f90 @@ -0,0 +1,853 @@ +module conical + + use const_and_precisions, only : wp_ + implicit none + +contains + + function fconic(x,tau,m) +! +! this function subprogram computes the conical functions of the +! first kind P sub(-1/2 + i*tau) (x) for m = 0 and m = 1. +! Ref. in Kolbig, Comp. Phys. Commun. 23 (1981) 51 +! + implicit none + real(wp_), intent(in) :: x, tau + integer, intent(in) :: m + real(wp_) :: fconic + real(wp_) :: t(7),h(9),v(11) + real(wp_) :: aa,a0,a1,a2,a3,a4,a5,a6,b0,b1,fm,fn,fn1,r1,r2,s,s0,s1 + real(wp_) :: x1,y,y2,y3,z + integer :: jp,j,n + real(wp_), parameter :: rpi=1.7724538509055_wp_,pi2=0.63661977236758_wp_ + real(wp_), parameter :: eps=1.0e-14_wp_ + integer, parameter :: nout=2,nmax=200 +! + complex(wp_) a,b,c,ti,r,rr,q,u,u0,u1,u2,uu + complex(wp_) v0,v1,v2,vv,w(19) +! + logical lm0,lm1,lta + + fconic=0.0_wp_ + lm0=m == 0 + lm1=m == 1 + if(.not.(lm0 .or. lm1)) then + write(nout,"(1x,'fconic ... illegal value for m = ',i4)") m + return + end if + fm=m + fconic=1.0_wp_-fm + if(x == 1.0_wp_) return +! + fconic=0.0_wp_ + if(tau == 0.0_wp_ .and. abs(x-1.0_wp_) > 0.01_wp_) then + if(x > 1.0_wp_) then + y=sqrt((x-1.0_wp_)/(x+1.0_wp_)) + z=ellick(y) + s=sqrt(0.5_wp_*(x+1.0_wp_)) + if(lm0) fconic=pi2*z/s + if(lm1) fconic=pi2*s*(ellice(y)-z)/sqrt(x**2-1.0_wp_) + return + else + y=sqrt(0.5_wp_*(1.0_wp_-x)) + z=ellick(y) + if(lm0) fconic=pi2*z + if(lm1) fconic=pi2*(ellice(y)-0.5_wp_*(1.0_wp_+x)*z)/ & + sqrt(1.0_wp_-x**2) + return + end if + else + ti=cmplx(0._wp_,tau) +! + if((-1._wp_ < x .and. x <= 0.0_wp_).or. & + (0.0_wp_ < x .and. x <= 0.1_wp_ .and.tau<= 17.0_wp_).or. & + (0.1_wp_ < x .and. x <= 0.2_wp_ .and.tau<= 5.0_wp_)) then + lta=tau <= 10.0_wp_ + x1=x**2 + a=0.5_wp_*(0.5_wp_-fm-ti) + b=0.5_wp_*(0.5_wp_-fm+ti) + c=0.5_wp_ + jp=30 + else if((0.1_wp_ < x .and. x <= 0.2_wp_ .and.tau<= 17.0_wp_) & + .or.(0.2_wp_ < x .and. x <= 1.5_wp_ .and.tau<= 20.0_wp_)) & + then + lta=x > 1.0_wp_ .or. x <= 1.0_wp_ .and. tau <= 5.0_wp_ + x1=(1.0_wp_-x)/2._wp_ + a=0.5_wp_+fm-ti + b=0.5_wp_+fm+ti + c=fm+1.0_wp_ + jp=32 + else if(1.5_wp_ < x .and. tau <= max(20.0_wp_,x)) then + lta=.true. + x1=1.0_wp_/x**2 + u=exp((-0.5_wp_+ti)*log(2.0_wp_*x)+clogam(1.0_wp_+ti) & + -clogam(1.5_wp_-fm+ti)) + a=0.5_wp_*(0.5_wp_-fm-ti) + b=0.5_wp_*(1.5_wp_-fm-ti) + c=1.0_wp_-ti + jp=33 + else + if(x > 1.0_wp_) then + s=sqrt(x**2-1.0_wp_) + t(1)=log(x+s) + h(1)=tau*t(1) + b0=besj0l(h(1)) + b1=besj1l(h(1)) + z=1.0_wp_ + else + s=sqrt(1.0_wp_-x**2) + t(1)=acos(x) + h(1)=tau*t(1) + b0=besi0(h(1)) + b1=besi1(h(1)) + z=-1.0_wp_ + end if + h(1)=t(1)*x/s + v(1)=tau + do j = 2,7 + t(j)=t(j-1)*t(1) + h(j)=h(j-1)*h(1) + end do + do j = 2,11 + v(j)=v(j-1)*v(1) + end do +! + if(lm1) then + aa=-1.0_wp_ + a0=3.0_wp_*(1.0_wp_-h(1))/(8.0_wp_*t(1)) + a1=(-15.0_wp_*h(2)+6.0_wp_*h(1)+9.0_wp_+z*8.0_wp_*t(2))/ & + (128.0_wp_*t(2)) + a2=3.0_wp_*(-35.0_wp_*h(3)-15.0_wp_*h(2)+15.0_wp_*h(1)+35.0_wp_ & + +z*t(2)*(32.0_wp_*h(1)+8.0_wp_))/(1024.0_wp_*t(3)) + a3=(-4725.0_wp_*h(4)-6300.0_wp_*h(3)-3150.0_wp_*h(2)+3780.0_wp_*h(1) & + +10395.0_wp_-1216.0_wp_*t(4)+z*t(2)*(6000.0_wp_*h(2) & + +5760.0_wp_*h(1)+1680.0_wp_)) /(32768.0_wp_*t(4)) + a4=7.0_wp_*(-10395.0_wp_*h(5)-23625.0_wp_*h(4)-28350.0_wp_*h(3) & + -14850.0_wp_*h(2)+19305.0_wp_*h(1)+57915.0_wp_ & + -t(4)*(6336.0_wp_*h(1)+6080.0_wp_)+z*t(2)*(16800.0_wp_*h(3) & + +30000.0_wp_*h(2)+25920.0_wp_*h(1)+7920.0_wp_))/ & + (262144.0_wp_*t(5)) + a5=(-2837835.0_wp_*h(6)-9168390.0_wp_*h(5)-16372125.0_wp_*h(4) & + -18918900*h(3) -10135125.0_wp_*h(2)+13783770.0_wp_*h(1) & + +43648605.0_wp_-t(4)*(3044160.0_wp_*h(2)+5588352.0_wp_*h(1) & + +4213440.0_wp_)+z*t(2)*(5556600.0_wp_*h(4)+14817600.0_wp_*h(3) & + +20790000.0_wp_*h(2)+17297280.0_wp_*h(1)+5405400.0_wp_ & + +323072.0_wp_*t(4)))/ (4194304.0_wp_*t(6)) + a6=0.0_wp_ + else + aa=0.0_wp_ + a0=1.0_wp_ + a1=(h(1)-1.0_wp_)/(8.0_wp_*t(1)) + a2=(9.0_wp_*h(2)+6.0_wp_*h(1)-15.0_wp_-z*8.0_wp_*t(2))/ & + (128.0_wp_*t(2)) + a3=5.0_wp_*(15.0_wp_*h(3)+27.0_wp_*h(2)+21.0_wp_*h(1)-63.0_wp_ & + -z*t(2)*(16.0_wp_*h(1)+24.0_wp_))/(1024.0_wp_*t(3)) + a4=7.0_wp_*(525.0_wp_*h(4)+1500.0_wp_*h(3)+2430.0_wp_*h(2) & + +1980.0_wp_*h(1)-6435.0_wp_+192.0_wp_*t(4)-z*t(2)* & + (720.0_wp_*h(2)+1600.0_wp_*h(1)+2160.0_wp_))/(32768.0_wp_*t(4)) + a5=21.0_wp_*(2835.0_wp_*h(5)+11025.0_wp_*h(4)+24750.0_wp_*h(3) & + +38610.0_wp_*h(2)+32175.0_wp_*h(1)-109395.0_wp_+t(4) & + *(1984.0_wp_*h(1)+4032.0_wp_)-z*t(2) & + *(4800.0_wp_*h(3)+15120.0_wp_*h(2)+26400.0_wp_*h(1)+34320.0_wp_)) & + /(262144.0_wp_*t(5)) + a6=11.0_wp_*(218295.0_wp_*h(6)+1071630.0_wp_*h(5)+3009825.0_wp_*h(4) & + +6142500.0_wp_*h(3)+9398025.0_wp_*h(2)+7936110.0_wp_*h(1) & + -27776385.0_wp_+t(4)*(254016.0_wp_*h(2) & + +749952.0_wp_*h(1)+1100736.0_wp_)-z*t(2)*(441000.0_wp_*h(4) & + +1814400.0_wp_*h(3)+4127760.0_wp_*h(2)+6552000.0_wp_*h(1) & + +8353800.0_wp_+31232.0_wp_*t(4)))/(4194304.0_wp_*t(6)) + end if + s0=a0+(-4.0_wp_*a3/t(1)+a4)/v(4)+(-192.0_wp_*a5/t(3) & + +144.0_wp_*a6/t(2))/v(8)+z*(-a2/v(2)+(-24.0_wp_*a4/t(2) & + +12.0_wp_*a5/t(1)-a6)/v(6)+(-1920.0_wp_*a6/t(4))/v(10)) + s1=a1/v(1)+(8.0_wp_*(a3/t(2)-a4/t(1))+a5)/v(5)+(384.0_wp_*a5/t(4) & + -768.0_wp_*a6/t(3))/v(9)+z*(aa*v(1)+(2.0_wp_*a2/t(1)-a3)/v(3) & + +(48.0_wp_*a4/t(3)-72.0_wp_*a5/t(2) & + +18.0_wp_*a6/t(1))/v(7)+(3840.0_wp_*a6/t(5))/v(11)) + fconic=sqrt(t(1)/s)*(b0*s0+b1*s1) + return + end if +! + do + if(lta) then + y=-x1 + y2=y**2 + y3=y**3 + w(1)=a+1.0_wp_ + w(2)=a+2.0_wp_ + w(3)=b+1.0_wp_ + w(4)=b+2.0_wp_ + w(5)=c+1.0_wp_ + w(6)=c*w(5) + w(7)=a+b + w(8)=a*b + w(9)=(w(8)/c)*y + w(10)=w(1)*w(3) + w(11)=w(2)*w(4) + w(12)=1.0_wp_+(w(11)/(2.0_wp_*w(5)))*y + w(13)=w(7)-6.0_wp_ + w(14)=w(7)+6.0_wp_ + w(15)=2.0_wp_-w(8) + w(16)=w(15)-2.0_wp_*w(7) +! + v0=1.0_wp_ + v1=1.0_wp_+(w(10)/(2.0_wp_*c))*y + v2=w(12)+(w(10)*w(11)/(12.0_wp_*w(6)))*y2 + u0=1.0_wp_ + u1=v1-w(9) + u2=v2-w(9)*w(12)+(w(8)*w(10)/(2.0_wp_*w(6)))*y2 +! + r=1.0_wp_ + n=2 + do + n=n+1 + if(n > nmax) then + write(nout,200) x,tau,m + return + end if + rr=r + fn=n + h(1)=fn-1.0_wp_ + h(2)=fn-2.0_wp_ + h(3)=fn-3.0_wp_ + h(4)=2.0_wp_*fn + h(5)=h(4)-3.0_wp_ + h(6)=2.0_wp_*h(5) + h(7)=4.0_wp_*(h(4)-1.0_wp_)*h(5) + h(8)=8.0_wp_*h(5)**2*(h(4)-5.0_wp_) + h(9)=3.0_wp_*fn**2 + w(1)=a+h(1) + w(2)=a+h(2) + w(3)=b+h(1) + w(4)=b+h(2) + w(5)=c+h(1) + w(6)=c+h(2) + w(7)=c+h(3) + w(8)=h(2)-a + w(9)=h(2)-b + w(10)=h(1)-c + w(11)=w(1)*w(3) + w(12)=w(5)*w(6) +! + w(17)=1.0_wp_+((h(9)+w(13)*fn+w(16))/(h(6)*w(5)))*y + w(18)=-((w(11)*w(10)/h(6)+(h(9)-w(14)*fn+w(15))* & + w(11)*y/h(7))/w(12))*y + w(19)=(w(2)*w(11)*w(4)*w(8)*w(9)/(h(8)*w(7)*w(12)))*y3 + vv=w(17)*v2+w(18)*v1+w(19)*v0 + uu=w(17)*u2+w(18)*u1+w(19)*u0 + r=uu/vv + if(abs(r-rr) < eps) exit + v0=v1 + v1=v2 + v2=vv + u0=u1 + u1=u2 + u2=uu + end do + else + r=1.0_wp_ + q=1.0_wp_ + do n = 1,nmax + fn=n + fn1=fn-1.0_wp_ + rr=r + q=q*x1*(a+fn1)*(b+fn1)/((c+fn1)*fn) + r=r+q + if(abs(r-rr) < eps) exit + end do + if (n > nmax) then + write(nout,200) x,tau,m + return + end if + end if + if (jp/=30) exit + r1=real(r)/abs(exp(clogam(a+0.5_wp_)))**2 + a=0.5_wp_*(1.5_wp_-fm-ti) + b=0.5_wp_*(1.5_wp_-fm+ti) + c=1.5_wp_ + jp=31 + end do + if (jp==31) then + r2=real(r)/abs(exp(clogam(a-0.5_wp_)))**2 + fconic=rpi*(r1-2.0_wp_*x*r2) + if(lm1) fconic=(2.0_wp_/sqrt(1.0_wp_-x1))*fconic + return + else if (jp==32) then + fconic=real(r) + if(.not.lm0) then + fconic=0.5_wp_*(tau**2+0.25_wp_)*sqrt(abs(x**2-1.0_wp_))*fconic + if(x > 1.0_wp_) fconic=-fconic + end if + return + else if (jp==33) then + fconic=2.0_wp_*real(u*r*(0.5_wp_-fm+ti)/ti)/rpi + if(lm1) fconic=fconic/sqrt(1.0_wp_-x1) + return + end if + end if +! + 200 format(1x,'fconic ... convergence difficulties for c function, x = ', & + e12.4,5x,'tau = ',e12.4,5x,'m = ',i5) +! + end function fconic + + function clogam(z) +! + implicit none + complex(wp_) :: clogam + complex(wp_), intent(in) :: z + complex(wp_) :: v,h,r + integer :: i,n + real(wp_) :: x,t,a,c,d,e,f + integer, parameter :: nout=2 + real(wp_), parameter :: pi=3.1415926535898_wp_ + real(wp_), dimension(10), parameter :: b= & + (/+8.3333333333333e-2_wp_, -2.7777777777778e-3_wp_, & + +7.9365079365079e-4_wp_, -5.9523809523810e-4_wp_, & + +8.4175084175084e-4_wp_, -1.9175269175269e-3_wp_, & + +6.4102564102564e-3_wp_, -2.9550653594771e-2_wp_, & + +1.7964437236883e-1_wp_, -1.3924322169059e+0_wp_/) +! + x=real(z) + t=aimag(z) + if(-abs(x) == aint(x) .and. t == 0.0_wp_) then + write(nout,'(1x,f20.2)') x + clogam=(0.0_wp_,0.0_wp_) + return + end if + f=abs(t) + v=cmplx(x,f) + if(x < 0.0_wp_) v=1.0_wp_-v + h=(0.0_wp_,0.0_wp_) + c=real(v) + if(c < 7.0_wp_) then + n=6-int(c) + h=v + d=aimag(v) + a=atan2(d,c) + do i = 1,n + c=c+1.0_wp_ + v=cmplx(c,d) + h=h*v + a=a+atan2(d,c) + end do + h=cmplx(0.5_wp_*log(real(h)**2+aimag(h)**2),a,wp_) + v=v+1.0_wp_ + end if + r=1.0_wp_/v**2 + clogam=0.91893853320467_wp_+(v-0.5_wp_)*log(v)-v+(b(1)+r*(b(2)+r*(b(3) & + +r*(b(4)+r*(b(5)+r*(b(6)+r*(b(7)+r*(b(8)+r*(b(9)+r*b(10)))))))))) & + /v-h + if(x < 0.0_wp_) then +! + a=aint(x)-1.0_wp_ + c=pi*(x-a) + d=pi*f + e=exp(-2.0_wp_*d) + f=sin(c) + e=d+0.5_wp_*log(e*f**2+0.25_wp_*(1.0_wp_-e)**2) + f=atan2(cos(c)*tanh(d),f)-a*pi + clogam=1.1447298858494_wp_-cmplx(e,f)-clogam +! + end if + if(t < 0.0_wp_) clogam=conjg(clogam) +! + end function clogam + + function ellick(xk) + implicit none + real(wp_), intent(in) :: xk + real(wp_) :: ellick, ellice + integer :: i + real(wp_) :: eta,pa,pb,pc,pd + real(wp_), dimension(10), parameter :: & + a=(/9.6573590280856e-2_wp_, 3.0885146271305e-2_wp_, & + 1.4938013532687e-2_wp_, 8.7898018745551e-3_wp_, & + 6.1796274460533e-3_wp_, 6.8479092826245e-3_wp_, & + 9.8489293221769e-3_wp_, 8.0030039806500e-3_wp_, & + 2.2966348983970e-3_wp_, 1.3930878570066e-4_wp_/), & + b=(/1.2499999999991e-1_wp_, 7.0312499739038e-2_wp_, & + 4.8828041906862e-2_wp_, 3.7377739758624e-2_wp_, & + 3.0124849012899e-2_wp_, 2.3931913323111e-2_wp_, & + 1.5530941631977e-2_wp_, 5.9739042991554e-3_wp_, & + 9.2155463496325e-4_wp_, 2.9700280966556e-5_wp_/), & + c=(/4.4314718056089e-1_wp_, 5.6805194567559e-2_wp_, & + 2.1831811676130e-2_wp_, 1.1569595745295e-2_wp_, & + 7.5950934225594e-3_wp_, 7.8204040609596e-3_wp_, & + 1.0770635039866e-2_wp_, 8.6384421736041e-3_wp_, & + 2.4685033304607e-3_wp_, 1.4946621757181e-4_wp_/), & + d=(/2.4999999999990e-1_wp_, 9.3749999721203e-2_wp_, & + 5.8593661255531e-2_wp_, 4.2717890547383e-2_wp_, & + 3.3478943665762e-2_wp_, 2.6145014700314e-2_wp_, & + 1.6804023346363e-2_wp_, 6.4321465864383e-3_wp_, & + 9.8983328462254e-4_wp_, 3.1859195655502e-5_wp_/) +! + if(abs(xk) >= 1.0_wp_) then + ellick=0.0_wp_ + return + end if + eta=1.0_wp_-xk**2 + pa=a(10) + do i = 1,9 + pa=pa*eta+a(10-i) + end do + pa=pa*eta + pb=b(10) + do i = 1,9 + pb=pb*eta+b(10-i) + end do + pb=pb*eta + ellick=1.3862943611199_wp_+pa-log(eta)*(0.5_wp_+pb) + return +! + entry ellice(xk) +! + if (abs(xk) >= 1.0_wp_) then + if (abs(xk) > 1.0_wp_) then + ellick=0.0_wp_ + else + ellick=1.0_wp_ + end if + return + end if + eta=1.0_wp_-xk**2 + pc=c(10) + do i = 1,9 + pc=pc*eta+c(10-i) + end do + pc=pc*eta + pd=d(10) + do i = 1,9 + pd=pd*eta+d(10-i) + end do + pd=pd*eta + ellick=1.0_wp_+pc-log(eta)*pd + end function ellick + + function besjy(x) + implicit none + real(wp_), intent(in) :: x + real(wp_) :: besjy,besj0l,besj1l + real(wp_) :: besy0,besy1 + logical :: l + real(wp_) :: v,f,a,b,p,q + integer, parameter :: nout=2 +! + entry besj0l(x) +! + l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 4 + 8 f=0.0625_wp_*x**2-2.0_wp_ + a = - 0.0000000000000008_wp_ + b = f * a + 0.0000000000000413_wp_ + a = f * b - a - 0.0000000000019438_wp_ + b = f * a - b + 0.0000000000784870_wp_ + a = f * b - a - 0.0000000026792535_wp_ + b = f * a - b + 0.0000000760816359_wp_ + a = f * b - a - 0.0000017619469078_wp_ + b = f * a - b + 0.0000324603288210_wp_ + a = f * b - a - 0.0004606261662063_wp_ + b = f * a - b + 0.0048191800694676_wp_ + a = f * b - a - 0.0348937694114089_wp_ + b = f * a - b + 0.1580671023320973_wp_ + a = f * b - a - 0.3700949938726498_wp_ + b = f * a - b + 0.2651786132033368_wp_ + a = f * b - a - 0.0087234423528522_wp_ + a = f * a - b + 0.3154559429497802_wp_ + besjy=0.5_wp_*(a-b) + if(l) return +! + a = + 0.0000000000000016_wp_ + b = f * a - 0.0000000000000875_wp_ + a = f * b - a + 0.0000000000040263_wp_ + b = f * a - b - 0.0000000001583755_wp_ + a = f * b - a + 0.0000000052487948_wp_ + b = f * a - b - 0.0000001440723327_wp_ + a = f * b - a + 0.0000032065325377_wp_ + b = f * a - b - 0.0000563207914106_wp_ + a = f * b - a + 0.0007531135932578_wp_ + b = f * a - b - 0.0072879624795521_wp_ + a = f * b - a + 0.0471966895957634_wp_ + b = f * a - b - 0.1773020127811436_wp_ + a = f * b - a + 0.2615673462550466_wp_ + b = f * a - b + 0.1790343140771827_wp_ + a = f * b - a - 0.2744743055297453_wp_ + a = f * a - b - 0.0662922264065699_wp_ + besjy=0.636619772367581_wp_*log(x)*besjy+0.5_wp_*(a-b) + return +! + 4 f=256.0_wp_/x**2-2.0_wp_ + b = + 0.0000000000000007_wp_ + a = f * b - 0.0000000000000051_wp_ + b = f * a - b + 0.0000000000000433_wp_ + a = f * b - a - 0.0000000000004305_wp_ + b = f * a - b + 0.0000000000051683_wp_ + a = f * b - a - 0.0000000000786409_wp_ + b = f * a - b + 0.0000000016306465_wp_ + a = f * b - a - 0.0000000517059454_wp_ + b = f * a - b + 0.0000030751847875_wp_ + a = f * b - a - 0.0005365220468132_wp_ + a = f * a - b + 1.9989206986950373_wp_ + p=a-b + b = - 0.0000000000000006_wp_ + a = f * b + 0.0000000000000043_wp_ + b = f * a - b - 0.0000000000000334_wp_ + a = f * b - a + 0.0000000000003006_wp_ + b = f * a - b - 0.0000000000032067_wp_ + a = f * b - a + 0.0000000000422012_wp_ + b = f * a - b - 0.0000000007271916_wp_ + a = f * b - a + 0.0000000179724572_wp_ + b = f * a - b - 0.0000007414498411_wp_ + a = f * b - a + 0.0000683851994261_wp_ + a = f * a - b - 0.0311117092106740_wp_ + q=8.0_wp_*(a-b)/v + f=v-0.785398163397448_wp_ + a=cos(f) + b=sin(f) + f=0.398942280401432_wp_/sqrt(v) + if(l) go to 6 + besjy=f*(q*a+p*b) + return + 6 besjy=f*(p*a-q*b) + return +! + entry besj1l(x) +! + l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 5 + 3 f=0.0625_wp_*x**2-2.0_wp_ + b = + 0.0000000000000114_wp_ + a = f * b - 0.0000000000005777_wp_ + b = f * a - b + 0.0000000000252812_wp_ + a = f * b - a - 0.0000000009424213_wp_ + b = f * a - b + 0.0000000294970701_wp_ + a = f * b - a - 0.0000007617587805_wp_ + b = f * a - b + 0.0000158870192399_wp_ + a = f * b - a - 0.0002604443893486_wp_ + b = f * a - b + 0.0032402701826839_wp_ + a = f * b - a - 0.0291755248061542_wp_ + b = f * a - b + 0.1777091172397283_wp_ + a = f * b - a - 0.6614439341345433_wp_ + b = f * a - b + 1.2879940988576776_wp_ + a = f * b - a - 1.1918011605412169_wp_ + a = f * a - b + 1.2967175412105298_wp_ + besjy=0.0625_wp_*(a-b)*x + if(l) return +! + b = - 0.0000000000000244_wp_ + a = f * b + 0.0000000000012114_wp_ + b = f * a - b - 0.0000000000517212_wp_ + a = f * b - a + 0.0000000018754703_wp_ + b = f * a - b - 0.0000000568844004_wp_ + a = f * b - a + 0.0000014166243645_wp_ + b = f * a - b - 0.0000283046401495_wp_ + a = f * b - a + 0.0004404786298671_wp_ + b = f * a - b - 0.0051316411610611_wp_ + a = f * b - a + 0.0423191803533369_wp_ + b = f * a - b - 0.2266249915567549_wp_ + a = f * b - a + 0.6756157807721877_wp_ + b = f * a - b - 0.7672963628866459_wp_ + a = f * b - a - 0.1286973843813500_wp_ + a = f * a - b + 0.0406082117718685_wp_ + besjy=0.636619772367581_wp_*log(x)*besjy-0.636619772367581_wp_/x & + +0.0625_wp_*(a-b)*x + return +! + 5 f=256.0_wp_/x**2-2.0_wp_ + b = - 0.0000000000000007_wp_ + a = f * b + 0.0000000000000055_wp_ + b = f * a - b - 0.0000000000000468_wp_ + a = f * b - a + 0.0000000000004699_wp_ + b = f * a - b - 0.0000000000057049_wp_ + a = f * b - a + 0.0000000000881690_wp_ + b = f * a - b - 0.0000000018718907_wp_ + a = f * b - a + 0.0000000617763396_wp_ + b = f * a - b - 0.0000039872843005_wp_ + a = f * b - a + 0.0008989898330859_wp_ + a = f * a - b + 2.0018060817200274_wp_ + p=a-b + b = + 0.0000000000000007_wp_ + a = f * b - 0.0000000000000046_wp_ + b = f * a - b + 0.0000000000000360_wp_ + a = f * b - a - 0.0000000000003264_wp_ + b = f * a - b + 0.0000000000035152_wp_ + a = f * b - a - 0.0000000000468636_wp_ + b = f * a - b + 0.0000000008229193_wp_ + a = f * b - a - 0.0000000209597814_wp_ + b = f * a - b + 0.0000009138615258_wp_ + a = f * b - a - 0.0000962772354916_wp_ + a = f * a - b + 0.0935555741390707_wp_ + q=8.0_wp_*(a-b)/v + f=v-2.356194490192345_wp_ + a=cos(f) + b=sin(f) + f=0.398942280401432_wp_/sqrt(v) + if(l) go to 7 + besjy=f*(q*a+p*b) + return + 7 besjy=f*(p*a-q*b) + if(x < 0.0_wp_) besjy=-besjy + return +! + entry besy0(x) +! + if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(v >= 8.0_wp_) go to 4 + go to 8 + entry besy1(x) +! + if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(v >= 8.0_wp_) go to 5 + go to 3 +! + 9 besjy=0.0_wp_ + write(nout,"(1x,'besjy ... non-positive argument x = ',e15.4)") x + end function besjy + + function besik(x) + implicit none + real(wp_), intent(in) :: x + real(wp_) :: besik,ebesi0,besi0,ebesi1,besi1,ebesk0,besk0,ebesk1,besk1 + logical :: l,e + real(wp_) :: v,f,a,b,z + integer, parameter :: nout=2 +! + entry ebesi0(x) +! + e=.true. + go to 1 +! + entry besi0(x) +! + e=.false. + 1 l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 4 + 8 f=0.0625_wp_*x**2-2.0_wp_ + a = 0.000000000000002_wp_ + b = f * a + 0.000000000000120_wp_ + a = f * b - a + 0.000000000006097_wp_ + b = f * a - b + 0.000000000268828_wp_ + a = f * b - a + 0.000000010169727_wp_ + b = f * a - b + 0.000000326091051_wp_ + a = f * b - a + 0.000008738315497_wp_ + b = f * a - b + 0.000192469359688_wp_ + a = f * b - a + 0.003416331766012_wp_ + b = f * a - b + 0.047718748798174_wp_ + a = f * b - a + 0.509493365439983_wp_ + b = f * a - b + 4.011673760179349_wp_ + a = f * b - a + 22.274819242462231_wp_ + b = f * a - b + 82.489032744024100_wp_ + a = f * b - a + 190.494320172742844_wp_ + a = f * a - b + 255.466879624362167_wp_ + besik=0.5_wp_*(a-b) + if(l .and. e) besik=exp(-v)*besik + if(l) return +! + a = + 0.000000000000003_wp_ + b = f * a + 0.000000000000159_wp_ + a = f * b - a + 0.000000000007658_wp_ + b = f * a - b + 0.000000000318588_wp_ + a = f * b - a + 0.000000011281211_wp_ + b = f * a - b + 0.000000335195256_wp_ + a = f * b - a + 0.000008216025940_wp_ + b = f * a - b + 0.000162708379043_wp_ + a = f * b - a + 0.002536308188086_wp_ + b = f * a - b + 0.030080722420512_wp_ + a = f * b - a + 0.259084432434900_wp_ + b = f * a - b + 1.511535676029228_wp_ + a = f * b - a + 5.283632866873920_wp_ + b = f * a - b + 8.005368868700334_wp_ + a = f * b - a - 4.563433586448395_wp_ + a = f * a - b - 21.057660177402440_wp_ + besik=-log(0.125_wp_*x)*besik+0.5_wp_*(a-b) + if(e) besik=exp(x)*besik + return +! + 4 f=32.0_wp_/v-2.0_wp_ + b = - 0.000000000000001_wp_ + a = f * b - 0.000000000000001_wp_ + b = f * a - b + 0.000000000000004_wp_ + a = f * b - a + 0.000000000000010_wp_ + b = f * a - b - 0.000000000000024_wp_ + a = f * b - a - 0.000000000000104_wp_ + b = f * a - b + 0.000000000000039_wp_ + a = f * b - a + 0.000000000000966_wp_ + b = f * a - b + 0.000000000001800_wp_ + a = f * b - a - 0.000000000004497_wp_ + b = f * a - b - 0.000000000033127_wp_ + a = f * b - a - 0.000000000078957_wp_ + b = f * a - b + 0.000000000029802_wp_ + a = f * b - a + 0.000000001238425_wp_ + b = f * a - b + 0.000000008513091_wp_ + a = f * b - a + 0.000000056816966_wp_ + b = f * a - b + 0.000000513587727_wp_ + a = f * b - a + 0.000007247591100_wp_ + b = f * a - b + 0.000172700630778_wp_ + a = f * b - a + 0.008445122624921_wp_ + a = f * a - b + 2.016558410917480_wp_ + besik=0.199471140200717_wp_*(a-b)/sqrt(v) + if(e) return + besik=exp(v)*besik + return +! + entry ebesi1(x) +! + e=.true. + go to 2 +! + entry besi1(x) +! + e=.false. + 2 l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 3 + 7 f=0.0625_wp_*x**2-2.0_wp_ + a = + 0.000000000000001_wp_ + b = f * a + 0.000000000000031_wp_ + a = f * b - a + 0.000000000001679_wp_ + b = f * a - b + 0.000000000079291_wp_ + a = f * b - a + 0.000000003227617_wp_ + b = f * a - b + 0.000000111946285_wp_ + a = f * b - a + 0.000003264138122_wp_ + b = f * a - b + 0.000078756785754_wp_ + a = f * b - a + 0.001543019015627_wp_ + b = f * a - b + 0.023993079147841_wp_ + a = f * b - a + 0.287855511804672_wp_ + b = f * a - b + 2.571459906347755_wp_ + a = f * b - a + 16.334550552522066_wp_ + b = f * a - b + 69.395917633734448_wp_ + a = f * b - a + 181.312616040570265_wp_ + a = f * a - b + 259.890237806477292_wp_ + besik=0.0625_wp_*(a-b)*x + if(l .and. e) besik=exp(-v)*besik + if(l) return +! + a = + 0.000000000000001_wp_ + b = f * a + 0.000000000000042_wp_ + a = f * b - a + 0.000000000002163_wp_ + b = f * a - b + 0.000000000096660_wp_ + a = f * b - a + 0.000000003696783_wp_ + b = f * a - b + 0.000000119367971_wp_ + a = f * b - a + 0.000003202510692_wp_ + b = f * a - b + 0.000070010627855_wp_ + a = f * b - a + 0.001217056994516_wp_ + b = f * a - b + 0.016300049289816_wp_ + a = f * b - a + 0.161074301656148_wp_ + b = f * a - b + 1.101461993004852_wp_ + a = f * b - a + 4.666387026862842_wp_ + b = f * a - b + 9.361617831395389_wp_ + a = f * b - a - 1.839239224286199_wp_ + a = f * a - b - 26.688095480862668_wp_ + besik=log(0.125_wp_*x)*besik+1.0_wp_/x-0.0625_wp_*(a-b)*x + if(e) besik=exp(x)*besik + return +! + 3 f=32.0_wp_/v-2.0_wp_ + b = + 0.000000000000001_wp_ + a = f * b + 0.000000000000001_wp_ + b = f * a - b - 0.000000000000005_wp_ + a = f * b - a - 0.000000000000010_wp_ + b = f * a - b + 0.000000000000026_wp_ + a = f * b - a + 0.000000000000107_wp_ + b = f * a - b - 0.000000000000053_wp_ + a = f * b - a - 0.000000000001024_wp_ + b = f * a - b - 0.000000000001804_wp_ + a = f * b - a + 0.000000000005103_wp_ + b = f * a - b + 0.000000000035408_wp_ + a = f * b - a + 0.000000000081531_wp_ + b = f * a - b - 0.000000000047563_wp_ + a = f * b - a - 0.000000001401141_wp_ + b = f * a - b - 0.000000009613873_wp_ + a = f * b - a - 0.000000065961142_wp_ + b = f * a - b - 0.000000629724239_wp_ + a = f * b - a - 0.000009732146728_wp_ + b = f * a - b - 0.000277205360764_wp_ + a = f * b - a - 0.024467442963276_wp_ + a = f * a - b + 1.951601204652572_wp_ + besik=0.199471140200717_wp_*(a-b)/sqrt(v) + if(x < 0.0_wp_) besik=-besik + if(e) return + besik=exp(v)*besik + return +! + entry ebesk0 (x) +! + e=.true. + go to 11 +! + entry besk0(x) +! + e=.false. + 11 if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(x < 5.0_wp_) go to 8 + f=20.0_wp_/x-2.0_wp_ + a = - 0.000000000000002_wp_ + b = f * a + 0.000000000000011_wp_ + a = f * b - a - 0.000000000000079_wp_ + b = f * a - b + 0.000000000000581_wp_ + a = f * b - a - 0.000000000004580_wp_ + b = f * a - b + 0.000000000039044_wp_ + a = f * b - a - 0.000000000364547_wp_ + b = f * a - b + 0.000000003792996_wp_ + a = f * b - a - 0.000000045047338_wp_ + b = f * a - b + 0.000000632575109_wp_ + a = f * b - a - 0.000011106685197_wp_ + b = f * a - b + 0.000269532612763_wp_ + a = f * b - a - 0.011310504646928_wp_ + a = f * a - b + 1.976816348461652_wp_ + besik=0.626657068657750_wp_*(a-b)/sqrt(x) + if(e) return + z=besik + besik=0.0_wp_ + if(x < 180.0_wp_) besik=exp(-x)*z + return +! + entry ebesk1(x) +! + e=.true. + go to 12 +! + entry besk1(x) +! + e=.false. + 12 if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(x < 5.0_wp_) go to 7 + f=20.0_wp_/x-2.0_wp_ + a = + 0.000000000000002_wp_ + b = f * a - 0.000000000000013_wp_ + a = f * b - a + 0.000000000000089_wp_ + b = f * a - b - 0.000000000000663_wp_ + a = f * b - a + 0.000000000005288_wp_ + b = f * a - b - 0.000000000045757_wp_ + a = f * b - a + 0.000000000435417_wp_ + b = f * a - b - 0.000000004645555_wp_ + a = f * b - a + 0.000000057132218_wp_ + b = f * a - b - 0.000000845172048_wp_ + a = f * b - a + 0.000016185063810_wp_ + b = f * a - b - 0.000468475028167_wp_ + a = f * b - a + 0.035465291243331_wp_ + a = f * a - b + 2.071901717544716_wp_ + besik=0.626657068657750_wp_*(a-b)/sqrt(x) + if(e) return + z=besik + besik=0.0_wp_ + if(x < 180.0_wp_) besik=exp(-x)*z + return + 9 besik=0.0_wp_ + write(nout,"(1x,'besik ... non-positive argument x = ',e15.4)") x + end function besik +! +! routines for conical function: end +! +end module conical \ No newline at end of file diff --git a/src/dispersion.f90 b/src/dispersion.f90 index 2dd5392..233fc6a 100644 --- a/src/dispersion.f90 +++ b/src/dispersion.f90 @@ -1,7 +1,6 @@ module dispersion ! use const_and_precisions, only : wp_,zero,one,im,czero,cunit,pi,sqrt_pi - use eierf, only : calcei3 implicit none ! local constants integer, parameter :: npts=500 @@ -255,6 +254,7 @@ subroutine diel_tens_fr(xg,yg,mu,npl,e330,cr,ci,epsl,lrm,fast) ! Fully relativistic case computation of dielectric tensor elements ! up to third order in Larmor radius for hermitian part ! + use math, only : fact implicit none ! arguments integer :: lrm,fast @@ -360,6 +360,7 @@ end subroutine diel_tens_fr ! ! subroutine hermitian(rr,yg,mu,npl,cr,fast,lrm) + use eierf, only : calcei3 implicit none ! arguments integer :: lrm,fast @@ -572,6 +573,7 @@ end subroutine hermitian ! ! subroutine hermitian_2(rr,yg,mu,npl,cr,fast,lrm) + use quadpack, only : dqagsmv !dqagimv implicit none ! local constants integer,parameter :: lw=5000,liw=lw/4,npar=7 @@ -621,9 +623,9 @@ subroutine hermitian_2(rr,yg,mu,npl,cr,fast,lrm) if(n.eq.0.and.m.eq.0) ihmin=2 do ih=ihmin,2 apar(7) = real(ih,wp_) -! call dqagi(fhermit,bound,2,epsa,epsr,resfh, - call dqagsmv(fhermit,-tmax,tmax,apar,npar,epsa, & - epsr,resfh,epp,neval,ier,liw,lw,last,iw,w) +! call dqagimv(fhermit,bound,2,apar,npar,epsa,epsr,resfh, + call dqagsmv(fhermit,-tmax,tmax,apar,npar,epsa,epsr,resfh, & + epp,neval,ier,liw,lw,last,iw,w) rr(n,ih,m) = resfh end do end do @@ -719,6 +721,7 @@ end subroutine hermitian_2 ! ! function fhermit(t,apar,npar) + use eierf, only : calcei3 implicit none ! arguments integer, intent(in) :: npar @@ -771,6 +774,7 @@ end function fhermit ! ! subroutine antihermitian(ri,yg,mu,npl,ci,lrm) + use math, only : fact implicit none ! local constants integer, parameter :: lmx=20,nmx=lmx+2 @@ -866,6 +870,7 @@ end subroutine antihermitian ! ! subroutine ssbi(zz,n,l,fsbi) + use math, only : gamm implicit none ! local constants integer, parameter :: lmx=20,nmx=lmx+2 @@ -876,7 +881,7 @@ subroutine ssbi(zz,n,l,fsbi) real(wp_), dimension(nmx) :: fsbi ! local variables integer :: k,m,mm - real(wp_) :: c0,c1,sbi,gamm + real(wp_) :: c0,c1,sbi ! do m=n,l+2 c0=one/gamm(dble(m)+1.5_wp_) @@ -909,29 +914,11 @@ end subroutine expinit ! ! ! -function fact(k) - implicit none -! arguments - real(wp_) :: fact -! local variables - integer :: i,k -! - fact=0.0_wp_ - if(k.lt.0) return - fact=1.0_wp_ - if(k.eq.0) return - do i=1,k - fact=fact*i - end do -! -end function fact -! -! -! subroutine diel_tens_wr(xg,yg,mu,npl,e330,epsl,lrm) ! Weakly relativistic dielectric tensor computation of dielectric ! tensor elements (Krivenki and Orefice, JPP 30,125 - 1983) ! + use math, only : fact implicit none ! arguments integer :: lrm @@ -939,7 +926,7 @@ subroutine diel_tens_wr(xg,yg,mu,npl,e330,epsl,lrm) complex(wp_) :: e330,epsl(3,3,lrm) ! local variables integer :: l,lm,is,k - real(wp_) :: npl2,fcl,w,asl,bsl,fact + real(wp_) :: npl2,fcl,w,asl,bsl complex(wp_) :: ca11,ca12,ca13,ca22,ca23,ca33,cq0p,cq0m,cq1p,cq1m,cq2p complex(wp_), dimension(0:lrm,0:2) :: cefp,cefm ! @@ -996,7 +983,7 @@ subroutine diel_tens_wr(xg,yg,mu,npl,e330,epsl,lrm) epsl(3,2,l) = - epsl(2,3,l) end do ! -end +end subroutine diel_tens_wr ! ! ! @@ -1144,7 +1131,202 @@ subroutine fsup(cefp,cefm,lrm,yg,npl,mu) ! end do ! -end +end subroutine fsup + ! +! PLASMA DISPERSION FUNCTION Z of complex argument +! Z(z) = i sqrt(pi) w(z) +! Function w(z) from: +! algorithm 680, collected algorithms from acm. +! this work published in transactions on mathematical software, +! vol. 16, no. 1, pp. 47. +! + subroutine zetac (xi, yi, zr, zi, iflag) +! +! given a complex number z = (xi,yi), this subroutine computes +! the value of the faddeeva-function w(z) = exp(-z**2)*erfc(-i*z), +! where erfc is the complex complementary error-function and i +! means sqrt(-1). +! the accuracy of the algorithm for z in the 1st and 2nd quadrant +! is 14 significant digits; in the 3rd and 4th it is 13 significant +! digits outside a circular region with radius 0.126 around a zero +! of the function. +! all real variables in the program are real(8). +! +! +! the code contains a few compiler-dependent parameters : +! rmaxreal = the maximum value of rmaxreal equals the root of +! rmax = the largest number which can still be +! implemented on the computer in real(8) +! floating-point arithmetic +! rmaxexp = ln(rmax) - ln(2) +! rmaxgoni = the largest possible argument of a real(8) +! goniometric function (cos, sin, ...) +! the reason why these parameters are needed as they are defined will +! be explained in the code by means of comments +! +! +! parameter list +! xi = real part of z +! yi = imaginary part of z +! u = real part of w(z) +! v = imaginary part of w(z) +! iflag = an error flag indicating whether overflow will +! occur or not; type integer; +! the values of this variable have the following +! meaning : +! iflag=0 : no error condition +! iflag=1 : overflow will occur, the routine +! becomes inactive +! xi, yi are the input-parameters +! u, v, iflag are the output-parameters +! +! furthermore the parameter factor equals 2/sqrt(pi) +! +! the routine is not underflow-protected but any variable can be +! put to 0 upon underflow; +! +! reference - gpm poppe, cmj wijers; more efficient computation of +! the complex error-function, acm trans. math. software. +! + implicit none + real(wp_), intent(in) :: xi, yi + real(wp_), intent(out) :: zr, zi + integer, intent(out) :: iflag + real(wp_) :: xabs,yabs,x,y,qrho,xabsq,xquad,yquad,xsum,ysum,xaux,daux, & + u,u1,u2,v,v1,v2,h,h2,qlambda,c,rx,ry,sx,sy,tx,ty,w1 + integer :: i,j,n,nu,kapn,np1 + real(wp_), parameter :: factor = 1.12837916709551257388_wp_, & + rpi = 2.0_wp_/factor, & + rmaxreal = 0.5e+154_wp_, & + rmaxexp = 708.503061461606_wp_, & + rmaxgoni = 3.53711887601422e+15_wp_ + iflag=0 + xabs = abs(xi) + yabs = abs(yi) + x = xabs/6.3_wp_ + y = yabs/4.4_wp_ +! +! the following if-statement protects +! qrho = (x**2 + y**2) against overflow +! + if ((xabs>rmaxreal).or.(yabs>rmaxreal)) then + iflag=1 + return + end if + qrho = x**2 + y**2 + xabsq = xabs**2 + xquad = xabsq - yabs**2 + yquad = 2*xabs*yabs + if (qrho<0.085264_wp_) then +! +! if (qrho<0.085264_wp_) then the faddeeva-function is evaluated +! using a power-series (abramowitz/stegun, equation (7.1.5), p.297) +! n is the minimum number of terms needed to obtain the required +! accuracy +! + qrho = (1-0.85_wp_*y)*sqrt(qrho) + n = idnint(6 + 72*qrho) + j = 2*n+1 + xsum = 1.0_wp_/j + ysum = 0.0_wp_ + do i=n, 1, -1 + j = j - 2 + xaux = (xsum*xquad - ysum*yquad)/i + ysum = (xsum*yquad + ysum*xquad)/i + xsum = xaux + 1.0_wp_/j + end do + u1 = -factor*(xsum*yabs + ysum*xabs) + 1.0_wp_ + v1 = factor*(xsum*xabs - ysum*yabs) + daux = exp(-xquad) + u2 = daux*cos(yquad) + v2 = -daux*sin(yquad) + u = u1*u2 - v1*v2 + v = u1*v2 + v1*u2 + else +! +! if (qrho>1.o) then w(z) is evaluated using the laplace +! continued fraction +! nu is the minimum number of terms needed to obtain the required +! accuracy +! +! if ((qrho>0.085264_wp_).and.(qrho<1.0)) then w(z) is evaluated +! by a truncated taylor expansion, where the laplace continued fraction +! is used to calculate the derivatives of w(z) +! kapn is the minimum number of terms in the taylor expansion needed +! to obtain the required accuracy +! nu is the minimum number of terms of the continued fraction needed +! to calculate the derivatives with the required accuracy +! + if (qrho>1.0_wp_) then + h = 0.0_wp_ + kapn = 0 + qrho = sqrt(qrho) + nu = idint(3 + (1442/(26*qrho+77))) + else + qrho = (1-y)*sqrt(1-qrho) + h = 1.88_wp_*qrho + h2 = 2*h + kapn = idnint(7 + 34*qrho) + nu = idnint(16 + 26*qrho) + endif + if (h>0.0_wp_) qlambda = h2**kapn + rx = 0.0_wp_ + ry = 0.0_wp_ + sx = 0.0_wp_ + sy = 0.0_wp_ + do n=nu, 0, -1 + np1 = n + 1 + tx = yabs + h + np1*rx + ty = xabs - np1*ry + c = 0.5_wp_/(tx**2 + ty**2) + rx = c*tx + ry = c*ty + if ((h>0.0_wp_).and.(n<=kapn)) then + tx = qlambda + sx + sx = rx*tx - ry*sy + sy = ry*tx + rx*sy + qlambda = qlambda/h2 + endif + end do + if (h==0.0_wp_) then + u = factor*rx + v = factor*ry + else + u = factor*sx + v = factor*sy + end if + if (yabs==0.0_wp_) u = exp(-xabs**2) + end if +! +! evaluation of w(z) in the other quadrants +! + if (yi<0.0_wp_) then + if (qrho<0.085264_wp_) then + u2 = 2*u2 + v2 = 2*v2 + else + xquad = -xquad +! +! the following if-statement protects 2*exp(-z**2) +! against overflow +! + if ((yquad>rmaxgoni).or. (xquad>rmaxexp)) then + iflag=1 + return + end if + w1 = 2.0_wp_*exp(xquad) + u2 = w1*cos(yquad) + v2 = -w1*sin(yquad) + end if + u = u2 - u + v = v2 - v + if (xi>0.0_wp_) v = -v + else + if (xi<0.0_wp_) v = -v + end if + zr = -v*rpi + zi = u*rpi + end subroutine zetac ! end module dispersion \ No newline at end of file diff --git a/src/dqagmv.f b/src/dqagmv.f deleted file mode 100644 index bd3cfba..0000000 --- a/src/dqagmv.f +++ /dev/null @@ -1,1696 +0,0 @@ -c -c -c Integration routine dqags.f from quadpack and dependencies: BEGIN -c Modified version for functions f(x,yi) with more than one variable -c -c - subroutine dqagsmv(f,a,b,apar,np,epsabs,epsrel,result,abserr, - * neval,ier,limit,lenw,last,iwork,work) -c***begin prologue dqagsmv -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a1 -c***keywords automatic integrator, general-purpose, -c (end-point) singularities, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & prog. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)). -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x,apar,np). the actual name for f needs -c to be declared e x t e r n a l in the driver -c program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c apar - array of parameters of the integrand function f -c -c np - number of parameters. size of apar -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more sub- -c divisions by increasing the value of limit -c (and taking the according dimension -c adjustments into account. however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is detec- -c ted, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour -c occurs at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. it is presumed that -c the requested tolerance cannot be -c achieved, and that the returned result is -c the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28) -c or limit.lt.1 or lenw.lt.limit*4. -c result, abserr, neval, last are set to -c zero.except when limit or lenw is invalid, -c iwork(1), work(limit*2+1) and -c work(limit*3+1) are set to zero, work(1) -c is set to a and work(limit+1) to b. -c -c dimensioning parameters -c limit - integer -c dimensioning parameter for iwork -c limit determines the maximum number of subintervals -c in the partition of the given integration interval -c (a,b), limit.ge.1. -c if limit.lt.1, the routine will end with ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least limit*4. -c if lenw.lt.limit*4, the routine will end -c with ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdivision process, detemines the -c number of significant elements actually in the work -c arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least limit, the first k -c elements of which contain pointers -c to the error estimates over the subintervals -c such that work(limit*3+iwork(1)),... , -c work(limit*3+iwork(k)) form a decreasing -c sequence, with k = last if last.le.(limit/2+2), -c and k = limit+1-last otherwise -c -c work - double precision -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left -c end-points of the subintervals in the -c partition of (a,b), -c work(limit+1), ..., work(limit+last) contain -c the right end-points, -c work(limit*2+1), ..., work(limit*2+last) contain -c the integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3+last) -c contain the error estimates. -c -c***references (none) -c***routines called dqagsemv,xerror -c***end prologue dqagsmv -c -c - double precision a,abserr,b,epsabs,epsrel,f,result,work,apar - integer ier,iwork,last,lenw,limit,lvl,l1,l2,l3,neval,np -c - dimension iwork(limit),work(lenw),apar(np) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement dqags - ier = 6 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - if(limit.lt.1.or.lenw.lt.limit*4) go to 10 -c -c prepare call for dqagse. -c - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 -c - call dqagsemv(f,a,b,apar,np,epsabs,epsrel,limit,result,abserr, - * neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 - if(ier.ne.0) print*,'habnormal return from dqags',ier,lvl - return - end -c - subroutine dqagsemv(f,a,b,apar,np,epsabs,epsrel,limit,result, - * abserr,neval,ier,alist,blist,rlist,elist,iord,last) -c***begin prologue dqagsemv -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a1 -c***keywords automatic integrator, general-purpose, -c (end point) singularities, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)). -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x,apar,np). the actual name for f needs -c to be declared e x t e r n a l in the driver -c program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c apar - array of parameters of the integrand function f -c -c np - number of parameters. size of apar -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c limit - integer -c gives an upperbound on the number of subintervals -c in the partition of (a,b) -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more sub- -c divisions by increasing the value of limit -c (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is detec- -c ted, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour -c occurs at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is presumed that the requested -c tolerance cannot be achieved, and that the -c returned result is the best which can be -c obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28). -c result, abserr, neval, last, rlist(1), -c iord(1) and elist(1) are set to zero. -c alist(1) and blist(1) are set to a and b -c respectively. -c -c alist - double precision -c vector of dimension at least limit, the first -c last elements of which are the left end points -c of the subintervals in the partition of the -c given integration range (a,b) -c -c blist - double precision -c vector of dimension at least limit, the first -c last elements of which are the right end points -c of the subintervals in the partition of the given -c integration range (a,b) -c -c rlist - double precision -c vector of dimension at least limit, the first -c last elements of which are the integral -c approximations on the subintervals -c -c elist - double precision -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c iord - integer -c vector of dimension at least limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., elist(iord(k)) -c form a decreasing sequence, with k = last -c if last.le.(limit/2+2), and k = limit+1-last -c otherwise -c -c last - integer -c number of subintervals actually produced in the -c subdivision process -c -c***references (none) -c***routines called d1mach,dqelg,dqk21mv,dqpsrt -c***end prologue dqagsemv -c - double precision a,abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,d1mach,dmax1, - * dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd,errmax, - * error1,error2,erro12,errsum,ertest,f,oflow,resabs,reseps,result, - * res3la,rlist,rlist2,small,uflow,apar - integer id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, - * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2,np - logical extrap,noext -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * res3la(3),rlist(limit),rlist2(52),apar(np) -c - external f -c -c the dimension of rlist2 is determined by the value of -c limexp in subroutine dqelg (rlist2 should be of dimension -c (limexp+2) at least). -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c rlist2 - array of dimension at least limexp+2 containing -c the part of the epsilon table which is still -c needed for further computations -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest error -c estimate -c errmax - elist(maxerr) -c erlast - error on the interval currently subdivided -c (before that subdivision has taken place) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left interval -c *****2 - variable for the right interval -c last - index for subdivision -c nres - number of calls to the extrapolation routine -c numrl2 - number of elements currently in rlist2. if an -c appropriate approximation to the compounded -c integral has been obtained it is put in -c rlist2(numrl2) after numrl2 has been increased -c by one. -c small - length of the smallest interval considered up -c to now, multiplied by 1.5 -c erlarg - sum of the errors over the intervals larger -c than the smallest interval considered up to now -c extrap - logical variable denoting that the routine is -c attempting to perform extrapolation i.e. before -c subdividing the smallest interval we try to -c decrease the value of erlarg. -c noext - logical variable denoting that extrapolation -c is no longer allowed (true value) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c oflow is the largest positive magnitude. -c -c***first executable statement dqagse - epmach = d1mach(4) -c -c test on validity of parameters -c ------------------------------ - ier = 0 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - alist(1) = a - blist(1) = b - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - if(epsabs.le.0.0d+00.and.epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) - * ier = 6 - if(ier.eq.6) go to 999 -c -c first approximation to the integral -c ----------------------------------- -c - uflow = d1mach(1) - oflow = d1mach(2) - ierro = 0 - call dqk21mv(f,a,b,apar,np,result,abserr,defabs,resabs) -c -c test on accuracy. -c - dres = dabs(result) - errbnd = dmax1(epsabs,epsrel*dres) - last = 1 - rlist(1) = result - elist(1) = abserr - iord(1) = 1 - if(abserr.le.1.0d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 - if(limit.eq.1) ier = 1 - if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. - * abserr.eq.0.0d+00) go to 140 -c -c initialization -c -------------- -c - rlist2(1) = result - errmax = abserr - maxerr = 1 - area = result - errsum = abserr - abserr = oflow - nrmax = 1 - nres = 0 - numrl2 = 2 - ktmin = 0 - extrap = .false. - noext = .false. - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ksgn = -1 - if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 90 last = 2,limit -c -c bisect the subinterval with the nrmax-th largest error -c estimate. -c - a1 = alist(maxerr) - b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - erlast = errmax - call dqk21mv(f,a1,b1,apar,np,area1,error1,resabs,defab1) - call dqk21mv(f,a2,b2,apar,np,area2,error2,resabs,defab2) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2) go to 15 - if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) - * .or.erro12.lt.0.99d+00*errmax) go to 10 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 15 rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = dmax1(epsabs,epsrel*dabs(area)) -c -c test for roundoff error and eventually set error flag. -c - if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 - if(iroff2.ge.5) ierro = 3 -c -c set error flag in the case that the number of subintervals -c equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at a point of the integration range. -c - if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* - * (dabs(a2)+0.1d+04*uflow)) ier = 4 -c -c append the newly-created intervals to the list. -c - if(error2.gt.error1) go to 20 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 30 - 20 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine dqpsrt to maintain the descending ordering -c in the list of error estimates and select the subinterval -c with nrmax-th largest error estimate (to be bisected next). -c - 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) -c ***jump out of do-loop - if(errsum.le.errbnd) go to 115 -c ***jump out of do-loop - if(ier.ne.0) go to 100 - if(last.eq.2) go to 80 - if(noext) go to 90 - erlarg = erlarg-erlast - if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12 - if(extrap) go to 40 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - extrap = .true. - nrmax = 2 - 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors over the -c larger intervals (erlarg) and perform extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 50 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) -c ***jump out of do-loop - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - nrmax = nrmax+1 - 50 continue -c -c perform extrapolation. -c - 60 numrl2 = numrl2+1 - rlist2(numrl2) = area - call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) - ktmin = ktmin+1 - if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5 - if(abseps.ge.abserr) go to 70 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = dmax1(epsabs,epsrel*dabs(reseps)) -c ***jump out of do-loop - if(abserr.le.ertest) go to 100 -c -c prepare bisection of the smallest interval. -c - 70 if(numrl2.eq.1) noext = .true. - if(ier.eq.5) go to 100 - maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - small = small*0.5d+00 - erlarg = errsum - go to 90 - 80 small = dabs(b-a)*0.375d+00 - erlarg = errsum - ertest = errbnd - rlist2(2) = area - 90 continue -c -c set final result and error estimate. -c ------------------------------------ -c - 100 if(abserr.eq.oflow) go to 115 - if(ier+ierro.eq.0) go to 110 - if(ierro.eq.3) abserr = abserr+correc - if(ier.eq.0) ier = 3 - if(result.ne.0.0d+00.and.area.ne.0.0d+00) go to 105 - if(abserr.gt.errsum) go to 115 - if(area.eq.0.0d+00) go to 130 - go to 110 - 105 if(abserr/dabs(result).gt.errsum/dabs(area)) go to 115 -c -c test on divergence. -c - 110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. - * defabs*0.1d-01) go to 130 - if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03 - * .or.errsum.gt.dabs(area)) ier = 6 - go to 130 -c -c compute global integral sum. -c - 115 result = 0.0d+00 - do 120 k = 1,last - result = result+rlist(k) - 120 continue - abserr = errsum - 130 if(ier.gt.2) ier = ier-1 - 140 neval = 42*last-21 - 999 return - end -c - subroutine dqk21mv(f,a,b,apar,np,result,abserr,resabs,resasc) -c***begin prologue dqk21mv -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 21-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b), with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x,apar,np). the actual name for f -c needs to be declared e x t e r n a l in the -c driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c apar - array of parameters of the integrand function f -c -c np - number of parameters. size of apar -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 21-point -c kronrod rule (resk) obtained by optimal addition -c of abscissae to the 10-point gauss rule (resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should not exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk21mv -c - double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, - * resg,resk,reskh,result,uflow,wg,wgk,xgk,apar - integer j,jtw,jtwm1,np - external f -c - dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11),apar(np) -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 21-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 10-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 10-point gauss rule -c -c wgk - weights of the 21-point kronrod rule -c -c wg - weights of the 10-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.0666713443 0868813759 3568809893 332 d0 / - data wg ( 2) / 0.1494513491 5058059314 5776339657 697 d0 / - data wg ( 3) / 0.2190863625 1598204399 5534934228 163 d0 / - data wg ( 4) / 0.2692667193 0999635509 1226921569 469 d0 / - data wg ( 5) / 0.2955242247 1475287017 3892994651 338 d0 / -c - data xgk ( 1) / 0.9956571630 2580808073 5527280689 003 d0 / - data xgk ( 2) / 0.9739065285 1717172007 7964012084 452 d0 / - data xgk ( 3) / 0.9301574913 5570822600 1207180059 508 d0 / - data xgk ( 4) / 0.8650633666 8898451073 2096688423 493 d0 / - data xgk ( 5) / 0.7808177265 8641689706 3717578345 042 d0 / - data xgk ( 6) / 0.6794095682 9902440623 4327365114 874 d0 / - data xgk ( 7) / 0.5627571346 6860468333 9000099272 694 d0 / - data xgk ( 8) / 0.4333953941 2924719079 9265943165 784 d0 / - data xgk ( 9) / 0.2943928627 0146019813 1126603103 866 d0 / - data xgk ( 10) / 0.1488743389 8163121088 4826001129 720 d0 / - data xgk ( 11) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0116946388 6737187427 8064396062 192 d0 / - data wgk ( 2) / 0.0325581623 0796472747 8818972459 390 d0 / - data wgk ( 3) / 0.0547558965 7435199603 1381300244 580 d0 / - data wgk ( 4) / 0.0750396748 1091995276 7043140916 190 d0 / - data wgk ( 5) / 0.0931254545 8369760553 5065465083 366 d0 / - data wgk ( 6) / 0.1093871588 0229764189 9210590325 805 d0 / - data wgk ( 7) / 0.1234919762 6206585107 7958109831 074 d0 / - data wgk ( 8) / 0.1347092173 1147332592 8054001771 707 d0 / - data wgk ( 9) / 0.1427759385 7706008079 7094273138 717 d0 / - data wgk ( 10) / 0.1477391049 0133849137 4841515972 068 d0 / - data wgk ( 11) / 0.1494455540 0291690566 4936468389 821 d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 10-point gauss formula -c resk - result of the 21-point kronrod formula -c reskh - approximation to the mean value of f over (a,b), -c i.e. to i/(b-a) -c -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk21 - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 21-point kronrod approximation to -c the integral, and estimate the absolute error. -c - resg = 0.0d+00 - fc = f(centr,apar,np) - resk = wgk(11)*fc - resabs = dabs(resk) - do 10 j=1,5 - jtw = 2*j - absc = hlgth*xgk(jtw) - fval1 = f(centr-absc,apar,np) - fval2 = f(centr+absc,apar,np) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j = 1,5 - jtwm1 = 2*j-1 - absc = hlgth*xgk(jtwm1) - fval1 = f(centr-absc,apar,np) - fval2 = f(centr+absc,apar,np) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(11)*dabs(fc-reskh) - do 20 j=1,10 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end -c - subroutine dqagimv(f,bound,inf,apar,np,epsabs,epsrel,result, - * abserr,neval,ier,limit,lenw,last,iwork,work) -c***begin prologue dqagimv -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a1,h2a4a1 -c***keywords automatic integrator, infinite intervals, -c general-purpose, transformation, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. -k.u.leuven -c***purpose the routine calculates an approximation result to a given -c integral i = integral of f over (bound,+infinity) -c or i = integral of f over (-infinity,bound) -c or i = integral of f over (-infinity,+infinity) -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)). -c***description -c -c integration over infinite intervals -c standard fortran subroutine -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x,apar,np). the actual name for f needs -c to be declared e x t e r n a l in the driver -c program. -c -c bound - double precision -c finite bound of integration range -c (has no meaning if interval is doubly-infinite) -c -c inf - integer -c indicating the kind of integration range involved -c inf = 1 corresponds to (bound,+infinity), -c inf = -1 to (-infinity,bound), -c inf = 2 to (-infinity,+infinity). -c -c apar - array of parameters of the integrand function f -c -c np - number of parameters. size of apar -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c - ier.gt.0 abnormal termination of the routine. the -c estimates for result and error are less -c reliable. it is assumed that the requested -c accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is assumed that the requested tolerance -c cannot be achieved, and that the returned -c result is the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c or limit.lt.1 or leniw.lt.limit*4. -c result, abserr, neval, last are set to -c zero. exept when limit or leniw is -c invalid, iwork(1), work(limit*2+1) and -c work(limit*3+1) are set to zero, work(1) -c is set to a and work(limit+1) to b. -c -c dimensioning parameters -c limit - integer -c dimensioning parameter for iwork -c limit determines the maximum number of subintervals -c in the partition of the given integration interval -c (a,b), limit.ge.1. -c if limit.lt.1, the routine will end with ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least limit*4. -c if lenw.lt.limit*4, the routine will end -c with ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdivision process, which -c determines the number of significant elements -c actually in the work arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least limit, the first -c k elements of which contain pointers -c to the error estimates over the subintervals, -c such that work(limit*3+iwork(1)),... , -c work(limit*3+iwork(k)) form a decreasing -c sequence, with k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c work - double precision -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left -c end points of the subintervals in the -c partition of (a,b), -c work(limit+1), ..., work(limit+last) contain -c the right end points, -c work(limit*2+1), ...,work(limit*2+last) contain the -c integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3) -c contain the error estimates. -c***references (none) -c***routines called dqagiemv,xerror -c***end prologue dqagimv -c - double precision abserr,bound,epsabs,epsrel,f,result,work,apar - integer ier,inf,iwork,last,lenw,limit,lvl,l1,l2,l3,neval,np -c - dimension iwork(limit),work(lenw),apar(np) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement dqagi - ier = 6 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - if(limit.lt.1.or.lenw.lt.limit*4) go to 10 -c -c prepare call for dqagie. -c - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 -c - call dqagiemv(f,bound,inf,apar,np,epsabs,epsrel,limit,result, - * abserr,neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 - if(ier.ne.0) print*,'habnormal return from dqagi' - return - end -c - subroutine dqagiemv(f,bound,inf,apar,np,epsabs,epsrel,limit, - * result,abserr,neval,ier,alist,blist,rlist,elist,iord,last) -c***begin prologue dqagiemv -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a1,h2a4a1 -c***keywords automatic integrator, infinite intervals, -c general-purpose, transformation, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math & progr. div - k.u.leuven -c de doncker,elise,appl. math & progr. div - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c integral i = integral of f over (bound,+infinity) -c or i = integral of f over (-infinity,bound) -c or i = integral of f over (-infinity,+infinity), -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)) -c***description -c -c integration over infinite intervals -c standard fortran subroutine -c -c f - double precision -c function subprogram defining the integrand -c function f(x,apar,np). the actual name for f needs -c to be declared e x t e r n a l in the driver -c program. -c -c bound - double precision -c finite bound of integration range -c (has no meaning if interval is doubly-infinite) -c -c inf - double precision -c indicating the kind of integration range involved -c inf = 1 corresponds to (bound,+infinity), -c inf = -1 to (-infinity,bound), -c inf = 2 to (-infinity,+infinity). -c -c apar - array of parameters of the integrand function f -c -c np - number of parameters. size of apar -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c limit - integer -c gives an upper bound on the number of subintervals -c in the partition of (a,b), limit.ge.1 -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c - ier.gt.0 abnormal termination of the routine. the -c estimates for result and error are less -c reliable. it is assumed that the requested -c accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however,if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. -c if the position of a local difficulty can -c be determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is assumed that the requested tolerance -c cannot be achieved, and that the returned -c result is the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c result, abserr, neval, last, rlist(1), -c elist(1) and iord(1) are set to zero. -c alist(1) and blist(1) are set to 0 -c and 1 respectively. -c -c alist - double precision -c vector of dimension at least limit, the first -c last elements of which are the left -c end points of the subintervals in the partition -c of the transformed integration range (0,1). -c -c blist - double precision -c vector of dimension at least limit, the first -c last elements of which are the right -c end points of the subintervals in the partition -c of the transformed integration range (0,1). -c -c rlist - double precision -c vector of dimension at least limit, the first -c last elements of which are the integral -c approximations on the subintervals -c -c elist - double precision -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c iord - integer -c vector of dimension limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., elist(iord(k)) -c form a decreasing sequence, with k = last -c if last.le.(limit/2+2), and k = limit+1-last -c otherwise -c -c last - integer -c number of subintervals actually produced -c in the subdivision process -c -c***references (none) -c***routines called d1mach,dqelg,dqk15imv,dqpsrt -c***end prologue dqagiemv - double precision abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,blist,boun,bound,b1,b2,correc,dabs,defabs,defab1,defab2, - * dmax1,dres,d1mach,elist,epmach,epsabs,epsrel,erlarg,erlast, - * errbnd,errmax,error1,error2,erro12,errsum,ertest,f,oflow,resabs, - * reseps,result,res3la,rlist,rlist2,small,uflow,apar - integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, - * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2,np - logical extrap,noext -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * res3la(3),rlist(limit),rlist2(52),apar(np) -c - external f -c -c the dimension of rlist2 is determined by the value of -c limexp in subroutine dqelg. -c -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c rlist2 - array of dimension at least (limexp+2), -c containing the part of the epsilon table -c wich is still needed for further computations -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest error -c estimate -c errmax - elist(maxerr) -c erlast - error on the interval currently subdivided -c (before that subdivision has taken place) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left subinterval -c *****2 - variable for the right subinterval -c last - index for subdivision -c nres - number of calls to the extrapolation routine -c numrl2 - number of elements currently in rlist2. if an -c appropriate approximation to the compounded -c integral has been obtained, it is put in -c rlist2(numrl2) after numrl2 has been increased -c by one. -c small - length of the smallest interval considered up -c to now, multiplied by 1.5 -c erlarg - sum of the errors over the intervals larger -c than the smallest interval considered up to now -c extrap - logical variable denoting that the routine -c is attempting to perform extrapolation. i.e. -c before subdividing the smallest interval we -c try to decrease the value of erlarg. -c noext - logical variable denoting that extrapolation -c is no longer allowed (true-value) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c oflow is the largest positive magnitude. -c -c***first executable statement dqagie - epmach = d1mach(4) -c -c test on validity of parameters -c ----------------------------- -c - ier = 0 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - alist(1) = 0.0d+00 - blist(1) = 0.1d+01 - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - iord(1) = 0 - if(epsabs.le.0.0d+00.and.epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) - * ier = 6 - if(ier.eq.6) go to 999 -c -c -c first approximation to the integral -c ----------------------------------- -c -c determine the interval to be mapped onto (0,1). -c if inf = 2 the integral is computed as i = i1+i2, where -c i1 = integral of f over (-infinity,0), -c i2 = integral of f over (0,+infinity). -c - boun = bound - if(inf.eq.2) boun = 0.0d+00 - call dqk15imv(f,boun,inf,0.0d+00,0.1d+01,apar,np,result,abserr, - * defabs,resabs) -c -c test on accuracy -c - last = 1 - rlist(1) = result - elist(1) = abserr - iord(1) = 1 - dres = dabs(result) - errbnd = dmax1(epsabs,epsrel*dres) - if(abserr.le.1.0d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 - if(limit.eq.1) ier = 1 - if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. - * abserr.eq.0.0d+00) go to 130 -c -c initialization -c -------------- -c - uflow = d1mach(1) - oflow = d1mach(2) - rlist2(1) = result - errmax = abserr - maxerr = 1 - area = result - errsum = abserr - abserr = oflow - nrmax = 1 - nres = 0 - ktmin = 0 - numrl2 = 2 - extrap = .false. - noext = .false. - ierro = 0 - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ksgn = -1 - if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 90 last = 2,limit -c -c bisect the subinterval with nrmax-th largest error estimate. -c - a1 = alist(maxerr) - b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - erlast = errmax - call dqk15imv(f,boun,inf,a1,b1,apar,np,area1,error1,resabs, - * defab1) - call dqk15imv(f,boun,inf,a2,b2,apar,np,area2,error2,resabs, - * defab2) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2)go to 15 - if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) - * .or.erro12.lt.0.99d+00*errmax) go to 10 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 15 rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = dmax1(epsabs,epsrel*dabs(area)) -c -c test for roundoff error and eventually set error flag. -c - if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 - if(iroff2.ge.5) ierro = 3 -c -c set error flag in the case that the number of -c subintervals equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at some points of the integration range. -c - if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* - * (dabs(a2)+0.1d+04*uflow)) ier = 4 -c -c append the newly-created intervals to the list. -c - if(error2.gt.error1) go to 20 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 30 - 20 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine dqpsrt to maintain the descending ordering -c in the list of error estimates and select the subinterval -c with nrmax-th largest error estimate (to be bisected next). -c - 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) - if(errsum.le.errbnd) go to 115 - if(ier.ne.0) go to 100 - if(last.eq.2) go to 80 - if(noext) go to 90 - erlarg = erlarg-erlast - if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12 - if(extrap) go to 40 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - extrap = .true. - nrmax = 2 - 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors over the -c larger intervals (erlarg) and perform extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 50 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - nrmax = nrmax+1 - 50 continue -c -c perform extrapolation. -c - 60 numrl2 = numrl2+1 - rlist2(numrl2) = area - call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) - ktmin = ktmin+1 - if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5 - if(abseps.ge.abserr) go to 70 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = dmax1(epsabs,epsrel*dabs(reseps)) - if(abserr.le.ertest) go to 100 -c -c prepare bisection of the smallest interval. -c - 70 if(numrl2.eq.1) noext = .true. - if(ier.eq.5) go to 100 - maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - small = small*0.5d+00 - erlarg = errsum - go to 90 - 80 small = 0.375d+00 - erlarg = errsum - ertest = errbnd - rlist2(2) = area - 90 continue -c -c set final result and error estimate. -c ------------------------------------ -c - 100 if(abserr.eq.oflow) go to 115 - if((ier+ierro).eq.0) go to 110 - if(ierro.eq.3) abserr = abserr+correc - if(ier.eq.0) ier = 3 - if(result.ne.0.0d+00.and.area.ne.0.0d+00)go to 105 - if(abserr.gt.errsum)go to 115 - if(area.eq.0.0d+00) go to 130 - go to 110 - 105 if(abserr/dabs(result).gt.errsum/dabs(area))go to 115 -c -c test on divergence -c - 110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. - * defabs*0.1d-01) go to 130 - if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03. - *or.errsum.gt.dabs(area)) ier = 6 - go to 130 -c -c compute global integral sum. -c - 115 result = 0.0d+00 - do 120 k = 1,last - result = result+rlist(k) - 120 continue - abserr = errsum - 130 neval = 30*last-15 - if(inf.eq.2) neval = 2*neval - if(ier.gt.2) ier=ier-1 - 999 return - end -c - subroutine dqk15imv(f,boun,inf,a,b,apar,np,result,abserr,resabs, - * resasc) -c***begin prologue dqk15imv -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a2,h2a4a2 -c***keywords 15-point transformed gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the original (infinite integration range is mapped -c onto the interval (0,1) and (a,b) is a part of (0,1). -c it is the purpose to compute -c i = integral of transformed integrand over (a,b), -c j = integral of abs(transformed integrand) over (a,b). -c***description -c -c integration rule -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c fuction subprogram defining the integrand -c function f(x,apar,np). the actual name for f -c needs to be declared e x t e r n a l in the -c calling program. -c -c boun - double precision -c finite bound of original integration -c range (set to zero if inf = +2) -c -c inf - integer -c if inf = -1, the original interval is -c (-infinity,bound), -c if inf = +1, the original interval is -c (bound,+infinity), -c if inf = +2, the original interval is -c (-infinity,+infinity) and -c the integral is computed as the sum of two -c integrals, one over (-infinity,0) and one over -c (0,+infinity). -c -c a - double precision -c lower limit for integration over subrange -c of (0,1) -c -c b - double precision -c upper limit for integration over subrange -c of (0,1) -c -c apar - array of parameters of the integrand function f -c -c np - number of parameters. size of apar -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 15-point -c kronrod rule(resk) obtained by optimal addition -c of abscissae to the 7-point gauss rule(resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of -c abs((transformed integrand)-i/(b-a)) over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk15imv -c - double precision a,absc,absc1,absc2,abserr,b,boun,centr,dabs,dinf, - * dmax1,dmin1,d1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth, - * resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2,uflow,wg,wgk, - * xgk,apar - integer inf,j,np - external f -c - dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8),apar(np) -c -c the abscissae and weights are supplied for the interval -c (-1,1). because of symmetry only the positive abscissae and -c their corresponding weights are given. -c -c xgk - abscissae of the 15-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 7-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 7-point gauss rule -c -c wgk - weights of the 15-point kronrod rule -c -c wg - weights of the 7-point gauss rule, corresponding -c to the abscissae xgk(2), xgk(4), ... -c wg(1), wg(3), ... are set to zero. -c - data wg(1) / 0.0d0 / - data wg(2) / 0.1294849661 6886969327 0611432679 082d0 / - data wg(3) / 0.0d0 / - data wg(4) / 0.2797053914 8927666790 1467771423 780d0 / - data wg(5) / 0.0d0 / - data wg(6) / 0.3818300505 0511894495 0369775488 975d0 / - data wg(7) / 0.0d0 / - data wg(8) / 0.4179591836 7346938775 5102040816 327d0 / -c - data xgk(1) / 0.9914553711 2081263920 6854697526 329d0 / - data xgk(2) / 0.9491079123 4275852452 6189684047 851d0 / - data xgk(3) / 0.8648644233 5976907278 9712788640 926d0 / - data xgk(4) / 0.7415311855 9939443986 3864773280 788d0 / - data xgk(5) / 0.5860872354 6769113029 4144838258 730d0 / - data xgk(6) / 0.4058451513 7739716690 6606412076 961d0 / - data xgk(7) / 0.2077849550 0789846760 0689403773 245d0 / - data xgk(8) / 0.0000000000 0000000000 0000000000 000d0 / -c - data wgk(1) / 0.0229353220 1052922496 3732008058 970d0 / - data wgk(2) / 0.0630920926 2997855329 0700663189 204d0 / - data wgk(3) / 0.1047900103 2225018383 9876322541 518d0 / - data wgk(4) / 0.1406532597 1552591874 5189590510 238d0 / - data wgk(5) / 0.1690047266 3926790282 6583426598 550d0 / - data wgk(6) / 0.1903505780 6478540991 3256402421 014d0 / - data wgk(7) / 0.2044329400 7529889241 4161999234 649d0 / - data wgk(8) / 0.2094821410 8472782801 2999174891 714d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc* - abscissa -c tabsc* - transformed abscissa -c fval* - function value -c resg - result of the 7-point gauss formula -c resk - result of the 15-point kronrod formula -c reskh - approximation to the mean value of the transformed -c integrand over (a,b), i.e. to i/(b-a) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk15imv - epmach = d1mach(4) - uflow = d1mach(1) - dinf = min0(1,inf) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - tabsc1 = boun+dinf*(0.1d+01-centr)/centr - fval1 = f(tabsc1,apar,np) - if(inf.eq.2) fval1 = fval1+f(-tabsc1,apar,np) - fc = (fval1/centr)/centr -c -c compute the 15-point kronrod approximation to -c the integral, and estimate the error. -c - resg = wg(8)*fc - resk = wgk(8)*fc - resabs = dabs(resk) - do 10 j=1,7 - absc = hlgth*xgk(j) - absc1 = centr-absc - absc2 = centr+absc - tabsc1 = boun+dinf*(0.1d+01-absc1)/absc1 - tabsc2 = boun+dinf*(0.1d+01-absc2)/absc2 - fval1 = f(tabsc1,apar,np) - fval2 = f(tabsc2,apar,np) - if(inf.eq.2) fval1 = fval1+f(-tabsc1,apar,np) - if(inf.eq.2) fval2 = fval2+f(-tabsc2,apar,np) - fval1 = (fval1/absc1)/absc1 - fval2 = (fval2/absc2)/absc2 - fv1(j) = fval1 - fv2(j) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(j)*fsum - resabs = resabs+wgk(j)*(dabs(fval1)+dabs(fval2)) - 10 continue - reskh = resk*0.5d+00 - resasc = wgk(8)*dabs(fc-reskh) - do 20 j=1,7 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resasc = resasc*hlgth - resabs = resabs*hlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.d0) abserr = resasc* - * dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end diff --git a/src/gray.f b/src/gray.f index 5c9d3bc..38487bc 100644 --- a/src/gray.f +++ b/src/gray.f @@ -1054,6 +1054,7 @@ c c subroutine read_beams use graydata_flags, only : filenmbm, ibeam + use utils, only : locate implicit real*8(a-h,o-z) parameter(nstrmx=50) @@ -1165,6 +1166,7 @@ c c subroutine equidata use const_and_precisions, only : pi + use utils, only : vmaxmini use graydata_flags, only : ipsinorm,sspl,ixp,icocos,neqdsk use graydata_par, only : sgnbphi,sgniphi,factb use interp_eqprof, only : nsrt,nszt,nsft,rlim,zlim,nlim,nr,nz, @@ -1613,6 +1615,8 @@ c c c subroutine points_ox(rz,zz,rf,zf,psinvf,info) + use const_and_precisions, only : comp_eps + use minpack, only : hybrj1 implicit real*8 (a-h,o-z) parameter(n=2,ldfjac=n,lwa=(n*(n+13))/2) dimension xvec(n),fvec(n),fjac(ldfjac,n),wa(lwa) @@ -1620,7 +1624,7 @@ c common/psival/psinv xvec(1)=rz xvec(2)=zz - tol = sqrt(dpmpar(1)) + tol = sqrt(comp_eps) call hybrj1(fcnox,n,xvec,fvec,fjac,ldfjac,tol,info,wa,lwa) if(info.gt.1) then print'(a,i2,a,2f8.4)',' info subr points_ox =',info, @@ -1664,6 +1668,8 @@ c c c subroutine points_tgo(rz,zz,rf,zf,psin,info) + use const_and_precisions, only : comp_eps + use minpack, only : hybrj1 implicit real*8 (a-h,o-z) parameter(n=2,ldfjac=n,lwa=(n*(n+13))/2) dimension xvec(n),fvec(n),fjac(ldfjac,n),wa(lwa) @@ -1672,7 +1678,7 @@ c h=psin xvec(1)=rz xvec(2)=zz - tol = sqrt(dpmpar(1)) + tol = sqrt(comp_eps) call hybrj1(fcntgo,n,xvec,fvec,fjac,ldfjac,tol,info,wa,lwa) if(info.gt.1) then end if @@ -1717,6 +1723,7 @@ c c subroutine print_prof use interp_eqprof, only : psinr,qpsi,nr + use utils, only : intlin implicit real*8 (a-h,o-z) parameter(eps=1.d-4) @@ -1782,6 +1789,7 @@ c subroutine surfq(qval,psival) use magsurf_data, only : npoints use interp_eqprof, only : nr,psinr,qpsi + use utils, only : locate, intlin implicit real*8 (a-h,o-z) dimension rcn(npoints),zcn(npoints) @@ -4469,6 +4477,7 @@ c use graydata_flags, only : iprof use graydata_anequil, only : te0,dte0,alt1,alt2 use interp_eqprof, only : psrad,ct,npp + use utils, only : locate implicit real*8 (a-h,o-z) c @@ -4493,6 +4502,7 @@ c use graydata_flags, only : iprof use graydata_anequil, only : zeffan use interp_eqprof, only : psrad,cz,npp + use utils, only : locate implicit real*8 (a-h,o-z) c @@ -4514,6 +4524,7 @@ c beam tracing initial conditions igrad=1 c subroutine ic_gb use const_and_precisions, only : izero,zero,one,pi,cvdr=>degree + use math, only : catand use graydata_flags, only : ipol use graydata_par, only : rwmax,psipol0,chipol0 @@ -4530,8 +4541,6 @@ c complex*16 ui,sss,ddd,phic,qi1,qi2,tc,ts,qqxx,qqxy,qqyy complex*16 dqi1,dqi2,dqqxx,dqqyy,dqqxy complex*16 d2qi1,d2qi2,d2qqxx,d2qqyy,d2qqxy - complex*16 catand - external catand c common/nray/nrayr,nrayth common/parwv/ak0,akinv,fhz @@ -5382,14 +5391,14 @@ c use green_func_p, only: SpitzFuncCoeff use const_and_precisions, only : pi,qesi=>e_,mesi=>me_,vcsi=>c_, * qe=>ecgs_,me=>mecgs_,vc=>ccgs_,mc2=>mc2_ - + use conical, only : fconic implicit none real*8 anum,denom,resp,resj,effjcd,coullog,dens real*8 yg,anpl,anpr,amu,anprre,anprim real*8 mc2m2,anucc,canucc,ddens real*8 ceff,Zeff,psinv real*8 rbn,rbx,alams,fp0s,pa,fc - real*8 fjch,fjncl,fjch0,fconic + real*8 fjch,fjncl,fjch0 real*8 cst2,eccdpar(5) complex*16 ex,ey,ez integer ieccd,nhmn,nhmx,nhn,ithn,ierr,iokhawa @@ -5477,6 +5486,7 @@ c c subroutine curr_int(yg,anpl,anprre,amu,ex,ey,ez,nhn,ithn,cst2, * fcur,eccdpar,necp,resj,resp,iokhawa,ierr) + use quadpack, only : dqagsmv implicit real*8(a-h,o-z) parameter(epsa=0.0d0,epsr=1.0d-2) parameter(xxcr=16.0d0) @@ -5639,6 +5649,7 @@ c extrapar(14) = uplm c extrapar(15) = ygn c use const_and_precisions, only : ui=>im + use math, only : fact implicit real*8 (a-h,o-z) complex*16 ex,ey,ez,emxy,epxy dimension extrapar(npar) @@ -5726,6 +5737,7 @@ c extrapar(18) = alams c extrapar(19) = pa c extrapar(20) = fp0s c + use conical, only : fconic implicit real*8 (a-h,o-z) complex*16 ex,ey,ez dimension extrapar(npar) @@ -6013,8 +6025,10 @@ c c subroutine pec(pabs,currt) use const_and_precisions, only : pi,one + use numint, only : simpson use graydata_flags, only : ipec,ieccd,iequil,nnd,dst use graydata_anequil, only : rr0m,rpam + use utils, only : locatex, locate, intlin implicit real*8(a-h,o-z) parameter(nndmx=5001,jmx=31,kmx=36,nmx=8000) @@ -6359,6 +6373,7 @@ c subroutine profwidth(nd,xx,yy,rhotmx,rhopmx,ypk,drhot,drhop) use const_and_precisions, only : emn1 use graydata_flags, only : ipec,iequil + use utils, only : locatex, locate, intlin, vmaxmini implicit real*8(a-h,o-z) dimension xx(nd),yy(nd) diff --git a/src/grayl.f b/src/grayl.f index 1184f52..d08a4fc 100644 --- a/src/grayl.f +++ b/src/grayl.f @@ -1,279 +1,3 @@ - subroutine locate(xx,n,x,j) - implicit real*8(a-h,o-z) - dimension xx(n) -c -c Given an array xx(n), and a value x -c returns a value j such that xx(j) < x < xx(j+1) -c xx(n) must be monotonic, either increasing or decreasing. -c j=0 or j=n indicate that x is out of range (Numerical Recipes) -c - jl=0 - ju=n+1 - do while ((ju-jl).gt.1) - jm=(ju+jl)/2 - if((xx(n).gt.xx(1)). eqv .(x.gt.xx(jm))) then - jl=jm - else - ju=jm - endif - end do - j=jl - return - end -c -c -c - subroutine locatex(xx,n,n1,n2,x,j) - implicit real*8(a-h,o-z) - dimension xx(n) -c -c Given an array xx(n), and a value x -c returns a value j such that xx(j) < x < xx(j+1) -c xx(n) must be monotonic, either increasing or decreasing. -c j=n1-1or j=n2+1 indicate that x is out of range -c modified from subr. locate (Numerical Recipes) -c - jl=n1-1 - ju=n2+1 - do while ((ju-jl).gt.1) - jm=(ju+jl)/2 - if((xx(n2).gt.xx(n1)). eqv .(x.gt.xx(jm))) then - jl=jm - else - ju=jm - endif - end do - j=jl - return - end -c -c -c - subroutine intlin(x1,y1,x2,y2,x,y) - implicit real*8 (a-h,o-z) -c -c linear interpolation -c (x1,y1) < (x,y) < (x2,y2) -c - dx=x2-x1 - if(dx.eq.0.d0) then - print*,'ERROR in INTLIN',x1,x2,y1,y2 - else - aa=(x2-x)/dx - bb=1.0d0-aa - y=aa*y1+bb*y2 - endif -c - return - end - -c - subroutine vmax(x,n,xmax,imx) - implicit real*8 (a-h,o-z) - dimension x(n) - xmax=-1d+30 - do i=1,n - if(x(i).ge.xmax) then - xmax=x(i) - imx=i - end if - end do - return - end -c -c -c - subroutine vmin(x,n,xmin,imn) - implicit real*8 (a-h,o-z) - dimension x(n) - xmin=1d+30 - do i=1,n - if(x(i).le.xmin) then - xmin=x(i) - imn=i - end if - end do - return - end -c -c -c - subroutine vmaxmini(x,n,xmin,xmax,imn,imx) - implicit real*8 (a-h,o-z) - dimension x(n) - xmin=1d+30 - xmax=-1d+30 - do i=2,n - if(x(i).le.xmin) then - xmin=x(i) - imn=i - end if - if(x(i).ge.xmax) then - xmax=x(i) - imx=i - end if - end do - return - end -c -c -c - subroutine vmaxmin(x,n,xmin,xmax) - implicit real*8 (a-h,o-z) - dimension x(n) - xmin=1d+30 - xmax=-1d+30 - do i=2,n - if(x(i).le.xmin) xmin=x(i) - if(x(i).ge.xmax) xmax=x(i) - end do - return - end -c -c -c -c -c -c catand : double complex version of catan from slatec library -*deck catan - double complex function catand (z) -c***begin prologue catan -c***purpose compute the complex arc tangent. -c***library slatec (fnlib) -c***category c4a -c***type complex (catan-c) -c***keywords arc tangent, elementary functions, fnlib, trigonometric -c***author fullerton, w., (lanl) -c***description -c -c catan(z) calculates the complex trigonometric arc tangent of z. -c the result is in units of radians, and the real part is in the first -c or fourth quadrant. -c -c***references (none) -c***routines called d1mach, xermsg -c***revision history (yymmdd) -c 770801 date written -c 890531 changed all specific intrinsics to generic. (wrb) -c 890531 revision date from version 3.2 -c 891214 prologue converted to version 4.0 format. (bab) -c 900315 calls to xerror changed to calls to xermsg. (thj) -c 900326 removed duplicate information from description section. -c (wrb) -c***end prologue catan - implicit real*8(a-h,o-z) - complex*16 z, z2 - logical first - save pi2, nterms, sqeps, rmin, rmax, first - data pi2 / 1.5707963267 9489661923d0 / - data first /.true./ -c***first executable statement catan - if (first) then -c nterms = log(eps)/log(rbnd) where rbnd = 0.1 - nterms = -0.4343d0*log(d1mach(3)) + 1.0d0 - sqeps = sqrt(d1mach(4)) - rmin = sqrt (3.0d0*d1mach(3)) - rmax = 1.0d0/d1mach(3) - endif - first = .false. -c - r = abs(z) - if (r.gt.0.1d0) go to 30 -c - catand = z - if (r.lt.rmin) return -c - catand = (0.0d0, 0.0d0) - z2 = z*z - do 20 i=1,nterms - twoi = 2*(nterms-i) + 1 - catand = 1.0d0/twoi - z2*catand - 20 continue - catand = z*catand - return -c - 30 if (r.gt.rmax) go to 50 - x = dble(z) - y = dimag(z) - r2 = r*r - if (r2.eq.1.0d0.and.x.eq. 0.0d0) print*,'catand, z is +i or -i' - if (abs(r2-1.0d0).gt.sqeps) go to 40 - if (abs(dcmplx(1.0d0, 0.0d0)+z*z) .lt. sqeps) - . print*,'catand, answer lt half precision, z**2 close to -1' -c - 40 xans = 0.5d0*atan2(2.0d0*x, 1.0d0-r2) - yans = 0.25d0*log((r2+2.0d0*y+1.0d0)/(r2-2.0d0*y+1.0d0)) - catand = dcmplx(xans, yans) - return -c - 50 catand = dcmplx (pi2, 0.0d0) - if (dble(z).lt.0.0d0) catand = dcmplx(-pi2,0.0d0) - return -c - end -c -c -c - integer function length(string) -*returns length of string ignoring trailing blanks - character*(*) string - do 15, i = len(string), 1, -1 - if(string(i:i) .ne. ' ') go to 20 -15 continue -20 length = i - end - -c -c -c - subroutine simpson (n,h,fi,s) -c -c subroutine for integration over f(x) with the simpson rule. fi: -c integrand f(x); h: interval; s: integral. copyright (c) tao pang 1997. -c - implicit none - integer n - integer i - real*8 h - real*8 s0,s1,s2 - real*8 s - real*8 fi(n) - - s = 0.0d0 - s0 = 0.0d0 - s1 = 0.0d0 - s2 = 0.0d0 - do i = 2, n-1, 2 - s1 = s1+fi(i-1) - s0 = s0+fi(i) - s2 = s2+fi(i+1) - end do - s = h*(s1+4.0d0*s0+s2)/3.0d0 -c -c if n is even, add the last slice separately -c - if (mod(n,2).eq.0) s = s - . +h*(5.0d0*fi(n)+8.0d0*fi(n-1)-fi(n-2))/12.0d0 - end subroutine simpson -c -c -c - subroutine trapezoid(n,xi,fi,s) -c subroutine for integration with the trapezoidal rule. -c fi: integrand f(x); xi: abscissa x; -c s: integral Int_{xi(1)}^{xi(n)} f(x)dx - implicit none - integer n - real*8 xi(n),fi(n) - real*8 s - integer i -c - s = 0.0d0 - do i = 1, n-1 - s = s+(xi(i+1)-xi(i))*(fi(i+1)-fi(i)) - end do - s = 0.5d0*s - end subroutine trapezoid c c c spline routines: begin @@ -534,3296 +258,6 @@ c c c spline routines: end c -c -c routines for conical function: begin -c - function fconic(x,tau,m) -c -c this function subprogram computes the conical functions of the -c first kind P sub(-1/2 + i*tau) (x) for m = 0 and m = 1. -c Ref. in Kolbig, Comp. Phys. Commun. 23 (1981) 51 -c - implicit double precision (a-h,o-z) - dimension t(7),h(9),v(11) -c - double complex a,b,c,ti,r,rr,q,u,u0,u1,u2,uu - double complex v0,v1,v2,vv,w(19),clogam -c - logical lm0,lm1,lta -c - data rpi /1.7724 53850 9055d0/, pi2 /0.63661 97723 6758d0/ - data eps /1.0d-14/, nmax /200/, nout /2/ - - fconic=0.0d0 - lm0=m .eq. 0 - lm1=m .eq. 1 - if(.not.(lm0 .or. lm1)) go to 99 - fm=m - fconic=1.0d0-fm - if(x .eq. 1.0d0) return -c - fconic=0.0d0 - if(tau .eq. 0.0d0 .and. abs(x-1.0d0) .gt. 0.01d0) go to 60 - ti=dcmplx(0.d0,tau) -c - if(-1.d0 .lt. x .and. x .le. 0.0d0) go to 11 - if(0.0d0 .lt. x .and. x .le. 0.1d0 .and.tau.le. 17.0d0) go to 11 - if(0.1d0 .lt. x .and. x .le. 0.2d0 .and.tau.le. 5.0d0) go to 11 - if(0.1d0 .lt. x .and. x .le. 0.2d0 .and.tau.le. 17.0d0) go to 12 - if(0.2d0 .lt. x .and. x .le. 1.5d0 .and.tau.le. 20.0d0) go to 12 - if(1.5d0 .lt. x .and. tau .le. max(20.0d0,x)) go to 13 - go to 50 -c - 11 lta=tau .le. 10.0d0 - x1=x**2 - a=0.5d0*(0.5d0-fm-ti) - b=0.5d0*(0.5d0-fm+ti) - c=0.5d0 - assign 30 to jp - go to 100 - 30 r1=dble(r)/abs(exp(clogam(a+0.5d0)))**2 - a=0.5d0*(1.5d0-fm-ti) - b=0.5d0*(1.5d0-fm+ti) - c=1.5d0 - assign 31 to jp - go to 100 - 31 r2=dble(r)/abs(exp(clogam(a-0.5d0)))**2 - fconic=rpi*(r1-2.0d0*x*r2) - if(lm1) fconic=(2.0d0/sqrt(1.0d0-x1))*fconic - return -c - 12 lta=x .gt. 1.0d0 .or. x .le. 1.0d0 .and. tau .le. 5.0d0 - x1=(1.0d0-x)/2.d0 - a=0.5d0+fm-ti - b=0.5d0+fm+ti - c=fm+1.0d0 - assign 32 to jp - go to 100 - 32 fconic=dble(r) - if(lm0) return - fconic=0.5d0*(tau**2+0.25d0)*sqrt(abs(x**2-1.0d0))*fconic - if(x .gt. 1.0d0) fconic=-fconic - return -c - 13 lta=.true. - x1=1.0d0/x**2 - u=exp((-0.5d0+ti)*log(2.0d0*x)+clogam(1.0d0+ti) - . -clogam(1.5d0-fm+ti)) - a=0.5d0*(0.5d0-fm-ti) - b=0.5d0*(1.5d0-fm-ti) - c=1.0d0-ti - assign 33 to jp - go to 100 - 33 fconic=2.0d0*dble(u*r*(0.5d0-fm+ti)/ti)/rpi - if(lm1) fconic=fconic/sqrt(1.0d0-x1) - return -c - 100 if(lta) go to 110 - r=1.0d0 - q=1.0d0 - do 101 n = 1,nmax - fn=n - fn1=fn-1.0d0 - rr=r - q=q*x1*(a+fn1)*(b+fn1)/((c+fn1)*fn) - r=r+q - if(abs(r-rr) .lt. eps) go to 102 - 101 continue - go to 98 -c - 110 y=-x1 - y2=y**2 - y3=y**3 - w(1)=a+1.0d0 - w(2)=a+2.0d0 - w(3)=b+1.0d0 - w(4)=b+2.0d0 - w(5)=c+1.0d0 - w(6)=c*w(5) - w(7)=a+b - w(8)=a*b - w(9)=(w(8)/c)*y - w(10)=w(1)*w(3) - w(11)=w(2)*w(4) - w(12)=1.0d0+(w(11)/(2.0d0*w(5)))*y - w(13)=w(7)-6.0d0 - w(14)=w(7)+6.0d0 - w(15)=2.0d0-w(8) - w(16)=w(15)-2.0d0*w(7) -c - v0=1.0d0 - v1=1.0d0+(w(10)/(2.0d0*c))*y - v2=w(12)+(w(10)*w(11)/(12.0d0*w(6)))*y2 - u0=1.0d0 - u1=v1-w(9) - u2=v2-w(9)*w(12)+(w(8)*w(10)/(2.0d0*w(6)))*y2 -c - r=1.0d0 - n=2 - 111 n=n+1 - if(n .gt. nmax) go to 98 - rr=r - fn=n - h(1)=fn-1.0d0 - h(2)=fn-2.0d0 - h(3)=fn-3.0d0 - h(4)=2.0d0*fn - h(5)=h(4)-3.0d0 - h(6)=2.0d0*h(5) - h(7)=4.0d0*(h(4)-1.0d0)*h(5) - h(8)=8.0d0*h(5)**2*(h(4)-5.0d0) - h(9)=3.0d0*fn**2 - w(1)=a+h(1) - w(2)=a+h(2) - w(3)=b+h(1) - w(4)=b+h(2) - w(5)=c+h(1) - w(6)=c+h(2) - w(7)=c+h(3) - w(8)=h(2)-a - w(9)=h(2)-b - w(10)=h(1)-c - w(11)=w(1)*w(3) - w(12)=w(5)*w(6) -c - w(17)=1.0d0+((h(9)+w(13)*fn+w(16))/(h(6)*w(5)))*y - w(18)=-((w(11)*w(10)/h(6)+(h(9)-w(14)*fn+w(15))*w(11)*y/h(7))/ - 1 w(12))*y - w(19)=(w(2)*w(11)*w(4)*w(8)*w(9)/(h(8)*w(7)*w(12)))*y3 - vv=w(17)*v2+w(18)*v1+w(19)*v0 - uu=w(17)*u2+w(18)*u1+w(19)*u0 - r=uu/vv - if(abs(r-rr) .lt. eps) go to 102 - v0=v1 - v1=v2 - v2=vv - u0=u1 - u1=u2 - u2=uu - go to 111 - 102 go to jp, (30,31,32,33) -c - 50 if(x .gt. 1.0d0) go to 2 - s=sqrt(1.0d0-x**2) - t(1)=acos(x) - h(1)=tau*t(1) - b0=besi0(h(1)) - b1=besi1(h(1)) - z=-1.0d0 - go to 3 -c - 2 s=sqrt(x**2-1.0d0) - t(1)=log(x+s) - h(1)=tau*t(1) - b0=besj0l(h(1)) - b1=besj1l(h(1)) - z=1.0d0 -c - 3 h(1)=t(1)*x/s - v(1)=tau - do 20 j = 2,7 - t(j)=t(j-1)*t(1) - 20 h(j)=h(j-1)*h(1) - do 21 j = 2,11 - 21 v(j)=v(j-1)*v(1) -c - if(lm1) go to 51 - aa=0.0d0 - a0=1.0d0 - a1=(h(1)-1.0d0)/(8.0d0*t(1)) - a2=(9.0d0*h(2)+6.0d0*h(1)-15.0d0-z*8.0d0*t(2))/(128.0d0*t(2)) - a3=5.0d0*(15.0d0*h(3)+27.0d0*h(2)+21.0d0*h(1)-63.0d0 - . -z*t(2)*(16.0d0*h(1)+24.0d0) - 1 )/(1024.0d0*t(3)) - a4=7.0d0*(525.0d0*h(4)+1500.0d0*h(3)+2430.0d0*h(2)+1980.0d0*h(1) - . -6435.0d0+192.0d0*t(4) - 1-z*t(2)*(720.0d0*h(2)+1600.0d0*h(1)+2160.0d0))/(32768.0d0*t(4)) - a5=21.0d0*(2835.0d0*h(5)+11025.0d0*h(4)+24750.0d0*h(3) - 1 +38610.0d0*h(2)+32175.0d0*h(1)-109395.0d0+t(4) - . *(1984.0d0*h(1)+4032.0d0) - 2 -z*t(2)*(4800.0d0*h(3)+15120.0d0*h(2)+26400.0d0*h(1)+34320.0d0)) - 3 /(262144.0d0*t(5)) - a6=11.0d0*(218295.0d0*h(6)+1071630.0d0*h(5)+3009825.0d0*h(4) - . +6142500.0d0* - 1 h(3)+9398025.0d0*h(2)+7936110.0d0*h(1)-27776385.0d0 - . +t(4)*(254016.0d0*h(2) - 2 +749952.0d0*h(1)+1100736.0d0)-z*t(2)*(441000.0d0*h(4) - . +1814400.0d0*h(3) - 3 +4127760.0d0*h(2)+6552000.0d0*h(1)+8353800.0d0+31232.0d0*t(4)))/ - 4 (4194304.0d0*t(6)) - go to 52 -c - 51 aa=-1.0d0 - a0=3.0d0*(1.0d0-h(1))/(8.0d0*t(1)) - a1=(-15.0d0*h(2)+6.0d0*h(1)+9.0d0+z*8.0d0*t(2))/(128.0d0*t(2)) - a2=3.0d0*(-35.0d0*h(3)-15.0d0*h(2)+15.0d0*h(1)+35.0d0 - 1 +z*t(2)*(32.0d0*h(1)+8.0d0))/(1024.0d0*t(3)) - a3=(-4725.0d0*h(4)-6300.0d0*h(3)-3150.0d0*h(2)+3780.0d0*h(1) - 1 +10395.0d0-1216.0d0*t(4)+z*t(2)*(6000.0d0*h(2) - 2 +5760.0d0*h(1)+1680.0d0)) /(32768.0d0*t(4)) - a4=7.0d0*(-10395.0d0*h(5)-23625.0d0*h(4)-28350.0d0*h(3) - . -14850.0d0*h(2)+19305.0d0*h(1)+57915.0d0 - 1 -t(4)*(6336.0d0*h(1)+6080.0d0)+z*t(2)*(16800.0d0* - 2 h(3)+30000.0d0*h(2)+25920.0d0*h(1)+7920.0d0))/(262144.0d0*t(5)) - a5=(-2837835.0d0*h(6)-9168390.0d0*h(5)-16372125.0d0*h(4) - . -18918900*h(3) -10135125.0d0*h(2)+13783770.0d0*h(1) - 1 +43648605.0d0-t(4)*(3044160.0d0*h(2)+5588352.0d0*h(1) - 2 +4213440.0d0)+z*t(2)*(5556600.0d0*h(4)+14817600.0d0*h(3) - 3 +20790000.0d0*h(2)+17297280.0d0*h(1)+5405400.0d0 - 4 +323072.0d0*t(4)))/ (4194304.0d0*t(6)) - a6=0.0d0 -c - 52 s0=a0+(-4.0d0*a3/t(1)+a4)/v(4)+(-192.0d0*a5/t(3)+144.0d0*a6/t(2)) - 1 /v(8)+z*(-a2/v(2)+(-24.0d0*a4/t(2)+12.0d0*a5/t(1)-a6)/v(6) - 2 +(-1920.0d0*a6/t(4))/v(10)) - s1=a1/v(1)+(8.0d0*(a3/t(2)-a4/t(1))+a5)/v(5)+(384.0d0*a5/t(4) - 1 -768.0d0*a6/t(3))/v(9) - 2 +z*(aa*v(1)+(2.0d0*a2/t(1)-a3)/v(3)+(48.0d0*a4/t(3)-72.0d0*a5 - 3 /t(2)+18.0d0*a6/t(1))/v(7)+(3840.0d0*a6/t(5))/v(11)) - fconic=sqrt(t(1)/s)*(b0*s0+b1*s1) - return -c - 60 if(x .gt. 1.0d0) go to 61 - y=sqrt(0.5d0*(1.0d0-x)) - z=ellick(y) - if(lm0) fconic=pi2*z - if(lm1) fconic=pi2*(ellice(y)-0.5d0*(1.0d0+x)*z)/sqrt(1.0d0-x**2) - return - 61 y=sqrt((x-1.0d0)/(x+1.0d0)) - z=ellick(y) - s=sqrt(0.5d0*(x+1.0d0)) - if(lm0) fconic=pi2*z/s - if(lm1) fconic=pi2*s*(ellice(y)-z)/sqrt(x**2-1.0d0) - return -c - 98 write(nout,200) x,tau,m - return - 99 write(nout,201) m - return -c - 200 format(1x,'fconic ... convergence difficulties for - 1c function, x = ',e12.4,5x,'tau = ',e12.4,5x,'m = ',i5) - 201 format(1x,33hfconic ... illegal value for m = ,i4) -c - end -c -c -c - double complex function clogam(z) -c - implicit double precision (a-h,o-z) - double complex z,v,h,r -c - dimension b(10) -c - data nout /2/ - data pi /3.14159 26535 898d0/ - data b(1),b(2),b(3),b(4),b(5),b(6),b(7),b(8),b(9),b(10) - 1 /+8.33333 33333 333 d-2, -2.77777 77777 778 d-3, - 1 +7.93650 79365 079 d-4, -5.95238 09523 810 d-4, - 2 +8.41750 84175 084 d-4, -1.91752 69175 269 d-3, - 3 +6.41025 64102 564 d-3, -2.95506 53594 771 d-2, - 4 +1.79644 37236 883 d-1, -1.39243 22169 059 d+0/ -c - x=dble(z) - t=dimag(z) - if(-abs(x) .eq. aint(x) .and. t .eq. 0.0d0) go to 5 - f=abs(t) - v=dcmplx(x,f) - if(x .lt. 0.0d0) v=1.0d0-v - h=(0.0d0,0.0d0) - c=dble(v) - if(c .ge. 7.0d0) go to 3 - n=6-int(c) - h=v - d=dimag(v) - a=atan2(d,c) - if(n .eq. 0) go to 2 - do 1 i = 1,n - c=c+1.0d0 - v=dcmplx(c,d) - h=h*v - 1 a=a+atan2(d,c) - 2 h=dcmplx(0.5d0*log(dble(h)**2+dimag(h)**2),a) - v=v+1.0d0 - 3 r=1.0d0/v**2 - clogam=0.91893853320467d0+(v-0.5d0)*log(v)-v+(b(1)+r*(b(2)+r*(b(3) - 1 +r*(b(4)+r*(b(5)+r*(b(6)+r*(b(7)+r*(b(8)+r*(b(9)+r*b(10)))))))))) - 2 /v-h - if(x .ge. 0.0d0) go to 4 -c - a=aint(x)-1.0d0 - c=pi*(x-a) - d=pi*f - e=exp(-2.0d0*d) - f=sin(c) - e=d+0.5d0*log(e*f**2+0.25d0*(1.0d0-e)**2) - f=atan2(cos(c)*tanh(d),f)-a*pi - clogam=1.1447298858494d0-dcmplx(e,f)-clogam -c - 4 if(t .lt. 0.0d0) clogam=dconjg(clogam) - return - - 5 write(nout,100) x - clogam=(0.0d0,0.0d0) - return -c - 100 format(1x,f20.2) -c - end -c -c -c - function ellick(xk) -c - implicit double precision (a-h,o-z) - dimension a(10),b(10),c(10),d(10) -c - data a(1)/9.65735 90280 856 d-2/ - data a(2)/3.08851 46271 305 d-2/ - data a(3)/1.49380 13532 687 d-2/ - data a(4)/8.78980 18745 551 d-3/ - data a(5)/6.17962 74460 533 d-3/ - data a(6)/6.84790 92826 245 d-3/ - data a(7)/9.84892 93221 769 d-3/ - data a(8)/8.00300 39806 500 d-3/ - data a(9)/2.29663 48983 970 d-3/ - data a(10)/1.39308 78570 066 d-4/ -c - data b(1)/1.24999 99999 991 d-1/ - data b(2)/7.03124 99739 038 d-2/ - data b(3)/4.88280 41906 862 d-2/ - data b(4)/3.73777 39758 624 d-2/ - data b(5)/3.01248 49012 899 d-2/ - data b(6)/2.39319 13323 111 d-2/ - data b(7)/1.55309 41631 977 d-2/ - data b(8)/5.97390 42991 554 d-3/ - data b(9)/9.21554 63496 325 d-4/ - data b(10)/2.97002 80966 556 d-5/ -c - data c(1)/4.43147 18056 089 d-1/ - data c(2)/5.68051 94567 559 d-2/ - data c(3)/2.18318 11676 130 d-2/ - data c(4)/1.15695 95745 295 d-2/ - data c(5)/7.59509 34225 594 d-3/ - data c(6)/7.82040 40609 596 d-3/ - data c(7)/1.07706 35039 866 d-2/ - data c(8)/8.63844 21736 041 d-3/ - data c(9)/2.46850 33304 607 d-3/ - data c(10)/1.49466 21757 181 d-4/ -c - data d(1)/2.49999 99999 990 d-1/ - data d(2)/9.37499 99721 203 d-2/ - data d(3)/5.85936 61255 531 d-2/ - data d(4)/4.27178 90547 383 d-2/ - data d(5)/3.34789 43665 762 d-2/ - data d(6)/2.61450 14700 314 d-2/ - data d(7)/1.68040 23346 363 d-2/ - data d(8)/6.43214 65864 383 d-3/ - data d(9)/9.89833 28462 254 d-4/ - data d(10)/3.18591 95655 502 d-5/ -c - if(abs(xk) .ge. 1.0d0) go to 10 - eta=1.0d0-xk**2 - pa=a(10) - do 1 i = 1,9 - 1 pa=pa*eta+a(10-i) - pa=pa*eta - pb=b(10) - do 2 i = 1,9 - 2 pb=pb*eta+b(10-i) - pb=pb*eta - ellick=1.3862943611199d0+pa-log(eta)*(0.5d0+pb) - return -c - 10 ellick=0.0d0 - return - 9 ellick=1.0d0 - return -c - entry ellice(xk) -c - if(abs(xk)-1.0d0) 8,9,10 - 8 eta=1.0d0-xk**2 - pc=c(10) - do 3 i = 1,9 - 3 pc=pc*eta+c(10-i) - pc=pc*eta - pd=d(10) - do 4 i = 1,9 - 4 pd=pd*eta+d(10-i) - pd=pd*eta - ellick=1.0d0+pc-log(eta)*pd - return - end -c -c -c - function besjy(x) -c - implicit double precision (a-h,o-z) - logical l -c - data nout /2/ -c - entry besj0l(x) -c - l=.true. - v=abs(x) - if(v .ge. 8.0d0) go to 4 - 8 f=0.0625d0*x**2-2.0d0 - a = - 0.00000 00000 000008d0 - b = f * a + 0.00000 00000 000413d0 - a = f * b - a - 0.00000 00000 019438d0 - b = f * a - b + 0.00000 00000 784870d0 - a = f * b - a - 0.00000 00026 792535d0 - b = f * a - b + 0.00000 00760 816359d0 - a = f * b - a - 0.00000 17619 469078d0 - b = f * a - b + 0.00003 24603 288210d0 - a = f * b - a - 0.00046 06261 662063d0 - b = f * a - b + 0.00481 91800 694676d0 - a = f * b - a - 0.03489 37694 114089d0 - b = f * a - b + 0.15806 71023 320973d0 - a = f * b - a - 0.37009 49938 726498d0 - b = f * a - b + 0.26517 86132 033368d0 - a = f * b - a - 0.00872 34423 528522d0 - a = f * a - b + 0.31545 59429 497802d0 - besjy=0.5d0*(a-b) - if(l) return -c - a = + 0.00000 00000 000016d0 - b = f * a - 0.00000 00000 000875d0 - a = f * b - a + 0.00000 00000 040263d0 - b = f * a - b - 0.00000 00001 583755d0 - a = f * b - a + 0.00000 00052 487948d0 - b = f * a - b - 0.00000 01440 723327d0 - a = f * b - a + 0.00000 32065 325377d0 - b = f * a - b - 0.00005 63207 914106d0 - a = f * b - a + 0.00075 31135 932578d0 - b = f * a - b - 0.00728 79624 795521d0 - a = f * b - a + 0.04719 66895 957634d0 - b = f * a - b - 0.17730 20127 811436d0 - a = f * b - a + 0.26156 73462 550466d0 - b = f * a - b + 0.17903 43140 771827d0 - a = f * b - a - 0.27447 43055 297453d0 - a = f * a - b - 0.06629 22264 065699d0 - besjy=0.636619772367581d0*log(x)*besjy+0.5d0*(a-b) - return -c - 4 f=256.0d0/x**2-2.0d0 - b = + 0.00000 00000 000007 d0 - a = f * b - 0.00000 00000 000051 d0 - b = f * a - b + 0.00000 00000 000433 d0 - a = f * b - a - 0.00000 00000 004305 d0 - b = f * a - b + 0.00000 00000 051683 d0 - a = f * b - a - 0.00000 00000 786409 d0 - b = f * a - b + 0.00000 00016 306465 d0 - a = f * b - a - 0.00000 00517 059454 d0 - b = f * a - b + 0.00000 30751 847875 d0 - a = f * b - a - 0.00053 65220 468132 d0 - a = f * a - b + 1.99892 06986 950373 d0 - p=a-b - b = - 0.00000 00000 000006 d0 - a = f * b + 0.00000 00000 000043 d0 - b = f * a - b - 0.00000 00000 000334 d0 - a = f * b - a + 0.00000 00000 003006 d0 - b = f * a - b - 0.00000 00000 032067 d0 - a = f * b - a + 0.00000 00000 422012 d0 - b = f * a - b - 0.00000 00007 271916 d0 - a = f * b - a + 0.00000 00179 724572 d0 - b = f * a - b - 0.00000 07414 498411 d0 - a = f * b - a + 0.00006 83851 994261 d0 - a = f * a - b - 0.03111 17092 106740 d0 - q=8.0d0*(a-b)/v - f=v-0.785398163397448d0 - a=cos(f) - b=sin(f) - f=0.398942280401432d0/sqrt(v) - if(l) go to 6 - besjy=f*(q*a+p*b) - return - 6 besjy=f*(p*a-q*b) - return -c - entry besj1l(x) -c - l=.true. - v=abs(x) - if(v .ge. 8.0d0) go to 5 - 3 f=0.0625d0*x**2-2.0d0 - b = + 0.00000 00000 000114 d0 - a = f * b - 0.00000 00000 005777 d0 - b = f * a - b + 0.00000 00000 252812 d0 - a = f * b - a - 0.00000 00009 424213 d0 - b = f * a - b + 0.00000 00294 970701 d0 - a = f * b - a - 0.00000 07617 587805 d0 - b = f * a - b + 0.00001 58870 192399 d0 - a = f * b - a - 0.00026 04443 893486 d0 - b = f * a - b + 0.00324 02701 826839 d0 - a = f * b - a - 0.02917 55248 061542 d0 - b = f * a - b + 0.17770 91172 397283 d0 - a = f * b - a - 0.66144 39341 345433 d0 - b = f * a - b + 1.28799 40988 576776 d0 - a = f * b - a - 1.19180 11605 412169 d0 - a = f * a - b + 1.29671 75412 105298 d0 - besjy=0.0625d0*(a-b)*x - if(l) return -c - b = - 0.00000 00000 000244 d0 - a = f * b + 0.00000 00000 012114 d0 - b = f * a - b - 0.00000 00000 517212 d0 - a = f * b - a + 0.00000 00018 754703 d0 - b = f * a - b - 0.00000 00568 844004 d0 - a = f * b - a + 0.00000 14166 243645 d0 - b = f * a - b - 0.00002 83046 401495 d0 - a = f * b - a + 0.00044 04786 298671 d0 - b = f * a - b - 0.00513 16411 610611 d0 - a = f * b - a + 0.04231 91803 533369 d0 - b = f * a - b - 0.22662 49915 567549 d0 - a = f * b - a + 0.67561 57807 721877 d0 - b = f * a - b - 0.76729 63628 866459 d0 - a = f * b - a - 0.12869 73843 813500 d0 - a = f * a - b + 0.04060 82117 718685 d0 - besjy=0.636619772367581d0*log(x)*besjy-0.636619772367581d0/x - 1 +0.0625d0*(a-b)*x - return -c - 5 f=256.0d0/x**2-2.0d0 - b = - 0.00000 00000 000007 d0 - a = f * b + 0.00000 00000 000055 d0 - b = f * a - b - 0.00000 00000 000468 d0 - a = f * b - a + 0.00000 00000 004699 d0 - b = f * a - b - 0.00000 00000 057049 d0 - a = f * b - a + 0.00000 00000 881690 d0 - b = f * a - b - 0.00000 00018 718907 d0 - a = f * b - a + 0.00000 00617 763396 d0 - b = f * a - b - 0.00000 39872 843005 d0 - a = f * b - a + 0.00089 89898 330859 d0 - a = f * a - b + 2.00180 60817 200274 d0 - p=a-b - b = + 0.00000 00000 000007 d0 - a = f * b - 0.00000 00000 000046 d0 - b = f * a - b + 0.00000 00000 000360 d0 - a = f * b - a - 0.00000 00000 003264 d0 - b = f * a - b + 0.00000 00000 035152 d0 - a = f * b - a - 0.00000 00000 468636 d0 - b = f * a - b + 0.00000 00008 229193 d0 - a = f * b - a - 0.00000 00209 597814 d0 - b = f * a - b + 0.00000 09138 615258 d0 - a = f * b - a - 0.00009 62772 354916 d0 - a = f * a - b + 0.09355 55741 390707 d0 - q=8.0d0*(a-b)/v - f=v-2.356194490192345d0 - a=cos(f) - b=sin(f) - f=0.398942280401432d0/sqrt(v) - if(l) go to 7 - besjy=f*(q*a+p*b) - return - 7 besjy=f*(p*a-q*b) - if(x .lt. 0.0d0) besjy=-besjy - return -c - entry besy0(x) -c - if(x .le. 0.0d0) go to 9 - l=.false. - v=x - if(v .ge. 8.0d0) go to 4 - go to 8 - entry besy1(x) -c - if(x .le. 0.0d0) go to 9 - l=.false. - v=x - if(v .ge. 8.0d0) go to 5 - go to 3 -c - 9 besjy=0.0d0 - write(nout,100) x - return - 100 format(1x,36hbesjy ... non-positive argument x = ,e15.4) -c - end -c -c -c - function besik(x) -c - implicit double precision (a-h,o-z) - logical l,e -c - data nout /2/ -c - entry ebesi0(x) -c - e=.true. - go to 1 -c - entry besi0(x) -c - e=.false. - 1 l=.true. - v=abs(x) - if(v .ge. 8.0d0) go to 4 - 8 f=0.0625d0*x**2-2.0d0 - a = 0.00000 00000 00002 d0 - b = f * a + 0.00000 00000 00120 d0 - a = f * b - a + 0.00000 00000 06097 d0 - b = f * a - b + 0.00000 00002 68828 d0 - a = f * b - a + 0.00000 00101 69727 d0 - b = f * a - b + 0.00000 03260 91051 d0 - a = f * b - a + 0.00000 87383 15497 d0 - b = f * a - b + 0.00019 24693 59688 d0 - a = f * b - a + 0.00341 63317 66012 d0 - b = f * a - b + 0.04771 87487 98174 d0 - a = f * b - a + 0.50949 33654 39983 d0 - b = f * a - b + 4.01167 37601 79349 d0 - a = f * b - a + 22.27481 92424 62231 d0 - b = f * a - b + 82.48903 27440 24100 d0 - a = f * b - a + 190.49432 01727 42844 d0 - a = f * a - b + 255.46687 96243 62167 d0 - besik=0.5d0*(a-b) - if(l .and. e) besik=exp(-v)*besik - if(l) return -c - a = + 0.00000 00000 00003 d0 - b = f * a + 0.00000 00000 00159 d0 - a = f * b - a + 0.00000 00000 07658 d0 - b = f * a - b + 0.00000 00003 18588 d0 - a = f * b - a + 0.00000 00112 81211 d0 - b = f * a - b + 0.00000 03351 95256 d0 - a = f * b - a + 0.00000 82160 25940 d0 - b = f * a - b + 0.00016 27083 79043 d0 - a = f * b - a + 0.00253 63081 88086 d0 - b = f * a - b + 0.03008 07224 20512 d0 - a = f * b - a + 0.25908 44324 34900 d0 - b = f * a - b + 1.51153 56760 29228 d0 - a = f * b - a + 5.28363 28668 73920 d0 - b = f * a - b + 8.00536 88687 00334 d0 - a = f * b - a - 4.56343 35864 48395 d0 - a = f * a - b - 21.05766 01774 02440 d0 - besik=-log(0.125d0*x)*besik+0.5d0*(a-b) - if(e) besik=exp(x)*besik - return -c - 4 f=32.0d0/v-2.0d0 - b = - 0.00000 00000 00001 d0 - a = f * b - 0.00000 00000 00001 d0 - b = f * a - b + 0.00000 00000 00004 d0 - a = f * b - a + 0.00000 00000 00010 d0 - b = f * a - b - 0.00000 00000 00024 d0 - a = f * b - a - 0.00000 00000 00104 d0 - b = f * a - b + 0.00000 00000 00039 d0 - a = f * b - a + 0.00000 00000 00966 d0 - b = f * a - b + 0.00000 00000 01800 d0 - a = f * b - a - 0.00000 00000 04497 d0 - b = f * a - b - 0.00000 00000 33127 d0 - a = f * b - a - 0.00000 00000 78957 d0 - b = f * a - b + 0.00000 00000 29802 d0 - a = f * b - a + 0.00000 00012 38425 d0 - b = f * a - b + 0.00000 00085 13091 d0 - a = f * b - a + 0.00000 00568 16966 d0 - b = f * a - b + 0.00000 05135 87727 d0 - a = f * b - a + 0.00000 72475 91100 d0 - b = f * a - b + 0.00017 27006 30778 d0 - a = f * b - a + 0.00844 51226 24921 d0 - a = f * a - b + 2.01655 84109 17480 d0 - besik=0.199471140200717d0*(a-b)/sqrt(v) - if(e) return - besik=exp(v)*besik - return -c - entry ebesi1(x) -c - e=.true. - go to 2 -c - entry besi1(x) -c - e=.false. - 2 l=.true. - v=abs(x) - if(v .ge. 8.0d0) go to 3 - 7 f=0.0625d0*x**2-2.0d0 - a = + 0.00000 00000 00001 d0 - b = f * a + 0.00000 00000 00031 d0 - a = f * b - a + 0.00000 00000 01679 d0 - b = f * a - b + 0.00000 00000 79291 d0 - a = f * b - a + 0.00000 00032 27617 d0 - b = f * a - b + 0.00000 01119 46285 d0 - a = f * b - a + 0.00000 32641 38122 d0 - b = f * a - b + 0.00007 87567 85754 d0 - a = f * b - a + 0.00154 30190 15627 d0 - b = f * a - b + 0.02399 30791 47841 d0 - a = f * b - a + 0.28785 55118 04672 d0 - b = f * a - b + 2.57145 99063 47755 d0 - a = f * b - a + 16.33455 05525 22066 d0 - b = f * a - b + 69.39591 76337 34448 d0 - a = f * b - a + 181.31261 60405 70265 d0 - a = f * a - b + 259.89023 78064 77292 d0 - besik=0.0625d0*(a-b)*x - if(l .and. e) besik=exp(-v)*besik - if(l) return -c - a = + 0.00000 00000 00001 d0 - b = f * a + 0.00000 00000 00042 d0 - a = f * b - a + 0.00000 00000 02163 d0 - b = f * a - b + 0.00000 00000 96660 d0 - a = f * b - a + 0.00000 00036 96783 d0 - b = f * a - b + 0.00000 01193 67971 d0 - a = f * b - a + 0.00000 32025 10692 d0 - b = f * a - b + 0.00007 00106 27855 d0 - a = f * b - a + 0.00121 70569 94516 d0 - b = f * a - b + 0.01630 00492 89816 d0 - a = f * b - a + 0.16107 43016 56148 d0 - b = f * a - b + 1.10146 19930 04852 d0 - a = f * b - a + 4.66638 70268 62842 d0 - b = f * a - b + 9.36161 78313 95389 d0 - a = f * b - a - 1.83923 92242 86199 d0 - a = f * a - b - 26.68809 54808 62668 d0 - besik=log(0.125d0*x)*besik+1.0d0/x-0.0625d0*(a-b)*x - if(e) besik=exp(x)*besik - return -c - 3 f=32.0d0/v-2.0d0 - b = + 0.00000 00000 00001 d0 - a = f * b + 0.00000 00000 00001 d0 - b = f * a - b - 0.00000 00000 00005 d0 - a = f * b - a - 0.00000 00000 00010 d0 - b = f * a - b + 0.00000 00000 00026 d0 - a = f * b - a + 0.00000 00000 00107 d0 - b = f * a - b - 0.00000 00000 00053 d0 - a = f * b - a - 0.00000 00000 01024 d0 - b = f * a - b - 0.00000 00000 01804 d0 - a = f * b - a + 0.00000 00000 05103 d0 - b = f * a - b + 0.00000 00000 35408 d0 - a = f * b - a + 0.00000 00000 81531 d0 - b = f * a - b - 0.00000 00000 47563 d0 - a = f * b - a - 0.00000 00014 01141 d0 - b = f * a - b - 0.00000 00096 13873 d0 - a = f * b - a - 0.00000 00659 61142 d0 - b = f * a - b - 0.00000 06297 24239 d0 - a = f * b - a - 0.00000 97321 46728 d0 - b = f * a - b - 0.00027 72053 60764 d0 - a = f * b - a - 0.02446 74429 63276 d0 - a = f * a - b + 1.95160 12046 52572 d0 - besik=0.199471140200717d0*(a-b)/sqrt(v) - if(x .lt. 0.0d0) besik=-besik - if(e) return - besik=exp(v)*besik - return -c - entry ebesk0 (x) -c - e=.true. - go to 11 -c - entry besk0(x) -c - e=.false. - 11 if(x .le. 0.0d0) go to 9 - l=.false. - v=x - if(x .lt. 5.0d0) go to 8 - f=20.0d0/x-2.0d0 - a = - 0.00000 00000 00002 d0 - b = f * a + 0.00000 00000 00011 d0 - a = f * b - a - 0.00000 00000 00079 d0 - b = f * a - b + 0.00000 00000 00581 d0 - a = f * b - a - 0.00000 00000 04580 d0 - b = f * a - b + 0.00000 00000 39044 d0 - a = f * b - a - 0.00000 00003 64547 d0 - b = f * a - b + 0.00000 00037 92996 d0 - a = f * b - a - 0.00000 00450 47338 d0 - b = f * a - b + 0.00000 06325 75109 d0 - a = f * b - a - 0.00001 11066 85197 d0 - b = f * a - b + 0.00026 95326 12763 d0 - a = f * b - a - 0.01131 05046 46928 d0 - a = f * a - b + 1.97681 63484 61652 d0 - besik=0.626657068657750d0*(a-b)/sqrt(x) - if(e) return - z=besik - besik=0.0d0 - if(x .lt. 180.0d0) besik=exp(-x)*z - return -c - entry ebesk1(x) -c - e=.true. - go to 12 -c - entry besk1(x) -c - e=.false. - 12 if(x .le. 0.0d0) go to 9 - l=.false. - v=x - if(x .lt. 5.0d0) go to 7 - f=20.0d0/x-2.0d0 - a = + 0.00000 00000 00002 d0 - b = f * a - 0.00000 00000 00013 d0 - a = f * b - a + 0.00000 00000 00089 d0 - b = f * a - b - 0.00000 00000 00663 d0 - a = f * b - a + 0.00000 00000 05288 d0 - b = f * a - b - 0.00000 00000 45757 d0 - a = f * b - a + 0.00000 00004 35417 d0 - b = f * a - b - 0.00000 00046 45555 d0 - a = f * b - a + 0.00000 00571 32218 d0 - b = f * a - b - 0.00000 08451 72048 d0 - a = f * b - a + 0.00001 61850 63810 d0 - b = f * a - b - 0.00046 84750 28167 d0 - a = f * b - a + 0.03546 52912 43331 d0 - a = f * a - b + 2.07190 17175 44716 d0 - besik=0.626657068657750d0*(a-b)/sqrt(x) - if(e) return - z=besik - besik=0.0d0 - if(x .lt. 180.0d0) besik=exp(-x)*z - return - 9 besik=0.0d0 - write(nout,100) x - 100 format(1x,'besik ... non-positive argument x = ',e15.4) - return -c - end -c -c -c routines for conical function: end -c -c -c factorial function -c - function fact(k) - real*8 fact - fact=0.0d0 - if(k.lt.0) return - fact=1.0d0 - if(k.eq.0) return - do i=1,k - fact=fact*i - end do - return - end -c - FUNCTION gamm(xx) - DOUBLE PRECISION gamm,xx -c Returns the value Gamma(xx) for xx > 0. - INTEGER j - DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) - SAVE cof,stp - DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, - * 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, - * -.5395239384953d-5,2.5066282746310005d0/ - x=xx - y=x - tmp=x+5.5d0 - tmp=(x+0.5d0)*log(tmp)-tmp - ser=1.000000000190015d0 - do j=1,6 - y=y+1.d0 - ser=ser+cof(j)/y - end do - gamm=exp(tmp)*(stp*ser/x) - return - END -c -c -c -c PLASMA DISPERSION FUNCTION Z of complex argument -c Z(z) = i sqrt(pi) w(z) -c Function w(z) from: -c algorithm 680, collected algorithms from acm. -c this work published in transactions on mathematical software, -c vol. 16, no. 1, pp. 47. -c - subroutine zetac (xi, yi, zr, zi, iflag) -c -c given a complex number z = (xi,yi), this subroutine computes -c the value of the faddeeva-function w(z) = exp(-z**2)*erfc(-i*z), -c where erfc is the complex complementary error-function and i -c means sqrt(-1). -c the accuracy of the algorithm for z in the 1st and 2nd quadrant -c is 14 significant digits; in the 3rd and 4th it is 13 significant -c digits outside a circular region with radius 0.126 around a zero -c of the function. -c all real variables in the program are double precision. -c -c -c the code contains a few compiler-dependent parameters : -c rmaxreal = the maximum value of rmaxreal equals the root of -c rmax = the largest number which can still be -c implemented on the computer in double precision -c floating-point arithmetic -c rmaxexp = ln(rmax) - ln(2) -c rmaxgoni = the largest possible argument of a double precision -c goniometric function (dcos, dsin, ...) -c the reason why these parameters are needed as they are defined will -c be explained in the code by means of comments -c -c -c parameter list -c xi = real part of z -c yi = imaginary part of z -c u = real part of w(z) -c v = imaginary part of w(z) -c iflag = an error flag indicating whether overflow will -c occur or not; type integer; -c the values of this variable have the following -c meaning : -c iflag=0 : no error condition -c iflag=1 : overflow will occur, the routine -c becomes inactive -c xi, yi are the input-parameters -c u, v, iflag are the output-parameters -c -c furthermore the parameter factor equals 2/sqrt(pi) -c -c the routine is not underflow-protected but any variable can be -c put to 0 upon underflow; -c -c reference - gpm poppe, cmj wijers; more efficient computation of -c the complex error-function, acm trans. math. software. -c -* -* -* -* - implicit double precision (a-h, o-z) -* - parameter (factor = 1.12837916709551257388d0, - * rpi = 2.0d0/factor, - * rmaxreal = 0.5d+154, - * rmaxexp = 708.503061461606d0, - * rmaxgoni = 3.53711887601422d+15) -* - iflag=0 -* - xabs = dabs(xi) - yabs = dabs(yi) - x = xabs/6.3d0 - y = yabs/4.4d0 -* -c -c the following if-statement protects -c qrho = (x**2 + y**2) against overflow -c - if ((xabs.gt.rmaxreal).or.(yabs.gt.rmaxreal)) goto 100 -* - qrho = x**2 + y**2 -* - xabsq = xabs**2 - xquad = xabsq - yabs**2 - yquad = 2*xabs*yabs -* - if (qrho.lt.0.085264d0) then -c -c if (qrho.lt.0.085264d0) then the faddeeva-function is evaluated -c using a power-series (abramowitz/stegun, equation (7.1.5), p.297) -c n is the minimum number of terms needed to obtain the required -c accuracy -c - qrho = (1-0.85d0*y)*dsqrt(qrho) - n = idnint(6 + 72*qrho) - j = 2*n+1 - xsum = 1.0d0/j - ysum = 0.0d0 - do 10 i=n, 1, -1 - j = j - 2 - xaux = (xsum*xquad - ysum*yquad)/i - ysum = (xsum*yquad + ysum*xquad)/i - xsum = xaux + 1.0d0/j - 10 continue - u1 = -factor*(xsum*yabs + ysum*xabs) + 1.0d0 - v1 = factor*(xsum*xabs - ysum*yabs) - daux = dexp(-xquad) - u2 = daux*dcos(yquad) - v2 = -daux*dsin(yquad) -* - u = u1*u2 - v1*v2 - v = u1*v2 + v1*u2 -* - else -c -c if (qrho.gt.1.o) then w(z) is evaluated using the laplace -c continued fraction -c nu is the minimum number of terms needed to obtain the required -c accuracy -c -c if ((qrho.gt.0.085264d0).and.(qrho.lt.1.0)) then w(z) is evaluated -c by a truncated taylor expansion, where the laplace continued fraction -c is used to calculate the derivatives of w(z) -c kapn is the minimum number of terms in the taylor expansion needed -c to obtain the required accuracy -c nu is the minimum number of terms of the continued fraction needed -c to calculate the derivatives with the required accuracy -c -* - if (qrho.gt.1.0d0) then - h = 0.0d0 - kapn = 0 - qrho = dsqrt(qrho) - nu = idint(3 + (1442/(26*qrho+77))) - else - qrho = (1-y)*dsqrt(1-qrho) - h = 1.88d0*qrho - h2 = 2*h - kapn = idnint(7 + 34*qrho) - nu = idnint(16 + 26*qrho) - endif -* - if (h.gt.0.0d0) qlambda = h2**kapn -* - rx = 0.0d0 - ry = 0.0d0 - sx = 0.0d0 - sy = 0.0d0 -* - do 11 n=nu, 0, -1 - np1 = n + 1 - tx = yabs + h + np1*rx - ty = xabs - np1*ry - c = 0.5d0/(tx**2 + ty**2) - rx = c*tx - ry = c*ty - if ((h.gt.0.0d0).and.(n.le.kapn)) then - tx = qlambda + sx - sx = rx*tx - ry*sy - sy = ry*tx + rx*sy - qlambda = qlambda/h2 - endif - 11 continue -* - if (h.eq.0.0d0) then - u = factor*rx - v = factor*ry - else - u = factor*sx - v = factor*sy - end if -* - if (yabs.eq.0.0d0) u = dexp(-xabs**2) -* - end if -* -* -c -c evaluation of w(z) in the other quadrants -c -* - if (yi.lt.0.0d0) then -* - if (qrho.lt.0.085264d0) then - u2 = 2*u2 - v2 = 2*v2 - else - xquad = -xquad -* -c -c the following if-statement protects 2*exp(-z**2) -c against overflow -c - if ((yquad.gt.rmaxgoni).or. - * (xquad.gt.rmaxexp)) goto 100 -* - w1 = 2.0d0*dexp(xquad) - u2 = w1*dcos(yquad) - v2 = -w1*dsin(yquad) - end if -* - u = u2 - u - v = v2 - v - if (xi.gt.0.0d0) v = -v - else - if (xi.lt.0.0d0) v = -v - end if -* - zr = -v*rpi - zi = u*rpi -* - - return -* - 100 iflag=1 -* - return -* - end -c -c -c Integration routine dqags.f from quadpack and dependencies: BEGIN -c -c - subroutine dqags(f,a,b,epsabs,epsrel,result,abserr,neval,ier, - * limit,lenw,last,iwork,work) -c***begin prologue dqags -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a1 -c***keywords automatic integrator, general-purpose, -c (end-point) singularities, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & prog. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)). -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more sub- -c divisions by increasing the value of limit -c (and taking the according dimension -c adjustments into account. however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is detec- -c ted, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour -c occurs at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. it is presumed that -c the requested tolerance cannot be -c achieved, and that the returned result is -c the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28) -c or limit.lt.1 or lenw.lt.limit*4. -c result, abserr, neval, last are set to -c zero.except when limit or lenw is invalid, -c iwork(1), work(limit*2+1) and -c work(limit*3+1) are set to zero, work(1) -c is set to a and work(limit+1) to b. -c -c dimensioning parameters -c limit - integer -c dimensioning parameter for iwork -c limit determines the maximum number of subintervals -c in the partition of the given integration interval -c (a,b), limit.ge.1. -c if limit.lt.1, the routine will end with ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least limit*4. -c if lenw.lt.limit*4, the routine will end -c with ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdivision process, detemines the -c number of significant elements actually in the work -c arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least limit, the first k -c elements of which contain pointers -c to the error estimates over the subintervals -c such that work(limit*3+iwork(1)),... , -c work(limit*3+iwork(k)) form a decreasing -c sequence, with k = last if last.le.(limit/2+2), -c and k = limit+1-last otherwise -c -c work - double precision -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left -c end-points of the subintervals in the -c partition of (a,b), -c work(limit+1), ..., work(limit+last) contain -c the right end-points, -c work(limit*2+1), ..., work(limit*2+last) contain -c the integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3+last) -c contain the error estimates. -c -c***references (none) -c***routines called dqagse,xerror -c***end prologue dqags -c -c - double precision a,abserr,b,epsabs,epsrel,f,result,work - integer ier,iwork,last,lenw,limit,lvl,l1,l2,l3,neval -c - dimension iwork(limit),work(lenw) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement dqags - ier = 6 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - if(limit.lt.1.or.lenw.lt.limit*4) go to 10 -c -c prepare call for dqagse. -c - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 -c - call dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, - * ier,work(1),work(l1),work(l2),work(l3),iwork,last) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 - if(ier.ne.0) print*,'habnormal return from dqags',ier,lvl - return - end -c - subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, - * ier,alist,blist,rlist,elist,iord,last) -c***begin prologue dqagse -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a1 -c***keywords automatic integrator, general-purpose, -c (end point) singularities, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)). -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c limit - integer -c gives an upperbound on the number of subintervals -c in the partition of (a,b) -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more sub- -c divisions by increasing the value of limit -c (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is detec- -c ted, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour -c occurs at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is presumed that the requested -c tolerance cannot be achieved, and that the -c returned result is the best which can be -c obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28). -c result, abserr, neval, last, rlist(1), -c iord(1) and elist(1) are set to zero. -c alist(1) and blist(1) are set to a and b -c respectively. -c -c alist - double precision -c vector of dimension at least limit, the first -c last elements of which are the left end points -c of the subintervals in the partition of the -c given integration range (a,b) -c -c blist - double precision -c vector of dimension at least limit, the first -c last elements of which are the right end points -c of the subintervals in the partition of the given -c integration range (a,b) -c -c rlist - double precision -c vector of dimension at least limit, the first -c last elements of which are the integral -c approximations on the subintervals -c -c elist - double precision -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c iord - integer -c vector of dimension at least limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., elist(iord(k)) -c form a decreasing sequence, with k = last -c if last.le.(limit/2+2), and k = limit+1-last -c otherwise -c -c last - integer -c number of subintervals actually produced in the -c subdivision process -c -c***references (none) -c***routines called d1mach,dqelg,dqk21,dqpsrt -c***end prologue dqagse -c - double precision a,abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,d1mach,dmax1, - * dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd,errmax, - * error1,error2,erro12,errsum,ertest,f,oflow,resabs,reseps,result, - * res3la,rlist,rlist2,small,uflow - integer id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, - * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 - logical extrap,noext -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * res3la(3),rlist(limit),rlist2(52) -c - external f -c -c the dimension of rlist2 is determined by the value of -c limexp in subroutine dqelg (rlist2 should be of dimension -c (limexp+2) at least). -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c rlist2 - array of dimension at least limexp+2 containing -c the part of the epsilon table which is still -c needed for further computations -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest error -c estimate -c errmax - elist(maxerr) -c erlast - error on the interval currently subdivided -c (before that subdivision has taken place) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left interval -c *****2 - variable for the right interval -c last - index for subdivision -c nres - number of calls to the extrapolation routine -c numrl2 - number of elements currently in rlist2. if an -c appropriate approximation to the compounded -c integral has been obtained it is put in -c rlist2(numrl2) after numrl2 has been increased -c by one. -c small - length of the smallest interval considered up -c to now, multiplied by 1.5 -c erlarg - sum of the errors over the intervals larger -c than the smallest interval considered up to now -c extrap - logical variable denoting that the routine is -c attempting to perform extrapolation i.e. before -c subdividing the smallest interval we try to -c decrease the value of erlarg. -c noext - logical variable denoting that extrapolation -c is no longer allowed (true value) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c oflow is the largest positive magnitude. -c -c***first executable statement dqagse - epmach = d1mach(4) -c -c test on validity of parameters -c ------------------------------ - ier = 0 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - alist(1) = a - blist(1) = b - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - if(epsabs.le.0.0d+00.and.epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) - * ier = 6 - if(ier.eq.6) go to 999 -c -c first approximation to the integral -c ----------------------------------- -c - uflow = d1mach(1) - oflow = d1mach(2) - ierro = 0 - call dqk21(f,a,b,result,abserr,defabs,resabs) -c -c test on accuracy. -c - dres = dabs(result) - errbnd = dmax1(epsabs,epsrel*dres) - last = 1 - rlist(1) = result - elist(1) = abserr - iord(1) = 1 - if(abserr.le.1.0d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 - if(limit.eq.1) ier = 1 - if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. - * abserr.eq.0.0d+00) go to 140 -c -c initialization -c -------------- -c - rlist2(1) = result - errmax = abserr - maxerr = 1 - area = result - errsum = abserr - abserr = oflow - nrmax = 1 - nres = 0 - numrl2 = 2 - ktmin = 0 - extrap = .false. - noext = .false. - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ksgn = -1 - if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 90 last = 2,limit -c -c bisect the subinterval with the nrmax-th largest error -c estimate. -c - a1 = alist(maxerr) - b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - erlast = errmax - call dqk21(f,a1,b1,area1,error1,resabs,defab1) - call dqk21(f,a2,b2,area2,error2,resabs,defab2) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2) go to 15 - if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) - * .or.erro12.lt.0.99d+00*errmax) go to 10 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 15 rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = dmax1(epsabs,epsrel*dabs(area)) -c -c test for roundoff error and eventually set error flag. -c - if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 - if(iroff2.ge.5) ierro = 3 -c -c set error flag in the case that the number of subintervals -c equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at a point of the integration range. -c - if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* - * (dabs(a2)+0.1d+04*uflow)) ier = 4 -c -c append the newly-created intervals to the list. -c - if(error2.gt.error1) go to 20 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 30 - 20 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine dqpsrt to maintain the descending ordering -c in the list of error estimates and select the subinterval -c with nrmax-th largest error estimate (to be bisected next). -c - 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) -c ***jump out of do-loop - if(errsum.le.errbnd) go to 115 -c ***jump out of do-loop - if(ier.ne.0) go to 100 - if(last.eq.2) go to 80 - if(noext) go to 90 - erlarg = erlarg-erlast - if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12 - if(extrap) go to 40 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - extrap = .true. - nrmax = 2 - 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors over the -c larger intervals (erlarg) and perform extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 50 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) -c ***jump out of do-loop - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - nrmax = nrmax+1 - 50 continue -c -c perform extrapolation. -c - 60 numrl2 = numrl2+1 - rlist2(numrl2) = area - call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) - ktmin = ktmin+1 - if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5 - if(abseps.ge.abserr) go to 70 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = dmax1(epsabs,epsrel*dabs(reseps)) -c ***jump out of do-loop - if(abserr.le.ertest) go to 100 -c -c prepare bisection of the smallest interval. -c - 70 if(numrl2.eq.1) noext = .true. - if(ier.eq.5) go to 100 - maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - small = small*0.5d+00 - erlarg = errsum - go to 90 - 80 small = dabs(b-a)*0.375d+00 - erlarg = errsum - ertest = errbnd - rlist2(2) = area - 90 continue -c -c set final result and error estimate. -c ------------------------------------ -c - 100 if(abserr.eq.oflow) go to 115 - if(ier+ierro.eq.0) go to 110 - if(ierro.eq.3) abserr = abserr+correc - if(ier.eq.0) ier = 3 - if(result.ne.0.0d+00.and.area.ne.0.0d+00) go to 105 - if(abserr.gt.errsum) go to 115 - if(area.eq.0.0d+00) go to 130 - go to 110 - 105 if(abserr/dabs(result).gt.errsum/dabs(area)) go to 115 -c -c test on divergence. -c - 110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. - * defabs*0.1d-01) go to 130 - if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03 - * .or.errsum.gt.dabs(area)) ier = 6 - go to 130 -c -c compute global integral sum. -c - 115 result = 0.0d+00 - do 120 k = 1,last - result = result+rlist(k) - 120 continue - abserr = errsum - 130 if(ier.gt.2) ier = ier-1 - 140 neval = 42*last-21 - 999 return - end -c - subroutine dqelg(n,epstab,result,abserr,res3la,nres) -c***begin prologue dqelg -c***refer to dqagie,dqagoe,dqagpe,dqagse -c***routines called d1mach -c***revision date 830518 (yymmdd) -c***keywords epsilon algorithm, convergence acceleration, -c extrapolation -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math & progr. div. - k.u.leuven -c***purpose the routine determines the limit of a given sequence of -c approximations, by means of the epsilon algorithm of -c p.wynn. an estimate of the absolute error is also given. -c the condensed epsilon table is computed. only those -c elements needed for the computation of the next diagonal -c are preserved. -c***description -c -c epsilon algorithm -c standard fortran subroutine -c double precision version -c -c parameters -c n - integer -c epstab(n) contains the new element in the -c first column of the epsilon table. -c -c epstab - double precision -c vector of dimension 52 containing the elements -c of the two lower diagonals of the triangular -c epsilon table. the elements are numbered -c starting at the right-hand corner of the -c triangle. -c -c result - double precision -c resulting approximation to the integral -c -c abserr - double precision -c estimate of the absolute error computed from -c result and the 3 previous results -c -c res3la - double precision -c vector of dimension 3 containing the last 3 -c results -c -c nres - integer -c number of calls to the routine -c (should be zero at first call) -c -c***end prologue dqelg -c - double precision abserr,dabs,delta1,delta2,delta3,dmax1,d1mach, - * epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3, - * oflow,res,result,res3la,ss,tol1,tol2,tol3 - integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num - dimension epstab(52),res3la(3) -c -c list of major variables -c ----------------------- -c -c e0 - the 4 elements on which the computation of a new -c e1 element in the epsilon table is based -c e2 -c e3 e0 -c e3 e1 new -c e2 -c newelm - number of elements to be computed in the new -c diagonal -c error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) -c result - the element in the new diagonal with least value -c of error -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c oflow is the largest positive magnitude. -c limexp is the maximum number of elements the epsilon -c table can contain. if this number is reached, the upper -c diagonal of the epsilon table is deleted. -c -c***first executable statement dqelg - epmach = d1mach(4) - oflow = d1mach(2) - nres = nres+1 - abserr = oflow - result = epstab(n) - if(n.lt.3) go to 100 - limexp = 50 - epstab(n+2) = epstab(n) - newelm = (n-1)/2 - epstab(n) = oflow - num = n - k1 = n - do 40 i = 1,newelm - k2 = k1-1 - k3 = k1-2 - res = epstab(k1+2) - e0 = epstab(k3) - e1 = epstab(k2) - e2 = res - e1abs = dabs(e1) - delta2 = e2-e1 - err2 = dabs(delta2) - tol2 = dmax1(dabs(e2),e1abs)*epmach - delta3 = e1-e0 - err3 = dabs(delta3) - tol3 = dmax1(e1abs,dabs(e0))*epmach - if(err2.gt.tol2.or.err3.gt.tol3) go to 10 -c -c if e0, e1 and e2 are equal to within machine -c accuracy, convergence is assumed. -c result = e2 -c abserr = abs(e1-e0)+abs(e2-e1) -c - result = res - abserr = err2+err3 -c ***jump out of do-loop - go to 100 - 10 e3 = epstab(k1) - epstab(k1) = e1 - delta1 = e1-e3 - err1 = dabs(delta1) - tol1 = dmax1(e1abs,dabs(e3))*epmach -c -c if two elements are very close to each other, omit -c a part of the table by adjusting the value of n -c - if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20 - ss = 0.1d+01/delta1+0.1d+01/delta2-0.1d+01/delta3 - epsinf = dabs(ss*e1) -c -c test to detect irregular behaviour in the table, and -c eventually omit a part of the table adjusting the value -c of n. -c - if(epsinf.gt.0.1d-03) go to 30 - 20 n = i+i-1 -c ***jump out of do-loop - go to 50 -c -c compute a new element and eventually adjust -c the value of result. -c - 30 res = e1+0.1d+01/ss - epstab(k1) = res - k1 = k1-2 - error = err2+dabs(res-e2)+err3 - if(error.gt.abserr) go to 40 - abserr = error - result = res - 40 continue -c -c shift the table. -c - 50 if(n.eq.limexp) n = 2*(limexp/2)-1 - ib = 1 - if((num/2)*2.eq.num) ib = 2 - ie = newelm+1 - do 60 i=1,ie - ib2 = ib+2 - epstab(ib) = epstab(ib2) - ib = ib2 - 60 continue - if(num.eq.n) go to 80 - indx = num-n+1 - do 70 i = 1,n - epstab(i)= epstab(indx) - indx = indx+1 - 70 continue - 80 if(nres.ge.4) go to 90 - res3la(nres) = result - abserr = oflow - go to 100 -c -c compute error estimate -c - 90 abserr = dabs(result-res3la(3))+dabs(result-res3la(2)) - * +dabs(result-res3la(1)) - res3la(1) = res3la(2) - res3la(2) = res3la(3) - res3la(3) = result - 100 abserr = dmax1(abserr,0.5d+01*epmach*dabs(result)) - return - end -c - subroutine dqk21(f,a,b,result,abserr,resabs,resasc) -c***begin prologue dqk21 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 21-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b), with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 21-point -c kronrod rule (resk) obtained by optimal addition -c of abscissae to the 10-point gauss rule (resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should not exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk21 -c - double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, - * resg,resk,reskh,result,uflow,wg,wgk,xgk - integer j,jtw,jtwm1 - external f -c - dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11) -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 21-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 10-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 10-point gauss rule -c -c wgk - weights of the 21-point kronrod rule -c -c wg - weights of the 10-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.0666713443 0868813759 3568809893 332 d0 / - data wg ( 2) / 0.1494513491 5058059314 5776339657 697 d0 / - data wg ( 3) / 0.2190863625 1598204399 5534934228 163 d0 / - data wg ( 4) / 0.2692667193 0999635509 1226921569 469 d0 / - data wg ( 5) / 0.2955242247 1475287017 3892994651 338 d0 / -c - data xgk ( 1) / 0.9956571630 2580808073 5527280689 003 d0 / - data xgk ( 2) / 0.9739065285 1717172007 7964012084 452 d0 / - data xgk ( 3) / 0.9301574913 5570822600 1207180059 508 d0 / - data xgk ( 4) / 0.8650633666 8898451073 2096688423 493 d0 / - data xgk ( 5) / 0.7808177265 8641689706 3717578345 042 d0 / - data xgk ( 6) / 0.6794095682 9902440623 4327365114 874 d0 / - data xgk ( 7) / 0.5627571346 6860468333 9000099272 694 d0 / - data xgk ( 8) / 0.4333953941 2924719079 9265943165 784 d0 / - data xgk ( 9) / 0.2943928627 0146019813 1126603103 866 d0 / - data xgk ( 10) / 0.1488743389 8163121088 4826001129 720 d0 / - data xgk ( 11) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0116946388 6737187427 8064396062 192 d0 / - data wgk ( 2) / 0.0325581623 0796472747 8818972459 390 d0 / - data wgk ( 3) / 0.0547558965 7435199603 1381300244 580 d0 / - data wgk ( 4) / 0.0750396748 1091995276 7043140916 190 d0 / - data wgk ( 5) / 0.0931254545 8369760553 5065465083 366 d0 / - data wgk ( 6) / 0.1093871588 0229764189 9210590325 805 d0 / - data wgk ( 7) / 0.1234919762 6206585107 7958109831 074 d0 / - data wgk ( 8) / 0.1347092173 1147332592 8054001771 707 d0 / - data wgk ( 9) / 0.1427759385 7706008079 7094273138 717 d0 / - data wgk ( 10) / 0.1477391049 0133849137 4841515972 068 d0 / - data wgk ( 11) / 0.1494455540 0291690566 4936468389 821 d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 10-point gauss formula -c resk - result of the 21-point kronrod formula -c reskh - approximation to the mean value of f over (a,b), -c i.e. to i/(b-a) -c -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk21 - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 21-point kronrod approximation to -c the integral, and estimate the absolute error. -c - resg = 0.0d+00 - fc = f(centr) - resk = wgk(11)*fc - resabs = dabs(resk) - do 10 j=1,5 - jtw = 2*j - absc = hlgth*xgk(jtw) - fval1 = f(centr-absc) - fval2 = f(centr+absc) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j = 1,5 - jtwm1 = 2*j-1 - absc = hlgth*xgk(jtwm1) - fval1 = f(centr-absc) - fval2 = f(centr+absc) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(11)*dabs(fc-reskh) - do 20 j=1,10 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end -c - subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) -c***begin prologue dqpsrt -c***refer to dqage,dqagie,dqagpe,dqawse -c***routines called (none) -c***revision date 810101 (yymmdd) -c***keywords sequential sorting -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose this routine maintains the descending ordering in the -c list of the local error estimated resulting from the -c interval subdivision process. at each call two error -c estimates are inserted using the sequential search -c method, top-down for the largest error estimate and -c bottom-up for the smallest error estimate. -c***description -c -c ordering routine -c standard fortran subroutine -c double precision version -c -c parameters (meaning at output) -c limit - integer -c maximum number of error estimates the list -c can contain -c -c last - integer -c number of error estimates currently in the list -c -c maxerr - integer -c maxerr points to the nrmax-th largest error -c estimate currently in the list -c -c ermax - double precision -c nrmax-th largest error estimate -c ermax = elist(maxerr) -c -c elist - double precision -c vector of dimension last containing -c the error estimates -c -c iord - integer -c vector of dimension last, the first k elements -c of which contain pointers to the error -c estimates, such that -c elist(iord(1)),..., elist(iord(k)) -c form a decreasing sequence, with -c k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c nrmax - integer -c maxerr = iord(nrmax) -c -c***end prologue dqpsrt -c - double precision elist,ermax,errmax,errmin - integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, - * nrmax - dimension elist(last),iord(last) -c -c check whether the list contains more than -c two error estimates. -c -c***first executable statement dqpsrt - if(last.gt.2) go to 10 - iord(1) = 1 - iord(2) = 2 - go to 90 -c -c this part of the routine is only executed if, due to a -c difficult integrand, subdivision increased the error -c estimate. in the normal case the insert procedure should -c start after the nrmax-th largest error estimate. -c - 10 errmax = elist(maxerr) - if(nrmax.eq.1) go to 30 - ido = nrmax-1 - do 20 i = 1,ido - isucc = iord(nrmax-1) -c ***jump out of do-loop - if(errmax.le.elist(isucc)) go to 30 - iord(nrmax) = isucc - nrmax = nrmax-1 - 20 continue -c -c compute the number of elements in the list to be maintained -c in descending order. this number depends on the number of -c subdivisions still allowed. -c - 30 jupbn = last - if(last.gt.(limit/2+2)) jupbn = limit+3-last - errmin = elist(last) -c -c insert errmax by traversing the list top-down, -c starting comparison from the element elist(iord(nrmax+1)). -c - jbnd = jupbn-1 - ibeg = nrmax+1 - if(ibeg.gt.jbnd) go to 50 - do 40 i=ibeg,jbnd - isucc = iord(i) -c ***jump out of do-loop - if(errmax.ge.elist(isucc)) go to 60 - iord(i-1) = isucc - 40 continue - 50 iord(jbnd) = maxerr - iord(jupbn) = last - go to 90 -c -c insert errmin by traversing the list bottom-up. -c - 60 iord(i-1) = maxerr - k = jbnd - do 70 j=i,jbnd - isucc = iord(k) -c ***jump out of do-loop - if(errmin.lt.elist(isucc)) go to 80 - iord(k+1) = isucc - k = k-1 - 70 continue - iord(i) = last - go to 90 - 80 iord(k+1) = last -c -c set maxerr and ermax. -c - 90 maxerr = iord(nrmax) - ermax = elist(maxerr) - return - end -c - subroutine dqagi(f,bound,inf,epsabs,epsrel,result,abserr,neval, - * ier,limit,lenw,last,iwork,work) -c***begin prologue dqagi -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a1,h2a4a1 -c***keywords automatic integrator, infinite intervals, -c general-purpose, transformation, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. -k.u.leuven -c***purpose the routine calculates an approximation result to a given -c integral i = integral of f over (bound,+infinity) -c or i = integral of f over (-infinity,bound) -c or i = integral of f over (-infinity,+infinity) -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)). -c***description -c -c integration over infinite intervals -c standard fortran subroutine -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c bound - double precision -c finite bound of integration range -c (has no meaning if interval is doubly-infinite) -c -c inf - integer -c indicating the kind of integration range involved -c inf = 1 corresponds to (bound,+infinity), -c inf = -1 to (-infinity,bound), -c inf = 2 to (-infinity,+infinity). -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c - ier.gt.0 abnormal termination of the routine. the -c estimates for result and error are less -c reliable. it is assumed that the requested -c accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is assumed that the requested tolerance -c cannot be achieved, and that the returned -c result is the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c or limit.lt.1 or leniw.lt.limit*4. -c result, abserr, neval, last are set to -c zero. exept when limit or leniw is -c invalid, iwork(1), work(limit*2+1) and -c work(limit*3+1) are set to zero, work(1) -c is set to a and work(limit+1) to b. -c -c dimensioning parameters -c limit - integer -c dimensioning parameter for iwork -c limit determines the maximum number of subintervals -c in the partition of the given integration interval -c (a,b), limit.ge.1. -c if limit.lt.1, the routine will end with ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least limit*4. -c if lenw.lt.limit*4, the routine will end -c with ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdivision process, which -c determines the number of significant elements -c actually in the work arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least limit, the first -c k elements of which contain pointers -c to the error estimates over the subintervals, -c such that work(limit*3+iwork(1)),... , -c work(limit*3+iwork(k)) form a decreasing -c sequence, with k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c work - double precision -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left -c end points of the subintervals in the -c partition of (a,b), -c work(limit+1), ..., work(limit+last) contain -c the right end points, -c work(limit*2+1), ...,work(limit*2+last) contain the -c integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3) -c contain the error estimates. -c***references (none) -c***routines called dqagie,xerror -c***end prologue dqagi -c - double precision abserr,bound,epsabs,epsrel,f,result,work - integer ier,inf,iwork,last,lenw,limit,lvl,l1,l2,l3,neval -c - dimension iwork(limit),work(lenw) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement dqagi - ier = 6 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - if(limit.lt.1.or.lenw.lt.limit*4) go to 10 -c -c prepare call for dqagie. -c - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 -c - call dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, - * neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 - if(ier.ne.0) print*,'habnormal return from dqagi' - return - end -c - subroutine dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, - * neval,ier,alist,blist,rlist,elist,iord,last) -c***begin prologue dqagie -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a1,h2a4a1 -c***keywords automatic integrator, infinite intervals, -c general-purpose, transformation, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math & progr. div - k.u.leuven -c de doncker,elise,appl. math & progr. div - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c integral i = integral of f over (bound,+infinity) -c or i = integral of f over (-infinity,bound) -c or i = integral of f over (-infinity,+infinity), -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)) -c***description -c -c integration over infinite intervals -c standard fortran subroutine -c -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c bound - double precision -c finite bound of integration range -c (has no meaning if interval is doubly-infinite) -c -c inf - double precision -c indicating the kind of integration range involved -c inf = 1 corresponds to (bound,+infinity), -c inf = -1 to (-infinity,bound), -c inf = 2 to (-infinity,+infinity). -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c limit - integer -c gives an upper bound on the number of subintervals -c in the partition of (a,b), limit.ge.1 -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c - ier.gt.0 abnormal termination of the routine. the -c estimates for result and error are less -c reliable. it is assumed that the requested -c accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however,if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. -c if the position of a local difficulty can -c be determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is assumed that the requested tolerance -c cannot be achieved, and that the returned -c result is the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c result, abserr, neval, last, rlist(1), -c elist(1) and iord(1) are set to zero. -c alist(1) and blist(1) are set to 0 -c and 1 respectively. -c -c alist - double precision -c vector of dimension at least limit, the first -c last elements of which are the left -c end points of the subintervals in the partition -c of the transformed integration range (0,1). -c -c blist - double precision -c vector of dimension at least limit, the first -c last elements of which are the right -c end points of the subintervals in the partition -c of the transformed integration range (0,1). -c -c rlist - double precision -c vector of dimension at least limit, the first -c last elements of which are the integral -c approximations on the subintervals -c -c elist - double precision -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c iord - integer -c vector of dimension limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., elist(iord(k)) -c form a decreasing sequence, with k = last -c if last.le.(limit/2+2), and k = limit+1-last -c otherwise -c -c last - integer -c number of subintervals actually produced -c in the subdivision process -c -c***references (none) -c***routines called d1mach,dqelg,dqk15i,dqpsrt -c***end prologue dqagie - double precision abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,blist,boun,bound,b1,b2,correc,dabs,defabs,defab1,defab2, - * dmax1,dres,d1mach,elist,epmach,epsabs,epsrel,erlarg,erlast, - * errbnd,errmax,error1,error2,erro12,errsum,ertest,f,oflow,resabs, - * reseps,result,res3la,rlist,rlist2,small,uflow - integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, - * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 - logical extrap,noext -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * res3la(3),rlist(limit),rlist2(52) -c - external f -c -c the dimension of rlist2 is determined by the value of -c limexp in subroutine dqelg. -c -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c rlist2 - array of dimension at least (limexp+2), -c containing the part of the epsilon table -c wich is still needed for further computations -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest error -c estimate -c errmax - elist(maxerr) -c erlast - error on the interval currently subdivided -c (before that subdivision has taken place) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left subinterval -c *****2 - variable for the right subinterval -c last - index for subdivision -c nres - number of calls to the extrapolation routine -c numrl2 - number of elements currently in rlist2. if an -c appropriate approximation to the compounded -c integral has been obtained, it is put in -c rlist2(numrl2) after numrl2 has been increased -c by one. -c small - length of the smallest interval considered up -c to now, multiplied by 1.5 -c erlarg - sum of the errors over the intervals larger -c than the smallest interval considered up to now -c extrap - logical variable denoting that the routine -c is attempting to perform extrapolation. i.e. -c before subdividing the smallest interval we -c try to decrease the value of erlarg. -c noext - logical variable denoting that extrapolation -c is no longer allowed (true-value) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c oflow is the largest positive magnitude. -c -c***first executable statement dqagie - epmach = d1mach(4) -c -c test on validity of parameters -c ----------------------------- -c - ier = 0 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - alist(1) = 0.0d+00 - blist(1) = 0.1d+01 - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - iord(1) = 0 - if(epsabs.le.0.0d+00.and.epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) - * ier = 6 - if(ier.eq.6) go to 999 -c -c -c first approximation to the integral -c ----------------------------------- -c -c determine the interval to be mapped onto (0,1). -c if inf = 2 the integral is computed as i = i1+i2, where -c i1 = integral of f over (-infinity,0), -c i2 = integral of f over (0,+infinity). -c - boun = bound - if(inf.eq.2) boun = 0.0d+00 - call dqk15i(f,boun,inf,0.0d+00,0.1d+01,result,abserr, - * defabs,resabs) -c -c test on accuracy -c - last = 1 - rlist(1) = result - elist(1) = abserr - iord(1) = 1 - dres = dabs(result) - errbnd = dmax1(epsabs,epsrel*dres) - if(abserr.le.1.0d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 - if(limit.eq.1) ier = 1 - if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. - * abserr.eq.0.0d+00) go to 130 -c -c initialization -c -------------- -c - uflow = d1mach(1) - oflow = d1mach(2) - rlist2(1) = result - errmax = abserr - maxerr = 1 - area = result - errsum = abserr - abserr = oflow - nrmax = 1 - nres = 0 - ktmin = 0 - numrl2 = 2 - extrap = .false. - noext = .false. - ierro = 0 - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ksgn = -1 - if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 90 last = 2,limit -c -c bisect the subinterval with nrmax-th largest error estimate. -c - a1 = alist(maxerr) - b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - erlast = errmax - call dqk15i(f,boun,inf,a1,b1,area1,error1,resabs,defab1) - call dqk15i(f,boun,inf,a2,b2,area2,error2,resabs,defab2) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2)go to 15 - if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) - * .or.erro12.lt.0.99d+00*errmax) go to 10 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 15 rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = dmax1(epsabs,epsrel*dabs(area)) -c -c test for roundoff error and eventually set error flag. -c - if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 - if(iroff2.ge.5) ierro = 3 -c -c set error flag in the case that the number of -c subintervals equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at some points of the integration range. -c - if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* - * (dabs(a2)+0.1d+04*uflow)) ier = 4 -c -c append the newly-created intervals to the list. -c - if(error2.gt.error1) go to 20 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 30 - 20 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine dqpsrt to maintain the descending ordering -c in the list of error estimates and select the subinterval -c with nrmax-th largest error estimate (to be bisected next). -c - 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) - if(errsum.le.errbnd) go to 115 - if(ier.ne.0) go to 100 - if(last.eq.2) go to 80 - if(noext) go to 90 - erlarg = erlarg-erlast - if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12 - if(extrap) go to 40 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - extrap = .true. - nrmax = 2 - 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors over the -c larger intervals (erlarg) and perform extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 50 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) - if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - nrmax = nrmax+1 - 50 continue -c -c perform extrapolation. -c - 60 numrl2 = numrl2+1 - rlist2(numrl2) = area - call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) - ktmin = ktmin+1 - if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5 - if(abseps.ge.abserr) go to 70 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = dmax1(epsabs,epsrel*dabs(reseps)) - if(abserr.le.ertest) go to 100 -c -c prepare bisection of the smallest interval. -c - 70 if(numrl2.eq.1) noext = .true. - if(ier.eq.5) go to 100 - maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - small = small*0.5d+00 - erlarg = errsum - go to 90 - 80 small = 0.375d+00 - erlarg = errsum - ertest = errbnd - rlist2(2) = area - 90 continue -c -c set final result and error estimate. -c ------------------------------------ -c - 100 if(abserr.eq.oflow) go to 115 - if((ier+ierro).eq.0) go to 110 - if(ierro.eq.3) abserr = abserr+correc - if(ier.eq.0) ier = 3 - if(result.ne.0.0d+00.and.area.ne.0.0d+00)go to 105 - if(abserr.gt.errsum)go to 115 - if(area.eq.0.0d+00) go to 130 - go to 110 - 105 if(abserr/dabs(result).gt.errsum/dabs(area))go to 115 -c -c test on divergence -c - 110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. - * defabs*0.1d-01) go to 130 - if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03. - *or.errsum.gt.dabs(area)) ier = 6 - go to 130 -c -c compute global integral sum. -c - 115 result = 0.0d+00 - do 120 k = 1,last - result = result+rlist(k) - 120 continue - abserr = errsum - 130 neval = 30*last-15 - if(inf.eq.2) neval = 2*neval - if(ier.gt.2) ier=ier-1 - 999 return - end -c - subroutine dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc) -c***begin prologue dqk15i -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a2,h2a4a2 -c***keywords 15-point transformed gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the original (infinite integration range is mapped -c onto the interval (0,1) and (a,b) is a part of (0,1). -c it is the purpose to compute -c i = integral of transformed integrand over (a,b), -c j = integral of abs(transformed integrand) over (a,b). -c***description -c -c integration rule -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c fuction subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the calling program. -c -c boun - double precision -c finite bound of original integration -c range (set to zero if inf = +2) -c -c inf - integer -c if inf = -1, the original interval is -c (-infinity,bound), -c if inf = +1, the original interval is -c (bound,+infinity), -c if inf = +2, the original interval is -c (-infinity,+infinity) and -c the integral is computed as the sum of two -c integrals, one over (-infinity,0) and one over -c (0,+infinity). -c -c a - double precision -c lower limit for integration over subrange -c of (0,1) -c -c b - double precision -c upper limit for integration over subrange -c of (0,1) -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 15-point -c kronrod rule(resk) obtained by optimal addition -c of abscissae to the 7-point gauss rule(resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of -c abs((transformed integrand)-i/(b-a)) over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk15i -c - double precision a,absc,absc1,absc2,abserr,b,boun,centr,dabs,dinf, - * dmax1,dmin1,d1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth, - * resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2,uflow,wg,wgk, - * xgk - integer inf,j - external f -c - dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8) -c -c the abscissae and weights are supplied for the interval -c (-1,1). because of symmetry only the positive abscissae and -c their corresponding weights are given. -c -c xgk - abscissae of the 15-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 7-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 7-point gauss rule -c -c wgk - weights of the 15-point kronrod rule -c -c wg - weights of the 7-point gauss rule, corresponding -c to the abscissae xgk(2), xgk(4), ... -c wg(1), wg(3), ... are set to zero. -c - data wg(1) / 0.0d0 / - data wg(2) / 0.1294849661 6886969327 0611432679 082d0 / - data wg(3) / 0.0d0 / - data wg(4) / 0.2797053914 8927666790 1467771423 780d0 / - data wg(5) / 0.0d0 / - data wg(6) / 0.3818300505 0511894495 0369775488 975d0 / - data wg(7) / 0.0d0 / - data wg(8) / 0.4179591836 7346938775 5102040816 327d0 / -c - data xgk(1) / 0.9914553711 2081263920 6854697526 329d0 / - data xgk(2) / 0.9491079123 4275852452 6189684047 851d0 / - data xgk(3) / 0.8648644233 5976907278 9712788640 926d0 / - data xgk(4) / 0.7415311855 9939443986 3864773280 788d0 / - data xgk(5) / 0.5860872354 6769113029 4144838258 730d0 / - data xgk(6) / 0.4058451513 7739716690 6606412076 961d0 / - data xgk(7) / 0.2077849550 0789846760 0689403773 245d0 / - data xgk(8) / 0.0000000000 0000000000 0000000000 000d0 / -c - data wgk(1) / 0.0229353220 1052922496 3732008058 970d0 / - data wgk(2) / 0.0630920926 2997855329 0700663189 204d0 / - data wgk(3) / 0.1047900103 2225018383 9876322541 518d0 / - data wgk(4) / 0.1406532597 1552591874 5189590510 238d0 / - data wgk(5) / 0.1690047266 3926790282 6583426598 550d0 / - data wgk(6) / 0.1903505780 6478540991 3256402421 014d0 / - data wgk(7) / 0.2044329400 7529889241 4161999234 649d0 / - data wgk(8) / 0.2094821410 8472782801 2999174891 714d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc* - abscissa -c tabsc* - transformed abscissa -c fval* - function value -c resg - result of the 7-point gauss formula -c resk - result of the 15-point kronrod formula -c reskh - approximation to the mean value of the transformed -c integrand over (a,b), i.e. to i/(b-a) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk15i - epmach = d1mach(4) - uflow = d1mach(1) - dinf = min0(1,inf) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - tabsc1 = boun+dinf*(0.1d+01-centr)/centr - fval1 = f(tabsc1) - if(inf.eq.2) fval1 = fval1+f(-tabsc1) - fc = (fval1/centr)/centr -c -c compute the 15-point kronrod approximation to -c the integral, and estimate the error. -c - resg = wg(8)*fc - resk = wgk(8)*fc - resabs = dabs(resk) - do 10 j=1,7 - absc = hlgth*xgk(j) - absc1 = centr-absc - absc2 = centr+absc - tabsc1 = boun+dinf*(0.1d+01-absc1)/absc1 - tabsc2 = boun+dinf*(0.1d+01-absc2)/absc2 - fval1 = f(tabsc1) - fval2 = f(tabsc2) - if(inf.eq.2) fval1 = fval1+f(-tabsc1) - if(inf.eq.2) fval2 = fval2+f(-tabsc2) - fval1 = (fval1/absc1)/absc1 - fval2 = (fval2/absc2)/absc2 - fv1(j) = fval1 - fv2(j) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(j)*fsum - resabs = resabs+wgk(j)*(dabs(fval1)+dabs(fval2)) - 10 continue - reskh = resk*0.5d+00 - resasc = wgk(8)*dabs(fc-reskh) - do 20 j=1,7 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resasc = resasc*hlgth - resabs = resabs*hlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.d0) abserr = resasc* - * dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end -c -c - double precision function d1mach(i) - integer i -c -c double-precision machine constants -c d1mach( 1) = b**(emin-1), the smallest positive magnitude. -c d1mach( 2) = b**emax*(1 - b**(-t)), the largest magnitude. -c d1mach( 3) = b**(-t), the smallest relative spacing. -c d1mach( 4) = b**(1-t), the largest relative spacing. -c d1mach( 5) = log10(b) -c - integer small(2) - integer large(2) - integer right(2) - integer diver(2) - integer log10(2) - integer sc, cray1(38), j - common /d9mach/ cray1 - save small, large, right, diver, log10, sc - double precision dmach(5) - equivalence (dmach(1),small(1)) - equivalence (dmach(2),large(1)) - equivalence (dmach(3),right(1)) - equivalence (dmach(4),diver(1)) - equivalence (dmach(5),log10(1)) -c this version adapts automatically to most current machines. -c r1mach can handle auto-double compiling, but this version of -c d1mach does not, because we do not have quad constants for -c many machines yet. -c to compile on older machines, add a c in column 1 -c on the next line - data sc/0/ -c and remove the c from column 1 in one of the sections below. -c constants for even older machines can be obtained by -c mail netlib@research.bell-labs.com -c send old1mach from blas -c please send corrections to dmg or ehg@bell-labs.com. -c -c machine constants for the honeywell dps 8/70 series. -c data small(1),small(2) / o402400000000, o000000000000 / -c data large(1),large(2) / o376777777777, o777777777777 / -c data right(1),right(2) / o604400000000, o000000000000 / -c data diver(1),diver(2) / o606400000000, o000000000000 / -c data log10(1),log10(2) / o776464202324, o117571775714 /, sc/987/ -c -c machine constants for pdp-11 fortrans supporting -c 32-bit integers. -c data small(1),small(2) / 8388608, 0 / -c data large(1),large(2) / 2147483647, -1 / -c data right(1),right(2) / 612368384, 0 / -c data diver(1),diver(2) / 620756992, 0 / -c data log10(1),log10(2) / 1067065498, -2063872008 /, sc/987/ -c -c machine constants for the univac 1100 series. -c data small(1),small(2) / o000040000000, o000000000000 / -c data large(1),large(2) / o377777777777, o777777777777 / -c data right(1),right(2) / o170540000000, o000000000000 / -c data diver(1),diver(2) / o170640000000, o000000000000 / -c data log10(1),log10(2) / o177746420232, o411757177572 /, sc/987/ -c -c on first call, if no data uncommented, test machine types. - if (sc .ne. 987) then - dmach(1) = 1.d13 - if ( small(1) .eq. 1117925532 - * .and. small(2) .eq. -448790528) then -* *** ieee big endian *** - small(1) = 1048576 - small(2) = 0 - large(1) = 2146435071 - large(2) = -1 - right(1) = 1017118720 - right(2) = 0 - diver(1) = 1018167296 - diver(2) = 0 - log10(1) = 1070810131 - log10(2) = 1352628735 - else if ( small(2) .eq. 1117925532 - * .and. small(1) .eq. -448790528) then -* *** ieee little endian *** - small(2) = 1048576 - small(1) = 0 - large(2) = 2146435071 - large(1) = -1 - right(2) = 1017118720 - right(1) = 0 - diver(2) = 1018167296 - diver(1) = 0 - log10(2) = 1070810131 - log10(1) = 1352628735 - else if ( small(1) .eq. -2065213935 - * .and. small(2) .eq. 10752) then -* *** vax with d_floating *** - small(1) = 128 - small(2) = 0 - large(1) = -32769 - large(2) = -1 - right(1) = 9344 - right(2) = 0 - diver(1) = 9472 - diver(2) = 0 - log10(1) = 546979738 - log10(2) = -805796613 - else if ( small(1) .eq. 1267827943 - * .and. small(2) .eq. 704643072) then -* *** ibm mainframe *** - small(1) = 1048576 - small(2) = 0 - large(1) = 2147483647 - large(2) = -1 - right(1) = 856686592 - right(2) = 0 - diver(1) = 873463808 - diver(2) = 0 - log10(1) = 1091781651 - log10(2) = 1352628735 - else if ( small(1) .eq. 1120022684 - * .and. small(2) .eq. -448790528) then -* *** convex c-1 *** - small(1) = 1048576 - small(2) = 0 - large(1) = 2147483647 - large(2) = -1 - right(1) = 1019215872 - right(2) = 0 - diver(1) = 1020264448 - diver(2) = 0 - log10(1) = 1072907283 - log10(2) = 1352628735 - else if ( small(1) .eq. 815547074 - * .and. small(2) .eq. 58688) then -* *** vax g-floating *** - small(1) = 16 - small(2) = 0 - large(1) = -32769 - large(2) = -1 - right(1) = 15552 - right(2) = 0 - diver(1) = 15568 - diver(2) = 0 - log10(1) = 1142112243 - log10(2) = 2046775455 - else - dmach(2) = 1.d27 + 1 - dmach(3) = 1.d27 - large(2) = large(2) - right(2) - if (large(2) .eq. 64 .and. small(2) .eq. 0) then - cray1(1) = 67291416 - do 10 j = 1, 20 - cray1(j+1) = cray1(j) + cray1(j) - 10 continue - cray1(22) = cray1(21) + 321322 - do 20 j = 22, 37 - cray1(j+1) = cray1(j) + cray1(j) - 20 continue - if (cray1(38) .eq. small(1)) then -* *** cray *** - call i1mcry(small(1), j, 8285, 8388608, 0) - small(2) = 0 - call i1mcry(large(1), j, 24574, 16777215, 16777215) - call i1mcry(large(2), j, 0, 16777215, 16777214) - call i1mcry(right(1), j, 16291, 8388608, 0) - right(2) = 0 - call i1mcry(diver(1), j, 16292, 8388608, 0) - diver(2) = 0 - call i1mcry(log10(1), j, 16383, 10100890, 8715215) - call i1mcry(log10(2), j, 0, 16226447, 9001388) - else - write(*,9000) - stop 779 - end if - else - write(*,9000) - stop 779 - end if - end if - sc = 987 - end if -* sanity check - if (dmach(4) .ge. 1.0d0) stop 778 - if (i .lt. 1 .or. i .gt. 5) then - write(*,*) 'd1mach(i): i =',i,' is out of bounds.' - stop - end if - d1mach = dmach(i) - return - 9000 format(/' adjust d1mach by uncommenting data statements'/ - *' appropriate for your machine.') - end -c - subroutine i1mcry(a, a1, b, c, d) -**** special computation for old cray machines **** - integer a, a1, b, c, d - a1 = 16777216*b + c - a = 16777216*a1 + d - end -c -c c subroutine surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) @@ -8281,2568 +4715,3 @@ c apply a newton iteration to improve the accuracy of the roots. 700 continue 800 return end -c -c -c hybrj1 from MINPACK -c - subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) - integer n,ldfjac,info,lwa - double precision tol - double precision x(n),fvec(n),fjac(ldfjac,n),wa(lwa) - external fcn -c ********** -c -c subroutine hybrj1 -c -c the purpose of hybrj1 is to find a zero of a system of -c n nonlinear functions in n variables by a modification -c of the powell hybrid method. this is done by using the -c more general nonlinear equation solver hybrj. the user -c must provide a subroutine which calculates the functions -c and the jacobian. -c -c the subroutine statement is -c -c subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) -c integer n,ldfjac,iflag -c double precision x(n),fvec(n),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c --------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of hybrj1. -c in this case set iflag to a negative integer. -c -c n is a positive integer input variable set to the number -c of functions and variables. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length n which contains -c the functions evaluated at the output x. -c -c fjac is an output n by n array which contains the -c orthogonal matrix q produced by the qr factorization -c of the final approximate jacobian. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c tol is a nonnegative input variable. termination occurs -c when the algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info = 2 number of calls to fcn with iflag = 1 has -c reached 100*(n+1). -c -c info = 3 tol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 4 iteration is not making good progress. -c -c wa is a work array of length lwa. -c -c lwa is a positive integer input variable not less than -c (n*(n+13))/2. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... hybrj -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer j,lr,maxfev,mode,nfev,njev,nprint - double precision factor,one,xtol,zero - data factor,one,zero /1.0d2,1.0d0,0.0d0/ - info = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. ldfjac .lt. n .or. tol .lt. zero - * .or. lwa .lt. (n*(n + 13))/2) go to 20 -c -c call hybrj. -c - maxfev = 100*(n + 1) - xtol = tol - mode = 2 - do 10 j = 1, n - wa(j) = one - 10 continue - nprint = 0 - lr = (n*(n + 1))/2 - call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode, - * factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1), - * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) - if (info .eq. 5) info = 4 - 20 continue - return -c -c last card of subroutine hybrj1. -c - end -c - subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, - * factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, - * wa3,wa4) - integer n,ldfjac,maxfev,mode,nprint,info,nfev,njev,lr - double precision xtol,factor - double precision x(n),fvec(n),fjac(ldfjac,n),diag(n),r(lr), - * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) -c ********** -c -c subroutine hybrj -c -c the purpose of hybrj is to find a zero of a system of -c n nonlinear functions in n variables by a modification -c of the powell hybrid method. the user must provide a -c subroutine which calculates the functions and the jacobian. -c -c the subroutine statement is -c -c subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, -c mode,factor,nprint,info,nfev,njev,r,lr,qtf, -c wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) -c integer n,ldfjac,iflag -c double precision x(n),fvec(n),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c --------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of hybrj. -c in this case set iflag to a negative integer. -c -c n is a positive integer input variable set to the number -c of functions and variables. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length n which contains -c the functions evaluated at the output x. -c -c fjac is an output n by n array which contains the -c orthogonal matrix q produced by the qr factorization -c of the final approximate jacobian. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn with iflag = 1 -c has reached maxfev. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.). 100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x and fvec available -c for printing. fvec and fjac should not be altered. -c if nprint is not positive, no special calls of fcn -c with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 relative error between two consecutive iterates -c is at most xtol. -c -c info = 2 number of calls to fcn with iflag = 1 has -c reached maxfev. -c -c info = 3 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 4 iteration is not making good progress, as -c measured by the improvement from the last -c five jacobian evaluations. -c -c info = 5 iteration is not making good progress, as -c measured by the improvement from the last -c ten iterations. -c -c nfev is an integer output variable set to the number of -c calls to fcn with iflag = 1. -c -c njev is an integer output variable set to the number of -c calls to fcn with iflag = 2. -c -c r is an output array of length lr which contains the -c upper triangular matrix produced by the qr factorization -c of the final approximate jacobian, stored rowwise. -c -c lr is a positive integer input variable not less than -c (n*(n+1))/2. -c -c qtf is an output array of length n which contains -c the vector (q transpose)*fvec. -c -c wa1, wa2, wa3, and wa4 are work arrays of length n. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dogleg,dpmpar,enorm, -c qform,qrfac,r1mpyq,r1updt -c -c fortran-supplied ... dabs,dmax1,dmin1,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iflag,iter,j,jm1,l,ncfail,ncsuc,nslow1,nslow2 - integer iwa(1) - logical jeval,sing - double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, - * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, - * zero - double precision dpmpar,enorm - data one,p1,p5,p001,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 - njev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. ldfjac .lt. n .or. xtol .lt. zero - * .or. maxfev .le. 0 .or. factor .le. zero - * .or. lr .lt. (n*(n + 1))/2) go to 300 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 300 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(n,x,fvec,fjac,ldfjac,iflag) - nfev = 1 - if (iflag .lt. 0) go to 300 - fnorm = enorm(n,fvec) -c -c initialize iteration counter and monitors. -c - iter = 1 - ncsuc = 0 - ncfail = 0 - nslow1 = 0 - nslow2 = 0 -c -c beginning of the outer loop. -c - 30 continue - jeval = .true. -c -c calculate the jacobian matrix. -c - iflag = 2 - call fcn(n,x,fvec,fjac,ldfjac,iflag) - njev = njev + 1 - if (iflag .lt. 0) go to 300 -c -c compute the qr factorization of the jacobian. -c - call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 70 - if (mode .eq. 2) go to 50 - do 40 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 40 continue - 50 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 60 j = 1, n - wa3(j) = diag(j)*x(j) - 60 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 70 continue -c -c form (q transpose)*fvec and store in qtf. -c - do 80 i = 1, n - qtf(i) = fvec(i) - 80 continue - do 120 j = 1, n - if (fjac(j,j) .eq. zero) go to 110 - sum = zero - do 90 i = j, n - sum = sum + fjac(i,j)*qtf(i) - 90 continue - temp = -sum/fjac(j,j) - do 100 i = j, n - qtf(i) = qtf(i) + fjac(i,j)*temp - 100 continue - 110 continue - 120 continue -c -c copy the triangular factor of the qr factorization into r. -c - sing = .false. - do 150 j = 1, n - l = j - jm1 = j - 1 - if (jm1 .lt. 1) go to 140 - do 130 i = 1, jm1 - r(l) = fjac(i,j) - l = l + n - i - 130 continue - 140 continue - r(l) = wa1(j) - if (wa1(j) .eq. zero) sing = .true. - 150 continue -c -c accumulate the orthogonal factor in fjac. -c - call qform(n,n,fjac,ldfjac,wa1) -c -c rescale if necessary. -c - if (mode .eq. 2) go to 170 - do 160 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 160 continue - 170 continue -c -c beginning of the inner loop. -c - 180 continue -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 190 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) - * call fcn(n,x,fvec,fjac,ldfjac,iflag) - if (iflag .lt. 0) go to 300 - 190 continue -c -c determine the direction p. -c - call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) -c -c store the direction p and x + p. calculate the norm of p. -c - do 200 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 200 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(n,wa2,wa4,fjac,ldfjac,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 300 - fnorm1 = enorm(n,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction. -c - l = 1 - do 220 i = 1, n - sum = zero - do 210 j = i, n - sum = sum + r(l)*wa1(j) - l = l + 1 - 210 continue - wa3(i) = qtf(i) + sum - 220 continue - temp = enorm(n,wa3) - prered = zero - if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .gt. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .ge. p1) go to 230 - ncsuc = 0 - ncfail = ncfail + 1 - delta = p5*delta - go to 240 - 230 continue - ncfail = 0 - ncsuc = ncsuc + 1 - if (ratio .ge. p5 .or. ncsuc .gt. 1) - * delta = dmax1(delta,pnorm/p5) - if (dabs(ratio-one) .le. p1) delta = pnorm/p5 - 240 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 260 -c -c successful iteration. update x, fvec, and their norms. -c - do 250 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - fvec(j) = wa4(j) - 250 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 260 continue -c -c determine the progress of the iteration. -c - nslow1 = nslow1 + 1 - if (actred .ge. p001) nslow1 = 0 - if (jeval) nslow2 = nslow2 + 1 - if (actred .ge. p1) nslow2 = 0 -c -c test for convergence. -c - if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 - if (info .ne. 0) go to 300 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 2 - if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 - if (nslow2 .eq. 5) info = 4 - if (nslow1 .eq. 10) info = 5 - if (info .ne. 0) go to 300 -c -c criterion for recalculating jacobian. -c - if (ncfail .eq. 2) go to 290 -c -c calculate the rank one modification to the jacobian -c and update qtf if necessary. -c - do 280 j = 1, n - sum = zero - do 270 i = 1, n - sum = sum + fjac(i,j)*wa4(i) - 270 continue - wa2(j) = (sum - wa3(j))/pnorm - wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) - if (ratio .ge. p0001) qtf(j) = sum - 280 continue -c -c compute the qr factorization of the updated jacobian. -c - call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) - call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) - call r1mpyq(1,n,qtf,1,wa2,wa3) -c -c end of the inner loop. -c - jeval = .false. - go to 180 - 290 continue -c -c end of the outer loop. -c - go to 30 - 300 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) - return -c -c last card of subroutine hybrj. -c - end -c - subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) - integer n,lr - double precision delta - double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n) -c ********** -c -c subroutine dogleg -c -c given an m by n matrix a, an n by n nonsingular diagonal -c matrix d, an m-vector b, and a positive number delta, the -c problem is to determine the convex combination x of the -c gauss-newton and scaled gradient directions that minimizes -c (a*x - b) in the least squares sense, subject to the -c restriction that the euclidean norm of d*x be at most delta. -c -c this subroutine completes the solution of the problem -c if it is provided with the necessary information from the -c qr factorization of a. that is, if a = q*r, where q has -c orthogonal columns and r is an upper triangular matrix, -c then dogleg expects the full upper triangle of r and -c the first n components of (q transpose)*b. -c -c the subroutine statement is -c -c subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an input array of length lr which must contain the upper -c triangular matrix r stored by rows. -c -c lr is a positive integer input variable not less than -c (n*(n+1))/2. -c -c diag is an input array of length n which must contain the -c diagonal elements of the matrix d. -c -c qtb is an input array of length n which must contain the first -c n elements of the vector (q transpose)*b. -c -c delta is a positive input variable which specifies an upper -c bound on the euclidean norm of d*x. -c -c x is an output array of length n which contains the desired -c convex combination of the gauss-newton direction and the -c scaled gradient direction. -c -c wa1 and wa2 are work arrays of length n. -c -c subprograms called -c -c minpack-supplied ... dpmpar,enorm -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jj,jp1,k,l - double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, - * temp,zero - double precision dpmpar,enorm - data one,zero /1.0d0,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c -c first, calculate the gauss-newton direction. -c - jj = (n*(n + 1))/2 + 1 - do 50 k = 1, n - j = n - k + 1 - jp1 = j + 1 - jj = jj - k - l = jj + 1 - sum = zero - if (n .lt. jp1) go to 20 - do 10 i = jp1, n - sum = sum + r(l)*x(i) - l = l + 1 - 10 continue - 20 continue - temp = r(jj) - if (temp .ne. zero) go to 40 - l = j - do 30 i = 1, j - temp = dmax1(temp,dabs(r(l))) - l = l + n - i - 30 continue - temp = epsmch*temp - if (temp .eq. zero) temp = epsmch - 40 continue - x(j) = (qtb(j) - sum)/temp - 50 continue -c -c test whether the gauss-newton direction is acceptable. -c - do 60 j = 1, n - wa1(j) = zero - wa2(j) = diag(j)*x(j) - 60 continue - qnorm = enorm(n,wa2) - if (qnorm .le. delta) go to 140 -c -c the gauss-newton direction is not acceptable. -c next, calculate the scaled gradient direction. -c - l = 1 - do 80 j = 1, n - temp = qtb(j) - do 70 i = j, n - wa1(i) = wa1(i) + r(l)*temp - l = l + 1 - 70 continue - wa1(j) = wa1(j)/diag(j) - 80 continue -c -c calculate the norm of the scaled gradient and test for -c the special case in which the scaled gradient is zero. -c - gnorm = enorm(n,wa1) - sgnorm = zero - alpha = delta/qnorm - if (gnorm .eq. zero) go to 120 -c -c calculate the point along the scaled gradient -c at which the quadratic is minimized. -c - do 90 j = 1, n - wa1(j) = (wa1(j)/gnorm)/diag(j) - 90 continue - l = 1 - do 110 j = 1, n - sum = zero - do 100 i = j, n - sum = sum + r(l)*wa1(i) - l = l + 1 - 100 continue - wa2(j) = sum - 110 continue - temp = enorm(n,wa2) - sgnorm = (gnorm/temp)/temp -c -c test whether the scaled gradient direction is acceptable. -c - alpha = zero - if (sgnorm .ge. delta) go to 120 -c -c the scaled gradient direction is not acceptable. -c finally, calculate the point along the dogleg -c at which the quadratic is minimized. -c - bnorm = enorm(n,qtb) - temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) - temp = temp - (delta/qnorm)*(sgnorm/delta)**2 - * + dsqrt((temp-(delta/qnorm))**2 - * +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) - alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp - 120 continue -c -c form appropriate convex combination of the gauss-newton -c direction and the scaled gradient direction. -c - temp = (one - alpha)*dmin1(sgnorm,delta) - do 130 j = 1, n - x(j) = temp*wa1(j) + alpha*x(j) - 130 continue - 140 continue - return -c -c last card of subroutine dogleg. -c - end - double precision function dpmpar(i) - integer i -c ********** -c -c Function dpmpar -c -c This function provides double precision machine parameters -c when the appropriate set of data statements is activated (by -c removing the c from column 1) and all other data statements are -c rendered inactive. Most of the parameter values were obtained -c from the corresponding Bell Laboratories Port Library function. -c -c The function statement is -c -c double precision function dpmpar(i) -c -c where -c -c i is an integer input variable set to 1, 2, or 3 which -c selects the desired machine parameter. If the machine has -c t base b digits and its smallest and largest exponents are -c emin and emax, respectively, then these parameters are -c -c dpmpar(1) = b**(1 - t), the machine precision, -c -c dpmpar(2) = b**(emin - 1), the smallest magnitude, -c -c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. -c -c Argonne National Laboratory. MINPACK Project. November 1996. -c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' -c -c ********** - integer mcheps(4) - integer minmag(4) - integer maxmag(4) - double precision dmach(3) - equivalence (dmach(1),mcheps(1)) - equivalence (dmach(2),minmag(1)) - equivalence (dmach(3),maxmag(1)) -c -c Machine constants for the IBM 360/370 series, -c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, -c the Xerox Sigma 5/7/9 and the Sel systems 85/86. -c -c data mcheps(1),mcheps(2) / z34100000, z00000000 / -c data minmag(1),minmag(2) / z00100000, z00000000 / -c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / -c -c Machine constants for the Honeywell 600/6000 series. -c -c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / -c data minmag(1),minmag(2) / o402400000000, o000000000000 / -c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / -c -c Machine constants for the CDC 6000/7000 series. -c -c data mcheps(1) / 15614000000000000000b / -c data mcheps(2) / 15010000000000000000b / -c -c data minmag(1) / 00604000000000000000b / -c data minmag(2) / 00000000000000000000b / -c -c data maxmag(1) / 37767777777777777777b / -c data maxmag(2) / 37167777777777777777b / -c -c Machine constants for the PDP-10 (KA processor). -c -c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / -c data minmag(1),minmag(2) / "033400000000, "000000000000 / -c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / -c -c Machine constants for the PDP-10 (KI processor). -c -c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / -c data minmag(1),minmag(2) / "000400000000, "000000000000 / -c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / -c -c Machine constants for the PDP-11. -c -c data mcheps(1),mcheps(2) / 9472, 0 / -c data mcheps(3),mcheps(4) / 0, 0 / -c -c data minmag(1),minmag(2) / 128, 0 / -c data minmag(3),minmag(4) / 0, 0 / -c -c data maxmag(1),maxmag(2) / 32767, -1 / -c data maxmag(3),maxmag(4) / -1, -1 / -c -c Machine constants for the Burroughs 6700/7700 systems. -c -c data mcheps(1) / o1451000000000000 / -c data mcheps(2) / o0000000000000000 / -c -c data minmag(1) / o1771000000000000 / -c data minmag(2) / o7770000000000000 / -c -c data maxmag(1) / o0777777777777777 / -c data maxmag(2) / o7777777777777777 / -c -c Machine constants for the Burroughs 5700 system. -c -c data mcheps(1) / o1451000000000000 / -c data mcheps(2) / o0000000000000000 / -c -c data minmag(1) / o1771000000000000 / -c data minmag(2) / o0000000000000000 / -c -c data maxmag(1) / o0777777777777777 / -c data maxmag(2) / o0007777777777777 / -c -c Machine constants for the Burroughs 1700 system. -c -c data mcheps(1) / zcc6800000 / -c data mcheps(2) / z000000000 / -c -c data minmag(1) / zc00800000 / -c data minmag(2) / z000000000 / -c -c data maxmag(1) / zdffffffff / -c data maxmag(2) / zfffffffff / -c -c Machine constants for the Univac 1100 series. -c -c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / -c data minmag(1),minmag(2) / o000040000000, o000000000000 / -c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / -c -c Machine constants for the Data General Eclipse S/200. -c -c Note - it may be appropriate to include the following card - -c static dmach(3) -c -c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ -c data mcheps/32020k,3*0/ -c -c Machine constants for the Harris 220. -c -c data mcheps(1),mcheps(2) / '20000000, '00000334 / -c data minmag(1),minmag(2) / '20000000, '00000201 / -c data maxmag(1),maxmag(2) / '37777777, '37777577 / -c -c Machine constants for the Cray-1. -c -c data mcheps(1) / 0376424000000000000000b / -c data mcheps(2) / 0000000000000000000000b / -c -c data minmag(1) / 0200034000000000000000b / -c data minmag(2) / 0000000000000000000000b / -c -c data maxmag(1) / 0577777777777777777777b / -c data maxmag(2) / 0000007777777777777776b / -c -c Machine constants for the Prime 400. -c -c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / -c data minmag(1),minmag(2) / :10000000000, :00000100000 / -c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / -c -c Machine constants for the VAX-11. -c -c data mcheps(1),mcheps(2) / 9472, 0 / -c data minmag(1),minmag(2) / 128, 0 / -c data maxmag(1),maxmag(2) / -32769, -1 / -c -c Machine constants for IEEE machines. -c - data dmach(1) /2.22044604926d-16/ - data dmach(2) /2.22507385852d-308/ - data dmach(3) /1.79769313485d+308/ -c - dpmpar = dmach(i) - return -c -c Last card of function dpmpar. -c - end -c - double precision function enorm(n,x) - integer n - double precision x(n) -c ********** -c -c function enorm -c -c given an n-vector x, this function calculates the -c euclidean norm of x. -c -c the euclidean norm is computed by accumulating the sum of -c squares in three different sums. the sums of squares for the -c small and large components are scaled so that no overflows -c occur. non-destructive underflows are permitted. underflows -c and overflows do not occur in the computation of the unscaled -c sum of squares for the intermediate components. -c the definitions of small, intermediate and large components -c depend on two constants, rdwarf and rgiant. the main -c restrictions on these constants are that rdwarf**2 not -c underflow and rgiant**2 not overflow. the constants -c given here are suitable for every known computer. -c -c the function statement is -c -c double precision function enorm(n,x) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c subprograms called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i - double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, - * x1max,x3max,zero - data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ - s1 = zero - s2 = zero - s3 = zero - x1max = zero - x3max = zero - floatn = n - agiant = rgiant/floatn - do 90 i = 1, n - xabs = dabs(x(i)) - if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 - if (xabs .le. rdwarf) go to 30 -c -c sum for large components. -c - if (xabs .le. x1max) go to 10 - s1 = one + s1*(x1max/xabs)**2 - x1max = xabs - go to 20 - 10 continue - s1 = s1 + (xabs/x1max)**2 - 20 continue - go to 60 - 30 continue -c -c sum for small components. -c - if (xabs .le. x3max) go to 40 - s3 = one + s3*(x3max/xabs)**2 - x3max = xabs - go to 50 - 40 continue - if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 - 50 continue - 60 continue - go to 80 - 70 continue -c -c sum for intermediate components. -c - s2 = s2 + xabs**2 - 80 continue - 90 continue -c -c calculation of norm. -c - if (s1 .eq. zero) go to 100 - enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) - go to 130 - 100 continue - if (s2 .eq. zero) go to 110 - if (s2 .ge. x3max) - * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) - if (s2 .lt. x3max) - * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) - go to 120 - 110 continue - enorm = x3max*dsqrt(s3) - 120 continue - 130 continue - return -c -c last card of function enorm. -c - end -c - subroutine qform(m,n,q,ldq,wa) - integer m,n,ldq - double precision q(ldq,m),wa(m) -c ********** -c -c subroutine qform -c -c this subroutine proceeds from the computed qr factorization of -c an m by n matrix a to accumulate the m by m orthogonal matrix -c q from its factored form. -c -c the subroutine statement is -c -c subroutine qform(m,n,q,ldq,wa) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of a and the order of q. -c -c n is a positive integer input variable set to the number -c of columns of a. -c -c q is an m by m array. on input the full lower trapezoid in -c the first min(m,n) columns of q contains the factored form. -c on output q has been accumulated into a square matrix. -c -c ldq is a positive integer input variable not less than m -c which specifies the leading dimension of the array q. -c -c wa is a work array of length m. -c -c subprograms called -c -c fortran-supplied ... min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jm1,k,l,minmn,np1 - double precision one,sum,temp,zero - data one,zero /1.0d0,0.0d0/ -c -c zero out upper triangle of q in the first min(m,n) columns. -c - minmn = min0(m,n) - if (minmn .lt. 2) go to 30 - do 20 j = 2, minmn - jm1 = j - 1 - do 10 i = 1, jm1 - q(i,j) = zero - 10 continue - 20 continue - 30 continue -c -c initialize remaining columns to those of the identity matrix. -c - np1 = n + 1 - if (m .lt. np1) go to 60 - do 50 j = np1, m - do 40 i = 1, m - q(i,j) = zero - 40 continue - q(j,j) = one - 50 continue - 60 continue -c -c accumulate q from its factored form. -c - do 120 l = 1, minmn - k = minmn - l + 1 - do 70 i = k, m - wa(i) = q(i,k) - q(i,k) = zero - 70 continue - q(k,k) = one - if (wa(k) .eq. zero) go to 110 - do 100 j = k, m - sum = zero - do 80 i = k, m - sum = sum + q(i,j)*wa(i) - 80 continue - temp = sum/wa(k) - do 90 i = k, m - q(i,j) = q(i,j) - temp*wa(i) - 90 continue - 100 continue - 110 continue - 120 continue - return -c -c last card of subroutine qform. -c - end -c - subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) - integer m,n,lda,lipvt - integer ipvt(lipvt) - logical pivot - double precision a(lda,n),rdiag(n),acnorm(n),wa(n) -c ********** -c -c subroutine qrfac -c -c this subroutine uses householder transformations with column -c pivoting (optional) to compute a qr factorization of the -c m by n matrix a. that is, qrfac determines an orthogonal -c matrix q, a permutation matrix p, and an upper trapezoidal -c matrix r with diagonal elements of nonincreasing magnitude, -c such that a*p = q*r. the householder transformation for -c column k, k = 1,2,...,min(m,n), is of the form -c -c t -c i - (1/u(k))*u*u -c -c where u has zeros in the first k-1 positions. the form of -c this transformation and the method of pivoting first -c appeared in the corresponding linpack subroutine. -c -c the subroutine statement is -c -c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of a. -c -c n is a positive integer input variable set to the number -c of columns of a. -c -c a is an m by n array. on input a contains the matrix for -c which the qr factorization is to be computed. on output -c the strict upper trapezoidal part of a contains the strict -c upper trapezoidal part of r, and the lower trapezoidal -c part of a contains a factored form of q (the non-trivial -c elements of the u vectors described above). -c -c lda is a positive integer input variable not less than m -c which specifies the leading dimension of the array a. -c -c pivot is a logical input variable. if pivot is set true, -c then column pivoting is enforced. if pivot is set false, -c then no column pivoting is done. -c -c ipvt is an integer output array of length lipvt. ipvt -c defines the permutation matrix p such that a*p = q*r. -c column j of p is column ipvt(j) of the identity matrix. -c if pivot is false, ipvt is not referenced. -c -c lipvt is a positive integer input variable. if pivot is false, -c then lipvt may be as small as 1. if pivot is true, then -c lipvt must be at least n. -c -c rdiag is an output array of length n which contains the -c diagonal elements of r. -c -c acnorm is an output array of length n which contains the -c norms of the corresponding columns of the input matrix a. -c if this information is not needed, then acnorm can coincide -c with rdiag. -c -c wa is a work array of length n. if pivot is false, then wa -c can coincide with rdiag. -c -c subprograms called -c -c minpack-supplied ... dpmpar,enorm -c -c fortran-supplied ... dmax1,dsqrt,min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jp1,k,kmax,minmn - double precision ajnorm,epsmch,one,p05,sum,temp,zero - double precision dpmpar,enorm - data one,p05,zero /1.0d0,5.0d-2,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c -c compute the initial column norms and initialize several arrays. -c - do 10 j = 1, n - acnorm(j) = enorm(m,a(1,j)) - rdiag(j) = acnorm(j) - wa(j) = rdiag(j) - if (pivot) ipvt(j) = j - 10 continue -c -c reduce a to r with householder transformations. -c - minmn = min0(m,n) - do 110 j = 1, minmn - if (.not.pivot) go to 40 -c -c bring the column of largest norm into the pivot position. -c - kmax = j - do 20 k = j, n - if (rdiag(k) .gt. rdiag(kmax)) kmax = k - 20 continue - if (kmax .eq. j) go to 40 - do 30 i = 1, m - temp = a(i,j) - a(i,j) = a(i,kmax) - a(i,kmax) = temp - 30 continue - rdiag(kmax) = rdiag(j) - wa(kmax) = wa(j) - k = ipvt(j) - ipvt(j) = ipvt(kmax) - ipvt(kmax) = k - 40 continue -c -c compute the householder transformation to reduce the -c j-th column of a to a multiple of the j-th unit vector. -c - ajnorm = enorm(m-j+1,a(j,j)) - if (ajnorm .eq. zero) go to 100 - if (a(j,j) .lt. zero) ajnorm = -ajnorm - do 50 i = j, m - a(i,j) = a(i,j)/ajnorm - 50 continue - a(j,j) = a(j,j) + one -c -c apply the transformation to the remaining columns -c and update the norms. -c - jp1 = j + 1 - if (n .lt. jp1) go to 100 - do 90 k = jp1, n - sum = zero - do 60 i = j, m - sum = sum + a(i,j)*a(i,k) - 60 continue - temp = sum/a(j,j) - do 70 i = j, m - a(i,k) = a(i,k) - temp*a(i,j) - 70 continue - if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 - temp = a(j,k)/rdiag(k) - rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) - if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 - rdiag(k) = enorm(m-j,a(jp1,k)) - wa(k) = rdiag(k) - 80 continue - 90 continue - 100 continue - rdiag(j) = -ajnorm - 110 continue - return -c -c last card of subroutine qrfac. -c - end -c - subroutine r1mpyq(m,n,a,lda,v,w) - integer m,n,lda - double precision a(lda,n),v(n),w(n) -c ********** -c -c subroutine r1mpyq -c -c given an m by n matrix a, this subroutine computes a*q where -c q is the product of 2*(n - 1) transformations -c -c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) -c -c and gv(i), gw(i) are givens rotations in the (i,n) plane which -c eliminate elements in the i-th and n-th planes, respectively. -c q itself is not given, rather the information to recover the -c gv, gw rotations is supplied. -c -c the subroutine statement is -c -c subroutine r1mpyq(m,n,a,lda,v,w) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of a. -c -c n is a positive integer input variable set to the number -c of columns of a. -c -c a is an m by n array. on input a must contain the matrix -c to be postmultiplied by the orthogonal matrix q -c described above. on output a*q has replaced a. -c -c lda is a positive integer input variable not less than m -c which specifies the leading dimension of the array a. -c -c v is an input array of length n. v(i) must contain the -c information necessary to recover the givens rotation gv(i) -c described above. -c -c w is an input array of length n. w(i) must contain the -c information necessary to recover the givens rotation gw(i) -c described above. -c -c subroutines called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,nmj,nm1 - double precision cos,one,sin,temp - data one /1.0d0/ -c -c apply the first set of givens rotations to a. -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 50 - do 20 nmj = 1, nm1 - j = n - nmj - if (dabs(v(j)) .gt. one) cos = one/v(j) - if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2) - if (dabs(v(j)) .le. one) sin = v(j) - if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2) - do 10 i = 1, m - temp = cos*a(i,j) - sin*a(i,n) - a(i,n) = sin*a(i,j) + cos*a(i,n) - a(i,j) = temp - 10 continue - 20 continue -c -c apply the second set of givens rotations to a. -c - do 40 j = 1, nm1 - if (dabs(w(j)) .gt. one) cos = one/w(j) - if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2) - if (dabs(w(j)) .le. one) sin = w(j) - if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2) - do 30 i = 1, m - temp = cos*a(i,j) + sin*a(i,n) - a(i,n) = -sin*a(i,j) + cos*a(i,n) - a(i,j) = temp - 30 continue - 40 continue - 50 continue - return -c -c last card of subroutine r1mpyq. -c - end -c - subroutine r1updt(m,n,s,ls,u,v,w,sing) - integer m,n,ls - logical sing - double precision s(ls),u(m),v(n),w(m) -c ********** -c -c subroutine r1updt -c -c given an m by n lower trapezoidal matrix s, an m-vector u, -c and an n-vector v, the problem is to determine an -c orthogonal matrix q such that -c -c t -c (s + u*v )*q -c -c is again lower trapezoidal. -c -c this subroutine determines q as the product of 2*(n - 1) -c transformations -c -c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) -c -c where gv(i), gw(i) are givens rotations in the (i,n) plane -c which eliminate elements in the i-th and n-th planes, -c respectively. q itself is not accumulated, rather the -c information to recover the gv, gw rotations is returned. -c -c the subroutine statement is -c -c subroutine r1updt(m,n,s,ls,u,v,w,sing) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of s. -c -c n is a positive integer input variable set to the number -c of columns of s. n must not exceed m. -c -c s is an array of length ls. on input s must contain the lower -c trapezoidal matrix s stored by columns. on output s contains -c the lower trapezoidal matrix produced as described above. -c -c ls is a positive integer input variable not less than -c (n*(2*m-n+1))/2. -c -c u is an input array of length m which must contain the -c vector u. -c -c v is an array of length n. on input v must contain the vector -c v. on output v(i) contains the information necessary to -c recover the givens rotation gv(i) described above. -c -c w is an output array of length m. w(i) contains information -c necessary to recover the givens rotation gw(i) described -c above. -c -c sing is a logical output variable. sing is set true if any -c of the diagonal elements of the output s are zero. otherwise -c sing is set false. -c -c subprograms called -c -c minpack-supplied ... dpmpar -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more, -c john l. nazareth -c -c ********** - integer i,j,jj,l,nmj,nm1 - double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, - * zero - double precision dpmpar - data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ -c -c giant is the largest magnitude. -c - giant = dpmpar(3) -c -c initialize the diagonal element pointer. -c - jj = (n*(2*m - n + 1))/2 - (m - n) -c -c move the nontrivial part of the last column of s into w. -c - l = jj - do 10 i = n, m - w(i) = s(l) - l = l + 1 - 10 continue -c -c rotate the vector v into a multiple of the n-th unit vector -c in such a way that a spike is introduced into w. -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 nmj = 1, nm1 - j = n - nmj - jj = jj - (m - j + 1) - w(j) = zero - if (v(j) .eq. zero) go to 50 -c -c determine a givens rotation which eliminates the -c j-th element of v. -c - if (dabs(v(n)) .ge. dabs(v(j))) go to 20 - cotan = v(n)/v(j) - sin = p5/dsqrt(p25+p25*cotan**2) - cos = sin*cotan - tau = one - if (dabs(cos)*giant .gt. one) tau = one/cos - go to 30 - 20 continue - tan = v(j)/v(n) - cos = p5/dsqrt(p25+p25*tan**2) - sin = cos*tan - tau = sin - 30 continue -c -c apply the transformation to v and store the information -c necessary to recover the givens rotation. -c - v(n) = sin*v(j) + cos*v(n) - v(j) = tau -c -c apply the transformation to s and extend the spike in w. -c - l = jj - do 40 i = j, m - temp = cos*s(l) - sin*w(i) - w(i) = sin*s(l) + cos*w(i) - s(l) = temp - l = l + 1 - 40 continue - 50 continue - 60 continue - 70 continue -c -c add the spike from the rank 1 update to w. -c - do 80 i = 1, m - w(i) = w(i) + v(n)*u(i) - 80 continue -c -c eliminate the spike. -c - sing = .false. - if (nm1 .lt. 1) go to 140 - do 130 j = 1, nm1 - if (w(j) .eq. zero) go to 120 -c -c determine a givens rotation which eliminates the -c j-th element of the spike. -c - if (dabs(s(jj)) .ge. dabs(w(j))) go to 90 - cotan = s(jj)/w(j) - sin = p5/dsqrt(p25+p25*cotan**2) - cos = sin*cotan - tau = one - if (dabs(cos)*giant .gt. one) tau = one/cos - go to 100 - 90 continue - tan = w(j)/s(jj) - cos = p5/dsqrt(p25+p25*tan**2) - sin = cos*tan - tau = sin - 100 continue -c -c apply the transformation to s and reduce the spike in w. -c - l = jj - do 110 i = j, m - temp = cos*s(l) + sin*w(i) - w(i) = -sin*s(l) + cos*w(i) - s(l) = temp - l = l + 1 - 110 continue -c -c store the information necessary to recover the -c givens rotation. -c - w(j) = tau - 120 continue -c -c test for zero diagonal elements in the output s. -c - if (s(jj) .eq. zero) sing = .true. - jj = jj + (m - j + 1) - 130 continue - 140 continue -c -c move w back into the last column of the output s. -c - l = jj - do 150 i = n, m - s(l) = w(i) - l = l + 1 - 150 continue - if (s(jj) .eq. zero) sing = .true. - return -c -c last card of subroutine r1updt. -c - end -c -c -c - subroutine quanc8(fun,a,b,abserr,relerr,result,errest,nofun,flag) -c - double precision fun, a, b, abserr, relerr, result, errest, flag - integer nofun -c -c estimate the integral of fun(x) from a to b -c to a user provided tolerance. -c an automatic adaptive routine based on -c the 8-panel newton-cotes rule. -c -c input .. -c -c fun the name of the integrand function subprogram fun(x). -c a the lower limit of integration. -c b the upper limit of integration.(b may be less than a.) -c relerr a relative error tolerance. (should be non-negative) -c abserr an absolute error tolerance. (should be non-negative) -c -c output .. -c -c result an approximation to the integral hopefully satisfying the -c least stringent of the two error tolerances. -c errest an estimate of the magnitude of the actual error. -c nofun the number of function values used in calculation of result. -c flag a reliability indicator. if flag is zero, then result -c probably satisfies the error tolerance. if flag is -c xxx.yyy , then xxx = the number of intervals which have -c not converged and 0.yyy = the fraction of the interval -c left to do when the limit on nofun was approached. -c - double precision w0,w1,w2,w3,w4,area,x0,f0,stone,step,cor11,temp - double precision qprev,qnow,qdiff,qleft,esterr,tolerr - double precision qright(31),f(16),x(16),fsave(8,30),xsave(8,30) - double precision dabs,dmax1 - integer levmin,levmax,levout,nomax,nofin,lev,nim,i,j -c -c *** stage 1 *** general initialization -c set constants. -c - levmin = 1 - levmax = 30 - levout = 6 - nomax = 5000 - nofin = nomax - 8*(levmax-levout+2**(levout+1)) -c -c trouble when nofun reaches nofin -c - w0 = 3956.0d0 / 14175.0d0 - w1 = 23552.0d0 / 14175.0d0 - w2 = -3712.0d0 / 14175.0d0 - w3 = 41984.0d0 / 14175.0d0 - w4 = -18160.0d0 / 14175.0d0 -c -c initialize running sums to zero. -c - flag = 0.0d0 - result = 0.0d0 - cor11 = 0.0d0 - errest = 0.0d0 - area = 0.0d0 - nofun = 0 - if (a .eq. b) return -c -c *** stage 2 *** initialization for first interval -c - lev = 0 - nim = 1 - x0 = a - x(16) = b - qprev = 0.0d0 - f0 = fun(x0) - stone = (b - a) / 16.0d0 - x(8) = (x0 + x(16)) / 2.0d0 - x(4) = (x0 + x(8)) / 2.0d0 - x(12) = (x(8) + x(16)) / 2.0d0 - x(2) = (x0 + x(4)) / 2.0d0 - x(6) = (x(4) + x(8)) / 2.0d0 - x(10) = (x(8) + x(12)) / 2.0d0 - x(14) = (x(12) + x(16)) / 2.0d0 - do 25 j = 2, 16, 2 - f(j) = fun(x(j)) - 25 continue - nofun = 9 -c -c *** stage 3 *** central calculation -c requires qprev,x0,x2,x4,...,x16,f0,f2,f4,...,f16. -c calculates x1,x3,...x15, f1,f3,...f15,qleft,qright,qnow,qdiff,area. -c - 30 x(1) = (x0 + x(2)) / 2.0d0 - f(1) = fun(x(1)) - do 35 j = 3, 15, 2 - x(j) = (x(j-1) + x(j+1)) / 2.0d0 - f(j) = fun(x(j)) - 35 continue - nofun = nofun + 8 - step = (x(16) - x0) / 16.0d0 - qleft = (w0*(f0 + f(8)) + w1*(f(1)+f(7)) + w2*(f(2)+f(6)) - 1 + w3*(f(3)+f(5)) + w4*f(4)) * step - qright(lev+1)=(w0*(f(8)+f(16))+w1*(f(9)+f(15))+w2*(f(10)+f(14)) - 1 + w3*(f(11)+f(13)) + w4*f(12)) * step - qnow = qleft + qright(lev+1) - qdiff = qnow - qprev - area = area + qdiff -c -c *** stage 4 *** interval convergence test -c - esterr = dabs(qdiff) / 1023.0d0 - tolerr = dmax1(abserr,relerr*dabs(area)) * (step/stone) - if (lev .lt. levmin) go to 50 - if (lev .ge. levmax) go to 62 - if (nofun .gt. nofin) go to 60 - if (esterr .le. tolerr) go to 70 -c -c *** stage 5 *** no convergence -c locate next interval. -c - 50 nim = 2*nim - lev = lev+1 -c -c store right hand elements for future use. -c - do 52 i = 1, 8 - fsave(i,lev) = f(i+8) - xsave(i,lev) = x(i+8) - 52 continue -c -c assemble left hand elements for immediate use. -c - qprev = qleft - do 55 i = 1, 8 - j = -i - f(2*j+18) = f(j+9) - x(2*j+18) = x(j+9) - 55 continue - go to 30 -c -c *** stage 6 *** trouble section -c number of function values is about to exceed limit. -c - 60 nofin = 2*nofin - levmax = levout - flag = flag + (b - x0) / (b - a) - go to 70 -c -c current level is levmax. -c - 62 flag = flag + 1.0d0 -c -c *** stage 7 *** interval converged -c add contributions into running sums. -c - 70 result = result + qnow - errest = errest + esterr - cor11 = cor11 + qdiff / 1023.0d0 -c -c locate next interval. -c - 72 if (nim .eq. 2*(nim/2)) go to 75 - nim = nim/2 - lev = lev-1 - go to 72 - 75 nim = nim + 1 - if (lev .le. 0) go to 80 -c -c assemble elements required for the next interval. -c - qprev = qright(lev) - x0 = x(16) - f0 = f(16) - do 78 i = 1, 8 - f(2*i) = fsave(i,lev) - x(2*i) = xsave(i,lev) - 78 continue - go to 30 -c -c *** stage 8 *** finalize and return -c - 80 result = result + cor11 -c -c make sure errest not less than roundoff level. -c - if (errest .eq. 0.0d0) return - 82 temp = dabs(result) + errest - if (temp .ne. dabs(result)) return - errest = 2.0d0*errest - go to 82 - end - - subroutine dqagp(f,a,b,npts2,points,epsabs,epsrel,result,abserr, - * neval,ier,leniw,lenw,last,iwork,work) -c***begin prologue dqagp -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a2a1 -c***keywords automatic integrator, general-purpose, -c singularities at user specified points, -c extrapolation, globally adaptive -c***author piessens,robert,appl. math. & progr. div - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c break points of the integration interval, where local -c difficulties of the integrand may occur (e.g. -c singularities, discontinuities), are provided by the user. -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c npts2 - integer -c number equal to two more than the number of -c user-supplied break points within the integration -c range, npts.ge.2. -c if npts2.lt.2, the routine will end with ier = 6. -c -c points - double precision -c vector of dimension npts2, the first (npts2-2) -c elements of which are the user provided break -c points. if these points do not constitute an -c ascending sequence there will be an automatic -c sorting. -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine. -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (i.e. singularity, -c discontinuity within the interval), it -c should be supplied to the routine as an -c element of the vector points. if necessary -c an appropriate special-purpose integrator -c must be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is presumed that the requested -c tolerance cannot be achieved, and that -c the returned result is the best which -c can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier.gt.0. -c = 6 the input is invalid because -c npts2.lt.2 or -c break points are specified outside -c the integration range or -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c result, abserr, neval, last are set to -c zero. exept when leniw or lenw or npts2 is -c invalid, iwork(1), iwork(limit+1), -c work(limit*2+1) and work(limit*3+1) -c are set to zero. -c work(1) is set to a and work(limit+1) -c to b (where limit = (leniw-npts2)/2). -c -c dimensioning parameters -c leniw - integer -c dimensioning parameter for iwork -c leniw determines limit = (leniw-npts2)/2, -c which is the maximum number of subintervals in the -c partition of the given integration interval (a,b), -c leniw.ge.(3*npts2-2). -c if leniw.lt.(3*npts2-2), the routine will end with -c ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least leniw*2-npts2. -c if lenw.lt.leniw*2-npts2, the routine will end -c with ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdivision process, which -c determines the number of significant elements -c actually in the work arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least leniw. on return, -c the first k elements of which contain -c pointers to the error estimates over the -c subintervals, such that work(limit*3+iwork(1)),..., -c work(limit*3+iwork(k)) form a decreasing -c sequence, with k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c iwork(limit+1), ...,iwork(limit+last) contain the -c subdivision levels of the subintervals, i.e. -c if (aa,bb) is a subinterval of (p1,p2) -c where p1 as well as p2 is a user-provided -c break point or integration limit, then (aa,bb) has -c level l if abs(bb-aa) = abs(p2-p1)*2**(-l), -c iwork(limit*2+1), ..., iwork(limit*2+npts2) have -c no significance for the user, -c note that limit = (leniw-npts2)/2. -c -c work - double precision -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left -c end points of the subintervals in the -c partition of (a,b), -c work(limit+1), ..., work(limit+last) contain -c the right end points, -c work(limit*2+1), ..., work(limit*2+last) contain -c the integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3+last) -c contain the corresponding error estimates, -c work(limit*4+1), ..., work(limit*4+npts2) -c contain the integration limits and the -c break points sorted in an ascending sequence. -c note that limit = (leniw-npts2)/2. -c -c***references (none) -c***routines called dqagpe,xerror -c***end prologue dqagp -c - double precision a,abserr,b,epsabs,epsrel,f,points,result,work - integer ier,iwork,last,leniw,lenw,limit,lvl,l1,l2,l3,l4,neval, - * npts2 -c - dimension iwork(leniw),points(npts2),work(lenw) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement dqagp - ier = 6 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - if(leniw.lt.(3*npts2-2).or.lenw.lt.(leniw*2-npts2).or.npts2.lt.2) - * go to 10 -c -c prepare call for dqagpe. -c - limit = (leniw-npts2)/2 - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 - l4 = limit+l3 -c - call dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,abserr, - * neval,ier,work(1),work(l1),work(l2),work(l3),work(l4), - * iwork(1),iwork(l1),iwork(l2),last) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 - if(ier.ne.0) print*,'habnormal return from dqaps',ier,lvl - return - end - - subroutine dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, - * abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin, - * last) -c***begin prologue dqagpe -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a2a1 -c***keywords automatic integrator, general-purpose, -c singularities at user specified points, -c extrapolation, globally adaptive. -c***author piessens,robert ,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), hopefully -c satisfying following claim for accuracy abs(i-result).le. -c max(epsabs,epsrel*abs(i)). break points of the integration -c interval, where local difficulties of the integrand may -c occur(e.g. singularities,discontinuities),provided by user. -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c npts2 - integer -c number equal to two more than the number of -c user-supplied break points within the integration -c range, npts2.ge.2. -c if npts2.lt.2, the routine will end with ier = 6. -c -c points - double precision -c vector of dimension npts2, the first (npts2-2) -c elements of which are the user provided break -c points. if these points do not constitute an -c ascending sequence there will be an automatic -c sorting. -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c limit - integer -c gives an upper bound on the number of subintervals -c in the partition of (a,b), limit.ge.npts2 -c if limit.lt.npts2, the routine will end with -c ier = 6. -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine. -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (i.e. singularity, -c discontinuity within the interval), it -c should be supplied to the routine as an -c element of the vector points. if necessary -c an appropriate special-purpose integrator -c must be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. it is presumed that -c the requested tolerance cannot be -c achieved, and that the returned result is -c the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier.gt.0. -c = 6 the input is invalid because -c npts2.lt.2 or -c break points are specified outside -c the integration range or -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c or limit.lt.npts2. -c result, abserr, neval, last, rlist(1), -c and elist(1) are set to zero. alist(1) and -c blist(1) are set to a and b respectively. -c -c alist - double precision -c vector of dimension at least limit, the first -c last elements of which are the left end points -c of the subintervals in the partition of the given -c integration range (a,b) -c -c blist - double precision -c vector of dimension at least limit, the first -c last elements of which are the right end points -c of the subintervals in the partition of the given -c integration range (a,b) -c -c rlist - double precision -c vector of dimension at least limit, the first -c last elements of which are the integral -c approximations on the subintervals -c -c elist - double precision -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c pts - double precision -c vector of dimension at least npts2, containing the -c integration limits and the break points of the -c interval in ascending sequence. -c -c level - integer -c vector of dimension at least limit, containing the -c subdivision levels of the subinterval, i.e. if -c (aa,bb) is a subinterval of (p1,p2) where p1 as -c well as p2 is a user-provided break point or -c integration limit, then (aa,bb) has level l if -c abs(bb-aa) = abs(p2-p1)*2**(-l). -c -c ndin - integer -c vector of dimension at least npts2, after first -c integration over the intervals (pts(i)),pts(i+1), -c i = 0,1, ..., npts2-2, the error estimates over -c some of the intervals may have been increased -c artificially, in order to put their subdivision -c forward. if this happens for the subinterval -c numbered k, ndin(k) is put to 1, otherwise -c ndin(k) = 0. -c -c iord - integer -c vector of dimension at least limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., elist(iord(k)) -c form a decreasing sequence, with k = last -c if last.le.(limit/2+2), and k = limit+1-last -c otherwise -c -c last - integer -c number of subintervals actually produced in the -c subdivisions process -c -c***references (none) -c***routines called d1mach,dqelg,dqk21,dqpsrt -c***end prologue dqagpe - double precision a,abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,dmax1,dmin1, - * dres,d1mach,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, - * errmax,error1,erro12,error2,errsum,ertest,f,oflow,points,pts, - * resa,resabs,reseps,result,res3la,rlist,rlist2,sign,temp,uflow - integer i,id,ier,ierro,ind1,ind2,iord,ip1,iroff1,iroff2,iroff3,j, - * jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax,limit,maxerr, - * ndin,neval,nint,nintp1,npts,npts2,nres,nrmax,numrl2 - logical extrap,noext -c -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * level(limit),ndin(npts2),points(npts2),pts(npts2),res3la(3), - * rlist(limit),rlist2(52) -c - external f -c -c the dimension of rlist2 is determined by the value of -c limexp in subroutine epsalg (rlist2 should be of dimension -c (limexp+2) at least). -c -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c rlist2 - array of dimension at least limexp+2 -c containing the part of the epsilon table which -c is still needed for further computations -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest error -c estimate -c errmax - elist(maxerr) -c erlast - error on the interval currently subdivided -c (before that subdivision has taken place) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left subinterval -c *****2 - variable for the right subinterval -c last - index for subdivision -c nres - number of calls to the extrapolation routine -c numrl2 - number of elements in rlist2. if an appropriate -c approximation to the compounded integral has -c been obtained, it is put in rlist2(numrl2) after -c numrl2 has been increased by one. -c erlarg - sum of the errors over the intervals larger -c than the smallest interval considered up to now -c extrap - logical variable denoting that the routine -c is attempting to perform extrapolation. i.e. -c before subdividing the smallest interval we -c try to decrease the value of erlarg. -c noext - logical variable denoting that extrapolation is -c no longer allowed (true-value) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c oflow is the largest positive magnitude. -c -c***first executable statement dqagpe - epmach = d1mach(4) -c -c test on validity of parameters -c ----------------------------- -c - ier = 0 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - alist(1) = a - blist(1) = b - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - iord(1) = 0 - level(1) = 0 - npts = npts2-2 - if(npts2.lt.2.or.limit.le.npts.or.(epsabs.le.0.0d+00.and. - * epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28))) ier = 6 - if(ier.eq.6) go to 999 -c -c if any break points are provided, sort them into an -c ascending sequence. -c - sign = 1.0d+00 - if(a.gt.b) sign = -1.0d+00 - pts(1) = dmin1(a,b) - if(npts.eq.0) go to 15 - do 10 i = 1,npts - pts(i+1) = points(i) - 10 continue - 15 pts(npts+2) = dmax1(a,b) - nint = npts+1 - a1 = pts(1) - if(npts.eq.0) go to 40 - nintp1 = nint+1 - do 20 i = 1,nint - ip1 = i+1 - do 20 j = ip1,nintp1 - if(pts(i).le.pts(j)) go to 20 - temp = pts(i) - pts(i) = pts(j) - pts(j) = temp - 20 continue - if(pts(1).ne.dmin1(a,b).or.pts(nintp1).ne.dmax1(a,b)) ier = 6 - if(ier.eq.6) go to 999 -c -c compute first integral and error approximations. -c ------------------------------------------------ -c - 40 resabs = 0.0d+00 - do 50 i = 1,nint - b1 = pts(i+1) - call dqk21(f,a1,b1,area1,error1,defabs,resa) - abserr = abserr+error1 - result = result+area1 - ndin(i) = 0 - if(error1.eq.resa.and.error1.ne.0.0d+00) ndin(i) = 1 - resabs = resabs+defabs - level(i) = 0 - elist(i) = error1 - alist(i) = a1 - blist(i) = b1 - rlist(i) = area1 - iord(i) = i - a1 = b1 - 50 continue - errsum = 0.0d+00 - do 55 i = 1,nint - if(ndin(i).eq.1) elist(i) = abserr - errsum = errsum+elist(i) - 55 continue -c -c test on accuracy. -c - last = nint - neval = 21*nint - dres = dabs(result) - errbnd = dmax1(epsabs,epsrel*dres) - if(abserr.le.0.1d+03*epmach*resabs.and.abserr.gt.errbnd) ier = 2 - if(nint.eq.1) go to 80 - do 70 i = 1,npts - jlow = i+1 - ind1 = iord(i) - do 60 j = jlow,nint - ind2 = iord(j) - if(elist(ind1).gt.elist(ind2)) go to 60 - ind1 = ind2 - k = j - 60 continue - if(ind1.eq.iord(i)) go to 70 - iord(k) = iord(i) - iord(i) = ind1 - 70 continue - if(limit.lt.npts2) ier = 1 - 80 if(ier.ne.0.or.abserr.le.errbnd) go to 210 -c -c initialization -c -------------- -c - rlist2(1) = result - maxerr = iord(1) - errmax = elist(maxerr) - area = result - nrmax = 1 - nres = 0 - numrl2 = 1 - ktmin = 0 - extrap = .false. - noext = .false. - erlarg = errsum - ertest = errbnd - levmax = 1 - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ierro = 0 - uflow = d1mach(1) - oflow = d1mach(2) - abserr = oflow - ksgn = -1 - if(dres.ge.(0.1d+01-0.5d+02*epmach)*resabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 160 last = npts2,limit -c -c bisect the subinterval with the nrmax-th largest error -c estimate. -c - levcur = level(maxerr)+1 - a1 = alist(maxerr) - b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - erlast = errmax - call dqk21(f,a1,b1,area1,error1,resa,defab1) - call dqk21(f,a2,b2,area2,error2,resa,defab2) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - neval = neval+42 - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2) go to 95 - if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) - * .or.erro12.lt.0.99d+00*errmax) go to 90 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 90 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 95 level(maxerr) = levcur - level(last) = levcur - rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = dmax1(epsabs,epsrel*dabs(area)) -c -c test for roundoff error and eventually set error flag. -c - if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 - if(iroff2.ge.5) ierro = 3 -c -c set error flag in the case that the number of -c subintervals equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at a point of the integration range -c - if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* - * (dabs(a2)+0.1d+04*uflow)) ier = 4 -c -c append the newly-created intervals to the list. -c - if(error2.gt.error1) go to 100 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 110 - 100 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine dqpsrt to maintain the descending ordering -c in the list of error estimates and select the subinterval -c with nrmax-th largest error estimate (to be bisected next). -c - 110 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) -c ***jump out of do-loop - if(errsum.le.errbnd) go to 190 -c ***jump out of do-loop - if(ier.ne.0) go to 170 - if(noext) go to 160 - erlarg = erlarg-erlast - if(levcur+1.le.levmax) erlarg = erlarg+erro12 - if(extrap) go to 120 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(level(maxerr)+1.le.levmax) go to 160 - extrap = .true. - nrmax = 2 - 120 if(ierro.eq.3.or.erlarg.le.ertest) go to 140 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors over -c the larger intervals (erlarg) and perform extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 130 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) -c ***jump out of do-loop - if(level(maxerr)+1.le.levmax) go to 160 - nrmax = nrmax+1 - 130 continue -c -c perform extrapolation. -c - 140 numrl2 = numrl2+1 - rlist2(numrl2) = area - if(numrl2.le.2) go to 155 - call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) - ktmin = ktmin+1 - if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5 - if(abseps.ge.abserr) go to 150 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = dmax1(epsabs,epsrel*dabs(reseps)) -c ***jump out of do-loop - if(abserr.lt.ertest) go to 170 -c -c prepare bisection of the smallest interval. -c - 150 if(numrl2.eq.1) noext = .true. - if(ier.ge.5) go to 170 - 155 maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - levmax = levmax+1 - erlarg = errsum - 160 continue -c -c set the final result. -c --------------------- -c -c - 170 if(abserr.eq.oflow) go to 190 - if((ier+ierro).eq.0) go to 180 - if(ierro.eq.3) abserr = abserr+correc - if(ier.eq.0) ier = 3 - if(result.ne.0.0d+00.and.area.ne.0.0d+00)go to 175 - if(abserr.gt.errsum)go to 190 - if(area.eq.0.0d+00) go to 210 - go to 180 - 175 if(abserr/dabs(result).gt.errsum/dabs(area))go to 190 -c -c test on divergence. -c - 180 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. - * resabs*0.1d-01) go to 210 - if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03.or. - * errsum.gt.dabs(area)) ier = 6 - go to 210 -c -c compute global integral sum. -c - 190 result = 0.0d+00 - do 200 k = 1,last - result = result+rlist(k) - 200 continue - abserr = errsum - 210 if(ier.gt.2) ier = ier-1 - result = result*sign - 999 return - end diff --git a/src/green_func_p.f90 b/src/green_func_p.f90 index 60c6395..44eedbf 100644 --- a/src/green_func_p.f90 +++ b/src/green_func_p.f90 @@ -388,6 +388,7 @@ ! dKdu - its derivative !======================================================================= use const_and_precisions, only : zero,one + use numint, only : quanc8 IMPLICIT NONE REAL(wp_), INTENT(in) :: Zeff,fc,u,q,gam REAL(wp_), INTENT(out) :: K,dKdu diff --git a/src/math.f90 b/src/math.f90 new file mode 100644 index 0000000..4e4662e --- /dev/null +++ b/src/math.f90 @@ -0,0 +1,125 @@ +module math + + use const_and_precisions, only : wp_, zero, one + implicit none + +contains + + function catand(z) +!***begin prologue catan +!***purpose compute the complex arc tangent. +!***library slatec (fnlib) +!***category c4a +!***type complex (catan-c) +!***keywords arc tangent, elementary functions, fnlib, trigonometric +!***author fullerton, w., (lanl) +!***description +! +! catan(z) calculates the complex trigonometric arc tangent of z. +! the result is in units of radians, and the real part is in the first +! or fourth quadrant. +! +!***references (none) +!***routines called (none) +!***revision history (yymmdd) +! 770801 date written +! 890531 changed all specific intrinsics to generic. (wrb) +! 890531 revision date from version 3.2 +! 891214 prologue converted to version 4.0 format. (bab) +! 900315 calls to xerror changed to calls to xermsg. (thj) +! 900326 removed duplicate information from description section. +! (wrb) +!***end prologue catan + use const_and_precisions, only : comp_eps, pi2=>pihalf, czero, cunit + implicit none + complex(wp_) :: catand + complex(wp_), intent(in) :: z + complex(wp_) :: z2 + real(wp_) :: r,x,y,r2,xans,yans,twoi + integer :: i + logical, save :: first=.true. + integer, save :: nterms + real(wp_), save :: rmin, rmax, sqeps +!***first executable statement catan + if (first) then +! nterms = log(eps)/log(rbnd) where rbnd = 0.1 + nterms = int(-0.4343_wp_*log(0.5_wp_*comp_eps) + 1.0_wp_) + sqeps = sqrt(comp_eps) + rmin = sqrt (1.5_wp_*comp_eps) + rmax = 2.0_wp_/comp_eps + endif + first = .false. +! + r = abs(z) + if (r<=0.1_wp_) then +! + catand = z + if (r 0. + INTEGER :: j + real(wp_) :: ser,tmp,x,y + real(wp_), parameter :: stp=2.5066282746310005_wp_ + real(wp_), dimension(6), parameter :: cof=(/76.18009172947146_wp_, & + -86.50532032941677_wp_,24.01409824083091_wp_,-1.231739572450155_wp_, & + .1208650973866179e-2_wp_,-.5395239384953e-5_wp_/) + x=xx + y=x + tmp=x+5.5_wp_ + tmp=(x+0.5_wp_)*log(tmp)-tmp + ser=1.000000000190015_wp_ + do j=1,6 + y=y+1._wp_ + ser=ser+cof(j)/y + end do + gamm=exp(tmp)*(stp*ser/x) + end function gamm + +end module math \ No newline at end of file diff --git a/src/minpack.f90 b/src/minpack.f90 new file mode 100644 index 0000000..e661639 --- /dev/null +++ b/src/minpack.f90 @@ -0,0 +1,1401 @@ +module minpack + + use const_and_precisions, only : wp_ + implicit none + +contains + + subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) + use const_and_precisions, only : zero, one + implicit none +! arguments + integer, intent(in) :: n, ldfjac, lwa + integer, intent(out) :: info + real(wp_), intent(in) :: tol + real(wp_), intent(out) :: fvec(n), fjac(ldfjac,n), wa(lwa) + real(wp_), intent(inout) :: x(n) +! ********** +! +! subroutine hybrj1 +! +! the purpose of hybrj1 is to find a zero of a system of +! n nonlinear functions in n variables by a modification +! of the powell hybrid method. this is done by using the +! more general nonlinear equation solver hybrj. the user +! must provide a subroutine which calculates the functions +! and the jacobian. +! +! the subroutine statement is +! +! subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) +! +! where +! +! fcn is the name of the user-supplied subroutine which +! calculates the functions and the jacobian. fcn must +! be declared in an external statement in the user +! calling program, and should be written as follows. +! +! subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +! integer n,ldfjac,iflag +! real(8) x(n),fvec(n),fjac(ldfjac,n) +! ---------- +! if iflag = 1 calculate the functions at x and +! return this vector in fvec. do not alter fjac. +! if iflag = 2 calculate the jacobian at x and +! return this matrix in fjac. do not alter fvec. +! --------- +! return +! end +! +! the value of iflag should not be changed by fcn unless +! the user wants to terminate execution of hybrj1. +! in this case set iflag to a negative integer. +! +! n is a positive integer input variable set to the number +! of functions and variables. +! +! x is an array of length n. on input x must contain +! an initial estimate of the solution vector. on output x +! contains the final estimate of the solution vector. +! +! fvec is an output array of length n which contains +! the functions evaluated at the output x. +! +! fjac is an output n by n array which contains the +! orthogonal matrix q produced by the qr factorization +! of the final approximate jacobian. +! +! ldfjac is a positive integer input variable not less than n +! which specifies the leading dimension of the array fjac. +! +! tol is a nonnegative input variable. termination occurs +! when the algorithm estimates that the relative error +! between x and the solution is at most tol. +! +! info is an integer output variable. if the user has +! terminated execution, info is set to the (negative) +! value of iflag. see description of fcn. otherwise, +! info is set as follows. +! +! info = 0 improper input parameters. +! +! info = 1 algorithm estimates that the relative error +! between x and the solution is at most tol. +! +! info = 2 number of calls to fcn with iflag = 1 has +! reached 100*(n+1). +! +! info = 3 tol is too small. no further improvement in +! the approximate solution x is possible. +! +! info = 4 iteration is not making good progress. +! +! wa is a work array of length lwa. +! +! lwa is a positive integer input variable not less than +! (n*(n+13))/2. +! +! subprograms called +! +! user-supplied ...... fcn +! +! minpack-supplied ... hybrj +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: j, lr, maxfev, mode, nfev, njev, nprint + real(wp_) :: xtol +! parameters + real(wp_), parameter :: factor=1.0e2_wp_ + + interface + subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) + use const_and_precisions, only : wp_ + implicit none + integer :: n,ldfjac,iflag + real(wp_) :: x(n),fvec(n),fjac(ldfjac,n) + end subroutine fcn + end interface + + info = 0 +! +! check the input parameters for errors. +! + if (n <= 0 .or. ldfjac < n .or. tol < zero & + .or. lwa < (n*(n + 13))/2) return +! +! call hybrj. +! + maxfev = 100*(n + 1) + xtol = tol + mode = 2 + do j = 1, n + wa(j) = one + end do + nprint = 0 + lr = (n*(n + 1))/2 + call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode, & + factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1), & + wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info == 5) info = 4 + end subroutine hybrj1 + + subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, & + factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, & + wa3,wa4) + use const_and_precisions, only : zero, one, epsmch=>comp_eps + implicit none +! arguments + integer, intent(in) :: n, ldfjac, maxfev, mode, nprint, lr + integer, intent(out) :: info, nfev, njev + real(wp_), intent(in) :: xtol, factor + real(wp_), intent(out) :: fvec(n), fjac(ldfjac,n), r(lr), qtf(n), & + wa1(n), wa2(n), wa3(n), wa4(n) + real(wp_), intent(inout) :: x(n), diag(n) +! ********** +! +! subroutine hybrj +! +! the purpose of hybrj is to find a zero of a system of +! n nonlinear functions in n variables by a modification +! of the powell hybrid method. the user must provide a +! subroutine which calculates the functions and the jacobian. +! +! the subroutine statement is +! +! subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, +! mode,factor,nprint,info,nfev,njev,r,lr,qtf, +! wa1,wa2,wa3,wa4) +! +! where +! +! fcn is the name of the user-supplied subroutine which +! calculates the functions and the jacobian. fcn must +! be declared in an external statement in the user +! calling program, and should be written as follows. +! +! subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +! integer n,ldfjac,iflag +! real(8) x(n),fvec(n),fjac(ldfjac,n) +! ---------- +! if iflag = 1 calculate the functions at x and +! return this vector in fvec. do not alter fjac. +! if iflag = 2 calculate the jacobian at x and +! return this matrix in fjac. do not alter fvec. +! --------- +! return +! end +! +! the value of iflag should not be changed by fcn unless +! the user wants to terminate execution of hybrj. +! in this case set iflag to a negative integer. +! +! n is a positive integer input variable set to the number +! of functions and variables. +! +! x is an array of length n. on input x must contain +! an initial estimate of the solution vector. on output x +! contains the final estimate of the solution vector. +! +! fvec is an output array of length n which contains +! the functions evaluated at the output x. +! +! fjac is an output n by n array which contains the +! orthogonal matrix q produced by the qr factorization +! of the final approximate jacobian. +! +! ldfjac is a positive integer input variable not less than n +! which specifies the leading dimension of the array fjac. +! +! xtol is a nonnegative input variable. termination +! occurs when the relative error between two consecutive +! iterates is at most xtol. +! +! maxfev is a positive integer input variable. termination +! occurs when the number of calls to fcn with iflag = 1 +! has reached maxfev. +! +! diag is an array of length n. if mode = 1 (see +! below), diag is internally set. if mode = 2, diag +! must contain positive entries that serve as +! multiplicative scale factors for the variables. +! +! mode is an integer input variable. if mode = 1, the +! variables will be scaled internally. if mode = 2, +! the scaling is specified by the input diag. other +! values of mode are equivalent to mode = 1. +! +! factor is a positive input variable used in determining the +! initial step bound. this bound is set to the product of +! factor and the euclidean norm of diag*x if nonzero, or else +! to factor itself. in most cases factor should lie in the +! interval (.1,100.). 100. is a generally recommended value. +! +! nprint is an integer input variable that enables controlled +! printing of iterates if it is positive. in this case, +! fcn is called with iflag = 0 at the beginning of the first +! iteration and every nprint iterations thereafter and +! immediately prior to return, with x and fvec available +! for printing. fvec and fjac should not be altered. +! if nprint is not positive, no special calls of fcn +! with iflag = 0 are made. +! +! info is an integer output variable. if the user has +! terminated execution, info is set to the (negative) +! value of iflag. see description of fcn. otherwise, +! info is set as follows. +! +! info = 0 improper input parameters. +! +! info = 1 relative error between two consecutive iterates +! is at most xtol. +! +! info = 2 number of calls to fcn with iflag = 1 has +! reached maxfev. +! +! info = 3 xtol is too small. no further improvement in +! the approximate solution x is possible. +! +! info = 4 iteration is not making good progress, as +! measured by the improvement from the last +! five jacobian evaluations. +! +! info = 5 iteration is not making good progress, as +! measured by the improvement from the last +! ten iterations. +! +! nfev is an integer output variable set to the number of +! calls to fcn with iflag = 1. +! +! njev is an integer output variable set to the number of +! calls to fcn with iflag = 2. +! +! r is an output array of length lr which contains the +! upper triangular matrix produced by the qr factorization +! of the final approximate jacobian, stored rowwise. +! +! lr is a positive integer input variable not less than +! (n*(n+1))/2. +! +! qtf is an output array of length n which contains +! the vector (q transpose)*fvec. +! +! wa1, wa2, wa3, and wa4 are work arrays of length n. +! +! subprograms called +! +! user-supplied ...... fcn +! +! minpack-supplied ... dogleg,enorm, +! qform,qrfac,r1mpyq,r1updt +! +! fortran-supplied ... abs,dmax1,dmin1,mod +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, iflag, iter, j, jm1, l, ncfail, ncsuc, nslow1, nslow2 + integer, dimension(1) :: iwa + logical :: jeval, sing + real(wp_) :: actred, delta, fnorm, fnorm1, pnorm, prered, & + ratio, summ, temp, xnorm +! parameters + real(wp_), parameter :: p1 = 1.0e-1_wp_, p5 = 5.0e-1_wp_, & + p001 = 1.0e-3_wp_, p0001 = 1.0e-4_wp_ + + interface + subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) + use const_and_precisions, only : wp_ + implicit none + integer :: n,ldfjac,iflag + real(wp_) :: x(n),fvec(n),fjac(ldfjac,n) + end subroutine fcn + end interface +! + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +! +! check the input parameters for errors. +! + if (n <= 0 .or. ldfjac < n .or. xtol < zero & + .or. maxfev <= 0 .or. factor <= zero & + .or. lr < (n*(n + 1))/2) go to 300 + if (mode == 2) then + do j = 1, n + if (diag(j) <= zero) go to 300 + end do + end if +! +! evaluate the function at the starting point +! and calculate its norm. +! + iflag = 1 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag < 0) go to 300 + fnorm = enorm(n,fvec) +! +! initialize iteration counter and monitors. +! + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +! +! beginning of the outer loop. +! + do + jeval = .true. +! +! calculate the jacobian matrix. +! + iflag = 2 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag < 0) go to 300 +! +! compute the qr factorization of the jacobian. +! + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +! +! on the first iteration and if mode is 1, scale according +! to the norms of the columns of the initial jacobian. +! + if (iter == 1) then + if (mode /= 2) then + do j = 1, n + diag(j) = wa2(j) + if (wa2(j) == zero) diag(j) = one + end do + end if +! +! on the first iteration, calculate the norm of the scaled x +! and initialize the step bound delta. +! + do j = 1, n + wa3(j) = diag(j)*x(j) + end do + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta == zero) delta = factor + end if +! +! form (q transpose)*fvec and store in qtf. +! + do i = 1, n + qtf(i) = fvec(i) + end do + do j = 1, n + if (fjac(j,j) /= zero) then + summ = zero + do i = j, n + summ = summ + fjac(i,j)*qtf(i) + end do + temp = -summ/fjac(j,j) + do i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + end do + end if + end do +! +! copy the triangular factor of the qr factorization into r. +! + sing = .false. + do j = 1, n + l = j + jm1 = j - 1 + do i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + end do + r(l) = wa1(j) + if (wa1(j) == zero) sing = .true. + end do +! +! accumulate the orthogonal factor in fjac. +! + call qform(n,n,fjac,ldfjac,wa1) +! +! rescale if necessary. +! + if (mode /= 2) then + do j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + end do + end if +! +! beginning of the inner loop. +! + do +! +! if requested, call fcn to enable printing of iterates. +! + if (nprint > 0) then + iflag = 0 + if (mod(iter-1,nprint) == 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + if (iflag < 0) go to 300 + end if +! +! determine the direction p. +! + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +! +! store the direction p and x + p. calculate the norm of p. +! + do j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + end do + pnorm = enorm(n,wa3) +! +! on the first iteration, adjust the initial step bound. +! + if (iter == 1) delta = dmin1(delta,pnorm) +! +! evaluate the function at x + p and calculate its norm. +! + iflag = 1 + call fcn(n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag < 0) go to 300 + fnorm1 = enorm(n,wa4) +! +! compute the scaled actual reduction. +! + actred = -one + if (fnorm1 < fnorm) actred = one - (fnorm1/fnorm)**2 +! +! compute the scaled predicted reduction. +! + l = 1 + do i = 1, n + summ = zero + do j = i, n + summ = summ + r(l)*wa1(j) + l = l + 1 + end do + wa3(i) = qtf(i) + summ + end do + temp = enorm(n,wa3) + prered = zero + if (temp < fnorm) prered = one - (temp/fnorm)**2 +! +! compute the ratio of the actual to the predicted +! reduction. +! + ratio = zero + if (prered > zero) ratio = actred/prered +! +! update the step bound. +! + if (ratio < p1) then + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + else + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio >= p5 .or. ncsuc > 1) delta = dmax1(delta,pnorm/p5) + if (abs(ratio-one) <= p1) delta = pnorm/p5 + end if +! +! test for successful iteration. +! + if (ratio >= p0001) then +! +! successful iteration. update x, fvec, and their norms. +! + do j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + end do + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + end if +! +! determine the progress of the iteration. +! + nslow1 = nslow1 + 1 + if (actred >= p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred >= p1) nslow2 = 0 +! +! test for convergence. +! + if (delta <= xtol*xnorm .or. fnorm == zero) info = 1 + if (info /= 0) go to 300 +! +! tests for termination and stringent tolerances. +! + if (nfev >= maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) <= epsmch*xnorm) info = 3 + if (nslow2 == 5) info = 4 + if (nslow1 == 10) info = 5 + if (info /= 0) go to 300 +! +! criterion for recalculating jacobian. +! + if (ncfail == 2) exit +! +! calculate the rank one modification to the jacobian +! and update qtf if necessary. +! + do j = 1, n + summ = zero + do i = 1, n + summ = summ + fjac(i,j)*wa4(i) + end do + wa2(j) = (summ - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio >= p0001) qtf(j) = summ + end do +! +! compute the qr factorization of the updated jacobian. +! + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +! +! end of the inner loop. +! + jeval = .false. + end do +! +! end of the outer loop. +! + end do + 300 continue +! +! termination, either normal or user imposed. +! + if (iflag < 0) info = iflag + iflag = 0 + if (nprint > 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + end subroutine hybrj + + subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) + use const_and_precisions, only : zero, one, epsmch=>comp_eps + implicit none +! arguments + integer, intent(in) :: n, lr + real(wp_), intent(in) :: delta, r(lr), diag(n), qtb(n) + real(wp_), intent(out) :: x(n), wa1(n), wa2(n) +! ********** +! +! subroutine dogleg +! +! given an m by n matrix a, an n by n nonsingular diagonal +! matrix d, an m-vector b, and a positive number delta, the +! problem is to determine the convex combination x of the +! gauss-newton and scaled gradient directions that minimizes +! (a*x - b) in the least squares sense, subject to the +! restriction that the euclidean norm of d*x be at most delta. +! +! this subroutine completes the solution of the problem +! if it is provided with the necessary information from the +! qr factorization of a. that is, if a = q*r, where q has +! orthogonal columns and r is an upper triangular matrix, +! then dogleg expects the full upper triangle of r and +! the first n components of (q transpose)*b. +! +! the subroutine statement is +! +! subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) +! +! where +! +! n is a positive integer input variable set to the order of r. +! +! r is an input array of length lr which must contain the upper +! triangular matrix r stored by rows. +! +! lr is a positive integer input variable not less than +! (n*(n+1))/2. +! +! diag is an input array of length n which must contain the +! diagonal elements of the matrix d. +! +! qtb is an input array of length n which must contain the first +! n elements of the vector (q transpose)*b. +! +! delta is a positive input variable which specifies an upper +! bound on the euclidean norm of d*x. +! +! x is an output array of length n which contains the desired +! convex combination of the gauss-newton direction and the +! scaled gradient direction. +! +! wa1 and wa2 are work arrays of length n. +! +! subprograms called +! +! minpack-supplied ... enorm +! +! fortran-supplied ... abs,dmax1,dmin1,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, jj, jp1, k, l + real(wp_) :: alpha, bnorm, gnorm, qnorm, sgnorm, summ, temp +! +! first, calculate the gauss-newton direction. +! + jj = (n*(n + 1))/2 + 1 + do k = 1, n + j = n - k + 1 + jp1 = j + 1 + jj = jj - k + l = jj + 1 + summ = zero + do i = jp1, n + summ = summ + r(l)*x(i) + l = l + 1 + end do + temp = r(jj) + if (temp == zero) then + l = j + do i = 1, j + temp = dmax1(temp,abs(r(l))) + l = l + n - i + end do + temp = epsmch*temp + if (temp == zero) temp = epsmch + end if + x(j) = (qtb(j) - summ)/temp + end do +! +! test whether the gauss-newton direction is acceptable. +! + do j = 1, n + wa1(j) = zero + wa2(j) = diag(j)*x(j) + end do + qnorm = enorm(n,wa2) + if (qnorm <= delta) return +! +! the gauss-newton direction is not acceptable. +! next, calculate the scaled gradient direction. +! + l = 1 + do j = 1, n + temp = qtb(j) + do i = j, n + wa1(i) = wa1(i) + r(l)*temp + l = l + 1 + end do + wa1(j) = wa1(j)/diag(j) + end do +! +! calculate the norm of the scaled gradient and test for +! the special case in which the scaled gradient is zero. +! + gnorm = enorm(n,wa1) + sgnorm = zero + alpha = delta/qnorm + if (gnorm /= zero) then +! +! calculate the point along the scaled gradient +! at which the quadratic is minimized. +! + do j = 1, n + wa1(j) = (wa1(j)/gnorm)/diag(j) + end do + l = 1 + do j = 1, n + summ = zero + do i = j, n + summ = summ + r(l)*wa1(i) + l = l + 1 + end do + wa2(j) = summ + end do + temp = enorm(n,wa2) + sgnorm = (gnorm/temp)/temp +! +! test whether the scaled gradient direction is acceptable. +! + alpha = zero + if (sgnorm < delta) then +! +! the scaled gradient direction is not acceptable. +! finally, calculate the point along the dogleg +! at which the quadratic is minimized. +! + bnorm = enorm(n,qtb) + temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) + temp = temp - (delta/qnorm)*(sgnorm/delta)**2 & + + sqrt((temp-(delta/qnorm))**2 & + +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) + alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp + end if + end if +! +! form appropriate convex combination of the gauss-newton +! direction and the scaled gradient direction. +! + temp = (one - alpha)*dmin1(sgnorm,delta) + do j = 1, n + x(j) = temp*wa1(j) + alpha*x(j) + end do + end subroutine dogleg + + function enorm(n,x) + use const_and_precisions, only : zero, one + implicit none + real(wp_) :: enorm + integer, intent(in) :: n + real(wp_), dimension(n), intent(in) :: x +! ********** +! +! function enorm +! +! given an n-vector x, this function calculates the +! euclidean norm of x. +! +! the euclidean norm is computed by accumulating the sum of +! squares in three different sums. the sums of squares for the +! small and large components are scaled so that no overflows +! occur. non-destructive underflows are permitted. underflows +! and overflows do not occur in the computation of the unscaled +! sum of squares for the intermediate components. +! the definitions of small, intermediate and large components +! depend on two constants, rdwarf and rgiant. the main +! restrictions on these constants are that rdwarf**2 not +! underflow and rgiant**2 not overflow. the constants +! given here are suitable for every known computer. +! +! the function statement is +! +! real(8) function enorm(n,x) +! +! where +! +! n is a positive integer input variable. +! +! x is an input array of length n. +! +! subprograms called +! +! fortran-supplied ... abs,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** + integer :: i + real(wp_) :: agiant,floatn,s1,s2,s3,xabs,x1max,x3max + real(wp_), parameter :: rdwarf=3.834e-20_wp_,rgiant=1.304e19_wp_ + s1 = zero + s2 = zero + s3 = zero + x1max = zero + x3max = zero + floatn = n + agiant = rgiant/floatn + do i = 1, n + xabs = abs(x(i)) + if (xabs <= rdwarf .or. xabs >= agiant) then + if (xabs > rdwarf) then +! +! sum for large components. +! + if (xabs > x1max) then + s1 = one + s1*(x1max/xabs)**2 + x1max = xabs + else + s1 = s1 + (xabs/x1max)**2 + end if + else +! +! sum for small components. +! + if (xabs > x3max) then + s3 = one + s3*(x3max/xabs)**2 + x3max = xabs + else + if (xabs /= zero) s3 = s3 + (xabs/x3max)**2 + end if + end if + else +! +! sum for intermediate components. +! + s2 = s2 + xabs**2 + end if + end do +! +! calculation of norm. +! + if (s1 /= zero) then + enorm = x1max*sqrt(s1+(s2/x1max)/x1max) + else + if (s2 /= zero) then + if (s2 >= x3max) enorm = sqrt(s2*(one+(x3max/s2)*(x3max*s3))) + if (s2 < x3max) enorm = sqrt(x3max*((s2/x3max)+(x3max*s3))) + else + enorm = x3max*sqrt(s3) + end if + end if + end function enorm + + subroutine qform(m,n,q,ldq,wa) + use const_and_precisions, only : zero, one + implicit none +! arguments + integer, intent(in) :: m,n,ldq + real(wp_), intent(out) :: wa(m) + real(wp_), intent(inout) :: q(ldq,m) +! ********** +! +! subroutine qform +! +! this subroutine proceeds from the computed qr factorization of +! an m by n matrix a to accumulate the m by m orthogonal matrix +! q from its factored form. +! +! the subroutine statement is +! +! subroutine qform(m,n,q,ldq,wa) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of a and the order of q. +! +! n is a positive integer input variable set to the number +! of columns of a. +! +! q is an m by m array. on input the full lower trapezoid in +! the first min(m,n) columns of q contains the factored form. +! on output q has been accumulated into a square matrix. +! +! ldq is a positive integer input variable not less than m +! which specifies the leading dimension of the array q. +! +! wa is a work array of length m. +! +! subprograms called +! +! fortran-supplied ... min0 +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, jm1, k, l, minmn, np1 + real(wp_) :: summ, temp +! +! zero out upper triangle of q in the first min(m,n) columns. +! + minmn = min0(m,n) + do j = 2, minmn + jm1 = j - 1 + do i = 1, jm1 + q(i,j) = zero + end do + end do +! +! initialize remaining columns to those of the identity matrix. +! + np1 = n + 1 + do j = np1, m + do i = 1, m + q(i,j) = zero + end do + q(j,j) = one + end do +! +! accumulate q from its factored form. +! + do l = 1, minmn + k = minmn - l + 1 + do i = k, m + wa(i) = q(i,k) + q(i,k) = zero + end do + q(k,k) = one + if (wa(k) /= zero) then + do j = k, m + summ = zero + do i = k, m + summ = summ + q(i,j)*wa(i) + end do + temp = summ/wa(k) + do i = k, m + q(i,j) = q(i,j) - temp*wa(i) + end do + end do + end if + end do + end subroutine qform + + subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) + use const_and_precisions, only : zero, one, epsmch=>comp_eps + implicit none +! arguments + integer, intent(in) :: m, n, lda, lipvt + integer, intent(out) :: ipvt(lipvt) + logical, intent(in) :: pivot + real(wp_), intent(out) :: rdiag(n), acnorm(n), wa(n) + real(wp_), intent(inout) :: a(lda,n) +! ********** +! +! subroutine qrfac +! +! this subroutine uses householder transformations with column +! pivoting (optional) to compute a qr factorization of the +! m by n matrix a. that is, qrfac determines an orthogonal +! matrix q, a permutation matrix p, and an upper trapezoidal +! matrix r with diagonal elements of nonincreasing magnitude, +! such that a*p = q*r. the householder transformation for +! column k, k = 1,2,...,min(m,n), is of the form +! +! t +! i - (1/u(k))*u*u +! +! where u has zeros in the first k-1 positions. the form of +! this transformation and the method of pivoting first +! appeared in the corresponding linpack subroutine. +! +! the subroutine statement is +! +! subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of a. +! +! n is a positive integer input variable set to the number +! of columns of a. +! +! a is an m by n array. on input a contains the matrix for +! which the qr factorization is to be computed. on output +! the strict upper trapezoidal part of a contains the strict +! upper trapezoidal part of r, and the lower trapezoidal +! part of a contains a factored form of q (the non-trivial +! elements of the u vectors described above). +! +! lda is a positive integer input variable not less than m +! which specifies the leading dimension of the array a. +! +! pivot is a logical input variable. if pivot is set true, +! then column pivoting is enforced. if pivot is set false, +! then no column pivoting is done. +! +! ipvt is an integer output array of length lipvt. ipvt +! defines the permutation matrix p such that a*p = q*r. +! column j of p is column ipvt(j) of the identity matrix. +! if pivot is false, ipvt is not referenced. +! +! lipvt is a positive integer input variable. if pivot is false, +! then lipvt may be as small as 1. if pivot is true, then +! lipvt must be at least n. +! +! rdiag is an output array of length n which contains the +! diagonal elements of r. +! +! acnorm is an output array of length n which contains the +! norms of the corresponding columns of the input matrix a. +! if this information is not needed, then acnorm can coincide +! with rdiag. +! +! wa is a work array of length n. if pivot is false, then wa +! can coincide with rdiag. +! +! subprograms called +! +! minpack-supplied ... enorm +! +! fortran-supplied ... dmax1,sqrt,min0 +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, jp1, k, kmax, minmn + real(wp_) :: ajnorm, summ, temp +! parameters + real(wp_), parameter :: p05=5.0e-2_wp_ +! +! compute the initial column norms and initialize several arrays. +! + do j = 1, n + acnorm(j) = enorm(m,a(1,j)) + rdiag(j) = acnorm(j) + wa(j) = rdiag(j) + if (pivot) ipvt(j) = j + end do +! +! reduce a to r with householder transformations. +! + minmn = min0(m,n) + do j = 1, minmn + if (pivot) then +! +! bring the column of largest norm into the pivot position. +! + kmax = j + do k = j, n + if (rdiag(k) > rdiag(kmax)) kmax = k + end do + if (kmax /= j) then + do i = 1, m + temp = a(i,j) + a(i,j) = a(i,kmax) + a(i,kmax) = temp + end do + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + k = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = k + end if + end if +! +! compute the householder transformation to reduce the +! j-th column of a to a multiple of the j-th unit vector. +! + ajnorm = enorm(m-j+1,a(j,j)) + if (ajnorm /= zero) then + if (a(j,j) < zero) ajnorm = -ajnorm + do i = j, m + a(i,j) = a(i,j)/ajnorm + end do + a(j,j) = a(j,j) + one +! +! apply the transformation to the remaining columns +! and update the norms. +! + jp1 = j + 1 + do k = jp1, n + summ = zero + do i = j, m + summ = summ + a(i,j)*a(i,k) + end do + temp = summ/a(j,j) + do i = j, m + a(i,k) = a(i,k) - temp*a(i,j) + end do + if (pivot .and. rdiag(k) /= zero) then + temp = a(j,k)/rdiag(k) + rdiag(k) = rdiag(k)*sqrt(dmax1(zero,one-temp**2)) + if (p05*(rdiag(k)/wa(k))**2 <= epsmch) then + rdiag(k) = enorm(m-j,a(jp1,k)) + wa(k) = rdiag(k) + end if + end if + end do + end if + rdiag(j) = -ajnorm + end do + end subroutine qrfac + + subroutine r1mpyq(m,n,a,lda,v,w) + use const_and_precisions, only : one + implicit none +! arguments + integer, intent(in) :: m, n, lda + real(wp_), intent(in) :: v(n),w(n) + real(wp_), intent(inout) :: a(lda,n) +! ********** +! +! subroutine r1mpyq +! +! given an m by n matrix a, this subroutine computes a*q where +! q is the product of 2*(n - 1) transformations +! +! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +! +! and gv(i), gw(i) are givens rotations in the (i,n) plane which +! eliminate elements in the i-th and n-th planes, respectively. +! q itself is not given, rather the information to recover the +! gv, gw rotations is supplied. +! +! the subroutine statement is +! +! subroutine r1mpyq(m,n,a,lda,v,w) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of a. +! +! n is a positive integer input variable set to the number +! of columns of a. +! +! a is an m by n array. on input a must contain the matrix +! to be postmultiplied by the orthogonal matrix q +! described above. on output a*q has replaced a. +! +! lda is a positive integer input variable not less than m +! which specifies the leading dimension of the array a. +! +! v is an input array of length n. v(i) must contain the +! information necessary to recover the givens rotation gv(i) +! described above. +! +! w is an input array of length n. w(i) must contain the +! information necessary to recover the givens rotation gw(i) +! described above. +! +! subroutines called +! +! fortran-supplied ... abs,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, nmj, nm1 + real(wp_) :: cs, sn, temp +! +! apply the first set of givens rotations to a. +! + nm1 = n - 1 + if (nm1 < 1) return + do nmj = 1, nm1 + j = n - nmj + if (abs(v(j)) > one) cs = one/v(j) + if (abs(v(j)) > one) sn = sqrt(one-cs**2) + if (abs(v(j)) <= one) sn = v(j) + if (abs(v(j)) <= one) cs = sqrt(one-sn**2) + do i = 1, m + temp = cs*a(i,j) - sn*a(i,n) + a(i,n) = sn*a(i,j) + cs*a(i,n) + a(i,j) = temp + end do + end do +! +! apply the second set of givens rotations to a. +! + do j = 1, nm1 + if (abs(w(j)) > one) cs = one/w(j) + if (abs(w(j)) > one) sn = sqrt(one-cs**2) + if (abs(w(j)) <= one) sn = w(j) + if (abs(w(j)) <= one) cs = sqrt(one-sn**2) + do i = 1, m + temp = cs*a(i,j) + sn*a(i,n) + a(i,n) = -sn*a(i,j) + cs*a(i,n) + a(i,j) = temp + end do + end do + end subroutine r1mpyq + + subroutine r1updt(m,n,s,ls,u,v,w,sing) + use const_and_precisions, only : zero, one, giant=>comp_huge + implicit none +! arguments + integer, intent(in) :: m, n, ls + logical, intent(out) :: sing + real(wp_), intent(in) :: u(m) + real(wp_), intent(out) :: w(m) + real(wp_), intent(inout) :: s(ls), v(n) +! ********** +! +! subroutine r1updt +! +! given an m by n lower trapezoidal matrix s, an m-vector u, +! and an n-vector v, the problem is to determine an +! orthogonal matrix q such that +! +! t +! (s + u*v )*q +! +! is again lower trapezoidal. +! +! this subroutine determines q as the product of 2*(n - 1) +! transformations +! +! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +! +! where gv(i), gw(i) are givens rotations in the (i,n) plane +! which eliminate elements in the i-th and n-th planes, +! respectively. q itself is not accumulated, rather the +! information to recover the gv, gw rotations is returned. +! +! the subroutine statement is +! +! subroutine r1updt(m,n,s,ls,u,v,w,sing) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of s. +! +! n is a positive integer input variable set to the number +! of columns of s. n must not exceed m. +! +! s is an array of length ls. on input s must contain the lower +! trapezoidal matrix s stored by columns. on output s contains +! the lower trapezoidal matrix produced as described above. +! +! ls is a positive integer input variable not less than +! (n*(2*m-n+1))/2. +! +! u is an input array of length m which must contain the +! vector u. +! +! v is an array of length n. on input v must contain the vector +! v. on output v(i) contains the information necessary to +! recover the givens rotation gv(i) described above. +! +! w is an output array of length m. w(i) contains information +! necessary to recover the givens rotation gw(i) described +! above. +! +! sing is a logical output variable. sing is set true if any +! of the diagonal elements of the output s are zero. otherwise +! sing is set false. +! +! subprograms called +! +! fortran-supplied ... abs,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more, +! john l. nazareth +! +! ********** +! local variables + integer :: i, j, jj, l, nmj, nm1 + real(wp_) :: cs, cotan, sn, tn, tau, temp +! parameters + real(wp_), parameter :: p5=5.0e-1_wp_, p25=2.5e-1_wp_ +! +! initialize the diagonal element pointer. +! + jj = (n*(2*m - n + 1))/2 - (m - n) +! +! move the nontrivial part of the last column of s into w. +! + l = jj + do i = n, m + w(i) = s(l) + l = l + 1 + end do +! +! rotate the vector v into a multiple of the n-th unit vector +! in such a way that a spike is introduced into w. +! + nm1 = n - 1 + do nmj = 1, nm1 + j = n - nmj + jj = jj - (m - j + 1) + w(j) = zero + if (v(j) /= zero) then +! +! determine a givens rotation which eliminates the +! j-th element of v. +! + if (abs(v(n)) < abs(v(j))) then + cotan = v(n)/v(j) + sn = p5/sqrt(p25+p25*cotan**2) + cs = sn*cotan + tau = one + if (abs(cs)*giant > one) tau = one/cs + else + tn = v(j)/v(n) + cs = p5/sqrt(p25+p25*tn**2) + sn = cs*tn + tau = sn + end if +! +! apply the transformation to v and store the information +! necessary to recover the givens rotation. +! + v(n) = sn*v(j) + cs*v(n) + v(j) = tau +! +! apply the transformation to s and extend the spike in w. +! + l = jj + do i = j, m + temp = cs*s(l) - sn*w(i) + w(i) = sn*s(l) + cs*w(i) + s(l) = temp + l = l + 1 + end do + end if + end do +! +! add the spike from the rank 1 update to w. +! + do i = 1, m + w(i) = w(i) + v(n)*u(i) + end do +! +! eliminate the spike. +! + sing = .false. + do j = 1, nm1 + if (w(j) /= zero) then +! +! determine a givens rotation which eliminates the +! j-th element of the spike. +! + if (abs(s(jj)) < abs(w(j))) then + cotan = s(jj)/w(j) + sn = p5/sqrt(p25+p25*cotan**2) + cs = sn*cotan + tau = one + if (abs(cs)*giant > one) tau = one/cs + else + tn = w(j)/s(jj) + cs = p5/sqrt(p25+p25*tn**2) + sn = cs*tn + tau = sn + end if +! +! apply the transformation to s and reduce the spike in w. +! + l = jj + do i = j, m + temp = cs*s(l) + sn*w(i) + w(i) = -sn*s(l) + cs*w(i) + s(l) = temp + l = l + 1 + end do +! +! store the information necessary to recover the +! givens rotation. +! + w(j) = tau + end if +! +! test for zero diagonal elements in the output s. +! + if (s(jj) == zero) sing = .true. + jj = jj + (m - j + 1) + end do +! +! move w back into the last column of the output s. +! + l = jj + do i = n, m + s(l) = w(i) + l = l + 1 + end do + if (s(jj) == zero) sing = .true. +! + end subroutine r1updt + +end module minpack \ No newline at end of file diff --git a/src/numint.f90 b/src/numint.f90 new file mode 100644 index 0000000..c8b2474 --- /dev/null +++ b/src/numint.f90 @@ -0,0 +1,257 @@ +module numint + + use const_and_precisions, only : wp_, zero, one + implicit none + +contains + + subroutine simpson (n,h,fi,s) +! subroutine for integration over f(x) with the simpson rule. fi: +! integrand f(x); h: interval; s: integral. copyright (c) tao pang 1997. + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: h + real(wp_), dimension(n), intent(in) :: fi + real(wp_), intent(out) :: s + integer :: i + real(wp_) :: s0,s1,s2 + + s = zero + s0 = zero + s1 = zero + s2 = zero + do i = 2, n-1, 2 + s1 = s1+fi(i-1) + s0 = s0+fi(i) + s2 = s2+fi(i+1) + end do + s = h*(s1+4.0_wp_*s0+s2)/3.0_wp_ +! if n is even, add the last slice separately + if (mod(n,2).eq.0) s = s+h*(5.0_wp_*fi(n)+8.0_wp_*fi(n-1)-fi(n-2))/12.0_wp_ + end subroutine simpson + + subroutine trapezoid(n,xi,fi,s) +! subroutine for integration with the trapezoidal rule. +! fi: integrand f(x); xi: abscissa x; +! s: integral Int_{xi(1)}^{xi(n)} f(x)dx + implicit none + integer, intent(in) :: n + real(wp_), dimension(n), intent(in) :: xi,fi + real(wp_), intent(out) :: s + integer :: i + + s = zero + do i = 1, n-1 + s = s+(xi(i+1)-xi(i))*(fi(i+1)-fi(i)) + end do + s = 0.5_wp_*s + end subroutine trapezoid + + subroutine quanc8(fun,a,b,abserr,relerr,result,errest,nofun,flag) + implicit none + real(wp_), intent(in) :: a, b, abserr, relerr + real(wp_), intent(out) :: result, errest, flag + integer, intent(out) :: nofun +! +! estimate the integral of fun(x) from a to b +! to a user provided tolerance. +! an automatic adaptive routine based on +! the 8-panel newton-cotes rule. +! +! input .. +! +! fun the name of the integrand function subprogram fun(x). +! a the lower limit of integration. +! b the upper limit of integration.(b may be less than a.) +! relerr a relative error tolerance. (should be non-negative) +! abserr an absolute error tolerance. (should be non-negative) +! +! output .. +! +! result an approximation to the integral hopefully satisfying the +! least stringent of the two error tolerances. +! errest an estimate of the magnitude of the actual error. +! nofun the number of function values used in calculation of result. +! flag a reliability indicator. if flag is zero, then result +! probably satisfies the error tolerance. if flag is +! xxx.yyy , then xxx = the number of intervals which have +! not converged and 0.yyy = the fraction of the interval +! left to do when the limit on nofun was approached. +! + real(wp_) :: w0,w1,w2,w3,w4,area,x0,f0,stone,step,cor11,temp + real(wp_) :: qprev,qnow,qdiff,qleft,esterr,tolerr + real(wp_), dimension(31) :: qright + real(wp_), dimension(16) :: f,x + real(wp_), dimension(8,30) :: fsave,xsave + integer :: levmin,levmax,levout,nomax,nofin,lev,nim,i,j + + interface + function fun(x) + use const_and_precisions, only : wp_ + implicit none + real(wp_), intent(in) :: x + real(wp_) :: fun + end function fun + end interface +! +! *** stage 1 *** general initialization +! set constants. +! + levmin = 1 + levmax = 30 + levout = 6 + nomax = 5000 + nofin = nomax - 8*(levmax-levout+2**(levout+1)) +! +! trouble when nofun reaches nofin +! + w0 = 3956.0_wp_ / 14175.0_wp_ + w1 = 23552.0_wp_ / 14175.0_wp_ + w2 = -3712.0_wp_ / 14175.0_wp_ + w3 = 41984.0_wp_ / 14175.0_wp_ + w4 = -18160.0_wp_ / 14175.0_wp_ +! +! initialize running sums to zero. +! + flag = zero + result = zero + cor11 = zero + errest = zero + area = zero + nofun = 0 + if (a .eq. b) return +! +! *** stage 2 *** initialization for first interval +! + lev = 0 + nim = 1 + x0 = a + x(16) = b + qprev = zero + f0 = fun(x0) + stone = (b - a) / 16.0_wp_ + x(8) = (x0 + x(16)) / 2.0_wp_ + x(4) = (x0 + x(8)) / 2.0_wp_ + x(12) = (x(8) + x(16)) / 2.0_wp_ + x(2) = (x0 + x(4)) / 2.0_wp_ + x(6) = (x(4) + x(8)) / 2.0_wp_ + x(10) = (x(8) + x(12)) / 2.0_wp_ + x(14) = (x(12) + x(16)) / 2.0_wp_ + do j = 2, 16, 2 + f(j) = fun(x(j)) + end do + nofun = 9 +! +! *** stage 3 *** central calculation +! requires qprev,x0,x2,x4,...,x16,f0,f2,f4,...,f16. +! calculates x1,x3,...x15, f1,f3,...f15,qleft,qright,qnow,qdiff,area. +! + do + do + x(1) = (x0 + x(2)) / 2.0_wp_ + f(1) = fun(x(1)) + do j = 3, 15, 2 + x(j) = (x(j-1) + x(j+1)) / 2.0_wp_ + f(j) = fun(x(j)) + end do + nofun = nofun + 8 + step = (x(16) - x0) / 16.0_wp_ + qleft = (w0*(f0 + f(8)) + w1*(f(1)+f(7)) + w2*(f(2)+f(6)) & + + w3*(f(3)+f(5)) + w4*f(4)) * step + qright(lev+1)=(w0*(f(8)+f(16))+w1*(f(9)+f(15))+w2*(f(10)+f(14)) & + + w3*(f(11)+f(13)) + w4*f(12)) * step + qnow = qleft + qright(lev+1) + qdiff = qnow - qprev + area = area + qdiff +! +! *** stage 4 *** interval convergence test +! + esterr = abs(qdiff) / 1023.0_wp_ + tolerr = max(abserr,relerr*abs(area)) * (step/stone) + if (lev .ge. levmin) then +! +! *** stage 6 *** trouble section +! number of function values is about to exceed limit. +! + if (lev .ge. levmax) then +! +! current level is levmax. +! + flag = flag + one + exit + end if + if (nofun .gt. nofin) then + nofin = 2*nofin + levmax = levout + flag = flag + (b - x0) / (b - a) + exit + end if + if (esterr .le. tolerr) exit + end if +! +! *** stage 5 *** no convergence +! locate next interval. +! + nim = 2*nim + lev = lev+1 +! +! store right hand elements for future use. +! + do i = 1, 8 + fsave(i,lev) = f(i+8) + xsave(i,lev) = x(i+8) + end do +! +! assemble left hand elements for immediate use. +! + qprev = qleft + do i = 1, 8 + j = -i + f(2*j+18) = f(j+9) + x(2*j+18) = x(j+9) + end do + end do +! +! *** stage 7 *** interval converged +! add contributions into running sums. +! + result = result + qnow + errest = errest + esterr + cor11 = cor11 + qdiff / 1023.0_wp_ +! +! locate next interval. +! + do + if (nim .eq. 2*(nim/2)) exit + nim = nim/2 + lev = lev-1 + end do + nim = nim + 1 + if (lev .le. 0) exit +! +! assemble elements required for the next interval. +! + qprev = qright(lev) + x0 = x(16) + f0 = f(16) + do i = 1, 8 + f(2*i) = fsave(i,lev) + x(2*i) = xsave(i,lev) + end do + end do +! +! *** stage 8 *** finalize and return +! + result = result + cor11 +! +! make sure errest not less than roundoff level. +! + if (errest .eq. zero) return + do + temp = abs(result) + errest + if (temp .ne. abs(result)) return + errest = 2.0_wp_*errest + end do + end subroutine quanc8 + +end module numint \ No newline at end of file diff --git a/src/quadpack.f90 b/src/quadpack.f90 new file mode 100644 index 0000000..3279453 --- /dev/null +++ b/src/quadpack.f90 @@ -0,0 +1,4541 @@ +module quadpack + + use const_and_precisions, only : wp_ + implicit none + +contains + + subroutine dqags(f,a,b,epsabs,epsrel,result,abserr,neval,ier, & + limit,lenw,last,iwork,work) +!***begin prologue dqags +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end-point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & prog. div. - k.u.leuven +!***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)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! +! parameters +! on entry +! f - real(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(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 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<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! 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 + end if + if(ier==6) lvl = 1 + if(ier/=0) print*,'habnormal return from dqags',ier,lvl + end subroutine dqags + + subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, & + ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagse +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***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)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(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(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 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<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + real(wp_), intent(in) :: a,b,epsabs,epsrel + integer, intent(in) :: limit + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: neval,ier,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f +! + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,b1,b2,correc,abs, & + defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine 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. +! +!***first executable statement dqagse +! +! test on validity of parameters +! ------------------------------ + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = a + blist(1) = b + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with the nrmax-th largest error +! estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(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/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of subintervals +! equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=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 subroutine 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) +! ***jump out of do-loop + if(errsum<=errbnd) go to 115 +! ***jump out of do-loop + if(ier/=0) exit + if(last==2) then + small = abs(b-a)*0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! 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>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) +! ***jump out of do-loop + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + end if + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum) go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence. +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + if(ier>2) ier = ier-1 + 140 continue + neval = 42*last-21 + end subroutine dqagse + + subroutine dqelg(n,epstab,result,abserr,res3la,nres) +!***begin prologue dqelg +!***refer to dqagie,dqagoe,dqagpe,dqagse +!***routines called (none) +!***revision date 830518 (yymmdd) +!***keywords epsilon algorithm, convergence acceleration, +! extrapolation +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math & progr. div. - k.u.leuven +!***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. +!***description +! +! epsilon algorithm +! standard fortran subroutine +! real(8) version +! +! parameters +! n - integer +! epstab(n) contains the new element in the +! first column of the epsilon table. +! +! epstab - real(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(8) +! resulting approximation to the integral +! +! abserr - real(8) +! estimate of the absolute error computed from +! result and the 3 previous results +! +! res3la - real(8) +! vector of dimension 3 containing the last 3 +! results +! +! nres - integer +! number of calls to the routine +! (should be zero at first call) +! +!***end prologue dqelg +! + use const_and_precisions, only : epmach=>comp_eps, oflow=>comp_huge + implicit none + real(wp_), intent(out) :: abserr,result + real(wp_), dimension(52), intent(inout) :: epstab + real(wp_), dimension(3), intent(inout) :: res3la + integer, intent(inout) :: n,nres + real(wp_) :: abs,delta1,delta2,delta3,dmax1,epsinf,error, & + err1,err2,err3,e0,e1,e1abs,e2,e3,res,ss,tol1,tol2,tol3 + integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,newelm,num +! +! list of major variables +! ----------------------- +! +! 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. +! +!***first executable statement dqelg + nres = nres+1 + abserr = oflow + result = epstab(n) + if(n<3) go to 100 + limexp = 50 + epstab(n+2) = epstab(n) + newelm = (n-1)/2 + epstab(n) = oflow + num = n + k1 = n + do 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 = dmax1(abs(e2),e1abs)*epmach + delta3 = e1-e0 + err3 = abs(delta3) + tol3 = dmax1(e1abs,abs(e0))*epmach + if(err2<=tol2.and.err3<=tol3) then +! +! if e0, e1 and e2 are equal to within machine +! accuracy, convergence is assumed. +! result = e2 +! abserr = abs(e1-e0)+abs(e2-e1) +! + result = res + abserr = err2+err3 +! ***jump out of do-loop + go to 100 + end if + e3 = epstab(k1) + epstab(k1) = e1 + delta1 = e1-e3 + err1 = abs(delta1) + tol1 = dmax1(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<=tol1.or.err2<=tol2.or.err3<=tol3) go to 20 + ss = 0.1e+01_wp_/delta1+0.1e+01_wp_/delta2-0.1e+01_wp_/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>0.1e-03_wp_) go to 30 +! ***jump out of do-loop + 20 continue + n = i+i-1 + exit +! +! compute a new element and eventually adjust +! the value of result. +! + 30 continue + res = e1+0.1e+01_wp_/ss + epstab(k1) = res + k1 = k1-2 + error = err2+abs(res-e2)+err3 + if(error<=abserr) then + abserr = error + result = res + end if + end do +! +! shift the table. +! + if(n==limexp) n = 2*(limexp/2)-1 + ib = 1 + if((num/2)*2==num) ib = 2 + ie = newelm+1 + do i=1,ie + ib2 = ib+2 + epstab(ib) = epstab(ib2) + ib = ib2 + end do + if(num/=n) then + indx = num-n+1 + do i = 1,n + epstab(i)= epstab(indx) + indx = indx+1 + end do + end if + if(nres<4) then + res3la(nres) = result + abserr = oflow + else +! +! compute error estimate +! + abserr = abs(result-res3la(3))+abs(result-res3la(2)) & + +abs(result-res3la(1)) + res3la(1) = res3la(2) + res3la(2) = res3la(3) + res3la(3) = result + end if + 100 continue + abserr = dmax1(abserr,0.5e+01_wp_*epmach*abs(result)) + end subroutine dqelg + + subroutine dqk21(f,a,b,result,abserr,resabs,resasc) +!***begin prologue dqk21 +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a2 +!***keywords 21-point gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose to compute i = integral of f over (a,b), with error +! estimate +! j = integral of abs(f) over (a,b) +!***description +! +! integration rules +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(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(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! on return +! result - real(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(8) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk21 +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,centr,abs,dhlgth,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh + real(wp_), dimension(10) :: fv1,fv2 + integer :: j,jtw,jtwm1 +! +! 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. +! + real(wp_), dimension(5), parameter :: & + wg = (/ 0.066671344308688137593568809893332_wp_, & + 0.149451349150580593145776339657697_wp_, & + 0.219086362515982043995534934228163_wp_, & + 0.269266719309996355091226921569469_wp_, & + 0.295524224714752870173892994651338_wp_ /) +! + real(wp_), dimension(11), parameter :: & + xgk = (/ 0.995657163025808080735527280689003_wp_, & + 0.973906528517171720077964012084452_wp_, & + 0.930157491355708226001207180059508_wp_, & + 0.865063366688984510732096688423493_wp_, & + 0.780817726586416897063717578345042_wp_, & + 0.679409568299024406234327365114874_wp_, & + 0.562757134668604683339000099272694_wp_, & + 0.433395394129247190799265943165784_wp_, & + 0.294392862701460198131126603103866_wp_, & + 0.148874338981631210884826001129720_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.011694638867371874278064396062192_wp_, & + 0.032558162307964727478818972459390_wp_, & + 0.054755896574351996031381300244580_wp_, & + 0.075039674810919952767043140916190_wp_, & + 0.093125454583697605535065465083366_wp_, & + 0.109387158802297641899210590325805_wp_, & + 0.123491976262065851077958109831074_wp_, & + 0.134709217311473325928054001771707_wp_, & + 0.142775938577060080797094273138717_wp_, & + 0.147739104901338491374841515972068_wp_, & + 0.149445554002916905664936468389821_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! 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. +! +!***first executable statement dqk21 + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + dhlgth = abs(hlgth) +! +! compute the 21-point kronrod approximation to +! the integral, and estimate the absolute error. +! + resg = 0.0e+00_wp_ + 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.5e+00_wp_ + 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/=0.0e+00_wp_.and.abserr/=0.0e+00_wp_) & + abserr = resasc*dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk21 + + subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) +!***begin prologue dqpsrt +!***refer to dqage,dqagie,dqagpe,dqawse +!***routines called (none) +!***revision date 810101 (yymmdd) +!***keywords sequential sorting +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***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. +!***description +! +! ordering routine +! standard fortran subroutine +! real(8) version +! +! parameters (meaning at output) +! limit - integer +! maximum number of error estimates the list +! can contain +! +! last - integer +! number of error estimates currently in the list +! +! maxerr - integer +! maxerr points to the nrmax-th largest error +! estimate currently in the list +! +! ermax - real(8) +! nrmax-th largest error estimate +! ermax = elist(maxerr) +! +! elist - real(8) +! vector of dimension last containing +! the error estimates +! +! iord - integer +! 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<=(limit/2+2), and +! k = limit+1-last otherwise +! +! nrmax - integer +! maxerr = iord(nrmax) +! +!***end prologue dqpsrt +! + implicit none + integer, intent(in) :: last,limit + real(wp_), intent(out) :: ermax + integer, intent(inout) :: maxerr,nrmax + real(wp_), dimension(last), intent(inout) :: elist + integer, dimension(last), intent(inout) :: iord + real(wp_) :: errmax,errmin + integer :: i,ibeg,ido,isucc,j,jbnd,jupbn,k +! +! check whether the list contains more than +! two error estimates. +! +!***first executable statement dqpsrt + if(last<=2) then + iord(1) = 1 + iord(2) = 2 + go to 90 + end if +! +! 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. +! + errmax = elist(maxerr) + if(nrmax/=1) then + ido = nrmax-1 + do i = 1,ido + isucc = iord(nrmax-1) +! ***jump out of do-loop + if(errmax<=elist(isucc)) exit + iord(nrmax) = isucc + nrmax = nrmax-1 + end do + end if +! +! compute the number of elements in the list to be maintained +! in descending order. this number depends on the number of +! subdivisions still allowed. +! + jupbn = last + if(last>(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) +! ***jump out of do-loop + if(errmax>=elist(isucc)) then +! +! insert errmin by traversing the list bottom-up. +! + iord(i-1) = maxerr + k = jbnd + do j=i,jbnd + isucc = iord(k) +! ***jump out of do-loop + if(errmin0 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<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! 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) +! + end if + if(ier/=0) print*,'habnormal return from dqagi' + end subroutine dqagi + + subroutine dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, & + neval,ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagie +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a1,h2a4a1 +!***keywords automatic integrator, infinite intervals, +! general-purpose, transformation, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math & progr. div - k.u.leuven +! de doncker,elise,appl. math & progr. div - k.u.leuven +!***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)<=max(epsabs,epsrel*abs(i)) +!***description +! +! integration over infinite intervals +! standard fortran subroutine +! +! f - real(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(8) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - real(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(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel=1 +! +! on return +! result - real(8) +! approximation to the integral +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! - ier>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<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + integer, intent(in) :: limit,inf + real(wp_), intent(in) :: bound,epsabs,epsrel + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: ier,neval,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,boun,b1,b2,correc, & + abs,defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine dqelg. +! +! +! 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 +! 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. +! +!***first executable statement dqagie +! +! test on validity of parameters +! ----------------------------- +! + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = 0.0e+00_wp_ + blist(1) = 0.1e+01_wp_ + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + iord(1) = 0 + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) go to 130 +! +! initialization +! -------------- +! + 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with nrmax-th largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(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/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at some points of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=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 subroutine 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(errsum<=errbnd) go to 115 + if(ier/=0) exit + if(last==2) then + small = 0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! 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>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do + end if +! +! perform extrapolation. +! + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum)go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + neval = 30*last-15 + if(inf==2) neval = 2*neval + if(ier>2) ier=ier-1 + end subroutine dqagie + + subroutine dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc) +!***begin prologue dqk15i +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a2,h2a4a2 +!***keywords 15-point transformed gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***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). +!***description +! +! integration rule +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(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(8) +! finite bound of original integration +! range (set to zero if inf = +2) +! +! inf - integer +! 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(8) +! lower limit for integration over subrange +! of (0,1) +! +! b - real(8) +! upper limit for integration over subrange +! of (0,1) +! +! on return +! result - real(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(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of +! abs((transformed integrand)-i/(b-a)) over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk15i +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b,boun + integer, intent(in) :: inf + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,absc1,absc2,centr,abs,dinf,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh,tabsc1,tabsc2 + real(wp_), dimension(7) :: fv1,fv2 + integer :: j +! +! 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. +! + real(wp_), dimension(8), parameter :: & + wg = (/ 0.000000000000000000000000000000000_wp_, & + 0.129484966168869693270611432679082_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.279705391489276667901467771423780_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.381830050505118944950369775488975_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.417959183673469387755102040816327_wp_ /), & + xgk = (/ 0.991455371120812639206854697526329_wp_, & + 0.949107912342758524526189684047851_wp_, & + 0.864864423359769072789712788640926_wp_, & + 0.741531185599394439863864773280788_wp_, & + 0.586087235467691130294144838258730_wp_, & + 0.405845151377397166906606412076961_wp_, & + 0.207784955007898467600689403773245_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.022935322010529224963732008058970_wp_, & + 0.063092092629978553290700663189204_wp_, & + 0.104790010322250183839876322541518_wp_, & + 0.140653259715525918745189590510238_wp_, & + 0.169004726639267902826583426598550_wp_, & + 0.190350578064785409913256402421014_wp_, & + 0.204432940075298892414161999234649_wp_, & + 0.209482141084727828012999174891714_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! 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. +! +!***first executable statement dqk15i + dinf = min0(1,inf) +! + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + tabsc1 = boun+dinf*(0.1e+01_wp_-centr)/centr + fval1 = f(tabsc1) + if(inf==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.1e+01_wp_-absc1)/absc1 + tabsc2 = boun+dinf*(0.1e+01_wp_-absc2)/absc2 + fval1 = f(tabsc1) + fval2 = f(tabsc2) + if(inf==2) fval1 = fval1+f(-tabsc1) + if(inf==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.5e+00_wp_ + 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/=0.0e+00_wp_.and.abserr/=0._wp_) abserr = resasc* & + dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk15i + + subroutine dqagp(f,a,b,npts2,points,epsabs,epsrel,result,abserr, & + neval,ier,leniw,lenw,last,iwork,work) +!***begin prologue dqagp +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a2a1 +!***keywords automatic integrator, general-purpose, +! singularities at user specified points, +! extrapolation, globally adaptive +!***author piessens,robert,appl. math. & progr. div - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***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. +!***description +! +! computation of a definite integral +! standard fortran subroutine +! double precision version +! +! parameters +! on entry +! f - double precision +! 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 - double precision +! lower limit of integration +! +! b - double precision +! upper limit of integration +! +! npts2 - integer +! 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 - double precision +! 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 - double precision +! absolute accuracy requested +! epsrel - double precision +! 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 - double precision +! approximation to the integral +! +! abserr - double precision +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! 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 +! 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 +! 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 +! 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 +! 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 - double precision +! 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. +! +!***references (none) +!***routines called dqagpe,xerror +!***end prologue dqagp +! + implicit none + real(wp_), intent(in) :: a,b,epsabs,epsrel + integer, intent(in) :: npts2,lenw,leniw + real(wp_), intent(in), dimension(npts2) ::points + real(wp_), intent(out) :: abserr,result + integer, intent(out) :: neval,ier,last + integer :: limit,lvl,l1,l2,l3,l4 +! + real(wp_), dimension(lenw) :: work + integer, dimension(leniw) :: iwork +! + real(wp_), external :: f +! +! check validity of limit and lenw. +! +!***first executable statement dqagp + ier = 6 + neval = 0 + last = 0 + result = 0.0_wp_ + abserr = 0.0_wp_ + if(leniw.ge.(3*npts2-2).and.lenw.ge.(leniw*2-npts2).and.npts2.ge.2) then +! +! 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 + end if + if(ier.eq.6) lvl = 1 + if(ier.ne.0) print*,'habnormal return from dqaps',ier,lvl + end subroutine dqagp + + subroutine dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, & + abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin,last) +!***begin prologue dqagpe +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a2a1 +!***keywords automatic integrator, general-purpose, +! singularities at user specified points, +! extrapolation, globally adaptive. +!***author piessens,robert ,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***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. +!***description +! +! computation of a definite integral +! standard fortran subroutine +! double precision version +! +! parameters +! on entry +! f - double precision +! 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 - double precision +! lower limit of integration +! +! b - double precision +! upper limit of integration +! +! npts2 - integer +! 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 - double precision +! 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 - double precision +! absolute accuracy requested +! epsrel - double precision +! 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 +! 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 - double precision +! approximation to the integral +! +! abserr - double precision +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! 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 - double precision +! 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 - double precision +! 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 - double precision +! vector of dimension at least limit, the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - double precision +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! pts - double precision +! vector of dimension at least npts2, containing the +! integration limits and the break points of the +! interval in ascending sequence. +! +! level - integer +! 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 +! 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 +! 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 +! number of subintervals actually produced in the +! subdivisions process +! +!***references (none) +!***routines called dqelg,dqk21,dqpsrt +!***end prologue dqagpe + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + real(wp_) :: a,abseps,abserr,alist,area,area1,area12,area2,a1, & + a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,dmax1,dmin1, & + dres,elist,epsabs,epsrel,erlarg,erlast,errbnd, & + errmax,error1,erro12,error2,errsum,ertest,points,pts, & + resa,resabs,reseps,result,res3la,rlist,rlist2,sign,temp + integer :: i,id,ier,ierro,ind1,ind2,iord,ip1,iroff1,iroff2,iroff3,j, & + jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax,limit,maxerr, & + ndin,neval,nint,nintp1,npts,npts2,nres,nrmax,numrl2 + logical :: extrap,noext +! +! + dimension alist(limit),blist(limit),elist(limit),iord(limit), & + level(limit),ndin(npts2),points(npts2),pts(npts2),res3la(3), & + rlist(limit),rlist2(52) +! + real(wp_), external :: f +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine epsalg (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 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. +! +!***first executable statement dqagpe +! +! test on validity of parameters +! ----------------------------- +! + ier = 0 + neval = 0 + last = 0 + result = 0.0_wp_ + abserr = 0.0_wp_ + alist(1) = a + blist(1) = b + rlist(1) = 0.0_wp_ + elist(1) = 0.0_wp_ + iord(1) = 0 + level(1) = 0 + npts = npts2-2 + if(npts2.lt.2.or.limit.le.npts.or.(epsabs.le.0.0_wp_.and. & + epsrel.lt.dmax1(0.5e+02_wp_*epmach,0.5e-28_wp_))) ier = 6 + if(ier.eq.6) return +! +! if any break points are provided, sort them into an +! ascending sequence. +! + sign = 1.0_wp_ + if(a.gt.b) sign = -1.0_wp_ + pts(1) = dmin1(a,b) + do i = 1,npts + pts(i+1) = points(i) + end do + pts(npts+2) = dmax1(a,b) + nint = npts+1 + a1 = pts(1) + if(npts.ne.0) then + 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.dmin1(a,b).or.pts(nintp1).ne.dmax1(a,b)) ier = 6 + if(ier.eq.6) return + end if +! +! compute first integral and error approximations. +! ------------------------------------------------ +! + resabs = 0.0_wp_ + 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.0_wp_) 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.0_wp_ + 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 = dabs(result) + errbnd = dmax1(epsabs,epsrel*dres) + if(abserr.le.0.1d+03*epmach*resabs.and.abserr.gt.errbnd) ier = 2 + if(nint.ne.1) then + 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 + end if + if(ier.eq.0.and.abserr.gt.errbnd) then +! +! 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 + abserr = oflow + ksgn = -1 + if(dres.ge.(0.1d+01-0.5d+02*epmach)*resabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do 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.ne.error1.and.defab2.ne.error2) then + if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12) & + .and.erro12.ge.0.99d+00*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + end if + level(maxerr) = levcur + level(last) = levcur + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(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(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* & + (dabs(a2)+0.1d+04*uflow)) ier = 4 +! +! 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 subroutine 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) +! ***jump out of do-loop + if(errsum.le.errbnd) go to 190 +! ***jump out of do-loop + if(ier.ne.0) exit + if(noext) cycle + erlarg = erlarg-erlast + if(levcur+1.le.levmax) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(level(maxerr)+1.le.levmax) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro.ne.3.and.erlarg.gt.ertest) then +! +! 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) +! ***jump out of do-loop + if(level(maxerr)+1.le.levmax) go to 160 + nrmax = nrmax+1 + end do + end if +! +! perform extrapolation. +! + numrl2 = numrl2+1 + rlist2(numrl2) = area + if(numrl2.gt.2) then + 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.lt.abserr) then + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = dmax1(epsabs,epsrel*dabs(reseps)) +! ***jump out of do-loop + if(abserr.lt.ertest) exit + end if +! +! prepare bisection of the smallest interval. +! + if(numrl2.eq.1) noext = .true. + if(ier.ge.5) exit + end if + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + levmax = levmax+1 + erlarg = errsum + 160 continue + end do +! +! set the final result. +! --------------------- +! +! + if(abserr.eq.oflow) go to 190 + if((ier+ierro).ne.0) then + 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) then + if(abserr/dabs(result).gt.errsum/dabs(area))go to 190 + else + if(abserr.gt.errsum)go to 190 + if(area.eq.0.0d+00) go to 210 + end if +! +! test on divergence. +! + end if + if(ksgn.ne.(-1).or.dmax1(dabs(result),dabs(area)).gt.resabs*0.1d-01) then + if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03.or. & + errsum.gt.dabs(area)) ier = 6 + end if + go to 210 +! +! compute global integral sum. +! + 190 result = 0.0d+00 + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + end if + 210 if(ier.gt.2) ier = ier-1 + result = result*sign + end subroutine dqagpe +! +! +! Integration routine dqags.f from quadpack and dependencies: BEGIN +! Modified version for functions f(x,yi) with more than one variable +! +! + subroutine dqagsmv(f,a,b,apar,np,epsabs,epsrel,result,abserr,neval,ier, & + limit,lenw,last,iwork,work) +!***begin prologue dqagsmv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end-point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & prog. div. - k.u.leuven +!***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)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 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<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! prepare call for dqagse. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +! + call dqagsemv(f,a,b,apar,np,epsabs,epsrel,limit,result,abserr,neval, & + ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 + end if + if(ier==6) lvl = 1 + if(ier/=0) print*,'habnormal return from dqags',ier,lvl + end subroutine dqagsmv + + subroutine dqagsemv(f,a,b,apar,np,epsabs,epsrel,limit,result,abserr,neval, & + ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagsemv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***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)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 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<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + real(wp_), intent(in) :: a,b,epsabs,epsrel + integer, intent(in) :: limit,np + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: neval,ier,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f +! + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,b1,b2,correc,abs, & + defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine 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. +! +!***first executable statement dqagsemv +! +! test on validity of parameters +! ------------------------------ + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = a + blist(1) = b + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with the nrmax-th largest error +! estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk21mv(f,a1,b1,apar,np,area1,error1,resabs,defab1) + call dqk21mv(f,a2,b2,apar,np,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/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of subintervals +! equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=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 subroutine 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) +! ***jump out of do-loop + if(errsum<=errbnd) go to 115 +! ***jump out of do-loop + if(ier/=0) exit + if(last==2) then + small = abs(b-a)*0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! 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>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) +! ***jump out of do-loop + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + end if + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum) go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence. +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + if(ier>2) ier = ier-1 + 140 continue + neval = 42*last-21 + end subroutine dqagsemv + + subroutine dqk21mv(f,a,b,apar,np,result,abserr,resabs,resasc) +!***begin prologue dqk21mv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a2 +!***keywords 21-point gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose to compute i = integral of f over (a,b), with error +! estimate +! j = integral of abs(f) over (a,b) +!***description +! +! integration rules +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! on return +! result - real(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(8) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk21mv +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b + integer, intent(in) :: np + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,centr,abs,dhlgth,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh + real(wp_), dimension(10) :: fv1,fv2 + integer :: j,jtw,jtwm1 +! +! 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. +! + real(wp_), dimension(5), parameter :: & + wg = (/ 0.066671344308688137593568809893332_wp_, & + 0.149451349150580593145776339657697_wp_, & + 0.219086362515982043995534934228163_wp_, & + 0.269266719309996355091226921569469_wp_, & + 0.295524224714752870173892994651338_wp_ /) +! + real(wp_), dimension(11), parameter :: & + xgk = (/ 0.995657163025808080735527280689003_wp_, & + 0.973906528517171720077964012084452_wp_, & + 0.930157491355708226001207180059508_wp_, & + 0.865063366688984510732096688423493_wp_, & + 0.780817726586416897063717578345042_wp_, & + 0.679409568299024406234327365114874_wp_, & + 0.562757134668604683339000099272694_wp_, & + 0.433395394129247190799265943165784_wp_, & + 0.294392862701460198131126603103866_wp_, & + 0.148874338981631210884826001129720_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.011694638867371874278064396062192_wp_, & + 0.032558162307964727478818972459390_wp_, & + 0.054755896574351996031381300244580_wp_, & + 0.075039674810919952767043140916190_wp_, & + 0.093125454583697605535065465083366_wp_, & + 0.109387158802297641899210590325805_wp_, & + 0.123491976262065851077958109831074_wp_, & + 0.134709217311473325928054001771707_wp_, & + 0.142775938577060080797094273138717_wp_, & + 0.147739104901338491374841515972068_wp_, & + 0.149445554002916905664936468389821_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! 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. +! +!***first executable statement dqk21mv + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + dhlgth = abs(hlgth) +! +! compute the 21-point kronrod approximation to +! the integral, and estimate the absolute error. +! + resg = 0.0e+00_wp_ + fc = f(centr,apar,np) + resk = wgk(11)*fc + resabs = abs(resk) + do j=1,5 + jtw = 2*j + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc,apar,np) + fval2 = f(centr+absc,apar,np) + 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,apar,np) + fval2 = f(centr+absc,apar,np) + 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.5e+00_wp_ + 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/=0.0e+00_wp_.and.abserr/=0.0e+00_wp_) & + abserr = resasc*dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk21mv + + subroutine dqagimv(f,bound,inf,apar,np,epsabs,epsrel,result,abserr,neval, & + ier,limit,lenw,last,iwork,work) +!***begin prologue dqagimv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a1,h2a4a1 +!***keywords automatic integrator, infinite intervals, +! general-purpose, transformation, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. -k.u.leuven +!***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)<=max(epsabs,epsrel*abs(i)). +!***description +! +! integration over infinite intervals +! standard fortran subroutine +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! bound - real(8) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - integer +! indicating the kind of integration range involved +! inf = 1 corresponds to (bound,+infinity), +! inf = -1 to (-infinity,bound), +! inf = 2 to (-infinity,+infinity). +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 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<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! prepare call for dqagie. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +! + call dqagiemv(f,bound,inf,apar,np,epsabs,epsrel,limit,result,abserr, & + neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! + end if + if(ier/=0) print*,'habnormal return from dqagi' + end subroutine dqagimv + + subroutine dqagiemv(f,bound,inf,apar,np,epsabs,epsrel,limit,result,abserr, & + neval,ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagiemv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a1,h2a4a1 +!***keywords automatic integrator, infinite intervals, +! general-purpose, transformation, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math & progr. div - k.u.leuven +! de doncker,elise,appl. math & progr. div - k.u.leuven +!***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)<=max(epsabs,epsrel*abs(i)) +!***description +! +! integration over infinite intervals +! standard fortran subroutine +! +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! bound - real(8) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - real(8) +! indicating the kind of integration range involved +! inf = 1 corresponds to (bound,+infinity), +! inf = -1 to (-infinity,bound), +! inf = 2 to (-infinity,+infinity). +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel=1 +! +! on return +! result - real(8) +! approximation to the integral +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! - ier>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<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + integer, intent(in) :: limit,inf,np + real(wp_), intent(in) :: bound,epsabs,epsrel + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: ier,neval,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,boun,b1,b2,correc, & + abs,defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine dqelg. +! +! +! 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 +! 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. +! +!***first executable statement dqagie +! +! test on validity of parameters +! ----------------------------- +! + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = 0.0e+00_wp_ + blist(1) = 0.1e+01_wp_ + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + iord(1) = 0 + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) go to 130 +! +! initialization +! -------------- +! + 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with nrmax-th largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk15imv(f,boun,inf,a1,b1,apar,np,area1,error1,resabs,defab1) + call dqk15imv(f,boun,inf,a2,b2,apar,np,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/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at some points of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=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 subroutine 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(errsum<=errbnd) go to 115 + if(ier/=0) exit + if(last==2) then + small = 0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! 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>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do + end if +! +! perform extrapolation. +! + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum)go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + neval = 30*last-15 + if(inf==2) neval = 2*neval + if(ier>2) ier=ier-1 + end subroutine dqagiemv + + subroutine dqk15imv(f,boun,inf,a,b,apar,np,result,abserr,resabs,resasc) +!***begin prologue dqk15imv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a2,h2a4a2 +!***keywords 15-point transformed gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***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). +!***description +! +! integration rule +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! fuction subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! boun - real(8) +! finite bound of original integration +! range (set to zero if inf = +2) +! +! inf - integer +! 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(8) +! lower limit for integration over subrange +! of (0,1) +! +! b - real(8) +! upper limit for integration over subrange +! of (0,1) +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! on return +! result - real(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(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of +! abs((transformed integrand)-i/(b-a)) over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk15imv +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b,boun + integer, intent(in) :: inf,np + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,absc1,absc2,centr,abs,dinf,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh,tabsc1,tabsc2 + real(wp_), dimension(7) :: fv1,fv2 + integer :: j +! +! 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. +! + real(wp_), dimension(8), parameter :: & + wg = (/ 0.000000000000000000000000000000000_wp_, & + 0.129484966168869693270611432679082_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.279705391489276667901467771423780_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.381830050505118944950369775488975_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.417959183673469387755102040816327_wp_ /), & + xgk = (/ 0.991455371120812639206854697526329_wp_, & + 0.949107912342758524526189684047851_wp_, & + 0.864864423359769072789712788640926_wp_, & + 0.741531185599394439863864773280788_wp_, & + 0.586087235467691130294144838258730_wp_, & + 0.405845151377397166906606412076961_wp_, & + 0.207784955007898467600689403773245_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.022935322010529224963732008058970_wp_, & + 0.063092092629978553290700663189204_wp_, & + 0.104790010322250183839876322541518_wp_, & + 0.140653259715525918745189590510238_wp_, & + 0.169004726639267902826583426598550_wp_, & + 0.190350578064785409913256402421014_wp_, & + 0.204432940075298892414161999234649_wp_, & + 0.209482141084727828012999174891714_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! 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. +! +!***first executable statement dqk15imv + dinf = min0(1,inf) +! + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + tabsc1 = boun+dinf*(0.1e+01_wp_-centr)/centr + fval1 = f(tabsc1,apar,np) + if(inf==2) fval1 = fval1+f(-tabsc1,apar,np) + 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.1e+01_wp_-absc1)/absc1 + tabsc2 = boun+dinf*(0.1e+01_wp_-absc2)/absc2 + fval1 = f(tabsc1,apar,np) + fval2 = f(tabsc2,apar,np) + if(inf==2) fval1 = fval1+f(-tabsc1,apar,np) + if(inf==2) fval2 = fval2+f(-tabsc2,apar,np) + 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.5e+00_wp_ + 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/=0.0e+00_wp_.and.abserr/=0._wp_) abserr = resasc* & + dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk15imv + +end module quadpack \ No newline at end of file diff --git a/src/reflections.f90 b/src/reflections.f90 index 3de82da..8c7b708 100644 --- a/src/reflections.f90 +++ b/src/reflections.f90 @@ -75,6 +75,7 @@ subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw) end subroutine inters_linewall subroutine linecone_coord(xv,kv,rs,zs,s,t,n) + use utils, only : bubble implicit none real(wp_), intent(in), dimension(3) :: xv,kv real(wp_), intent(in), dimension(2) :: rs,zs @@ -155,7 +156,7 @@ subroutine interssegm_coord(xa,ya,xb,yb,s,t,ierr) dxb = xb(2)-xb(1) dyb = yb(2)-yb(1) crossprod = dxb*dya - dxa*dyb - if (abs(crossprod)a(i).neqv.x>a(i+1)) then - nj=nj+1 - if (nj<=m) j(nj)=i - end if - end do -end subroutine locate_unord - -function locate(a,n,x) result(j) - !Given an array a(n), and a value x, with a(n) monotonic, either - !increasing or decreasing, returns a value j such that - !a(j) < x <= a(j+1) for a increasing, and such that - !a(j+1) < x <= a(j) for a decreasing. - !j=0 or j=n indicate that x is out of range (Numerical Recipes) - implicit none - integer, intent(in) :: n - real(wp_), dimension(n), intent(in) :: a - real(wp_), intent(in) :: x - integer :: j - integer :: jl,ju,jm - logical :: incr - jl=0 - ju=n+1 - incr=a(n)>a(1) - do while ((ju-jl)>1) - jm=(ju+jl)/2 - if(incr.eqv.(x>a(jm))) then - jl=jm - else - ju=jm - endif - end do - j=jl -end function locate - -subroutine order(p,q) - !returns p,q in ascending order - implicit none - real(wp_), intent(inout) :: p,q - real(wp_) :: temp - if (p>q) then - temp=p - p=q - q=temp - end if -end subroutine order - -subroutine bubble(a,n) - !bubble sorting of array a - implicit none - integer, intent(in) :: n - real(wp_), dimension(n), intent(inout) :: a - integer :: i, j - do i=1,n - do j=n,i+1,-1 - call order(a(j-1), a(j)) - end do - end do -end subroutine bubble - end module reflections diff --git a/src/utils.f90 b/src/utils.f90 new file mode 100644 index 0000000..84249ca --- /dev/null +++ b/src/utils.f90 @@ -0,0 +1,249 @@ +module utils + + use const_and_precisions, only : wp_ + implicit none + +contains + + function locatef(a,n,x) result(j) +! Given an array a(n), and a value x, with a(n) monotonic, either +! increasing or decreasing, returns a value j such that +! a(j) < x <= a(j+1) for a increasing, and such that +! a(j+1) < x <= a(j) for a decreasing. +! j=0 or j=n indicate that x is out of range (Numerical Recipes) + implicit none + integer, intent(in) :: n + real(wp_), dimension(n), intent(in) :: a + real(wp_), intent(in) :: x + integer :: j + integer :: jl,ju,jm + logical :: incr + jl=0 + ju=n+1 + incr=a(n)>a(1) + do while ((ju-jl)>1) + jm=(ju+jl)/2 + if(incr.eqv.(x>a(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + end function locatef + + subroutine locate(xx,n,x,j) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: xx(n), x + integer, intent(out) :: j + integer :: jl,ju,jm + logical :: incr +! +! Given an array xx(n), and a value x +! returns a value j such that xx(j) < x < xx(j+1) +! xx(n) must be monotonic, either increasing or decreasing. +! j=0 or j=n indicate that x is out of range (Numerical Recipes) +! + jl=0 + ju=n+1 + incr=xx(n)>xx(1) + do while ((ju-jl)>1) + jm=(ju+jl)/2 + if(incr .eqv. (x>xx(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + end subroutine locate + + subroutine locatex(xx,n,n1,n2,x,j) + implicit none + integer, intent(in) :: n,n1,n2 + real(wp_), intent(in) :: xx(n), x + integer, intent(out) :: j + integer :: jl,ju,jm +! +! Given an array xx(n), and a value x +! returns a value j such that xx(j) < x < xx(j+1) +! xx(n) must be monotonic, either increasing or decreasing. +! j=n1-1or j=n2+1 indicate that x is out of range +! modified from subr. locate (Numerical Recipes) +! + jl=n1-1 + ju=n2+1 + do while ((ju-jl)>1) + jm=(ju+jl)/2 + if((xx(n2)>xx(n1)) .eqv. (x>xx(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + end subroutine locatex + + subroutine locate_unord(a,n,x,j,m,nj) + implicit none + integer, intent(in) :: n,m + integer, intent(out) :: nj + real(wp_), dimension(n), intent(in) :: a + real(wp_), intent(in) :: x + integer, dimension(m), intent(inout) :: j + integer :: i + nj=0 + do i=1,n-1 + if (x>a(i).neqv.x>a(i+1)) then + nj=nj+1 + if (nj<=m) j(nj)=i + end if + end do + end subroutine locate_unord + + function intlinf(x1,y1,x2,y2,x) result(y) + !linear interpolation + !must be x1 != x2 + use const_and_precisions, only : one + implicit none + real(wp_),intent(in) :: x1,y1,x2,y2,x + real(wp_) :: y + real(wp_) :: a + a=(x2-x)/(x2-x1) + y=a*y1+(one-a)*y2 + end function intlinf + + subroutine intlin(x1,y1,x2,y2,x,y) + implicit none + real(wp_), intent(in) :: x1,y1,x2,y2,x + real(wp_), intent(out) :: y + real(wp_) :: dx,aa,bb +! +! linear interpolation +! (x1,y1) < (x,y) < (x2,y2) +! + dx=x2-x1 + aa=(x2-x)/dx + bb=1.0_wp_-aa + y=aa*y1+bb*y2 + end subroutine intlin + + subroutine vmax(x,n,xmax,imx) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: x(n) + real(wp_), intent(out) :: xmax + integer, intent(out) :: imx + integer :: i + + if (n<1) then + imx=0 + return + end if + imx=1 + xmax=x(1) + do i=2,n + if(x(i)>xmax) then + xmax=x(i) + imx=i + end if + end do + end subroutine vmax + + subroutine vmin(x,n,xmin,imn) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: x(n) + real(wp_), intent(out) :: xmin + integer, intent(out) :: imn + integer :: i + + if (n<1) then + imn=0 + return + end if + imn=1 + xmin=x(1) + do i=2,n + if(x(i)xmax) then + xmax=x(i) + imx=i + end if + end do + end subroutine vmaxmini + + subroutine vmaxmin(x,n,xmin,xmax) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: x(n) + real(wp_), intent(out) :: xmin, xmax + integer :: i + + if (n<1) then + return + end if + xmin=x(1) + xmax=x(1) + do i=2,n + if(x(i)xmax) then + xmax=x(i) + end if + end do + end subroutine vmaxmin + + subroutine order(p,q) +! returns p,q in ascending order + implicit none + real(wp_), intent(inout) :: p,q + real(wp_) :: temp + if (p>q) then + temp=p + p=q + q=temp + end if + end subroutine order + + subroutine bubble(a,n) +! bubble sorting of array a + implicit none + integer, intent(in) :: n + real(wp_), dimension(n), intent(inout) :: a + integer :: i, j + do i=1,n + do j=n,i+1,-1 + call order(a(j-1), a(j)) + end do + end do + end subroutine bubble + +end module utils \ No newline at end of file