242 $ WORK, LWORK, INFO )
252 INTEGER INFO, LDA, LDAB, LWORK, N, KD
255 REAL A( LDA, * ), AB( LDAB, * ),
256 $ tau( * ), work( * )
264 parameter( rone = 1.0e+0,
270 LOGICAL LQUERY, UPPER
271 INTEGER I, J, IINFO, LWMIN, PN, PK, LK,
272 $ ldt, ldw, lds2, lds1,
274 $ tpos, wpos, s2pos, s1pos
286 EXTERNAL lsame, ilaenv2stage
294 upper = lsame( uplo,
'U' )
295 lquery = ( lwork.EQ.-1 )
296 lwmin = ilaenv2stage( 4,
'SSYTRD_SY2SB',
'', n, kd, -1, -1 )
298 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
300 ELSE IF( n.LT.0 )
THEN
302 ELSE IF( kd.LT.0 )
THEN
304 ELSE IF( lda.LT.max( 1, n ) )
THEN
306 ELSE IF( ldab.LT.max( 1, kd+1 ) )
THEN
308 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
313 CALL xerbla(
'SSYTRD_SY2SB', -info )
315 ELSE IF( lquery )
THEN
327 CALL scopy( lk, a( i-lk+1, i ), 1,
328 $ ab( kd+1-lk+1, i ), 1 )
332 lk = min( kd+1, n-i+1 )
333 CALL scopy( lk, a( i, i ), 1, ab( 1, i ), 1 )
347 ls2 = lwmin - lt - lw - ls1
365 CALL slaset(
"A", ldt, kd, zero, zero, work( tpos ), ldt )
368 DO 10 i = 1, n - kd, kd
370 pk = min( n-i-kd+1, kd )
374 CALL sgelqf( kd, pn, a( i, i+kd ), lda,
375 $ tau( i ), work( s2pos ), ls2, iinfo )
380 lk = min( kd, n-j ) + 1
381 CALL scopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
384 CALL slaset(
'Lower', pk, pk, zero, one,
385 $ a( i, i+kd ), lda )
389 CALL slarft(
'Forward',
'Rowwise', pn, pk,
390 $ a( i, i+kd ), lda, tau( i ),
391 $ work( tpos ), ldt )
395 CALL sgemm(
'Conjugate',
'No transpose', pk, pn, pk,
396 $ one, work( tpos ), ldt,
398 $ zero, work( s2pos ), lds2 )
400 CALL ssymm(
'Right', uplo, pk, pn,
401 $ one, a( i+kd, i+kd ), lda,
402 $ work( s2pos ), lds2,
403 $ zero, work( wpos ), ldw )
405 CALL sgemm(
'No transpose',
'Conjugate', pk, pk, pn,
406 $ one, work( wpos ), ldw,
407 $ work( s2pos ), lds2,
408 $ zero, work( s1pos ), lds1 )
410 CALL sgemm(
'No transpose',
'No transpose', pk, pn, pk,
411 $ -half, work( s1pos ), lds1,
413 $ one, work( wpos ), ldw )
419 CALL ssyr2k( uplo,
'Conjugate', pn, pk,
420 $ -one, a( i, i+kd ), lda,
422 $ rone, a( i+kd, i+kd ), lda )
428 lk = min(kd, n-j) + 1
429 CALL scopy( lk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
436 DO 40 i = 1, n - kd, kd
438 pk = min( n-i-kd+1, kd )
442 CALL sgeqrf( pn, kd, a( i+kd, i ), lda,
443 $ tau( i ), work( s2pos ), ls2, iinfo )
448 lk = min( kd, n-j ) + 1
449 CALL scopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
452 CALL slaset(
'Upper', pk, pk, zero, one,
453 $ a( i+kd, i ), lda )
457 CALL slarft(
'Forward',
'Columnwise', pn, pk,
458 $ a( i+kd, i ), lda, tau( i ),
459 $ work( tpos ), ldt )
463 CALL sgemm(
'No transpose',
'No transpose', pn, pk, pk,
464 $ one, a( i+kd, i ), lda,
466 $ zero, work( s2pos ), lds2 )
468 CALL ssymm(
'Left', uplo, pn, pk,
469 $ one, a( i+kd, i+kd ), lda,
470 $ work( s2pos ), lds2,
471 $ zero, work( wpos ), ldw )
473 CALL sgemm(
'Conjugate',
'No transpose', pk, pk, pn,
474 $ one, work( s2pos ), lds2,
476 $ zero, work( s1pos ), lds1 )
478 CALL sgemm(
'No transpose',
'No transpose', pn, pk, pk,
479 $ -half, a( i+kd, i ), lda,
480 $ work( s1pos ), lds1,
481 $ one, work( wpos ), ldw )
487 CALL ssyr2k( uplo,
'No transpose', pn, pk,
488 $ -one, a( i+kd, i ), lda,
490 $ rone, a( i+kd, i+kd ), lda )
503 lk = min(kd, n-j) + 1
504 CALL scopy( lk, a( j, j ), 1, ab( 1, j ), 1 )
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 xerbla(SRNAME, INFO)
XERBLA
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
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 scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine ssyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYR2K
subroutine ssymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYMM
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM