183 SUBROUTINE sgels( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
193 INTEGER info, lda, ldb, lwork, m, n, nrhs
196 REAL a( lda, * ),
b( ldb, * ), work( * )
203 parameter( zero = 0.0e0, one = 1.0e0 )
207 INTEGER brow, i, iascl, ibscl,
j, mn, nb, scllen, wsize
208 REAL anrm, bignum, bnrm, smlnum
224 INTRINSIC max, min, real
232 lquery = ( lwork.EQ.-1 )
233 IF( .NOT.(
lsame( trans,
'N' ) .OR.
lsame( trans,
'T' ) ) )
THEN
235 ELSE IF( m.LT.0 )
THEN
237 ELSE IF( n.LT.0 )
THEN
239 ELSE IF( nrhs.LT.0 )
THEN
241 ELSE IF( lda.LT.max( 1, m ) )
THEN
243 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
245 ELSE IF( lwork.LT.max( 1, mn + max( mn, nrhs ) ) .AND.
252 IF( info.EQ.0 .OR. info.EQ.-10 )
THEN
255 IF(
lsame( trans,
'N' ) )
259 nb =
ilaenv( 1,
'SGEQRF',
' ', m, n, -1, -1 )
261 nb = max( nb,
ilaenv( 1,
'SORMQR',
'LN', m, nrhs, n,
264 nb = max( nb,
ilaenv( 1,
'SORMQR',
'LT', m, nrhs, n,
268 nb =
ilaenv( 1,
'SGELQF',
' ', m, n, -1, -1 )
270 nb = max( nb,
ilaenv( 1,
'SORMLQ',
'LT', n, nrhs, m,
273 nb = max( nb,
ilaenv( 1,
'SORMLQ',
'LN', n, nrhs, m,
278 wsize = max( 1, mn + max( mn, nrhs )*nb )
279 work( 1 ) =
REAL( wsize )
284 CALL
xerbla(
'SGELS ', -info )
286 ELSE IF( lquery )
THEN
292 IF( min( m, n, nrhs ).EQ.0 )
THEN
293 CALL
slaset(
'Full', max( m, n ), nrhs, zero, zero,
b, ldb )
300 bignum = one / smlnum
301 CALL
slabad( smlnum, bignum )
305 anrm =
slange(
'M', m, n, a, lda, rwork )
307 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
311 CALL
slascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
313 ELSE IF( anrm.GT.bignum )
THEN
317 CALL
slascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
319 ELSE IF( anrm.EQ.zero )
THEN
323 CALL
slaset(
'F', max( m, n ), nrhs, zero, zero,
b, ldb )
330 bnrm =
slange(
'M', brow, nrhs,
b, ldb, rwork )
332 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
336 CALL
slascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs,
b, ldb,
339 ELSE IF( bnrm.GT.bignum )
THEN
343 CALL
slascl(
'G', 0, 0, bnrm, bignum, brow, nrhs,
b, ldb,
352 CALL
sgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
363 CALL
sormqr(
'Left',
'Transpose', m, nrhs, n, a, lda,
364 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
371 CALL
strtrs(
'Upper',
'No transpose',
'Non-unit', n, nrhs,
372 $ a, lda,
b, ldb, info )
386 CALL
strtrs(
'Upper',
'Transpose',
'Non-unit', n, nrhs,
387 $ a, lda,
b, ldb, info )
403 CALL
sormqr(
'Left',
'No transpose', m, nrhs, n, a, lda,
404 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
417 CALL
sgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
428 CALL
strtrs(
'Lower',
'No transpose',
'Non-unit', m, nrhs,
429 $ a, lda,
b, ldb, info )
445 CALL
sormlq(
'Left',
'Transpose', n, nrhs, m, a, lda,
446 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
459 CALL
sormlq(
'Left',
'No transpose', n, nrhs, m, a, lda,
460 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
467 CALL
strtrs(
'Lower',
'Transpose',
'Non-unit', m, nrhs,
468 $ a, lda,
b, ldb, info )
482 IF( iascl.EQ.1 )
THEN
483 CALL
slascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs,
b, ldb,
485 ELSE IF( iascl.EQ.2 )
THEN
486 CALL
slascl(
'G', 0, 0, anrm, bignum, scllen, nrhs,
b, ldb,
489 IF( ibscl.EQ.1 )
THEN
490 CALL
slascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs,
b, ldb,
492 ELSE IF( ibscl.EQ.2 )
THEN
493 CALL
slascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs,
b, ldb,
498 work( 1 ) =
REAL( wsize )
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...
LOGICAL function lsame(CA, CB)
LSAME
subroutine sormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMLQ
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
REAL function slamch(CMACH)
SLAMCH
subroutine sgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
SGELS solves overdetermined or underdetermined systems for GE matrices
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
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 strtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
STRTRS
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
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 sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slabad(SMALL, LARGE)
SLABAD