178 SUBROUTINE sgelsx( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
187 INTEGER info, lda, ldb, m, n, nrhs, rank
192 REAL a( lda, * ),
b( ldb, * ), work( * )
199 parameter( imax = 1, imin = 2 )
200 REAL zero, one, done, ntdone
201 parameter( zero = 0.0e0, one = 1.0e0, done = zero,
205 INTEGER i, iascl, ibscl, ismax, ismin,
j, k, mn
206 REAL anrm, bignum, bnrm, c1, c2, s1, s2, smax,
207 $ smaxpr, smin, sminpr, smlnum, t1, t2
218 INTRINSIC abs, max, min
231 ELSE IF( n.LT.0 )
THEN
233 ELSE IF( nrhs.LT.0 )
THEN
235 ELSE IF( lda.LT.max( 1, m ) )
THEN
237 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
242 CALL
xerbla(
'SGELSX', -info )
248 IF( min( m, n, nrhs ).EQ.0 )
THEN
256 bignum = one / smlnum
257 CALL
slabad( smlnum, bignum )
261 anrm =
slange(
'M', m, n, a, lda, work )
263 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
267 CALL
slascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
269 ELSE IF( anrm.GT.bignum )
THEN
273 CALL
slascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
275 ELSE IF( anrm.EQ.zero )
THEN
279 CALL
slaset(
'F', max( m, n ), nrhs, zero, zero,
b, ldb )
284 bnrm =
slange(
'M', m, nrhs,
b, ldb, work )
286 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
290 CALL
slascl(
'G', 0, 0, bnrm, smlnum, m, nrhs,
b, ldb, info )
292 ELSE IF( bnrm.GT.bignum )
THEN
296 CALL
slascl(
'G', 0, 0, bnrm, bignum, m, nrhs,
b, ldb, info )
303 CALL
sgeqpf( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ), info )
312 smax = abs( a( 1, 1 ) )
314 IF( abs( a( 1, 1 ) ).EQ.zero )
THEN
316 CALL
slaset(
'F', max( m, n ), nrhs, zero, zero,
b, ldb )
323 IF( rank.LT.mn )
THEN
325 CALL
slaic1( imin, rank, work( ismin ), smin, a( 1, i ),
326 $ a( i, i ), sminpr, s1, c1 )
327 CALL
slaic1( imax, rank, work( ismax ), smax, a( 1, i ),
328 $ a( i, i ), smaxpr, s2, c2 )
330 IF( smaxpr*rcond.LE.sminpr )
THEN
332 work( ismin+i-1 ) = s1*work( ismin+i-1 )
333 work( ismax+i-1 ) = s2*work( ismax+i-1 )
335 work( ismin+rank ) = c1
336 work( ismax+rank ) = c2
351 $ CALL
stzrqf( rank, n, a, lda, work( mn+1 ), info )
357 CALL
sorm2r(
'Left',
'Transpose', m, nrhs, mn, a, lda, work( 1 ),
358 $
b, ldb, work( 2*mn+1 ), info )
364 CALL
strsm(
'Left',
'Upper',
'No transpose',
'Non-unit', rank,
365 $ nrhs, one, a, lda,
b, ldb )
367 DO 40 i = rank + 1, n
377 CALL
slatzm(
'Left', n-rank+1, nrhs, a( i, rank+1 ), lda,
378 $ work( mn+i ),
b( i, 1 ),
b( rank+1, 1 ), ldb,
389 work( 2*mn+i ) = ntdone
392 IF( work( 2*mn+i ).EQ.ntdone )
THEN
393 IF( jpvt( i ).NE.i )
THEN
396 t2 =
b( jpvt( k ),
j )
398 b( jpvt( k ),
j ) = t1
399 work( 2*mn+k ) = done
402 t2 =
b( jpvt( k ),
j )
406 work( 2*mn+k ) = done
414 IF( iascl.EQ.1 )
THEN
415 CALL
slascl(
'G', 0, 0, anrm, smlnum, n, nrhs,
b, ldb, info )
416 CALL
slascl(
'U', 0, 0, smlnum, anrm, rank, rank, a, lda,
418 ELSE IF( iascl.EQ.2 )
THEN
419 CALL
slascl(
'G', 0, 0, anrm, bignum, n, nrhs,
b, ldb, info )
420 CALL
slascl(
'U', 0, 0, bignum, anrm, rank, rank, a, lda,
423 IF( ibscl.EQ.1 )
THEN
424 CALL
slascl(
'G', 0, 0, smlnum, bnrm, n, nrhs,
b, ldb, info )
425 ELSE IF( ibscl.EQ.2 )
THEN
426 CALL
slascl(
'G', 0, 0, bignum, bnrm, n, nrhs,
b, ldb, info )
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...
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
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 stzrqf(M, N, A, LDA, TAU, INFO)
STZRQF
REAL function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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 sgelsx(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO)
SGELSX solves overdetermined or underdetermined systems for GE matrices
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slaic1(JOB, J, X, SEST, W, GAMMA, SESTPR, S, C)
SLAIC1 applies one step of incremental condition estimation.
subroutine sgeqpf(M, N, A, LDA, JPVT, TAU, WORK, INFO)
SGEQPF
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
subroutine slatzm(SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK)
SLATZM