163 SUBROUTINE chbtrd( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
173 INTEGER INFO, KD, LDAB, LDQ, N
177 COMPLEX AB( ldab, * ), Q( ldq, * ), WORK( * )
184 parameter( zero = 0.0e+0 )
186 parameter( czero = ( 0.0e+0, 0.0e+0 ),
187 $ cone = ( 1.0e+0, 0.0e+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
202 INTRINSIC abs, conjg, max, min, real
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(
'CHBTRD', -info )
247 $
CALL claset(
'Full', n, n, czero, cone, q, ldq )
268 ab( kd1, 1 ) =
REAL( AB( KD1, 1 ) )
273 DO 80 k = kdn + 1, 2, -1
282 CALL clargv( nr, ab( 1, j1-1 ), inca, work( j1 ),
283 $ kd1, d( j1 ), kd1 )
291 IF( nr.GE.2*kd-1 )
THEN 293 CALL clartv( 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 crot( kdm1, ab( 2, jinc-1 ), 1,
302 $ ab( 1, jinc ), 1, d( jinc ),
310 IF( k.LE.n-i+1 )
THEN 315 CALL clartg( 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 crot( 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 clar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),
335 $ ab( kd, j1 ), inca, d( j1 ),
341 CALL clacgv( nr, work( j1 ), kd1 )
342 IF( 2*kd-1.LT.nr )
THEN 354 $
CALL clartv( 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 crot( 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 crot( 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 crot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
398 $ 1, d( j ), conjg( work( j ) ) )
402 DO 60 j = j1, j2, kd1
403 CALL crot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
404 $ d( j ), conjg( 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 cscal( n, conjg( t ), q( 1, i+1 ), 1 )
462 d( i ) = ab( kd1, i )
476 ab( 1, 1 ) =
REAL( AB( 1, 1 ) )
481 DO 200 k = kdn + 1, 2, -1
490 CALL clargv( nr, ab( kd1, j1-kd1 ), inca,
491 $ work( j1 ), kd1, d( j1 ), kd1 )
499 IF( nr.GT.2*kd-1 )
THEN 501 CALL clartv( 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 crot( 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 clartg( ab( k-1, i ), ab( k, i ),
523 $ d( i+k-1 ), work( i+k-1 ), temp )
528 CALL crot( k-3, ab( k-2, i+1 ), ldab-1,
529 $ ab( k-1, i+1 ), ldab-1, d( i+k-1 ),
540 $
CALL clar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),
541 $ ab( 2, j1-1 ), inca, d( j1 ),
551 CALL clacgv( nr, work( j1 ), kd1 )
552 IF( nr.GT.2*kd-1 )
THEN 560 $
CALL clartv( 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 crot( kdm1, ab( 3, j1inc-1 ), 1,
569 $ ab( 2, j1inc ), 1, d( j1inc ),
573 lend = min( kdm1, n-j2 )
576 $
CALL crot( 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 crot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
606 $ 1, d( j ), work( j ) )
610 DO 180 j = j1, j2, kd1
611 CALL crot( 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 cscal( n, t, q( 1, i+1 ), 1 )
subroutine crot(N, CX, INCX, CY, INCY, C, S)
CROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors...
subroutine clartg(F, G, CS, SN, R)
CLARTG generates a plane rotation with real cosine and complex sine.
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine chbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
CHBTRD
subroutine clartv(N, X, INCX, Y, INCY, C, S, INCC)
CLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a p...
subroutine clargv(N, X, INCX, Y, INCY, C, INCC)
CLARGV generates a vector of plane rotations with real cosines and complex sines. ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine clar2v(N, X, Y, Z, INCX, C, S, INCC)
CLAR2V applies a vector of plane rotations with real cosines and complex sines from both sides to a s...