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
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
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 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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine csscal(N, SA, CX, INCX)
CSSCAL
REAL function snrm2(N, X, INCX)
SNRM2