243 SUBROUTINE zhetrd_he2hb( UPLO, N, KD, A, LDA, AB, LDAB, TAU,
244 $ work, lwork, info )
255 INTEGER INFO, LDA, LDAB, LWORK, N, KD
258 COMPLEX*16 A( lda, * ), AB( ldab, * ),
259 $ tau( * ), work( * )
265 DOUBLE PRECISION RONE
266 COMPLEX*16 ZERO, ONE, HALF
267 parameter ( rone = 1.0d+0,
268 $ zero = ( 0.0d+0, 0.0d+0 ),
269 $ one = ( 1.0d+0, 0.0d+0 ),
270 $ half = ( 0.5d+0, 0.0d+0 ) )
273 LOGICAL LQUERY, UPPER
274 INTEGER I, J, IINFO, LWMIN, PN, PK, LK,
275 $ ldt, ldw, lds2, lds1,
277 $ tpos, wpos, s2pos, s1pos
289 EXTERNAL lsame, ilaenv
297 upper = lsame( uplo,
'U' )
298 lquery = ( lwork.EQ.-1 )
299 lwmin = ilaenv( 20,
'ZHETRD_HE2HB',
'', n, kd, -1, -1 )
301 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
303 ELSE IF( n.LT.0 )
THEN
305 ELSE IF( kd.LT.0 )
THEN
307 ELSE IF( lda.LT.max( 1, n ) )
THEN
309 ELSE IF( ldab.LT.max( 1, kd+1 ) )
THEN
311 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
316 CALL xerbla(
'ZHETRD_HE2HB', -info )
318 ELSE IF( lquery )
THEN
330 CALL zcopy( lk, a( i-lk+1, i ), 1,
331 $ ab( kd+1-lk+1, i ), 1 )
335 lk = min( kd+1, n-i+1 )
336 CALL zcopy( lk, a( i, i ), 1, ab( 1, i ), 1 )
350 ls2 = lwmin - lt - lw - ls1
368 CALL zlaset(
"A", ldt, kd, zero, zero, work( tpos ), ldt )
371 DO 10 i = 1, n - kd, kd
373 pk = min( n-i-kd+1, kd )
377 CALL zgelqf( kd, pn, a( i, i+kd ), lda,
378 $ tau( i ), work( s2pos ), ls2, iinfo )
383 lk = min( kd, n-j ) + 1
384 CALL zcopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
387 CALL zlaset(
'Lower', pk, pk, zero, one,
388 $ a( i, i+kd ), lda )
392 CALL zlarft(
'Forward',
'Rowwise', pn, pk,
393 $ a( i, i+kd ), lda, tau( i ),
394 $ work( tpos ), ldt )
398 CALL zgemm(
'Conjugate',
'No transpose', pk, pn, pk,
399 $ one, work( tpos ), ldt,
401 $ zero, work( s2pos ), lds2 )
403 CALL zhemm(
'Right', uplo, pk, pn,
404 $ one, a( i+kd, i+kd ), lda,
405 $ work( s2pos ), lds2,
406 $ zero, work( wpos ), ldw )
408 CALL zgemm(
'No transpose',
'Conjugate', pk, pk, pn,
409 $ one, work( wpos ), ldw,
410 $ work( s2pos ), lds2,
411 $ zero, work( s1pos ), lds1 )
413 CALL zgemm(
'No transpose',
'No transpose', pk, pn, pk,
414 $ -half, work( s1pos ), lds1,
416 $ one, work( wpos ), ldw )
422 CALL zher2k( uplo,
'Conjugate', pn, pk,
423 $ -one, a( i, i+kd ), lda,
425 $ rone, a( i+kd, i+kd ), lda )
431 lk = min(kd, n-j) + 1
432 CALL zcopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
439 DO 40 i = 1, n - kd, kd
441 pk = min( n-i-kd+1, kd )
445 CALL zgeqrf( pn, kd, a( i+kd, i ), lda,
446 $ tau( i ), work( s2pos ), ls2, iinfo )
451 lk = min( kd, n-j ) + 1
452 CALL zcopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
455 CALL zlaset(
'Upper', pk, pk, zero, one,
456 $ a( i+kd, i ), lda )
460 CALL zlarft(
'Forward',
'Columnwise', pn, pk,
461 $ a( i+kd, i ), lda, tau( i ),
462 $ work( tpos ), ldt )
466 CALL zgemm(
'No transpose',
'No transpose', pn, pk, pk,
467 $ one, a( i+kd, i ), lda,
469 $ zero, work( s2pos ), lds2 )
471 CALL zhemm(
'Left', uplo, pn, pk,
472 $ one, a( i+kd, i+kd ), lda,
473 $ work( s2pos ), lds2,
474 $ zero, work( wpos ), ldw )
476 CALL zgemm(
'Conjugate',
'No transpose', pk, pk, pn,
477 $ one, work( s2pos ), lds2,
479 $ zero, work( s1pos ), lds1 )
481 CALL zgemm(
'No transpose',
'No transpose', pn, pk, pk,
482 $ -half, a( i+kd, i ), lda,
483 $ work( s1pos ), lds1,
484 $ one, work( wpos ), ldw )
490 CALL zher2k( uplo,
'No transpose', pn, pk,
491 $ -one, a( i+kd, i ), lda,
493 $ rone, a( i+kd, i+kd ), lda )
506 lk = min(kd, n-j) + 1
507 CALL zcopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zlarft(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT)
ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
subroutine zhetrd_he2hb(UPLO, N, KD, A, LDA, AB, LDAB, TAU, WORK, LWORK, INFO)
ZHETRD_HE2HB
subroutine zhemm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZHEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
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 zgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGELQF
subroutine zher2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZHER2K