1 SUBROUTINE PSORMBR( VECT, SIDE, TRANS, M, N, K, A, IA, JA, DESCA, 2 $ TAU, C, IC, JC, DESCC, WORK, LWORK, INFO ) 3* 4* -- ScaLAPACK routine (version 1.7) -- 5* University of Tennessee, Knoxville, Oak Ridge National Laboratory, 6* and University of California, Berkeley. 7* May 1, 1997 8* 9* .. Scalar Arguments .. 10 CHARACTER SIDE, TRANS, VECT 11 INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N 12* .. 13* .. Array Arguments .. 14 INTEGER DESCA( * ), DESCC( * ) 15 REAL A( * ), C( * ), TAU( * ), WORK( * ) 16* .. 17* 18* Purpose 19* ======= 20* 21* If VECT = 'Q', PSORMBR overwrites the general real distributed M-by-N 22* matrix sub( C ) = C(IC:IC+M-1,JC:JC+N-1) with 23* 24* SIDE = 'L' SIDE = 'R' 25* TRANS = 'N': Q * sub( C ) sub( C ) * Q 26* TRANS = 'T': Q**T * sub( C ) sub( C ) * Q**T 27* 28* If VECT = 'P', PSORMBR overwrites sub( C ) with 29* 30* SIDE = 'L' SIDE = 'R' 31* TRANS = 'N': P * sub( C ) sub( C ) * P 32* TRANS = 'T': P**T * sub( C ) sub( C ) * P**T 33* 34* Here Q and P**T are the orthogonal distributed matrices determined by 35* PSGEBRD when reducing a real distributed matrix A(IA:*,JA:*) to 36* bidiagonal form: A(IA:*,JA:*) = Q * B * P**T. Q and P**T are defined 37* as products of elementary reflectors H(i) and G(i) respectively. 38* 39* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the 40* order of the orthogonal matrix Q or P**T that is applied. 41* 42* If VECT = 'Q', A(IA:*,JA:*) is assumed to have been an NQ-by-K 43* matrix: 44* if nq >= k, Q = H(1) H(2) . . . H(k); 45* if nq < k, Q = H(1) H(2) . . . H(nq-1). 46* 47* If VECT = 'P', A(IA:*,JA:*) is assumed to have been a K-by-NQ 48* matrix: 49* if k < nq, P = G(1) G(2) . . . G(k); 50* if k >= nq, P = G(1) G(2) . . . G(nq-1). 51* 52* Notes 53* ===== 54* 55* Each global data object is described by an associated description 56* vector. This vector stores the information required to establish 57* the mapping between an object element and its corresponding process 58* and memory location. 59* 60* Let A be a generic term for any 2D block cyclicly distributed array. 61* Such a global array has an associated description vector DESCA. 62* In the following comments, the character _ should be read as 63* "of the global array". 64* 65* NOTATION STORED IN EXPLANATION 66* --------------- -------------- -------------------------------------- 67* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case, 68* DTYPE_A = 1. 69* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 70* the BLACS process grid A is distribu- 71* ted over. The context itself is glo- 72* bal, but the handle (the integer 73* value) may vary. 74* M_A (global) DESCA( M_ ) The number of rows in the global 75* array A. 76* N_A (global) DESCA( N_ ) The number of columns in the global 77* array A. 78* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute 79* the rows of the array. 80* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute 81* the columns of the array. 82* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 83* row of the array A is distributed. 84* CSRC_A (global) DESCA( CSRC_ ) The process column over which the 85* first column of the array A is 86* distributed. 87* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 88* array. LLD_A >= MAX(1,LOCr(M_A)). 89* 90* Let K be the number of rows or columns of a distributed matrix, 91* and assume that its process grid has dimension p x q. 92* LOCr( K ) denotes the number of elements of K that a process 93* would receive if K were distributed over the p processes of its 94* process column. 95* Similarly, LOCc( K ) denotes the number of elements of K that a 96* process would receive if K were distributed over the q processes of 97* its process row. 98* The values of LOCr() and LOCc() may be determined via a call to the 99* ScaLAPACK tool function, NUMROC: 100* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ), 101* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). 102* An upper bound for these quantities may be computed by: 103* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A 104* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A 105* 106* Arguments 107* ========= 108* 109* VECT (global input) CHARACTER 110* = 'Q': apply Q or Q**T; 111* = 'P': apply P or P**T. 112* 113* SIDE (global input) CHARACTER 114* = 'L': apply Q, Q**T, P or P**T from the Left; 115* = 'R': apply Q, Q**T, P or P**T from the Right. 116* 117* TRANS (global input) CHARACTER 118* = 'N': No transpose, apply Q or P; 119* = 'T': Transpose, apply Q**T or P**T. 120* 121* M (global input) INTEGER 122* The number of rows to be operated on i.e the number of rows 123* of the distributed submatrix sub( C ). M >= 0. 124* 125* N (global input) INTEGER 126* The number of columns to be operated on i.e the number of 127* columns of the distributed submatrix sub( C ). N >= 0. 128* 129* K (global input) INTEGER 130* If VECT = 'Q', the number of columns in the original 131* distributed matrix reduced by PSGEBRD. 132* If VECT = 'P', the number of rows in the original 133* distributed matrix reduced by PSGEBRD. 134* K >= 0. 135* 136* A (local input) REAL pointer into the local memory 137* to an array of dimension (LLD_A,LOCc(JA+MIN(NQ,K)-1)) if 138* VECT='Q', and (LLD_A,LOCc(JA+NQ-1)) if VECT = 'P'. NQ = M 139* if SIDE = 'L', and NQ = N otherwise. The vectors which 140* define the elementary reflectors H(i) and G(i), whose 141* products determine the matrices Q and P, as returned by 142* PSGEBRD. 143* If VECT = 'Q', LLD_A >= max(1,LOCr(IA+NQ-1)); 144* if VECT = 'P', LLD_A >= max(1,LOCr(IA+MIN(NQ,K)-1)). 145* 146* IA (global input) INTEGER 147* The row index in the global array A indicating the first 148* row of sub( A ). 149* 150* JA (global input) INTEGER 151* The column index in the global array A indicating the 152* first column of sub( A ). 153* 154* DESCA (global and local input) INTEGER array of dimension DLEN_. 155* The array descriptor for the distributed matrix A. 156* 157* TAU (local input) REAL array, dimension 158* LOCc(JA+MIN(NQ,K)-1) if VECT = 'Q', LOCr(IA+MIN(NQ,K)-1) if 159* VECT = 'P', TAU(i) must contain the scalar factor of the 160* elementary reflector H(i) or G(i), which determines Q or P, 161* as returned by PDGEBRD in its array argument TAUQ or TAUP. 162* TAU is tied to the distributed matrix A. 163* 164* C (local input/local output) REAL pointer into the 165* local memory to an array of dimension (LLD_C,LOCc(JC+N-1)). 166* On entry, the local pieces of the distributed matrix sub(C). 167* On exit, if VECT='Q', sub( C ) is overwritten by Q*sub( C ) 168* or Q'*sub( C ) or sub( C )*Q' or sub( C )*Q; if VECT='P, 169* sub( C ) is overwritten by P*sub( C ) or P'*sub( C ) or 170* sub( C )*P or sub( C )*P'. 171* 172* IC (global input) INTEGER 173* The row index in the global array C indicating the first 174* row of sub( C ). 175* 176* JC (global input) INTEGER 177* The column index in the global array C indicating the 178* first column of sub( C ). 179* 180* DESCC (global and local input) INTEGER array of dimension DLEN_. 181* The array descriptor for the distributed matrix C. 182* 183* WORK (local workspace/local output) REAL array, 184* dimension (LWORK) 185* On exit, WORK(1) returns the minimal and optimal LWORK. 186* 187* LWORK (local or global input) INTEGER 188* The dimension of the array WORK. 189* LWORK is local input and must be at least 190* If SIDE = 'L', 191* NQ = M; 192* if( (VECT = 'Q' and NQ >= K) or (VECT <> 'Q' and NQ > K) ), 193* IAA=IA; JAA=JA; MI=M; NI=N; ICC=IC; JCC=JC; 194* else 195* IAA=IA+1; JAA=JA; MI=M-1; NI=N; ICC=IC+1; JCC=JC; 196* end if 197* else if SIDE = 'R', 198* NQ = N; 199* if( (VECT = 'Q' and NQ >= K) or (VECT <> 'Q' and NQ > K) ), 200* IAA=IA; JAA=JA; MI=M; NI=N; ICC=IC; JCC=JC; 201* else 202* IAA=IA; JAA=JA+1; MI=M; NI=N-1; ICC=IC; JCC=JC+1; 203* end if 204* end if 205* 206* If VECT = 'Q', 207* If SIDE = 'L', 208* LWORK >= MAX( (NB_A*(NB_A-1))/2, (NqC0 + MpC0)*NB_A ) + 209* NB_A * NB_A 210* else if SIDE = 'R', 211* LWORK >= MAX( (NB_A*(NB_A-1))/2, ( NqC0 + MAX( NpA0 + 212* NUMROC( NUMROC( NI+ICOFFC, NB_A, 0, 0, NPCOL ), 213* NB_A, 0, 0, LCMQ ), MpC0 ) )*NB_A ) + 214* NB_A * NB_A 215* end if 216* else if VECT <> 'Q', 217* if SIDE = 'L', 218* LWORK >= MAX( (MB_A*(MB_A-1))/2, ( MpC0 + MAX( MqA0 + 219* NUMROC( NUMROC( MI+IROFFC, MB_A, 0, 0, NPROW ), 220* MB_A, 0, 0, LCMP ), NqC0 ) )*MB_A ) + 221* MB_A * MB_A 222* else if SIDE = 'R', 223* LWORK >= MAX( (MB_A*(MB_A-1))/2, (MpC0 + NqC0)*MB_A ) + 224* MB_A * MB_A 225* end if 226* end if 227* 228* where LCMP = LCM / NPROW, LCMQ = LCM / NPCOL, with 229* LCM = ICLM( NPROW, NPCOL ), 230* 231* IROFFA = MOD( IAA-1, MB_A ), ICOFFA = MOD( JAA-1, NB_A ), 232* IAROW = INDXG2P( IAA, MB_A, MYROW, RSRC_A, NPROW ), 233* IACOL = INDXG2P( JAA, NB_A, MYCOL, CSRC_A, NPCOL ), 234* MqA0 = NUMROC( MI+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ), 235* NpA0 = NUMROC( NI+IROFFA, MB_A, MYROW, IAROW, NPROW ), 236* 237* IROFFC = MOD( ICC-1, MB_C ), ICOFFC = MOD( JCC-1, NB_C ), 238* ICROW = INDXG2P( ICC, MB_C, MYROW, RSRC_C, NPROW ), 239* ICCOL = INDXG2P( JCC, NB_C, MYCOL, CSRC_C, NPCOL ), 240* MpC0 = NUMROC( MI+IROFFC, MB_C, MYROW, ICROW, NPROW ), 241* NqC0 = NUMROC( NI+ICOFFC, NB_C, MYCOL, ICCOL, NPCOL ), 242* 243* INDXG2P and NUMROC are ScaLAPACK tool functions; 244* MYROW, MYCOL, NPROW and NPCOL can be determined by calling 245* the subroutine BLACS_GRIDINFO. 246* 247* If LWORK = -1, then LWORK is global input and a workspace 248* query is assumed; the routine only calculates the minimum 249* and optimal size for all work arrays. Each of these 250* values is returned in the first entry of the corresponding 251* work array, and no error message is issued by PXERBLA. 252* 253* 254* INFO (global output) INTEGER 255* = 0: successful exit 256* < 0: If the i-th argument is an array and the j-entry had 257* an illegal value, then INFO = -(i*100+j), if the i-th 258* argument is a scalar and had an illegal value, then 259* INFO = -i. 260* 261* Alignment requirements 262* ====================== 263* 264* The distributed submatrices A(IA:*, JA:*) and C(IC:IC+M-1,JC:JC+N-1) 265* must verify some alignment properties, namely the following 266* expressions should be true: 267* 268* If VECT = 'Q', 269* If SIDE = 'L', 270* ( MB_A.EQ.MB_C .AND. IROFFA.EQ.IROFFC .AND. IAROW.EQ.ICROW ) 271* If SIDE = 'R', 272* ( MB_A.EQ.NB_C .AND. IROFFA.EQ.ICOFFC ) 273* else 274* If SIDE = 'L', 275* ( MB_A.EQ.MB_C .AND. ICOFFA.EQ.IROFFC ) 276* If SIDE = 'R', 277* ( NB_A.EQ.NB_C .AND. ICOFFA.EQ.ICOFFC .AND. IACOL.EQ.ICCOL ) 278* end if 279* 280* ===================================================================== 281* 282* .. Parameters .. 283 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, 284 $ LLD_, MB_, M_, NB_, N_, RSRC_ 285 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, 286 $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, 287 $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) 288* .. 289* .. Local Scalars .. 290 LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN 291 CHARACTER TRANST 292 INTEGER IAA, IACOL, IAROW, ICC, ICCOL, ICOFFA, ICOFFC, 293 $ ICROW, ICTXT, IINFO, IROFFA, IROFFC, JAA, JCC, 294 $ LCM, LCMP, LCMQ, LWMIN, MI, MPC0, MQA0, MYCOL, 295 $ MYROW, NI, NPA0, NPCOL, NPROW, NQ, NQC0 296* .. 297* .. Local Arrays .. 298 INTEGER IDUM1( 5 ), IDUM2( 5 ) 299* .. 300* .. External Subroutines .. 301 EXTERNAL BLACS_GRIDINFO, CHK1MAT, PCHK2MAT, PSORMLQ, 302 $ PSORMQR, PXERBLA 303* .. 304* .. External Functions .. 305 LOGICAL LSAME 306 INTEGER ILCM, INDXG2P, NUMROC 307 EXTERNAL ILCM, INDXG2P, LSAME, NUMROC 308* .. 309* .. Intrinsic Functions .. 310 INTRINSIC ICHAR, MAX, MOD, REAL 311* .. 312* .. Executable Statements .. 313* 314* Get grid parameters 315* 316 ICTXT = DESCA( CTXT_ ) 317 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 318* 319* Test the input parameters 320* 321 INFO = 0 322 IF( NPROW.EQ.-1 ) THEN 323 INFO = -(1000+CTXT_) 324 ELSE 325 APPLYQ = LSAME( VECT, 'Q' ) 326 LEFT = LSAME( SIDE, 'L' ) 327 NOTRAN = LSAME( TRANS, 'N' ) 328* 329* NQ is the order of Q or P 330* 331 IF( LEFT ) THEN 332 NQ = M 333 IF( ( APPLYQ .AND. NQ.GE.K ) .OR. 334 $ ( .NOT.APPLYQ .AND. NQ.GT.K ) ) THEN 335 IAA = IA 336 JAA = JA 337 MI = M 338 NI = N 339 ICC = IC 340 JCC = JC 341 ELSE 342 IAA = IA + 1 343 JAA = JA 344 MI = M - 1 345 NI = N 346 ICC = IC + 1 347 JCC = JC 348 END IF 349* 350 IF( APPLYQ ) THEN 351 CALL CHK1MAT( M, 4, K, 6, IA, JA, DESCA, 10, INFO ) 352 ELSE 353 CALL CHK1MAT( K, 6, M, 4, IA, JA, DESCA, 10, INFO ) 354 END IF 355 ELSE 356 NQ = N 357 IF( ( APPLYQ .AND. NQ.GE.K ) .OR. 358 $ ( .NOT.APPLYQ .AND. NQ.GT.K ) ) THEN 359 IAA = IA 360 JAA = JA 361 MI = M 362 NI = N 363 ICC = IC 364 JCC = JC 365 ELSE 366 IAA = IA 367 JAA = JA + 1 368 MI = M 369 NI = N - 1 370 ICC = IC 371 JCC = JC + 1 372 END IF 373* 374 IF( APPLYQ ) THEN 375 CALL CHK1MAT( N, 5, K, 6, IA, JA, DESCA, 10, INFO ) 376 ELSE 377 CALL CHK1MAT( K, 6, N, 5, IA, JA, DESCA, 10, INFO ) 378 END IF 379 END IF 380 CALL CHK1MAT( M, 4, N, 5, IC, JC, DESCC, 15, INFO ) 381* 382 IF( INFO.EQ.0 ) THEN 383 IROFFA = MOD( IAA-1, DESCA( MB_ ) ) 384 ICOFFA = MOD( JAA-1, DESCA( NB_ ) ) 385 IROFFC = MOD( ICC-1, DESCC( MB_ ) ) 386 ICOFFC = MOD( JCC-1, DESCC( NB_ ) ) 387 IACOL = INDXG2P( JAA, DESCA( NB_ ), MYCOL, DESCA( CSRC_ ), 388 $ NPCOL ) 389 IAROW = INDXG2P( IAA, DESCA( MB_ ), MYROW, DESCA( RSRC_ ), 390 $ NPROW ) 391 ICROW = INDXG2P( ICC, DESCC( MB_ ), MYROW, DESCC( RSRC_ ), 392 $ NPROW ) 393 ICCOL = INDXG2P( JCC, DESCC( NB_ ), MYCOL, DESCC( CSRC_ ), 394 $ NPCOL ) 395 MPC0 = NUMROC( MI+IROFFC, DESCC( MB_ ), MYROW, ICROW, 396 $ NPROW ) 397 NQC0 = NUMROC( NI+ICOFFC, DESCC( NB_ ), MYCOL, ICCOL, 398 $ NPCOL ) 399* 400 IF( APPLYQ ) THEN 401 IF( LEFT ) THEN 402 LWMIN = MAX( ( DESCA( NB_ ) * ( DESCA( NB_ ) - 1 ) ) 403 $ / 2, ( MPC0 + NQC0 ) * DESCA( NB_ ) ) + 404 $ DESCA( NB_ ) * DESCA( NB_ ) 405 ELSE 406 NPA0 = NUMROC( NI+IROFFA, DESCA( MB_ ), MYROW, IAROW, 407 $ NPROW ) 408 LCM = ILCM( NPROW, NPCOL ) 409 LCMQ = LCM / NPCOL 410 LWMIN = MAX( ( DESCA( NB_ ) * ( DESCA( NB_ ) - 1 ) ) 411 $ / 2, ( NQC0 + MAX( NPA0 + NUMROC( NUMROC( 412 $ NI+ICOFFC, DESCA( NB_ ), 0, 0, NPCOL ), 413 $ DESCA( NB_ ), 0, 0, LCMQ ), MPC0 ) ) * 414 $ DESCA( NB_ ) ) + DESCA( NB_ ) * DESCA( NB_ ) 415 END IF 416 ELSE 417* 418 IF( LEFT ) THEN 419 MQA0 = NUMROC( MI+ICOFFA, DESCA( NB_ ), MYCOL, IACOL, 420 $ NPCOL ) 421 LCM = ILCM( NPROW, NPCOL ) 422 LCMP = LCM / NPROW 423 LWMIN = MAX( ( DESCA( MB_ ) * ( DESCA( MB_ ) - 1 ) ) 424 $ / 2, ( MPC0 + MAX( MQA0 + NUMROC( NUMROC( 425 $ MI+IROFFC, DESCA( MB_ ), 0, 0, NPROW ), 426 $ DESCA( MB_ ), 0, 0, LCMP ), NQC0 ) ) * 427 $ DESCA( MB_ ) ) + DESCA( MB_ ) * DESCA( MB_ ) 428 ELSE 429 LWMIN = MAX( ( DESCA( MB_ ) * ( DESCA( MB_ ) - 1 ) ) 430 $ / 2, ( MPC0 + NQC0 ) * DESCA( MB_ ) ) + 431 $ DESCA( MB_ ) * DESCA( MB_ ) 432 END IF 433* 434 END IF 435* 436 WORK( 1 ) = REAL( LWMIN ) 437 LQUERY = ( LWORK.EQ.-1 ) 438 IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN 439 INFO = -1 440 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 441 INFO = -2 442 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 443 INFO = -3 444 ELSE IF( K.LT.0 ) THEN 445 INFO = -6 446 ELSE IF( APPLYQ .AND. .NOT.LEFT .AND. 447 $ DESCA( MB_ ).NE.DESCC( NB_ ) ) THEN 448 INFO = -(1000+NB_) 449 ELSE IF( APPLYQ .AND. LEFT .AND. IROFFA.NE.IROFFC ) THEN 450 INFO = -13 451 ELSE IF( APPLYQ .AND. LEFT .AND. IAROW.NE.ICROW ) THEN 452 INFO = -13 453 ELSE IF( .NOT.APPLYQ .AND. LEFT .AND. 454 $ ICOFFA.NE.IROFFC ) THEN 455 INFO = -13 456 ELSE IF( .NOT.APPLYQ .AND. .NOT.LEFT .AND. 457 $ IACOL.NE.ICCOL ) THEN 458 INFO = -14 459 ELSE IF( APPLYQ .AND. .NOT.LEFT .AND. 460 $ IROFFA.NE.ICOFFC ) THEN 461 INFO = -14 462 ELSE IF( .NOT.APPLYQ .AND. .NOT.LEFT .AND. 463 $ ICOFFA.NE.ICOFFC ) THEN 464 INFO = -14 465 ELSE IF( APPLYQ .AND. LEFT .AND. 466 $ DESCA( MB_ ).NE.DESCC( MB_ ) ) THEN 467 INFO = -(1500+MB_) 468 ELSE IF( .NOT.APPLYQ .AND. LEFT .AND. 469 $ DESCA( MB_ ).NE.DESCC( MB_ ) ) THEN 470 INFO = -(1500+MB_) 471 ELSE IF( APPLYQ .AND. .NOT.LEFT .AND. 472 $ DESCA( MB_ ).NE.DESCC( NB_ ) ) THEN 473 INFO = -(1500+NB_) 474 ELSE IF( .NOT.APPLYQ .AND. .NOT.LEFT .AND. 475 $ DESCA( NB_ ).NE.DESCC( NB_ ) ) THEN 476 INFO = -(1500+NB_) 477 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 478 INFO = -17 479 END IF 480 END IF 481* 482 IF( APPLYQ ) THEN 483 IDUM1( 1 ) = ICHAR( 'Q' ) 484 ELSE 485 IDUM1( 1 ) = ICHAR( 'P' ) 486 END IF 487 IDUM2( 1 ) = 1 488 IF( LEFT ) THEN 489 IDUM1( 2 ) = ICHAR( 'L' ) 490 ELSE 491 IDUM1( 2 ) = ICHAR( 'R' ) 492 END IF 493 IDUM2( 2 ) = 2 494 IF( NOTRAN ) THEN 495 IDUM1( 3 ) = ICHAR( 'N' ) 496 ELSE 497 IDUM1( 3 ) = ICHAR( 'T' ) 498 END IF 499 IDUM2( 3 ) = 3 500 IDUM1( 4 ) = K 501 IDUM2( 4 ) = 6 502 IF( LWORK.EQ.-1 ) THEN 503 IDUM1( 5 ) = -1 504 ELSE 505 IDUM1( 5 ) = 1 506 END IF 507 IDUM2( 5 ) = 17 508 IF( APPLYQ ) THEN 509 IF( LEFT ) THEN 510 CALL PCHK2MAT( M, 4, K, 6, IA, JA, DESCA, 10, M, 4, N, 511 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 512 $ INFO ) 513 ELSE 514 CALL PCHK2MAT( N, 5, K, 6, IA, JA, DESCA, 10, M, 4, N, 515 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 516 $ INFO ) 517 END IF 518 ELSE 519 IF( LEFT ) THEN 520 CALL PCHK2MAT( K, 6, M, 4, IA, JA, DESCA, 10, M, 4, N, 521 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 522 $ INFO ) 523 ELSE 524 CALL PCHK2MAT( K, 6, N, 5, IA, JA, DESCA, 10, M, 4, N, 525 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 526 $ INFO ) 527 END IF 528 END IF 529 END IF 530* 531 IF( INFO.NE.0 ) THEN 532 CALL PXERBLA( ICTXT, 'PSORMBR', -INFO ) 533 RETURN 534 ELSE IF( LQUERY ) THEN 535 RETURN 536 END IF 537* 538* Quick return if possible 539* 540 IF( M.EQ.0 .OR. N.EQ.0 ) 541 $ RETURN 542* 543 IF( APPLYQ ) THEN 544* 545* Apply Q 546* 547 IF( NQ.GE.K ) THEN 548* 549* Q was determined by a call to PSGEBRD with nq >= k 550* 551 CALL PSORMQR( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, 552 $ C, IC, JC, DESCC, WORK, LWORK, IINFO ) 553 ELSE IF( NQ.GT.1 ) THEN 554* 555* Q was determined by a call to PSGEBRD with nq < k 556* 557 CALL PSORMQR( SIDE, TRANS, MI, NI, NQ-1, A, IA+1, JA, DESCA, 558 $ TAU, C, ICC, JCC, DESCC, WORK, LWORK, IINFO ) 559 END IF 560 ELSE 561* 562* Apply P 563* 564 IF( NOTRAN ) THEN 565 TRANST = 'T' 566 ELSE 567 TRANST = 'N' 568 END IF 569 IF( NQ.GT.K ) THEN 570* 571* P was determined by a call to PSGEBRD with nq > k 572* 573 CALL PSORMLQ( SIDE, TRANST, M, N, K, A, IA, JA, DESCA, TAU, 574 $ C, IC, JC, DESCC, WORK, LWORK, IINFO ) 575 ELSE IF( NQ.GT.1 ) THEN 576* 577* P was determined by a call to PSGEBRD with nq <= k 578* 579 CALL PSORMLQ( SIDE, TRANST, MI, NI, NQ-1, A, IA, JA+1, 580 $ DESCA, TAU, C, ICC, JCC, DESCC, WORK, LWORK, 581 $ IINFO ) 582 END IF 583 END IF 584* 585 WORK( 1 ) = REAL( LWMIN ) 586* 587 RETURN 588* 589* End of PSORMBR 590* 591 END 592