278 SUBROUTINE slasd7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
279 $ vlw, alpha, beta, dsigma, idx, idxp, idxq,
280 $ perm, givptr, givcol, ldgcol, givnum, ldgnum,
289 INTEGER givptr, icompq, info, k, ldgcol, ldgnum, nl,
291 REAL alpha, beta, c, s
294 INTEGER givcol( ldgcol, * ), idx( * ), idxp( * ),
295 $ idxq( * ), perm( * )
296 REAL d( * ), dsigma( * ), givnum( ldgnum, * ),
297 $ vf( * ), vfw( * ), vl( * ), vlw( * ), z( * ),
304 REAL zero, one, two, eight
305 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
310 INTEGER i, idxi, idxj, idxjp,
j, jp, jprev, k2, m, n,
312 REAL eps, hlftol, tau, tol, z1
332 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) )
THEN
334 ELSE IF( nl.LT.1 )
THEN
336 ELSE IF( nr.LT.1 )
THEN
338 ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) )
THEN
340 ELSE IF( ldgcol.LT.n )
THEN
342 ELSE IF( ldgnum.LT.n )
THEN
346 CALL
xerbla(
'SLASD7', -info )
352 IF( icompq.EQ.1 )
THEN
359 z1 = alpha*vl( nlp1 )
363 z( i+1 ) = alpha*vl( i )
367 idxq( i+1 ) = idxq( i ) + 1
374 z( i ) = beta*vf( i )
381 idxq( i ) = idxq( i ) + nlp1
387 dsigma( i ) = d( idxq( i ) )
388 zw( i ) = z( idxq( i ) )
389 vfw( i ) = vf( idxq( i ) )
390 vlw( i ) = vl( idxq( i ) )
393 CALL
slamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) )
397 d( i ) = dsigma( idxi )
399 vf( i ) = vfw( idxi )
400 vl( i ) = vlw( idxi )
406 tol = max( abs( alpha ), abs( beta ) )
407 tol = eight*eight*eps*max( abs( d( n ) ), tol )
431 IF( abs( z(
j ) ).LE.tol )
THEN
450 IF( abs( z(
j ) ).LE.tol )
THEN
460 IF( abs( d(
j )-d( jprev ) ).LE.tol )
THEN
478 IF( icompq.EQ.1 )
THEN
480 idxjp = idxq( idx( jprev )+1 )
481 idxj = idxq( idx(
j )+1 )
482 IF( idxjp.LE.nlp1 )
THEN
485 IF( idxj.LE.nlp1 )
THEN
488 givcol( givptr, 2 ) = idxjp
489 givcol( givptr, 1 ) = idxj
490 givnum( givptr, 2 ) = c
491 givnum( givptr, 1 ) = s
493 CALL
srot( 1, vf( jprev ), 1, vf(
j ), 1, c, s )
494 CALL
srot( 1, vl( jprev ), 1, vl(
j ), 1, c, s )
501 dsigma( k ) = d( jprev )
513 dsigma( k ) = d( jprev )
524 dsigma(
j ) = d( jp )
528 IF( icompq.EQ.1 )
THEN
531 perm(
j ) = idxq( idx( jp )+1 )
532 IF( perm(
j ).LE.nlp1 )
THEN
533 perm(
j ) = perm(
j ) - 1
541 CALL
scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 )
548 IF( abs( dsigma( 2 ) ).LE.hlftol )
549 $ dsigma( 2 ) = hlftol
551 z( 1 ) =
slapy2( z1, z( m ) )
552 IF( z( 1 ).LE.tol )
THEN
560 CALL
srot( 1, vf( m ), 1, vf( 1 ), 1, c, s )
561 CALL
srot( 1, vl( m ), 1, vl( 1 ), 1, c, s )
563 IF( abs( z1 ).LE.tol )
THEN
572 CALL
scopy( k-1, zw( 2 ), 1, z( 2 ), 1 )
573 CALL
scopy( n-1, vfw( 2 ), 1, vf( 2 ), 1 )
574 CALL
scopy( n-1, vlw( 2 ), 1, vl( 2 ), 1 )
subroutine slasd7(ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO)
SLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to def...
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
real function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
real function slapy2(X, Y)
SLAPY2 returns sqrt(x2+y2).
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT