001:       SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
002: *
003: *  -- LAPACK routine (version 3.2) --
004: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
005: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       CHARACTER          UPLO
010:       INTEGER            INFO, ITYPE, LDA, LDB, N
011: *     ..
012: *     .. Array Arguments ..
013:       COMPLEX*16         A( LDA, * ), B( LDB, * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  ZHEGS2 reduces a complex Hermitian-definite generalized
020: *  eigenproblem to standard form.
021: *
022: *  If ITYPE = 1, the problem is A*x = lambda*B*x,
023: *  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
024: *
025: *  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
026: *  B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
027: *
028: *  B must have been previously factorized as U'*U or L*L' by ZPOTRF.
029: *
030: *  Arguments
031: *  =========
032: *
033: *  ITYPE   (input) INTEGER
034: *          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
035: *          = 2 or 3: compute U*A*U' or L'*A*L.
036: *
037: *  UPLO    (input) CHARACTER*1
038: *          Specifies whether the upper or lower triangular part of the
039: *          Hermitian matrix A is stored, and how B has been factorized.
040: *          = 'U':  Upper triangular
041: *          = 'L':  Lower triangular
042: *
043: *  N       (input) INTEGER
044: *          The order of the matrices A and B.  N >= 0.
045: *
046: *  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
047: *          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
048: *          n by n upper triangular part of A contains the upper
049: *          triangular part of the matrix A, and the strictly lower
050: *          triangular part of A is not referenced.  If UPLO = 'L', the
051: *          leading n by n lower triangular part of A contains the lower
052: *          triangular part of the matrix A, and the strictly upper
053: *          triangular part of A is not referenced.
054: *
055: *          On exit, if INFO = 0, the transformed matrix, stored in the
056: *          same format as A.
057: *
058: *  LDA     (input) INTEGER
059: *          The leading dimension of the array A.  LDA >= max(1,N).
060: *
061: *  B       (input) COMPLEX*16 array, dimension (LDB,N)
062: *          The triangular factor from the Cholesky factorization of B,
063: *          as returned by ZPOTRF.
064: *
065: *  LDB     (input) INTEGER
066: *          The leading dimension of the array B.  LDB >= max(1,N).
067: *
068: *  INFO    (output) INTEGER
069: *          = 0:  successful exit.
070: *          < 0:  if INFO = -i, the i-th argument had an illegal value.
071: *
072: *  =====================================================================
073: *
074: *     .. Parameters ..
075:       DOUBLE PRECISION   ONE, HALF
076:       PARAMETER          ( ONE = 1.0D+0, HALF = 0.5D+0 )
077:       COMPLEX*16         CONE
078:       PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
079: *     ..
080: *     .. Local Scalars ..
081:       LOGICAL            UPPER
082:       INTEGER            K
083:       DOUBLE PRECISION   AKK, BKK
084:       COMPLEX*16         CT
085: *     ..
086: *     .. External Subroutines ..
087:       EXTERNAL           XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV,
088:      $                   ZTRSV
089: *     ..
090: *     .. Intrinsic Functions ..
091:       INTRINSIC          MAX
092: *     ..
093: *     .. External Functions ..
094:       LOGICAL            LSAME
095:       EXTERNAL           LSAME
096: *     ..
097: *     .. Executable Statements ..
098: *
099: *     Test the input parameters.
100: *
101:       INFO = 0
102:       UPPER = LSAME( UPLO, 'U' )
103:       IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
104:          INFO = -1
105:       ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
106:          INFO = -2
107:       ELSE IF( N.LT.0 ) THEN
108:          INFO = -3
109:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
110:          INFO = -5
111:       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
112:          INFO = -7
113:       END IF
114:       IF( INFO.NE.0 ) THEN
115:          CALL XERBLA( 'ZHEGS2', -INFO )
116:          RETURN
117:       END IF
118: *
119:       IF( ITYPE.EQ.1 ) THEN
120:          IF( UPPER ) THEN
121: *
122: *           Compute inv(U')*A*inv(U)
123: *
124:             DO 10 K = 1, N
125: *
126: *              Update the upper triangle of A(k:n,k:n)
127: *
128:                AKK = A( K, K )
129:                BKK = B( K, K )
130:                AKK = AKK / BKK**2
131:                A( K, K ) = AKK
132:                IF( K.LT.N ) THEN
133:                   CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
134:                   CT = -HALF*AKK
135:                   CALL ZLACGV( N-K, A( K, K+1 ), LDA )
136:                   CALL ZLACGV( N-K, B( K, K+1 ), LDB )
137:                   CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
138:      $                        LDA )
139:                   CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA,
140:      $                        B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
141:                   CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
142:      $                        LDA )
143:                   CALL ZLACGV( N-K, B( K, K+1 ), LDB )
144:                   CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit',
145:      $                        N-K, B( K+1, K+1 ), LDB, A( K, K+1 ),
146:      $                        LDA )
147:                   CALL ZLACGV( N-K, A( K, K+1 ), LDA )
148:                END IF
149:    10       CONTINUE
150:          ELSE
151: *
152: *           Compute inv(L)*A*inv(L')
153: *
154:             DO 20 K = 1, N
155: *
156: *              Update the lower triangle of A(k:n,k:n)
157: *
158:                AKK = A( K, K )
159:                BKK = B( K, K )
160:                AKK = AKK / BKK**2
161:                A( K, K ) = AKK
162:                IF( K.LT.N ) THEN
163:                   CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
164:                   CT = -HALF*AKK
165:                   CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
166:                   CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1,
167:      $                        B( K+1, K ), 1, A( K+1, K+1 ), LDA )
168:                   CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
169:                   CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
170:      $                        B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
171:                END IF
172:    20       CONTINUE
173:          END IF
174:       ELSE
175:          IF( UPPER ) THEN
176: *
177: *           Compute U*A*U'
178: *
179:             DO 30 K = 1, N
180: *
181: *              Update the upper triangle of A(1:k,1:k)
182: *
183:                AKK = A( K, K )
184:                BKK = B( K, K )
185:                CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
186:      $                     LDB, A( 1, K ), 1 )
187:                CT = HALF*AKK
188:                CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
189:                CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1,
190:      $                     A, LDA )
191:                CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
192:                CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 )
193:                A( K, K ) = AKK*BKK**2
194:    30       CONTINUE
195:          ELSE
196: *
197: *           Compute L'*A*L
198: *
199:             DO 40 K = 1, N
200: *
201: *              Update the lower triangle of A(1:k,1:k)
202: *
203:                AKK = A( K, K )
204:                BKK = B( K, K )
205:                CALL ZLACGV( K-1, A( K, 1 ), LDA )
206:                CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1,
207:      $                     B, LDB, A( K, 1 ), LDA )
208:                CT = HALF*AKK
209:                CALL ZLACGV( K-1, B( K, 1 ), LDB )
210:                CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
211:                CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ),
212:      $                     LDB, A, LDA )
213:                CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
214:                CALL ZLACGV( K-1, B( K, 1 ), LDB )
215:                CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA )
216:                CALL ZLACGV( K-1, A( K, 1 ), LDA )
217:                A( K, K ) = AKK*BKK**2
218:    40       CONTINUE
219:          END IF
220:       END IF
221:       RETURN
222: *
223: *     End of ZHEGS2
224: *
225:       END
226: