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 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
subroutine slargv(N, X, INCX, Y, INCY, C, INCC)
SLARGV generates a vector of plane rotations with real cosines and real sines.
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 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 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...