267 SUBROUTINE slals0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
268 $ perm, givptr, givcol, ldgcol, givnum, ldgnum,
269 $ poles, difl, difr, z, k, c, s, work, info )
277 INTEGER givptr, icompq, info, k, ldb, ldbx, ldgcol,
278 $ ldgnum, nl, nr, nrhs, sqre
282 INTEGER givcol( ldgcol, * ), perm( * )
283 REAL b( ldb, * ), bx( ldbx, * ), difl( * ),
284 $ difr( ldgnum, * ), givnum( ldgnum, * ),
285 $ poles( ldgnum, * ), work( * ), z( * )
291 REAL one, zero, negone
292 parameter( one = 1.0e0, zero = 0.0e0, negone = -1.0e0 )
295 INTEGER i,
j, m, n, nlp1
296 REAL diflj, difrj, dj, dsigj, dsigjp, temp
315 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) )
THEN
317 ELSE IF( nl.LT.1 )
THEN
319 ELSE IF( nr.LT.1 )
THEN
321 ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) )
THEN
329 ELSE IF( ldb.LT.n )
THEN
331 ELSE IF( ldbx.LT.n )
THEN
333 ELSE IF( givptr.LT.0 )
THEN
335 ELSE IF( ldgcol.LT.n )
THEN
337 ELSE IF( ldgnum.LT.n )
THEN
339 ELSE IF( k.LT.1 )
THEN
343 CALL
xerbla(
'SLALS0', -info )
350 IF( icompq.EQ.0 )
THEN
357 CALL
srot( nrhs,
b( givcol( i, 2 ), 1 ), ldb,
358 $
b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
364 CALL
scopy( nrhs,
b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
366 CALL
scopy( nrhs,
b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx )
373 CALL
scopy( nrhs, bx, ldbx,
b, ldb )
374 IF( z( 1 ).LT.zero )
THEN
375 CALL
sscal( nrhs, negone,
b, ldb )
381 dsigj = -poles(
j, 2 )
383 difrj = -difr(
j, 1 )
384 dsigjp = -poles(
j+1, 2 )
386 IF( ( z(
j ).EQ.zero ) .OR. ( poles(
j, 2 ).EQ.zero ) )
390 work(
j ) = -poles(
j, 2 )*z(
j ) / diflj /
391 $ ( poles(
j, 2 )+dj )
394 IF( ( z( i ).EQ.zero ) .OR.
395 $ ( poles( i, 2 ).EQ.zero ) )
THEN
398 work( i ) = poles( i, 2 )*z( i ) /
399 $ (
slamc3( poles( i, 2 ), dsigj )-
400 $ diflj ) / ( poles( i, 2 )+dj )
404 IF( ( z( i ).EQ.zero ) .OR.
405 $ ( poles( i, 2 ).EQ.zero ) )
THEN
408 work( i ) = poles( i, 2 )*z( i ) /
409 $ (
slamc3( poles( i, 2 ), dsigjp )+
410 $ difrj ) / ( poles( i, 2 )+dj )
414 temp =
snrm2( k, work, 1 )
415 CALL
sgemv(
'T', k, nrhs, one, bx, ldbx, work, 1, zero,
417 CALL
slascl(
'G', 0, 0, temp, one, 1, nrhs,
b(
j, 1 ),
424 IF( k.LT.max( m, n ) )
425 $ CALL
slacpy(
'A', n-k, nrhs, bx( k+1, 1 ), ldbx,
435 CALL
scopy( nrhs,
b, ldb, bx, ldbx )
438 dsigj = poles(
j, 2 )
439 IF( z(
j ).EQ.zero )
THEN
442 work(
j ) = -z(
j ) / difl(
j ) /
443 $ ( dsigj+poles(
j, 1 ) ) / difr(
j, 2 )
446 IF( z(
j ).EQ.zero )
THEN
449 work( i ) = z(
j ) / (
slamc3( dsigj, -poles( i+1,
450 $ 2 ) )-difr( i, 1 ) ) /
451 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
455 IF( z(
j ).EQ.zero )
THEN
458 work( i ) = z(
j ) / (
slamc3( dsigj, -poles( i,
459 $ 2 ) )-difl( i ) ) /
460 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
463 CALL
sgemv(
'T', k, nrhs, one,
b, ldb, work, 1, zero,
472 CALL
scopy( nrhs,
b( m, 1 ), ldb, bx( m, 1 ), ldbx )
473 CALL
srot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
475 IF( k.LT.max( m, n ) )
476 $ CALL
slacpy(
'A', n-k, nrhs,
b( k+1, 1 ), ldb, bx( k+1, 1 ),
481 CALL
scopy( nrhs, bx( 1, 1 ), ldbx,
b( nlp1, 1 ), ldb )
483 CALL
scopy( nrhs, bx( m, 1 ), ldbx,
b( m, 1 ), ldb )
486 CALL
scopy( nrhs, bx( i, 1 ), ldbx,
b( perm( i ), 1 ), ldb )
491 DO 100 i = givptr, 1, -1
492 CALL
srot( nrhs,
b( givcol( i, 2 ), 1 ), ldb,
493 $
b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
REAL function slamc3(A, B)
SLAMC3
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
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 slals0(ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO)
SLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
REAL function snrm2(N, X, INCX)
SNRM2
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT