187 SUBROUTINE dgbbrd( 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 DOUBLE PRECISION ab( ldab, * ), c( ldc, * ), d( * ), e( * ),
201 $ pt( ldpt, * ), q( ldq, * ), work( * )
207 DOUBLE PRECISION zero, one
208 parameter( zero = 0.0d+0, one = 1.0d+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
214 DOUBLE PRECISION ra, rb, rc, rs
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(
'DGBBRD', -info )
266 $ CALL
dlaset(
'Full', m, m, zero, one, q, ldq )
268 $ CALL
dlaset(
'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
dlargv( 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
dlartv( 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
dlartg( 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
drot( 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
drot( 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
drot( 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
dlargv( 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
dlartv( 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
dlartg( 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
drot( 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
drot( 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
dlartg( 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
drot( m, q( 1, i ), 1, q( 1, i+1 ), 1, rc, rs )
493 $ CALL
drot( 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
dlartg( ab( ku+1, i ), rb, rc, rs, ra )
514 e( i-1 ) = rc*ab( ku, i )
517 $ CALL
drot( 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