84 lines
2.0 KiB
Fortran
84 lines
2.0 KiB
Fortran
SUBROUTINE tred2(a,n,np,d,e)
|
|
INTEGER n,np
|
|
REAL a(np,np),d(np),e(np)
|
|
INTEGER i,j,k,l
|
|
REAL f,g,h,hh,scale
|
|
do 18 i=n,2,-1
|
|
l=i-1
|
|
h=0.
|
|
scale=0.
|
|
if(l.gt.1)then
|
|
do 11 k=1,l
|
|
scale=scale+abs(a(i,k))
|
|
11 continue
|
|
if(scale.eq.0.)then
|
|
e(i)=a(i,l)
|
|
else
|
|
do 12 k=1,l
|
|
a(i,k)=a(i,k)/scale
|
|
h=h+a(i,k)**2
|
|
12 continue
|
|
f=a(i,l)
|
|
g=-sign(sqrt(h),f)
|
|
e(i)=scale*g
|
|
h=h-f*g
|
|
a(i,l)=f-g
|
|
f=0.
|
|
do 15 j=1,l
|
|
C Omit following line if finding only eigenvalues
|
|
a(j,i)=a(i,j)/h
|
|
g=0.
|
|
do 13 k=1,j
|
|
g=g+a(j,k)*a(i,k)
|
|
13 continue
|
|
do 14 k=j+1,l
|
|
g=g+a(k,j)*a(i,k)
|
|
14 continue
|
|
e(j)=g/h
|
|
f=f+e(j)*a(i,j)
|
|
15 continue
|
|
hh=f/(h+h)
|
|
do 17 j=1,l
|
|
f=a(i,j)
|
|
g=e(j)-hh*f
|
|
e(j)=g
|
|
do 16 k=1,j
|
|
a(j,k)=a(j,k)-f*e(k)-g*a(i,k)
|
|
16 continue
|
|
17 continue
|
|
endif
|
|
else
|
|
e(i)=a(i,l)
|
|
endif
|
|
d(i)=h
|
|
18 continue
|
|
C Omit following line if finding only eigenvalues.
|
|
d(1)=0.
|
|
e(1)=0.
|
|
do 24 i=1,n
|
|
C Delete lines from here ...
|
|
l=i-1
|
|
if(d(i).ne.0.)then
|
|
do 22 j=1,l
|
|
g=0.
|
|
do 19 k=1,l
|
|
g=g+a(i,k)*a(k,j)
|
|
19 continue
|
|
do 21 k=1,l
|
|
a(k,j)=a(k,j)-g*a(k,i)
|
|
21 continue
|
|
22 continue
|
|
endif
|
|
C ... to here when finding only eigenvalues.
|
|
d(i)=a(i,i)
|
|
C Also delete lines from here ...
|
|
a(i,i)=1.
|
|
do 23 j=1,l
|
|
a(i,j)=0.
|
|
a(j,i)=0.
|
|
23 continue
|
|
C ... to here when finding only eigenvalues.
|
|
24 continue
|
|
return
|
|
END
|