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