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 chbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
CHBTRD
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 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...