224 SUBROUTINE slasd3( 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 REAL d( * ), dsigma( * ), q( ldq, * ), u( ldu, * ),
240 $ u2( ldu2, * ), vt( ldvt, * ), vt2( ldvt2, * ),
247 REAL one, zero, negone
248 parameter( one = 1.0e+0, zero = 0.0e+0,
252 INTEGER ctemp, i,
j, jc, ktemp, m, n, nlp1, nlp2, nrp1
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(
'SLASD3', -info )
305 d( 1 ) = abs( z( 1 ) )
306 CALL
scopy( m, vt2( 1, 1 ), ldvt2, vt( 1, 1 ), ldvt )
307 IF( z( 1 ).GT.zero )
THEN
308 CALL
scopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 )
311 u( i, 1 ) = -u2( i, 1 )
335 dsigma( i ) =
slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
340 CALL
scopy( k, z, 1, q, 1 )
344 rho =
snrm2( k, z, 1 )
345 CALL
slascl(
'G', 0, 0, rho, one, k, 1, z, k, info )
351 CALL
slasd4( 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 =
snrm2( k, u( 1, i ), 1 )
389 q( 1, i ) = u( 1, i ) / temp
392 q(
j, i ) = u( jc, i ) / temp
399 CALL
sgemm(
'N',
'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,
403 IF( ctot( 1 ).GT.0 )
THEN
404 CALL
sgemm(
'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
sgemm(
'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
sgemm(
'N',
'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),
414 $ ldu2, q( ktemp, 1 ), ldq, zero, u( 1, 1 ), ldu )
416 CALL
slacpy(
'F', nl, k, u2, ldu2, u, ldu )
418 CALL
scopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu )
419 ktemp = 2 + ctot( 1 )
420 ctemp = ctot( 2 ) + ctot( 3 )
421 CALL
sgemm(
'N',
'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,
422 $ q( ktemp, 1 ), ldq, zero, u( nlp2, 1 ), ldu )
428 temp =
snrm2( k, vt( 1, i ), 1 )
429 q( i, 1 ) = vt( 1, i ) / temp
432 q( i,
j ) = vt( jc, i ) / temp
439 CALL
sgemm(
'N',
'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,
443 ktemp = 1 + ctot( 1 )
444 CALL
sgemm(
'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
sgemm(
'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
sgemm(
'N',
'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,
464 $ vt2( ktemp, nlp2 ), ldvt2, zero, vt( 1, nlp2 ), ldvt )
REAL function slamc3(A, B)
SLAMC3
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine slasd3(NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO)
SLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slasd4(N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO)
SLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modif...
REAL function snrm2(N, X, INCX)
SNRM2