268 SUBROUTINE dlasd2( 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
279 DOUBLE PRECISION ALPHA, BETA
282 INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
284 DOUBLE PRECISION D( * ), DSIGMA( * ), U( ldu, * ),
285 $ u2( ldu2, * ), vt( ldvt, * ), vt2( ldvt2, * ),
292 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT
293 parameter ( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
297 INTEGER CTOT( 4 ), PSM( 4 )
300 INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
302 DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1
305 DOUBLE PRECISION DLAMCH, DLAPY2
306 EXTERNAL dlamch, dlapy2
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(
'DLASD2', -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 dlamrg( 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 = dlamch(
'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 drot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s )
485 CALL drot( 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 dcopy( n, u( 1, idxj ), 1, u2( 1, j ), 1 )
561 CALL dcopy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 )
568 IF( abs( dsigma( 2 ) ).LE.hlftol )
569 $ dsigma( 2 ) = hlftol
571 z( 1 ) = dlapy2( z1, z( m ) )
572 IF( z( 1 ).LE.tol )
THEN
581 IF( abs( z1 ).LE.tol )
THEN
590 CALL dcopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 )
595 CALL dlaset(
'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 dcopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 )
610 CALL dcopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 )
617 CALL dcopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 )
618 CALL dlacpy(
'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),
620 CALL dlacpy(
'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),
627 coltyp( j ) = ctot( j )
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dlamrg(N1, N2, A, DTRD1, DTRD2, INDEX)
DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlasd2(NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO)
DLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc...