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 clargv(N, X, INCX, Y, INCY, C, INCC)
CLARGV generates a vector of plane rotations with real cosines and complex sines. ...
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...
subroutine clartg(F, G, CS, SN, R)
CLARTG generates a plane rotation with real cosine and complex sine.
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 xerbla(SRNAME, INFO)
XERBLA
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine chbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
CHBTRD
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 clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
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...