181 SUBROUTINE sgels( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
190 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
193 REAL A( LDA, * ), B( LDB, * ), WORK( * )
200 parameter( zero = 0.0e0, one = 1.0e0 )
204 INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
205 REAL ANRM, BIGNUM, BNRM, SMLNUM
214 EXTERNAL lsame, ilaenv, slamch, slange
221 INTRINSIC max, min, real
229 lquery = ( lwork.EQ.-1 )
230 IF( .NOT.( lsame( trans,
'N' ) .OR. lsame( trans,
'T' ) ) )
THEN
232 ELSE IF( m.LT.0 )
THEN
234 ELSE IF( n.LT.0 )
THEN
236 ELSE IF( nrhs.LT.0 )
THEN
238 ELSE IF( lda.LT.max( 1, m ) )
THEN
240 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
242 ELSE IF( lwork.LT.max( 1, mn + max( mn, nrhs ) ) .AND.
249 IF( info.EQ.0 .OR. info.EQ.-10 )
THEN
252 IF( lsame( trans,
'N' ) )
256 nb = ilaenv( 1,
'SGEQRF',
' ', m, n, -1, -1 )
258 nb = max( nb, ilaenv( 1,
'SORMQR',
'LN', m, nrhs, n,
261 nb = max( nb, ilaenv( 1,
'SORMQR',
'LT', m, nrhs, n,
265 nb = ilaenv( 1,
'SGELQF',
' ', m, n, -1, -1 )
267 nb = max( nb, ilaenv( 1,
'SORMLQ',
'LT', n, nrhs, m,
270 nb = max( nb, ilaenv( 1,
'SORMLQ',
'LN', n, nrhs, m,
275 wsize = max( 1, mn + max( mn, nrhs )*nb )
276 work( 1 ) = real( wsize )
281 CALL xerbla(
'SGELS ', -info )
283 ELSE IF( lquery )
THEN
289 IF( min( m, n, nrhs ).EQ.0 )
THEN
290 CALL slaset(
'Full', max( m, n ), nrhs, zero, zero, b, ldb )
296 smlnum = slamch(
'S' ) / slamch(
'P' )
297 bignum = one / smlnum
298 CALL slabad( smlnum, bignum )
302 anrm = slange(
'M', m, n, a, lda, rwork )
304 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
308 CALL slascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
310 ELSE IF( anrm.GT.bignum )
THEN
314 CALL slascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
316 ELSE IF( anrm.EQ.zero )
THEN
320 CALL slaset(
'F', max( m, n ), nrhs, zero, zero, b, ldb )
327 bnrm = slange(
'M', brow, nrhs, b, ldb, rwork )
329 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
333 CALL slascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb,
336 ELSE IF( bnrm.GT.bignum )
THEN
340 CALL slascl(
'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,
349 CALL sgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
360 CALL sormqr(
'Left',
'Transpose', m, nrhs, n, a, lda,
361 $ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
368 CALL strtrs(
'Upper',
'No transpose',
'Non-unit', n, nrhs,
369 $ a, lda, b, ldb, info )
383 CALL strtrs(
'Upper',
'Transpose',
'Non-unit', n, nrhs,
384 $ a, lda, b, ldb, info )
400 CALL sormqr(
'Left',
'No transpose', m, nrhs, n, a, lda,
401 $ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
414 CALL sgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
425 CALL strtrs(
'Lower',
'No transpose',
'Non-unit', m, nrhs,
426 $ a, lda, b, ldb, info )
442 CALL sormlq(
'Left',
'Transpose', n, nrhs, m, a, lda,
443 $ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
456 CALL sormlq(
'Left',
'No transpose', n, nrhs, m, a, lda,
457 $ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
464 CALL strtrs(
'Lower',
'Transpose',
'Non-unit', m, nrhs,
465 $ a, lda, b, ldb, info )
479 IF( iascl.EQ.1 )
THEN
480 CALL slascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,
482 ELSE IF( iascl.EQ.2 )
THEN
483 CALL slascl(
'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,
486 IF( ibscl.EQ.1 )
THEN
487 CALL slascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,
489 ELSE IF( ibscl.EQ.2 )
THEN
490 CALL slascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,
495 work( 1 ) = real( wsize )
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 sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
subroutine sgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
SGELS solves overdetermined or underdetermined systems for GE matrices
subroutine strtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
STRTRS
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
subroutine sormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMLQ