182 SUBROUTINE cgels( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
192 INTEGER info, lda, ldb, lwork, m, n, nrhs
195 COMPLEX a( lda, * ),
b( ldb, * ), work( * )
202 parameter( zero = 0.0e+0, one = 1.0e+0 )
204 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
208 INTEGER brow, i, iascl, ibscl,
j, mn, nb, scllen, wsize
209 REAL anrm, bignum, bnrm, smlnum
225 INTRINSIC max, min, real
233 lquery = ( lwork.EQ.-1 )
234 IF( .NOT.(
lsame( trans,
'N' ) .OR.
lsame( trans,
'C' ) ) )
THEN
236 ELSE IF( m.LT.0 )
THEN
238 ELSE IF( n.LT.0 )
THEN
240 ELSE IF( nrhs.LT.0 )
THEN
242 ELSE IF( lda.LT.max( 1, m ) )
THEN
244 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
246 ELSE IF( lwork.LT.max( 1, mn+max( mn, nrhs ) ) .AND.
253 IF( info.EQ.0 .OR. info.EQ.-10 )
THEN
256 IF(
lsame( trans,
'N' ) )
260 nb =
ilaenv( 1,
'CGEQRF',
' ', m, n, -1, -1 )
262 nb = max( nb,
ilaenv( 1,
'CUNMQR',
'LN', m, nrhs, n,
265 nb = max( nb,
ilaenv( 1,
'CUNMQR',
'LC', m, nrhs, n,
269 nb =
ilaenv( 1,
'CGELQF',
' ', m, n, -1, -1 )
271 nb = max( nb,
ilaenv( 1,
'CUNMLQ',
'LC', n, nrhs, m,
274 nb = max( nb,
ilaenv( 1,
'CUNMLQ',
'LN', n, nrhs, m,
279 wsize = max( 1, mn + max( mn, nrhs )*nb )
280 work( 1 ) =
REAL( wsize )
285 CALL
xerbla(
'CGELS ', -info )
287 ELSE IF( lquery )
THEN
293 IF( min( m, n, nrhs ).EQ.0 )
THEN
294 CALL
claset(
'Full', max( m, n ), nrhs, czero, czero,
b, ldb )
301 bignum = one / smlnum
302 CALL
slabad( smlnum, bignum )
306 anrm =
clange(
'M', m, n, a, lda, rwork )
308 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
312 CALL
clascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
314 ELSE IF( anrm.GT.bignum )
THEN
318 CALL
clascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
320 ELSE IF( anrm.EQ.zero )
THEN
324 CALL
claset(
'F', max( m, n ), nrhs, czero, czero,
b, ldb )
331 bnrm =
clange(
'M', brow, nrhs,
b, ldb, rwork )
333 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
337 CALL
clascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs,
b, ldb,
340 ELSE IF( bnrm.GT.bignum )
THEN
344 CALL
clascl(
'G', 0, 0, bnrm, bignum, brow, nrhs,
b, ldb,
353 CALL
cgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
364 CALL
cunmqr(
'Left',
'Conjugate transpose', m, nrhs, n, a,
365 $ lda, work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
372 CALL
ctrtrs(
'Upper',
'No transpose',
'Non-unit', n, nrhs,
373 $ a, lda,
b, ldb, info )
387 CALL
ctrtrs(
'Upper',
'Conjugate transpose',
'Non-unit',
388 $ n, nrhs, a, lda,
b, ldb, info )
404 CALL
cunmqr(
'Left',
'No transpose', m, nrhs, n, a, lda,
405 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
418 CALL
cgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
429 CALL
ctrtrs(
'Lower',
'No transpose',
'Non-unit', m, nrhs,
430 $ a, lda,
b, ldb, info )
446 CALL
cunmlq(
'Left',
'Conjugate transpose', n, nrhs, m, a,
447 $ lda, work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
460 CALL
cunmlq(
'Left',
'No transpose', n, nrhs, m, a, lda,
461 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
468 CALL
ctrtrs(
'Lower',
'Conjugate transpose',
'Non-unit',
469 $ m, nrhs, a, lda,
b, ldb, info )
483 IF( iascl.EQ.1 )
THEN
484 CALL
clascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs,
b, ldb,
486 ELSE IF( iascl.EQ.2 )
THEN
487 CALL
clascl(
'G', 0, 0, anrm, bignum, scllen, nrhs,
b, ldb,
490 IF( ibscl.EQ.1 )
THEN
491 CALL
clascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs,
b, ldb,
493 ELSE IF( ibscl.EQ.2 )
THEN
494 CALL
clascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs,
b, ldb,
499 work( 1 ) =
REAL( wsize )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMQR
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine ctrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
CTRTRS
subroutine cgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGELQF
real function slamch(CMACH)
SLAMCH
subroutine cunmlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMLQ
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slabad(SMALL, LARGE)
SLABAD
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine cgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
CGELS solves overdetermined or underdetermined systems for GE matrices