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
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 )
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 dcopy(N, DX, INCX, DY, INCY)
DCOPY
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...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
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...
DOUBLE PRECISION function dlapy2(X, Y)
DLAPY2 returns sqrt(x2+y2).