LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
cstt22.f
Go to the documentation of this file.
1*> \brief \b CSTT22
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* SUBROUTINE CSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK,
12* LDWORK, RWORK, RESULT )
13*
14* .. Scalar Arguments ..
15* INTEGER KBAND, LDU, LDWORK, M, N
16* ..
17* .. Array Arguments ..
18* REAL AD( * ), AE( * ), RESULT( 2 ), RWORK( * ),
19* $ SD( * ), SE( * )
20* COMPLEX U( LDU, * ), WORK( LDWORK, * )
21* ..
22*
23*
24*> \par Purpose:
25* =============
26*>
27*> \verbatim
28*>
29*> CSTT22 checks a set of M eigenvalues and eigenvectors,
30*>
31*> A U = U S
32*>
33*> where A is Hermitian tridiagonal, the columns of U are unitary,
34*> and S is diagonal (if KBAND=0) or Hermitian tridiagonal (if KBAND=1).
35*> Two tests are performed:
36*>
37*> RESULT(1) = | U* A U - S | / ( |A| m ulp )
38*>
39*> RESULT(2) = | I - U*U | / ( m ulp )
40*> \endverbatim
41*
42* Arguments:
43* ==========
44*
45*> \param[in] N
46*> \verbatim
47*> N is INTEGER
48*> The size of the matrix. If it is zero, CSTT22 does nothing.
49*> It must be at least zero.
50*> \endverbatim
51*>
52*> \param[in] M
53*> \verbatim
54*> M is INTEGER
55*> The number of eigenpairs to check. If it is zero, CSTT22
56*> does nothing. It must be at least zero.
57*> \endverbatim
58*>
59*> \param[in] KBAND
60*> \verbatim
61*> KBAND is INTEGER
62*> The bandwidth of the matrix S. It may only be zero or one.
63*> If zero, then S is diagonal, and SE is not referenced. If
64*> one, then S is Hermitian tri-diagonal.
65*> \endverbatim
66*>
67*> \param[in] AD
68*> \verbatim
69*> AD is REAL array, dimension (N)
70*> The diagonal of the original (unfactored) matrix A. A is
71*> assumed to be Hermitian tridiagonal.
72*> \endverbatim
73*>
74*> \param[in] AE
75*> \verbatim
76*> AE is REAL array, dimension (N)
77*> The off-diagonal of the original (unfactored) matrix A. A
78*> is assumed to be Hermitian tridiagonal. AE(1) is ignored,
79*> AE(2) is the (1,2) and (2,1) element, etc.
80*> \endverbatim
81*>
82*> \param[in] SD
83*> \verbatim
84*> SD is REAL array, dimension (N)
85*> The diagonal of the (Hermitian tri-) diagonal matrix S.
86*> \endverbatim
87*>
88*> \param[in] SE
89*> \verbatim
90*> SE is REAL array, dimension (N)
91*> The off-diagonal of the (Hermitian tri-) diagonal matrix S.
92*> Not referenced if KBSND=0. If KBAND=1, then AE(1) is
93*> ignored, SE(2) is the (1,2) and (2,1) element, etc.
94*> \endverbatim
95*>
96*> \param[in] U
97*> \verbatim
98*> U is REAL array, dimension (LDU, N)
99*> The unitary matrix in the decomposition.
100*> \endverbatim
101*>
102*> \param[in] LDU
103*> \verbatim
104*> LDU is INTEGER
105*> The leading dimension of U. LDU must be at least N.
106*> \endverbatim
107*>
108*> \param[out] WORK
109*> \verbatim
110*> WORK is COMPLEX array, dimension (LDWORK, M+1)
111*> \endverbatim
112*>
113*> \param[in] LDWORK
114*> \verbatim
115*> LDWORK is INTEGER
116*> The leading dimension of WORK. LDWORK must be at least
117*> max(1,M).
118*> \endverbatim
119*>
120*> \param[out] RWORK
121*> \verbatim
122*> RWORK is REAL array, dimension (N)
123*> \endverbatim
124*>
125*> \param[out] RESULT
126*> \verbatim
127*> RESULT is REAL array, dimension (2)
128*> The values computed by the two tests described above. The
129*> values are currently limited to 1/ulp, to avoid overflow.
130*> \endverbatim
131*
132* Authors:
133* ========
134*
135*> \author Univ. of Tennessee
136*> \author Univ. of California Berkeley
137*> \author Univ. of Colorado Denver
138*> \author NAG Ltd.
139*
140*> \ingroup complex_eig
141*
142* =====================================================================
143 SUBROUTINE cstt22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK,
144 $ LDWORK, RWORK, RESULT )
145*
146* -- LAPACK test routine --
147* -- LAPACK is a software package provided by Univ. of Tennessee, --
148* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*
150* .. Scalar Arguments ..
151 INTEGER KBAND, LDU, LDWORK, M, N
152* ..
153* .. Array Arguments ..
154 REAL AD( * ), AE( * ), RESULT( 2 ), RWORK( * ),
155 $ sd( * ), se( * )
156 COMPLEX U( LDU, * ), WORK( LDWORK, * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 REAL ZERO, ONE
163 parameter( zero = 0.0e0, one = 1.0e0 )
164 COMPLEX CZERO, CONE
165 parameter( czero = ( 0.0e+0, 0.0e+0 ),
166 $ cone = ( 1.0e+0, 0.0e+0 ) )
167* ..
168* .. Local Scalars ..
169 INTEGER I, J, K
170 REAL ANORM, ULP, UNFL, WNORM
171 COMPLEX AUKJ
172* ..
173* .. External Functions ..
174 REAL CLANGE, CLANSY, SLAMCH
175 EXTERNAL clange, clansy, slamch
176* ..
177* .. External Subroutines ..
178 EXTERNAL cgemm
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, max, min, real
182* ..
183* .. Executable Statements ..
184*
185 result( 1 ) = zero
186 result( 2 ) = zero
187 IF( n.LE.0 .OR. m.LE.0 )
188 $ RETURN
189*
190 unfl = slamch( 'Safe minimum' )
191 ulp = slamch( 'Epsilon' )
192*
193* Do Test 1
194*
195* Compute the 1-norm of A.
196*
197 IF( n.GT.1 ) THEN
198 anorm = abs( ad( 1 ) ) + abs( ae( 1 ) )
199 DO 10 j = 2, n - 1
200 anorm = max( anorm, abs( ad( j ) )+abs( ae( j ) )+
201 $ abs( ae( j-1 ) ) )
202 10 CONTINUE
203 anorm = max( anorm, abs( ad( n ) )+abs( ae( n-1 ) ) )
204 ELSE
205 anorm = abs( ad( 1 ) )
206 END IF
207 anorm = max( anorm, unfl )
208*
209* Norm of U*AU - S
210*
211 DO 40 i = 1, m
212 DO 30 j = 1, m
213 work( i, j ) = czero
214 DO 20 k = 1, n
215 aukj = ad( k )*u( k, j )
216 IF( k.NE.n )
217 $ aukj = aukj + ae( k )*u( k+1, j )
218 IF( k.NE.1 )
219 $ aukj = aukj + ae( k-1 )*u( k-1, j )
220 work( i, j ) = work( i, j ) + u( k, i )*aukj
221 20 CONTINUE
222 30 CONTINUE
223 work( i, i ) = work( i, i ) - sd( i )
224 IF( kband.EQ.1 ) THEN
225 IF( i.NE.1 )
226 $ work( i, i-1 ) = work( i, i-1 ) - se( i-1 )
227 IF( i.NE.n )
228 $ work( i, i+1 ) = work( i, i+1 ) - se( i )
229 END IF
230 40 CONTINUE
231*
232 wnorm = clansy( '1', 'L', m, work, m, rwork )
233*
234 IF( anorm.GT.wnorm ) THEN
235 result( 1 ) = ( wnorm / anorm ) / ( m*ulp )
236 ELSE
237 IF( anorm.LT.one ) THEN
238 result( 1 ) = ( min( wnorm, m*anorm ) / anorm ) / ( m*ulp )
239 ELSE
240 result( 1 ) = min( wnorm / anorm, real( m ) ) / ( m*ulp )
241 END IF
242 END IF
243*
244* Do Test 2
245*
246* Compute U*U - I
247*
248 CALL cgemm( 'T', 'N', m, m, n, cone, u, ldu, u, ldu, czero, work,
249 $ m )
250*
251 DO 50 j = 1, m
252 work( j, j ) = work( j, j ) - one
253 50 CONTINUE
254*
255 result( 2 ) = min( real( m ), clange( '1', m, m, work, m,
256 $ rwork ) ) / ( m*ulp )
257*
258 RETURN
259*
260* End of CSTT22
261*
262 END
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:187
subroutine cstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RWORK, RESULT)
CSTT22
Definition: cstt22.f:145