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
306 DOUBLE PRECISION DLAMC3, DNRM2
307 EXTERNAL dlamc3, dnrm2
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 ),
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
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...
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV