Annotation of rpl/lapack/lapack/zgels.f, revision 1.9
1.9 ! bertrand 1: *> \brief <b> ZGELS solves overdetermined or underdetermined systems for GE matrices</b>
! 2: *
! 3: * =========== DOCUMENTATION ===========
! 4: *
! 5: * Online html documentation available at
! 6: * http://www.netlib.org/lapack/explore-html/
! 7: *
! 8: *> \htmlonly
! 9: *> Download ZGELS + dependencies
! 10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgels.f">
! 11: *> [TGZ]</a>
! 12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgels.f">
! 13: *> [ZIP]</a>
! 14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgels.f">
! 15: *> [TXT]</a>
! 16: *> \endhtmlonly
! 17: *
! 18: * Definition:
! 19: * ===========
! 20: *
! 21: * SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
! 22: * INFO )
! 23: *
! 24: * .. Scalar Arguments ..
! 25: * CHARACTER TRANS
! 26: * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
! 27: * ..
! 28: * .. Array Arguments ..
! 29: * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
! 30: * ..
! 31: *
! 32: *
! 33: *> \par Purpose:
! 34: * =============
! 35: *>
! 36: *> \verbatim
! 37: *>
! 38: *> ZGELS solves overdetermined or underdetermined complex linear systems
! 39: *> involving an M-by-N matrix A, or its conjugate-transpose, using a QR
! 40: *> or LQ factorization of A. It is assumed that A has full rank.
! 41: *>
! 42: *> The following options are provided:
! 43: *>
! 44: *> 1. If TRANS = 'N' and m >= n: find the least squares solution of
! 45: *> an overdetermined system, i.e., solve the least squares problem
! 46: *> minimize || B - A*X ||.
! 47: *>
! 48: *> 2. If TRANS = 'N' and m < n: find the minimum norm solution of
! 49: *> an underdetermined system A * X = B.
! 50: *>
! 51: *> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of
! 52: *> an undetermined system A**H * X = B.
! 53: *>
! 54: *> 4. If TRANS = 'C' and m < n: find the least squares solution of
! 55: *> an overdetermined system, i.e., solve the least squares problem
! 56: *> minimize || B - A**H * X ||.
! 57: *>
! 58: *> Several right hand side vectors b and solution vectors x can be
! 59: *> handled in a single call; they are stored as the columns of the
! 60: *> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
! 61: *> matrix X.
! 62: *> \endverbatim
! 63: *
! 64: * Arguments:
! 65: * ==========
! 66: *
! 67: *> \param[in] TRANS
! 68: *> \verbatim
! 69: *> TRANS is CHARACTER*1
! 70: *> = 'N': the linear system involves A;
! 71: *> = 'C': the linear system involves A**H.
! 72: *> \endverbatim
! 73: *>
! 74: *> \param[in] M
! 75: *> \verbatim
! 76: *> M is INTEGER
! 77: *> The number of rows of the matrix A. M >= 0.
! 78: *> \endverbatim
! 79: *>
! 80: *> \param[in] N
! 81: *> \verbatim
! 82: *> N is INTEGER
! 83: *> The number of columns of the matrix A. N >= 0.
! 84: *> \endverbatim
! 85: *>
! 86: *> \param[in] NRHS
! 87: *> \verbatim
! 88: *> NRHS is INTEGER
! 89: *> The number of right hand sides, i.e., the number of
! 90: *> columns of the matrices B and X. NRHS >= 0.
! 91: *> \endverbatim
! 92: *>
! 93: *> \param[in,out] A
! 94: *> \verbatim
! 95: *> A is COMPLEX*16 array, dimension (LDA,N)
! 96: *> On entry, the M-by-N matrix A.
! 97: *> if M >= N, A is overwritten by details of its QR
! 98: *> factorization as returned by ZGEQRF;
! 99: *> if M < N, A is overwritten by details of its LQ
! 100: *> factorization as returned by ZGELQF.
! 101: *> \endverbatim
! 102: *>
! 103: *> \param[in] LDA
! 104: *> \verbatim
! 105: *> LDA is INTEGER
! 106: *> The leading dimension of the array A. LDA >= max(1,M).
! 107: *> \endverbatim
! 108: *>
! 109: *> \param[in,out] B
! 110: *> \verbatim
! 111: *> B is COMPLEX*16 array, dimension (LDB,NRHS)
! 112: *> On entry, the matrix B of right hand side vectors, stored
! 113: *> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
! 114: *> if TRANS = 'C'.
! 115: *> On exit, if INFO = 0, B is overwritten by the solution
! 116: *> vectors, stored columnwise:
! 117: *> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
! 118: *> squares solution vectors; the residual sum of squares for the
! 119: *> solution in each column is given by the sum of squares of the
! 120: *> modulus of elements N+1 to M in that column;
! 121: *> if TRANS = 'N' and m < n, rows 1 to N of B contain the
! 122: *> minimum norm solution vectors;
! 123: *> if TRANS = 'C' and m >= n, rows 1 to M of B contain the
! 124: *> minimum norm solution vectors;
! 125: *> if TRANS = 'C' and m < n, rows 1 to M of B contain the
! 126: *> least squares solution vectors; the residual sum of squares
! 127: *> for the solution in each column is given by the sum of
! 128: *> squares of the modulus of elements M+1 to N in that column.
! 129: *> \endverbatim
! 130: *>
! 131: *> \param[in] LDB
! 132: *> \verbatim
! 133: *> LDB is INTEGER
! 134: *> The leading dimension of the array B. LDB >= MAX(1,M,N).
! 135: *> \endverbatim
! 136: *>
! 137: *> \param[out] WORK
! 138: *> \verbatim
! 139: *> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
! 140: *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
! 141: *> \endverbatim
! 142: *>
! 143: *> \param[in] LWORK
! 144: *> \verbatim
! 145: *> LWORK is INTEGER
! 146: *> The dimension of the array WORK.
! 147: *> LWORK >= max( 1, MN + max( MN, NRHS ) ).
! 148: *> For optimal performance,
! 149: *> LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
! 150: *> where MN = min(M,N) and NB is the optimum block size.
! 151: *>
! 152: *> If LWORK = -1, then a workspace query is assumed; the routine
! 153: *> only calculates the optimal size of the WORK array, returns
! 154: *> this value as the first entry of the WORK array, and no error
! 155: *> message related to LWORK is issued by XERBLA.
! 156: *> \endverbatim
! 157: *>
! 158: *> \param[out] INFO
! 159: *> \verbatim
! 160: *> INFO is INTEGER
! 161: *> = 0: successful exit
! 162: *> < 0: if INFO = -i, the i-th argument had an illegal value
! 163: *> > 0: if INFO = i, the i-th diagonal element of the
! 164: *> triangular factor of A is zero, so that A does not have
! 165: *> full rank; the least squares solution could not be
! 166: *> computed.
! 167: *> \endverbatim
! 168: *
! 169: * Authors:
! 170: * ========
! 171: *
! 172: *> \author Univ. of Tennessee
! 173: *> \author Univ. of California Berkeley
! 174: *> \author Univ. of Colorado Denver
! 175: *> \author NAG Ltd.
! 176: *
! 177: *> \date November 2011
! 178: *
! 179: *> \ingroup complex16GEsolve
! 180: *
! 181: * =====================================================================
1.1 bertrand 182: SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
183: $ INFO )
184: *
1.9 ! bertrand 185: * -- LAPACK driver routine (version 3.4.0) --
1.1 bertrand 186: * -- LAPACK is a software package provided by Univ. of Tennessee, --
187: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.9 ! bertrand 188: * November 2011
1.1 bertrand 189: *
190: * .. Scalar Arguments ..
191: CHARACTER TRANS
192: INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
193: * ..
194: * .. Array Arguments ..
195: COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
196: * ..
197: *
198: * =====================================================================
199: *
200: * .. Parameters ..
201: DOUBLE PRECISION ZERO, ONE
202: PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
203: COMPLEX*16 CZERO
204: PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
205: * ..
206: * .. Local Scalars ..
207: LOGICAL LQUERY, TPSD
208: INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
209: DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM
210: * ..
211: * .. Local Arrays ..
212: DOUBLE PRECISION RWORK( 1 )
213: * ..
214: * .. External Functions ..
215: LOGICAL LSAME
216: INTEGER ILAENV
217: DOUBLE PRECISION DLAMCH, ZLANGE
218: EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
219: * ..
220: * .. External Subroutines ..
221: EXTERNAL DLABAD, XERBLA, ZGELQF, ZGEQRF, ZLASCL, ZLASET,
222: $ ZTRTRS, ZUNMLQ, ZUNMQR
223: * ..
224: * .. Intrinsic Functions ..
225: INTRINSIC DBLE, MAX, MIN
226: * ..
227: * .. Executable Statements ..
228: *
229: * Test the input arguments.
230: *
231: INFO = 0
232: MN = MIN( M, N )
233: LQUERY = ( LWORK.EQ.-1 )
234: IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'C' ) ) ) THEN
235: INFO = -1
236: ELSE IF( M.LT.0 ) THEN
237: INFO = -2
238: ELSE IF( N.LT.0 ) THEN
239: INFO = -3
240: ELSE IF( NRHS.LT.0 ) THEN
241: INFO = -4
242: ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
243: INFO = -6
244: ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
245: INFO = -8
246: ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY )
247: $ THEN
248: INFO = -10
249: END IF
250: *
251: * Figure out optimal block size
252: *
253: IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
254: *
255: TPSD = .TRUE.
256: IF( LSAME( TRANS, 'N' ) )
257: $ TPSD = .FALSE.
258: *
259: IF( M.GE.N ) THEN
260: NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
261: IF( TPSD ) THEN
262: NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LN', M, NRHS, N,
263: $ -1 ) )
264: ELSE
265: NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LC', M, NRHS, N,
266: $ -1 ) )
267: END IF
268: ELSE
269: NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
270: IF( TPSD ) THEN
271: NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M,
272: $ -1 ) )
273: ELSE
274: NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', 'LN', N, NRHS, M,
275: $ -1 ) )
276: END IF
277: END IF
278: *
279: WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
280: WORK( 1 ) = DBLE( WSIZE )
281: *
282: END IF
283: *
284: IF( INFO.NE.0 ) THEN
285: CALL XERBLA( 'ZGELS ', -INFO )
286: RETURN
287: ELSE IF( LQUERY ) THEN
288: RETURN
289: END IF
290: *
291: * Quick return if possible
292: *
293: IF( MIN( M, N, NRHS ).EQ.0 ) THEN
294: CALL ZLASET( 'Full', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
295: RETURN
296: END IF
297: *
298: * Get machine parameters
299: *
300: SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
301: BIGNUM = ONE / SMLNUM
302: CALL DLABAD( SMLNUM, BIGNUM )
303: *
304: * Scale A, B if max element outside range [SMLNUM,BIGNUM]
305: *
306: ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
307: IASCL = 0
308: IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
309: *
310: * Scale matrix norm up to SMLNUM
311: *
312: CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
313: IASCL = 1
314: ELSE IF( ANRM.GT.BIGNUM ) THEN
315: *
316: * Scale matrix norm down to BIGNUM
317: *
318: CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
319: IASCL = 2
320: ELSE IF( ANRM.EQ.ZERO ) THEN
321: *
322: * Matrix all zero. Return zero solution.
323: *
324: CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
325: GO TO 50
326: END IF
327: *
328: BROW = M
329: IF( TPSD )
330: $ BROW = N
331: BNRM = ZLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
332: IBSCL = 0
333: IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
334: *
335: * Scale matrix norm up to SMLNUM
336: *
337: CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
338: $ INFO )
339: IBSCL = 1
340: ELSE IF( BNRM.GT.BIGNUM ) THEN
341: *
342: * Scale matrix norm down to BIGNUM
343: *
344: CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
345: $ INFO )
346: IBSCL = 2
347: END IF
348: *
349: IF( M.GE.N ) THEN
350: *
351: * compute QR factorization of A
352: *
353: CALL ZGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
354: $ INFO )
355: *
356: * workspace at least N, optimally N*NB
357: *
358: IF( .NOT.TPSD ) THEN
359: *
360: * Least-Squares Problem min || A * X - B ||
361: *
1.8 bertrand 362: * B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS)
1.1 bertrand 363: *
364: CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, N, A,
365: $ LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
366: $ INFO )
367: *
368: * workspace at least NRHS, optimally NRHS*NB
369: *
370: * B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
371: *
372: CALL ZTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS,
373: $ A, LDA, B, LDB, INFO )
374: *
375: IF( INFO.GT.0 ) THEN
376: RETURN
377: END IF
378: *
379: SCLLEN = N
380: *
381: ELSE
382: *
1.8 bertrand 383: * Overdetermined system of equations A**H * X = B
1.1 bertrand 384: *
1.8 bertrand 385: * B(1:N,1:NRHS) := inv(R**H) * B(1:N,1:NRHS)
1.1 bertrand 386: *
387: CALL ZTRTRS( 'Upper', 'Conjugate transpose','Non-unit',
388: $ N, NRHS, A, LDA, B, LDB, INFO )
389: *
390: IF( INFO.GT.0 ) THEN
391: RETURN
392: END IF
393: *
394: * B(N+1:M,1:NRHS) = ZERO
395: *
396: DO 20 J = 1, NRHS
397: DO 10 I = N + 1, M
398: B( I, J ) = CZERO
399: 10 CONTINUE
400: 20 CONTINUE
401: *
402: * B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
403: *
404: CALL ZUNMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
405: $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
406: $ INFO )
407: *
408: * workspace at least NRHS, optimally NRHS*NB
409: *
410: SCLLEN = M
411: *
412: END IF
413: *
414: ELSE
415: *
416: * Compute LQ factorization of A
417: *
418: CALL ZGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
419: $ INFO )
420: *
421: * workspace at least M, optimally M*NB.
422: *
423: IF( .NOT.TPSD ) THEN
424: *
425: * underdetermined system of equations A * X = B
426: *
427: * B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
428: *
429: CALL ZTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS,
430: $ A, LDA, B, LDB, INFO )
431: *
432: IF( INFO.GT.0 ) THEN
433: RETURN
434: END IF
435: *
436: * B(M+1:N,1:NRHS) = 0
437: *
438: DO 40 J = 1, NRHS
439: DO 30 I = M + 1, N
440: B( I, J ) = CZERO
441: 30 CONTINUE
442: 40 CONTINUE
443: *
1.8 bertrand 444: * B(1:N,1:NRHS) := Q(1:N,:)**H * B(1:M,1:NRHS)
1.1 bertrand 445: *
446: CALL ZUNMLQ( 'Left', 'Conjugate transpose', N, NRHS, M, A,
447: $ LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
448: $ INFO )
449: *
450: * workspace at least NRHS, optimally NRHS*NB
451: *
452: SCLLEN = N
453: *
454: ELSE
455: *
1.8 bertrand 456: * overdetermined system min || A**H * X - B ||
1.1 bertrand 457: *
458: * B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
459: *
460: CALL ZUNMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
461: $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
462: $ INFO )
463: *
464: * workspace at least NRHS, optimally NRHS*NB
465: *
1.8 bertrand 466: * B(1:M,1:NRHS) := inv(L**H) * B(1:M,1:NRHS)
1.1 bertrand 467: *
468: CALL ZTRTRS( 'Lower', 'Conjugate transpose', 'Non-unit',
469: $ M, NRHS, A, LDA, B, LDB, INFO )
470: *
471: IF( INFO.GT.0 ) THEN
472: RETURN
473: END IF
474: *
475: SCLLEN = M
476: *
477: END IF
478: *
479: END IF
480: *
481: * Undo scaling
482: *
483: IF( IASCL.EQ.1 ) THEN
484: CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
485: $ INFO )
486: ELSE IF( IASCL.EQ.2 ) THEN
487: CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
488: $ INFO )
489: END IF
490: IF( IBSCL.EQ.1 ) THEN
491: CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
492: $ INFO )
493: ELSE IF( IBSCL.EQ.2 ) THEN
494: CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
495: $ INFO )
496: END IF
497: *
498: 50 CONTINUE
499: WORK( 1 ) = DBLE( WSIZE )
500: *
501: RETURN
502: *
503: * End of ZGELS
504: *
505: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zgels.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack