LAPACK 3.12.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 unmbr
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 REAL SROUNDUP_LWORK
221 EXTERNAL ilaenv, lsame, sroundup_lwork
222* ..
223* .. External Subroutines ..
224 EXTERNAL sormlq, sormqr, xerbla
225* ..
226* .. Intrinsic Functions ..
227 INTRINSIC max, min
228* ..
229* .. Executable Statements ..
230*
231* Test the input arguments
232*
233 info = 0
234 applyq = lsame( vect, 'Q' )
235 left = lsame( side, 'L' )
236 notran = lsame( trans, 'N' )
237 lquery = ( lwork.EQ.-1 )
238*
239* NQ is the order of Q or P and NW is the minimum dimension of WORK
240*
241 IF( left ) THEN
242 nq = m
243 nw = max( 1, n )
244 ELSE
245 nq = n
246 nw = max( 1, m )
247 END IF
248 IF( .NOT.applyq .AND. .NOT.lsame( vect, 'P' ) ) THEN
249 info = -1
250 ELSE IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
251 info = -2
252 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) ) THEN
253 info = -3
254 ELSE IF( m.LT.0 ) THEN
255 info = -4
256 ELSE IF( n.LT.0 ) THEN
257 info = -5
258 ELSE IF( k.LT.0 ) THEN
259 info = -6
260 ELSE IF( ( applyq .AND. lda.LT.max( 1, nq ) ) .OR.
261 $ ( .NOT.applyq .AND. lda.LT.max( 1, min( nq, k ) ) ) )
262 $ THEN
263 info = -8
264 ELSE IF( ldc.LT.max( 1, m ) ) THEN
265 info = -11
266 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
267 info = -13
268 END IF
269*
270 IF( info.EQ.0 ) THEN
271 IF( applyq ) THEN
272 IF( left ) THEN
273 nb = ilaenv( 1, 'SORMQR', side // trans, m-1, n, m-1,
274 $ -1 )
275 ELSE
276 nb = ilaenv( 1, 'SORMQR', side // trans, m, n-1, n-1,
277 $ -1 )
278 END IF
279 ELSE
280 IF( left ) THEN
281 nb = ilaenv( 1, 'SORMLQ', side // trans, m-1, n, m-1,
282 $ -1 )
283 ELSE
284 nb = ilaenv( 1, 'SORMLQ', side // trans, m, n-1, n-1,
285 $ -1 )
286 END IF
287 END IF
288 lwkopt = nw*nb
289 work( 1 ) = sroundup_lwork(lwkopt)
290 END IF
291*
292 IF( info.NE.0 ) THEN
293 CALL xerbla( 'SORMBR', -info )
294 RETURN
295 ELSE IF( lquery ) THEN
296 RETURN
297 END IF
298*
299* Quick return if possible
300*
301 work( 1 ) = 1
302 IF( m.EQ.0 .OR. n.EQ.0 )
303 $ RETURN
304*
305 IF( applyq ) THEN
306*
307* Apply Q
308*
309 IF( nq.GE.k ) THEN
310*
311* Q was determined by a call to SGEBRD with nq >= k
312*
313 CALL sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,
314 $ work, lwork, iinfo )
315 ELSE IF( nq.GT.1 ) THEN
316*
317* Q was determined by a call to SGEBRD with nq < k
318*
319 IF( left ) THEN
320 mi = m - 1
321 ni = n
322 i1 = 2
323 i2 = 1
324 ELSE
325 mi = m
326 ni = n - 1
327 i1 = 1
328 i2 = 2
329 END IF
330 CALL sormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,
331 $ c( i1, i2 ), ldc, work, lwork, iinfo )
332 END IF
333 ELSE
334*
335* Apply P
336*
337 IF( notran ) THEN
338 transt = 'T'
339 ELSE
340 transt = 'N'
341 END IF
342 IF( nq.GT.k ) THEN
343*
344* P was determined by a call to SGEBRD with nq > k
345*
346 CALL sormlq( side, transt, m, n, k, a, lda, tau, c, ldc,
347 $ work, lwork, iinfo )
348 ELSE IF( nq.GT.1 ) THEN
349*
350* P was determined by a call to SGEBRD with nq <= k
351*
352 IF( left ) THEN
353 mi = m - 1
354 ni = n
355 i1 = 2
356 i2 = 1
357 ELSE
358 mi = m
359 ni = n - 1
360 i1 = 1
361 i2 = 2
362 END IF
363 CALL sormlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,
364 $ tau, c( i1, i2 ), ldc, work, lwork, iinfo )
365 END IF
366 END IF
367 work( 1 ) = sroundup_lwork(lwkopt)
368 RETURN
369*
370* End of SORMBR
371*
372 END
subroutine xerbla(srname, info)
Definition cblat2.f:3285
subroutine sormbr(vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMBR
Definition sormbr.f:196
subroutine sormlq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMLQ
Definition sormlq.f:168
subroutine sormqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMQR
Definition sormqr.f:168