001:       SUBROUTINE DSPGST( 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:       DOUBLE PRECISION   AP( * ), BP( * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  DSPGST reduces a real symmetric-definite generalized eigenproblem
020: *  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**T)*A*inv(U) or inv(L)*A*inv(L**T)
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**T or L**T*A*L.
027: *
028: *  B must have been previously factorized as U**T*U or L*L**T by DPPTRF.
029: *
030: *  Arguments
031: *  =========
032: *
033: *  ITYPE   (input) INTEGER
034: *          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
035: *          = 2 or 3: compute U*A*U**T or L**T*A*L.
036: *
037: *  UPLO    (input) CHARACTER*1
038: *          = 'U':  Upper triangle of A is stored and B is factored as
039: *                  U**T*U;
040: *          = 'L':  Lower triangle of A is stored and B is factored as
041: *                  L*L**T.
042: *
043: *  N       (input) INTEGER
044: *          The order of the matrices A and B.  N >= 0.
045: *
046: *  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
047: *          On entry, the upper or lower triangle of the symmetric 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) DOUBLE PRECISION 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 DPPTRF.
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:       DOUBLE PRECISION   ONE, HALF
068:       PARAMETER          ( ONE = 1.0D0, HALF = 0.5D0 )
069: *     ..
070: *     .. Local Scalars ..
071:       LOGICAL            UPPER
072:       INTEGER            J, J1, J1J1, JJ, K, K1, K1K1, KK
073:       DOUBLE PRECISION   AJJ, AKK, BJJ, BKK, CT
074: *     ..
075: *     .. External Subroutines ..
076:       EXTERNAL           DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV,
077:      $                   XERBLA
078: *     ..
079: *     .. External Functions ..
080:       LOGICAL            LSAME
081:       DOUBLE PRECISION   DDOT
082:       EXTERNAL           LSAME, DDOT
083: *     ..
084: *     .. Executable Statements ..
085: *
086: *     Test the input parameters.
087: *
088:       INFO = 0
089:       UPPER = LSAME( UPLO, 'U' )
090:       IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
091:          INFO = -1
092:       ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
093:          INFO = -2
094:       ELSE IF( N.LT.0 ) THEN
095:          INFO = -3
096:       END IF
097:       IF( INFO.NE.0 ) THEN
098:          CALL XERBLA( 'DSPGST', -INFO )
099:          RETURN
100:       END IF
101: *
102:       IF( ITYPE.EQ.1 ) THEN
103:          IF( UPPER ) THEN
104: *
105: *           Compute inv(U')*A*inv(U)
106: *
107: *           J1 and JJ are the indices of A(1,j) and A(j,j)
108: *
109:             JJ = 0
110:             DO 10 J = 1, N
111:                J1 = JJ + 1
112:                JJ = JJ + J
113: *
114: *              Compute the j-th column of the upper triangle of A
115: *
116:                BJJ = BP( JJ )
117:                CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP,
118:      $                     AP( J1 ), 1 )
119:                CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE,
120:      $                     AP( J1 ), 1 )
121:                CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
122:                AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ),
123:      $                    1 ) ) / BJJ
124:    10       CONTINUE
125:          ELSE
126: *
127: *           Compute inv(L)*A*inv(L')
128: *
129: *           KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
130: *
131:             KK = 1
132:             DO 20 K = 1, N
133:                K1K1 = KK + N - K + 1
134: *
135: *              Update the lower triangle of A(k:n,k:n)
136: *
137:                AKK = AP( KK )
138:                BKK = BP( KK )
139:                AKK = AKK / BKK**2
140:                AP( KK ) = AKK
141:                IF( K.LT.N ) THEN
142:                   CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
143:                   CT = -HALF*AKK
144:                   CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
145:                   CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1,
146:      $                        BP( KK+1 ), 1, AP( K1K1 ) )
147:                   CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
148:                   CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K,
149:      $                        BP( K1K1 ), AP( KK+1 ), 1 )
150:                END IF
151:                KK = K1K1
152:    20       CONTINUE
153:          END IF
154:       ELSE
155:          IF( UPPER ) THEN
156: *
157: *           Compute U*A*U'
158: *
159: *           K1 and KK are the indices of A(1,k) and A(k,k)
160: *
161:             KK = 0
162:             DO 30 K = 1, N
163:                K1 = KK + 1
164:                KK = KK + K
165: *
166: *              Update the upper triangle of A(1:k,1:k)
167: *
168:                AKK = AP( KK )
169:                BKK = BP( KK )
170:                CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
171:      $                     AP( K1 ), 1 )
172:                CT = HALF*AKK
173:                CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
174:                CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1,
175:      $                     AP )
176:                CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
177:                CALL DSCAL( K-1, BKK, AP( K1 ), 1 )
178:                AP( KK ) = AKK*BKK**2
179:    30       CONTINUE
180:          ELSE
181: *
182: *           Compute L'*A*L
183: *
184: *           JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
185: *
186:             JJ = 1
187:             DO 40 J = 1, N
188:                J1J1 = JJ + N - J + 1
189: *
190: *              Compute the j-th column of the lower triangle of A
191: *
192:                AJJ = AP( JJ )
193:                BJJ = BP( JJ )
194:                AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1,
195:      $                    BP( JJ+1 ), 1 )
196:                CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
197:                CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1,
198:      $                     ONE, AP( JJ+1 ), 1 )
199:                CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1,
200:      $                     BP( JJ ), AP( JJ ), 1 )
201:                JJ = J1J1
202:    40       CONTINUE
203:          END IF
204:       END IF
205:       RETURN
206: *
207: *     End of DSPGST
208: *
209:       END
210: