program integrator
!... This program integrates a function f(x) by means of Romberg integration.
!... Version 0.0.1
implicit none
REAL*8, allocatable :: fx(:)
!... Input parameters
real*8 y1,y2
integer mxpts
common/bkinput/ y1,y2,mxpts
integer m
integer ierr,stat
!... Input file
open (unit=10,file='romberg.inp',status='old')
!... call input
call readinput(m) allocate(fx(m),stat=ierr)
if(ierr.ne.0)stop 'allocation fails - fx'
!... Create array of data
call createarray(fx,m)
!... Romberg integration
call integrateRomb(fx,m)
!... Close files
deallocate(fx)
close (unit=10)
end
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine readinput(m)
implicit none
!... Input parameters
real*8 y1,y2
integer mxpts
common/bkinput/ y1,y2,mxpts
integer m
real*8 rzero, one, two, five
data rzero,one,two,five/0.0d0,1.0d0,2.0d0,5.0d0/
namelist /griddata/mxpts,y1,y2
mxpts=0
y1=rzero
y2=rzero
!... read griddata
read(10,griddata)
m=mxpts+1
write(*,111) y2,y1,m
111 format(/5x,'y2=',f9.3,5x,'y1=',f9.3,5x,'m=',i8,5x)
return
end
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!... Create array to be evaluated. This is done in order to simulate
!... a realistic numerical situation where f is not know anallytically
subroutine createarray(fx,m)
implicit none
real*8 y1,y2
integer mxpts
common/bkinput/ y1,y2,mxpts
integer m
real*8 fx
dimension fx(m)
integer i
real*8 dx,x
dx=(y2-y1)/mxpts
do i=1,mxpts+1
x=y1+(i-1)*dx
fx(i)=4.d0*dsqrt(1.d0-x**2)
enddo
return
end
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE trapzd(fx,m,a,b,s,n)
integer m
real*8 fx
dimension fx(m)
REAL*8 a,b,s,h
integer n,j,k
REAL*8 T(200)
j=1
h=(b-a)
T(1)=h*(fx(1)+fx(m))/2.d0
do i=1,n
j=2*j
rsum=0.d0
h=h/2.d0
do k=1,j-1,2
rsum=rsum+fx(k*m/j)
enddo
T(i+1)=T(i)/2.d0+h*rsum
enddo
s=T(n+1)
return
END
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% SUBROUTINE polint(xa,ya,n,x,y,dy)
!... From numerical recipes in Fortran77
INTEGER n,NMAX
REAL*8 dy,x,y,xa(n),ya(n)
PARAMETER (NMAX=10)
INTEGER i,m,ns
REAL*8 den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)
ns=1
dif=abs(x-xa(1))
do 32 i=1,n
dift=abs(x-xa(i))
if (dift.lt.dif) then
ns=i
dif=dift
endif
c(i)=ya(i)
d(i)=ya(i)
32 continue
y=ya(ns)
ns=ns-1
do 35 m=1,n-1
do 34 i=1,n-m
ho=xa(i)-x
hp=xa(i+m)-x
w=c(i+1)-d(i)
den=ho-hp
if(den.eq.0.)stop 'failure in polint'
den=w/den
d(i)=hp*den
c(i)=ho*den
34 continue
if (2*ns.lt.n-m)then
dy=c(ns+1)
else
dy=d(ns)
ns=ns-1
endif
y=y+dy
35 continue
return
END
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE qromb(fx,m,a,b,ss)
!... From numerical recipes in Fortran77
integer m
real*8 fx
dimension fx(m)
real*8 y1,y2
integer mxpts
common/bkinput/ y1,y2,mxpts
INTEGER JMAX,JMAXP,K,KM
REAL*8 a,b,ss,EPS,dss
PARAMETER (EPS=1.e-6, K=2, KM=K-1)
CU USES polint,trapzd
INTEGER j
REAL*8, allocatable :: h(:),s(:)
JMAX=mxpts
JMAXP=JMAX+1
ALLOCATE( h(JMAXP), s(JMAXP) )
h(1)=1.0d0
do 33 j=1,JMAX
call trapzd(fx,m,a,b,s(j),j)
if (j.ge.K) then
call polint(h(j-KM),s(j-KM),K,0.0d0,ss,dss)
endif
s(j+1)=s(j)
h(j+1)=0.25d0*h(j)
33 continue
deallocate(h,s)
END
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine integrateRomb(fx,m)
!... This routine performs the numerical integration of the function
!... f(x) using Romberg integration.
implicit none
real*8 y1,y2
integer mxpts
common/bkinput/ y1,y2,mxpts
integer m
real*8 fx
dimension fx(m) integer i
real*8 rint,intaux,ss
call qromb(fx,m,y1,y2,ss) print*,'Integral value by Romberg integration is=',ss
print*,'Romberg-Exact=',
+ 3.14159265358979323846264338327950288419716d0-ss
! + 7.954926521012845274513219665329394328161342771816638573400-ss
return
end
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%