93 lines
2.5 KiB
Fortran
93 lines
2.5 KiB
Fortran
SUBROUTINE jacobi(a,n,np,d,v,nrot)
|
|
INTEGER n,np,nrot,NMAX
|
|
REAL a(np,np),d(np),v(np,np)
|
|
PARAMETER (NMAX=500)
|
|
INTEGER i,ip,iq,j
|
|
REAL c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX)
|
|
do 12 ip=1,n
|
|
do 11 iq=1,n
|
|
v(ip,iq)=0.
|
|
11 continue
|
|
v(ip,ip)=1.
|
|
12 continue
|
|
do 13 ip=1,n
|
|
b(ip)=a(ip,ip)
|
|
d(ip)=b(ip)
|
|
z(ip)=0.
|
|
13 continue
|
|
nrot=0
|
|
do 24 i=1,50
|
|
sm=0.
|
|
do 15 ip=1,n-1
|
|
do 14 iq=ip+1,n
|
|
sm=sm+abs(a(ip,iq))
|
|
14 continue
|
|
15 continue
|
|
if(sm.eq.0.)return
|
|
if(i.lt.4)then
|
|
tresh=0.2*sm/n**2
|
|
else
|
|
tresh=0.
|
|
endif
|
|
do 22 ip=1,n-1
|
|
do 21 iq=ip+1,n
|
|
g=100.*abs(a(ip,iq))
|
|
if((i.gt.4).and.(abs(d(ip))+
|
|
*g.eq.abs(d(ip))).and.(abs(d(iq))+g.eq.abs(d(iq))))then
|
|
a(ip,iq)=0.
|
|
else if(abs(a(ip,iq)).gt.tresh)then
|
|
h=d(iq)-d(ip)
|
|
if(abs(h)+g.eq.abs(h))then
|
|
t=a(ip,iq)/h
|
|
else
|
|
theta=0.5*h/a(ip,iq)
|
|
t=1./(abs(theta)+sqrt(1.+theta**2))
|
|
if(theta.lt.0.)t=-t
|
|
endif
|
|
c=1./sqrt(1+t**2)
|
|
s=t*c
|
|
tau=s/(1.+c)
|
|
h=t*a(ip,iq)
|
|
z(ip)=z(ip)-h
|
|
z(iq)=z(iq)+h
|
|
d(ip)=d(ip)-h
|
|
d(iq)=d(iq)+h
|
|
a(ip,iq)=0.
|
|
do 16 j=1,ip-1
|
|
g=a(j,ip)
|
|
h=a(j,iq)
|
|
a(j,ip)=g-s*(h+g*tau)
|
|
a(j,iq)=h+s*(g-h*tau)
|
|
16 continue
|
|
do 17 j=ip+1,iq-1
|
|
g=a(ip,j)
|
|
h=a(j,iq)
|
|
a(ip,j)=g-s*(h+g*tau)
|
|
a(j,iq)=h+s*(g-h*tau)
|
|
17 continue
|
|
do 18 j=iq+1,n
|
|
g=a(ip,j)
|
|
h=a(iq,j)
|
|
a(ip,j)=g-s*(h+g*tau)
|
|
a(iq,j)=h+s*(g-h*tau)
|
|
18 continue
|
|
do 19 j=1,n
|
|
g=v(j,ip)
|
|
h=v(j,iq)
|
|
v(j,ip)=g-s*(h+g*tau)
|
|
v(j,iq)=h+s*(g-h*tau)
|
|
19 continue
|
|
nrot=nrot+1
|
|
endif
|
|
21 continue
|
|
22 continue
|
|
do 23 ip=1,n
|
|
b(ip)=b(ip)+z(ip)
|
|
d(ip)=b(ip)
|
|
z(ip)=0.
|
|
23 continue
|
|
24 continue
|
|
pause 'too many iterations in jacobi'
|
|
return
|
|
END
|