243 SUBROUTINE ssytrd_sy2sb( UPLO, N, KD, A, LDA, AB, LDAB, TAU,
244 $ work, lwork, info )
255 INTEGER INFO, LDA, LDAB, LWORK, N, KD
258 REAL A( lda, * ), AB( ldab, * ),
259 $ tau( * ), work( * )
267 parameter ( rone = 1.0e+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,
'SSYTRD_SY2SB',
'', 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(
'SSYTRD_SY2SB', -info )
318 ELSE IF( lquery )
THEN
330 CALL scopy( 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 scopy( lk, a( i, i ), 1, ab( 1, i ), 1 )
350 ls2 = lwmin - lt - lw - ls1
368 CALL slaset(
"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 sgelqf( kd, pn, a( i, i+kd ), lda,
378 $ tau( i ), work( s2pos ), ls2, iinfo )
383 lk = min( kd, n-j ) + 1
384 CALL scopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
387 CALL slaset(
'Lower', pk, pk, zero, one,
388 $ a( i, i+kd ), lda )
392 CALL slarft(
'Forward',
'Rowwise', pn, pk,
393 $ a( i, i+kd ), lda, tau( i ),
394 $ work( tpos ), ldt )
398 CALL sgemm(
'Conjugate',
'No transpose', pk, pn, pk,
399 $ one, work( tpos ), ldt,
401 $ zero, work( s2pos ), lds2 )
403 CALL ssymm(
'Right', uplo, pk, pn,
404 $ one, a( i+kd, i+kd ), lda,
405 $ work( s2pos ), lds2,
406 $ zero, work( wpos ), ldw )
408 CALL sgemm(
'No transpose',
'Conjugate', pk, pk, pn,
409 $ one, work( wpos ), ldw,
410 $ work( s2pos ), lds2,
411 $ zero, work( s1pos ), lds1 )
413 CALL sgemm(
'No transpose',
'No transpose', pk, pn, pk,
414 $ -half, work( s1pos ), lds1,
416 $ one, work( wpos ), ldw )
422 CALL ssyr2k( 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 scopy( 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 sgeqrf( pn, kd, a( i+kd, i ), lda,
446 $ tau( i ), work( s2pos ), ls2, iinfo )
451 lk = min( kd, n-j ) + 1
452 CALL scopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
455 CALL slaset(
'Upper', pk, pk, zero, one,
456 $ a( i+kd, i ), lda )
460 CALL slarft(
'Forward',
'Columnwise', pn, pk,
461 $ a( i+kd, i ), lda, tau( i ),
462 $ work( tpos ), ldt )
466 CALL sgemm(
'No transpose',
'No transpose', pn, pk, pk,
467 $ one, a( i+kd, i ), lda,
469 $ zero, work( s2pos ), lds2 )
471 CALL ssymm(
'Left', uplo, pn, pk,
472 $ one, a( i+kd, i+kd ), lda,
473 $ work( s2pos ), lds2,
474 $ zero, work( wpos ), ldw )
476 CALL sgemm(
'Conjugate',
'No transpose', pk, pk, pn,
477 $ one, work( s2pos ), lds2,
479 $ zero, work( s1pos ), lds1 )
481 CALL sgemm(
'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 ssyr2k( 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 scopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
subroutine slarft(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT)
SLARFT forms the triangular factor T of a block reflector H = I - vtvH
subroutine ssytrd_sy2sb(UPLO, N, KD, A, LDA, AB, LDAB, TAU, WORK, LWORK, INFO)
SSYTRD_SY2SB
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ssyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYR2K
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine ssymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYMM
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF