161 SUBROUTINE ssbtrd( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
170 INTEGER INFO, KD, LDAB, LDQ, N
173 REAL AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
181 parameter( zero = 0.0e+0, one = 1.0e+0 )
184 LOGICAL INITQ, UPPER, WANTQ
185 INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
186 $ j1, j1end, j1inc, j2, jend, jin, jinc, k, kd1,
187 $ kdm1, kdn, l, last, lend, nq, nr, nrt
205 initq = lsame( vect,
'V' )
206 wantq = initq .OR. lsame( vect,
'U' )
207 upper = lsame( uplo,
'U' )
214 IF( .NOT.wantq .AND. .NOT.lsame( vect,
'N' ) )
THEN
216 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
218 ELSE IF( n.LT.0 )
THEN
220 ELSE IF( kd.LT.0 )
THEN
222 ELSE IF( ldab.LT.kd1 )
THEN
224 ELSE IF( ldq.LT.max( 1, n ) .AND. wantq )
THEN
228 CALL xerbla(
'SSBTRD', -info )
240 $
CALL slaset(
'Full', n, n, zero, one, q, ldq )
264 DO 80 k = kdn + 1, 2, -1
273 CALL slargv( nr, ab( 1, j1-1 ), inca, work( j1 ),
274 $ kd1, d( j1 ), kd1 )
282 IF( nr.GE.2*kd-1 )
THEN
284 CALL slartv( nr, ab( l+1, j1-1 ), inca,
285 $ ab( l, j1 ), inca, d( j1 ),
290 jend = j1 + ( nr-1 )*kd1
291 DO 20 jinc = j1, jend, kd1
292 CALL srot( kdm1, ab( 2, jinc-1 ), 1,
293 $ ab( 1, jinc ), 1, d( jinc ),
301 IF( k.LE.n-i+1 )
THEN
306 CALL slartg( ab( kd-k+3, i+k-2 ),
307 $ ab( kd-k+2, i+k-1 ), d( i+k-1 ),
308 $ work( i+k-1 ), temp )
309 ab( kd-k+3, i+k-2 ) = temp
313 CALL srot( k-3, ab( kd-k+4, i+k-2 ), 1,
314 $ ab( kd-k+3, i+k-1 ), 1, d( i+k-1 ),
325 $
CALL slar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),
326 $ ab( kd, j1 ), inca, d( j1 ),
332 IF( 2*kd-1.LT.nr )
THEN
344 $
CALL slartv( nrt, ab( kd-l, j1+l ), inca,
345 $ ab( kd-l+1, j1+l ), inca,
346 $ d( j1 ), work( j1 ), kd1 )
349 j1end = j1 + kd1*( nr-2 )
350 IF( j1end.GE.j1 )
THEN
351 DO 40 jin = j1, j1end, kd1
352 CALL srot( kd-1, ab( kd-1, jin+1 ), incx,
353 $ ab( kd, jin+1 ), incx,
354 $ d( jin ), work( jin ) )
357 lend = min( kdm1, n-j2 )
360 $
CALL srot( lend, ab( kd-1, last+1 ), incx,
361 $ ab( kd, last+1 ), incx, d( last ),
375 iqend = max( iqend, j2 )
379 $ iqaend = iqaend + kd
380 iqaend = min( iqaend, iqend )
381 DO 50 j = j1, j2, kd1
384 iqb = max( 1, j-ibl )
385 nq = 1 + iqaend - iqb
386 iqaend = min( iqaend+kd, iqend )
387 CALL srot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
388 $ 1, d( j ), work( j ) )
392 DO 60 j = j1, j2, kd1
393 CALL srot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
394 $ d( j ), work( j ) )
400 IF( j2+kdn.GT.n )
THEN
408 DO 70 j = j1, j2, kd1
413 work( j+kd ) = work( j )*ab( 1, j+kd )
414 ab( 1, j+kd ) = d( j )*ab( 1, j+kd )
425 e( i ) = ab( kd, i+1 )
439 d( i ) = ab( kd1, i )
456 DO 200 k = kdn + 1, 2, -1
465 CALL slargv( nr, ab( kd1, j1-kd1 ), inca,
466 $ work( j1 ), kd1, d( j1 ), kd1 )
474 IF( nr.GT.2*kd-1 )
THEN
476 CALL slartv( nr, ab( kd1-l, j1-kd1+l ), inca,
477 $ ab( kd1-l+1, j1-kd1+l ), inca,
478 $ d( j1 ), work( j1 ), kd1 )
481 jend = j1 + kd1*( nr-1 )
482 DO 140 jinc = j1, jend, kd1
483 CALL srot( kdm1, ab( kd, jinc-kd ), incx,
484 $ ab( kd1, jinc-kd ), incx,
485 $ d( jinc ), work( jinc ) )
492 IF( k.LE.n-i+1 )
THEN
497 CALL slartg( ab( k-1, i ), ab( k, i ),
498 $ d( i+k-1 ), work( i+k-1 ), temp )
503 CALL srot( k-3, ab( k-2, i+1 ), ldab-1,
504 $ ab( k-1, i+1 ), ldab-1, d( i+k-1 ),
515 $
CALL slar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),
516 $ ab( 2, j1-1 ), inca, d( j1 ),
526 IF( nr.GT.2*kd-1 )
THEN
534 $
CALL slartv( nrt, ab( l+2, j1-1 ), inca,
535 $ ab( l+1, j1 ), inca, d( j1 ),
539 j1end = j1 + kd1*( nr-2 )
540 IF( j1end.GE.j1 )
THEN
541 DO 160 j1inc = j1, j1end, kd1
542 CALL srot( kdm1, ab( 3, j1inc-1 ), 1,
543 $ ab( 2, j1inc ), 1, d( j1inc ),
547 lend = min( kdm1, n-j2 )
550 $
CALL srot( lend, ab( 3, last-1 ), 1,
551 $ ab( 2, last ), 1, d( last ),
567 iqend = max( iqend, j2 )
571 $ iqaend = iqaend + kd
572 iqaend = min( iqaend, iqend )
573 DO 170 j = j1, j2, kd1
576 iqb = max( 1, j-ibl )
577 nq = 1 + iqaend - iqb
578 iqaend = min( iqaend+kd, iqend )
579 CALL srot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
580 $ 1, d( j ), work( j ) )
584 DO 180 j = j1, j2, kd1
585 CALL srot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
586 $ d( j ), work( j ) )
591 IF( j2+kdn.GT.n )
THEN
599 DO 190 j = j1, j2, kd1
604 work( j+kd ) = work( j )*ab( kd1, j )
605 ab( kd1, j ) = d( j )*ab( kd1, j )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slartv(N, X, INCX, Y, INCY, C, S, INCC)
SLARTV applies a vector of plane rotations with real cosines and real sines to the elements of a pair...
subroutine slar2v(N, X, Y, Z, INCX, C, S, INCC)
SLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequ...
subroutine slargv(N, X, INCX, Y, INCY, C, INCC)
SLARGV generates a vector of plane rotations with real cosines and real sines.
subroutine ssbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
SSBTRD
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT