187 SUBROUTINE sgbbrd( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
188 $ ldq, pt, ldpt, c, ldc, work, info )
197 INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
200 REAL AB( ldab, * ), C( ldc, * ), D( * ), E( * ),
201 $ pt( ldpt, * ), q( ldq, * ), work( * )
208 parameter( zero = 0.0e+0, one = 1.0e+0 )
211 LOGICAL WANTB, WANTC, WANTPT, WANTQ
212 INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
213 $ kun, l, minmn, ml, ml0, mn, mu, mu0, nr, nrt
230 wantb = lsame( vect,
'B' )
231 wantq = lsame( vect,
'Q' ) .OR. wantb
232 wantpt = lsame( vect,
'P' ) .OR. wantb
236 IF( .NOT.wantq .AND. .NOT.wantpt .AND. .NOT.lsame( vect,
'N' ) )
239 ELSE IF( m.LT.0 )
THEN
241 ELSE IF( n.LT.0 )
THEN
243 ELSE IF( ncc.LT.0 )
THEN
245 ELSE IF( kl.LT.0 )
THEN
247 ELSE IF( ku.LT.0 )
THEN
249 ELSE IF( ldab.LT.klu1 )
THEN
251 ELSE IF( ldq.LT.1 .OR. wantq .AND. ldq.LT.max( 1, m ) )
THEN
253 ELSE IF( ldpt.LT.1 .OR. wantpt .AND. ldpt.LT.max( 1, n ) )
THEN
255 ELSE IF( ldc.LT.1 .OR. wantc .AND. ldc.LT.max( 1, m ) )
THEN
259 CALL
xerbla(
'SGBBRD', -info )
266 $ CALL
slaset(
'Full', m, m, zero, one, q, ldq )
268 $ CALL
slaset(
'Full', n, n, zero, one, pt, ldpt )
272 IF( m.EQ.0 .OR. n.EQ.0 )
277 IF( kl+ku.GT.1 )
THEN
321 $ CALL
slargv( nr, ab( klu1, j1-klm-1 ), inca,
322 $ work( j1 ), kb1, work( mn+j1 ), kb1 )
327 IF( j2-klm+l-1.GT.n )
THEN
333 $ CALL
slartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,
334 $ ab( klu1-l+1, j1-klm+l-1 ), inca,
335 $ work( mn+j1 ), work( j1 ), kb1 )
339 IF( ml.LE.m-i+1 )
THEN
344 CALL
slartg( ab( ku+ml-1, i ), ab( ku+ml, i ),
345 $ work( mn+i+ml-1 ), work( i+ml-1 ),
347 ab( ku+ml-1, i ) = ra
349 $ CALL
srot( min( ku+ml-2, n-i ),
350 $ ab( ku+ml-2, i+1 ), ldab-1,
351 $ ab( ku+ml-1, i+1 ), ldab-1,
352 $ work( mn+i+ml-1 ), work( i+ml-1 ) )
362 DO 20 j = j1, j2, kb1
363 CALL
srot( m, q( 1, j-1 ), 1, q( 1, j ), 1,
364 $ work( mn+j ), work( j ) )
372 DO 30 j = j1, j2, kb1
373 CALL
srot( ncc, c( j-1, 1 ), ldc, c( j, 1 ), ldc,
374 $ work( mn+j ), work( j ) )
378 IF( j2+kun.GT.n )
THEN
386 DO 40 j = j1, j2, kb1
391 work( j+kun ) = work( j )*ab( 1, j+kun )
392 ab( 1, j+kun ) = work( mn+j )*ab( 1, j+kun )
399 $ CALL
slargv( nr, ab( 1, j1+kun-1 ), inca,
400 $ work( j1+kun ), kb1, work( mn+j1+kun ),
406 IF( j2+l-1.GT.m )
THEN
412 $ CALL
slartv( nrt, ab( l+1, j1+kun-1 ), inca,
413 $ ab( l, j1+kun ), inca,
414 $ work( mn+j1+kun ), work( j1+kun ),
418 IF( ml.EQ.ml0 .AND. mu.GT.mu0 )
THEN
419 IF( mu.LE.n-i+1 )
THEN
424 CALL
slartg( ab( ku-mu+3, i+mu-2 ),
425 $ ab( ku-mu+2, i+mu-1 ),
426 $ work( mn+i+mu-1 ), work( i+mu-1 ),
428 ab( ku-mu+3, i+mu-2 ) = ra
429 CALL
srot( min( kl+mu-2, m-i ),
430 $ ab( ku-mu+4, i+mu-2 ), 1,
431 $ ab( ku-mu+3, i+mu-1 ), 1,
432 $ work( mn+i+mu-1 ), work( i+mu-1 ) )
442 DO 60 j = j1, j2, kb1
443 CALL
srot( n, pt( j+kun-1, 1 ), ldpt,
444 $ pt( j+kun, 1 ), ldpt, work( mn+j+kun ),
449 IF( j2+kb.GT.m )
THEN
457 DO 70 j = j1, j2, kb1
462 work( j+kb ) = work( j+kun )*ab( klu1, j+kun )
463 ab( klu1, j+kun ) = work( mn+j+kun )*ab( klu1, j+kun )
475 IF( ku.EQ.0 .AND. kl.GT.0 )
THEN
483 DO 100 i = 1, min( m-1, n )
484 CALL
slartg( ab( 1, i ), ab( 2, i ), rc, rs, ra )
487 e( i ) = rs*ab( 1, i+1 )
488 ab( 1, i+1 ) = rc*ab( 1, i+1 )
491 $ CALL
srot( m, q( 1, i ), 1, q( 1, i+1 ), 1, rc, rs )
493 $ CALL
srot( ncc, c( i, 1 ), ldc, c( i+1, 1 ), ldc, rc,
497 $ d( m ) = ab( 1, m )
498 ELSE IF( ku.GT.0 )
THEN
510 CALL
slartg( ab( ku+1, i ), rb, rc, rs, ra )
514 e( i-1 ) = rc*ab( ku, i )
517 $ CALL
srot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,
524 DO 120 i = 1, minmn - 1
525 e( i ) = ab( ku, i+1 )
528 d( i ) = ab( ku+1, i )
536 DO 140 i = 1, minmn - 1
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 sgbbrd(VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO)
SGBBRD
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.
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 slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT