193 SUBROUTINE zgbbrd( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
194 $ ldq, pt, ldpt, c, ldc, work, rwork, info )
203 INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
206 DOUBLE PRECISION D( * ), E( * ), RWORK( * )
207 COMPLEX*16 AB( ldab, * ), C( ldc, * ), PT( ldpt, * ),
208 $ q( ldq, * ), work( * )
214 DOUBLE PRECISION ZERO
215 parameter ( zero = 0.0d+0 )
216 COMPLEX*16 CZERO, CONE
217 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
218 $ cone = ( 1.0d+0, 0.0d+0 ) )
221 LOGICAL WANTB, WANTC, WANTPT, WANTQ
222 INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
223 $ kun, l, minmn, ml, ml0, mu, mu0, nr, nrt
224 DOUBLE PRECISION ABST, RC
225 COMPLEX*16 RA, RB, RS, T
232 INTRINSIC abs, dconjg, max, min
242 wantb = lsame( vect,
'B' )
243 wantq = lsame( vect,
'Q' ) .OR. wantb
244 wantpt = lsame( vect,
'P' ) .OR. wantb
248 IF( .NOT.wantq .AND. .NOT.wantpt .AND. .NOT.lsame( vect,
'N' ) )
251 ELSE IF( m.LT.0 )
THEN
253 ELSE IF( n.LT.0 )
THEN
255 ELSE IF( ncc.LT.0 )
THEN
257 ELSE IF( kl.LT.0 )
THEN
259 ELSE IF( ku.LT.0 )
THEN
261 ELSE IF( ldab.LT.klu1 )
THEN
263 ELSE IF( ldq.LT.1 .OR. wantq .AND. ldq.LT.max( 1, m ) )
THEN
265 ELSE IF( ldpt.LT.1 .OR. wantpt .AND. ldpt.LT.max( 1, n ) )
THEN
267 ELSE IF( ldc.LT.1 .OR. wantc .AND. ldc.LT.max( 1, m ) )
THEN
271 CALL xerbla(
'ZGBBRD', -info )
278 $
CALL zlaset(
'Full', m, m, czero, cone, q, ldq )
280 $
CALL zlaset(
'Full', n, n, czero, cone, pt, ldpt )
284 IF( m.EQ.0 .OR. n.EQ.0 )
289 IF( kl+ku.GT.1 )
THEN
332 $
CALL zlargv( nr, ab( klu1, j1-klm-1 ), inca,
333 $ work( j1 ), kb1, rwork( j1 ), kb1 )
338 IF( j2-klm+l-1.GT.n )
THEN
344 $
CALL zlartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,
345 $ ab( klu1-l+1, j1-klm+l-1 ), inca,
346 $ rwork( j1 ), work( j1 ), kb1 )
350 IF( ml.LE.m-i+1 )
THEN
355 CALL zlartg( ab( ku+ml-1, i ), ab( ku+ml, i ),
356 $ rwork( i+ml-1 ), work( i+ml-1 ), ra )
357 ab( ku+ml-1, i ) = ra
359 $
CALL zrot( min( ku+ml-2, n-i ),
360 $ ab( ku+ml-2, i+1 ), ldab-1,
361 $ ab( ku+ml-1, i+1 ), ldab-1,
362 $ rwork( i+ml-1 ), work( i+ml-1 ) )
372 DO 20 j = j1, j2, kb1
373 CALL zrot( m, q( 1, j-1 ), 1, q( 1, j ), 1,
374 $ rwork( j ), dconjg( work( j ) ) )
382 DO 30 j = j1, j2, kb1
383 CALL zrot( ncc, c( j-1, 1 ), ldc, c( j, 1 ), ldc,
384 $ rwork( j ), work( j ) )
388 IF( j2+kun.GT.n )
THEN
396 DO 40 j = j1, j2, kb1
401 work( j+kun ) = work( j )*ab( 1, j+kun )
402 ab( 1, j+kun ) = rwork( j )*ab( 1, j+kun )
409 $
CALL zlargv( nr, ab( 1, j1+kun-1 ), inca,
410 $ work( j1+kun ), kb1, rwork( j1+kun ),
416 IF( j2+l-1.GT.m )
THEN
422 $
CALL zlartv( nrt, ab( l+1, j1+kun-1 ), inca,
423 $ ab( l, j1+kun ), inca,
424 $ rwork( j1+kun ), work( j1+kun ), kb1 )
427 IF( ml.EQ.ml0 .AND. mu.GT.mu0 )
THEN
428 IF( mu.LE.n-i+1 )
THEN
433 CALL zlartg( ab( ku-mu+3, i+mu-2 ),
434 $ ab( ku-mu+2, i+mu-1 ),
435 $ rwork( i+mu-1 ), work( i+mu-1 ), ra )
436 ab( ku-mu+3, i+mu-2 ) = ra
437 CALL zrot( min( kl+mu-2, m-i ),
438 $ ab( ku-mu+4, i+mu-2 ), 1,
439 $ ab( ku-mu+3, i+mu-1 ), 1,
440 $ rwork( i+mu-1 ), work( i+mu-1 ) )
450 DO 60 j = j1, j2, kb1
451 CALL zrot( n, pt( j+kun-1, 1 ), ldpt,
452 $ pt( j+kun, 1 ), ldpt, rwork( j+kun ),
453 $ dconjg( work( j+kun ) ) )
457 IF( j2+kb.GT.m )
THEN
465 DO 70 j = j1, j2, kb1
470 work( j+kb ) = work( j+kun )*ab( klu1, j+kun )
471 ab( klu1, j+kun ) = rwork( j+kun )*ab( klu1, j+kun )
483 IF( ku.EQ.0 .AND. kl.GT.0 )
THEN
491 DO 100 i = 1, min( m-1, n )
492 CALL zlartg( ab( 1, i ), ab( 2, i ), rc, rs, ra )
495 ab( 2, i ) = rs*ab( 1, i+1 )
496 ab( 1, i+1 ) = rc*ab( 1, i+1 )
499 $
CALL zrot( m, q( 1, i ), 1, q( 1, i+1 ), 1, rc,
502 $
CALL zrot( ncc, c( i, 1 ), ldc, c( i+1, 1 ), ldc, rc,
510 IF( ku.GT.0 .AND. m.LT.n )
THEN
517 CALL zlartg( ab( ku+1, i ), rb, rc, rs, ra )
520 rb = -dconjg( rs )*ab( ku, i )
521 ab( ku, i ) = rc*ab( ku, i )
524 $
CALL zrot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,
537 IF( abst.NE.zero )
THEN
543 $
CALL zscal( m, t, q( 1, i ), 1 )
545 $
CALL zscal( ncc, dconjg( t ), c( i, 1 ), ldc )
546 IF( i.LT.minmn )
THEN
547 IF( ku.EQ.0 .AND. kl.EQ.0 )
THEN
552 t = ab( 2, i )*dconjg( t )
554 t = ab( ku, i+1 )*dconjg( t )
558 IF( abst.NE.zero )
THEN
564 $
CALL zscal( n, t, pt( i+1, 1 ), ldpt )
565 t = ab( ku+1, i+1 )*dconjg( t )
subroutine zlartv(N, X, INCX, Y, INCY, C, S, INCC)
ZLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a p...
subroutine zrot(N, CX, INCX, CY, INCY, C, S)
ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine zlargv(N, X, INCX, Y, INCY, C, INCC)
ZLARGV generates a vector of plane rotations with real cosines and complex sines. ...
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zgbbrd(VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO)
ZGBBRD
subroutine zlartg(F, G, CS, SN, R)
ZLARTG generates a plane rotation with real cosine and complex sine.