001:       SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, 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, LDA, LDB, N
011: *     ..
012: *     .. Array Arguments ..
013:       REAL               A( LDA, * ), B( LDB, * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  SSYGST reduces a real symmetric-definite generalized eigenproblem
020: *  to standard form.
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 SPOTRF.
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: *  A       (input/output) REAL array, dimension (LDA,N)
047: *          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
048: *          N-by-N upper triangular part of A contains the upper
049: *          triangular part of the matrix A, and the strictly lower
050: *          triangular part of A is not referenced.  If UPLO = 'L', the
051: *          leading N-by-N lower triangular part of A contains the lower
052: *          triangular part of the matrix A, and the strictly upper
053: *          triangular part of A is not referenced.
054: *
055: *          On exit, if INFO = 0, the transformed matrix, stored in the
056: *          same format as A.
057: *
058: *  LDA     (input) INTEGER
059: *          The leading dimension of the array A.  LDA >= max(1,N).
060: *
061: *  B       (input) REAL array, dimension (LDB,N)
062: *          The triangular factor from the Cholesky factorization of B,
063: *          as returned by SPOTRF.
064: *
065: *  LDB     (input) INTEGER
066: *          The leading dimension of the array B.  LDB >= max(1,N).
067: *
068: *  INFO    (output) INTEGER
069: *          = 0:  successful exit
070: *          < 0:  if INFO = -i, the i-th argument had an illegal value
071: *
072: *  =====================================================================
073: *
074: *     .. Parameters ..
075:       REAL               ONE, HALF
076:       PARAMETER          ( ONE = 1.0, HALF = 0.5 )
077: *     ..
078: *     .. Local Scalars ..
079:       LOGICAL            UPPER
080:       INTEGER            K, KB, NB
081: *     ..
082: *     .. External Subroutines ..
083:       EXTERNAL           SSYGS2, SSYMM, SSYR2K, STRMM, STRSM, XERBLA
084: *     ..
085: *     .. Intrinsic Functions ..
086:       INTRINSIC          MAX, MIN
087: *     ..
088: *     .. External Functions ..
089:       LOGICAL            LSAME
090:       INTEGER            ILAENV
091:       EXTERNAL           LSAME, ILAENV
092: *     ..
093: *     .. Executable Statements ..
094: *
095: *     Test the input parameters.
096: *
097:       INFO = 0
098:       UPPER = LSAME( UPLO, 'U' )
099:       IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
100:          INFO = -1
101:       ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
102:          INFO = -2
103:       ELSE IF( N.LT.0 ) THEN
104:          INFO = -3
105:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
106:          INFO = -5
107:       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
108:          INFO = -7
109:       END IF
110:       IF( INFO.NE.0 ) THEN
111:          CALL XERBLA( 'SSYGST', -INFO )
112:          RETURN
113:       END IF
114: *
115: *     Quick return if possible
116: *
117:       IF( N.EQ.0 )
118:      $   RETURN
119: *
120: *     Determine the block size for this environment.
121: *
122:       NB = ILAENV( 1, 'SSYGST', UPLO, N, -1, -1, -1 )
123: *
124:       IF( NB.LE.1 .OR. NB.GE.N ) THEN
125: *
126: *        Use unblocked code
127: *
128:          CALL SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
129:       ELSE
130: *
131: *        Use blocked code
132: *
133:          IF( ITYPE.EQ.1 ) THEN
134:             IF( UPPER ) THEN
135: *
136: *              Compute inv(U')*A*inv(U)
137: *
138:                DO 10 K = 1, N, NB
139:                   KB = MIN( N-K+1, NB )
140: *
141: *                 Update the upper triangle of A(k:n,k:n)
142: *
143:                   CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
144:      $                         B( K, K ), LDB, INFO )
145:                   IF( K+KB.LE.N ) THEN
146:                      CALL STRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
147:      $                           KB, N-K-KB+1, ONE, B( K, K ), LDB,
148:      $                           A( K, K+KB ), LDA )
149:                      CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
150:      $                           A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
151:      $                           A( K, K+KB ), LDA )
152:                      CALL SSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
153:      $                            A( K, K+KB ), LDA, B( K, K+KB ), LDB,
154:      $                            ONE, A( K+KB, K+KB ), LDA )
155:                      CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
156:      $                           A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
157:      $                           A( K, K+KB ), LDA )
158:                      CALL STRSM( 'Right', UPLO, 'No transpose',
159:      $                           'Non-unit', KB, N-K-KB+1, ONE,
160:      $                           B( K+KB, K+KB ), LDB, A( K, K+KB ),
161:      $                           LDA )
162:                   END IF
163:    10          CONTINUE
164:             ELSE
165: *
166: *              Compute inv(L)*A*inv(L')
167: *
168:                DO 20 K = 1, N, NB
169:                   KB = MIN( N-K+1, NB )
170: *
171: *                 Update the lower triangle of A(k:n,k:n)
172: *
173:                   CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
174:      $                         B( K, K ), LDB, INFO )
175:                   IF( K+KB.LE.N ) THEN
176:                      CALL STRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
177:      $                           N-K-KB+1, KB, ONE, B( K, K ), LDB,
178:      $                           A( K+KB, K ), LDA )
179:                      CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
180:      $                           A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
181:      $                           A( K+KB, K ), LDA )
182:                      CALL SSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
183:      $                            -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
184:      $                            LDB, ONE, A( K+KB, K+KB ), LDA )
185:                      CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
186:      $                           A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
187:      $                           A( K+KB, K ), LDA )
188:                      CALL STRSM( 'Left', UPLO, 'No transpose',
189:      $                           'Non-unit', N-K-KB+1, KB, ONE,
190:      $                           B( K+KB, K+KB ), LDB, A( K+KB, K ),
191:      $                           LDA )
192:                   END IF
193:    20          CONTINUE
194:             END IF
195:          ELSE
196:             IF( UPPER ) THEN
197: *
198: *              Compute U*A*U'
199: *
200:                DO 30 K = 1, N, NB
201:                   KB = MIN( N-K+1, NB )
202: *
203: *                 Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
204: *
205:                   CALL STRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
206:      $                        K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
207:                   CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
208:      $                        LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
209:                   CALL SSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
210:      $                         A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
211:      $                         LDA )
212:                   CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
213:      $                        LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
214:                   CALL STRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
215:      $                        K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
216:      $                        LDA )
217:                   CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
218:      $                         B( K, K ), LDB, INFO )
219:    30          CONTINUE
220:             ELSE
221: *
222: *              Compute L'*A*L
223: *
224:                DO 40 K = 1, N, NB
225:                   KB = MIN( N-K+1, NB )
226: *
227: *                 Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
228: *
229:                   CALL STRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
230:      $                        KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
231:                   CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
232:      $                        LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
233:                   CALL SSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
234:      $                         A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
235:      $                         LDA )
236:                   CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
237:      $                        LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
238:                   CALL STRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
239:      $                        K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
240:                   CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
241:      $                         B( K, K ), LDB, INFO )
242:    40          CONTINUE
243:             END IF
244:          END IF
245:       END IF
246:       RETURN
247: *
248: *     End of SSYGST
249: *
250:       END
251: