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 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 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.