265 SUBROUTINE slals0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
266 $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
267 $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
274 INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
275 $ LDGNUM, NL, NR, NRHS, SQRE
279 INTEGER GIVCOL( LDGCOL, * ), PERM( * )
280 REAL B( LDB, * ), BX( LDBX, * ), DIFL( * ),
281 $ difr( ldgnum, * ), givnum( ldgnum, * ),
282 $ poles( ldgnum, * ), work( * ), z( * )
288 REAL ONE, ZERO, NEGONE
289 PARAMETER ( ONE = 1.0e0, zero = 0.0e0, negone = -1.0e0 )
292 INTEGER I, J, M, N, NLP1
293 REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
301 EXTERNAL SLAMC3, SNRM2
313 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) )
THEN
315 ELSE IF( nl.LT.1 )
THEN
317 ELSE IF( nr.LT.1 )
THEN
319 ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) )
THEN
321 ELSE IF( nrhs.LT.1 )
THEN
323 ELSE IF( ldb.LT.n )
THEN
325 ELSE IF( ldbx.LT.n )
THEN
327 ELSE IF( givptr.LT.0 )
THEN
329 ELSE IF( ldgcol.LT.n )
THEN
331 ELSE IF( ldgnum.LT.n )
THEN
333 ELSE IF( k.LT.1 )
THEN
337 CALL xerbla(
'SLALS0', -info )
344 IF( icompq.EQ.0 )
THEN
351 CALL srot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
352 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
358 CALL scopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
360 CALL scopy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx )
367 CALL scopy( nrhs, bx, ldbx, b, ldb )
368 IF( z( 1 ).LT.zero )
THEN
369 CALL sscal( nrhs, negone, b, ldb )
375 dsigj = -poles( j, 2 )
377 difrj = -difr( j, 1 )
378 dsigjp = -poles( j+1, 2 )
380 IF( ( z( j ).EQ.zero ) .OR. ( poles( j, 2 ).EQ.zero ) )
384 work( j ) = -poles( j, 2 )*z( j ) / diflj /
385 $ ( poles( j, 2 )+dj )
388 IF( ( z( i ).EQ.zero ) .OR.
389 $ ( poles( i, 2 ).EQ.zero ) )
THEN
392 work( i ) = poles( i, 2 )*z( i ) /
393 $ ( slamc3( poles( i, 2 ), dsigj )-
394 $ diflj ) / ( poles( i, 2 )+dj )
398 IF( ( z( i ).EQ.zero ) .OR.
399 $ ( poles( i, 2 ).EQ.zero ) )
THEN
402 work( i ) = poles( i, 2 )*z( i ) /
403 $ ( slamc3( poles( i, 2 ), dsigjp )+
404 $ difrj ) / ( poles( i, 2 )+dj )
408 temp = snrm2( k, work, 1 )
409 CALL sgemv(
'T', k, nrhs, one, bx, ldbx, work, 1, zero,
411 CALL slascl(
'G', 0, 0, temp, one, 1, nrhs, b( j, 1 ),
418 IF( k.LT.max( m, n ) )
419 $
CALL slacpy(
'A', n-k, nrhs, bx( k+1, 1 ), ldbx,
429 CALL scopy( nrhs, b, ldb, bx, ldbx )
432 dsigj = poles( j, 2 )
433 IF( z( j ).EQ.zero )
THEN
436 work( j ) = -z( j ) / difl( j ) /
437 $ ( dsigj+poles( j, 1 ) ) / difr( j, 2 )
440 IF( z( j ).EQ.zero )
THEN
443 work( i ) = z( j ) / ( slamc3( dsigj, -poles( i+1,
444 $ 2 ) )-difr( i, 1 ) ) /
445 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
449 IF( z( j ).EQ.zero )
THEN
452 work( i ) = z( j ) / ( slamc3( dsigj, -poles( i,
453 $ 2 ) )-difl( i ) ) /
454 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
457 CALL sgemv(
'T', k, nrhs, one, b, ldb, work, 1, zero,
466 CALL scopy( nrhs, b( m, 1 ), ldb, bx( m, 1 ), ldbx )
467 CALL srot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
469 IF( k.LT.max( m, n ) )
470 $
CALL slacpy(
'A', n-k, nrhs, b( k+1, 1 ), ldb, bx( k+1, 1 ),
475 CALL scopy( nrhs, bx( 1, 1 ), ldbx, b( nlp1, 1 ), ldb )
477 CALL scopy( nrhs, bx( m, 1 ), ldbx, b( m, 1 ), ldb )
480 CALL scopy( nrhs, bx( i, 1 ), ldbx, b( perm( i ), 1 ), ldb )
485 DO 100 i = givptr, 1, -1
486 CALL srot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
487 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
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 xerbla(SRNAME, INFO)
XERBLA
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...
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV