160 SUBROUTINE sgetsls( TRANS, M, N, NRHS, A, LDA, B, LDB,
161 $ work, lwork, info )
170 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
173 REAL A( lda, * ), B( ldb, * ), WORK( * )
181 parameter ( zero = 0.0e0, one = 1.0e0 )
185 INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW,
186 $ scllen, mnk, tszo, tszm, lwo, lwm, lw1, lw2,
187 $ wsizeo, wsizem, info2
188 REAL ANRM, BIGNUM, BNRM, SMLNUM, TQ( 5 ), WORKQ
194 EXTERNAL lsame, ilaenv,
slabad, slamch, slange
201 INTRINSIC REAL, 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 sgeqr( m, n, a, lda, tq, -1, workq, -1, info2 )
235 tszo = int( tq( 1 ) )
237 CALL sgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
238 $ tszo, b, ldb, workq, -1, info2 )
239 lwo = max( lwo, int( workq ) )
240 CALL sgeqr( m, n, a, lda, tq, -2, workq, -2, info2 )
241 tszm = int( tq( 1 ) )
243 CALL sgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
244 $ tszm, b, ldb, workq, -1, info2 )
245 lwm = max( lwm, int( workq ) )
249 CALL sgelq( m, n, a, lda, tq, -1, workq, -1, info2 )
250 tszo = int( tq( 1 ) )
252 CALL sgemlq(
'L', trans, n, nrhs, m, a, lda, tq,
253 $ tszo, b, ldb, workq, -1, info2 )
254 lwo = max( lwo, int( workq ) )
255 CALL sgelq( m, n, a, lda, tq, -2, workq, -2, info2 )
256 tszm = int( tq( 1 ) )
258 CALL sgemlq(
'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(
'SGETSLS', -info )
273 work( 1 ) =
REAL( 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 slaset(
'FULL', max( m, n ), nrhs, zero, zero,
299 smlnum = slamch(
'S' ) / slamch(
'P' )
300 bignum = one / smlnum
301 CALL slabad( smlnum, bignum )
305 anrm = slange(
'M', m, n, a, lda, work )
307 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
311 CALL slascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
313 ELSE IF( anrm.GT.bignum )
THEN
317 CALL slascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
319 ELSE IF( anrm.EQ.zero )
THEN
323 CALL slaset(
'F', maxmn, nrhs, zero, zero, b, ldb )
331 bnrm = slange(
'M', brow, nrhs, b, ldb, work )
333 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
337 CALL slascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb,
340 ELSE IF( bnrm.GT.bignum )
THEN
344 CALL slascl(
'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,
353 CALL sgeqr( m, n, a, lda, work( lw2+1 ), lw1,
354 $ work( 1 ), lw2, info )
355 IF ( .NOT.tran )
THEN
361 CALL sgemqr(
'L' ,
'T', m, nrhs, n, a, lda,
362 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
367 CALL strtrs(
'U',
'N',
'N', n, nrhs,
368 $ a, lda, b, ldb, info )
379 CALL strtrs(
'U',
'T',
'N', n, nrhs,
380 $ a, lda, b, ldb, info )
396 CALL sgemqr(
'L',
'N', m, nrhs, n, a, lda,
397 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
408 CALL sgelq( m, n, a, lda, work( lw2+1 ), lw1,
409 $ work( 1 ), lw2, info )
419 CALL strtrs(
'L',
'N',
'N', m, nrhs,
420 $ a, lda, b, ldb, info )
436 CALL sgemlq(
'L',
'T', n, nrhs, m, a, lda,
437 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
450 CALL sgemlq(
'L',
'N', n, nrhs, m, a, lda,
451 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
458 CALL strtrs(
'Lower',
'Transpose',
'Non-unit', m, nrhs,
459 $ a, lda, b, ldb, info )
473 IF( iascl.EQ.1 )
THEN
474 CALL slascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,
476 ELSE IF( iascl.EQ.2 )
THEN
477 CALL slascl(
'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,
480 IF( ibscl.EQ.1 )
THEN
481 CALL slascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,
483 ELSE IF( ibscl.EQ.2 )
THEN
484 CALL slascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,
489 work( 1 ) =
REAL( tszo + lwo )
subroutine strtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
STRTRS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgeqr(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
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 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 slabad(SMALL, LARGE)
SLABAD
subroutine sgemqr(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
subroutine sgemlq(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
subroutine sgelq(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
subroutine sgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)