227 SUBROUTINE claed8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
228 $ q2, ldq2, w, indxp, indx, indxq, perm, givptr,
229 $ givcol, givnum, info )
237 INTEGER cutpnt, givptr, info, k, ldq, ldq2, n, qsiz
241 INTEGER givcol( 2, * ), indx( * ), indxp( * ),
242 $ indxq( * ), perm( * )
243 REAL d( * ), dlamda( * ), givnum( 2, * ), w( * ),
245 COMPLEX q( ldq, * ), q2( ldq2, * )
251 REAL mone, zero, one, two, eight
252 parameter( mone = -1.0e0, zero = 0.0e0, one = 1.0e0,
253 $ two = 2.0e0, eight = 8.0e0 )
256 INTEGER i, imax,
j, jlam, jmax, jp, k2, n1, n1p1, n2
257 REAL c, eps, s, t, tau, tol
269 INTRINSIC abs, max, min, sqrt
279 ELSE IF( qsiz.LT.n )
THEN
281 ELSE IF( ldq.LT.max( 1, n ) )
THEN
283 ELSE IF( cutpnt.LT.min( 1, n ) .OR. cutpnt.GT.n )
THEN
285 ELSE IF( ldq2.LT.max( 1, n ) )
THEN
289 CALL
xerbla(
'CLAED8', -info )
309 IF( rho.LT.zero )
THEN
310 CALL
sscal( n2, mone, z( n1p1 ), 1 )
315 t = one / sqrt( two )
319 CALL
sscal( n, t, z, 1 )
324 DO 20 i = cutpnt + 1, n
325 indxq( i ) = indxq( i ) + cutpnt
328 dlamda( i ) = d( indxq( i ) )
329 w( i ) = z( indxq( i ) )
333 CALL
slamrg( n1, n2, dlamda, 1, 1, indx )
335 d( i ) = dlamda( indx( i ) )
336 z( i ) = w( indx( i ) )
344 tol = eight*eps*abs( d( jmax ) )
350 IF( rho*abs( z( imax ) ).LE.tol )
THEN
353 perm(
j ) = indxq( indx(
j ) )
354 CALL
ccopy( qsiz, q( 1, perm(
j ) ), 1, q2( 1,
j ), 1 )
356 CALL
clacpy(
'A', qsiz, n, q2( 1, 1 ), ldq2, q( 1, 1 ), ldq )
369 IF( rho*abs( z(
j ) ).LE.tol )
THEN
386 IF( rho*abs( z(
j ) ).LE.tol )
THEN
403 t = d(
j ) - d( jlam )
406 IF( abs( t*c*s ).LE.tol )
THEN
416 givcol( 1, givptr ) = indxq( indx( jlam ) )
417 givcol( 2, givptr ) = indxq( indx(
j ) )
418 givnum( 1, givptr ) = c
419 givnum( 2, givptr ) = s
420 CALL
csrot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,
421 $ q( 1, indxq( indx(
j ) ) ), 1, c, s )
422 t = d( jlam )*c*c + d(
j )*s*s
423 d(
j ) = d( jlam )*s*s + d(
j )*c*c
429 IF( d( jlam ).LT.d( indxp( k2+i ) ) )
THEN
430 indxp( k2+i-1 ) = indxp( k2+i )
435 indxp( k2+i-1 ) = jlam
438 indxp( k2+i-1 ) = jlam
444 dlamda( k ) = d( jlam )
456 dlamda( k ) = d( jlam )
468 dlamda(
j ) = d( jp )
469 perm(
j ) = indxq( indx( jp ) )
470 CALL
ccopy( qsiz, q( 1, perm(
j ) ), 1, q2( 1,
j ), 1 )
477 CALL
scopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
478 CALL
clacpy(
'A', qsiz, n-k, q2( 1, k+1 ), ldq2, q( 1, k+1 ),
INTEGER function isamax(N, SX, INCX)
ISAMAX
REAL function slamch(CMACH)
SLAMCH
subroutine csrot(N, CX, INCX, CY, INCY, C, S)
CSROT
REAL function slapy2(X, Y)
SLAPY2 returns sqrt(x2+y2).
subroutine slamrg(N1, N2, A, STRD1, STRD2, INDEX)
SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine claed8(K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO)
CLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matri...
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine sscal(N, SA, SX, INCX)
SSCAL