224 SUBROUTINE dlasd3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
225 $ ldu2, vt, ldvt, vt2, ldvt2, idxc, ctot, z,
234 INTEGER info, k, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr,
238 INTEGER ctot( * ), idxc( * )
239 DOUBLE PRECISION d( * ), dsigma( * ), q( ldq, * ), u( ldu, * ),
240 $ u2( ldu2, * ), vt( ldvt, * ), vt2( ldvt2, * ),
247 DOUBLE PRECISION one, zero, negone
248 parameter( one = 1.0d+0, zero = 0.0d+0,
252 INTEGER ctemp, i,
j, jc, ktemp, m, n, nlp1, nlp2, nrp1
253 DOUBLE PRECISION rho, temp
263 INTRINSIC abs, sign, sqrt
273 ELSE IF( nr.LT.1 )
THEN
275 ELSE IF( ( sqre.NE.1 ) .AND. ( sqre.NE.0 ) )
THEN
284 IF( ( k.LT.1 ) .OR. ( k.GT.n ) )
THEN
286 ELSE IF( ldq.LT.k )
THEN
288 ELSE IF( ldu.LT.n )
THEN
290 ELSE IF( ldu2.LT.n )
THEN
292 ELSE IF( ldvt.LT.m )
THEN
294 ELSE IF( ldvt2.LT.m )
THEN
298 CALL
xerbla(
'DLASD3', -info )
305 d( 1 ) = abs( z( 1 ) )
306 CALL
dcopy( m, vt2( 1, 1 ), ldvt2, vt( 1, 1 ), ldvt )
307 IF( z( 1 ).GT.zero )
THEN
308 CALL
dcopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 )
311 u( i, 1 ) = -u2( i, 1 )
335 dsigma( i ) =
dlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
340 CALL
dcopy( k, z, 1, q, 1 )
344 rho =
dnrm2( k, z, 1 )
345 CALL
dlascl(
'G', 0, 0, rho, one, k, 1, z, k, info )
351 CALL
dlasd4( k,
j, dsigma, z, u( 1,
j ), rho, d(
j ),
364 z( i ) = u( i, k )*vt( i, k )
366 z( i ) = z( i )*( u( i,
j )*vt( i,
j ) /
367 $ ( dsigma( i )-dsigma(
j ) ) /
368 $ ( dsigma( i )+dsigma(
j ) ) )
371 z( i ) = z( i )*( u( i,
j )*vt( i,
j ) /
372 $ ( dsigma( i )-dsigma(
j+1 ) ) /
373 $ ( dsigma( i )+dsigma(
j+1 ) ) )
375 z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1 ) )
382 vt( 1, i ) = z( 1 ) / u( 1, i ) / vt( 1, i )
385 vt(
j, i ) = z(
j ) / u(
j, i ) / vt(
j, i )
386 u(
j, i ) = dsigma(
j )*vt(
j, i )
388 temp =
dnrm2( k, u( 1, i ), 1 )
389 q( 1, i ) = u( 1, i ) / temp
392 q(
j, i ) = u( jc, i ) / temp
399 CALL
dgemm(
'N',
'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,
403 IF( ctot( 1 ).GT.0 )
THEN
404 CALL
dgemm(
'N',
'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,
405 $ q( 2, 1 ), ldq, zero, u( 1, 1 ), ldu )
406 IF( ctot( 3 ).GT.0 )
THEN
407 ktemp = 2 + ctot( 1 ) + ctot( 2 )
408 CALL
dgemm(
'N',
'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),
409 $ ldu2, q( ktemp, 1 ), ldq, one, u( 1, 1 ), ldu )
411 ELSE IF( ctot( 3 ).GT.0 )
THEN
412 ktemp = 2 + ctot( 1 ) + ctot( 2 )
413 CALL
dgemm(
'N',
'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),
414 $ ldu2, q( ktemp, 1 ), ldq, zero, u( 1, 1 ), ldu )
416 CALL
dlacpy(
'F', nl, k, u2, ldu2, u, ldu )
418 CALL
dcopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu )
419 ktemp = 2 + ctot( 1 )
420 ctemp = ctot( 2 ) + ctot( 3 )
421 CALL
dgemm(
'N',
'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,
422 $ q( ktemp, 1 ), ldq, zero, u( nlp2, 1 ), ldu )
428 temp =
dnrm2( k, vt( 1, i ), 1 )
429 q( i, 1 ) = vt( 1, i ) / temp
432 q( i,
j ) = vt( jc, i ) / temp
439 CALL
dgemm(
'N',
'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,
443 ktemp = 1 + ctot( 1 )
444 CALL
dgemm(
'N',
'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,
445 $ vt2( 1, 1 ), ldvt2, zero, vt( 1, 1 ), ldvt )
446 ktemp = 2 + ctot( 1 ) + ctot( 2 )
448 $ CALL
dgemm(
'N',
'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),
449 $ ldq, vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ),
452 ktemp = ctot( 1 ) + 1
454 IF( ktemp.GT.1 )
THEN
456 q( i, ktemp ) = q( i, 1 )
459 vt2( ktemp, i ) = vt2( 1, i )
462 ctemp = 1 + ctot( 2 ) + ctot( 3 )
463 CALL
dgemm(
'N',
'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,
464 $ vt2( ktemp, nlp2 ), ldvt2, zero, vt( 1, nlp2 ), ldvt )
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine dlasd3(NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO)
DLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and...
double precision function dlamc3(A, B)
DLAMC3
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
double precision function dnrm2(N, X, INCX)
DNRM2
subroutine dlasd4(N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO)
DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modif...