You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
242 lines
5.9 KiB
242 lines
5.9 KiB
C (C) Copr. 1986-92 Numerical Recipes Software ]2w.1,r1..
|
|
|
|
c--- modified by J. Campbell, 11/14/2012 to better handle comparison
|
|
c--- of floating points using precision given by EPS
|
|
SUBROUTINE pvdsvdcmp(a,m,n,mp,np,w,v)
|
|
implicit none
|
|
include 'lib/TensorReduction/Include/types.f'
|
|
include 'lib/TensorReduction/Include/TRconstants.f'
|
|
INTEGER:: m,mp,n,np
|
|
real(dp)::a(mp,np),v(np,np),w(np)
|
|
integer,parameter:: nmax=500
|
|
CU USES pvdpythag
|
|
integer:: i,its,j,jj,k,l,nm
|
|
real(dp):: anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX),pvdpythag
|
|
real(dp),parameter:: EPS=1.d-8
|
|
g=zero
|
|
scale=zero
|
|
anorm=zero
|
|
do 25 i=1,n
|
|
l=i+1
|
|
rv1(i)=scale*g
|
|
g=zero
|
|
s=zero
|
|
scale=zero
|
|
if(i.le.m)then
|
|
do 11 k=i,m
|
|
scale=scale+abs(a(k,i))
|
|
11 continue
|
|
if(scale.ne.zero)then
|
|
do 12 k=i,m
|
|
a(k,i)=a(k,i)/scale
|
|
s=s+a(k,i)*a(k,i)
|
|
12 continue
|
|
f=a(i,i)
|
|
g=-sign(sqrt(s),f)
|
|
h=f*g-s
|
|
a(i,i)=f-g
|
|
do 15 j=l,n
|
|
s=zero
|
|
do 13 k=i,m
|
|
s=s+a(k,i)*a(k,j)
|
|
13 continue
|
|
f=s/h
|
|
do 14 k=i,m
|
|
a(k,j)=a(k,j)+f*a(k,i)
|
|
14 continue
|
|
15 continue
|
|
do 16 k=i,m
|
|
a(k,i)=scale*a(k,i)
|
|
16 continue
|
|
endif
|
|
endif
|
|
w(i)=scale *g
|
|
g=zero
|
|
s=zero
|
|
scale=zero
|
|
if((i.le.m).and.(i.ne.n))then
|
|
do 17 k=l,n
|
|
scale=scale+abs(a(i,k))
|
|
17 continue
|
|
if(scale.ne.zero)then
|
|
do 18 k=l,n
|
|
a(i,k)=a(i,k)/scale
|
|
s=s+a(i,k)*a(i,k)
|
|
18 continue
|
|
f=a(i,l)
|
|
g=-sign(sqrt(s),f)
|
|
h=f*g-s
|
|
a(i,l)=f-g
|
|
do 19 k=l,n
|
|
rv1(k)=a(i,k)/h
|
|
19 continue
|
|
do 23 j=l,m
|
|
s=zero
|
|
do 21 k=l,n
|
|
s=s+a(j,k)*a(i,k)
|
|
21 continue
|
|
do 22 k=l,n
|
|
a(j,k)=a(j,k)+s*rv1(k)
|
|
22 continue
|
|
23 continue
|
|
do 24 k=l,n
|
|
a(i,k)=scale*a(i,k)
|
|
24 continue
|
|
endif
|
|
endif
|
|
anorm=max(anorm,(abs(w(i))+abs(rv1(i))))
|
|
25 continue
|
|
do 32 i=n,1,-1
|
|
if(i.lt.n)then
|
|
if(g.ne.zero)then
|
|
do 26 j=l,n
|
|
v(j,i)=(a(i,j)/a(i,l))/g
|
|
26 continue
|
|
do 29 j=l,n
|
|
s=zero
|
|
do 27 k=l,n
|
|
s=s+a(i,k)*v(k,j)
|
|
27 continue
|
|
do 28 k=l,n
|
|
v(k,j)=v(k,j)+s*v(k,i)
|
|
28 continue
|
|
29 continue
|
|
endif
|
|
do 31 j=l,n
|
|
v(i,j)=zero
|
|
v(j,i)=zero
|
|
31 continue
|
|
endif
|
|
v(i,i)=1._dp
|
|
g=rv1(i)
|
|
l=i
|
|
32 continue
|
|
do 39 i=min(m,n),1,-1
|
|
l=i+1
|
|
g=w(i)
|
|
do 33 j=l,n
|
|
a(i,j)=zero
|
|
33 continue
|
|
if(g.ne.zero)then
|
|
g=1._dp/g
|
|
do 36 j=l,n
|
|
s=zero
|
|
do 34 k=l,m
|
|
s=s+a(k,i)*a(k,j)
|
|
34 continue
|
|
f=(s/a(i,i))*g
|
|
do 35 k=i,m
|
|
a(k,j)=a(k,j)+f*a(k,i)
|
|
35 continue
|
|
36 continue
|
|
do 37 j=i,m
|
|
a(j,i)=a(j,i)*g
|
|
37 continue
|
|
else
|
|
do 38 j= i,m
|
|
a(j,i)=zero
|
|
38 continue
|
|
endif
|
|
a(i,i)=a(i,i)+1._dp
|
|
39 continue
|
|
do 49 k=n,1,-1
|
|
do 48 its=1,30
|
|
do 41 l=k,1,-1
|
|
nm=l-1
|
|
if(abs(rv1(l)).lt.EPS*anorm) goto 2
|
|
if(abs(w(nm)).lt.EPS*anorm) goto 1
|
|
c if((abs(rv1(l))+anorm).eq.anorm) goto 2
|
|
c if((abs(w(nm))+anorm).eq.anorm) goto 1
|
|
41 continue
|
|
1 c=zero
|
|
s=1._dp
|
|
do 43 i=l,k
|
|
f=s*rv1(i)
|
|
rv1(i)=c*rv1(i)
|
|
if(abs(f).lt.EPS*anorm) goto 2
|
|
c if((abs(f)+anorm).eq.anorm) goto 2
|
|
g=w(i)
|
|
h=pvdpythag(f,g)
|
|
w(i)=h
|
|
h=1._dp/h
|
|
c= (g*h)
|
|
s=-(f*h)
|
|
do 42 j=1,m
|
|
y=a(j,nm)
|
|
z=a(j,i)
|
|
a(j,nm)=(y*c)+(z*s)
|
|
a(j,i)=-(y*s)+(z*c)
|
|
42 continue
|
|
43 continue
|
|
2 z=w(k)
|
|
if(l.eq.k)then
|
|
if(z.lt.zero)then
|
|
w(k)=-z
|
|
do 44 j=1,n
|
|
v(j,k)=-v(j,k)
|
|
44 continue
|
|
endif
|
|
goto 3
|
|
endif
|
|
if(its.eq.30) then
|
|
do i=1,m
|
|
do j=1,n
|
|
write(6,*) i,j,a(i,j)
|
|
enddo
|
|
enddo
|
|
stop 'no convergence in svdcmp'
|
|
endif
|
|
x=w(l)
|
|
nm=k-1
|
|
y=w(nm)
|
|
g=rv1(nm)
|
|
h=rv1(k)
|
|
f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0_dp*h*y)
|
|
g=pvdpythag(f,1._dp)
|
|
f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
|
|
c=1._dp
|
|
s=1._dp
|
|
do 47 j=l,nm
|
|
i=j+1
|
|
g=rv1(i)
|
|
y=w(i)
|
|
h=s*g
|
|
g=c*g
|
|
z=pvdpythag(f,h)
|
|
rv1(j)=z
|
|
c=f/z
|
|
s=h/z
|
|
f= (x*c)+(g*s)
|
|
g=-(x*s)+(g*c)
|
|
h=y*s
|
|
y=y*c
|
|
do 45 jj=1,n
|
|
x=v(jj,j)
|
|
z=v(jj,i)
|
|
v(jj,j)= (x*c)+(z*s)
|
|
v(jj,i)=-(x*s)+(z*c)
|
|
45 continue
|
|
z=pvdpythag(f,h)
|
|
w(j)=z
|
|
if(z.ne.zero)then
|
|
z=1._dp/z
|
|
c=f*z
|
|
s=h*z
|
|
endif
|
|
f= (c*g)+(s*y)
|
|
x=-(s*g)+(c*y)
|
|
do 46 jj=1,m
|
|
y=a(jj,j)
|
|
z=a(jj,i)
|
|
a(jj,j)= (y*c)+(z*s)
|
|
a(jj,i)=-(y*s)+(z*c)
|
|
46 continue
|
|
47 continue
|
|
rv1(l)=zero
|
|
rv1(k)=f
|
|
w(k)=x
|
|
48 continue
|
|
3 continue
|
|
49 continue
|
|
return
|
|
END
|