001:       SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, 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, LDA, LWORK, N
011: *     ..
012: *     .. Array Arguments ..
013:       REAL               A( LDA, * ), D( * ), E( * ), TAU( * ),
014:      $                   WORK( * )
015: *     ..
016: *
017: *  Purpose
018: *  =======
019: *
020: *  SSYTRD reduces a real symmetric matrix A to real symmetric
021: *  tridiagonal form T by an orthogonal similarity transformation:
022: *  Q**T * A * Q = T.
023: *
024: *  Arguments
025: *  =========
026: *
027: *  UPLO    (input) CHARACTER*1
028: *          = 'U':  Upper triangle of A is stored;
029: *          = 'L':  Lower triangle of A is stored.
030: *
031: *  N       (input) INTEGER
032: *          The order of the matrix A.  N >= 0.
033: *
034: *  A       (input/output) REAL array, dimension (LDA,N)
035: *          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
036: *          N-by-N upper triangular part of A contains the upper
037: *          triangular part of the matrix A, and the strictly lower
038: *          triangular part of A is not referenced.  If UPLO = 'L', the
039: *          leading N-by-N lower triangular part of A contains the lower
040: *          triangular part of the matrix A, and the strictly upper
041: *          triangular part of A is not referenced.
042: *          On exit, if UPLO = 'U', the diagonal and first superdiagonal
043: *          of A are overwritten by the corresponding elements of the
044: *          tridiagonal matrix T, and the elements above the first
045: *          superdiagonal, with the array TAU, represent the orthogonal
046: *          matrix Q as a product of elementary reflectors; if UPLO
047: *          = 'L', the diagonal and first subdiagonal of A are over-
048: *          written by the corresponding elements of the tridiagonal
049: *          matrix T, and the elements below the first subdiagonal, with
050: *          the array TAU, represent the orthogonal matrix Q as a product
051: *          of elementary reflectors. See Further Details.
052: *
053: *  LDA     (input) INTEGER
054: *          The leading dimension of the array A.  LDA >= max(1,N).
055: *
056: *  D       (output) REAL array, dimension (N)
057: *          The diagonal elements of the tridiagonal matrix T:
058: *          D(i) = A(i,i).
059: *
060: *  E       (output) REAL array, dimension (N-1)
061: *          The off-diagonal elements of the tridiagonal matrix T:
062: *          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
063: *
064: *  TAU     (output) REAL array, dimension (N-1)
065: *          The scalar factors of the elementary reflectors (see Further
066: *          Details).
067: *
068: *  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
069: *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
070: *
071: *  LWORK   (input) INTEGER
072: *          The dimension of the array WORK.  LWORK >= 1.
073: *          For optimum performance LWORK >= N*NB, where NB is the
074: *          optimal blocksize.
075: *
076: *          If LWORK = -1, then a workspace query is assumed; the routine
077: *          only calculates the optimal size of the WORK array, returns
078: *          this value as the first entry of the WORK array, and no error
079: *          message related to LWORK is issued by XERBLA.
080: *
081: *  INFO    (output) INTEGER
082: *          = 0:  successful exit
083: *          < 0:  if INFO = -i, the i-th argument had an illegal value
084: *
085: *  Further Details
086: *  ===============
087: *
088: *  If UPLO = 'U', the matrix Q is represented as a product of elementary
089: *  reflectors
090: *
091: *     Q = H(n-1) . . . H(2) H(1).
092: *
093: *  Each H(i) has the form
094: *
095: *     H(i) = I - tau * v * v'
096: *
097: *  where tau is a real scalar, and v is a real vector with
098: *  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
099: *  A(1:i-1,i+1), and tau in TAU(i).
100: *
101: *  If UPLO = 'L', the matrix Q is represented as a product of elementary
102: *  reflectors
103: *
104: *     Q = H(1) H(2) . . . H(n-1).
105: *
106: *  Each H(i) has the form
107: *
108: *     H(i) = I - tau * v * v'
109: *
110: *  where tau is a real scalar, and v is a real vector with
111: *  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
112: *  and tau in TAU(i).
113: *
114: *  The contents of A on exit are illustrated by the following examples
115: *  with n = 5:
116: *
117: *  if UPLO = 'U':                       if UPLO = 'L':
118: *
119: *    (  d   e   v2  v3  v4 )              (  d                  )
120: *    (      d   e   v3  v4 )              (  e   d              )
121: *    (          d   e   v4 )              (  v1  e   d          )
122: *    (              d   e  )              (  v1  v2  e   d      )
123: *    (                  d  )              (  v1  v2  v3  e   d  )
124: *
125: *  where d and e denote diagonal and off-diagonal elements of T, and vi
126: *  denotes an element of the vector defining H(i).
127: *
128: *  =====================================================================
129: *
130: *     .. Parameters ..
131:       REAL               ONE
132:       PARAMETER          ( ONE = 1.0E+0 )
133: *     ..
134: *     .. Local Scalars ..
135:       LOGICAL            LQUERY, UPPER
136:       INTEGER            I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
137:      $                   NBMIN, NX
138: *     ..
139: *     .. External Subroutines ..
140:       EXTERNAL           SLATRD, SSYR2K, SSYTD2, XERBLA
141: *     ..
142: *     .. Intrinsic Functions ..
143:       INTRINSIC          MAX
144: *     ..
145: *     .. External Functions ..
146:       LOGICAL            LSAME
147:       INTEGER            ILAENV
148:       EXTERNAL           LSAME, ILAENV
149: *     ..
150: *     .. Executable Statements ..
151: *
152: *     Test the input parameters
153: *
154:       INFO = 0
155:       UPPER = LSAME( UPLO, 'U' )
156:       LQUERY = ( LWORK.EQ.-1 )
157:       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
158:          INFO = -1
159:       ELSE IF( N.LT.0 ) THEN
160:          INFO = -2
161:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
162:          INFO = -4
163:       ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
164:          INFO = -9
165:       END IF
166: *
167:       IF( INFO.EQ.0 ) THEN
168: *
169: *        Determine the block size.
170: *
171:          NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
172:          LWKOPT = N*NB
173:          WORK( 1 ) = LWKOPT
174:       END IF
175: *
176:       IF( INFO.NE.0 ) THEN
177:          CALL XERBLA( 'SSYTRD', -INFO )
178:          RETURN
179:       ELSE IF( LQUERY ) THEN
180:          RETURN
181:       END IF
182: *
183: *     Quick return if possible
184: *
185:       IF( N.EQ.0 ) THEN
186:          WORK( 1 ) = 1
187:          RETURN
188:       END IF
189: *
190:       NX = N
191:       IWS = 1
192:       IF( NB.GT.1 .AND. NB.LT.N ) THEN
193: *
194: *        Determine when to cross over from blocked to unblocked code
195: *        (last block is always handled by unblocked code).
196: *
197:          NX = MAX( NB, ILAENV( 3, 'SSYTRD', UPLO, N, -1, -1, -1 ) )
198:          IF( NX.LT.N ) THEN
199: *
200: *           Determine if workspace is large enough for blocked code.
201: *
202:             LDWORK = N
203:             IWS = LDWORK*NB
204:             IF( LWORK.LT.IWS ) THEN
205: *
206: *              Not enough workspace to use optimal NB:  determine the
207: *              minimum value of NB, and reduce NB or force use of
208: *              unblocked code by setting NX = N.
209: *
210:                NB = MAX( LWORK / LDWORK, 1 )
211:                NBMIN = ILAENV( 2, 'SSYTRD', UPLO, N, -1, -1, -1 )
212:                IF( NB.LT.NBMIN )
213:      $            NX = N
214:             END IF
215:          ELSE
216:             NX = N
217:          END IF
218:       ELSE
219:          NB = 1
220:       END IF
221: *
222:       IF( UPPER ) THEN
223: *
224: *        Reduce the upper triangle of A.
225: *        Columns 1:kk are handled by the unblocked method.
226: *
227:          KK = N - ( ( N-NX+NB-1 ) / NB )*NB
228:          DO 20 I = N - NB + 1, KK + 1, -NB
229: *
230: *           Reduce columns i:i+nb-1 to tridiagonal form and form the
231: *           matrix W which is needed to update the unreduced part of
232: *           the matrix
233: *
234:             CALL SLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
235:      $                   LDWORK )
236: *
237: *           Update the unreduced submatrix A(1:i-1,1:i-1), using an
238: *           update of the form:  A := A - V*W' - W*V'
239: *
240:             CALL SSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
241:      $                   LDA, WORK, LDWORK, ONE, A, LDA )
242: *
243: *           Copy superdiagonal elements back into A, and diagonal
244: *           elements into D
245: *
246:             DO 10 J = I, I + NB - 1
247:                A( J-1, J ) = E( J-1 )
248:                D( J ) = A( J, J )
249:    10       CONTINUE
250:    20    CONTINUE
251: *
252: *        Use unblocked code to reduce the last or only block
253: *
254:          CALL SSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
255:       ELSE
256: *
257: *        Reduce the lower triangle of A
258: *
259:          DO 40 I = 1, N - NX, NB
260: *
261: *           Reduce columns i:i+nb-1 to tridiagonal form and form the
262: *           matrix W which is needed to update the unreduced part of
263: *           the matrix
264: *
265:             CALL SLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
266:      $                   TAU( I ), WORK, LDWORK )
267: *
268: *           Update the unreduced submatrix A(i+ib:n,i+ib:n), using
269: *           an update of the form:  A := A - V*W' - W*V'
270: *
271:             CALL SSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
272:      $                   A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
273:      $                   A( I+NB, I+NB ), LDA )
274: *
275: *           Copy subdiagonal elements back into A, and diagonal
276: *           elements into D
277: *
278:             DO 30 J = I, I + NB - 1
279:                A( J+1, J ) = E( J )
280:                D( J ) = A( J, J )
281:    30       CONTINUE
282:    40    CONTINUE
283: *
284: *        Use unblocked code to reduce the last or only block
285: *
286:          CALL SSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
287:      $                TAU( I ), IINFO )
288:       END IF
289: *
290:       WORK( 1 ) = LWKOPT
291:       RETURN
292: *
293: *     End of SSYTRD
294: *
295:       END
296: