183 SUBROUTINE dgels( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
193 INTEGER info, lda, ldb, lwork, m, n, nrhs
196 DOUBLE PRECISION a( lda, * ),
b( ldb, * ), work( * )
202 DOUBLE PRECISION zero, one
203 parameter( zero = 0.0d0, one = 1.0d0 )
207 INTEGER brow, i, iascl, ibscl,
j, mn, nb, scllen, wsize
208 DOUBLE PRECISION anrm, bignum, bnrm, smlnum
211 DOUBLE PRECISION rwork( 1 )
224 INTRINSIC dble, max, min
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. .NOT.lquery )
252 IF( info.EQ.0 .OR. info.EQ.-10 )
THEN
255 IF(
lsame( trans,
'N' ) )
259 nb =
ilaenv( 1,
'DGEQRF',
' ', m, n, -1, -1 )
261 nb = max( nb,
ilaenv( 1,
'DORMQR',
'LN', m, nrhs, n,
264 nb = max( nb,
ilaenv( 1,
'DORMQR',
'LT', m, nrhs, n,
268 nb =
ilaenv( 1,
'DGELQF',
' ', m, n, -1, -1 )
270 nb = max( nb,
ilaenv( 1,
'DORMLQ',
'LT', n, nrhs, m,
273 nb = max( nb,
ilaenv( 1,
'DORMLQ',
'LN', n, nrhs, m,
278 wsize = max( 1, mn+max( mn, nrhs )*nb )
279 work( 1 ) = dble( wsize )
284 CALL
xerbla(
'DGELS ', -info )
286 ELSE IF( lquery )
THEN
292 IF( min( m, n, nrhs ).EQ.0 )
THEN
293 CALL
dlaset(
'Full', max( m, n ), nrhs, zero, zero,
b, ldb )
300 bignum = one / smlnum
301 CALL
dlabad( smlnum, bignum )
305 anrm =
dlange(
'M', m, n, a, lda, rwork )
307 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
311 CALL
dlascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
313 ELSE IF( anrm.GT.bignum )
THEN
317 CALL
dlascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
319 ELSE IF( anrm.EQ.zero )
THEN
323 CALL
dlaset(
'F', max( m, n ), nrhs, zero, zero,
b, ldb )
330 bnrm =
dlange(
'M', brow, nrhs,
b, ldb, rwork )
332 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
336 CALL
dlascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs,
b, ldb,
339 ELSE IF( bnrm.GT.bignum )
THEN
343 CALL
dlascl(
'G', 0, 0, bnrm, bignum, brow, nrhs,
b, ldb,
352 CALL
dgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
363 CALL
dormqr(
'Left',
'Transpose', m, nrhs, n, a, lda,
364 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
371 CALL
dtrtrs(
'Upper',
'No transpose',
'Non-unit', n, nrhs,
372 $ a, lda,
b, ldb, info )
386 CALL
dtrtrs(
'Upper',
'Transpose',
'Non-unit', n, nrhs,
387 $ a, lda,
b, ldb, info )
403 CALL
dormqr(
'Left',
'No transpose', m, nrhs, n, a, lda,
404 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
417 CALL
dgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
428 CALL
dtrtrs(
'Lower',
'No transpose',
'Non-unit', m, nrhs,
429 $ a, lda,
b, ldb, info )
445 CALL
dormlq(
'Left',
'Transpose', n, nrhs, m, a, lda,
446 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
459 CALL
dormlq(
'Left',
'No transpose', n, nrhs, m, a, lda,
460 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
467 CALL
dtrtrs(
'Lower',
'Transpose',
'Non-unit', m, nrhs,
468 $ a, lda,
b, ldb, info )
482 IF( iascl.EQ.1 )
THEN
483 CALL
dlascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs,
b, ldb,
485 ELSE IF( iascl.EQ.2 )
THEN
486 CALL
dlascl(
'G', 0, 0, anrm, bignum, scllen, nrhs,
b, ldb,
489 IF( ibscl.EQ.1 )
THEN
490 CALL
dlascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs,
b, ldb,
492 ELSE IF( ibscl.EQ.2 )
THEN
493 CALL
dlascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs,
b, ldb,
498 work( 1 ) = dble( wsize )
subroutine dgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGELQF
LOGICAL function lsame(CA, CB)
LSAME
subroutine dgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
DGELS solves overdetermined or underdetermined systems for GE matrices
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
subroutine dormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMQR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMLQ
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine dlabad(SMALL, LARGE)
DLABAD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dtrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
DTRTRS
DOUBLE PRECISION function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...