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 372