166 SUBROUTINE dlasd8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
167 $ dsigma, work, info )
175 INTEGER icompq, info, k, lddifr
178 DOUBLE PRECISION d( * ), difl( * ), difr( lddifr, * ),
179 $ dsigma( * ), vf( * ), vl( * ), work( * ),
187 parameter( one = 1.0d+0 )
190 INTEGER i, iwk1, iwk2, iwk2i, iwk3, iwk3i,
j
191 DOUBLE PRECISION 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(
'DLASD8', -info )
224 d( 1 ) = abs( z( 1 ) )
226 IF( icompq.EQ.1 )
THEN
251 dsigma( i ) =
dlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
264 rho =
dnrm2( k, z, 1 )
265 CALL
dlascl(
'G', 0, 0, rho, one, k, 1, z, k, info )
270 CALL
dlaset(
'A', k, 1, one, one, work( iwk3 ), k )
276 CALL
dlasd4( k,
j, dsigma, z, work( iwk1 ), rho, d(
j ),
277 $ work( iwk2 ), info )
282 CALL
xerbla(
'DLASD4', -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 ) / (
dlamc3( dsigma( i ), dsigj )-diflj )
321 $ / ( dsigma( i )+dj )
324 work( i ) = z( i ) / (
dlamc3( dsigma( i ), dsigjp )+difrj )
325 $ / ( dsigma( i )+dj )
327 temp =
dnrm2( k, work, 1 )
328 work( iwk2i+
j ) =
ddot( k, work, 1, vf, 1 ) / temp
329 work( iwk3i+
j ) =
ddot( k, work, 1, vl, 1 ) / temp
330 IF( icompq.EQ.1 )
THEN
335 CALL
dcopy( k, work( iwk2 ), 1, vf, 1 )
336 CALL
dcopy( k, work( iwk3 ), 1, vl, 1 )
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 dlasd8(ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO)
DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D...
double precision function dlamc3(A, B)
DLAMC3
double precision function ddot(N, DX, INCX, DY, INCY)
DDOT
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
double precision function dnrm2(N, X, INCX)
DNRM2
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 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...