LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
sormbr.f
Go to the documentation of this file.
1*> \brief \b SORMBR
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download SORMBR + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sormbr.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sormbr.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sormbr.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
22* LDC, WORK, LWORK, INFO )
23*
24* .. Scalar Arguments ..
25* CHARACTER SIDE, TRANS, VECT
26* INTEGER INFO, K, LDA, LDC, LWORK, M, N
27* ..
28* .. Array Arguments ..
29* REAL A( LDA, * ), C( LDC, * ), TAU( * ),
30* $ WORK( * )
31* ..
32*
33*
34*> \par Purpose:
35* =============
36*>
37*> \verbatim
38*>
39*> If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C
40*> with
41*> SIDE = 'L' SIDE = 'R'
42*> TRANS = 'N': Q * C C * Q
43*> TRANS = 'T': Q**T * C C * Q**T
44*>
45*> If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C
46*> with
47*> SIDE = 'L' SIDE = 'R'
48*> TRANS = 'N': P * C C * P
49*> TRANS = 'T': P**T * C C * P**T
50*>
51*> Here Q and P**T are the orthogonal matrices determined by SGEBRD when
52*> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
53*> P**T are defined as products of elementary reflectors H(i) and G(i)
54*> respectively.
55*>
56*> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
57*> order of the orthogonal matrix Q or P**T that is applied.
58*>
59*> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
60*> if nq >= k, Q = H(1) H(2) . . . H(k);
61*> if nq < k, Q = H(1) H(2) . . . H(nq-1).
62*>
63*> If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
64*> if k < nq, P = G(1) G(2) . . . G(k);
65*> if k >= nq, P = G(1) G(2) . . . G(nq-1).
66*> \endverbatim
67*
68* Arguments:
69* ==========
70*
71*> \param[in] VECT
72*> \verbatim
73*> VECT is CHARACTER*1
74*> = 'Q': apply Q or Q**T;
75*> = 'P': apply P or P**T.
76*> \endverbatim
77*>
78*> \param[in] SIDE
79*> \verbatim
80*> SIDE is CHARACTER*1
81*> = 'L': apply Q, Q**T, P or P**T from the Left;
82*> = 'R': apply Q, Q**T, P or P**T from the Right.
83*> \endverbatim
84*>
85*> \param[in] TRANS
86*> \verbatim
87*> TRANS is CHARACTER*1
88*> = 'N': No transpose, apply Q or P;
89*> = 'T': Transpose, apply Q**T or P**T.
90*> \endverbatim
91*>
92*> \param[in] M
93*> \verbatim
94*> M is INTEGER
95*> The number of rows of the matrix C. M >= 0.
96*> \endverbatim
97*>
98*> \param[in] N
99*> \verbatim
100*> N is INTEGER
101*> The number of columns of the matrix C. N >= 0.
102*> \endverbatim
103*>
104*> \param[in] K
105*> \verbatim
106*> K is INTEGER
107*> If VECT = 'Q', the number of columns in the original
108*> matrix reduced by SGEBRD.
109*> If VECT = 'P', the number of rows in the original
110*> matrix reduced by SGEBRD.
111*> K >= 0.
112*> \endverbatim
113*>
114*> \param[in] A
115*> \verbatim
116*> A is REAL array, dimension
117*> (LDA,min(nq,K)) if VECT = 'Q'
118*> (LDA,nq) if VECT = 'P'
119*> The vectors which define the elementary reflectors H(i) and
120*> G(i), whose products determine the matrices Q and P, as
121*> returned by SGEBRD.
122*> \endverbatim
123*>
124*> \param[in] LDA
125*> \verbatim
126*> LDA is INTEGER
127*> The leading dimension of the array A.
128*> If VECT = 'Q', LDA >= max(1,nq);
129*> if VECT = 'P', LDA >= max(1,min(nq,K)).
130*> \endverbatim
131*>
132*> \param[in] TAU
133*> \verbatim
134*> TAU is REAL array, dimension (min(nq,K))
135*> TAU(i) must contain the scalar factor of the elementary
136*> reflector H(i) or G(i) which determines Q or P, as returned
137*> by SGEBRD in the array argument TAUQ or TAUP.
138*> \endverbatim
139*>
140*> \param[in,out] C
141*> \verbatim
142*> C is REAL array, dimension (LDC,N)
143*> On entry, the M-by-N matrix C.
144*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
145*> or P*C or P**T*C or C*P or C*P**T.
146*> \endverbatim
147*>
148*> \param[in] LDC
149*> \verbatim
150*> LDC is INTEGER
151*> The leading dimension of the array C. LDC >= max(1,M).
152*> \endverbatim
153*>
154*> \param[out] WORK
155*> \verbatim
156*> WORK is REAL array, dimension (MAX(1,LWORK))
157*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
158*> \endverbatim
159*>
160*> \param[in] LWORK
161*> \verbatim
162*> LWORK is INTEGER
163*> The dimension of the array WORK.
164*> If SIDE = 'L', LWORK >= max(1,N);
165*> if SIDE = 'R', LWORK >= max(1,M).
166*> For optimum performance LWORK >= N*NB if SIDE = 'L', and
167*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal
168*> blocksize.
169*>
170*> If LWORK = -1, then a workspace query is assumed; the routine
171*> only calculates the optimal size of the WORK array, returns
172*> this value as the first entry of the WORK array, and no error
173*> message related to LWORK is issued by XERBLA.
174*> \endverbatim
175*>
176*> \param[out] INFO
177*> \verbatim
178*> INFO is INTEGER
179*> = 0: successful exit
180*> < 0: if INFO = -i, the i-th argument had an illegal value
181*> \endverbatim
182*
183* Authors:
184* ========
185*
186*> \author Univ. of Tennessee
187*> \author Univ. of California Berkeley
188*> \author Univ. of Colorado Denver
189*> \author NAG Ltd.
190*
191*> \ingroup realOTHERcomputational
192*
193* =====================================================================
194 SUBROUTINE sormbr( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
195 $ LDC, WORK, LWORK, INFO )
196*
197* -- LAPACK computational routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 CHARACTER SIDE, TRANS, VECT
203 INTEGER INFO, K, LDA, LDC, LWORK, M, N
204* ..
205* .. Array Arguments ..
206 REAL A( LDA, * ), C( LDC, * ), TAU( * ),
207 $ work( * )
208* ..
209*
210* =====================================================================
211*
212* .. Local Scalars ..
213 LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
214 CHARACTER TRANST
215 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
216* ..
217* .. External Functions ..
218 LOGICAL LSAME
219 INTEGER ILAENV
220 EXTERNAL ilaenv, lsame
221* ..
222* .. External Subroutines ..
223 EXTERNAL sormlq, sormqr, xerbla
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC max, min
227* ..
228* .. Executable Statements ..
229*
230* Test the input arguments
231*
232 info = 0
233 applyq = lsame( vect, 'Q' )
234 left = lsame( side, 'L' )
235 notran = lsame( trans, 'N' )
236 lquery = ( lwork.EQ.-1 )
237*
238* NQ is the order of Q or P and NW is the minimum dimension of WORK
239*
240 IF( left ) THEN
241 nq = m
242 nw = max( 1, n )
243 ELSE
244 nq = n
245 nw = max( 1, m )
246 END IF
247 IF( .NOT.applyq .AND. .NOT.lsame( vect, 'P' ) ) THEN
248 info = -1
249 ELSE IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
250 info = -2
251 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) ) THEN
252 info = -3
253 ELSE IF( m.LT.0 ) THEN
254 info = -4
255 ELSE IF( n.LT.0 ) THEN
256 info = -5
257 ELSE IF( k.LT.0 ) THEN
258 info = -6
259 ELSE IF( ( applyq .AND. lda.LT.max( 1, nq ) ) .OR.
260 $ ( .NOT.applyq .AND. lda.LT.max( 1, min( nq, k ) ) ) )
261 $ THEN
262 info = -8
263 ELSE IF( ldc.LT.max( 1, m ) ) THEN
264 info = -11
265 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
266 info = -13
267 END IF
268*
269 IF( info.EQ.0 ) THEN
270 IF( applyq ) THEN
271 IF( left ) THEN
272 nb = ilaenv( 1, 'SORMQR', side // trans, m-1, n, m-1,
273 $ -1 )
274 ELSE
275 nb = ilaenv( 1, 'SORMQR', side // trans, m, n-1, n-1,
276 $ -1 )
277 END IF
278 ELSE
279 IF( left ) THEN
280 nb = ilaenv( 1, 'SORMLQ', side // trans, m-1, n, m-1,
281 $ -1 )
282 ELSE
283 nb = ilaenv( 1, 'SORMLQ', side // trans, m, n-1, n-1,
284 $ -1 )
285 END IF
286 END IF
287 lwkopt = nw*nb
288 work( 1 ) = lwkopt
289 END IF
290*
291 IF( info.NE.0 ) THEN
292 CALL xerbla( 'SORMBR', -info )
293 RETURN
294 ELSE IF( lquery ) THEN
295 RETURN
296 END IF
297*
298* Quick return if possible
299*
300 work( 1 ) = 1
301 IF( m.EQ.0 .OR. n.EQ.0 )
302 $ RETURN
303*
304 IF( applyq ) THEN
305*
306* Apply Q
307*
308 IF( nq.GE.k ) THEN
309*
310* Q was determined by a call to SGEBRD with nq >= k
311*
312 CALL sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,
313 $ work, lwork, iinfo )
314 ELSE IF( nq.GT.1 ) THEN
315*
316* Q was determined by a call to SGEBRD with nq < k
317*
318 IF( left ) THEN
319 mi = m - 1
320 ni = n
321 i1 = 2
322 i2 = 1
323 ELSE
324 mi = m
325 ni = n - 1
326 i1 = 1
327 i2 = 2
328 END IF
329 CALL sormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,
330 $ c( i1, i2 ), ldc, work, lwork, iinfo )
331 END IF
332 ELSE
333*
334* Apply P
335*
336 IF( notran ) THEN
337 transt = 'T'
338 ELSE
339 transt = 'N'
340 END IF
341 IF( nq.GT.k ) THEN
342*
343* P was determined by a call to SGEBRD with nq > k
344*
345 CALL sormlq( side, transt, m, n, k, a, lda, tau, c, ldc,
346 $ work, lwork, iinfo )
347 ELSE IF( nq.GT.1 ) THEN
348*
349* P was determined by a call to SGEBRD with nq <= k
350*
351 IF( left ) THEN
352 mi = m - 1
353 ni = n
354 i1 = 2
355 i2 = 1
356 ELSE
357 mi = m
358 ni = n - 1
359 i1 = 1
360 i2 = 2
361 END IF
362 CALL sormlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,
363 $ tau, c( i1, i2 ), ldc, work, lwork, iinfo )
364 END IF
365 END IF
366 work( 1 ) = lwkopt
367 RETURN
368*
369* End of SORMBR
370*
371 END
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
subroutine sormbr(VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMBR
Definition: sormbr.f:196
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
Definition: sormqr.f:168
subroutine sormlq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMLQ
Definition: sormlq.f:168