LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
sqrt14.f
Go to the documentation of this file.
1*> \brief \b SQRT14
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* REAL FUNCTION SQRT14( TRANS, M, N, NRHS, A, LDA, X,
12* LDX, WORK, LWORK )
13*
14* .. Scalar Arguments ..
15* CHARACTER TRANS
16* INTEGER LDA, LDX, LWORK, M, N, NRHS
17* ..
18* .. Array Arguments ..
19* REAL A( LDA, * ), WORK( LWORK ), X( LDX, * )
20* ..
21*
22*
23*> \par Purpose:
24* =============
25*>
26*> \verbatim
27*>
28*> SQRT14 checks whether X is in the row space of A or A'. It does so
29*> by scaling both X and A such that their norms are in the range
30*> [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X]
31*> (if TRANS = 'T') or an LQ factorization of [A',X]' (if TRANS = 'N'),
32*> and returning the norm of the trailing triangle, scaled by
33*> MAX(M,N,NRHS)*eps.
34*> \endverbatim
35*
36* Arguments:
37* ==========
38*
39*> \param[in] TRANS
40*> \verbatim
41*> TRANS is CHARACTER*1
42*> = 'N': No transpose, check for X in the row space of A
43*> = 'T': Transpose, check for X in the row space of A'.
44*> \endverbatim
45*>
46*> \param[in] M
47*> \verbatim
48*> M is INTEGER
49*> The number of rows of the matrix A.
50*> \endverbatim
51*>
52*> \param[in] N
53*> \verbatim
54*> N is INTEGER
55*> The number of columns of the matrix A.
56*> \endverbatim
57*>
58*> \param[in] NRHS
59*> \verbatim
60*> NRHS is INTEGER
61*> The number of right hand sides, i.e., the number of columns
62*> of X.
63*> \endverbatim
64*>
65*> \param[in] A
66*> \verbatim
67*> A is REAL array, dimension (LDA,N)
68*> The M-by-N matrix A.
69*> \endverbatim
70*>
71*> \param[in] LDA
72*> \verbatim
73*> LDA is INTEGER
74*> The leading dimension of the array A.
75*> \endverbatim
76*>
77*> \param[in] X
78*> \verbatim
79*> X is REAL array, dimension (LDX,NRHS)
80*> If TRANS = 'N', the N-by-NRHS matrix X.
81*> IF TRANS = 'T', the M-by-NRHS matrix X.
82*> \endverbatim
83*>
84*> \param[in] LDX
85*> \verbatim
86*> LDX is INTEGER
87*> The leading dimension of the array X.
88*> \endverbatim
89*>
90*> \param[out] WORK
91*> \verbatim
92*> WORK is REAL array dimension (LWORK)
93*> \endverbatim
94*>
95*> \param[in] LWORK
96*> \verbatim
97*> LWORK is INTEGER
98*> length of workspace array required
99*> If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);
100*> if TRANS = 'T', LWORK >= (N+NRHS)*(M+2).
101*> \endverbatim
102*
103* Authors:
104* ========
105*
106*> \author Univ. of Tennessee
107*> \author Univ. of California Berkeley
108*> \author Univ. of Colorado Denver
109*> \author NAG Ltd.
110*
111*> \ingroup single_lin
112*
113* =====================================================================
114 REAL function sqrt14( trans, m, n, nrhs, a, lda, x,
115 $ ldx, work, lwork )
116*
117* -- LAPACK test routine --
118* -- LAPACK is a software package provided by Univ. of Tennessee, --
119* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
120*
121* .. Scalar Arguments ..
122 CHARACTER trans
123 INTEGER lda, ldx, lwork, m, n, nrhs
124* ..
125* .. Array Arguments ..
126 REAL a( lda, * ), work( lwork ), x( ldx, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 REAL zero, one
133 parameter( zero = 0.0e0, one = 1.0e0 )
134* ..
135* .. Local Scalars ..
136 LOGICAL tpsd
137 INTEGER i, info, j, ldwork
138 REAL anrm, err, xnrm
139* ..
140* .. Local Arrays ..
141 REAL rwork( 1 )
142* ..
143* .. External Functions ..
144 LOGICAL lsame
145 REAL slamch, slange
146 EXTERNAL lsame, slamch, slange
147* ..
148* .. External Subroutines ..
149 EXTERNAL sgelq2, sgeqr2, slacpy, slascl, xerbla
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC abs, max, min, real
153* ..
154* .. Executable Statements ..
155*
156 sqrt14 = zero
157 IF( lsame( trans, 'N' ) ) THEN
158 ldwork = m + nrhs
159 tpsd = .false.
160 IF( lwork.LT.( m+nrhs )*( n+2 ) ) THEN
161 CALL xerbla( 'SQRT14', 10 )
162 RETURN
163 ELSE IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
164 RETURN
165 END IF
166 ELSE IF( lsame( trans, 'T' ) ) THEN
167 ldwork = m
168 tpsd = .true.
169 IF( lwork.LT.( n+nrhs )*( m+2 ) ) THEN
170 CALL xerbla( 'SQRT14', 10 )
171 RETURN
172 ELSE IF( m.LE.0 .OR. nrhs.LE.0 ) THEN
173 RETURN
174 END IF
175 ELSE
176 CALL xerbla( 'SQRT14', 1 )
177 RETURN
178 END IF
179*
180* Copy and scale A
181*
182 CALL slacpy( 'All', m, n, a, lda, work, ldwork )
183 anrm = slange( 'M', m, n, work, ldwork, rwork )
184 IF( anrm.NE.zero )
185 $ CALL slascl( 'G', 0, 0, anrm, one, m, n, work, ldwork, info )
186*
187* Copy X or X' into the right place and scale it
188*
189 IF( tpsd ) THEN
190*
191* Copy X into columns n+1:n+nrhs of work
192*
193 CALL slacpy( 'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
194 $ ldwork )
195 xnrm = slange( 'M', m, nrhs, work( n*ldwork+1 ), ldwork,
196 $ rwork )
197 IF( xnrm.NE.zero )
198 $ CALL slascl( 'G', 0, 0, xnrm, one, m, nrhs,
199 $ work( n*ldwork+1 ), ldwork, info )
200*
201* Compute QR factorization of X
202*
203 CALL sgeqr2( m, n+nrhs, work, ldwork,
204 $ work( ldwork*( n+nrhs )+1 ),
205 $ work( ldwork*( n+nrhs )+min( m, n+nrhs )+1 ),
206 $ info )
207*
208* Compute largest entry in upper triangle of
209* work(n+1:m,n+1:n+nrhs)
210*
211 err = zero
212 DO 20 j = n + 1, n + nrhs
213 DO 10 i = n + 1, min( m, j )
214 err = max( err, abs( work( i+( j-1 )*m ) ) )
215 10 CONTINUE
216 20 CONTINUE
217*
218 ELSE
219*
220* Copy X' into rows m+1:m+nrhs of work
221*
222 DO 40 i = 1, n
223 DO 30 j = 1, nrhs
224 work( m+j+( i-1 )*ldwork ) = x( i, j )
225 30 CONTINUE
226 40 CONTINUE
227*
228 xnrm = slange( 'M', nrhs, n, work( m+1 ), ldwork, rwork )
229 IF( xnrm.NE.zero )
230 $ CALL slascl( 'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
231 $ ldwork, info )
232*
233* Compute LQ factorization of work
234*
235 CALL sgelq2( ldwork, n, work, ldwork, work( ldwork*n+1 ),
236 $ work( ldwork*( n+1 )+1 ), info )
237*
238* Compute largest entry in lower triangle in
239* work(m+1:m+nrhs,m+1:n)
240*
241 err = zero
242 DO 60 j = m + 1, n
243 DO 50 i = j, ldwork
244 err = max( err, abs( work( i+( j-1 )*ldwork ) ) )
245 50 CONTINUE
246 60 CONTINUE
247*
248 END IF
249*
250 sqrt14 = err / ( real( max( m, n, nrhs ) )*slamch( 'Epsilon' ) )
251*
252 RETURN
253*
254* End of SQRT14
255*
256 END
subroutine xerbla(srname, info)
Definition cblat2.f:3285
subroutine sgelq2(m, n, a, lda, tau, work, info)
SGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgelq2.f:129
subroutine sgeqr2(m, n, a, lda, tau, work, info)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgeqr2.f:130
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
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:114
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:143
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
real function sqrt14(trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
SQRT14
Definition sqrt14.f:116