166 SUBROUTINE slasd8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
167 $ dsigma, work, info )
175 INTEGER icompq, info, k, lddifr
178 REAL d( * ), difl( * ), difr( lddifr, * ),
179 $ dsigma( * ), vf( * ), vl( * ), work( * ),
187 parameter( one = 1.0e+0 )
190 INTEGER i, iwk1, iwk2, iwk2i, iwk3, iwk3i,
j
191 REAL diflj, difrj, dj, dsigj, dsigjp, rho, temp
201 INTRINSIC abs, sign, sqrt
209 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) )
THEN
211 ELSE IF( k.LT.1 )
THEN
213 ELSE IF( lddifr.LT.k )
THEN
217 CALL
xerbla(
'SLASD8', -info )
224 d( 1 ) = abs( z( 1 ) )
226 IF( icompq.EQ.1 )
THEN
251 dsigma( i ) =
slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
264 rho =
snrm2( k, z, 1 )
265 CALL
slascl(
'G', 0, 0, rho, one, k, 1, z, k, info )
270 CALL
slaset(
'A', k, 1, one, one, work( iwk3 ), k )
276 CALL
slasd4( k,
j, dsigma, z, work( iwk1 ), rho, d(
j ),
277 $ work( iwk2 ), info )
282 CALL
xerbla(
'SLASD4', -info )
285 work( iwk3i+
j ) = work( iwk3i+
j )*work(
j )*work( iwk2i+
j )
286 difl(
j ) = -work(
j )
287 difr(
j, 1 ) = -work(
j+1 )
289 work( iwk3i+i ) = work( iwk3i+i )*work( i )*
290 $ work( iwk2i+i ) / ( dsigma( i )-
291 $ dsigma(
j ) ) / ( dsigma( i )+
295 work( iwk3i+i ) = work( iwk3i+i )*work( i )*
296 $ work( iwk2i+i ) / ( dsigma( i )-
297 $ dsigma(
j ) ) / ( dsigma( i )+
305 z( i ) = sign( sqrt( abs( work( iwk3i+i ) ) ), z( i ) )
315 difrj = -difr(
j, 1 )
316 dsigjp = -dsigma(
j+1 )
318 work(
j ) = -z(
j ) / diflj / ( dsigma(
j )+dj )
320 work( i ) = z( i ) / (
slamc3( dsigma( i ), dsigj )-diflj )
321 $ / ( dsigma( i )+dj )
324 work( i ) = z( i ) / (
slamc3( dsigma( i ), dsigjp )+difrj )
325 $ / ( dsigma( i )+dj )
327 temp =
snrm2( k, work, 1 )
328 work( iwk2i+
j ) =
sdot( k, work, 1, vf, 1 ) / temp
329 work( iwk3i+
j ) =
sdot( k, work, 1, vl, 1 ) / temp
330 IF( icompq.EQ.1 )
THEN
335 CALL
scopy( k, work( iwk2 ), 1, vf, 1 )
336 CALL
scopy( k, work( iwk3 ), 1, vl, 1 )
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 slasd8(ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO)
SLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D...
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.
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 sdot(N, SX, INCX, SY, INCY)
SDOT
REAL function snrm2(N, X, INCX)
SNRM2