200 SUBROUTINE sgelsd( M, N, NRHS, A, LDA, B, LDB, S, RCOND,
201 $ RANK, WORK, LWORK, IWORK, INFO )
208 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
213 REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
220 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
224 INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
225 $ ldwork, liwork, maxmn, maxwrk, minmn, minwrk,
226 $ mm, mnthr, nlvl, nwork, smlsiz, wlalsd
227 REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
236 REAL SLAMCH, SLANGE, SROUNDUP_LWORK
237 EXTERNAL slamch, slange, ilaenv,
241 INTRINSIC int, log, max, min, real
250 lquery = ( lwork.EQ.-1 )
253 ELSE IF( n.LT.0 )
THEN
255 ELSE IF( nrhs.LT.0 )
THEN
257 ELSE IF( lda.LT.max( 1, m ) )
THEN
259 ELSE IF( ldb.LT.max( 1, maxmn ) )
THEN
274 IF( minmn.GT.0 )
THEN
275 smlsiz = ilaenv( 9,
'SGELSD',
' ', 0, 0, 0, 0 )
276 mnthr = ilaenv( 6,
'SGELSD',
' ', m, n, nrhs, -1 )
277 nlvl = max( int( log( real( minmn ) / real( smlsiz + 1 ) ) /
278 $ log( two ) ) + 1, 0 )
279 liwork = 3*minmn*nlvl + 11*minmn
281 IF( m.GE.n .AND. m.GE.mnthr )
THEN
287 maxwrk = max( maxwrk, n + n*ilaenv( 1,
'SGEQRF',
' ',
290 maxwrk = max( maxwrk, n + nrhs*ilaenv( 1,
'SORMQR',
298 maxwrk = max( maxwrk, 3*n + ( mm + n )*ilaenv( 1,
299 $
'SGEBRD',
' ', mm, n, -1, -1 ) )
300 maxwrk = max( maxwrk, 3*n + nrhs*ilaenv( 1,
'SORMBR',
301 $
'QLT', mm, nrhs, n, -1 ) )
302 maxwrk = max( maxwrk, 3*n + ( n - 1 )*ilaenv( 1,
303 $
'SORMBR',
'PLN', n, nrhs, n, -1 ) )
304 wlalsd = 9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs +
306 maxwrk = max( maxwrk, 3*n + wlalsd )
307 minwrk = max( 3*n + mm, 3*n + nrhs, 3*n + wlalsd )
310 wlalsd = 9*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs +
312 IF( n.GE.mnthr )
THEN
317 maxwrk = m + m*ilaenv( 1,
'SGELQF',
' ', m, n, -1,
319 maxwrk = max( maxwrk, m*m + 4*m + 2*m*ilaenv( 1,
320 $
'SGEBRD',
' ', m, m, -1, -1 ) )
321 maxwrk = max( maxwrk, m*m + 4*m + nrhs*ilaenv( 1,
322 $
'SORMBR',
'QLT', m, nrhs, m, -1 ) )
323 maxwrk = max( maxwrk,
324 $ m*m + 4*m + ( m - 1 )*ilaenv( 1,
325 $
'SORMBR',
'PLN', m, nrhs, m, -1 ) )
327 maxwrk = max( maxwrk, m*m + m + m*nrhs )
329 maxwrk = max( maxwrk, m*m + 2*m )
331 maxwrk = max( maxwrk, m + nrhs*ilaenv( 1,
'SORMLQ',
332 $
'LT', n, nrhs, m, -1 ) )
333 maxwrk = max( maxwrk, m*m + 4*m + wlalsd )
336 maxwrk = max( maxwrk,
337 $ 4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) )
342 maxwrk = 3*m + ( n + m )*ilaenv( 1,
'SGEBRD',
' ',
345 maxwrk = max( maxwrk, 3*m + nrhs*ilaenv( 1,
347 $
'QLT', m, nrhs, n, -1 ) )
348 maxwrk = max( maxwrk, 3*m + m*ilaenv( 1,
'SORMBR',
349 $
'PLN', n, nrhs, m, -1 ) )
350 maxwrk = max( maxwrk, 3*m + wlalsd )
352 minwrk = max( 3*m + nrhs, 3*m + m, 3*m + wlalsd )
355 minwrk = min( minwrk, maxwrk )
356 work( 1 ) = sroundup_lwork(maxwrk)
359 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
365 CALL xerbla(
'SGELSD', -info )
367 ELSE IF( lquery )
THEN
373 IF( m.EQ.0 .OR. n.EQ.0 )
THEN
381 sfmin = slamch(
'S' )
383 bignum = one / smlnum
387 anrm = slange(
'M', m, n, a, lda, work )
389 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
393 CALL slascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
395 ELSE IF( anrm.GT.bignum )
THEN
399 CALL slascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
401 ELSE IF( anrm.EQ.zero )
THEN
405 CALL slaset(
'F', max( m, n ), nrhs, zero, zero, b, ldb )
406 CALL slaset(
'F', minmn, 1, zero, zero, s, 1 )
413 bnrm = slange(
'M', m, nrhs, b, ldb, work )
415 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
419 CALL slascl(
'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb,
422 ELSE IF( bnrm.GT.bignum )
THEN
426 CALL slascl(
'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb,
434 $
CALL slaset(
'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb )
443 IF( m.GE.mnthr )
THEN
454 CALL sgeqrf( m, n, a, lda, work( itau ), work( nwork ),
455 $ lwork-nwork+1, info )
460 CALL sormqr(
'L',
'T', m, nrhs, n, a, lda, work( itau ),
462 $ ldb, work( nwork ), lwork-nwork+1, info )
467 CALL slaset(
'L', n-1, n-1, zero, zero, a( 2, 1 ),
480 CALL sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),
481 $ work( itaup ), work( nwork ), lwork-nwork+1,
487 CALL sormbr(
'Q',
'L',
'T', mm, nrhs, n, a, lda,
489 $ b, ldb, work( nwork ), lwork-nwork+1, info )
493 CALL slalsd(
'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,
494 $ rcond, rank, work( nwork ), iwork, info )
501 CALL sormbr(
'P',
'L',
'N', n, nrhs, n, a, lda,
503 $ b, ldb, work( nwork ), lwork-nwork+1, info )
505 ELSE IF( n.GE.mnthr .AND. lwork.GE.4*m+m*m+
506 $ max( m, 2*m-4, nrhs, n-3*m, wlalsd ) )
THEN
512 IF( lwork.GE.max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),
513 $ m*lda+m+m*nrhs, 4*m+m*lda+wlalsd ) )ldwork = lda
520 CALL sgelqf( m, n, a, lda, work( itau ), work( nwork ),
521 $ lwork-nwork+1, info )
526 CALL slacpy(
'L', m, m, a, lda, work( il ), ldwork )
527 CALL slaset(
'U', m-1, m-1, zero, zero, work( il+ldwork ),
537 CALL sgebrd( m, m, work( il ), ldwork, s, work( ie ),
538 $ work( itauq ), work( itaup ), work( nwork ),
539 $ lwork-nwork+1, info )
544 CALL sormbr(
'Q',
'L',
'T', m, nrhs, m, work( il ), ldwork,
545 $ work( itauq ), b, ldb, work( nwork ),
546 $ lwork-nwork+1, info )
550 CALL slalsd(
'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,
551 $ rcond, rank, work( nwork ), iwork, info )
558 CALL sormbr(
'P',
'L',
'N', m, nrhs, m, work( il ), ldwork,
559 $ work( itaup ), b, ldb, work( nwork ),
560 $ lwork-nwork+1, info )
564 CALL slaset(
'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb )
570 CALL sormlq(
'L',
'T', n, nrhs, m, a, lda, work( itau ), b,
571 $ ldb, work( nwork ), lwork-nwork+1, info )
585 CALL sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),
586 $ work( itaup ), work( nwork ), lwork-nwork+1,
592 CALL sormbr(
'Q',
'L',
'T', m, nrhs, n, a, lda,
594 $ b, ldb, work( nwork ), lwork-nwork+1, info )
598 CALL slalsd(
'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,
599 $ rcond, rank, work( nwork ), iwork, info )
606 CALL sormbr(
'P',
'L',
'N', n, nrhs, m, a, lda,
608 $ b, ldb, work( nwork ), lwork-nwork+1, info )
614 IF( iascl.EQ.1 )
THEN
615 CALL slascl(
'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb,
617 CALL slascl(
'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,
619 ELSE IF( iascl.EQ.2 )
THEN
620 CALL slascl(
'G', 0, 0, anrm, bignum, n, nrhs, b, ldb,
622 CALL slascl(
'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,
625 IF( ibscl.EQ.1 )
THEN
626 CALL slascl(
'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb,
628 ELSE IF( ibscl.EQ.2 )
THEN
629 CALL slascl(
'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb,
634 work( 1 ) = sroundup_lwork(maxwrk)