269 SUBROUTINE clals0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
270 $ perm, givptr, givcol, ldgcol, givnum, ldgnum,
271 $ poles, difl, difr, z, k, c, s, rwork, info )
279 INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
280 $ ldgnum, nl, nr, nrhs, sqre
284 INTEGER GIVCOL( ldgcol, * ), PERM( * )
285 REAL DIFL( * ), DIFR( ldgnum, * ),
286 $ givnum( ldgnum, * ), poles( ldgnum, * ),
288 COMPLEX B( ldb, * ), BX( ldbx, * )
294 REAL ONE, ZERO, NEGONE
295 parameter( one = 1.0e0, zero = 0.0e0, negone = -1.0e0 )
298 INTEGER I, J, JCOL, JROW, M, N, NLP1
299 REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
307 EXTERNAL slamc3, snrm2
310 INTRINSIC aimag, cmplx, max, real
318 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) )
THEN
320 ELSE IF( nl.LT.1 )
THEN
322 ELSE IF( nr.LT.1 )
THEN
324 ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) )
THEN
332 ELSE IF( ldb.LT.n )
THEN
334 ELSE IF( ldbx.LT.n )
THEN
336 ELSE IF( givptr.LT.0 )
THEN
338 ELSE IF( ldgcol.LT.n )
THEN
340 ELSE IF( ldgnum.LT.n )
THEN
342 ELSE IF( k.LT.1 )
THEN
346 CALL xerbla(
'CLALS0', -info )
353 IF( icompq.EQ.0 )
THEN
360 CALL csrot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
361 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
367 CALL ccopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
369 CALL ccopy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx )
376 CALL ccopy( nrhs, bx, ldbx, b, ldb )
377 IF( z( 1 ).LT.zero )
THEN
378 CALL csscal( nrhs, negone, b, ldb )
384 dsigj = -poles( j, 2 )
386 difrj = -difr( j, 1 )
387 dsigjp = -poles( j+1, 2 )
389 IF( ( z( j ).EQ.zero ) .OR. ( poles( j, 2 ).EQ.zero ) )
393 rwork( j ) = -poles( j, 2 )*z( j ) / diflj /
394 $ ( poles( j, 2 )+dj )
397 IF( ( z( i ).EQ.zero ) .OR.
398 $ ( poles( i, 2 ).EQ.zero ) )
THEN
401 rwork( i ) = poles( i, 2 )*z( i ) /
402 $ ( slamc3( poles( i, 2 ), dsigj )-
403 $ diflj ) / ( poles( i, 2 )+dj )
407 IF( ( z( i ).EQ.zero ) .OR.
408 $ ( poles( i, 2 ).EQ.zero ) )
THEN
411 rwork( i ) = poles( i, 2 )*z( i ) /
412 $ ( slamc3( poles( i, 2 ), dsigjp )+
413 $ difrj ) / ( poles( i, 2 )+dj )
417 temp = snrm2( k, rwork, 1 )
429 rwork( i ) =
REAL( BX( JROW, JCOL ) )
432 CALL sgemv(
'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
433 $ rwork( 1 ), 1, zero, rwork( 1+k ), 1 )
438 rwork( i ) = aimag( bx( jrow, jcol ) )
441 CALL sgemv(
'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
442 $ rwork( 1 ), 1, zero, rwork( 1+k+nrhs ), 1 )
444 b( j, jcol ) = cmplx( rwork( jcol+k ),
445 $ rwork( jcol+k+nrhs ) )
447 CALL clascl(
'G', 0, 0, temp, one, 1, nrhs, b( j, 1 ),
454 IF( k.LT.max( m, n ) )
455 $
CALL clacpy(
'A', n-k, nrhs, bx( k+1, 1 ), ldbx,
465 CALL ccopy( nrhs, b, ldb, bx, ldbx )
468 dsigj = poles( j, 2 )
469 IF( z( j ).EQ.zero )
THEN
472 rwork( j ) = -z( j ) / difl( j ) /
473 $ ( dsigj+poles( j, 1 ) ) / difr( j, 2 )
476 IF( z( j ).EQ.zero )
THEN
479 rwork( i ) = z( j ) / ( slamc3( dsigj, -poles( i+1,
480 $ 2 ) )-difr( i, 1 ) ) /
481 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
485 IF( z( j ).EQ.zero )
THEN
488 rwork( i ) = z( j ) / ( slamc3( dsigj, -poles( i,
489 $ 2 ) )-difl( i ) ) /
490 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
501 DO 140 jcol = 1, nrhs
504 rwork( i ) =
REAL( B( JROW, JCOL ) )
507 CALL sgemv(
'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
508 $ rwork( 1 ), 1, zero, rwork( 1+k ), 1 )
510 DO 160 jcol = 1, nrhs
513 rwork( i ) = aimag( b( jrow, jcol ) )
516 CALL sgemv(
'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
517 $ rwork( 1 ), 1, zero, rwork( 1+k+nrhs ), 1 )
518 DO 170 jcol = 1, nrhs
519 bx( j, jcol ) = cmplx( rwork( jcol+k ),
520 $ rwork( jcol+k+nrhs ) )
529 CALL ccopy( nrhs, b( m, 1 ), ldb, bx( m, 1 ), ldbx )
530 CALL csrot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
532 IF( k.LT.max( m, n ) )
533 $
CALL clacpy(
'A', n-k, nrhs, b( k+1, 1 ), ldb,
534 $ bx( k+1, 1 ), ldbx )
538 CALL ccopy( nrhs, bx( 1, 1 ), ldbx, b( nlp1, 1 ), ldb )
540 CALL ccopy( nrhs, bx( m, 1 ), ldbx, b( m, 1 ), ldb )
543 CALL ccopy( nrhs, bx( i, 1 ), ldbx, b( perm( i ), 1 ), ldb )
548 DO 200 i = givptr, 1, -1
549 CALL csrot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
550 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
subroutine csrot(N, CX, INCX, CY, INCY, C, S)
CSROT
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine clals0(ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO)
CLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer...
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine csscal(N, SA, CX, INCX)
CSSCAL