163 SUBROUTINE zhbtrd( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
173 INTEGER INFO, KD, LDAB, LDQ, N
176 DOUBLE PRECISION D( * ), E( * )
177 COMPLEX*16 AB( ldab, * ), Q( ldq, * ), WORK( * )
183 DOUBLE PRECISION ZERO
184 parameter( zero = 0.0d+0 )
185 COMPLEX*16 CZERO, CONE
186 parameter( czero = ( 0.0d+0, 0.0d+0 ),
187 $ cone = ( 1.0d+0, 0.0d+0 ) )
190 LOGICAL INITQ, UPPER, WANTQ
191 INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
192 $ j1, j1end, j1inc, j2, jend, jin, jinc, k, kd1,
193 $ kdm1, kdn, l, last, lend, nq, nr, nrt
194 DOUBLE PRECISION ABST
202 INTRINSIC abs, dble, dconjg, max, min
212 initq = lsame( vect,
'V' )
213 wantq = initq .OR. lsame( vect,
'U' )
214 upper = lsame( uplo,
'U' )
221 IF( .NOT.wantq .AND. .NOT.lsame( vect,
'N' ) )
THEN 223 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN 225 ELSE IF( n.LT.0 )
THEN 227 ELSE IF( kd.LT.0 )
THEN 229 ELSE IF( ldab.LT.kd1 )
THEN 231 ELSE IF( ldq.LT.max( 1, n ) .AND. wantq )
THEN 235 CALL xerbla(
'ZHBTRD', -info )
247 $
CALL zlaset(
'Full', n, n, czero, cone, q, ldq )
268 ab( kd1, 1 ) = dble( ab( kd1, 1 ) )
273 DO 80 k = kdn + 1, 2, -1
282 CALL zlargv( nr, ab( 1, j1-1 ), inca, work( j1 ),
283 $ kd1, d( j1 ), kd1 )
291 IF( nr.GE.2*kd-1 )
THEN 293 CALL zlartv( nr, ab( l+1, j1-1 ), inca,
294 $ ab( l, j1 ), inca, d( j1 ),
299 jend = j1 + ( nr-1 )*kd1
300 DO 20 jinc = j1, jend, kd1
301 CALL zrot( kdm1, ab( 2, jinc-1 ), 1,
302 $ ab( 1, jinc ), 1, d( jinc ),
310 IF( k.LE.n-i+1 )
THEN 315 CALL zlartg( ab( kd-k+3, i+k-2 ),
316 $ ab( kd-k+2, i+k-1 ), d( i+k-1 ),
317 $ work( i+k-1 ), temp )
318 ab( kd-k+3, i+k-2 ) = temp
322 CALL zrot( k-3, ab( kd-k+4, i+k-2 ), 1,
323 $ ab( kd-k+3, i+k-1 ), 1, d( i+k-1 ),
334 $
CALL zlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),
335 $ ab( kd, j1 ), inca, d( j1 ),
341 CALL zlacgv( nr, work( j1 ), kd1 )
342 IF( 2*kd-1.LT.nr )
THEN 354 $
CALL zlartv( nrt, ab( kd-l, j1+l ), inca,
355 $ ab( kd-l+1, j1+l ), inca,
356 $ d( j1 ), work( j1 ), kd1 )
359 j1end = j1 + kd1*( nr-2 )
360 IF( j1end.GE.j1 )
THEN 361 DO 40 jin = j1, j1end, kd1
362 CALL zrot( kd-1, ab( kd-1, jin+1 ), incx,
363 $ ab( kd, jin+1 ), incx,
364 $ d( jin ), work( jin ) )
367 lend = min( kdm1, n-j2 )
370 $
CALL zrot( lend, ab( kd-1, last+1 ), incx,
371 $ ab( kd, last+1 ), incx, d( last ),
385 iqend = max( iqend, j2 )
389 $ iqaend = iqaend + kd
390 iqaend = min( iqaend, iqend )
391 DO 50 j = j1, j2, kd1
394 iqb = max( 1, j-ibl )
395 nq = 1 + iqaend - iqb
396 iqaend = min( iqaend+kd, iqend )
397 CALL zrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
398 $ 1, d( j ), dconjg( work( j ) ) )
402 DO 60 j = j1, j2, kd1
403 CALL zrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
404 $ d( j ), dconjg( work( j ) ) )
410 IF( j2+kdn.GT.n )
THEN 418 DO 70 j = j1, j2, kd1
423 work( j+kd ) = work( j )*ab( 1, j+kd )
424 ab( 1, j+kd ) = d( j )*ab( 1, j+kd )
439 IF( abst.NE.zero )
THEN 445 $ ab( kd, i+2 ) = ab( kd, i+2 )*t
447 CALL zscal( n, dconjg( t ), q( 1, i+1 ), 1 )
462 d( i ) = ab( kd1, i )
476 ab( 1, 1 ) = dble( ab( 1, 1 ) )
481 DO 200 k = kdn + 1, 2, -1
490 CALL zlargv( nr, ab( kd1, j1-kd1 ), inca,
491 $ work( j1 ), kd1, d( j1 ), kd1 )
499 IF( nr.GT.2*kd-1 )
THEN 501 CALL zlartv( nr, ab( kd1-l, j1-kd1+l ), inca,
502 $ ab( kd1-l+1, j1-kd1+l ), inca,
503 $ d( j1 ), work( j1 ), kd1 )
506 jend = j1 + kd1*( nr-1 )
507 DO 140 jinc = j1, jend, kd1
508 CALL zrot( kdm1, ab( kd, jinc-kd ), incx,
509 $ ab( kd1, jinc-kd ), incx,
510 $ d( jinc ), work( jinc ) )
517 IF( k.LE.n-i+1 )
THEN 522 CALL zlartg( ab( k-1, i ), ab( k, i ),
523 $ d( i+k-1 ), work( i+k-1 ), temp )
528 CALL zrot( k-3, ab( k-2, i+1 ), ldab-1,
529 $ ab( k-1, i+1 ), ldab-1, d( i+k-1 ),
540 $
CALL zlar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),
541 $ ab( 2, j1-1 ), inca, d( j1 ),
551 CALL zlacgv( nr, work( j1 ), kd1 )
552 IF( nr.GT.2*kd-1 )
THEN 560 $
CALL zlartv( nrt, ab( l+2, j1-1 ), inca,
561 $ ab( l+1, j1 ), inca, d( j1 ),
565 j1end = j1 + kd1*( nr-2 )
566 IF( j1end.GE.j1 )
THEN 567 DO 160 j1inc = j1, j1end, kd1
568 CALL zrot( kdm1, ab( 3, j1inc-1 ), 1,
569 $ ab( 2, j1inc ), 1, d( j1inc ),
573 lend = min( kdm1, n-j2 )
576 $
CALL zrot( lend, ab( 3, last-1 ), 1,
577 $ ab( 2, last ), 1, d( last ),
593 iqend = max( iqend, j2 )
597 $ iqaend = iqaend + kd
598 iqaend = min( iqaend, iqend )
599 DO 170 j = j1, j2, kd1
602 iqb = max( 1, j-ibl )
603 nq = 1 + iqaend - iqb
604 iqaend = min( iqaend+kd, iqend )
605 CALL zrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
606 $ 1, d( j ), work( j ) )
610 DO 180 j = j1, j2, kd1
611 CALL zrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
612 $ d( j ), work( j ) )
617 IF( j2+kdn.GT.n )
THEN 625 DO 190 j = j1, j2, kd1
630 work( j+kd ) = work( j )*ab( kd1, j )
631 ab( kd1, j ) = d( j )*ab( kd1, j )
646 IF( abst.NE.zero )
THEN 652 $ ab( 2, i+1 ) = ab( 2, i+1 )*t
654 CALL zscal( n, t, q( 1, i+1 ), 1 )
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 zlar2v(N, X, Y, Z, INCX, C, S, INCC)
ZLAR2V applies a vector of plane rotations with real cosines and complex sines from both sides to a s...
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 zhbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
ZHBTRD
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zlartg(F, G, CS, SN, R)
ZLARTG generates a plane rotation with real cosine and complex sine.