176 SUBROUTINE sgelsx( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
184 INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
189 REAL A( LDA, * ), B( LDB, * ), WORK( * )
196 parameter( imax = 1, imin = 2 )
197 REAL ZERO, ONE, DONE, NTDONE
198 parameter( zero = 0.0e0, one = 1.0e0, done = zero,
202 INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
203 REAL ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
204 $ smaxpr, smin, sminpr, smlnum, t1, t2
208 EXTERNAL slamch, slange
215 INTRINSIC abs, max, min
228 ELSE IF( n.LT.0 )
THEN
230 ELSE IF( nrhs.LT.0 )
THEN
232 ELSE IF( lda.LT.max( 1, m ) )
THEN
234 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
239 CALL xerbla(
'SGELSX', -info )
245 IF( min( m, n, nrhs ).EQ.0 )
THEN
252 smlnum = slamch(
'S' ) / slamch(
'P' )
253 bignum = one / smlnum
254 CALL slabad( smlnum, bignum )
258 anrm = slange(
'M', m, n, a, lda, work )
260 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
264 CALL slascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
266 ELSE IF( anrm.GT.bignum )
THEN
270 CALL slascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
272 ELSE IF( anrm.EQ.zero )
THEN
276 CALL slaset(
'F', max( m, n ), nrhs, zero, zero, b, ldb )
281 bnrm = slange(
'M', m, nrhs, b, ldb, work )
283 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
287 CALL slascl(
'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info )
289 ELSE IF( bnrm.GT.bignum )
THEN
293 CALL slascl(
'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info )
300 CALL sgeqpf( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ), info )
309 smax = abs( a( 1, 1 ) )
311 IF( abs( a( 1, 1 ) ).EQ.zero )
THEN
313 CALL slaset(
'F', max( m, n ), nrhs, zero, zero, b, ldb )
320 IF( rank.LT.mn )
THEN
322 CALL slaic1( imin, rank, work( ismin ), smin, a( 1, i ),
323 $ a( i, i ), sminpr, s1, c1 )
324 CALL slaic1( imax, rank, work( ismax ), smax, a( 1, i ),
325 $ a( i, i ), smaxpr, s2, c2 )
327 IF( smaxpr*rcond.LE.sminpr )
THEN
329 work( ismin+i-1 ) = s1*work( ismin+i-1 )
330 work( ismax+i-1 ) = s2*work( ismax+i-1 )
332 work( ismin+rank ) = c1
333 work( ismax+rank ) = c2
348 $
CALL stzrqf( rank, n, a, lda, work( mn+1 ), info )
354 CALL sorm2r(
'Left',
'Transpose', m, nrhs, mn, a, lda, work( 1 ),
355 $ b, ldb, work( 2*mn+1 ), info )
361 CALL strsm(
'Left',
'Upper',
'No transpose',
'Non-unit', rank,
362 $ nrhs, one, a, lda, b, ldb )
364 DO 40 i = rank + 1, n
374 CALL slatzm(
'Left', n-rank+1, nrhs, a( i, rank+1 ), lda,
375 $ work( mn+i ), b( i, 1 ), b( rank+1, 1 ), ldb,
386 work( 2*mn+i ) = ntdone
389 IF( work( 2*mn+i ).EQ.ntdone )
THEN
390 IF( jpvt( i ).NE.i )
THEN
393 t2 = b( jpvt( k ), j )
395 b( jpvt( k ), j ) = t1
396 work( 2*mn+k ) = done
399 t2 = b( jpvt( k ), j )
403 work( 2*mn+k ) = done
411 IF( iascl.EQ.1 )
THEN
412 CALL slascl(
'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info )
413 CALL slascl(
'U', 0, 0, smlnum, anrm, rank, rank, a, lda,
415 ELSE IF( iascl.EQ.2 )
THEN
416 CALL slascl(
'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info )
417 CALL slascl(
'U', 0, 0, bignum, anrm, rank, rank, a, lda,
420 IF( ibscl.EQ.1 )
THEN
421 CALL slascl(
'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info )
422 ELSE IF( ibscl.EQ.2 )
THEN
423 CALL slascl(
'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info )
subroutine slabad(SMALL, LARGE)
SLABAD
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 slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgeqpf(M, N, A, LDA, JPVT, TAU, WORK, INFO)
SGEQPF
subroutine sgelsx(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO)
SGELSX solves overdetermined or underdetermined systems for GE matrices
subroutine slaic1(JOB, J, X, SEST, W, GAMMA, SESTPR, S, C)
SLAIC1 applies one step of incremental condition estimation.
subroutine sorm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
subroutine stzrqf(M, N, A, LDA, TAU, INFO)
STZRQF
subroutine slatzm(SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK)
SLATZM
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM