001:       SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, 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, N
011: *     ..
012: *     .. Array Arguments ..
013:       COMPLEX            AP( * ), BP( * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  CHPGST reduces a complex Hermitian-definite generalized
020: *  eigenproblem to standard form, using packed storage.
021: *
022: *  If ITYPE = 1, the problem is A*x = lambda*B*x,
023: *  and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
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**H or L**H*A*L.
027: *
028: *  B must have been previously factorized as U**H*U or L*L**H by CPPTRF.
029: *
030: *  Arguments
031: *  =========
032: *
033: *  ITYPE   (input) INTEGER
034: *          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
035: *          = 2 or 3: compute U*A*U**H or L**H*A*L.
036: *
037: *  UPLO    (input) CHARACTER*1
038: *          = 'U':  Upper triangle of A is stored and B is factored as
039: *                  U**H*U;
040: *          = 'L':  Lower triangle of A is stored and B is factored as
041: *                  L*L**H.
042: *
043: *  N       (input) INTEGER
044: *          The order of the matrices A and B.  N >= 0.
045: *
046: *  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
047: *          On entry, the upper or lower triangle of the Hermitian matrix
048: *          A, packed columnwise in a linear array.  The j-th column of A
049: *          is stored in the array AP as follows:
050: *          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
051: *          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
052: *
053: *          On exit, if INFO = 0, the transformed matrix, stored in the
054: *          same format as A.
055: *
056: *  BP      (input) COMPLEX array, dimension (N*(N+1)/2)
057: *          The triangular factor from the Cholesky factorization of B,
058: *          stored in the same format as A, as returned by CPPTRF.
059: *
060: *  INFO    (output) INTEGER
061: *          = 0:  successful exit
062: *          < 0:  if INFO = -i, the i-th argument had an illegal value
063: *
064: *  =====================================================================
065: *
066: *     .. Parameters ..
067:       REAL               ONE, HALF
068:       PARAMETER          ( ONE = 1.0E+0, HALF = 0.5E+0 )
069:       COMPLEX            CONE
070:       PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
071: *     ..
072: *     .. Local Scalars ..
073:       LOGICAL            UPPER
074:       INTEGER            J, J1, J1J1, JJ, K, K1, K1K1, KK
075:       REAL               AJJ, AKK, BJJ, BKK
076:       COMPLEX            CT
077: *     ..
078: *     .. External Subroutines ..
079:       EXTERNAL           CAXPY, CHPMV, CHPR2, CSSCAL, CTPMV, CTPSV,
080:      $                   XERBLA
081: *     ..
082: *     .. Intrinsic Functions ..
083:       INTRINSIC          REAL
084: *     ..
085: *     .. External Functions ..
086:       LOGICAL            LSAME
087:       COMPLEX            CDOTC
088:       EXTERNAL           LSAME, CDOTC
089: *     ..
090: *     .. Executable Statements ..
091: *
092: *     Test the input parameters.
093: *
094:       INFO = 0
095:       UPPER = LSAME( UPLO, 'U' )
096:       IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
097:          INFO = -1
098:       ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
099:          INFO = -2
100:       ELSE IF( N.LT.0 ) THEN
101:          INFO = -3
102:       END IF
103:       IF( INFO.NE.0 ) THEN
104:          CALL XERBLA( 'CHPGST', -INFO )
105:          RETURN
106:       END IF
107: *
108:       IF( ITYPE.EQ.1 ) THEN
109:          IF( UPPER ) THEN
110: *
111: *           Compute inv(U')*A*inv(U)
112: *
113: *           J1 and JJ are the indices of A(1,j) and A(j,j)
114: *
115:             JJ = 0
116:             DO 10 J = 1, N
117:                J1 = JJ + 1
118:                JJ = JJ + J
119: *
120: *              Compute the j-th column of the upper triangle of A
121: *
122:                AP( JJ ) = REAL( AP( JJ ) )
123:                BJJ = BP( JJ )
124:                CALL CTPSV( UPLO, 'Conjugate transpose', 'Non-unit', J,
125:      $                     BP, AP( J1 ), 1 )
126:                CALL CHPMV( UPLO, J-1, -CONE, AP, BP( J1 ), 1, CONE,
127:      $                     AP( J1 ), 1 )
128:                CALL CSSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
129:                AP( JJ ) = ( AP( JJ )-CDOTC( J-1, AP( J1 ), 1, BP( J1 ),
130:      $                    1 ) ) / BJJ
131:    10       CONTINUE
132:          ELSE
133: *
134: *           Compute inv(L)*A*inv(L')
135: *
136: *           KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
137: *
138:             KK = 1
139:             DO 20 K = 1, N
140:                K1K1 = KK + N - K + 1
141: *
142: *              Update the lower triangle of A(k:n,k:n)
143: *
144:                AKK = AP( KK )
145:                BKK = BP( KK )
146:                AKK = AKK / BKK**2
147:                AP( KK ) = AKK
148:                IF( K.LT.N ) THEN
149:                   CALL CSSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
150:                   CT = -HALF*AKK
151:                   CALL CAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
152:                   CALL CHPR2( UPLO, N-K, -CONE, AP( KK+1 ), 1,
153:      $                        BP( KK+1 ), 1, AP( K1K1 ) )
154:                   CALL CAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
155:                   CALL CTPSV( UPLO, 'No transpose', 'Non-unit', N-K,
156:      $                        BP( K1K1 ), AP( KK+1 ), 1 )
157:                END IF
158:                KK = K1K1
159:    20       CONTINUE
160:          END IF
161:       ELSE
162:          IF( UPPER ) THEN
163: *
164: *           Compute U*A*U'
165: *
166: *           K1 and KK are the indices of A(1,k) and A(k,k)
167: *
168:             KK = 0
169:             DO 30 K = 1, N
170:                K1 = KK + 1
171:                KK = KK + K
172: *
173: *              Update the upper triangle of A(1:k,1:k)
174: *
175:                AKK = AP( KK )
176:                BKK = BP( KK )
177:                CALL CTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
178:      $                     AP( K1 ), 1 )
179:                CT = HALF*AKK
180:                CALL CAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
181:                CALL CHPR2( UPLO, K-1, CONE, AP( K1 ), 1, BP( K1 ), 1,
182:      $                     AP )
183:                CALL CAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
184:                CALL CSSCAL( K-1, BKK, AP( K1 ), 1 )
185:                AP( KK ) = AKK*BKK**2
186:    30       CONTINUE
187:          ELSE
188: *
189: *           Compute L'*A*L
190: *
191: *           JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
192: *
193:             JJ = 1
194:             DO 40 J = 1, N
195:                J1J1 = JJ + N - J + 1
196: *
197: *              Compute the j-th column of the lower triangle of A
198: *
199:                AJJ = AP( JJ )
200:                BJJ = BP( JJ )
201:                AP( JJ ) = AJJ*BJJ + CDOTC( N-J, AP( JJ+1 ), 1,
202:      $                    BP( JJ+1 ), 1 )
203:                CALL CSSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
204:                CALL CHPMV( UPLO, N-J, CONE, AP( J1J1 ), BP( JJ+1 ), 1,
205:      $                     CONE, AP( JJ+1 ), 1 )
206:                CALL CTPMV( UPLO, 'Conjugate transpose', 'Non-unit',
207:      $                     N-J+1, BP( JJ ), AP( JJ ), 1 )
208:                JJ = J1J1
209:    40       CONTINUE
210:          END IF
211:       END IF
212:       RETURN
213: *
214: *     End of CHPGST
215: *
216:       END
217: