182 SUBROUTINE zgels( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
192 INTEGER info, lda, ldb, lwork, m, n, nrhs
195 COMPLEX*16 a( lda, * ),
b( ldb, * ), work( * )
201 DOUBLE PRECISION zero, one
202 parameter( zero = 0.0d+0, one = 1.0d+0 )
204 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
208 INTEGER brow, i, iascl, ibscl,
j, mn, nb, scllen, wsize
209 DOUBLE PRECISION anrm, bignum, bnrm, smlnum
212 DOUBLE PRECISION rwork( 1 )
225 INTRINSIC dble, max, min
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. .NOT.lquery )
253 IF( info.EQ.0 .OR. info.EQ.-10 )
THEN
256 IF(
lsame( trans,
'N' ) )
260 nb =
ilaenv( 1,
'ZGEQRF',
' ', m, n, -1, -1 )
262 nb = max( nb,
ilaenv( 1,
'ZUNMQR',
'LN', m, nrhs, n,
265 nb = max( nb,
ilaenv( 1,
'ZUNMQR',
'LC', m, nrhs, n,
269 nb =
ilaenv( 1,
'ZGELQF',
' ', m, n, -1, -1 )
271 nb = max( nb,
ilaenv( 1,
'ZUNMLQ',
'LC', n, nrhs, m,
274 nb = max( nb,
ilaenv( 1,
'ZUNMLQ',
'LN', n, nrhs, m,
279 wsize = max( 1, mn+max( mn, nrhs )*nb )
280 work( 1 ) = dble( wsize )
285 CALL
xerbla(
'ZGELS ', -info )
287 ELSE IF( lquery )
THEN
293 IF( min( m, n, nrhs ).EQ.0 )
THEN
294 CALL
zlaset(
'Full', max( m, n ), nrhs, czero, czero,
b, ldb )
301 bignum = one / smlnum
302 CALL
dlabad( smlnum, bignum )
306 anrm =
zlange(
'M', m, n, a, lda, rwork )
308 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
312 CALL
zlascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
314 ELSE IF( anrm.GT.bignum )
THEN
318 CALL
zlascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
320 ELSE IF( anrm.EQ.zero )
THEN
324 CALL
zlaset(
'F', max( m, n ), nrhs, czero, czero,
b, ldb )
331 bnrm =
zlange(
'M', brow, nrhs,
b, ldb, rwork )
333 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
337 CALL
zlascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs,
b, ldb,
340 ELSE IF( bnrm.GT.bignum )
THEN
344 CALL
zlascl(
'G', 0, 0, bnrm, bignum, brow, nrhs,
b, ldb,
353 CALL
zgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
364 CALL
zunmqr(
'Left',
'Conjugate transpose', m, nrhs, n, a,
365 $ lda, work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
372 CALL
ztrtrs(
'Upper',
'No transpose',
'Non-unit', n, nrhs,
373 $ a, lda,
b, ldb, info )
387 CALL
ztrtrs(
'Upper',
'Conjugate transpose',
'Non-unit',
388 $ n, nrhs, a, lda,
b, ldb, info )
404 CALL
zunmqr(
'Left',
'No transpose', m, nrhs, n, a, lda,
405 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
418 CALL
zgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
429 CALL
ztrtrs(
'Lower',
'No transpose',
'Non-unit', m, nrhs,
430 $ a, lda,
b, ldb, info )
446 CALL
zunmlq(
'Left',
'Conjugate transpose', n, nrhs, m, a,
447 $ lda, work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
460 CALL
zunmlq(
'Left',
'No transpose', n, nrhs, m, a, lda,
461 $ work( 1 ),
b, ldb, work( mn+1 ), lwork-mn,
468 CALL
ztrtrs(
'Lower',
'Conjugate transpose',
'Non-unit',
469 $ m, nrhs, a, lda,
b, ldb, info )
483 IF( iascl.EQ.1 )
THEN
484 CALL
zlascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs,
b, ldb,
486 ELSE IF( iascl.EQ.2 )
THEN
487 CALL
zlascl(
'G', 0, 0, anrm, bignum, scllen, nrhs,
b, ldb,
490 IF( ibscl.EQ.1 )
THEN
491 CALL
zlascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs,
b, ldb,
493 ELSE IF( ibscl.EQ.2 )
THEN
494 CALL
zlascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs,
b, ldb,
499 work( 1 ) = dble( wsize )
LOGICAL function lsame(CA, CB)
LSAME
subroutine zunmlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMLQ
DOUBLE PRECISION function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlabad(SMALL, LARGE)
DLABAD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine ztrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
ZTRTRS
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine zgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGELQF
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
subroutine zgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
ZGELS solves overdetermined or underdetermined systems for GE matrices