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...
LOGICAL function lsame(CA, CB)
LSAME
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.
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...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
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 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