LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
zgelsx.f
Go to the documentation of this file.
1*> \brief <b> ZGELSX 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*> Download ZGELSX + dependencies
9*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelsx.f">
10*> [TGZ]</a>
11*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelsx.f">
12*> [ZIP]</a>
13*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelsx.f">
14*> [TXT]</a>
15*
16* Definition:
17* ===========
18*
19* SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
20* WORK, RWORK, INFO )
21*
22* .. Scalar Arguments ..
23* INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
24* DOUBLE PRECISION RCOND
25* ..
26* .. Array Arguments ..
27* INTEGER JPVT( * )
28* DOUBLE PRECISION RWORK( * )
29* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
30* ..
31*
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> This routine is deprecated and has been replaced by routine ZGELSY.
39*>
40*> ZGELSX computes the minimum-norm solution to a complex linear least
41*> squares problem:
42*> minimize || A * X - B ||
43*> using a complete orthogonal factorization of A. A is an M-by-N
44*> matrix which may be rank-deficient.
45*>
46*> Several right hand side vectors b and solution vectors x can be
47*> handled in a single call; they are stored as the columns of the
48*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
49*> matrix X.
50*>
51*> The routine first computes a QR factorization with column pivoting:
52*> A * P = Q * [ R11 R12 ]
53*> [ 0 R22 ]
54*> with R11 defined as the largest leading submatrix whose estimated
55*> condition number is less than 1/RCOND. The order of R11, RANK,
56*> is the effective rank of A.
57*>
58*> Then, R22 is considered to be negligible, and R12 is annihilated
59*> by unitary transformations from the right, arriving at the
60*> complete orthogonal factorization:
61*> A * P = Q * [ T11 0 ] * Z
62*> [ 0 0 ]
63*> The minimum-norm solution is then
64*> X = P * Z**H [ inv(T11)*Q1**H*B ]
65*> [ 0 ]
66*> where Q1 consists of the first RANK columns of Q.
67*> \endverbatim
68*
69* Arguments:
70* ==========
71*
72*> \param[in] M
73*> \verbatim
74*> M is INTEGER
75*> The number of rows of the matrix A. M >= 0.
76*> \endverbatim
77*>
78*> \param[in] N
79*> \verbatim
80*> N is INTEGER
81*> The number of columns of the matrix A. N >= 0.
82*> \endverbatim
83*>
84*> \param[in] NRHS
85*> \verbatim
86*> NRHS is INTEGER
87*> The number of right hand sides, i.e., the number of
88*> columns of matrices B and X. NRHS >= 0.
89*> \endverbatim
90*>
91*> \param[in,out] A
92*> \verbatim
93*> A is COMPLEX*16 array, dimension (LDA,N)
94*> On entry, the M-by-N matrix A.
95*> On exit, A has been overwritten by details of its
96*> complete orthogonal factorization.
97*> \endverbatim
98*>
99*> \param[in] LDA
100*> \verbatim
101*> LDA is INTEGER
102*> The leading dimension of the array A. LDA >= max(1,M).
103*> \endverbatim
104*>
105*> \param[in,out] B
106*> \verbatim
107*> B is COMPLEX*16 array, dimension (LDB,NRHS)
108*> On entry, the M-by-NRHS right hand side matrix B.
109*> On exit, the N-by-NRHS solution matrix X.
110*> If m >= n and RANK = n, the residual sum-of-squares for
111*> the solution in the i-th column is given by the sum of
112*> squares of elements N+1:M in that column.
113*> \endverbatim
114*>
115*> \param[in] LDB
116*> \verbatim
117*> LDB is INTEGER
118*> The leading dimension of the array B. LDB >= max(1,M,N).
119*> \endverbatim
120*>
121*> \param[in,out] JPVT
122*> \verbatim
123*> JPVT is INTEGER array, dimension (N)
124*> On entry, if JPVT(i) .ne. 0, the i-th column of A is an
125*> initial column, otherwise it is a free column. Before
126*> the QR factorization of A, all initial columns are
127*> permuted to the leading positions; only the remaining
128*> free columns are moved as a result of column pivoting
129*> during the factorization.
130*> On exit, if JPVT(i) = k, then the i-th column of A*P
131*> was the k-th column of A.
132*> \endverbatim
133*>
134*> \param[in] RCOND
135*> \verbatim
136*> RCOND is DOUBLE PRECISION
137*> RCOND is used to determine the effective rank of A, which
138*> is defined as the order of the largest leading triangular
139*> submatrix R11 in the QR factorization with pivoting of A,
140*> whose estimated condition number < 1/RCOND.
141*> \endverbatim
142*>
143*> \param[out] RANK
144*> \verbatim
145*> RANK is INTEGER
146*> The effective rank of A, i.e., the order of the submatrix
147*> R11. This is the same as the order of the submatrix T11
148*> in the complete orthogonal factorization of A.
149*> \endverbatim
150*>
151*> \param[out] WORK
152*> \verbatim
153*> WORK is COMPLEX*16 array, dimension
154*> (min(M,N) + max( N, 2*min(M,N)+NRHS )),
155*> \endverbatim
156*>
157*> \param[out] RWORK
158*> \verbatim
159*> RWORK is DOUBLE PRECISION array, dimension (2*N)
160*> \endverbatim
161*>
162*> \param[out] INFO
163*> \verbatim
164*> INFO is INTEGER
165*> = 0: successful exit
166*> < 0: if INFO = -i, the i-th argument had an illegal value
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*> \ingroup complex16GEsolve
178*
179* =====================================================================
180 SUBROUTINE zgelsx( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND,
181 $ RANK, WORK, RWORK, INFO )
182*
183* -- LAPACK driver routine --
184* -- LAPACK is a software package provided by Univ. of Tennessee, --
185* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
186*
187* .. Scalar Arguments ..
188 INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
189 DOUBLE PRECISION RCOND
190* ..
191* .. Array Arguments ..
192 INTEGER JPVT( * )
193 DOUBLE PRECISION RWORK( * )
194 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 INTEGER IMAX, IMIN
201 parameter( imax = 1, imin = 2 )
202 DOUBLE PRECISION ZERO, ONE, DONE, NTDONE
203 parameter( zero = 0.0d+0, one = 1.0d+0, done = zero,
204 $ ntdone = one )
205 COMPLEX*16 CZERO, CONE
206 parameter( czero = ( 0.0d+0, 0.0d+0 ),
207 $ cone = ( 1.0d+0, 0.0d+0 ) )
208* ..
209* .. Local Scalars ..
210 INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
211 DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR,
212 $ smlnum
213 COMPLEX*16 C1, C2, S1, S2, T1, T2
214* ..
215* .. External Subroutines ..
216 EXTERNAL xerbla, zgeqpf, zlaic1, zlascl, zlaset, zlatzm,
218* ..
219* .. External Functions ..
220 DOUBLE PRECISION DLAMCH, ZLANGE
221 EXTERNAL dlamch, zlange
222* ..
223* .. Intrinsic Functions ..
224 INTRINSIC abs, dconjg, max, min
225* ..
226* .. Executable Statements ..
227*
228 mn = min( m, n )
229 ismin = mn + 1
230 ismax = 2*mn + 1
231*
232* Test the input arguments.
233*
234 info = 0
235 IF( m.LT.0 ) THEN
236 info = -1
237 ELSE IF( n.LT.0 ) THEN
238 info = -2
239 ELSE IF( nrhs.LT.0 ) THEN
240 info = -3
241 ELSE IF( lda.LT.max( 1, m ) ) THEN
242 info = -5
243 ELSE IF( ldb.LT.max( 1, m, n ) ) THEN
244 info = -7
245 END IF
246*
247 IF( info.NE.0 ) THEN
248 CALL xerbla( 'ZGELSX', -info )
249 RETURN
250 END IF
251*
252* Quick return if possible
253*
254 IF( min( m, n, nrhs ).EQ.0 ) THEN
255 rank = 0
256 RETURN
257 END IF
258*
259* Get machine parameters
260*
261 smlnum = dlamch( 'S' ) / dlamch( 'P' )
262 bignum = one / smlnum
263*
264* Scale A, B if max elements outside range [SMLNUM,BIGNUM]
265*
266 anrm = zlange( 'M', m, n, a, lda, rwork )
267 iascl = 0
268 IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
269*
270* Scale matrix norm up to SMLNUM
271*
272 CALL zlascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
273 iascl = 1
274 ELSE IF( anrm.GT.bignum ) THEN
275*
276* Scale matrix norm down to BIGNUM
277*
278 CALL zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
279 iascl = 2
280 ELSE IF( anrm.EQ.zero ) THEN
281*
282* Matrix all zero. Return zero solution.
283*
284 CALL zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb )
285 rank = 0
286 GO TO 100
287 END IF
288*
289 bnrm = zlange( 'M', m, nrhs, b, ldb, rwork )
290 ibscl = 0
291 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum ) THEN
292*
293* Scale matrix norm up to SMLNUM
294*
295 CALL zlascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb,
296 $ info )
297 ibscl = 1
298 ELSE IF( bnrm.GT.bignum ) THEN
299*
300* Scale matrix norm down to BIGNUM
301*
302 CALL zlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb,
303 $ info )
304 ibscl = 2
305 END IF
306*
307* Compute QR factorization with column pivoting of A:
308* A * P = Q * R
309*
310 CALL zgeqpf( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),
311 $ rwork, info )
312*
313* complex workspace MN+N. Real workspace 2*N. Details of Householder
314* rotations stored in WORK(1:MN).
315*
316* Determine RANK using incremental condition estimation
317*
318 work( ismin ) = cone
319 work( ismax ) = cone
320 smax = abs( a( 1, 1 ) )
321 smin = smax
322 IF( abs( a( 1, 1 ) ).EQ.zero ) THEN
323 rank = 0
324 CALL zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb )
325 GO TO 100
326 ELSE
327 rank = 1
328 END IF
329*
330 10 CONTINUE
331 IF( rank.LT.mn ) THEN
332 i = rank + 1
333 CALL zlaic1( imin, rank, work( ismin ), smin, a( 1, i ),
334 $ a( i, i ), sminpr, s1, c1 )
335 CALL zlaic1( imax, rank, work( ismax ), smax, a( 1, i ),
336 $ a( i, i ), smaxpr, s2, c2 )
337*
338 IF( smaxpr*rcond.LE.sminpr ) THEN
339 DO 20 i = 1, rank
340 work( ismin+i-1 ) = s1*work( ismin+i-1 )
341 work( ismax+i-1 ) = s2*work( ismax+i-1 )
342 20 CONTINUE
343 work( ismin+rank ) = c1
344 work( ismax+rank ) = c2
345 smin = sminpr
346 smax = smaxpr
347 rank = rank + 1
348 GO TO 10
349 END IF
350 END IF
351*
352* Logically partition R = [ R11 R12 ]
353* [ 0 R22 ]
354* where R11 = R(1:RANK,1:RANK)
355*
356* [R11,R12] = [ T11, 0 ] * Y
357*
358 IF( rank.LT.n )
359 $ CALL ztzrqf( rank, n, a, lda, work( mn+1 ), info )
360*
361* Details of Householder rotations stored in WORK(MN+1:2*MN)
362*
363* B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS)
364*
365 CALL zunm2r( 'Left', 'Conjugate transpose', m, nrhs, mn, a,
366 $ lda, work( 1 ), b, ldb, work( 2*mn+1 ), info )
367*
368* workspace NRHS
369*
370* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
371*
372 CALL ztrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', rank,
373 $ nrhs, cone, a, lda, b, ldb )
374*
375 DO 40 i = rank + 1, n
376 DO 30 j = 1, nrhs
377 b( i, j ) = czero
378 30 CONTINUE
379 40 CONTINUE
380*
381* B(1:N,1:NRHS) := Y**H * B(1:N,1:NRHS)
382*
383 IF( rank.LT.n ) THEN
384 DO 50 i = 1, rank
385 CALL zlatzm( 'Left', n-rank+1, nrhs, a( i, rank+1 ),
386 $ lda, dconjg( work( mn+i ) ), b( i, 1 ),
387 $ b( rank+1, 1 ), ldb, work( 2*mn+1 ) )
388 50 CONTINUE
389 END IF
390*
391* workspace NRHS
392*
393* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
394*
395 DO 90 j = 1, nrhs
396 DO 60 i = 1, n
397 work( 2*mn+i ) = ntdone
398 60 CONTINUE
399 DO 80 i = 1, n
400 IF( work( 2*mn+i ).EQ.ntdone ) THEN
401 IF( jpvt( i ).NE.i ) THEN
402 k = i
403 t1 = b( k, j )
404 t2 = b( jpvt( k ), j )
405 70 CONTINUE
406 b( jpvt( k ), j ) = t1
407 work( 2*mn+k ) = done
408 t1 = t2
409 k = jpvt( k )
410 t2 = b( jpvt( k ), j )
411 IF( jpvt( k ).NE.i )
412 $ GO TO 70
413 b( i, j ) = t1
414 work( 2*mn+k ) = done
415 END IF
416 END IF
417 80 CONTINUE
418 90 CONTINUE
419*
420* Undo scaling
421*
422 IF( iascl.EQ.1 ) THEN
423 CALL zlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb,
424 $ info )
425 CALL zlascl( 'U', 0, 0, smlnum, anrm, rank, rank, a, lda,
426 $ info )
427 ELSE IF( iascl.EQ.2 ) THEN
428 CALL zlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb,
429 $ info )
430 CALL zlascl( 'U', 0, 0, bignum, anrm, rank, rank, a, lda,
431 $ info )
432 END IF
433 IF( ibscl.EQ.1 ) THEN
434 CALL zlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb,
435 $ info )
436 ELSE IF( ibscl.EQ.2 ) THEN
437 CALL zlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb,
438 $ info )
439 END IF
440*
441 100 CONTINUE
442*
443 RETURN
444*
445* End of ZGELSX
446*
447 END
subroutine xerbla(srname, info)
Definition cblat2.f:3285
subroutine zlaic1(job, j, x, sest, w, gamma, sestpr, s, c)
ZLAIC1 applies one step of incremental condition estimation.
Definition zlaic1.f:133
subroutine zlascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition zlascl.f:142
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition zlaset.f:104
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
subroutine zunm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
Definition zunm2r.f:157
subroutine zgelsx(m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank, work, rwork, info)
ZGELSX solves overdetermined or underdetermined systems for GE matrices
Definition zgelsx.f:182
subroutine zgeqpf(m, n, a, lda, jpvt, tau, work, rwork, info)
ZGEQPF
Definition zgeqpf.f:146
subroutine zlatzm(side, m, n, v, incv, tau, c1, c2, ldc, work)
ZLATZM
Definition zlatzm.f:151
subroutine ztzrqf(m, n, a, lda, tau, info)
ZTZRQF
Definition ztzrqf.f:136