268 SUBROUTINE slasd2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
269 $ ldvt, dsigma, u2, ldu2, vt2, ldvt2, idxp, idx,
270 $ idxc, idxq, coltyp, info )
278 INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
282 INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
284 REAL D( * ), DSIGMA( * ), U( ldu, * ),
285 $ u2( ldu2, * ), vt( ldvt, * ), vt2( ldvt2, * ),
292 REAL ZERO, ONE, TWO, EIGHT
293 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
297 INTEGER CTOT( 4 ), PSM( 4 )
300 INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
302 REAL C, EPS, HLFTOL, S, TAU, TOL, Z1
306 EXTERNAL slamch, slapy2
322 ELSE IF( nr.LT.1 )
THEN
324 ELSE IF( ( sqre.NE.1 ) .AND. ( sqre.NE.0 ) )
THEN
333 ELSE IF( ldvt.LT.m )
THEN
335 ELSE IF( ldu2.LT.n )
THEN
337 ELSE IF( ldvt2.LT.m )
THEN
341 CALL
xerbla(
'SLASD2', -info )
351 z1 = alpha*vt( nlp1, nlp1 )
354 z( i+1 ) = alpha*vt( i, nlp1 )
356 idxq( i+1 ) = idxq( i ) + 1
362 z( i ) = beta*vt( i, nlp2 )
377 idxq( i ) = idxq( i ) + nlp1
384 dsigma( i ) = d( idxq( i ) )
385 u2( i, 1 ) = z( idxq( i ) )
386 idxc( i ) = coltyp( idxq( i ) )
389 CALL
slamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) )
393 d( i ) = dsigma( idxi )
394 z( i ) = u2( idxi, 1 )
395 coltyp( i ) = idxc( idxi )
400 eps = slamch(
'Epsilon' )
401 tol = max( abs( alpha ), abs( beta ) )
402 tol = eight*eps*max( abs( d( n ) ), tol )
426 IF( abs( z( j ) ).LE.tol )
THEN
446 IF( abs( z( j ) ).LE.tol )
THEN
457 IF( abs( d( j )-d( jprev ) ).LE.tol )
THEN
476 idxjp = idxq( idx( jprev )+1 )
477 idxj = idxq( idx( j )+1 )
478 IF( idxjp.LE.nlp1 )
THEN
481 IF( idxj.LE.nlp1 )
THEN
484 CALL
srot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s )
485 CALL
srot( m, vt( idxjp, 1 ), ldvt, vt( idxj, 1 ), ldvt, c,
487 IF( coltyp( j ).NE.coltyp( jprev ) )
THEN
496 u2( k, 1 ) = z( jprev )
497 dsigma( k ) = d( jprev )
508 u2( k, 1 ) = z( jprev )
509 dsigma( k ) = d( jprev )
524 ctot( ct ) = ctot( ct ) + 1
530 psm( 2 ) = 2 + ctot( 1 )
531 psm( 3 ) = psm( 2 ) + ctot( 2 )
532 psm( 4 ) = psm( 3 ) + ctot( 3 )
542 idxc( psm( ct ) ) = j
543 psm( ct ) = psm( ct ) + 1
555 dsigma( j ) = d( jp )
556 idxj = idxq( idx( idxp( idxc( j ) ) )+1 )
557 IF( idxj.LE.nlp1 )
THEN
560 CALL
scopy( n, u( 1, idxj ), 1, u2( 1, j ), 1 )
561 CALL
scopy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 )
568 IF( abs( dsigma( 2 ) ).LE.hlftol )
569 $ dsigma( 2 ) = hlftol
571 z( 1 ) = slapy2( z1, z( m ) )
572 IF( z( 1 ).LE.tol )
THEN
581 IF( abs( z1 ).LE.tol )
THEN
590 CALL
scopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 )
595 CALL
slaset(
'A', n, 1, zero, zero, u2, ldu2 )
599 vt( m, i ) = -s*vt( nlp1, i )
600 vt2( 1, i ) = c*vt( nlp1, i )
603 vt2( 1, i ) = s*vt( m, i )
604 vt( m, i ) = c*vt( m, i )
607 CALL
scopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 )
610 CALL
scopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 )
617 CALL
scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 )
618 CALL
slacpy(
'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),
620 CALL
slacpy(
'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),
627 coltyp( j ) = ctot( j )
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 slamrg(N1, N2, A, STRD1, STRD2, INDEX)
SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slasd2(NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO)
SLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc...
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT