160 SUBROUTINE dgetsls( TRANS, M, N, NRHS, A, LDA, B, LDB,
161 $ work, lwork, info )
170 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
173 DOUBLE PRECISION A( lda, * ), B( ldb, * ), WORK( * )
180 DOUBLE PRECISION ZERO, ONE
181 parameter ( zero = 0.0d0, one = 1.0d0 )
185 INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW,
186 $ scllen, mnk, tszo, tszm, lwo, lwm, lw1, lw2,
187 $ wsizeo, wsizem, info2
188 DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, TQ( 5 ), WORKQ
193 DOUBLE PRECISION DLAMCH, DLANGE
194 EXTERNAL lsame, ilaenv,
dlabad, dlamch, dlange
201 INTRINSIC dble, max, min, int
210 mnk = max( minmn, nrhs )
211 tran = lsame( trans,
'T' )
213 lquery = ( lwork.EQ.-1 .OR. lwork.EQ.-2 )
214 IF( .NOT.( lsame( trans,
'N' ) .OR.
215 $ lsame( trans,
'T' ) ) )
THEN
217 ELSE IF( m.LT.0 )
THEN
219 ELSE IF( n.LT.0 )
THEN
221 ELSE IF( nrhs.LT.0 )
THEN
223 ELSE IF( lda.LT.max( 1, m ) )
THEN
225 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
234 CALL dgeqr( m, n, a, lda, tq, -1, workq, -1, info2 )
235 tszo = int( tq( 1 ) )
237 CALL dgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
238 $ tszo, b, ldb, workq, -1, info2 )
239 lwo = max( lwo, int( workq ) )
240 CALL dgeqr( m, n, a, lda, tq, -2, workq, -2, info2 )
241 tszm = int( tq( 1 ) )
243 CALL dgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
244 $ tszm, b, ldb, workq, -1, info2 )
245 lwm = max( lwm, int( workq ) )
249 CALL dgelq( m, n, a, lda, tq, -1, workq, -1, info2 )
250 tszo = int( tq( 1 ) )
252 CALL dgemlq(
'L', trans, n, nrhs, m, a, lda, tq,
253 $ tszo, b, ldb, workq, -1, info2 )
254 lwo = max( lwo, int( workq ) )
255 CALL dgelq( m, n, a, lda, tq, -2, workq, -2, info2 )
256 tszm = int( tq( 1 ) )
258 CALL dgemlq(
'L', trans, n, nrhs, m, a, lda, tq,
259 $ tszo, b, ldb, workq, -1, info2 )
260 lwm = max( lwm, int( workq ) )
265 IF( ( lwork.LT.wsizem ).AND.( .NOT.lquery ) )
THEN
272 CALL xerbla(
'DGETSLS', -info )
273 work( 1 ) = dble( wsizeo )
277 IF( lwork.EQ.-1 ) work( 1 ) =
REAL( wsizeo )
278 IF( lwork.EQ.-2 ) work( 1 ) =
REAL( wsizem )
281 IF( lwork.LT.wsizeo )
THEN
291 IF( min( m, n, nrhs ).EQ.0 )
THEN
292 CALL dlaset(
'FULL', max( m, n ), nrhs, zero, zero,
299 smlnum = dlamch(
'S' ) / dlamch(
'P' )
300 bignum = one / smlnum
301 CALL dlabad( smlnum, bignum )
305 anrm = dlange(
'M', m, n, a, lda, work )
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', maxmn, nrhs, zero, zero, b, ldb )
331 bnrm = dlange(
'M', brow, nrhs, b, ldb, work )
333 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
337 CALL dlascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb,
340 ELSE IF( bnrm.GT.bignum )
THEN
344 CALL dlascl(
'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,
353 CALL dgeqr( m, n, a, lda, work( lw2+1 ), lw1,
354 $ work( 1 ), lw2, info )
355 IF ( .NOT.tran )
THEN
361 CALL dgemqr(
'L' ,
'T', m, nrhs, n, a, lda,
362 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
367 CALL dtrtrs(
'U',
'N',
'N', n, nrhs,
368 $ a, lda, b, ldb, info )
379 CALL dtrtrs(
'U',
'T',
'N', n, nrhs,
380 $ a, lda, b, ldb, info )
396 CALL dgemqr(
'L',
'N', m, nrhs, n, a, lda,
397 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
408 CALL dgelq( m, n, a, lda, work( lw2+1 ), lw1,
409 $ work( 1 ), lw2, info )
419 CALL dtrtrs(
'L',
'N',
'N', m, nrhs,
420 $ a, lda, b, ldb, info )
436 CALL dgemlq(
'L',
'T', n, nrhs, m, a, lda,
437 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
450 CALL dgemlq(
'L',
'N', n, nrhs, m, a, lda,
451 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
458 CALL dtrtrs(
'Lower',
'Transpose',
'Non-unit', m, nrhs,
459 $ a, lda, b, ldb, info )
473 IF( iascl.EQ.1 )
THEN
474 CALL dlascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,
476 ELSE IF( iascl.EQ.2 )
THEN
477 CALL dlascl(
'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,
480 IF( ibscl.EQ.1 )
THEN
481 CALL dlascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,
483 ELSE IF( ibscl.EQ.2 )
THEN
484 CALL dlascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,
489 work( 1 ) = dble( tszo + lwo )
subroutine dgemlq(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
subroutine dgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
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 dgeqr(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
subroutine dtrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
DTRTRS
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...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dgemqr(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
subroutine dgelq(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)