Source module last modified on Wed, 13 Jul 2005, 16:20;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
# Collection of subroutines from EISPACK to solve hermitian eigenvalue problem
#----------------------------------------------------------------
SUBROUTINE eeigen(nm,n,ar,ai,w,matz,zr,zi,fv1,fv2,fm1,ierr)
#----------------------------------------------------------------
#
integer i,j,n,nm,ierr,matz
double precision ar(nm,n),ai(nm,n),w(n),zr(nm,n),zi(nm,n),
x fv1(n),fv2(n),fm1(2,n)
#
# this subroutine calls the recommended sequence of
# subroutines from the eigensystem subroutine package (eispack)
# to find the eigenvalues and eigenvectors (if desired)
# of a complex hermitian matrix.
#
# on input
#
# nm must be set to the row dimension of the two-dimensional
# array parameters as declared in the calling program
# dimension statement.
#
# n is the order of the matrix a=(ar,ai).
#
# ar and ai contain the real and imaginary parts,
# respectively, of the complex hermitian matrix.
#
# matz is an integer variable set equal to zero if
# only eigenvalues are desired. otherwise it is set to
# any non-zero integer for both eigenvalues and eigenvectors.
#
# on output
#
# w contains the eigenvalues in ascending order.
#
# zr and zi contain the real and imaginary parts,
# respectively, of the eigenvectors if matz is not zero.
#
# ierr is an integer output variable set equal to an error
# completion code described in the documentation for tqlrat
# and tql2. the normal completion code is zero.
#
# fv1, fv2, and fm1 are temporary storage arrays.
#
# questions and comments should be directed to burton s. garbow,
# mathematics and computer science div, argonne national laboratory
#
# this version dated august 1983.
#
# ------------------------------------------------------------------
#
if (n .le. nm) go to 10
ierr = 10 * n
go to 50
#
10 call htridi(nm,n,ar,ai,w,fv1,fv2,fm1)
if (matz .ne. 0) go to 20
# .......... find eigenvalues only ..........
call tqlrat(n,w,fv2,ierr)
go to 50
# .......... find both eigenvalues and eigenvectors ..........
20 do 40 i = 1, n
#
do 30 j = 1, n
zr(j,i) = 0.0d0
30 continue
#
zr(i,i) = 1.0d0
40 continue
#
call tql2(nm,n,w,fv1,zr,ierr)
if (ierr .ne. 0) go to 50
call htribk(nm,n,ar,ai,fm1,n,zr,zi)
50 return
end
#----------------------------------------------------------------
double precision FUNCTION epslon (x)
#----------------------------------------------------------------
double precision x
#
# estimate unit roundoff in quantities of size x.
#
double precision a,b,c,eps
#
# this program should function properly on all systems
# satisfying the following two assumptions,
# 1. the base used in representing floating point
# numbers is not a power of three.
# 2. the quantity a in statement 10 is represented to
# the accuracy used in floating point variables
# that are stored in memory.
# the statement number 10 and the go to 10 are intended to
# force optimizing compilers to generate code satisfying
# assumption 2.
# under these assumptions, it should be true that,
# a is not exactly equal to four-thirds,
# b has a zero for its last bit or digit,
# c is not exactly equal to one,
# eps measures the separation of 1.0 from
# the next larger floating point number.
# the developers of eispack would appreciate being informed
# about any systems where these assumptions do not hold.
#
# this version dated 4/6/83.
#
a = 4.0d0/3.0d0
10 b = a - 1.0d0
c = b + b + b
eps = dabs(c-1.0d0)
if (eps .eq. 0.0d0) go to 10
epslon = eps*dabs(x)
return
end
#----------------------------------------------------------------
SUBROUTINE htribk(nm,n,ar,ai,tau,m,zr,zi)
#----------------------------------------------------------------
#
integer i,j,k,l,m,n,nm
double precision ar(nm,n),ai(nm,n),tau(2,n),zr(nm,m),zi(nm,m)
double precision h,s,si
#
# this subroutine is a translation of a complex analogue of
# the algol procedure trbak1, num. math. 11, 181-195(1968)
# by martin, reinsch, and wilkinson.
# handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
#
# this subroutine forms the eigenvectors of a complex hermitian
# matrix by back transforming those of the corresponding
# real symmetric tridiagonal matrix determined by htridi.
#
# on input
#
# nm must be set to the row dimension of two-dimensional
# array parameters as declared in the calling program
# dimension statement.
#
# n is the order of the matrix.
#
# ar and ai contain information about the unitary trans-
# formations used in the reduction by htridi in their
# full lower triangles except for the diagonal of ar.
#
# tau contains further information about the transformations.
#
# m is the number of eigenvectors to be back transformed.
#
# zr contains the eigenvectors to be back transformed
# in its first m columns.
#
# on output
#
# zr and zi contain the real and imaginary parts,
# respectively, of the transformed eigenvectors
# in their first m columns.
#
# note that the last component of each returned vector
# is real and that vector euclidean norms are preserved.
#
# questions and comments should be directed to burton s. garbow,
# mathematics and computer science div, argonne national laboratory
#
# this version dated august 1983.
#
# ------------------------------------------------------------------
#
if (m .eq. 0) go to 200
# .......... transform the eigenvectors of the real symmetric
# tridiagonal matrix to those of the hermitian
# tridiagonal matrix. ..........
do 50 k = 1, n
#
do 50 j = 1, m
zi(k,j) = -zr(k,j) * tau(2,k)
zr(k,j) = zr(k,j) * tau(1,k)
50 continue
#
if (n .eq. 1) go to 200
# .......... recover and apply the householder matrices ..........
do 140 i = 2, n
l = i - 1
h = ai(i,i)
if (h .eq. 0.0d0) go to 140
#
do 130 j = 1, m
s = 0.0d0
si = 0.0d0
#
do 110 k = 1, l
s = s + ar(i,k) * zr(k,j) - ai(i,k) * zi(k,j)
si = si + ar(i,k) * zi(k,j) + ai(i,k) * zr(k,j)
110 continue
# .......... double divisions avoid possible underflow ..........
s = (s / h) / h
si = (si / h) / h
#
do 120 k = 1, l
zr(k,j) = zr(k,j) - s * ar(i,k) - si * ai(i,k)
zi(k,j) = zi(k,j) - si * ar(i,k) + s * ai(i,k)
120 continue
#
130 continue
#
140 continue
#
200 return
end
#----------------------------------------------------------------
SUBROUTINE htridi(nm,n,ar,ai,d,e,e2,tau)
#----------------------------------------------------------------
#
integer i,j,k,l,n,ii,nm,jp1
double precision ar(nm,n),ai(nm,n),d(n),e(n),e2(n),tau(2,n)
double precision f,g,h,fi,gi,hh,si,scale,pythag
#
# this subroutine is a translation of a complex analogue of
# the algol procedure tred1, num. math. 11, 181-195(1968)
# by martin, reinsch, and wilkinson.
# handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
#
# this subroutine reduces a complex hermitian matrix
# to a real symmetric tridiagonal matrix using
# unitary similarity transformations.
#
# on input
#
# nm must be set to the row dimension of two-dimensional
# array parameters as declared in the calling program
# dimension statement.
#
# n is the order of the matrix.
#
# ar and ai contain the real and imaginary parts,
# respectively, of the complex hermitian input matrix.
# only the lower triangle of the matrix need be supplied.
#
# on output
#
# ar and ai contain information about the unitary trans-
# formations used in the reduction in their full lower
# triangles. their strict upper triangles and the
# diagonal of ar are unaltered.
#
# d contains the diagonal elements of the the tridiagonal matrix.
#
# e contains the subdiagonal elements of the tridiagonal
# matrix in its last n-1 positions. e(1) is set to zero.
#
# e2 contains the squares of the corresponding elements of e.
# e2 may coincide with e if the squares are not needed.
#
# tau contains further information about the transformations.
#
# calls pythag for dsqrt(a*a + b*b) .
#
# questions and comments should be directed to burton s. garbow,
# mathematics and computer science div, argonne national laboratory
#
# this version dated august 1983.
#
# ------------------------------------------------------------------
#
tau(1,n) = 1.0d0
tau(2,n) = 0.0d0
#
do 100 i = 1, n
100 d(i) = ar(i,i)
# .......... for i=n step -1 until 1 do -- ..........
do 300 ii = 1, n
i = n + 1 - ii
l = i - 1
h = 0.0d0
scale = 0.0d0
if (l .lt. 1) go to 130
# .......... scale row (algol tol then not needed) ..........
do 120 k = 1, l
120 scale = scale + dabs(ar(i,k)) + dabs(ai(i,k))
#
if (scale .ne. 0.0d0) go to 140
tau(1,l) = 1.0d0
tau(2,l) = 0.0d0
130 e(i) = 0.0d0
e2(i) = 0.0d0
go to 290
#
140 do 150 k = 1, l
ar(i,k) = ar(i,k) / scale
ai(i,k) = ai(i,k) / scale
h = h + ar(i,k) * ar(i,k) + ai(i,k) * ai(i,k)
150 continue
#
e2(i) = scale * scale * h
g = dsqrt(h)
e(i) = scale * g
f = pythag(ar(i,l),ai(i,l))
# .......... form next diagonal element of matrix t ..........
if (f .eq. 0.0d0) go to 160
tau(1,l) = (ai(i,l) * tau(2,i) - ar(i,l) * tau(1,i)) / f
si = (ar(i,l) * tau(2,i) + ai(i,l) * tau(1,i)) / f
h = h + f * g
g = 1.0d0 + g / f
ar(i,l) = g * ar(i,l)
ai(i,l) = g * ai(i,l)
if (l .eq. 1) go to 270
go to 170
160 tau(1,l) = -tau(1,i)
si = tau(2,i)
ar(i,l) = g
170 f = 0.0d0
#
do 240 j = 1, l
g = 0.0d0
gi = 0.0d0
# .......... form element of a*u ..........
do 180 k = 1, j
g = g + ar(j,k) * ar(i,k) + ai(j,k) * ai(i,k)
gi = gi - ar(j,k) * ai(i,k) + ai(j,k) * ar(i,k)
180 continue
#
jp1 = j + 1
if (l .lt. jp1) go to 220
#
do 200 k = jp1, l
g = g + ar(k,j) * ar(i,k) - ai(k,j) * ai(i,k)
gi = gi - ar(k,j) * ai(i,k) - ai(k,j) * ar(i,k)
200 continue
# .......... form element of p ..........
220 e(j) = g / h
tau(2,j) = gi / h
f = f + e(j) * ar(i,j) - tau(2,j) * ai(i,j)
240 continue
#
hh = f / (h + h)
# .......... form reduced a ..........
do 260 j = 1, l
f = ar(i,j)
g = e(j) - hh * f
e(j) = g
fi = -ai(i,j)
gi = tau(2,j) - hh * fi
tau(2,j) = -gi
#
do 260 k = 1, j
ar(j,k) = ar(j,k) - f * e(k) - g * ar(i,k)
x + fi * tau(2,k) + gi * ai(i,k)
ai(j,k) = ai(j,k) - f * tau(2,k) - g * ai(i,k)
x - fi * e(k) - gi * ar(i,k)
260 continue
#
270 do 280 k = 1, l
ar(i,k) = scale * ar(i,k)
ai(i,k) = scale * ai(i,k)
280 continue
#
tau(2,l) = -si
290 hh = d(i)
d(i) = ar(i,i)
ar(i,i) = hh
ai(i,i) = scale * dsqrt(h)
300 continue
#
return
end
#----------------------------------------------------------------
SUBROUTINE tqlrat(n,d,e2,ierr)
#----------------------------------------------------------------
#
integer i,j,l,m,n,ii,l1,mml,ierr
double precision d(n),e2(n)
double precision b,c,f,g,h,p,r,s,t,epslon,pythag
#
# this subroutine is a translation of the algol procedure tqlrat,
# algorithm 464, comm. acm 16, 689(1973) by reinsch.
#
# this subroutine finds the eigenvalues of a symmetric
# tridiagonal matrix by the rational ql method.
#
# on input
#
# n is the order of the matrix.
#
# d contains the diagonal elements of the input matrix.
#
# e2 contains the squares of the subdiagonal elements of the
# input matrix in its last n-1 positions. e2(1) is arbitrary.
#
# on output
#
# d contains the eigenvalues in ascending order. if an
# error exit is made, the eigenvalues are correct and
# ordered for indices 1,2,...ierr-1, but may not be
# the smallest eigenvalues.
#
# e2 has been destroyed.
#
# ierr is set to
# zero for normal return,
# j if the j-th eigenvalue has not been
# determined after 30 iterations.
#
# calls pythag for dsqrt(a*a + b*b) .
#
# questions and comments should be directed to burton s. garbow,
# mathematics and computer science div, argonne national laboratory
#
# this version dated august 1983.
#
# ------------------------------------------------------------------
#
ierr = 0
if (n .eq. 1) go to 1001
#
do 100 i = 2, n
100 e2(i-1) = e2(i)
#
f = 0.0d0
t = 0.0d0
e2(n) = 0.0d0
#
do 290 l = 1, n
j = 0
h = dabs(d(l)) + dsqrt(e2(l))
if (t .gt. h) go to 105
t = h
b = epslon(t)
c = b * b
# .......... look for small squared sub-diagonal element ..........
105 do 110 m = l, n
if (e2(m) .le. c) go to 120
# .......... e2(n) is always zero, so there is no exit
# through the bottom of the loop ..........
110 continue
#
120 if (m .eq. l) go to 210
130 if (j .eq. 30) go to 1000
j = j + 1
# .......... form shift ..........
l1 = l + 1
s = dsqrt(e2(l))
g = d(l)
p = (d(l1) - g) / (2.0d0 * s)
r = pythag(p,1.0d0)
d(l) = s / (p + dsign(r,p))
h = g - d(l)
#
do 140 i = l1, n
140 d(i) = d(i) - h
#
f = f + h
# .......... rational ql transformation ..........
g = d(m)
if (g .eq. 0.0d0) g = b
h = g
s = 0.0d0
mml = m - l
# .......... for i=m-1 step -1 until l do -- ..........
do 200 ii = 1, mml
i = m - ii
p = g * h
r = p + e2(i)
e2(i+1) = s * r
s = e2(i) / r
d(i+1) = h + s * (h + d(i))
g = d(i) - e2(i) / g
if (g .eq. 0.0d0) g = b
h = g * p / r
200 continue
#
e2(l) = s * g
d(l) = h
# .......... guard against underflow in convergence test ..........
if (h .eq. 0.0d0) go to 210
if (dabs(e2(l)) .le. dabs(c/h)) go to 210
e2(l) = h * e2(l)
if (e2(l) .ne. 0.0d0) go to 130
210 p = d(l) + f
# .......... order eigenvalues ..........
if (l .eq. 1) go to 250
# .......... for i=l step -1 until 2 do -- ..........
do 230 ii = 2, l
i = l + 2 - ii
if (p .ge. d(i-1)) go to 270
d(i) = d(i-1)
230 continue
#
250 i = 1
270 d(i) = p
290 continue
#
go to 1001
# .......... set error -- no convergence to an
# eigenvalue after 30 iterations ..........
1000 ierr = l
1001 return
end
#----------------------------------------------------------------
double precision FUNCTION pythag(a,b)
#----------------------------------------------------------------
double precision a,b
#
# finds dsqrt(a**2+b**2) without overflow or destructive underflow
#
double precision p,r,s,t,u
p = dmax1(dabs(a),dabs(b))
if (p .eq. 0.0d0) go to 20
r = (dmin1(dabs(a),dabs(b))/p)**2
10 continue
t = 4.0d0 + r
if (t .eq. 4.0d0) go to 20
s = r/t
u = 1.0d0 + 2.0d0*s
p = u*p
r = (s/u)**2 * r
go to 10
20 pythag = p
return
end
#----------------------------------------------------------------
SUBROUTINE tql2(nm,n,d,e,z,ierr)
#----------------------------------------------------------------
#
integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
double precision d(n),e(n),z(nm,n)
double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
#
# this subroutine is a translation of the algol procedure tql2,
# num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
# wilkinson.
# handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
#
# this subroutine finds the eigenvalues and eigenvectors
# of a symmetric tridiagonal matrix by the ql method.
# the eigenvectors of a full symmetric matrix can also
# be found if tred2 has been used to reduce this
# full matrix to tridiagonal form.
#
# on input
#
# nm must be set to the row dimension of two-dimensional
# array parameters as declared in the calling program
# dimension statement.
#
# n is the order of the matrix.
#
# d contains the diagonal elements of the input matrix.
#
# e contains the subdiagonal elements of the input matrix
# in its last n-1 positions. e(1) is arbitrary.
#
# z contains the transformation matrix produced in the
# reduction by tred2, if performed. if the eigenvectors
# of the tridiagonal matrix are desired, z must contain
# the identity matrix.
#
# on output
#
# d contains the eigenvalues in ascending order. if an
# error exit is made, the eigenvalues are correct but
# unordered for indices 1,2,...,ierr-1.
#
# e has been destroyed.
#
# z contains orthonormal eigenvectors of the symmetric
# tridiagonal (or full) matrix. if an error exit is made,
# z contains the eigenvectors associated with the stored
# eigenvalues.
#
# ierr is set to
# zero for normal return,
# j if the j-th eigenvalue has not been
# determined after 30 iterations.
#
# calls pythag for dsqrt(a*a + b*b) .
#
# questions and comments should be directed to burton s. garbow,
# mathematics and computer science div, argonne national laboratory
#
# this version dated august 1983.
#
# ------------------------------------------------------------------
#
ierr = 0
if (n .eq. 1) go to 1001
#
do 100 i = 2, n
100 e(i-1) = e(i)
#
f = 0.0d0
tst1 = 0.0d0
e(n) = 0.0d0
#
do 240 l = 1, n
j = 0
h = dabs(d(l)) + dabs(e(l))
if (tst1 .lt. h) tst1 = h
# .......... look for small sub-diagonal element ..........
do 110 m = l, n
tst2 = tst1 + dabs(e(m))
if (tst2 .eq. tst1) go to 120
# .......... e(n) is always zero, so there is no exit
# through the bottom of the loop ..........
110 continue
#
120 if (m .eq. l) go to 220
130 if (j .eq. 30) go to 1000
j = j + 1
# .......... form shift ..........
l1 = l + 1
l2 = l1 + 1
g = d(l)
p = (d(l1) - g) / (2.0d0 * e(l))
r = pythag(p,1.0d0)
d(l) = e(l) / (p + dsign(r,p))
d(l1) = e(l) * (p + dsign(r,p))
dl1 = d(l1)
h = g - d(l)
if (l2 .gt. n) go to 145
#
do 140 i = l2, n
140 d(i) = d(i) - h
#
145 f = f + h
# .......... ql transformation ..........
p = d(m)
c = 1.0d0
c2 = c
el1 = e(l1)
s = 0.0d0
mml = m - l
# .......... for i=m-1 step -1 until l do -- ..........
do 200 ii = 1, mml
c3 = c2
c2 = c
s2 = s
i = m - ii
g = c * e(i)
h = c * p
r = pythag(p,e(i))
e(i+1) = s * r
s = e(i) / r
c = p / r
p = c * d(i) - s * g
d(i+1) = h + s * (c * g + s * d(i))
# .......... form vector ..........
do 180 k = 1, n
h = z(k,i+1)
z(k,i+1) = s * z(k,i) + c * h
z(k,i) = c * z(k,i) - s * h
180 continue
#
200 continue
#
p = -s * s2 * c3 * el1 * e(l) / dl1
e(l) = s * p
d(l) = c * p
tst2 = tst1 + dabs(e(l))
if (tst2 .gt. tst1) go to 130
220 d(l) = d(l) + f
240 continue
# .......... order eigenvalues and eigenvectors ..........
do 300 ii = 2, n
i = ii - 1
k = i
p = d(i)
#
do 260 j = ii, n
if (d(j) .ge. p) go to 260
k = j
p = d(j)
260 continue
#
if (k .eq. i) go to 300
d(k) = d(i)
d(i) = p
#
do 280 j = 1, n
p = z(j,i)
z(j,i) = z(j,k)
z(j,k) = p
280 continue
#
300 continue
#
go to 1001
# .......... set error -- no convergence to an
# eigenvalue after 30 iterations ..........
1000 ierr = l
1001 return
end