akaGM
Platinum Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
program razb
! use dfimsl
implicit none
interface
subroutine dqdags (f, a, b, errabs, errrel, result, errest)
!dec$ attributes default :: dqdags
real(kind(1d0)) :: a
real(kind(1d0)) :: b
real(kind(1d0)) :: errabs
real(kind(1d0)) :: errrel
real(kind(1d0)) :: result
real(kind(1d0)) :: errest
interface
real(kind(1d0)) function f(x)
!dec$ attributes default :: f
real(kind(1d0)), intent(in) :: x
end function
end interface
end subroutine
end interface
interface
real(kind(1d0)) function argG(x)
!dec$ attributes default :: argG
real(kind(1d0)), intent(in) :: x
end function
end interface
! Variables
integer::i,y,n,ig,jg,m,m0,j
real(8)::ll=-1.0,ul=1.0
real(8)::F,G,T
external F,G,T
real(8)::e=1e-4
real(8)::tau(3),q(3),a(8)
real(8)::f1,x,s1,s2,hg,pi,xb,xj,temp,f2,xg
real(8)::errabs=1e-10,errrel=1e-10,errest
! Body of razb
pi=acos(-1.0)
tau(1)=-0.7745966692
tau(2)=0.0
tau(3)=-tau(1)
q(1)=0.5555555556
q(2)=0.8888888888
q(3)=q(1)
do i=1,8,1
do j=1,3,1
a(i)=a(i)+F(tau(j))*T(tau(j),i)/sqrt(1-tau(j)*tau(j))*q(j)
enddo
if (i==1) then
a(i)=a(i)/pi
else
a(i)=a(i)*2/pi
end if
enddo
do i=1,8,1
f1=f1+a(i)*T(tau(3),i)
enddo
print*,'F~=',f1
do i=1,8,1
call DQDAGS(argG,ll,ul,errabs,errrel,a(i),errest)
a(i)=a(i)*2/pi*T(tau(3),i)
enddo
a(1)=a(1)/2
do i=1,8,1
f2=f2+a(i)
enddo
print*, 'f(x)=',f2
end program razb
real(8) FUNCTION T(x,i)
implicit none
real(8)::x,TT(8)
integer::i,j
if (i==1) then
TT=1
else if (i==2) then
TT=x
else
do j=3,i,1
TT(j)=2*x*TT(j-1)-TT(j-2)
enddo
end if
T=TT(i)
end FUNCTION T
real(8) FUNCTION F(x)
implicit none
real(8)::x
F=exp(-x)
end FUNCTION F
real(8) FUNCTION G(x,i)
implicit none
real(8)::x
real(8)::TT(8)
integer::i,j
if (i==1) then
TT(i)=1
else if (i==2) then
TT(i)=x
else
do j=3,i,1
TT(j)=2*x*TT(j-1)-TT(j-2)
enddo
end if
G=exp(-x)*TT(i)/(1-sqrt(x*x))
end FUNCTION G
real(8) FUNCTION argG(x)
implicit none
real(8) :: G,x
integer :: i
external G
argG = G(x,i)
end FUNCTION argG
|
