Annotation of rpl/lapack/lapack/zhegs2.f, revision 1.20
1.12 bertrand 1: *> \brief \b ZHEGS2 reduces a Hermitian definite generalized eigenproblem to standard form, using the factorization results obtained from cpotrf (unblocked algorithm).
1.9 bertrand 2: *
3: * =========== DOCUMENTATION ===========
4: *
1.16 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.9 bertrand 7: *
8: *> \htmlonly
1.16 bertrand 9: *> Download ZHEGS2 + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhegs2.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhegs2.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhegs2.f">
1.9 bertrand 15: *> [TXT]</a>
1.16 bertrand 16: *> \endhtmlonly
1.9 bertrand 17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
1.16 bertrand 22: *
1.9 bertrand 23: * .. Scalar Arguments ..
24: * CHARACTER UPLO
25: * INTEGER INFO, ITYPE, LDA, LDB, N
26: * ..
27: * .. Array Arguments ..
28: * COMPLEX*16 A( LDA, * ), B( LDB, * )
29: * ..
1.16 bertrand 30: *
1.9 bertrand 31: *
32: *> \par Purpose:
33: * =============
34: *>
35: *> \verbatim
36: *>
37: *> ZHEGS2 reduces a complex Hermitian-definite generalized
38: *> eigenproblem to standard form.
39: *>
40: *> If ITYPE = 1, the problem is A*x = lambda*B*x,
41: *> and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
42: *>
43: *> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
44: *> B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H *A*L.
45: *>
46: *> B must have been previously factorized as U**H *U or L*L**H by ZPOTRF.
47: *> \endverbatim
48: *
49: * Arguments:
50: * ==========
51: *
52: *> \param[in] ITYPE
53: *> \verbatim
54: *> ITYPE is INTEGER
55: *> = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
56: *> = 2 or 3: compute U*A*U**H or L**H *A*L.
57: *> \endverbatim
58: *>
59: *> \param[in] UPLO
60: *> \verbatim
61: *> UPLO is CHARACTER*1
62: *> Specifies whether the upper or lower triangular part of the
63: *> Hermitian matrix A is stored, and how B has been factorized.
64: *> = 'U': Upper triangular
65: *> = 'L': Lower triangular
66: *> \endverbatim
67: *>
68: *> \param[in] N
69: *> \verbatim
70: *> N is INTEGER
71: *> The order of the matrices A and B. N >= 0.
72: *> \endverbatim
73: *>
74: *> \param[in,out] A
75: *> \verbatim
76: *> A is COMPLEX*16 array, dimension (LDA,N)
77: *> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
78: *> n by n upper triangular part of A contains the upper
79: *> triangular part of the matrix A, and the strictly lower
80: *> triangular part of A is not referenced. If UPLO = 'L', the
81: *> leading n by n lower triangular part of A contains the lower
82: *> triangular part of the matrix A, and the strictly upper
83: *> triangular part of A is not referenced.
84: *>
85: *> On exit, if INFO = 0, the transformed matrix, stored in the
86: *> same format as A.
87: *> \endverbatim
88: *>
89: *> \param[in] LDA
90: *> \verbatim
91: *> LDA is INTEGER
92: *> The leading dimension of the array A. LDA >= max(1,N).
93: *> \endverbatim
94: *>
1.12 bertrand 95: *> \param[in,out] B
1.9 bertrand 96: *> \verbatim
97: *> B is COMPLEX*16 array, dimension (LDB,N)
98: *> The triangular factor from the Cholesky factorization of B,
99: *> as returned by ZPOTRF.
1.19 bertrand 100: *> B is modified by the routine but restored on exit.
1.9 bertrand 101: *> \endverbatim
102: *>
103: *> \param[in] LDB
104: *> \verbatim
105: *> LDB is INTEGER
106: *> The leading dimension of the array B. LDB >= max(1,N).
107: *> \endverbatim
108: *>
109: *> \param[out] INFO
110: *> \verbatim
111: *> INFO is INTEGER
112: *> = 0: successful exit.
113: *> < 0: if INFO = -i, the i-th argument had an illegal value.
114: *> \endverbatim
115: *
116: * Authors:
117: * ========
118: *
1.16 bertrand 119: *> \author Univ. of Tennessee
120: *> \author Univ. of California Berkeley
121: *> \author Univ. of Colorado Denver
122: *> \author NAG Ltd.
1.9 bertrand 123: *
124: *> \ingroup complex16HEcomputational
125: *
126: * =====================================================================
1.1 bertrand 127: SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
128: *
1.20 ! bertrand 129: * -- LAPACK computational routine --
1.1 bertrand 130: * -- LAPACK is a software package provided by Univ. of Tennessee, --
131: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
132: *
133: * .. Scalar Arguments ..
134: CHARACTER UPLO
135: INTEGER INFO, ITYPE, LDA, LDB, N
136: * ..
137: * .. Array Arguments ..
138: COMPLEX*16 A( LDA, * ), B( LDB, * )
139: * ..
140: *
141: * =====================================================================
142: *
143: * .. Parameters ..
144: DOUBLE PRECISION ONE, HALF
145: PARAMETER ( ONE = 1.0D+0, HALF = 0.5D+0 )
146: COMPLEX*16 CONE
147: PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
148: * ..
149: * .. Local Scalars ..
150: LOGICAL UPPER
151: INTEGER K
152: DOUBLE PRECISION AKK, BKK
153: COMPLEX*16 CT
154: * ..
155: * .. External Subroutines ..
156: EXTERNAL XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV,
157: $ ZTRSV
158: * ..
159: * .. Intrinsic Functions ..
160: INTRINSIC MAX
161: * ..
162: * .. External Functions ..
163: LOGICAL LSAME
164: EXTERNAL LSAME
165: * ..
166: * .. Executable Statements ..
167: *
168: * Test the input parameters.
169: *
170: INFO = 0
171: UPPER = LSAME( UPLO, 'U' )
172: IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
173: INFO = -1
174: ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
175: INFO = -2
176: ELSE IF( N.LT.0 ) THEN
177: INFO = -3
178: ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
179: INFO = -5
180: ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
181: INFO = -7
182: END IF
183: IF( INFO.NE.0 ) THEN
184: CALL XERBLA( 'ZHEGS2', -INFO )
185: RETURN
186: END IF
187: *
188: IF( ITYPE.EQ.1 ) THEN
189: IF( UPPER ) THEN
190: *
1.8 bertrand 191: * Compute inv(U**H)*A*inv(U)
1.1 bertrand 192: *
193: DO 10 K = 1, N
194: *
195: * Update the upper triangle of A(k:n,k:n)
196: *
1.20 ! bertrand 197: AKK = DBLE( A( K, K ) )
! 198: BKK = DBLE( B( K, K ) )
1.1 bertrand 199: AKK = AKK / BKK**2
200: A( K, K ) = AKK
201: IF( K.LT.N ) THEN
202: CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
203: CT = -HALF*AKK
204: CALL ZLACGV( N-K, A( K, K+1 ), LDA )
205: CALL ZLACGV( N-K, B( K, K+1 ), LDB )
206: CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
207: $ LDA )
208: CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA,
209: $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
210: CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
211: $ LDA )
212: CALL ZLACGV( N-K, B( K, K+1 ), LDB )
213: CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit',
214: $ N-K, B( K+1, K+1 ), LDB, A( K, K+1 ),
215: $ LDA )
216: CALL ZLACGV( N-K, A( K, K+1 ), LDA )
217: END IF
218: 10 CONTINUE
219: ELSE
220: *
1.8 bertrand 221: * Compute inv(L)*A*inv(L**H)
1.1 bertrand 222: *
223: DO 20 K = 1, N
224: *
225: * Update the lower triangle of A(k:n,k:n)
226: *
1.20 ! bertrand 227: AKK = DBLE( A( K, K ) )
! 228: BKK = DBLE( B( K, K ) )
1.1 bertrand 229: AKK = AKK / BKK**2
230: A( K, K ) = AKK
231: IF( K.LT.N ) THEN
232: CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
233: CT = -HALF*AKK
234: CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
235: CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1,
236: $ B( K+1, K ), 1, A( K+1, K+1 ), LDA )
237: CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
238: CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
239: $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
240: END IF
241: 20 CONTINUE
242: END IF
243: ELSE
244: IF( UPPER ) THEN
245: *
1.8 bertrand 246: * Compute U*A*U**H
1.1 bertrand 247: *
248: DO 30 K = 1, N
249: *
250: * Update the upper triangle of A(1:k,1:k)
251: *
1.20 ! bertrand 252: AKK = DBLE( A( K, K ) )
! 253: BKK = DBLE( B( K, K ) )
1.1 bertrand 254: CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
255: $ LDB, A( 1, K ), 1 )
256: CT = HALF*AKK
257: CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
258: CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1,
259: $ A, LDA )
260: CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
261: CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 )
262: A( K, K ) = AKK*BKK**2
263: 30 CONTINUE
264: ELSE
265: *
1.8 bertrand 266: * Compute L**H *A*L
1.1 bertrand 267: *
268: DO 40 K = 1, N
269: *
270: * Update the lower triangle of A(1:k,1:k)
271: *
1.20 ! bertrand 272: AKK = DBLE( A( K, K ) )
! 273: BKK = DBLE( B( K, K ) )
1.1 bertrand 274: CALL ZLACGV( K-1, A( K, 1 ), LDA )
275: CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1,
276: $ B, LDB, A( K, 1 ), LDA )
277: CT = HALF*AKK
278: CALL ZLACGV( K-1, B( K, 1 ), LDB )
279: CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
280: CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ),
281: $ LDB, A, LDA )
282: CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
283: CALL ZLACGV( K-1, B( K, 1 ), LDB )
284: CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA )
285: CALL ZLACGV( K-1, A( K, 1 ), LDA )
286: A( K, K ) = AKK*BKK**2
287: 40 CONTINUE
288: END IF
289: END IF
290: RETURN
291: *
292: * End of ZHEGS2
293: *
294: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zhegs2.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack