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