LAPACK  3.6.0 LAPACK: Linear Algebra PACKage
Collaboration diagram for real:


This browser is not able to show SVG: try Firefox, Chrome, Safari, or Opera instead.

## Functions

subroutine sgelsx (M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO)
SGELSX solves overdetermined or underdetermined systems for GE matrices More...

subroutine sgels (TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
SGELS solves overdetermined or underdetermined systems for GE matrices More...

subroutine sgelsd (M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO)
SGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices More...

subroutine sgelss (M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO)
SGELSS solves overdetermined or underdetermined systems for GE matrices More...

subroutine sgelsy (M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO)
SGELSY solves overdetermined or underdetermined systems for GE matrices More...

subroutine sgesv (N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) More...

subroutine sgesvx (FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SGESVX computes the solution to system of linear equations A * X = B for GE matrices More...

subroutine sgesvxx (FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
SGESVXX computes the solution to system of linear equations A * X = B for GE matrices More...

## Detailed Description

This is the group of real solve driver functions for GE matrices

## Function Documentation

 subroutine sgels ( character TRANS, integer M, integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, real, dimension( ldb, * ) B, integer LDB, real, dimension( * ) WORK, integer LWORK, integer INFO )

SGELS solves overdetermined or underdetermined systems for GE matrices

Download SGELS + dependencies [TGZ] [ZIP] [TXT]

Purpose:
``` SGELS solves overdetermined or underdetermined real linear systems
involving an M-by-N matrix A, or its transpose, using a QR or LQ
factorization of A.  It is assumed that A has full rank.

The following options are provided:

1. If TRANS = 'N' and m >= n:  find the least squares solution of
an overdetermined system, i.e., solve the least squares problem
minimize || B - A*X ||.

2. If TRANS = 'N' and m < n:  find the minimum norm solution of
an underdetermined system A * X = B.

3. If TRANS = 'T' and m >= n:  find the minimum norm solution of
an undetermined system A**T * X = B.

4. If TRANS = 'T' and m < n:  find the least squares solution of
an overdetermined system, i.e., solve the least squares problem
minimize || B - A**T * X ||.

Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.```
Parameters
 [in] TRANS ``` TRANS is CHARACTER*1 = 'N': the linear system involves A; = 'T': the linear system involves A**T. ``` [in] M ``` M is INTEGER The number of rows of the matrix A. M >= 0.``` [in] N ``` N is INTEGER The number of columns of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >=0.``` [in,out] A ``` A is REAL array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, if M >= N, A is overwritten by details of its QR factorization as returned by SGEQRF; if M < N, A is overwritten by details of its LQ factorization as returned by SGELQF.``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,M).``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the matrix B of right hand side vectors, stored columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS if TRANS = 'T'. On exit, if INFO = 0, B is overwritten by the solution vectors, stored columnwise: if TRANS = 'N' and m >= n, rows 1 to n of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements N+1 to M in that column; if TRANS = 'N' and m < n, rows 1 to N of B contain the minimum norm solution vectors; if TRANS = 'T' and m >= n, rows 1 to M of B contain the minimum norm solution vectors; if TRANS = 'T' and m < n, rows 1 to M of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements M+1 to N in that column.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= MAX(1,M,N).``` [out] WORK ``` WORK is REAL array, dimension (MAX(1,LWORK)) On exit, if INFO = 0, WORK(1) returns the optimal LWORK.``` [in] LWORK ``` LWORK is INTEGER The dimension of the array WORK. LWORK >= max( 1, MN + max( MN, NRHS ) ). For optimal performance, LWORK >= max( 1, MN + max( MN, NRHS )*NB ). where MN = min(M,N) and NB is the optimum block size. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA.``` [out] INFO ``` INFO is INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, the i-th diagonal element of the triangular factor of A is zero, so that A does not have full rank; the least squares solution could not be computed.```
Date
November 2011

Definition at line 185 of file sgels.f.

185 *
186 * -- LAPACK driver routine (version 3.4.0) --
187 * -- LAPACK is a software package provided by Univ. of Tennessee, --
188 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
189 * November 2011
190 *
191 * .. Scalar Arguments ..
192  CHARACTER trans
193  INTEGER info, lda, ldb, lwork, m, n, nrhs
194 * ..
195 * .. Array Arguments ..
196  REAL a( lda, * ), b( ldb, * ), work( * )
197 * ..
198 *
199 * =====================================================================
200 *
201 * .. Parameters ..
202  REAL zero, one
203  parameter( zero = 0.0e0, one = 1.0e0 )
204 * ..
205 * .. Local Scalars ..
206  LOGICAL lquery, tpsd
207  INTEGER brow, i, iascl, ibscl, j, mn, nb, scllen, wsize
208  REAL anrm, bignum, bnrm, smlnum
209 * ..
210 * .. Local Arrays ..
211  REAL rwork( 1 )
212 * ..
213 * .. External Functions ..
214  LOGICAL lsame
215  INTEGER ilaenv
216  REAL slamch, slange
217  EXTERNAL lsame, ilaenv, slamch, slange
218 * ..
219 * .. External Subroutines ..
220  EXTERNAL sgelqf, sgeqrf, slabad, slascl, slaset, sormlq,
221  \$ sormqr, strtrs, xerbla
222 * ..
223 * .. Intrinsic Functions ..
224  INTRINSIC max, min, real
225 * ..
226 * .. Executable Statements ..
227 *
228 * Test the input arguments.
229 *
230  info = 0
231  mn = min( m, n )
232  lquery = ( lwork.EQ.-1 )
233  IF( .NOT.( lsame( trans, 'N' ) .OR. lsame( trans, 'T' ) ) ) THEN
234  info = -1
235  ELSE IF( m.LT.0 ) THEN
236  info = -2
237  ELSE IF( n.LT.0 ) THEN
238  info = -3
239  ELSE IF( nrhs.LT.0 ) THEN
240  info = -4
241  ELSE IF( lda.LT.max( 1, m ) ) THEN
242  info = -6
243  ELSE IF( ldb.LT.max( 1, m, n ) ) THEN
244  info = -8
245  ELSE IF( lwork.LT.max( 1, mn + max( mn, nrhs ) ) .AND.
246  \$ .NOT.lquery ) THEN
247  info = -10
248  END IF
249 *
250 * Figure out optimal block size
251 *
252  IF( info.EQ.0 .OR. info.EQ.-10 ) THEN
253 *
254  tpsd = .true.
255  IF( lsame( trans, 'N' ) )
256  \$ tpsd = .false.
257 *
258  IF( m.GE.n ) THEN
259  nb = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 )
260  IF( tpsd ) THEN
261  nb = max( nb, ilaenv( 1, 'SORMQR', 'LN', m, nrhs, n,
262  \$ -1 ) )
263  ELSE
264  nb = max( nb, ilaenv( 1, 'SORMQR', 'LT', m, nrhs, n,
265  \$ -1 ) )
266  END IF
267  ELSE
268  nb = ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 )
269  IF( tpsd ) THEN
270  nb = max( nb, ilaenv( 1, 'SORMLQ', 'LT', n, nrhs, m,
271  \$ -1 ) )
272  ELSE
273  nb = max( nb, ilaenv( 1, 'SORMLQ', 'LN', n, nrhs, m,
274  \$ -1 ) )
275  END IF
276  END IF
277 *
278  wsize = max( 1, mn + max( mn, nrhs )*nb )
279  work( 1 ) = REAL( wsize )
280 *
281  END IF
282 *
283  IF( info.NE.0 ) THEN
284  CALL xerbla( 'SGELS ', -info )
285  RETURN
286  ELSE IF( lquery ) THEN
287  RETURN
288  END IF
289 *
290 * Quick return if possible
291 *
292  IF( min( m, n, nrhs ).EQ.0 ) THEN
293  CALL slaset( 'Full', max( m, n ), nrhs, zero, zero, b, ldb )
294  RETURN
295  END IF
296 *
297 * Get machine parameters
298 *
299  smlnum = slamch( 'S' ) / slamch( 'P' )
300  bignum = one / smlnum
301  CALL slabad( smlnum, bignum )
302 *
303 * Scale A, B if max element outside range [SMLNUM,BIGNUM]
304 *
305  anrm = slange( 'M', m, n, a, lda, rwork )
306  iascl = 0
307  IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
308 *
309 * Scale matrix norm up to SMLNUM
310 *
311  CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
312  iascl = 1
313  ELSE IF( anrm.GT.bignum ) THEN
314 *
315 * Scale matrix norm down to BIGNUM
316 *
317  CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
318  iascl = 2
319  ELSE IF( anrm.EQ.zero ) THEN
320 *
321 * Matrix all zero. Return zero solution.
322 *
323  CALL slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb )
324  GO TO 50
325  END IF
326 *
327  brow = m
328  IF( tpsd )
329  \$ brow = n
330  bnrm = slange( 'M', brow, nrhs, b, ldb, rwork )
331  ibscl = 0
332  IF( bnrm.GT.zero .AND. bnrm.LT.smlnum ) THEN
333 *
334 * Scale matrix norm up to SMLNUM
335 *
336  CALL slascl( 'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb,
337  \$ info )
338  ibscl = 1
339  ELSE IF( bnrm.GT.bignum ) THEN
340 *
341 * Scale matrix norm down to BIGNUM
342 *
343  CALL slascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,
344  \$ info )
345  ibscl = 2
346  END IF
347 *
348  IF( m.GE.n ) THEN
349 *
350 * compute QR factorization of A
351 *
352  CALL sgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
353  \$ info )
354 *
355 * workspace at least N, optimally N*NB
356 *
357  IF( .NOT.tpsd ) THEN
358 *
359 * Least-Squares Problem min || A * X - B ||
360 *
361 * B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
362 *
363  CALL sormqr( 'Left', 'Transpose', m, nrhs, n, a, lda,
364  \$ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
365  \$ info )
366 *
367 * workspace at least NRHS, optimally NRHS*NB
368 *
369 * B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
370 *
371  CALL strtrs( 'Upper', 'No transpose', 'Non-unit', n, nrhs,
372  \$ a, lda, b, ldb, info )
373 *
374  IF( info.GT.0 ) THEN
375  RETURN
376  END IF
377 *
378  scllen = n
379 *
380  ELSE
381 *
382 * Overdetermined system of equations A**T * X = B
383 *
384 * B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS)
385 *
386  CALL strtrs( 'Upper', 'Transpose', 'Non-unit', n, nrhs,
387  \$ a, lda, b, ldb, info )
388 *
389  IF( info.GT.0 ) THEN
390  RETURN
391  END IF
392 *
393 * B(N+1:M,1:NRHS) = ZERO
394 *
395  DO 20 j = 1, nrhs
396  DO 10 i = n + 1, m
397  b( i, j ) = zero
398  10 CONTINUE
399  20 CONTINUE
400 *
401 * B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
402 *
403  CALL sormqr( 'Left', 'No transpose', m, nrhs, n, a, lda,
404  \$ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
405  \$ info )
406 *
407 * workspace at least NRHS, optimally NRHS*NB
408 *
409  scllen = m
410 *
411  END IF
412 *
413  ELSE
414 *
415 * Compute LQ factorization of A
416 *
417  CALL sgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,
418  \$ info )
419 *
420 * workspace at least M, optimally M*NB.
421 *
422  IF( .NOT.tpsd ) THEN
423 *
424 * underdetermined system of equations A * X = B
425 *
426 * B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
427 *
428  CALL strtrs( 'Lower', 'No transpose', 'Non-unit', m, nrhs,
429  \$ a, lda, b, ldb, info )
430 *
431  IF( info.GT.0 ) THEN
432  RETURN
433  END IF
434 *
435 * B(M+1:N,1:NRHS) = 0
436 *
437  DO 40 j = 1, nrhs
438  DO 30 i = m + 1, n
439  b( i, j ) = zero
440  30 CONTINUE
441  40 CONTINUE
442 *
443 * B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS)
444 *
445  CALL sormlq( 'Left', 'Transpose', n, nrhs, m, a, lda,
446  \$ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
447  \$ info )
448 *
449 * workspace at least NRHS, optimally NRHS*NB
450 *
451  scllen = n
452 *
453  ELSE
454 *
455 * overdetermined system min || A**T * X - B ||
456 *
457 * B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
458 *
459  CALL sormlq( 'Left', 'No transpose', n, nrhs, m, a, lda,
460  \$ work( 1 ), b, ldb, work( mn+1 ), lwork-mn,
461  \$ info )
462 *
463 * workspace at least NRHS, optimally NRHS*NB
464 *
465 * B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS)
466 *
467  CALL strtrs( 'Lower', 'Transpose', 'Non-unit', m, nrhs,
468  \$ a, lda, b, ldb, info )
469 *
470  IF( info.GT.0 ) THEN
471  RETURN
472  END IF
473 *
474  scllen = m
475 *
476  END IF
477 *
478  END IF
479 *
480 * Undo scaling
481 *
482  IF( iascl.EQ.1 ) THEN
483  CALL slascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,
484  \$ info )
485  ELSE IF( iascl.EQ.2 ) THEN
486  CALL slascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,
487  \$ info )
488  END IF
489  IF( ibscl.EQ.1 ) THEN
490  CALL slascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,
491  \$ info )
492  ELSE IF( ibscl.EQ.2 ) THEN
493  CALL slascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,
494  \$ info )
495  END IF
496 *
497  50 CONTINUE
498  work( 1 ) = REAL( wsize )
499 *
500  RETURN
501 *
502 * End of SGELS
503 *
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine sormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMLQ
Definition: sormlq.f:170
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
Definition: sormqr.f:170
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
Definition: sgelqf.f:137
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
Definition: sgeqrf.f:138
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
subroutine strtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
STRTRS
Definition: strtrs.f:142
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
Definition: tstiee.f:83
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.
Definition: slascl.f:141
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:116
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...
Definition: slaset.f:112

Here is the call graph for this function:

Here is the caller graph for this function:

 subroutine sgelsd ( integer M, integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, real, dimension( ldb, * ) B, integer LDB, real, dimension( * ) S, real RCOND, integer RANK, real, dimension( * ) WORK, integer LWORK, integer, dimension( * ) IWORK, integer INFO )

SGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices

Download SGELSD + dependencies [TGZ] [ZIP] [TXT]

Purpose:
``` SGELSD computes the minimum-norm solution to a real linear least
squares problem:
minimize 2-norm(| b - A*x |)
using the singular value decomposition (SVD) of A. A is an M-by-N
matrix which may be rank-deficient.

Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.

The problem is solved in three steps:
(1) Reduce the coefficient matrix A to bidiagonal form with
Householder transformations, reducing the original problem
into a "bidiagonal least squares problem" (BLS)
(2) Solve the BLS using a divide and conquer approach.
(3) Apply back all the Householder tranformations to solve
the original least squares problem.

The effective rank of A is determined by treating as zero those
singular values which are less than RCOND times the largest singular
value.

The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.```
Parameters
 [in] M ``` M is INTEGER The number of rows of A. M >= 0.``` [in] N ``` N is INTEGER The number of columns of A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0.``` [in] A ``` A is REAL array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, A has been destroyed.``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,M).``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the M-by-NRHS right hand side matrix B. On exit, B is overwritten by the N-by-NRHS solution matrix X. If m >= n and RANK = n, the residual sum-of-squares for the solution in the i-th column is given by the sum of squares of elements n+1:m in that column.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,max(M,N)).``` [out] S ``` S is REAL array, dimension (min(M,N)) The singular values of A in decreasing order. The condition number of A in the 2-norm = S(1)/S(min(m,n)).``` [in] RCOND ``` RCOND is REAL RCOND is used to determine the effective rank of A. Singular values S(i) <= RCOND*S(1) are treated as zero. If RCOND < 0, machine precision is used instead.``` [out] RANK ``` RANK is INTEGER The effective rank of A, i.e., the number of singular values which are greater than RCOND*S(1).``` [out] WORK ``` WORK is REAL array, dimension (MAX(1,LWORK)) On exit, if INFO = 0, WORK(1) returns the optimal LWORK.``` [in] LWORK ``` LWORK is INTEGER The dimension of the array WORK. LWORK must be at least 1. The exact minimum amount of workspace needed depends on M, N and NRHS. As long as LWORK is at least 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, if M is greater than or equal to N or 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, if M is less than N, the code will execute correctly. SMLSIZ is returned by ILAENV and is equal to the maximum size of the subproblems at the bottom of the computation tree (usually about 25), and NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) For good performance, LWORK should generally be larger. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the array WORK and the minimum size of the array IWORK, and returns these values as the first entries of the WORK and IWORK arrays, and no error message related to LWORK is issued by XERBLA.``` [out] IWORK ``` IWORK is INTEGER array, dimension (MAX(1,LIWORK)) LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), where MINMN = MIN( M,N ). On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.``` [out] INFO ``` INFO is INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. > 0: the algorithm for computing the SVD failed to converge; if INFO = i, i off-diagonal elements of an intermediate bidiagonal form did not converge to zero.```
Date
November 2011
Contributors:
Ming Gu and Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA

Definition at line 212 of file sgelsd.f.

212 *
213 * -- LAPACK driver routine (version 3.4.0) --
214 * -- LAPACK is a software package provided by Univ. of Tennessee, --
215 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
216 * November 2011
217 *
218 * .. Scalar Arguments ..
219  INTEGER info, lda, ldb, lwork, m, n, nrhs, rank
220  REAL rcond
221 * ..
222 * .. Array Arguments ..
223  INTEGER iwork( * )
224  REAL a( lda, * ), b( ldb, * ), s( * ), work( * )
225 * ..
226 *
227 * =====================================================================
228 *
229 * .. Parameters ..
230  REAL zero, one, two
231  parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
232 * ..
233 * .. Local Scalars ..
234  LOGICAL lquery
235  INTEGER iascl, ibscl, ie, il, itau, itaup, itauq,
236  \$ ldwork, liwork, maxmn, maxwrk, minmn, minwrk,
237  \$ mm, mnthr, nlvl, nwork, smlsiz, wlalsd
238  REAL anrm, bignum, bnrm, eps, sfmin, smlnum
239 * ..
240 * .. External Subroutines ..
241  EXTERNAL sgebrd, sgelqf, sgeqrf, slabad, slacpy, slalsd,
243 * ..
244 * .. External Functions ..
245  INTEGER ilaenv
246  REAL slamch, slange
247  EXTERNAL slamch, slange, ilaenv
248 * ..
249 * .. Intrinsic Functions ..
250  INTRINSIC int, log, max, min, real
251 * ..
252 * .. Executable Statements ..
253 *
254 * Test the input arguments.
255 *
256  info = 0
257  minmn = min( m, n )
258  maxmn = max( m, n )
259  lquery = ( lwork.EQ.-1 )
260  IF( m.LT.0 ) THEN
261  info = -1
262  ELSE IF( n.LT.0 ) THEN
263  info = -2
264  ELSE IF( nrhs.LT.0 ) THEN
265  info = -3
266  ELSE IF( lda.LT.max( 1, m ) ) THEN
267  info = -5
268  ELSE IF( ldb.LT.max( 1, maxmn ) ) THEN
269  info = -7
270  END IF
271 *
272 * Compute workspace.
273 * (Note: Comments in the code beginning "Workspace:" describe the
274 * minimal amount of workspace needed at that point in the code,
275 * as well as the preferred amount for good performance.
276 * NB refers to the optimal block size for the immediately
277 * following subroutine, as returned by ILAENV.)
278 *
279  IF( info.EQ.0 ) THEN
280  minwrk = 1
281  maxwrk = 1
282  liwork = 1
283  IF( minmn.GT.0 ) THEN
284  smlsiz = ilaenv( 9, 'SGELSD', ' ', 0, 0, 0, 0 )
285  mnthr = ilaenv( 6, 'SGELSD', ' ', m, n, nrhs, -1 )
286  nlvl = max( int( log( REAL( MINMN ) / REAL( SMLSIZ + 1 ) ) /
287  \$ log( two ) ) + 1, 0 )
288  liwork = 3*minmn*nlvl + 11*minmn
289  mm = m
290  IF( m.GE.n .AND. m.GE.mnthr ) THEN
291 *
292 * Path 1a - overdetermined, with many more rows than
293 * columns.
294 *
295  mm = n
296  maxwrk = max( maxwrk, n + n*ilaenv( 1, 'SGEQRF', ' ', m,
297  \$ n, -1, -1 ) )
298  maxwrk = max( maxwrk, n + nrhs*ilaenv( 1, 'SORMQR', 'LT',
299  \$ m, nrhs, n, -1 ) )
300  END IF
301  IF( m.GE.n ) THEN
302 *
303 * Path 1 - overdetermined or exactly determined.
304 *
305  maxwrk = max( maxwrk, 3*n + ( mm + n )*ilaenv( 1,
306  \$ 'SGEBRD', ' ', mm, n, -1, -1 ) )
307  maxwrk = max( maxwrk, 3*n + nrhs*ilaenv( 1, 'SORMBR',
308  \$ 'QLT', mm, nrhs, n, -1 ) )
309  maxwrk = max( maxwrk, 3*n + ( n - 1 )*ilaenv( 1,
310  \$ 'SORMBR', 'PLN', n, nrhs, n, -1 ) )
311  wlalsd = 9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs +
312  \$ ( smlsiz + 1 )**2
313  maxwrk = max( maxwrk, 3*n + wlalsd )
314  minwrk = max( 3*n + mm, 3*n + nrhs, 3*n + wlalsd )
315  END IF
316  IF( n.GT.m ) THEN
317  wlalsd = 9*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs +
318  \$ ( smlsiz + 1 )**2
319  IF( n.GE.mnthr ) THEN
320 *
321 * Path 2a - underdetermined, with many more columns
322 * than rows.
323 *
324  maxwrk = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1,
325  \$ -1 )
326  maxwrk = max( maxwrk, m*m + 4*m + 2*m*ilaenv( 1,
327  \$ 'SGEBRD', ' ', m, m, -1, -1 ) )
328  maxwrk = max( maxwrk, m*m + 4*m + nrhs*ilaenv( 1,
329  \$ 'SORMBR', 'QLT', m, nrhs, m, -1 ) )
330  maxwrk = max( maxwrk, m*m + 4*m + ( m - 1 )*ilaenv( 1,
331  \$ 'SORMBR', 'PLN', m, nrhs, m, -1 ) )
332  IF( nrhs.GT.1 ) THEN
333  maxwrk = max( maxwrk, m*m + m + m*nrhs )
334  ELSE
335  maxwrk = max( maxwrk, m*m + 2*m )
336  END IF
337  maxwrk = max( maxwrk, m + nrhs*ilaenv( 1, 'SORMLQ',
338  \$ 'LT', n, nrhs, m, -1 ) )
339  maxwrk = max( maxwrk, m*m + 4*m + wlalsd )
340 ! XXX: Ensure the Path 2a case below is triggered. The workspace
341 ! calculation should use queries for all routines eventually.
342  maxwrk = max( maxwrk,
343  \$ 4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) )
344  ELSE
345 *
346 * Path 2 - remaining underdetermined cases.
347 *
348  maxwrk = 3*m + ( n + m )*ilaenv( 1, 'SGEBRD', ' ', m,
349  \$ n, -1, -1 )
350  maxwrk = max( maxwrk, 3*m + nrhs*ilaenv( 1, 'SORMBR',
351  \$ 'QLT', m, nrhs, n, -1 ) )
352  maxwrk = max( maxwrk, 3*m + m*ilaenv( 1, 'SORMBR',
353  \$ 'PLN', n, nrhs, m, -1 ) )
354  maxwrk = max( maxwrk, 3*m + wlalsd )
355  END IF
356  minwrk = max( 3*m + nrhs, 3*m + m, 3*m + wlalsd )
357  END IF
358  END IF
359  minwrk = min( minwrk, maxwrk )
360  work( 1 ) = maxwrk
361  iwork( 1 ) = liwork
362 *
363  IF( lwork.LT.minwrk .AND. .NOT.lquery ) THEN
364  info = -12
365  END IF
366  END IF
367 *
368  IF( info.NE.0 ) THEN
369  CALL xerbla( 'SGELSD', -info )
370  RETURN
371  ELSE IF( lquery ) THEN
372  RETURN
373  END IF
374 *
375 * Quick return if possible.
376 *
377  IF( m.EQ.0 .OR. n.EQ.0 ) THEN
378  rank = 0
379  RETURN
380  END IF
381 *
382 * Get machine parameters.
383 *
384  eps = slamch( 'P' )
385  sfmin = slamch( 'S' )
386  smlnum = sfmin / eps
387  bignum = one / smlnum
388  CALL slabad( smlnum, bignum )
389 *
390 * Scale A if max entry outside range [SMLNUM,BIGNUM].
391 *
392  anrm = slange( 'M', m, n, a, lda, work )
393  iascl = 0
394  IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
395 *
396 * Scale matrix norm up to SMLNUM.
397 *
398  CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
399  iascl = 1
400  ELSE IF( anrm.GT.bignum ) THEN
401 *
402 * Scale matrix norm down to BIGNUM.
403 *
404  CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
405  iascl = 2
406  ELSE IF( anrm.EQ.zero ) THEN
407 *
408 * Matrix all zero. Return zero solution.
409 *
410  CALL slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb )
411  CALL slaset( 'F', minmn, 1, zero, zero, s, 1 )
412  rank = 0
413  GO TO 10
414  END IF
415 *
416 * Scale B if max entry outside range [SMLNUM,BIGNUM].
417 *
418  bnrm = slange( 'M', m, nrhs, b, ldb, work )
419  ibscl = 0
420  IF( bnrm.GT.zero .AND. bnrm.LT.smlnum ) THEN
421 *
422 * Scale matrix norm up to SMLNUM.
423 *
424  CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info )
425  ibscl = 1
426  ELSE IF( bnrm.GT.bignum ) THEN
427 *
428 * Scale matrix norm down to BIGNUM.
429 *
430  CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info )
431  ibscl = 2
432  END IF
433 *
434 * If M < N make sure certain entries of B are zero.
435 *
436  IF( m.LT.n )
437  \$ CALL slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb )
438 *
439 * Overdetermined case.
440 *
441  IF( m.GE.n ) THEN
442 *
443 * Path 1 - overdetermined or exactly determined.
444 *
445  mm = m
446  IF( m.GE.mnthr ) THEN
447 *
448 * Path 1a - overdetermined, with many more rows than columns.
449 *
450  mm = n
451  itau = 1
452  nwork = itau + n
453 *
454 * Compute A=Q*R.
455 * (Workspace: need 2*N, prefer N+N*NB)
456 *
457  CALL sgeqrf( m, n, a, lda, work( itau ), work( nwork ),
458  \$ lwork-nwork+1, info )
459 *
460 * Multiply B by transpose(Q).
461 * (Workspace: need N+NRHS, prefer N+NRHS*NB)
462 *
463  CALL sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,
464  \$ ldb, work( nwork ), lwork-nwork+1, info )
465 *
466 * Zero out below R.
467 *
468  IF( n.GT.1 ) THEN
469  CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda )
470  END IF
471  END IF
472 *
473  ie = 1
474  itauq = ie + n
475  itaup = itauq + n
476  nwork = itaup + n
477 *
478 * Bidiagonalize R in A.
479 * (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
480 *
481  CALL sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),
482  \$ work( itaup ), work( nwork ), lwork-nwork+1,
483  \$ info )
484 *
485 * Multiply B by transpose of left bidiagonalizing vectors of R.
486 * (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
487 *
488  CALL sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),
489  \$ b, ldb, work( nwork ), lwork-nwork+1, info )
490 *
491 * Solve the bidiagonal least squares problem.
492 *
493  CALL slalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,
494  \$ rcond, rank, work( nwork ), iwork, info )
495  IF( info.NE.0 ) THEN
496  GO TO 10
497  END IF
498 *
499 * Multiply B by right bidiagonalizing vectors of R.
500 *
501  CALL sormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),
502  \$ b, ldb, work( nwork ), lwork-nwork+1, info )
503 *
504  ELSE IF( n.GE.mnthr .AND. lwork.GE.4*m+m*m+
505  \$ max( m, 2*m-4, nrhs, n-3*m, wlalsd ) ) THEN
506 *
507 * Path 2a - underdetermined, with many more columns than rows
508 * and sufficient workspace for an efficient algorithm.
509 *
510  ldwork = m
511  IF( lwork.GE.max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),
512  \$ m*lda+m+m*nrhs, 4*m+m*lda+wlalsd ) )ldwork = lda
513  itau = 1
514  nwork = m + 1
515 *
516 * Compute A=L*Q.
517 * (Workspace: need 2*M, prefer M+M*NB)
518 *
519  CALL sgelqf( m, n, a, lda, work( itau ), work( nwork ),
520  \$ lwork-nwork+1, info )
521  il = nwork
522 *
523 * Copy L to WORK(IL), zeroing out above its diagonal.
524 *
525  CALL slacpy( 'L', m, m, a, lda, work( il ), ldwork )
526  CALL slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),
527  \$ ldwork )
528  ie = il + ldwork*m
529  itauq = ie + m
530  itaup = itauq + m
531  nwork = itaup + m
532 *
533 * Bidiagonalize L in WORK(IL).
534 * (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
535 *
536  CALL sgebrd( m, m, work( il ), ldwork, s, work( ie ),
537  \$ work( itauq ), work( itaup ), work( nwork ),
538  \$ lwork-nwork+1, info )
539 *
540 * Multiply B by transpose of left bidiagonalizing vectors of L.
541 * (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
542 *
543  CALL sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,
544  \$ work( itauq ), b, ldb, work( nwork ),
545  \$ lwork-nwork+1, info )
546 *
547 * Solve the bidiagonal least squares problem.
548 *
549  CALL slalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,
550  \$ rcond, rank, work( nwork ), iwork, info )
551  IF( info.NE.0 ) THEN
552  GO TO 10
553  END IF
554 *
555 * Multiply B by right bidiagonalizing vectors of L.
556 *
557  CALL sormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,
558  \$ work( itaup ), b, ldb, work( nwork ),
559  \$ lwork-nwork+1, info )
560 *
561 * Zero out below first M rows of B.
562 *
563  CALL slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb )
564  nwork = itau + m
565 *
566 * Multiply transpose(Q) by B.
567 * (Workspace: need M+NRHS, prefer M+NRHS*NB)
568 *
569  CALL sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,
570  \$ ldb, work( nwork ), lwork-nwork+1, info )
571 *
572  ELSE
573 *
574 * Path 2 - remaining underdetermined cases.
575 *
576  ie = 1
577  itauq = ie + m
578  itaup = itauq + m
579  nwork = itaup + m
580 *
581 * Bidiagonalize A.
582 * (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
583 *
584  CALL sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),
585  \$ work( itaup ), work( nwork ), lwork-nwork+1,
586  \$ info )
587 *
588 * Multiply B by transpose of left bidiagonalizing vectors.
589 * (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
590 *
591  CALL sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),
592  \$ b, ldb, work( nwork ), lwork-nwork+1, info )
593 *
594 * Solve the bidiagonal least squares problem.
595 *
596  CALL slalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,
597  \$ rcond, rank, work( nwork ), iwork, info )
598  IF( info.NE.0 ) THEN
599  GO TO 10
600  END IF
601 *
602 * Multiply B by right bidiagonalizing vectors of A.
603 *
604  CALL sormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),
605  \$ b, ldb, work( nwork ), lwork-nwork+1, info )
606 *
607  END IF
608 *
609 * Undo scaling.
610 *
611  IF( iascl.EQ.1 ) THEN
612  CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info )
613  CALL slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,
614  \$ info )
615  ELSE IF( iascl.EQ.2 ) THEN
616  CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info )
617  CALL slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,
618  \$ info )
619  END IF
620  IF( ibscl.EQ.1 ) THEN
621  CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info )
622  ELSE IF( ibscl.EQ.2 ) THEN
623  CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info )
624  END IF
625 *
626  10 CONTINUE
627  work( 1 ) = maxwrk
628  iwork( 1 ) = liwork
629  RETURN
630 *
631 * End of SGELSD
632 *
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine sormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMLQ
Definition: sormlq.f:170
subroutine sgebrd(M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO)
SGEBRD
Definition: sgebrd.f:207
subroutine slalsd(UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO)
SLALSD uses the singular value decomposition of A to solve the least squares problem.
Definition: slalsd.f:181
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
Definition: sormqr.f:170
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
Definition: sgelqf.f:137
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
Definition: sgeqrf.f:138
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
Definition: tstiee.f:83
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.
Definition: slascl.f:141
subroutine sormbr(VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMBR
Definition: sormbr.f:198
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:116
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...
Definition: slaset.f:112

Here is the call graph for this function:

Here is the caller graph for this function:

 subroutine sgelss ( integer M, integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, real, dimension( ldb, * ) B, integer LDB, real, dimension( * ) S, real RCOND, integer RANK, real, dimension( * ) WORK, integer LWORK, integer INFO )

SGELSS solves overdetermined or underdetermined systems for GE matrices

Download SGELSS + dependencies [TGZ] [ZIP] [TXT]

Purpose:
``` SGELSS computes the minimum norm solution to a real linear least
squares problem:

Minimize 2-norm(| b - A*x |).

using the singular value decomposition (SVD) of A. A is an M-by-N
matrix which may be rank-deficient.

Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
X.

The effective rank of A is determined by treating as zero those
singular values which are less than RCOND times the largest singular
value.```
Parameters
 [in] M ``` M is INTEGER The number of rows of the matrix A. M >= 0.``` [in] N ``` N is INTEGER The number of columns of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0.``` [in,out] A ``` A is REAL array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, the first min(m,n) rows of A are overwritten with its right singular vectors, stored rowwise.``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,M).``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the M-by-NRHS right hand side matrix B. On exit, B is overwritten by the N-by-NRHS solution matrix X. If m >= n and RANK = n, the residual sum-of-squares for the solution in the i-th column is given by the sum of squares of elements n+1:m in that column.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,max(M,N)).``` [out] S ``` S is REAL array, dimension (min(M,N)) The singular values of A in decreasing order. The condition number of A in the 2-norm = S(1)/S(min(m,n)).``` [in] RCOND ``` RCOND is REAL RCOND is used to determine the effective rank of A. Singular values S(i) <= RCOND*S(1) are treated as zero. If RCOND < 0, machine precision is used instead.``` [out] RANK ``` RANK is INTEGER The effective rank of A, i.e., the number of singular values which are greater than RCOND*S(1).``` [out] WORK ``` WORK is REAL array, dimension (MAX(1,LWORK)) On exit, if INFO = 0, WORK(1) returns the optimal LWORK.``` [in] LWORK ``` LWORK is INTEGER The dimension of the array WORK. LWORK >= 1, and also: LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) For good performance, LWORK should generally be larger. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA.``` [out] INFO ``` INFO is INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. > 0: the algorithm for computing the SVD failed to converge; if INFO = i, i off-diagonal elements of an intermediate bidiagonal form did not converge to zero.```
Date
November 2011

Definition at line 174 of file sgelss.f.

174 *
175 * -- LAPACK driver routine (version 3.4.0) --
176 * -- LAPACK is a software package provided by Univ. of Tennessee, --
177 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
178 * November 2011
179 *
180 * .. Scalar Arguments ..
181  INTEGER info, lda, ldb, lwork, m, n, nrhs, rank
182  REAL rcond
183 * ..
184 * .. Array Arguments ..
185  REAL a( lda, * ), b( ldb, * ), s( * ), work( * )
186 * ..
187 *
188 * =====================================================================
189 *
190 * .. Parameters ..
191  REAL zero, one
192  parameter( zero = 0.0e+0, one = 1.0e+0 )
193 * ..
194 * .. Local Scalars ..
195  LOGICAL lquery
196  INTEGER bdspac, bl, chunk, i, iascl, ibscl, ie, il,
197  \$ itau, itaup, itauq, iwork, ldwork, maxmn,
198  \$ maxwrk, minmn, minwrk, mm, mnthr
199  INTEGER lwork_sgeqrf, lwork_sormqr, lwork_sgebrd,
200  \$ lwork_sormbr, lwork_sorgbr, lwork_sormlq
201  REAL anrm, bignum, bnrm, eps, sfmin, smlnum, thr
202 * ..
203 * .. Local Arrays ..
204  REAL dum( 1 )
205 * ..
206 * .. External Subroutines ..
207  EXTERNAL sbdsqr, scopy, sgebrd, sgelqf, sgemm, sgemv,
210 * ..
211 * .. External Functions ..
212  INTEGER ilaenv
213  REAL slamch, slange
214  EXTERNAL ilaenv, slamch, slange
215 * ..
216 * .. Intrinsic Functions ..
217  INTRINSIC max, min
218 * ..
219 * .. Executable Statements ..
220 *
221 * Test the input arguments
222 *
223  info = 0
224  minmn = min( m, n )
225  maxmn = max( m, n )
226  lquery = ( lwork.EQ.-1 )
227  IF( m.LT.0 ) THEN
228  info = -1
229  ELSE IF( n.LT.0 ) THEN
230  info = -2
231  ELSE IF( nrhs.LT.0 ) THEN
232  info = -3
233  ELSE IF( lda.LT.max( 1, m ) ) THEN
234  info = -5
235  ELSE IF( ldb.LT.max( 1, maxmn ) ) THEN
236  info = -7
237  END IF
238 *
239 * Compute workspace
240 * (Note: Comments in the code beginning "Workspace:" describe the
241 * minimal amount of workspace needed at that point in the code,
242 * as well as the preferred amount for good performance.
243 * NB refers to the optimal block size for the immediately
244 * following subroutine, as returned by ILAENV.)
245 *
246  IF( info.EQ.0 ) THEN
247  minwrk = 1
248  maxwrk = 1
249  IF( minmn.GT.0 ) THEN
250  mm = m
251  mnthr = ilaenv( 6, 'SGELSS', ' ', m, n, nrhs, -1 )
252  IF( m.GE.n .AND. m.GE.mnthr ) THEN
253 *
254 * Path 1a - overdetermined, with many more rows than
255 * columns
256 *
257 * Compute space needed for SGEQRF
258  CALL sgeqrf( m, n, a, lda, dum(1), dum(1), -1, info )
259  lwork_sgeqrf=dum(1)
260 * Compute space needed for SORMQR
261  CALL sormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1), b,
262  \$ ldb, dum(1), -1, info )
263  lwork_sormqr=dum(1)
264  mm = n
265  maxwrk = max( maxwrk, n + lwork_sgeqrf )
266  maxwrk = max( maxwrk, n + lwork_sormqr )
267  END IF
268  IF( m.GE.n ) THEN
269 *
270 * Path 1 - overdetermined or exactly determined
271 *
272 * Compute workspace needed for SBDSQR
273 *
274  bdspac = max( 1, 5*n )
275 * Compute space needed for SGEBRD
276  CALL sgebrd( mm, n, a, lda, s, dum(1), dum(1),
277  \$ dum(1), dum(1), -1, info )
278  lwork_sgebrd=dum(1)
279 * Compute space needed for SORMBR
280  CALL sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1),
281  \$ b, ldb, dum(1), -1, info )
282  lwork_sormbr=dum(1)
283 * Compute space needed for SORGBR
284  CALL sorgbr( 'P', n, n, n, a, lda, dum(1),
285  \$ dum(1), -1, info )
286  lwork_sorgbr=dum(1)
287 * Compute total workspace needed
288  maxwrk = max( maxwrk, 3*n + lwork_sgebrd )
289  maxwrk = max( maxwrk, 3*n + lwork_sormbr )
290  maxwrk = max( maxwrk, 3*n + lwork_sorgbr )
291  maxwrk = max( maxwrk, bdspac )
292  maxwrk = max( maxwrk, n*nrhs )
293  minwrk = max( 3*n + mm, 3*n + nrhs, bdspac )
294  maxwrk = max( minwrk, maxwrk )
295  END IF
296  IF( n.GT.m ) THEN
297 *
298 * Compute workspace needed for SBDSQR
299 *
300  bdspac = max( 1, 5*m )
301  minwrk = max( 3*m+nrhs, 3*m+n, bdspac )
302  IF( n.GE.mnthr ) THEN
303 *
304 * Path 2a - underdetermined, with many more columns
305 * than rows
306 *
307 * Compute space needed for SGEBRD
308  CALL sgebrd( m, m, a, lda, s, dum(1), dum(1),
309  \$ dum(1), dum(1), -1, info )
310  lwork_sgebrd=dum(1)
311 * Compute space needed for SORMBR
312  CALL sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,
313  \$ dum(1), b, ldb, dum(1), -1, info )
314  lwork_sormbr=dum(1)
315 * Compute space needed for SORGBR
316  CALL sorgbr( 'P', m, m, m, a, lda, dum(1),
317  \$ dum(1), -1, info )
318  lwork_sorgbr=dum(1)
319 * Compute space needed for SORMLQ
320  CALL sormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1),
321  \$ b, ldb, dum(1), -1, info )
322  lwork_sormlq=dum(1)
323 * Compute total workspace needed
324  maxwrk = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1,
325  \$ -1 )
326  maxwrk = max( maxwrk, m*m + 4*m + lwork_sgebrd )
327  maxwrk = max( maxwrk, m*m + 4*m + lwork_sormbr )
328  maxwrk = max( maxwrk, m*m + 4*m + lwork_sorgbr )
329  maxwrk = max( maxwrk, m*m + m + bdspac )
330  IF( nrhs.GT.1 ) THEN
331  maxwrk = max( maxwrk, m*m + m + m*nrhs )
332  ELSE
333  maxwrk = max( maxwrk, m*m + 2*m )
334  END IF
335  maxwrk = max( maxwrk, m + lwork_sormlq )
336  ELSE
337 *
338 * Path 2 - underdetermined
339 *
340 * Compute space needed for SGEBRD
341  CALL sgebrd( m, n, a, lda, s, dum(1), dum(1),
342  \$ dum(1), dum(1), -1, info )
343  lwork_sgebrd=dum(1)
344 * Compute space needed for SORMBR
345  CALL sormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,
346  \$ dum(1), b, ldb, dum(1), -1, info )
347  lwork_sormbr=dum(1)
348 * Compute space needed for SORGBR
349  CALL sorgbr( 'P', m, n, m, a, lda, dum(1),
350  \$ dum(1), -1, info )
351  lwork_sorgbr=dum(1)
352  maxwrk = 3*m + lwork_sgebrd
353  maxwrk = max( maxwrk, 3*m + lwork_sormbr )
354  maxwrk = max( maxwrk, 3*m + lwork_sorgbr )
355  maxwrk = max( maxwrk, bdspac )
356  maxwrk = max( maxwrk, n*nrhs )
357  END IF
358  END IF
359  maxwrk = max( minwrk, maxwrk )
360  END IF
361  work( 1 ) = maxwrk
362 *
363  IF( lwork.LT.minwrk .AND. .NOT.lquery )
364  \$ info = -12
365  END IF
366 *
367  IF( info.NE.0 ) THEN
368  CALL xerbla( 'SGELSS', -info )
369  RETURN
370  ELSE IF( lquery ) THEN
371  RETURN
372  END IF
373 *
374 * Quick return if possible
375 *
376  IF( m.EQ.0 .OR. n.EQ.0 ) THEN
377  rank = 0
378  RETURN
379  END IF
380 *
381 * Get machine parameters
382 *
383  eps = slamch( 'P' )
384  sfmin = slamch( 'S' )
385  smlnum = sfmin / eps
386  bignum = one / smlnum
387  CALL slabad( smlnum, bignum )
388 *
389 * Scale A if max element outside range [SMLNUM,BIGNUM]
390 *
391  anrm = slange( 'M', m, n, a, lda, work )
392  iascl = 0
393  IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
394 *
395 * Scale matrix norm up to SMLNUM
396 *
397  CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
398  iascl = 1
399  ELSE IF( anrm.GT.bignum ) THEN
400 *
401 * Scale matrix norm down to BIGNUM
402 *
403  CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
404  iascl = 2
405  ELSE IF( anrm.EQ.zero ) THEN
406 *
407 * Matrix all zero. Return zero solution.
408 *
409  CALL slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb )
410  CALL slaset( 'F', minmn, 1, zero, zero, s, 1 )
411  rank = 0
412  GO TO 70
413  END IF
414 *
415 * Scale B if max element outside range [SMLNUM,BIGNUM]
416 *
417  bnrm = slange( 'M', m, nrhs, b, ldb, work )
418  ibscl = 0
419  IF( bnrm.GT.zero .AND. bnrm.LT.smlnum ) THEN
420 *
421 * Scale matrix norm up to SMLNUM
422 *
423  CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info )
424  ibscl = 1
425  ELSE IF( bnrm.GT.bignum ) THEN
426 *
427 * Scale matrix norm down to BIGNUM
428 *
429  CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info )
430  ibscl = 2
431  END IF
432 *
433 * Overdetermined case
434 *
435  IF( m.GE.n ) THEN
436 *
437 * Path 1 - overdetermined or exactly determined
438 *
439  mm = m
440  IF( m.GE.mnthr ) THEN
441 *
442 * Path 1a - overdetermined, with many more rows than columns
443 *
444  mm = n
445  itau = 1
446  iwork = itau + n
447 *
448 * Compute A=Q*R
449 * (Workspace: need 2*N, prefer N+N*NB)
450 *
451  CALL sgeqrf( m, n, a, lda, work( itau ), work( iwork ),
452  \$ lwork-iwork+1, info )
453 *
454 * Multiply B by transpose(Q)
455 * (Workspace: need N+NRHS, prefer N+NRHS*NB)
456 *
457  CALL sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,
458  \$ ldb, work( iwork ), lwork-iwork+1, info )
459 *
460 * Zero out below R
461 *
462  IF( n.GT.1 )
463  \$ CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda )
464  END IF
465 *
466  ie = 1
467  itauq = ie + n
468  itaup = itauq + n
469  iwork = itaup + n
470 *
471 * Bidiagonalize R in A
472 * (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
473 *
474  CALL sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),
475  \$ work( itaup ), work( iwork ), lwork-iwork+1,
476  \$ info )
477 *
478 * Multiply B by transpose of left bidiagonalizing vectors of R
479 * (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
480 *
481  CALL sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),
482  \$ b, ldb, work( iwork ), lwork-iwork+1, info )
483 *
484 * Generate right bidiagonalizing vectors of R in A
485 * (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
486 *
487  CALL sorgbr( 'P', n, n, n, a, lda, work( itaup ),
488  \$ work( iwork ), lwork-iwork+1, info )
489  iwork = ie + n
490 *
491 * Perform bidiagonal QR iteration
492 * multiply B by transpose of left singular vectors
493 * compute right singular vectors in A
494 * (Workspace: need BDSPAC)
495 *
496  CALL sbdsqr( 'U', n, n, 0, nrhs, s, work( ie ), a, lda, dum,
497  \$ 1, b, ldb, work( iwork ), info )
498  IF( info.NE.0 )
499  \$ GO TO 70
500 *
501 * Multiply B by reciprocals of singular values
502 *
503  thr = max( rcond*s( 1 ), sfmin )
504  IF( rcond.LT.zero )
505  \$ thr = max( eps*s( 1 ), sfmin )
506  rank = 0
507  DO 10 i = 1, n
508  IF( s( i ).GT.thr ) THEN
509  CALL srscl( nrhs, s( i ), b( i, 1 ), ldb )
510  rank = rank + 1
511  ELSE
512  CALL slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb )
513  END IF
514  10 CONTINUE
515 *
516 * Multiply B by right singular vectors
517 * (Workspace: need N, prefer N*NRHS)
518 *
519  IF( lwork.GE.ldb*nrhs .AND. nrhs.GT.1 ) THEN
520  CALL sgemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,
521  \$ work, ldb )
522  CALL slacpy( 'G', n, nrhs, work, ldb, b, ldb )
523  ELSE IF( nrhs.GT.1 ) THEN
524  chunk = lwork / n
525  DO 20 i = 1, nrhs, chunk
526  bl = min( nrhs-i+1, chunk )
527  CALL sgemm( 'T', 'N', n, bl, n, one, a, lda, b( 1, i ),
528  \$ ldb, zero, work, n )
529  CALL slacpy( 'G', n, bl, work, n, b( 1, i ), ldb )
530  20 CONTINUE
531  ELSE
532  CALL sgemv( 'T', n, n, one, a, lda, b, 1, zero, work, 1 )
533  CALL scopy( n, work, 1, b, 1 )
534  END IF
535 *
536  ELSE IF( n.GE.mnthr .AND. lwork.GE.4*m+m*m+
537  \$ max( m, 2*m-4, nrhs, n-3*m ) ) THEN
538 *
539 * Path 2a - underdetermined, with many more columns than rows
540 * and sufficient workspace for an efficient algorithm
541 *
542  ldwork = m
543  IF( lwork.GE.max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),
544  \$ m*lda+m+m*nrhs ) )ldwork = lda
545  itau = 1
546  iwork = m + 1
547 *
548 * Compute A=L*Q
549 * (Workspace: need 2*M, prefer M+M*NB)
550 *
551  CALL sgelqf( m, n, a, lda, work( itau ), work( iwork ),
552  \$ lwork-iwork+1, info )
553  il = iwork
554 *
555 * Copy L to WORK(IL), zeroing out above it
556 *
557  CALL slacpy( 'L', m, m, a, lda, work( il ), ldwork )
558  CALL slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),
559  \$ ldwork )
560  ie = il + ldwork*m
561  itauq = ie + m
562  itaup = itauq + m
563  iwork = itaup + m
564 *
565 * Bidiagonalize L in WORK(IL)
566 * (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
567 *
568  CALL sgebrd( m, m, work( il ), ldwork, s, work( ie ),
569  \$ work( itauq ), work( itaup ), work( iwork ),
570  \$ lwork-iwork+1, info )
571 *
572 * Multiply B by transpose of left bidiagonalizing vectors of L
573 * (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
574 *
575  CALL sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,
576  \$ work( itauq ), b, ldb, work( iwork ),
577  \$ lwork-iwork+1, info )
578 *
579 * Generate right bidiagonalizing vectors of R in WORK(IL)
580 * (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
581 *
582  CALL sorgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),
583  \$ work( iwork ), lwork-iwork+1, info )
584  iwork = ie + m
585 *
586 * Perform bidiagonal QR iteration,
587 * computing right singular vectors of L in WORK(IL) and
588 * multiplying B by transpose of left singular vectors
589 * (Workspace: need M*M+M+BDSPAC)
590 *
591  CALL sbdsqr( 'U', m, m, 0, nrhs, s, work( ie ), work( il ),
592  \$ ldwork, a, lda, b, ldb, work( iwork ), info )
593  IF( info.NE.0 )
594  \$ GO TO 70
595 *
596 * Multiply B by reciprocals of singular values
597 *
598  thr = max( rcond*s( 1 ), sfmin )
599  IF( rcond.LT.zero )
600  \$ thr = max( eps*s( 1 ), sfmin )
601  rank = 0
602  DO 30 i = 1, m
603  IF( s( i ).GT.thr ) THEN
604  CALL srscl( nrhs, s( i ), b( i, 1 ), ldb )
605  rank = rank + 1
606  ELSE
607  CALL slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb )
608  END IF
609  30 CONTINUE
610  iwork = ie
611 *
612 * Multiply B by right singular vectors of L in WORK(IL)
613 * (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
614 *
615  IF( lwork.GE.ldb*nrhs+iwork-1 .AND. nrhs.GT.1 ) THEN
616  CALL sgemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,
617  \$ b, ldb, zero, work( iwork ), ldb )
618  CALL slacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb )
619  ELSE IF( nrhs.GT.1 ) THEN
620  chunk = ( lwork-iwork+1 ) / m
621  DO 40 i = 1, nrhs, chunk
622  bl = min( nrhs-i+1, chunk )
623  CALL sgemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,
624  \$ b( 1, i ), ldb, zero, work( iwork ), m )
625  CALL slacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),
626  \$ ldb )
627  40 CONTINUE
628  ELSE
629  CALL sgemv( 'T', m, m, one, work( il ), ldwork, b( 1, 1 ),
630  \$ 1, zero, work( iwork ), 1 )
631  CALL scopy( m, work( iwork ), 1, b( 1, 1 ), 1 )
632  END IF
633 *
634 * Zero out below first M rows of B
635 *
636  CALL slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb )
637  iwork = itau + m
638 *
639 * Multiply transpose(Q) by B
640 * (Workspace: need M+NRHS, prefer M+NRHS*NB)
641 *
642  CALL sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,
643  \$ ldb, work( iwork ), lwork-iwork+1, info )
644 *
645  ELSE
646 *
647 * Path 2 - remaining underdetermined cases
648 *
649  ie = 1
650  itauq = ie + m
651  itaup = itauq + m
652  iwork = itaup + m
653 *
654 * Bidiagonalize A
655 * (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
656 *
657  CALL sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),
658  \$ work( itaup ), work( iwork ), lwork-iwork+1,
659  \$ info )
660 *
661 * Multiply B by transpose of left bidiagonalizing vectors
662 * (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
663 *
664  CALL sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),
665  \$ b, ldb, work( iwork ), lwork-iwork+1, info )
666 *
667 * Generate right bidiagonalizing vectors in A
668 * (Workspace: need 4*M, prefer 3*M+M*NB)
669 *
670  CALL sorgbr( 'P', m, n, m, a, lda, work( itaup ),
671  \$ work( iwork ), lwork-iwork+1, info )
672  iwork = ie + m
673 *
674 * Perform bidiagonal QR iteration,
675 * computing right singular vectors of A in A and
676 * multiplying B by transpose of left singular vectors
677 * (Workspace: need BDSPAC)
678 *
679  CALL sbdsqr( 'L', m, n, 0, nrhs, s, work( ie ), a, lda, dum,
680  \$ 1, b, ldb, work( iwork ), info )
681  IF( info.NE.0 )
682  \$ GO TO 70
683 *
684 * Multiply B by reciprocals of singular values
685 *
686  thr = max( rcond*s( 1 ), sfmin )
687  IF( rcond.LT.zero )
688  \$ thr = max( eps*s( 1 ), sfmin )
689  rank = 0
690  DO 50 i = 1, m
691  IF( s( i ).GT.thr ) THEN
692  CALL srscl( nrhs, s( i ), b( i, 1 ), ldb )
693  rank = rank + 1
694  ELSE
695  CALL slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb )
696  END IF
697  50 CONTINUE
698 *
699 * Multiply B by right singular vectors of A
700 * (Workspace: need N, prefer N*NRHS)
701 *
702  IF( lwork.GE.ldb*nrhs .AND. nrhs.GT.1 ) THEN
703  CALL sgemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,
704  \$ work, ldb )
705  CALL slacpy( 'F', n, nrhs, work, ldb, b, ldb )
706  ELSE IF( nrhs.GT.1 ) THEN
707  chunk = lwork / n
708  DO 60 i = 1, nrhs, chunk
709  bl = min( nrhs-i+1, chunk )
710  CALL sgemm( 'T', 'N', n, bl, m, one, a, lda, b( 1, i ),
711  \$ ldb, zero, work, n )
712  CALL slacpy( 'F', n, bl, work, n, b( 1, i ), ldb )
713  60 CONTINUE
714  ELSE
715  CALL sgemv( 'T', m, n, one, a, lda, b, 1, zero, work, 1 )
716  CALL scopy( n, work, 1, b, 1 )
717  END IF
718  END IF
719 *
720 * Undo scaling
721 *
722  IF( iascl.EQ.1 ) THEN
723  CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info )
724  CALL slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,
725  \$ info )
726  ELSE IF( iascl.EQ.2 ) THEN
727  CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info )
728  CALL slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,
729  \$ info )
730  END IF
731  IF( ibscl.EQ.1 ) THEN
732  CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info )
733  ELSE IF( ibscl.EQ.2 ) THEN
734  CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info )
735  END IF
736 *
737  70 CONTINUE
738  work( 1 ) = maxwrk
739  RETURN
740 *
741 * End of SGELSS
742 *
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
Definition: sgemv.f:158
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine sormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMLQ
Definition: sormlq.f:170
subroutine sgebrd(M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO)
SGEBRD
Definition: sgebrd.f:207
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
Definition: sormqr.f:170
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:53
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine sbdsqr(UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO)
SBDSQR
Definition: sbdsqr.f:232
subroutine sorgbr(VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGBR
Definition: sorgbr.f:159
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
Definition: sgelqf.f:137
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
Definition: sgeqrf.f:138
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
Definition: sgemm.f:189
subroutine srscl(N, SA, SX, INCX)
SRSCL multiplies a vector by the reciprocal of a real scalar.
Definition: srscl.f:86
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
Definition: tstiee.f:83
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.
Definition: slascl.f:141
subroutine sormbr(VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMBR
Definition: sormbr.f:198
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:116
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...
Definition: slaset.f:112

Here is the call graph for this function:

Here is the caller graph for this function:

 subroutine sgelsx ( integer M, integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, real, dimension( ldb, * ) B, integer LDB, integer, dimension( * ) JPVT, real RCOND, integer RANK, real, dimension( * ) WORK, integer INFO )

SGELSX solves overdetermined or underdetermined systems for GE matrices

Download SGELSX + dependencies [TGZ] [ZIP] [TXT]

Purpose:
``` This routine is deprecated and has been replaced by routine SGELSY.

SGELSX computes the minimum-norm solution to a real linear least
squares problem:
minimize || A * X - B ||
using a complete orthogonal factorization of A.  A is an M-by-N
matrix which may be rank-deficient.

Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.

The routine first computes a QR factorization with column pivoting:
A * P = Q * [ R11 R12 ]
[  0  R22 ]
with R11 defined as the largest leading submatrix whose estimated
condition number is less than 1/RCOND.  The order of R11, RANK,
is the effective rank of A.

Then, R22 is considered to be negligible, and R12 is annihilated
by orthogonal transformations from the right, arriving at the
complete orthogonal factorization:
A * P = Q * [ T11 0 ] * Z
[  0  0 ]
The minimum-norm solution is then
X = P * Z**T [ inv(T11)*Q1**T*B ]
[        0         ]
where Q1 consists of the first RANK columns of Q.```
Parameters
 [in] M ``` M is INTEGER The number of rows of the matrix A. M >= 0.``` [in] N ``` N is INTEGER The number of columns of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of matrices B and X. NRHS >= 0.``` [in,out] A ``` A is REAL array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, A has been overwritten by details of its complete orthogonal factorization.``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,M).``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the M-by-NRHS right hand side matrix B. On exit, the N-by-NRHS solution matrix X. If m >= n and RANK = n, the residual sum-of-squares for the solution in the i-th column is given by the sum of squares of elements N+1:M in that column.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,M,N).``` [in,out] JPVT ``` JPVT is INTEGER array, dimension (N) On entry, if JPVT(i) .ne. 0, the i-th column of A is an initial column, otherwise it is a free column. Before the QR factorization of A, all initial columns are permuted to the leading positions; only the remaining free columns are moved as a result of column pivoting during the factorization. On exit, if JPVT(i) = k, then the i-th column of A*P was the k-th column of A.``` [in] RCOND ``` RCOND is REAL RCOND is used to determine the effective rank of A, which is defined as the order of the largest leading triangular submatrix R11 in the QR factorization with pivoting of A, whose estimated condition number < 1/RCOND.``` [out] RANK ``` RANK is INTEGER The effective rank of A, i.e., the order of the submatrix R11. This is the same as the order of the submatrix T11 in the complete orthogonal factorization of A.``` [out] WORK ``` WORK is REAL array, dimension (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),``` [out] INFO ``` INFO is INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value```
Date
November 2011

Definition at line 180 of file sgelsx.f.

180 *
181 * -- LAPACK driver routine (version 3.4.0) --
182 * -- LAPACK is a software package provided by Univ. of Tennessee, --
183 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
184 * November 2011
185 *
186 * .. Scalar Arguments ..
187  INTEGER info, lda, ldb, m, n, nrhs, rank
188  REAL rcond
189 * ..
190 * .. Array Arguments ..
191  INTEGER jpvt( * )
192  REAL a( lda, * ), b( ldb, * ), work( * )
193 * ..
194 *
195 * =====================================================================
196 *
197 * .. Parameters ..
198  INTEGER imax, imin
199  parameter( imax = 1, imin = 2 )
200  REAL zero, one, done, ntdone
201  parameter( zero = 0.0e0, one = 1.0e0, done = zero,
202  \$ ntdone = one )
203 * ..
204 * .. Local Scalars ..
205  INTEGER i, iascl, ibscl, ismax, ismin, j, k, mn
206  REAL anrm, bignum, bnrm, c1, c2, s1, s2, smax,
207  \$ smaxpr, smin, sminpr, smlnum, t1, t2
208 * ..
209 * .. External Functions ..
210  REAL slamch, slange
211  EXTERNAL slamch, slange
212 * ..
213 * .. External Subroutines ..
214  EXTERNAL sgeqpf, slabad, slaic1, slascl, slaset, slatzm,
216 * ..
217 * .. Intrinsic Functions ..
218  INTRINSIC abs, max, min
219 * ..
220 * .. Executable Statements ..
221 *
222  mn = min( m, n )
223  ismin = mn + 1
224  ismax = 2*mn + 1
225 *
226 * Test the input arguments.
227 *
228  info = 0
229  IF( m.LT.0 ) THEN
230  info = -1
231  ELSE IF( n.LT.0 ) THEN
232  info = -2
233  ELSE IF( nrhs.LT.0 ) THEN
234  info = -3
235  ELSE IF( lda.LT.max( 1, m ) ) THEN
236  info = -5
237  ELSE IF( ldb.LT.max( 1, m, n ) ) THEN
238  info = -7
239  END IF
240 *
241  IF( info.NE.0 ) THEN
242  CALL xerbla( 'SGELSX', -info )
243  RETURN
244  END IF
245 *
246 * Quick return if possible
247 *
248  IF( min( m, n, nrhs ).EQ.0 ) THEN
249  rank = 0
250  RETURN
251  END IF
252 *
253 * Get machine parameters
254 *
255  smlnum = slamch( 'S' ) / slamch( 'P' )
256  bignum = one / smlnum
257  CALL slabad( smlnum, bignum )
258 *
259 * Scale A, B if max elements outside range [SMLNUM,BIGNUM]
260 *
261  anrm = slange( 'M', m, n, a, lda, work )
262  iascl = 0
263  IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
264 *
265 * Scale matrix norm up to SMLNUM
266 *
267  CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
268  iascl = 1
269  ELSE IF( anrm.GT.bignum ) THEN
270 *
271 * Scale matrix norm down to BIGNUM
272 *
273  CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
274  iascl = 2
275  ELSE IF( anrm.EQ.zero ) THEN
276 *
277 * Matrix all zero. Return zero solution.
278 *
279  CALL slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb )
280  rank = 0
281  GO TO 100
282  END IF
283 *
284  bnrm = slange( 'M', m, nrhs, b, ldb, work )
285  ibscl = 0
286  IF( bnrm.GT.zero .AND. bnrm.LT.smlnum ) THEN
287 *
288 * Scale matrix norm up to SMLNUM
289 *
290  CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info )
291  ibscl = 1
292  ELSE IF( bnrm.GT.bignum ) THEN
293 *
294 * Scale matrix norm down to BIGNUM
295 *
296  CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info )
297  ibscl = 2
298  END IF
299 *
300 * Compute QR factorization with column pivoting of A:
301 * A * P = Q * R
302 *
303  CALL sgeqpf( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ), info )
304 *
305 * workspace 3*N. Details of Householder rotations stored
306 * in WORK(1:MN).
307 *
308 * Determine RANK using incremental condition estimation
309 *
310  work( ismin ) = one
311  work( ismax ) = one
312  smax = abs( a( 1, 1 ) )
313  smin = smax
314  IF( abs( a( 1, 1 ) ).EQ.zero ) THEN
315  rank = 0
316  CALL slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb )
317  GO TO 100
318  ELSE
319  rank = 1
320  END IF
321 *
322  10 CONTINUE
323  IF( rank.LT.mn ) THEN
324  i = rank + 1
325  CALL slaic1( imin, rank, work( ismin ), smin, a( 1, i ),
326  \$ a( i, i ), sminpr, s1, c1 )
327  CALL slaic1( imax, rank, work( ismax ), smax, a( 1, i ),
328  \$ a( i, i ), smaxpr, s2, c2 )
329 *
330  IF( smaxpr*rcond.LE.sminpr ) THEN
331  DO 20 i = 1, rank
332  work( ismin+i-1 ) = s1*work( ismin+i-1 )
333  work( ismax+i-1 ) = s2*work( ismax+i-1 )
334  20 CONTINUE
335  work( ismin+rank ) = c1
336  work( ismax+rank ) = c2
337  smin = sminpr
338  smax = smaxpr
339  rank = rank + 1
340  GO TO 10
341  END IF
342  END IF
343 *
344 * Logically partition R = [ R11 R12 ]
345 * [ 0 R22 ]
346 * where R11 = R(1:RANK,1:RANK)
347 *
348 * [R11,R12] = [ T11, 0 ] * Y
349 *
350  IF( rank.LT.n )
351  \$ CALL stzrqf( rank, n, a, lda, work( mn+1 ), info )
352 *
353 * Details of Householder rotations stored in WORK(MN+1:2*MN)
354 *
355 * B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
356 *
357  CALL sorm2r( 'Left', 'Transpose', m, nrhs, mn, a, lda, work( 1 ),
358  \$ b, ldb, work( 2*mn+1 ), info )
359 *
360 * workspace NRHS
361 *
362 * B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
363 *
364  CALL strsm( 'Left', 'Upper', 'No transpose', 'Non-unit', rank,
365  \$ nrhs, one, a, lda, b, ldb )
366 *
367  DO 40 i = rank + 1, n
368  DO 30 j = 1, nrhs
369  b( i, j ) = zero
370  30 CONTINUE
371  40 CONTINUE
372 *
373 * B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS)
374 *
375  IF( rank.LT.n ) THEN
376  DO 50 i = 1, rank
377  CALL slatzm( 'Left', n-rank+1, nrhs, a( i, rank+1 ), lda,
378  \$ work( mn+i ), b( i, 1 ), b( rank+1, 1 ), ldb,
379  \$ work( 2*mn+1 ) )
380  50 CONTINUE
381  END IF
382 *
383 * workspace NRHS
384 *
385 * B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
386 *
387  DO 90 j = 1, nrhs
388  DO 60 i = 1, n
389  work( 2*mn+i ) = ntdone
390  60 CONTINUE
391  DO 80 i = 1, n
392  IF( work( 2*mn+i ).EQ.ntdone ) THEN
393  IF( jpvt( i ).NE.i ) THEN
394  k = i
395  t1 = b( k, j )
396  t2 = b( jpvt( k ), j )
397  70 CONTINUE
398  b( jpvt( k ), j ) = t1
399  work( 2*mn+k ) = done
400  t1 = t2
401  k = jpvt( k )
402  t2 = b( jpvt( k ), j )
403  IF( jpvt( k ).NE.i )
404  \$ GO TO 70
405  b( i, j ) = t1
406  work( 2*mn+k ) = done
407  END IF
408  END IF
409  80 CONTINUE
410  90 CONTINUE
411 *
412 * Undo scaling
413 *
414  IF( iascl.EQ.1 ) THEN
415  CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info )
416  CALL slascl( 'U', 0, 0, smlnum, anrm, rank, rank, a, lda,
417  \$ info )
418  ELSE IF( iascl.EQ.2 ) THEN
419  CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info )
420  CALL slascl( 'U', 0, 0, bignum, anrm, rank, rank, a, lda,
421  \$ info )
422  END IF
423  IF( ibscl.EQ.1 ) THEN
424  CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info )
425  ELSE IF( ibscl.EQ.2 ) THEN
426  CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info )
427  END IF
428 *
429  100 CONTINUE
430 *
431  RETURN
432 *
433 * End of SGELSX
434 *
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
Definition: strsm.f:183
subroutine stzrqf(M, N, A, LDA, TAU, INFO)
STZRQF
Definition: stzrqf.f:140
subroutine sorm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
Definition: sorm2r.f:161
subroutine sgeqpf(M, N, A, LDA, JPVT, TAU, WORK, INFO)
SGEQPF
Definition: sgeqpf.f:144
subroutine slaic1(JOB, J, X, SEST, W, GAMMA, SESTPR, S, C)
SLAIC1 applies one step of incremental condition estimation.
Definition: slaic1.f:136
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.
Definition: slascl.f:141
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:116
subroutine slatzm(SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK)
SLATZM
Definition: slatzm.f:153
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...
Definition: slaset.f:112

Here is the call graph for this function:

 subroutine sgelsy ( integer M, integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, real, dimension( ldb, * ) B, integer LDB, integer, dimension( * ) JPVT, real RCOND, integer RANK, real, dimension( * ) WORK, integer LWORK, integer INFO )

SGELSY solves overdetermined or underdetermined systems for GE matrices

Download SGELSY + dependencies [TGZ] [ZIP] [TXT]

Purpose:
``` SGELSY computes the minimum-norm solution to a real linear least
squares problem:
minimize || A * X - B ||
using a complete orthogonal factorization of A.  A is an M-by-N
matrix which may be rank-deficient.

Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.

The routine first computes a QR factorization with column pivoting:
A * P = Q * [ R11 R12 ]
[  0  R22 ]
with R11 defined as the largest leading submatrix whose estimated
condition number is less than 1/RCOND.  The order of R11, RANK,
is the effective rank of A.

Then, R22 is considered to be negligible, and R12 is annihilated
by orthogonal transformations from the right, arriving at the
complete orthogonal factorization:
A * P = Q * [ T11 0 ] * Z
[  0  0 ]
The minimum-norm solution is then
X = P * Z**T [ inv(T11)*Q1**T*B ]
[        0         ]
where Q1 consists of the first RANK columns of Q.

This routine is basically identical to the original xGELSX except
three differences:
o The call to the subroutine xGEQPF has been substituted by the
the call to the subroutine xGEQP3. This subroutine is a Blas-3
version of the QR factorization with column pivoting.
o Matrix B (the right hand side) is updated with Blas-3.
o The permutation of matrix B (the right hand side) is faster and
more simple.```
Parameters
 [in] M ``` M is INTEGER The number of rows of the matrix A. M >= 0.``` [in] N ``` N is INTEGER The number of columns of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of matrices B and X. NRHS >= 0.``` [in,out] A ``` A is REAL array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, A has been overwritten by details of its complete orthogonal factorization.``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,M).``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the M-by-NRHS right hand side matrix B. On exit, the N-by-NRHS solution matrix X.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,M,N).``` [in,out] JPVT ``` JPVT is INTEGER array, dimension (N) On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted to the front of AP, otherwise column i is a free column. On exit, if JPVT(i) = k, then the i-th column of AP was the k-th column of A.``` [in] RCOND ``` RCOND is REAL RCOND is used to determine the effective rank of A, which is defined as the order of the largest leading triangular submatrix R11 in the QR factorization with pivoting of A, whose estimated condition number < 1/RCOND.``` [out] RANK ``` RANK is INTEGER The effective rank of A, i.e., the order of the submatrix R11. This is the same as the order of the submatrix T11 in the complete orthogonal factorization of A.``` [out] WORK ``` WORK is REAL array, dimension (MAX(1,LWORK)) On exit, if INFO = 0, WORK(1) returns the optimal LWORK.``` [in] LWORK ``` LWORK is INTEGER The dimension of the array WORK. The unblocked strategy requires that: LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), where MN = min( M, N ). The block algorithm requires that: LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), where NB is an upper bound on the blocksize returned by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR, and SORMRZ. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA.``` [out] INFO ``` INFO is INTEGER = 0: successful exit < 0: If INFO = -i, the i-th argument had an illegal value.```
Date
November 2011
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain

Definition at line 206 of file sgelsy.f.

206 *
207 * -- LAPACK driver routine (version 3.4.0) --
208 * -- LAPACK is a software package provided by Univ. of Tennessee, --
209 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
210 * November 2011
211 *
212 * .. Scalar Arguments ..
213  INTEGER info, lda, ldb, lwork, m, n, nrhs, rank
214  REAL rcond
215 * ..
216 * .. Array Arguments ..
217  INTEGER jpvt( * )
218  REAL a( lda, * ), b( ldb, * ), work( * )
219 * ..
220 *
221 * =====================================================================
222 *
223 * .. Parameters ..
224  INTEGER imax, imin
225  parameter( imax = 1, imin = 2 )
226  REAL zero, one
227  parameter( zero = 0.0e+0, one = 1.0e+0 )
228 * ..
229 * .. Local Scalars ..
230  LOGICAL lquery
231  INTEGER i, iascl, ibscl, ismax, ismin, j, lwkmin,
232  \$ lwkopt, mn, nb, nb1, nb2, nb3, nb4
233  REAL anrm, bignum, bnrm, c1, c2, s1, s2, smax,
234  \$ smaxpr, smin, sminpr, smlnum, wsize
235 * ..
236 * .. External Functions ..
237  INTEGER ilaenv
238  REAL slamch, slange
239  EXTERNAL ilaenv, slamch, slange
240 * ..
241 * .. External Subroutines ..
242  EXTERNAL scopy, sgeqp3, slabad, slaic1, slascl, slaset,
244 * ..
245 * .. Intrinsic Functions ..
246  INTRINSIC abs, max, min
247 * ..
248 * .. Executable Statements ..
249 *
250  mn = min( m, n )
251  ismin = mn + 1
252  ismax = 2*mn + 1
253 *
254 * Test the input arguments.
255 *
256  info = 0
257  lquery = ( lwork.EQ.-1 )
258  IF( m.LT.0 ) THEN
259  info = -1
260  ELSE IF( n.LT.0 ) THEN
261  info = -2
262  ELSE IF( nrhs.LT.0 ) THEN
263  info = -3
264  ELSE IF( lda.LT.max( 1, m ) ) THEN
265  info = -5
266  ELSE IF( ldb.LT.max( 1, m, n ) ) THEN
267  info = -7
268  END IF
269 *
270 * Figure out optimal block size
271 *
272  IF( info.EQ.0 ) THEN
273  IF( mn.EQ.0 .OR. nrhs.EQ.0 ) THEN
274  lwkmin = 1
275  lwkopt = 1
276  ELSE
277  nb1 = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 )
278  nb2 = ilaenv( 1, 'SGERQF', ' ', m, n, -1, -1 )
279  nb3 = ilaenv( 1, 'SORMQR', ' ', m, n, nrhs, -1 )
280  nb4 = ilaenv( 1, 'SORMRQ', ' ', m, n, nrhs, -1 )
281  nb = max( nb1, nb2, nb3, nb4 )
282  lwkmin = mn + max( 2*mn, n + 1, mn + nrhs )
283  lwkopt = max( lwkmin,
284  \$ mn + 2*n + nb*( n + 1 ), 2*mn + nb*nrhs )
285  END IF
286  work( 1 ) = lwkopt
287 *
288  IF( lwork.LT.lwkmin .AND. .NOT.lquery ) THEN
289  info = -12
290  END IF
291  END IF
292 *
293  IF( info.NE.0 ) THEN
294  CALL xerbla( 'SGELSY', -info )
295  RETURN
296  ELSE IF( lquery ) THEN
297  RETURN
298  END IF
299 *
300 * Quick return if possible
301 *
302  IF( mn.EQ.0 .OR. nrhs.EQ.0 ) THEN
303  rank = 0
304  RETURN
305  END IF
306 *
307 * Get machine parameters
308 *
309  smlnum = slamch( 'S' ) / slamch( 'P' )
310  bignum = one / smlnum
311  CALL slabad( smlnum, bignum )
312 *
313 * Scale A, B if max entries outside range [SMLNUM,BIGNUM]
314 *
315  anrm = slange( 'M', m, n, a, lda, work )
316  iascl = 0
317  IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
318 *
319 * Scale matrix norm up to SMLNUM
320 *
321  CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
322  iascl = 1
323  ELSE IF( anrm.GT.bignum ) THEN
324 *
325 * Scale matrix norm down to BIGNUM
326 *
327  CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
328  iascl = 2
329  ELSE IF( anrm.EQ.zero ) THEN
330 *
331 * Matrix all zero. Return zero solution.
332 *
333  CALL slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb )
334  rank = 0
335  GO TO 70
336  END IF
337 *
338  bnrm = slange( 'M', m, nrhs, b, ldb, work )
339  ibscl = 0
340  IF( bnrm.GT.zero .AND. bnrm.LT.smlnum ) THEN
341 *
342 * Scale matrix norm up to SMLNUM
343 *
344  CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info )
345  ibscl = 1
346  ELSE IF( bnrm.GT.bignum ) THEN
347 *
348 * Scale matrix norm down to BIGNUM
349 *
350  CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info )
351  ibscl = 2
352  END IF
353 *
354 * Compute QR factorization with column pivoting of A:
355 * A * P = Q * R
356 *
357  CALL sgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),
358  \$ lwork-mn, info )
359  wsize = mn + work( mn+1 )
360 *
361 * workspace: MN+2*N+NB*(N+1).
362 * Details of Householder rotations stored in WORK(1:MN).
363 *
364 * Determine RANK using incremental condition estimation
365 *
366  work( ismin ) = one
367  work( ismax ) = one
368  smax = abs( a( 1, 1 ) )
369  smin = smax
370  IF( abs( a( 1, 1 ) ).EQ.zero ) THEN
371  rank = 0
372  CALL slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb )
373  GO TO 70
374  ELSE
375  rank = 1
376  END IF
377 *
378  10 CONTINUE
379  IF( rank.LT.mn ) THEN
380  i = rank + 1
381  CALL slaic1( imin, rank, work( ismin ), smin, a( 1, i ),
382  \$ a( i, i ), sminpr, s1, c1 )
383  CALL slaic1( imax, rank, work( ismax ), smax, a( 1, i ),
384  \$ a( i, i ), smaxpr, s2, c2 )
385 *
386  IF( smaxpr*rcond.LE.sminpr ) THEN
387  DO 20 i = 1, rank
388  work( ismin+i-1 ) = s1*work( ismin+i-1 )
389  work( ismax+i-1 ) = s2*work( ismax+i-1 )
390  20 CONTINUE
391  work( ismin+rank ) = c1
392  work( ismax+rank ) = c2
393  smin = sminpr
394  smax = smaxpr
395  rank = rank + 1
396  GO TO 10
397  END IF
398  END IF
399 *
400 * workspace: 3*MN.
401 *
402 * Logically partition R = [ R11 R12 ]
403 * [ 0 R22 ]
404 * where R11 = R(1:RANK,1:RANK)
405 *
406 * [R11,R12] = [ T11, 0 ] * Y
407 *
408  IF( rank.LT.n )
409  \$ CALL stzrzf( rank, n, a, lda, work( mn+1 ), work( 2*mn+1 ),
410  \$ lwork-2*mn, info )
411 *
412 * workspace: 2*MN.
413 * Details of Householder rotations stored in WORK(MN+1:2*MN)
414 *
415 * B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
416 *
417  CALL sormqr( 'Left', 'Transpose', m, nrhs, mn, a, lda, work( 1 ),
418  \$ b, ldb, work( 2*mn+1 ), lwork-2*mn, info )
419  wsize = max( wsize, 2*mn+work( 2*mn+1 ) )
420 *
421 * workspace: 2*MN+NB*NRHS.
422 *
423 * B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
424 *
425  CALL strsm( 'Left', 'Upper', 'No transpose', 'Non-unit', rank,
426  \$ nrhs, one, a, lda, b, ldb )
427 *
428  DO 40 j = 1, nrhs
429  DO 30 i = rank + 1, n
430  b( i, j ) = zero
431  30 CONTINUE
432  40 CONTINUE
433 *
434 * B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS)
435 *
436  IF( rank.LT.n ) THEN
437  CALL sormrz( 'Left', 'Transpose', n, nrhs, rank, n-rank, a,
438  \$ lda, work( mn+1 ), b, ldb, work( 2*mn+1 ),
439  \$ lwork-2*mn, info )
440  END IF
441 *
442 * workspace: 2*MN+NRHS.
443 *
444 * B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
445 *
446  DO 60 j = 1, nrhs
447  DO 50 i = 1, n
448  work( jpvt( i ) ) = b( i, j )
449  50 CONTINUE
450  CALL scopy( n, work( 1 ), 1, b( 1, j ), 1 )
451  60 CONTINUE
452 *
453 * workspace: N.
454 *
455 * Undo scaling
456 *
457  IF( iascl.EQ.1 ) THEN
458  CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info )
459  CALL slascl( 'U', 0, 0, smlnum, anrm, rank, rank, a, lda,
460  \$ info )
461  ELSE IF( iascl.EQ.2 ) THEN
462  CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info )
463  CALL slascl( 'U', 0, 0, bignum, anrm, rank, rank, a, lda,
464  \$ info )
465  END IF
466  IF( ibscl.EQ.1 ) THEN
467  CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info )
468  ELSE IF( ibscl.EQ.2 ) THEN
469  CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info )
470  END IF
471 *
472  70 CONTINUE
473  work( 1 ) = lwkopt
474 *
475  RETURN
476 *
477 * End of SGELSY
478 *
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
Definition: sormqr.f:170
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:53
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
Definition: strsm.f:183
subroutine sormrz(SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMRZ
Definition: sormrz.f:189
subroutine slaic1(JOB, J, X, SEST, W, GAMMA, SESTPR, S, C)
SLAIC1 applies one step of incremental condition estimation.
Definition: slaic1.f:136
subroutine sgeqp3(M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO)
SGEQP3
Definition: sgeqp3.f:153
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
Definition: tstiee.f:83
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.
Definition: slascl.f:141
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:116
subroutine stzrzf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
STZRZF
Definition: stzrzf.f:153
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...
Definition: slaset.f:112

Here is the call graph for this function:

Here is the caller graph for this function:

 subroutine sgesv ( integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, integer, dimension( * ) IPIV, real, dimension( ldb, * ) B, integer LDB, integer INFO )

SGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)

Download SGESV + dependencies [TGZ] [ZIP] [TXT]

Purpose:
``` SGESV computes the solution to a real system of linear equations
A * X = B,
where A is an N-by-N matrix and X and B are N-by-NRHS matrices.

The LU decomposition with partial pivoting and row interchanges is
used to factor A as
A = P * L * U,
where P is a permutation matrix, L is unit lower triangular, and U is
upper triangular.  The factored form of A is then used to solve the
system of equations A * X = B.```
Parameters
 [in] N ``` N is INTEGER The number of linear equations, i.e., the order of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0.``` [in,out] A ``` A is REAL array, dimension (LDA,N) On entry, the N-by-N coefficient matrix A. On exit, the factors L and U from the factorization A = P*L*U; the unit diagonal elements of L are not stored.``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,N).``` [out] IPIV ``` IPIV is INTEGER array, dimension (N) The pivot indices that define the permutation matrix P; row i of the matrix was interchanged with row IPIV(i).``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the N-by-NRHS matrix of right hand side matrix B. On exit, if INFO = 0, the N-by-NRHS solution matrix X.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,N).``` [out] INFO ``` INFO is INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, so the solution could not be computed.```
Date
November 2011

Definition at line 124 of file sgesv.f.

124 *
125 * -- LAPACK driver routine (version 3.4.0) --
126 * -- LAPACK is a software package provided by Univ. of Tennessee, --
127 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128 * November 2011
129 *
130 * .. Scalar Arguments ..
131  INTEGER info, lda, ldb, n, nrhs
132 * ..
133 * .. Array Arguments ..
134  INTEGER ipiv( * )
135  REAL a( lda, * ), b( ldb, * )
136 * ..
137 *
138 * =====================================================================
139 *
140 * .. External Subroutines ..
141  EXTERNAL sgetrf, sgetrs, xerbla
142 * ..
143 * .. Intrinsic Functions ..
144  INTRINSIC max
145 * ..
146 * .. Executable Statements ..
147 *
148 * Test the input parameters.
149 *
150  info = 0
151  IF( n.LT.0 ) THEN
152  info = -1
153  ELSE IF( nrhs.LT.0 ) THEN
154  info = -2
155  ELSE IF( lda.LT.max( 1, n ) ) THEN
156  info = -4
157  ELSE IF( ldb.LT.max( 1, n ) ) THEN
158  info = -7
159  END IF
160  IF( info.NE.0 ) THEN
161  CALL xerbla( 'SGESV ', -info )
162  RETURN
163  END IF
164 *
165 * Compute the LU factorization of A.
166 *
167  CALL sgetrf( n, n, a, lda, ipiv, info )
168  IF( info.EQ.0 ) THEN
169 *
170 * Solve the system A*X = B, overwriting B with X.
171 *
172  CALL sgetrs( 'No transpose', n, nrhs, a, lda, ipiv, b, ldb,
173  \$ info )
174  END IF
175  RETURN
176 *
177 * End of SGESV
178 *
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine sgetrs(TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SGETRS
Definition: sgetrs.f:123
subroutine sgetrf(M, N, A, LDA, IPIV, INFO)
SGETRF
Definition: sgetrf.f:110

Here is the call graph for this function:

Here is the caller graph for this function:

 subroutine sgesvx ( character FACT, character TRANS, integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, real, dimension( ldaf, * ) AF, integer LDAF, integer, dimension( * ) IPIV, character EQUED, real, dimension( * ) R, real, dimension( * ) C, real, dimension( ldb, * ) B, integer LDB, real, dimension( ldx, * ) X, integer LDX, real RCOND, real, dimension( * ) FERR, real, dimension( * ) BERR, real, dimension( * ) WORK, integer, dimension( * ) IWORK, integer INFO )

SGESVX computes the solution to system of linear equations A * X = B for GE matrices

Download SGESVX + dependencies [TGZ] [ZIP] [TXT]

Purpose:
``` SGESVX uses the LU factorization to compute the solution to a real
system of linear equations
A * X = B,
where A is an N-by-N matrix and X and B are N-by-NRHS matrices.

Error bounds on the solution and a condition estimate are also
provided.```
Description:
``` The following steps are performed:

1. If FACT = 'E', real scaling factors are computed to equilibrate
the system:
TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
Whether or not the system will be equilibrated depends on the
scaling of the matrix A, but if equilibration is used, A is
overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
or diag(C)*B (if TRANS = 'T' or 'C').

2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
matrix A (after equilibration if FACT = 'E') as
A = P * L * U,
where P is a permutation matrix, L is a unit lower triangular
matrix, and U is upper triangular.

3. If some U(i,i)=0, so that U is exactly singular, then the routine
returns with INFO = i. Otherwise, the factored form of A is used
to estimate the condition number of the matrix A.  If the
reciprocal of the condition number is less than machine precision,
INFO = N+1 is returned as a warning, but the routine still goes on
to solve for X and compute error bounds as described below.

4. The system of equations is solved for X using the factored form
of A.

5. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.

6. If equilibration was used, the matrix X is premultiplied by
diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
that it solves the original system before equilibration.```
Parameters
 [in] FACT ``` FACT is CHARACTER*1 Specifies whether or not the factored form of the matrix A is supplied on entry, and if not, whether the matrix A should be equilibrated before it is factored. = 'F': On entry, AF and IPIV contain the factored form of A. If EQUED is not 'N', the matrix A has been equilibrated with scaling factors given by R and C. A, AF, and IPIV are not modified. = 'N': The matrix A will be copied to AF and factored. = 'E': The matrix A will be equilibrated if necessary, then copied to AF and factored.``` [in] TRANS ``` TRANS is CHARACTER*1 Specifies the form of the system of equations: = 'N': A * X = B (No transpose) = 'T': A**T * X = B (Transpose) = 'C': A**H * X = B (Transpose)``` [in] N ``` N is INTEGER The number of linear equations, i.e., the order of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0.``` [in,out] A ``` A is REAL array, dimension (LDA,N) On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is not 'N', then A must have been equilibrated by the scaling factors in R and/or C. A is not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. On exit, if EQUED .ne. 'N', A is scaled as follows: EQUED = 'R': A := diag(R) * A EQUED = 'C': A := A * diag(C) EQUED = 'B': A := diag(R) * A * diag(C).``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,N).``` [in,out] AF ``` AF is REAL array, dimension (LDAF,N) If FACT = 'F', then AF is an input argument and on entry contains the factors L and U from the factorization A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then AF is the factored form of the equilibrated matrix A. If FACT = 'N', then AF is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the original matrix A. If FACT = 'E', then AF is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the equilibrated matrix A (see the description of A for the form of the equilibrated matrix).``` [in] LDAF ``` LDAF is INTEGER The leading dimension of the array AF. LDAF >= max(1,N).``` [in,out] IPIV ``` IPIV is INTEGER array, dimension (N) If FACT = 'F', then IPIV is an input argument and on entry contains the pivot indices from the factorization A = P*L*U as computed by SGETRF; row i of the matrix was interchanged with row IPIV(i). If FACT = 'N', then IPIV is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the original matrix A. If FACT = 'E', then IPIV is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the equilibrated matrix A.``` [in,out] EQUED ``` EQUED is CHARACTER*1 Specifies the form of equilibration that was done. = 'N': No equilibration (always true if FACT = 'N'). = 'R': Row equilibration, i.e., A has been premultiplied by diag(R). = 'C': Column equilibration, i.e., A has been postmultiplied by diag(C). = 'B': Both row and column equilibration, i.e., A has been replaced by diag(R) * A * diag(C). EQUED is an input argument if FACT = 'F'; otherwise, it is an output argument.``` [in,out] R ``` R is REAL array, dimension (N) The row scale factors for A. If EQUED = 'R' or 'B', A is multiplied on the left by diag(R); if EQUED = 'N' or 'C', R is not accessed. R is an input argument if FACT = 'F'; otherwise, R is an output argument. If FACT = 'F' and EQUED = 'R' or 'B', each element of R must be positive.``` [in,out] C ``` C is REAL array, dimension (N) The column scale factors for A. If EQUED = 'C' or 'B', A is multiplied on the right by diag(C); if EQUED = 'N' or 'R', C is not accessed. C is an input argument if FACT = 'F'; otherwise, C is an output argument. If FACT = 'F' and EQUED = 'C' or 'B', each element of C must be positive.``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the N-by-NRHS right hand side matrix B. On exit, if EQUED = 'N', B is not modified; if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by diag(R)*B; if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is overwritten by diag(C)*B.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,N).``` [out] X ``` X is REAL array, dimension (LDX,NRHS) If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to the original system of equations. Note that A and B are modified on exit if EQUED .ne. 'N', and the solution to the equilibrated system is inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.``` [in] LDX ``` LDX is INTEGER The leading dimension of the array X. LDX >= max(1,N).``` [out] RCOND ``` RCOND is REAL The estimate of the reciprocal condition number of the matrix A after equilibration (if done). If RCOND is less than the machine precision (in particular, if RCOND = 0), the matrix is singular to working precision. This condition is indicated by a return code of INFO > 0.``` [out] FERR ``` FERR is REAL array, dimension (NRHS) The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), FERR(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for RCOND, and is almost always a slight overestimate of the true error.``` [out] BERR ``` BERR is REAL array, dimension (NRHS) The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution).``` [out] WORK ``` WORK is REAL array, dimension (4*N) On exit, WORK(1) contains the reciprocal pivot growth factor norm(A)/norm(U). The "max absolute element" norm is used. If WORK(1) is much less than 1, then the stability of the LU factorization of the (equilibrated) matrix A could be poor. This also means that the solution X, condition estimator RCOND, and forward error bound FERR could be unreliable. If factorization fails with 0 0: if INFO = i, and i is <= N: U(i,i) is exactly zero. The factorization has been completed, but the factor U is exactly singular, so the solution and error bounds could not be computed. RCOND = 0 is returned. = N+1: U is nonsingular, but RCOND is less than machine precision, meaning that the matrix is singular to working precision. Nevertheless, the solution and error bounds are computed because there are a number of situations where the computed solution can be more accurate than the value of RCOND would suggest.```
Date
April 2012

Definition at line 351 of file sgesvx.f.

351 *
352 * -- LAPACK driver routine (version 3.4.1) --
353 * -- LAPACK is a software package provided by Univ. of Tennessee, --
354 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
355 * April 2012
356 *
357 * .. Scalar Arguments ..
358  CHARACTER equed, fact, trans
359  INTEGER info, lda, ldaf, ldb, ldx, n, nrhs
360  REAL rcond
361 * ..
362 * .. Array Arguments ..
363  INTEGER ipiv( * ), iwork( * )
364  REAL a( lda, * ), af( ldaf, * ), b( ldb, * ),
365  \$ berr( * ), c( * ), ferr( * ), r( * ),
366  \$ work( * ), x( ldx, * )
367 * ..
368 *
369 * =====================================================================
370 *
371 * .. Parameters ..
372  REAL zero, one
373  parameter( zero = 0.0e+0, one = 1.0e+0 )
374 * ..
375 * .. Local Scalars ..
376  LOGICAL colequ, equil, nofact, notran, rowequ
377  CHARACTER norm
378  INTEGER i, infequ, j
379  REAL amax, anorm, bignum, colcnd, rcmax, rcmin,
380  \$ rowcnd, rpvgrw, smlnum
381 * ..
382 * .. External Functions ..
383  LOGICAL lsame
384  REAL slamch, slange, slantr
385  EXTERNAL lsame, slamch, slange, slantr
386 * ..
387 * .. External Subroutines ..
388  EXTERNAL sgecon, sgeequ, sgerfs, sgetrf, sgetrs, slacpy,
389  \$ slaqge, xerbla
390 * ..
391 * .. Intrinsic Functions ..
392  INTRINSIC max, min
393 * ..
394 * .. Executable Statements ..
395 *
396  info = 0
397  nofact = lsame( fact, 'N' )
398  equil = lsame( fact, 'E' )
399  notran = lsame( trans, 'N' )
400  IF( nofact .OR. equil ) THEN
401  equed = 'N'
402  rowequ = .false.
403  colequ = .false.
404  ELSE
405  rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' )
406  colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' )
407  smlnum = slamch( 'Safe minimum' )
408  bignum = one / smlnum
409  END IF
410 *
411 * Test the input parameters.
412 *
413  IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.lsame( fact, 'F' ) )
414  \$ THEN
415  info = -1
416  ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
417  \$ lsame( trans, 'C' ) ) THEN
418  info = -2
419  ELSE IF( n.LT.0 ) THEN
420  info = -3
421  ELSE IF( nrhs.LT.0 ) THEN
422  info = -4
423  ELSE IF( lda.LT.max( 1, n ) ) THEN
424  info = -6
425  ELSE IF( ldaf.LT.max( 1, n ) ) THEN
426  info = -8
427  ELSE IF( lsame( fact, 'F' ) .AND. .NOT.
428  \$ ( rowequ .OR. colequ .OR. lsame( equed, 'N' ) ) ) THEN
429  info = -10
430  ELSE
431  IF( rowequ ) THEN
432  rcmin = bignum
433  rcmax = zero
434  DO 10 j = 1, n
435  rcmin = min( rcmin, r( j ) )
436  rcmax = max( rcmax, r( j ) )
437  10 CONTINUE
438  IF( rcmin.LE.zero ) THEN
439  info = -11
440  ELSE IF( n.GT.0 ) THEN
441  rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
442  ELSE
443  rowcnd = one
444  END IF
445  END IF
446  IF( colequ .AND. info.EQ.0 ) THEN
447  rcmin = bignum
448  rcmax = zero
449  DO 20 j = 1, n
450  rcmin = min( rcmin, c( j ) )
451  rcmax = max( rcmax, c( j ) )
452  20 CONTINUE
453  IF( rcmin.LE.zero ) THEN
454  info = -12
455  ELSE IF( n.GT.0 ) THEN
456  colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
457  ELSE
458  colcnd = one
459  END IF
460  END IF
461  IF( info.EQ.0 ) THEN
462  IF( ldb.LT.max( 1, n ) ) THEN
463  info = -14
464  ELSE IF( ldx.LT.max( 1, n ) ) THEN
465  info = -16
466  END IF
467  END IF
468  END IF
469 *
470  IF( info.NE.0 ) THEN
471  CALL xerbla( 'SGESVX', -info )
472  RETURN
473  END IF
474 *
475  IF( equil ) THEN
476 *
477 * Compute row and column scalings to equilibrate the matrix A.
478 *
479  CALL sgeequ( n, n, a, lda, r, c, rowcnd, colcnd, amax, infequ )
480  IF( infequ.EQ.0 ) THEN
481 *
482 * Equilibrate the matrix.
483 *
484  CALL slaqge( n, n, a, lda, r, c, rowcnd, colcnd, amax,
485  \$ equed )
486  rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' )
487  colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' )
488  END IF
489  END IF
490 *
491 * Scale the right hand side.
492 *
493  IF( notran ) THEN
494  IF( rowequ ) THEN
495  DO 40 j = 1, nrhs
496  DO 30 i = 1, n
497  b( i, j ) = r( i )*b( i, j )
498  30 CONTINUE
499  40 CONTINUE
500  END IF
501  ELSE IF( colequ ) THEN
502  DO 60 j = 1, nrhs
503  DO 50 i = 1, n
504  b( i, j ) = c( i )*b( i, j )
505  50 CONTINUE
506  60 CONTINUE
507  END IF
508 *
509  IF( nofact .OR. equil ) THEN
510 *
511 * Compute the LU factorization of A.
512 *
513  CALL slacpy( 'Full', n, n, a, lda, af, ldaf )
514  CALL sgetrf( n, n, af, ldaf, ipiv, info )
515 *
516 * Return if INFO is non-zero.
517 *
518  IF( info.GT.0 ) THEN
519 *
520 * Compute the reciprocal pivot growth factor of the
521 * leading rank-deficient INFO columns of A.
522 *
523  rpvgrw = slantr( 'M', 'U', 'N', info, info, af, ldaf,
524  \$ work )
525  IF( rpvgrw.EQ.zero ) THEN
526  rpvgrw = one
527  ELSE
528  rpvgrw = slange( 'M', n, info, a, lda, work ) / rpvgrw
529  END IF
530  work( 1 ) = rpvgrw
531  rcond = zero
532  RETURN
533  END IF
534  END IF
535 *
536 * Compute the norm of the matrix A and the
537 * reciprocal pivot growth factor RPVGRW.
538 *
539  IF( notran ) THEN
540  norm = '1'
541  ELSE
542  norm = 'I'
543  END IF
544  anorm = slange( norm, n, n, a, lda, work )
545  rpvgrw = slantr( 'M', 'U', 'N', n, n, af, ldaf, work )
546  IF( rpvgrw.EQ.zero ) THEN
547  rpvgrw = one
548  ELSE
549  rpvgrw = slange( 'M', n, n, a, lda, work ) / rpvgrw
550  END IF
551 *
552 * Compute the reciprocal of the condition number of A.
553 *
554  CALL sgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info )
555 *
556 * Compute the solution matrix X.
557 *
558  CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx )
559  CALL sgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info )
560 *
561 * Use iterative refinement to improve the computed solution and
562 * compute error bounds and backward error estimates for it.
563 *
564  CALL sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,
565  \$ ldx, ferr, berr, work, iwork, info )
566 *
567 * Transform the solution matrix X to a solution of the original
568 * system.
569 *
570  IF( notran ) THEN
571  IF( colequ ) THEN
572  DO 80 j = 1, nrhs
573  DO 70 i = 1, n
574  x( i, j ) = c( i )*x( i, j )
575  70 CONTINUE
576  80 CONTINUE
577  DO 90 j = 1, nrhs
578  ferr( j ) = ferr( j ) / colcnd
579  90 CONTINUE
580  END IF
581  ELSE IF( rowequ ) THEN
582  DO 110 j = 1, nrhs
583  DO 100 i = 1, n
584  x( i, j ) = r( i )*x( i, j )
585  100 CONTINUE
586  110 CONTINUE
587  DO 120 j = 1, nrhs
588  ferr( j ) = ferr( j ) / rowcnd
589  120 CONTINUE
590  END IF
591 *
592 * Set INFO = N+1 if the matrix is singular to working precision.
593 *
594  IF( rcond.LT.slamch( 'Epsilon' ) )
595  \$ info = n + 1
596 *
597  work( 1 ) = rpvgrw
598  RETURN
599 *
600 * End of SGESVX
601 *
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine sgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
SGEEQU
Definition: sgeequ.f:141
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine sgetrs(TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SGETRS
Definition: sgetrs.f:123
subroutine sgerfs(TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SGERFS
Definition: sgerfs.f:187
subroutine sgetrf(M, N, A, LDA, IPIV, INFO)
SGETRF
Definition: sgetrf.f:110
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
subroutine sgecon(NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
SGECON
Definition: sgecon.f:126
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
subroutine slaqge(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED)
SLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ...
Definition: slaqge.f:144
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:116
real function slantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
SLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
Definition: slantr.f:143

Here is the call graph for this function:

Here is the caller graph for this function:

 subroutine sgesvxx ( character FACT, character TRANS, integer N, integer NRHS, real, dimension( lda, * ) A, integer LDA, real, dimension( ldaf, * ) AF, integer LDAF, integer, dimension( * ) IPIV, character EQUED, real, dimension( * ) R, real, dimension( * ) C, real, dimension( ldb, * ) B, integer LDB, real, dimension( ldx , * ) X, integer LDX, real RCOND, real RPVGRW, real, dimension( * ) BERR, integer N_ERR_BNDS, real, dimension( nrhs, * ) ERR_BNDS_NORM, real, dimension( nrhs, * ) ERR_BNDS_COMP, integer NPARAMS, real, dimension( * ) PARAMS, real, dimension( * ) WORK, integer, dimension( * ) IWORK, integer INFO )

SGESVXX computes the solution to system of linear equations A * X = B for GE matrices

Download SGESVXX + dependencies [TGZ] [ZIP] [TXT]

Purpose:
```    SGESVXX uses the LU factorization to compute the solution to a
real system of linear equations  A * X = B,  where A is an
N-by-N matrix and X and B are N-by-NRHS matrices.

If requested, both normwise and maximum componentwise error bounds
are returned. SGESVXX will return a solution with a tiny
guaranteed error (O(eps) where eps is the working machine
precision) unless the matrix is very ill-conditioned, in which
case a warning is returned. Relevant condition numbers also are
calculated and returned.

SGESVXX accepts user-provided factorizations and equilibration
factors; see the definitions of the FACT and EQUED options.
Solving with refinement and using a factorization from a previous
SGESVXX call will also produce a solution with either O(eps)
errors or warnings, but we cannot make that claim for general
user-provided factorizations and equilibration factors if they
differ from what SGESVXX would itself produce.```
Description:
```    The following steps are performed:

1. If FACT = 'E', real scaling factors are computed to equilibrate
the system:

TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B

Whether or not the system will be equilibrated depends on the
scaling of the matrix A, but if equilibration is used, A is
overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
or diag(C)*B (if TRANS = 'T' or 'C').

2. If FACT = 'N' or 'E', the LU decomposition is used to factor
the matrix A (after equilibration if FACT = 'E') as

A = P * L * U,

where P is a permutation matrix, L is a unit lower triangular
matrix, and U is upper triangular.

3. If some U(i,i)=0, so that U is exactly singular, then the
routine returns with INFO = i. Otherwise, the factored form of A
is used to estimate the condition number of the matrix A (see
argument RCOND). If the reciprocal of the condition number is less
than machine precision, the routine still goes on to solve for X
and compute error bounds as described below.

4. The system of equations is solved for X using the factored form
of A.

5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
the routine will use iterative refinement to try to get a small
error and error bounds.  Refinement calculates the residual to at
least twice the working precision.

6. If equilibration was used, the matrix X is premultiplied by
diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
that it solves the original system before equilibration.```
```     Some optional parameters are bundled in the PARAMS array.  These
settings determine how refinement is performed, but often the
defaults are acceptable.  If the defaults are acceptable, users
can pass NPARAMS = 0 which prevents the source code from accessing
the PARAMS argument.```
Parameters
 [in] FACT ``` FACT is CHARACTER*1 Specifies whether or not the factored form of the matrix A is supplied on entry, and if not, whether the matrix A should be equilibrated before it is factored. = 'F': On entry, AF and IPIV contain the factored form of A. If EQUED is not 'N', the matrix A has been equilibrated with scaling factors given by R and C. A, AF, and IPIV are not modified. = 'N': The matrix A will be copied to AF and factored. = 'E': The matrix A will be equilibrated if necessary, then copied to AF and factored.``` [in] TRANS ``` TRANS is CHARACTER*1 Specifies the form of the system of equations: = 'N': A * X = B (No transpose) = 'T': A**T * X = B (Transpose) = 'C': A**H * X = B (Conjugate Transpose = Transpose)``` [in] N ``` N is INTEGER The number of linear equations, i.e., the order of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0.``` [in,out] A ``` A is REAL array, dimension (LDA,N) On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is not 'N', then A must have been equilibrated by the scaling factors in R and/or C. A is not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. On exit, if EQUED .ne. 'N', A is scaled as follows: EQUED = 'R': A := diag(R) * A EQUED = 'C': A := A * diag(C) EQUED = 'B': A := diag(R) * A * diag(C).``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,N).``` [in,out] AF ``` AF is REAL array, dimension (LDAF,N) If FACT = 'F', then AF is an input argument and on entry contains the factors L and U from the factorization A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then AF is the factored form of the equilibrated matrix A. If FACT = 'N', then AF is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the original matrix A. If FACT = 'E', then AF is an output argument and on exit returns the factors L and U from the factorization A = P*L*U of the equilibrated matrix A (see the description of A for the form of the equilibrated matrix).``` [in] LDAF ``` LDAF is INTEGER The leading dimension of the array AF. LDAF >= max(1,N).``` [in,out] IPIV ``` IPIV is INTEGER array, dimension (N) If FACT = 'F', then IPIV is an input argument and on entry contains the pivot indices from the factorization A = P*L*U as computed by SGETRF; row i of the matrix was interchanged with row IPIV(i). If FACT = 'N', then IPIV is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the original matrix A. If FACT = 'E', then IPIV is an output argument and on exit contains the pivot indices from the factorization A = P*L*U of the equilibrated matrix A.``` [in,out] EQUED ``` EQUED is CHARACTER*1 Specifies the form of equilibration that was done. = 'N': No equilibration (always true if FACT = 'N'). = 'R': Row equilibration, i.e., A has been premultiplied by diag(R). = 'C': Column equilibration, i.e., A has been postmultiplied by diag(C). = 'B': Both row and column equilibration, i.e., A has been replaced by diag(R) * A * diag(C). EQUED is an input argument if FACT = 'F'; otherwise, it is an output argument.``` [in,out] R ``` R is REAL array, dimension (N) The row scale factors for A. If EQUED = 'R' or 'B', A is multiplied on the left by diag(R); if EQUED = 'N' or 'C', R is not accessed. R is an input argument if FACT = 'F'; otherwise, R is an output argument. If FACT = 'F' and EQUED = 'R' or 'B', each element of R must be positive. If R is output, each element of R is a power of the radix. If R is input, each element of R should be a power of the radix to ensure a reliable solution and error estimates. Scaling by powers of the radix does not cause rounding errors unless the result underflows or overflows. Rounding errors during scaling lead to refining with a matrix that is not equivalent to the input matrix, producing error estimates that may not be reliable.``` [in,out] C ``` C is REAL array, dimension (N) The column scale factors for A. If EQUED = 'C' or 'B', A is multiplied on the right by diag(C); if EQUED = 'N' or 'R', C is not accessed. C is an input argument if FACT = 'F'; otherwise, C is an output argument. If FACT = 'F' and EQUED = 'C' or 'B', each element of C must be positive. If C is output, each element of C is a power of the radix. If C is input, each element of C should be a power of the radix to ensure a reliable solution and error estimates. Scaling by powers of the radix does not cause rounding errors unless the result underflows or overflows. Rounding errors during scaling lead to refining with a matrix that is not equivalent to the input matrix, producing error estimates that may not be reliable.``` [in,out] B ``` B is REAL array, dimension (LDB,NRHS) On entry, the N-by-NRHS right hand side matrix B. On exit, if EQUED = 'N', B is not modified; if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by diag(R)*B; if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is overwritten by diag(C)*B.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,N).``` [out] X ``` X is REAL array, dimension (LDX,NRHS) If INFO = 0, the N-by-NRHS solution matrix X to the original system of equations. Note that A and B are modified on exit if EQUED .ne. 'N', and the solution to the equilibrated system is inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.``` [in] LDX ``` LDX is INTEGER The leading dimension of the array X. LDX >= max(1,N).``` [out] RCOND ``` RCOND is REAL Reciprocal scaled condition number. This is an estimate of the reciprocal Skeel condition number of the matrix A after equilibration (if done). If this is less than the machine precision (in particular, if it is zero), the matrix is singular to working precision. Note that the error may still be small even if this number is very small and the matrix appears ill- conditioned.``` [out] RPVGRW ``` RPVGRW is REAL Reciprocal pivot growth. On exit, this contains the reciprocal pivot growth factor norm(A)/norm(U). The "max absolute element" norm is used. If this is much less than 1, then the stability of the LU factorization of the (equilibrated) matrix A could be poor. This also means that the solution X, estimated condition numbers, and error bounds could be unreliable. If factorization fails with 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization has been completed, but the factor U is exactly singular, so the solution and error bounds could not be computed. RCOND = 0 is returned. = N+J: The solution corresponding to the Jth right-hand side is not guaranteed. The solutions corresponding to other right- hand sides K with K > J may not be guaranteed as well, but only the first such right-hand side is reported. If a small componentwise error is not requested (PARAMS(3) = 0.0) then the Jth right-hand side is the first with a normwise error bound that is not guaranteed (the smallest J such that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) the Jth right-hand side is the first with either a normwise or componentwise error bound that is not guaranteed (the smallest J such that either ERR_BNDS_NORM(J,1) = 0.0 or ERR_BNDS_COMP(J,1) = 0.0). See the definition of ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information about all of the right-hand sides check ERR_BNDS_NORM or ERR_BNDS_COMP.```
Date
April 2012

Definition at line 545 of file sgesvxx.f.

545 *
546 * -- LAPACK driver routine (version 3.4.1) --
547 * -- LAPACK is a software package provided by Univ. of Tennessee, --
548 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
549 * April 2012
550 *
551 * .. Scalar Arguments ..
552  CHARACTER equed, fact, trans
553  INTEGER info, lda, ldaf, ldb, ldx, n, nrhs, nparams,
554  \$ n_err_bnds
555  REAL rcond, rpvgrw
556 * ..
557 * .. Array Arguments ..
558  INTEGER ipiv( * ), iwork( * )
559  REAL a( lda, * ), af( ldaf, * ), b( ldb, * ),
560  \$ x( ldx , * ),work( * )
561  REAL r( * ), c( * ), params( * ), berr( * ),
562  \$ err_bnds_norm( nrhs, * ),
563  \$ err_bnds_comp( nrhs, * )
564 * ..
565 *
566 * ==================================================================
567 *
568 * .. Parameters ..
569  REAL zero, one
570  parameter( zero = 0.0e+0, one = 1.0e+0 )
571  INTEGER final_nrm_err_i, final_cmp_err_i, berr_i
572  INTEGER rcond_i, nrm_rcond_i, nrm_err_i, cmp_rcond_i
573  INTEGER cmp_err_i, piv_growth_i
574  parameter( final_nrm_err_i = 1, final_cmp_err_i = 2,
575  \$ berr_i = 3 )
576  parameter( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
577  parameter( cmp_rcond_i = 7, cmp_err_i = 8,
578  \$ piv_growth_i = 9 )
579 * ..
580 * .. Local Scalars ..
581  LOGICAL colequ, equil, nofact, notran, rowequ
582  INTEGER infequ, j
583  REAL amax, bignum, colcnd, rcmax, rcmin, rowcnd,
584  \$ smlnum
585 * ..
586 * .. External Functions ..
587  EXTERNAL lsame, slamch, sla_gerpvgrw
588  LOGICAL lsame
589  REAL slamch, sla_gerpvgrw
590 * ..
591 * .. External Subroutines ..
592  EXTERNAL sgeequb, sgetrf, sgetrs, slacpy, slaqge,
594 * ..
595 * .. Intrinsic Functions ..
596  INTRINSIC max, min
597 * ..
598 * .. Executable Statements ..
599 *
600  info = 0
601  nofact = lsame( fact, 'N' )
602  equil = lsame( fact, 'E' )
603  notran = lsame( trans, 'N' )
604  smlnum = slamch( 'Safe minimum' )
605  bignum = one / smlnum
606  IF( nofact .OR. equil ) THEN
607  equed = 'N'
608  rowequ = .false.
609  colequ = .false.
610  ELSE
611  rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' )
612  colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' )
613  END IF
614 *
615 * Default is failure. If an input parameter is wrong or
616 * factorization fails, make everything look horrible. Only the
617 * pivot growth is set here, the rest is initialized in SGERFSX.
618 *
619  rpvgrw = zero
620 *
621 * Test the input parameters. PARAMS is not tested until SGERFSX.
622 *
623  IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.
624  \$ lsame( fact, 'F' ) ) THEN
625  info = -1
626  ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
627  \$ lsame( trans, 'C' ) ) THEN
628  info = -2
629  ELSE IF( n.LT.0 ) THEN
630  info = -3
631  ELSE IF( nrhs.LT.0 ) THEN
632  info = -4
633  ELSE IF( lda.LT.max( 1, n ) ) THEN
634  info = -6
635  ELSE IF( ldaf.LT.max( 1, n ) ) THEN
636  info = -8
637  ELSE IF( lsame( fact, 'F' ) .AND. .NOT.
638  \$ ( rowequ .OR. colequ .OR. lsame( equed, 'N' ) ) ) THEN
639  info = -10
640  ELSE
641  IF( rowequ ) THEN
642  rcmin = bignum
643  rcmax = zero
644  DO 10 j = 1, n
645  rcmin = min( rcmin, r( j ) )
646  rcmax = max( rcmax, r( j ) )
647  10 CONTINUE
648  IF( rcmin.LE.zero ) THEN
649  info = -11
650  ELSE IF( n.GT.0 ) THEN
651  rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
652  ELSE
653  rowcnd = one
654  END IF
655  END IF
656  IF( colequ .AND. info.EQ.0 ) THEN
657  rcmin = bignum
658  rcmax = zero
659  DO 20 j = 1, n
660  rcmin = min( rcmin, c( j ) )
661  rcmax = max( rcmax, c( j ) )
662  20 CONTINUE
663  IF( rcmin.LE.zero ) THEN
664  info = -12
665  ELSE IF( n.GT.0 ) THEN
666  colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
667  ELSE
668  colcnd = one
669  END IF
670  END IF
671  IF( info.EQ.0 ) THEN
672  IF( ldb.LT.max( 1, n ) ) THEN
673  info = -14
674  ELSE IF( ldx.LT.max( 1, n ) ) THEN
675  info = -16
676  END IF
677  END IF
678  END IF
679 *
680  IF( info.NE.0 ) THEN
681  CALL xerbla( 'SGESVXX', -info )
682  RETURN
683  END IF
684 *
685  IF( equil ) THEN
686 *
687 * Compute row and column scalings to equilibrate the matrix A.
688 *
689  CALL sgeequb( n, n, a, lda, r, c, rowcnd, colcnd, amax,
690  \$ infequ )
691  IF( infequ.EQ.0 ) THEN
692 *
693 * Equilibrate the matrix.
694 *
695  CALL slaqge( n, n, a, lda, r, c, rowcnd, colcnd, amax,
696  \$ equed )
697  rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' )
698  colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' )
699  END IF
700 *
701 * If the scaling factors are not applied, set them to 1.0.
702 *
703  IF ( .NOT.rowequ ) THEN
704  DO j = 1, n
705  r( j ) = 1.0
706  END DO
707  END IF
708  IF ( .NOT.colequ ) THEN
709  DO j = 1, n
710  c( j ) = 1.0
711  END DO
712  END IF
713  END IF
714 *
715 * Scale the right-hand side.
716 *
717  IF( notran ) THEN
718  IF( rowequ ) CALL slascl2( n, nrhs, r, b, ldb )
719  ELSE
720  IF( colequ ) CALL slascl2( n, nrhs, c, b, ldb )
721  END IF
722 *
723  IF( nofact .OR. equil ) THEN
724 *
725 * Compute the LU factorization of A.
726 *
727  CALL slacpy( 'Full', n, n, a, lda, af, ldaf )
728  CALL sgetrf( n, n, af, ldaf, ipiv, info )
729 *
730 * Return if INFO is non-zero.
731 *
732  IF( info.GT.0 ) THEN
733 *
734 * Pivot in column INFO is exactly 0
735 * Compute the reciprocal pivot growth factor of the
736 * leading rank-deficient INFO columns of A.
737 *
738  rpvgrw = sla_gerpvgrw( n, info, a, lda, af, ldaf )
739  RETURN
740  END IF
741  END IF
742 *
743 * Compute the reciprocal pivot growth factor RPVGRW.
744 *
745  rpvgrw = sla_gerpvgrw( n, n, a, lda, af, ldaf )
746 *
747 * Compute the solution matrix X.
748 *
749  CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx )
750  CALL sgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info )
751 *
752 * Use iterative refinement to improve the computed solution and
753 * compute error bounds and backward error estimates for it.
754 *
755  CALL sgerfsx( trans, equed, n, nrhs, a, lda, af, ldaf,
756  \$ ipiv, r, c, b, ldb, x, ldx, rcond, berr,
757  \$ n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params,
758  \$ work, iwork, info )
759 *
760 * Scale solutions.
761 *
762  IF ( colequ .AND. notran ) THEN
763  CALL slascl2 ( n, nrhs, c, x, ldx )
764  ELSE IF ( rowequ .AND. .NOT.notran ) THEN
765  CALL slascl2 ( n, nrhs, r, x, ldx )
766  END IF
767 *
768  RETURN
769 *
770 * End of SGESVXX
771
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine sgerfsx(TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
SGERFSX
Definition: sgerfsx.f:416
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine sgetrs(TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SGETRS
Definition: sgetrs.f:123
subroutine sgetrf(M, N, A, LDA, IPIV, INFO)
SGETRF
Definition: sgetrf.f:110
subroutine sgeequb(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
SGEEQUB
Definition: sgeequb.f:148
subroutine slascl2(M, N, D, X, LDX)
SLASCL2 performs diagonal scaling on a vector.
Definition: slascl2.f:92
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
subroutine slaqge(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED)
SLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ...
Definition: slaqge.f:144
real function sla_gerpvgrw(N, NCOLS, A, LDA, AF, LDAF)
SLA_GERPVGRW
Definition: sla_gerpvgrw.f:99

Here is the call graph for this function:

Here is the caller graph for this function: