163 SUBROUTINE ssbtrd( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
173 INTEGER info, kd, ldab, ldq, n
176 REAL ab( ldab, * ), d( * ), e( * ), q( ldq, * ),
184 parameter( zero = 0.0e+0, one = 1.0e+0 )
187 LOGICAL initq, upper, wantq
188 INTEGER i, i2, ibl, inca, incx, iqaend, iqb, iqend,
j,
189 $ j1, j1end, j1inc, j2, jend, jin, jinc, k, kd1,
190 $ kdm1, kdn, l, last, lend, nq, nr, nrt
208 initq =
lsame( vect,
'V' )
209 wantq = initq .OR.
lsame( vect,
'U' )
210 upper =
lsame( uplo,
'U' )
217 IF( .NOT.wantq .AND. .NOT.
lsame( vect,
'N' ) )
THEN
219 ELSE IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
221 ELSE IF( n.LT.0 )
THEN
223 ELSE IF( kd.LT.0 )
THEN
225 ELSE IF( ldab.LT.kd1 )
THEN
227 ELSE IF( ldq.LT.max( 1, n ) .AND. wantq )
THEN
231 CALL
xerbla(
'SSBTRD', -info )
243 $ CALL
slaset(
'Full', n, n, zero, one, q, ldq )
267 DO 80 k = kdn + 1, 2, -1
276 CALL
slargv( nr, ab( 1, j1-1 ), inca, work( j1 ),
277 $ kd1, d( j1 ), kd1 )
285 IF( nr.GE.2*kd-1 )
THEN
287 CALL
slartv( nr, ab( l+1, j1-1 ), inca,
288 $ ab( l, j1 ), inca, d( j1 ),
293 jend = j1 + ( nr-1 )*kd1
294 DO 20 jinc = j1, jend, kd1
295 CALL
srot( kdm1, ab( 2, jinc-1 ), 1,
296 $ ab( 1, jinc ), 1, d( jinc ),
304 IF( k.LE.n-i+1 )
THEN
309 CALL
slartg( ab( kd-k+3, i+k-2 ),
310 $ ab( kd-k+2, i+k-1 ), d( i+k-1 ),
311 $ work( i+k-1 ), temp )
312 ab( kd-k+3, i+k-2 ) = temp
316 CALL
srot( k-3, ab( kd-k+4, i+k-2 ), 1,
317 $ ab( kd-k+3, i+k-1 ), 1, d( i+k-1 ),
328 $ CALL
slar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),
329 $ ab( kd, j1 ), inca, d( j1 ),
335 IF( 2*kd-1.LT.nr )
THEN
347 $ CALL
slartv( nrt, ab( kd-l, j1+l ), inca,
348 $ ab( kd-l+1, j1+l ), inca,
349 $ d( j1 ), work( j1 ), kd1 )
352 j1end = j1 + kd1*( nr-2 )
353 IF( j1end.GE.j1 )
THEN
354 DO 40 jin = j1, j1end, kd1
355 CALL
srot( kd-1, ab( kd-1, jin+1 ), incx,
356 $ ab( kd, jin+1 ), incx,
357 $ d( jin ), work( jin ) )
360 lend = min( kdm1, n-j2 )
363 $ CALL
srot( lend, ab( kd-1, last+1 ), incx,
364 $ ab( kd, last+1 ), incx, d( last ),
378 iqend = max( iqend, j2 )
382 $ iqaend = iqaend + kd
383 iqaend = min( iqaend, iqend )
384 DO 50
j = j1, j2, kd1
387 iqb = max( 1,
j-ibl )
388 nq = 1 + iqaend - iqb
389 iqaend = min( iqaend+kd, iqend )
390 CALL
srot( nq, q( iqb,
j-1 ), 1, q( iqb,
j ),
391 $ 1, d(
j ), work(
j ) )
395 DO 60
j = j1, j2, kd1
396 CALL
srot( n, q( 1,
j-1 ), 1, q( 1,
j ), 1,
397 $ d(
j ), work(
j ) )
403 IF( j2+kdn.GT.n )
THEN
411 DO 70
j = j1, j2, kd1
416 work(
j+kd ) = work(
j )*ab( 1,
j+kd )
417 ab( 1,
j+kd ) = d(
j )*ab( 1,
j+kd )
428 e( i ) = ab( kd, i+1 )
442 d( i ) = ab( kd1, i )
459 DO 200 k = kdn + 1, 2, -1
468 CALL
slargv( nr, ab( kd1, j1-kd1 ), inca,
469 $ work( j1 ), kd1, d( j1 ), kd1 )
477 IF( nr.GT.2*kd-1 )
THEN
479 CALL
slartv( nr, ab( kd1-l, j1-kd1+l ), inca,
480 $ ab( kd1-l+1, j1-kd1+l ), inca,
481 $ d( j1 ), work( j1 ), kd1 )
484 jend = j1 + kd1*( nr-1 )
485 DO 140 jinc = j1, jend, kd1
486 CALL
srot( kdm1, ab( kd, jinc-kd ), incx,
487 $ ab( kd1, jinc-kd ), incx,
488 $ d( jinc ), work( jinc ) )
495 IF( k.LE.n-i+1 )
THEN
500 CALL
slartg( ab( k-1, i ), ab( k, i ),
501 $ d( i+k-1 ), work( i+k-1 ), temp )
506 CALL
srot( k-3, ab( k-2, i+1 ), ldab-1,
507 $ ab( k-1, i+1 ), ldab-1, d( i+k-1 ),
518 $ CALL
slar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),
519 $ ab( 2, j1-1 ), inca, d( j1 ),
529 IF( nr.GT.2*kd-1 )
THEN
537 $ CALL
slartv( nrt, ab( l+2, j1-1 ), inca,
538 $ ab( l+1, j1 ), inca, d( j1 ),
542 j1end = j1 + kd1*( nr-2 )
543 IF( j1end.GE.j1 )
THEN
544 DO 160 j1inc = j1, j1end, kd1
545 CALL
srot( kdm1, ab( 3, j1inc-1 ), 1,
546 $ ab( 2, j1inc ), 1, d( j1inc ),
550 lend = min( kdm1, n-j2 )
553 $ CALL
srot( lend, ab( 3, last-1 ), 1,
554 $ ab( 2, last ), 1, d( last ),
570 iqend = max( iqend, j2 )
574 $ iqaend = iqaend + kd
575 iqaend = min( iqaend, iqend )
576 DO 170
j = j1, j2, kd1
579 iqb = max( 1,
j-ibl )
580 nq = 1 + iqaend - iqb
581 iqaend = min( iqaend+kd, iqend )
582 CALL
srot( nq, q( iqb,
j-1 ), 1, q( iqb,
j ),
583 $ 1, d(
j ), work(
j ) )
587 DO 180
j = j1, j2, kd1
588 CALL
srot( n, q( 1,
j-1 ), 1, q( 1,
j ), 1,
589 $ d(
j ), work(
j ) )
594 IF( j2+kdn.GT.n )
THEN
602 DO 190
j = j1, j2, kd1
607 work(
j+kd ) = work(
j )*ab( kd1,
j )
608 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 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 xerbla(SRNAME, INFO)
XERBLA
subroutine slargv(N, X, INCX, Y, INCY, C, INCC)
SLARGV generates a vector of plane rotations with real cosines and real sines.
logical function lsame(CA, CB)
LSAME
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...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
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