269 SUBROUTINE zlals0( 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
281 DOUBLE PRECISION c, s
284 INTEGER givcol( ldgcol, * ), perm( * )
285 DOUBLE PRECISION difl( * ), difr( ldgnum, * ),
286 $ givnum( ldgnum, * ), poles( ldgnum, * ),
288 COMPLEX*16 b( ldb, * ), bx( ldbx, * )
294 DOUBLE PRECISION one, zero, negone
295 parameter( one = 1.0d0, zero = 0.0d0, negone = -1.0d0 )
298 INTEGER i,
j, jcol, jrow, m, n, nlp1
299 DOUBLE PRECISION diflj, difrj, dj, dsigj, dsigjp, temp
310 INTRINSIC dble, dcmplx, dimag, max
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(
'ZLALS0', -info )
353 IF( icompq.EQ.0 )
THEN
360 CALL
zdrot( nrhs,
b( givcol( i, 2 ), 1 ), ldb,
361 $
b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
367 CALL
zcopy( nrhs,
b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
369 CALL
zcopy( nrhs,
b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx )
376 CALL
zcopy( nrhs, bx, ldbx,
b, ldb )
377 IF( z( 1 ).LT.zero )
THEN
378 CALL
zdscal( 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 $ (
dlamc3( 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 $ (
dlamc3( poles( i, 2 ), dsigjp )+
413 $ difrj ) / ( poles( i, 2 )+dj )
417 temp =
dnrm2( k, rwork, 1 )
429 rwork( i ) = dble( bx( jrow, jcol ) )
432 CALL
dgemv(
'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
433 $ rwork( 1 ), 1, zero, rwork( 1+k ), 1 )
438 rwork( i ) = dimag( bx( jrow, jcol ) )
441 CALL
dgemv(
'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
442 $ rwork( 1 ), 1, zero, rwork( 1+k+nrhs ), 1 )
444 b(
j, jcol ) = dcmplx( rwork( jcol+k ),
445 $ rwork( jcol+k+nrhs ) )
447 CALL
zlascl(
'G', 0, 0, temp, one, 1, nrhs,
b(
j, 1 ),
454 IF( k.LT.max( m, n ) )
455 $ CALL
zlacpy(
'A', n-k, nrhs, bx( k+1, 1 ), ldbx,
465 CALL
zcopy( 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 ) / (
dlamc3( 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 ) / (
dlamc3( dsigj, -poles( i,
489 $ 2 ) )-difl( i ) ) /
490 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
501 DO 140 jcol = 1, nrhs
504 rwork( i ) = dble(
b( jrow, jcol ) )
507 CALL
dgemv(
'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 ) = dimag(
b( jrow, jcol ) )
516 CALL
dgemv(
'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 ) = dcmplx( rwork( jcol+k ),
520 $ rwork( jcol+k+nrhs ) )
529 CALL
zcopy( nrhs,
b( m, 1 ), ldb, bx( m, 1 ), ldbx )
530 CALL
zdrot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
532 IF( k.LT.max( m, n ) )
533 $ CALL
zlacpy(
'A', n-k, nrhs,
b( k+1, 1 ), ldb, bx( k+1, 1 ),
538 CALL
zcopy( nrhs, bx( 1, 1 ), ldbx,
b( nlp1, 1 ), ldb )
540 CALL
zcopy( nrhs, bx( m, 1 ), ldbx,
b( m, 1 ), ldb )
543 CALL
zcopy( nrhs, bx( i, 1 ), ldbx,
b( perm( i ), 1 ), ldb )
548 DO 200 i = givptr, 1, -1
549 CALL
zdrot( nrhs,
b( givcol( i, 2 ), 1 ), ldb,
550 $
b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
DOUBLE PRECISION function dlamc3(A, B)
DLAMC3
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zdrot(N, CX, INCX, CY, INCY, C, S)
ZDROT
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zlals0(ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO)
ZLALS0 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
DOUBLE PRECISION function dnrm2(N, X, INCX)
DNRM2
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV