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 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 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 xerbla(SRNAME, INFO)
XERBLA
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 zhbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
ZHBTRD
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 zscal(N, ZA, ZX, INCX)
ZSCAL
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
subroutine zlartg(F, G, CS, SN, R)
ZLARTG generates a plane rotation with real cosine and complex sine.