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