|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
00001 SUBROUTINE PCUNMBR( VECT, SIDE, TRANS, M, N, K, A, IA, JA, DESCA, 00002 $ TAU, C, IC, JC, DESCC, WORK, LWORK, INFO ) 00003 * 00004 * -- ScaLAPACK routine (version 1.7) -- 00005 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00006 * and University of California, Berkeley. 00007 * May 1, 1997 00008 * 00009 * .. Scalar Arguments .. 00010 CHARACTER SIDE, TRANS, VECT 00011 INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N 00012 * .. 00013 * .. Array Arguments .. 00014 INTEGER DESCA( * ), DESCC( * ) 00015 COMPLEX A( * ), C( * ), TAU( * ), WORK( * ) 00016 * .. 00017 * 00018 * Purpose 00019 * ======= 00020 * 00021 * If VECT = 'Q', PCUNMBR overwrites the general complex distributed 00022 * M-by-N matrix sub( C ) = C(IC:IC+M-1,JC:JC+N-1) with 00023 * 00024 * SIDE = 'L' SIDE = 'R' 00025 * TRANS = 'N': Q * sub( C ) sub( C ) * Q 00026 * TRANS = 'C': Q**H * sub( C ) sub( C ) * Q**H 00027 * 00028 * If VECT = 'P', PCUNMBR overwrites sub( C ) with 00029 * 00030 * SIDE = 'L' SIDE = 'R' 00031 * TRANS = 'N': P * sub( C ) sub( C ) * P 00032 * TRANS = 'C': P**H * sub( C ) sub( C ) * P**H 00033 * 00034 * Here Q and P**H are the unitary distributed matrices determined by 00035 * PCGEBRD when reducing a complex distributed matrix A(IA:*,JA:*) to 00036 * bidiagonal form: A(IA:*,JA:*) = Q * B * P**H. Q and P**H are defined 00037 * as products of elementary reflectors H(i) and G(i) respectively. 00038 * 00039 * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the 00040 * order of the unitary matrix Q or P**H that is applied. 00041 * 00042 * If VECT = 'Q', A(IA:*,JA:*) is assumed to have been an NQ-by-K 00043 * matrix: 00044 * if nq >= k, Q = H(1) H(2) . . . H(k); 00045 * if nq < k, Q = H(1) H(2) . . . H(nq-1). 00046 * 00047 * If VECT = 'P', A(IA:*,JA:*) is assumed to have been a K-by-NQ 00048 * matrix: 00049 * if k < nq, P = G(1) G(2) . . . G(k); 00050 * if k >= nq, P = G(1) G(2) . . . G(nq-1). 00051 * 00052 * Notes 00053 * ===== 00054 * 00055 * Each global data object is described by an associated description 00056 * vector. This vector stores the information required to establish 00057 * the mapping between an object element and its corresponding process 00058 * and memory location. 00059 * 00060 * Let A be a generic term for any 2D block cyclicly distributed array. 00061 * Such a global array has an associated description vector DESCA. 00062 * In the following comments, the character _ should be read as 00063 * "of the global array". 00064 * 00065 * NOTATION STORED IN EXPLANATION 00066 * --------------- -------------- -------------------------------------- 00067 * DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case, 00068 * DTYPE_A = 1. 00069 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00070 * the BLACS process grid A is distribu- 00071 * ted over. The context itself is glo- 00072 * bal, but the handle (the integer 00073 * value) may vary. 00074 * M_A (global) DESCA( M_ ) The number of rows in the global 00075 * array A. 00076 * N_A (global) DESCA( N_ ) The number of columns in the global 00077 * array A. 00078 * MB_A (global) DESCA( MB_ ) The blocking factor used to distribute 00079 * the rows of the array. 00080 * NB_A (global) DESCA( NB_ ) The blocking factor used to distribute 00081 * the columns of the array. 00082 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00083 * row of the array A is distributed. 00084 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00085 * first column of the array A is 00086 * distributed. 00087 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00088 * array. LLD_A >= MAX(1,LOCr(M_A)). 00089 * 00090 * Let K be the number of rows or columns of a distributed matrix, 00091 * and assume that its process grid has dimension p x q. 00092 * LOCr( K ) denotes the number of elements of K that a process 00093 * would receive if K were distributed over the p processes of its 00094 * process column. 00095 * Similarly, LOCc( K ) denotes the number of elements of K that a 00096 * process would receive if K were distributed over the q processes of 00097 * its process row. 00098 * The values of LOCr() and LOCc() may be determined via a call to the 00099 * ScaLAPACK tool function, NUMROC: 00100 * LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ), 00101 * LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). 00102 * An upper bound for these quantities may be computed by: 00103 * LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A 00104 * LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A 00105 * 00106 * Arguments 00107 * ========= 00108 * 00109 * VECT (global input) CHARACTER 00110 * = 'Q': apply Q or Q**H; 00111 * = 'P': apply P or P**H. 00112 * 00113 * SIDE (global input) CHARACTER 00114 * = 'L': apply Q, Q**H, P or P**H from the Left; 00115 * = 'R': apply Q, Q**H, P or P**H from the Right. 00116 * 00117 * TRANS (global input) CHARACTER 00118 * = 'N': No transpose, apply Q or P; 00119 * = 'C': Conjugate transpose, apply Q**H or P**H. 00120 * 00121 * M (global input) INTEGER 00122 * The number of rows to be operated on i.e the number of rows 00123 * of the distributed submatrix sub( C ). M >= 0. 00124 * 00125 * N (global input) INTEGER 00126 * The number of columns to be operated on i.e the number of 00127 * columns of the distributed submatrix sub( C ). N >= 0. 00128 * 00129 * K (global input) INTEGER 00130 * If VECT = 'Q', the number of columns in the original 00131 * distributed matrix reduced by PCGEBRD. 00132 * If VECT = 'P', the number of rows in the original 00133 * distributed matrix reduced by PCGEBRD. 00134 * K >= 0. 00135 * 00136 * A (local input) COMPLEX pointer into the local memory 00137 * to an array of dimension (LLD_A,LOCc(JA+MIN(NQ,K)-1)) if 00138 * VECT='Q', and (LLD_A,LOCc(JA+NQ-1)) if VECT = 'P'. NQ = M 00139 * if SIDE = 'L', and NQ = N otherwise. The vectors which 00140 * define the elementary reflectors H(i) and G(i), whose 00141 * products determine the matrices Q and P, as returned by 00142 * PCGEBRD. 00143 * If VECT = 'Q', LLD_A >= max(1,LOCr(IA+NQ-1)); 00144 * if VECT = 'P', LLD_A >= max(1,LOCr(IA+MIN(NQ,K)-1)). 00145 * 00146 * IA (global input) INTEGER 00147 * The row index in the global array A indicating the first 00148 * row of sub( A ). 00149 * 00150 * JA (global input) INTEGER 00151 * The column index in the global array A indicating the 00152 * first column of sub( A ). 00153 * 00154 * DESCA (global and local input) INTEGER array of dimension DLEN_. 00155 * The array descriptor for the distributed matrix A. 00156 * 00157 * TAU (local input) COMPLEX array, dimension 00158 * LOCc(JA+MIN(NQ,K)-1) if VECT = 'Q', LOCr(IA+MIN(NQ,K)-1) if 00159 * VECT = 'P', TAU(i) must contain the scalar factor of the 00160 * elementary reflector H(i) or G(i), which determines Q or P, 00161 * as returned by PDGEBRD in its array argument TAUQ or TAUP. 00162 * TAU is tied to the distributed matrix A. 00163 * 00164 * C (local input/local output) COMPLEX pointer into the 00165 * local memory to an array of dimension (LLD_C,LOCc(JC+N-1)). 00166 * On entry, the local pieces of the distributed matrix sub(C). 00167 * On exit, if VECT='Q', sub( C ) is overwritten by Q*sub( C ) 00168 * or Q'*sub( C ) or sub( C )*Q' or sub( C )*Q; if VECT='P, 00169 * sub( C ) is overwritten by P*sub( C ) or P'*sub( C ) or 00170 * sub( C )*P or sub( C )*P'. 00171 * 00172 * IC (global input) INTEGER 00173 * The row index in the global array C indicating the first 00174 * row of sub( C ). 00175 * 00176 * JC (global input) INTEGER 00177 * The column index in the global array C indicating the 00178 * first column of sub( C ). 00179 * 00180 * DESCC (global and local input) INTEGER array of dimension DLEN_. 00181 * The array descriptor for the distributed matrix C. 00182 * 00183 * WORK (local workspace/local output) COMPLEX array, 00184 * dimension (LWORK) 00185 * On exit, WORK(1) returns the minimal and optimal LWORK. 00186 * 00187 * LWORK (local or global input) INTEGER 00188 * The dimension of the array WORK. 00189 * LWORK is local input and must be at least 00190 * If SIDE = 'L', 00191 * NQ = M; 00192 * if( (VECT = 'Q' and NQ >= K) or (VECT <> 'Q' and NQ > K) ), 00193 * IAA=IA; JAA=JA; MI=M; NI=N; ICC=IC; JCC=JC; 00194 * else 00195 * IAA=IA+1; JAA=JA; MI=M-1; NI=N; ICC=IC+1; JCC=JC; 00196 * end if 00197 * else if SIDE = 'R', 00198 * NQ = N; 00199 * if( (VECT = 'Q' and NQ >= K) or (VECT <> 'Q' and NQ > K) ), 00200 * IAA=IA; JAA=JA; MI=M; NI=N; ICC=IC; JCC=JC; 00201 * else 00202 * IAA=IA; JAA=JA+1; MI=M; NI=N-1; ICC=IC; JCC=JC+1; 00203 * end if 00204 * end if 00205 * 00206 * If VECT = 'Q', 00207 * If SIDE = 'L', 00208 * LWORK >= MAX( (NB_A*(NB_A-1))/2, (NqC0 + MpC0)*NB_A ) + 00209 * NB_A * NB_A 00210 * else if SIDE = 'R', 00211 * LWORK >= MAX( (NB_A*(NB_A-1))/2, ( NqC0 + MAX( NpA0 + 00212 * NUMROC( NUMROC( NI+ICOFFC, NB_A, 0, 0, NPCOL ), 00213 * NB_A, 0, 0, LCMQ ), MpC0 ) )*NB_A ) + 00214 * NB_A * NB_A 00215 * end if 00216 * else if VECT <> 'Q', 00217 * if SIDE = 'L', 00218 * LWORK >= MAX( (MB_A*(MB_A-1))/2, ( MpC0 + MAX( MqA0 + 00219 * NUMROC( NUMROC( MI+IROFFC, MB_A, 0, 0, NPROW ), 00220 * MB_A, 0, 0, LCMP ), NqC0 ) )*MB_A ) + 00221 * MB_A * MB_A 00222 * else if SIDE = 'R', 00223 * LWORK >= MAX( (MB_A*(MB_A-1))/2, (MpC0 + NqC0)*MB_A ) + 00224 * MB_A * MB_A 00225 * end if 00226 * end if 00227 * 00228 * where LCMP = LCM / NPROW, LCMQ = LCM / NPCOL, with 00229 * LCM = ICLM( NPROW, NPCOL ), 00230 * 00231 * IROFFA = MOD( IAA-1, MB_A ), ICOFFA = MOD( JAA-1, NB_A ), 00232 * IAROW = INDXG2P( IAA, MB_A, MYROW, RSRC_A, NPROW ), 00233 * IACOL = INDXG2P( JAA, NB_A, MYCOL, CSRC_A, NPCOL ), 00234 * MqA0 = NUMROC( MI+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ), 00235 * NpA0 = NUMROC( NI+IROFFA, MB_A, MYROW, IAROW, NPROW ), 00236 * 00237 * IROFFC = MOD( ICC-1, MB_C ), ICOFFC = MOD( JCC-1, NB_C ), 00238 * ICROW = INDXG2P( ICC, MB_C, MYROW, RSRC_C, NPROW ), 00239 * ICCOL = INDXG2P( JCC, NB_C, MYCOL, CSRC_C, NPCOL ), 00240 * MpC0 = NUMROC( MI+IROFFC, MB_C, MYROW, ICROW, NPROW ), 00241 * NqC0 = NUMROC( NI+ICOFFC, NB_C, MYCOL, ICCOL, NPCOL ), 00242 * 00243 * INDXG2P and NUMROC are ScaLAPACK tool functions; 00244 * MYROW, MYCOL, NPROW and NPCOL can be determined by calling 00245 * the subroutine BLACS_GRIDINFO. 00246 * 00247 * If LWORK = -1, then LWORK is global input and a workspace 00248 * query is assumed; the routine only calculates the minimum 00249 * and optimal size for all work arrays. Each of these 00250 * values is returned in the first entry of the corresponding 00251 * work array, and no error message is issued by PXERBLA. 00252 * 00253 * 00254 * INFO (global output) INTEGER 00255 * = 0: successful exit 00256 * < 0: If the i-th argument is an array and the j-entry had 00257 * an illegal value, then INFO = -(i*100+j), if the i-th 00258 * argument is a scalar and had an illegal value, then 00259 * INFO = -i. 00260 * 00261 * Alignment requirements 00262 * ====================== 00263 * 00264 * The distributed submatrices A(IA:*, JA:*) and C(IC:IC+M-1,JC:JC+N-1) 00265 * must verify some alignment properties, namely the following 00266 * expressions should be true: 00267 * 00268 * If VECT = 'Q', 00269 * If SIDE = 'L', 00270 * ( MB_A.EQ.MB_C .AND. IROFFA.EQ.IROFFC .AND. IAROW.EQ.ICROW ) 00271 * If SIDE = 'R', 00272 * ( MB_A.EQ.NB_C .AND. IROFFA.EQ.ICOFFC ) 00273 * else 00274 * If SIDE = 'L', 00275 * ( MB_A.EQ.MB_C .AND. ICOFFA.EQ.IROFFC ) 00276 * If SIDE = 'R', 00277 * ( NB_A.EQ.NB_C .AND. ICOFFA.EQ.ICOFFC .AND. IACOL.EQ.ICCOL ) 00278 * end if 00279 * 00280 * ===================================================================== 00281 * 00282 * .. Parameters .. 00283 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, 00284 $ LLD_, MB_, M_, NB_, N_, RSRC_ 00285 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, 00286 $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, 00287 $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) 00288 * .. 00289 * .. Local Scalars .. 00290 LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN 00291 CHARACTER TRANST 00292 INTEGER IAA, IACOL, IAROW, ICC, ICCOL, ICOFFA, ICOFFC, 00293 $ ICROW, ICTXT, IINFO, IROFFA, IROFFC, JAA, JCC, 00294 $ LCM, LCMP, LCMQ, LWMIN, MI, MPC0, MQA0, MYCOL, 00295 $ MYROW, NI, NPA0, NPCOL, NPROW, NQ, NQC0 00296 * .. 00297 * .. Local Arrays .. 00298 INTEGER IDUM1( 5 ), IDUM2( 5 ) 00299 * .. 00300 * .. External Subroutines .. 00301 EXTERNAL BLACS_GRIDINFO, CHK1MAT, PCHK2MAT, PCUNMLQ, 00302 $ PCUNMQR, PXERBLA 00303 * .. 00304 * .. External Functions .. 00305 LOGICAL LSAME 00306 INTEGER ILCM, INDXG2P, NUMROC 00307 EXTERNAL ILCM, INDXG2P, LSAME, NUMROC 00308 * .. 00309 * .. Intrinsic Functions .. 00310 INTRINSIC CMPLX, ICHAR, MAX, MOD, REAL 00311 * .. 00312 * .. Executable Statements .. 00313 * 00314 * Get grid parameters 00315 * 00316 ICTXT = DESCA( CTXT_ ) 00317 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 00318 * 00319 * Test the input parameters 00320 * 00321 INFO = 0 00322 IF( NPROW.EQ.-1 ) THEN 00323 INFO = -(1000+CTXT_) 00324 ELSE 00325 APPLYQ = LSAME( VECT, 'Q' ) 00326 LEFT = LSAME( SIDE, 'L' ) 00327 NOTRAN = LSAME( TRANS, 'N' ) 00328 * 00329 * NQ is the order of Q or P 00330 * 00331 IF( LEFT ) THEN 00332 NQ = M 00333 IF( ( APPLYQ .AND. NQ.GE.K ) .OR. 00334 $ ( .NOT.APPLYQ .AND. NQ.GT.K ) ) THEN 00335 IAA = IA 00336 JAA = JA 00337 MI = M 00338 NI = N 00339 ICC = IC 00340 JCC = JC 00341 ELSE 00342 IAA = IA + 1 00343 JAA = JA 00344 MI = M - 1 00345 NI = N 00346 ICC = IC + 1 00347 JCC = JC 00348 END IF 00349 * 00350 IF( APPLYQ ) THEN 00351 CALL CHK1MAT( M, 4, K, 6, IA, JA, DESCA, 10, INFO ) 00352 ELSE 00353 CALL CHK1MAT( K, 6, M, 4, IA, JA, DESCA, 10, INFO ) 00354 END IF 00355 ELSE 00356 NQ = N 00357 IF( ( APPLYQ .AND. NQ.GE.K ) .OR. 00358 $ ( .NOT.APPLYQ .AND. NQ.GT.K ) ) THEN 00359 IAA = IA 00360 JAA = JA 00361 MI = M 00362 NI = N 00363 ICC = IC 00364 JCC = JC 00365 ELSE 00366 IAA = IA 00367 JAA = JA + 1 00368 MI = M 00369 NI = N - 1 00370 ICC = IC 00371 JCC = JC + 1 00372 END IF 00373 * 00374 IF( APPLYQ ) THEN 00375 CALL CHK1MAT( N, 5, K, 6, IA, JA, DESCA, 10, INFO ) 00376 ELSE 00377 CALL CHK1MAT( K, 6, N, 5, IA, JA, DESCA, 10, INFO ) 00378 END IF 00379 END IF 00380 CALL CHK1MAT( M, 4, N, 5, IC, JC, DESCC, 15, INFO ) 00381 * 00382 IF( INFO.EQ.0 ) THEN 00383 IROFFA = MOD( IAA-1, DESCA( MB_ ) ) 00384 ICOFFA = MOD( JAA-1, DESCA( NB_ ) ) 00385 IROFFC = MOD( ICC-1, DESCC( MB_ ) ) 00386 ICOFFC = MOD( JCC-1, DESCC( NB_ ) ) 00387 IACOL = INDXG2P( JAA, DESCA( NB_ ), MYCOL, DESCA( CSRC_ ), 00388 $ NPCOL ) 00389 IAROW = INDXG2P( IAA, DESCA( MB_ ), MYROW, DESCA( RSRC_ ), 00390 $ NPROW ) 00391 ICROW = INDXG2P( ICC, DESCC( MB_ ), MYROW, DESCC( RSRC_ ), 00392 $ NPROW ) 00393 ICCOL = INDXG2P( JCC, DESCC( NB_ ), MYCOL, DESCC( CSRC_ ), 00394 $ NPCOL ) 00395 MPC0 = NUMROC( MI+IROFFC, DESCC( MB_ ), MYROW, ICROW, 00396 $ NPROW ) 00397 NQC0 = NUMROC( NI+ICOFFC, DESCC( NB_ ), MYCOL, ICCOL, 00398 $ NPCOL ) 00399 * 00400 IF( APPLYQ ) THEN 00401 IF( LEFT ) THEN 00402 LWMIN = MAX( ( DESCA( NB_ ) * ( DESCA( NB_ ) - 1 ) ) 00403 $ / 2, ( MPC0 + NQC0 ) * DESCA( NB_ ) ) + 00404 $ DESCA( NB_ ) * DESCA( NB_ ) 00405 ELSE 00406 NPA0 = NUMROC( NI+IROFFA, DESCA( MB_ ), MYROW, IAROW, 00407 $ NPROW ) 00408 LCM = ILCM( NPROW, NPCOL ) 00409 LCMQ = LCM / NPCOL 00410 LWMIN = MAX( ( DESCA( NB_ ) * ( DESCA( NB_ ) - 1 ) ) 00411 $ / 2, ( NQC0 + MAX( NPA0 + NUMROC( NUMROC( 00412 $ NI+ICOFFC, DESCA( NB_ ), 0, 0, NPCOL ), 00413 $ DESCA( NB_ ), 0, 0, LCMQ ), MPC0 ) ) * 00414 $ DESCA( NB_ ) ) + DESCA( NB_ ) * DESCA( NB_ ) 00415 END IF 00416 ELSE 00417 * 00418 IF( LEFT ) THEN 00419 MQA0 = NUMROC( MI+ICOFFA, DESCA( NB_ ), MYCOL, IACOL, 00420 $ NPCOL ) 00421 LCM = ILCM( NPROW, NPCOL ) 00422 LCMP = LCM / NPROW 00423 LWMIN = MAX( ( DESCA( MB_ ) * ( DESCA( MB_ ) - 1 ) ) 00424 $ / 2, ( MPC0 + MAX( MQA0 + NUMROC( NUMROC( 00425 $ MI+IROFFC, DESCA( MB_ ), 0, 0, NPROW ), 00426 $ DESCA( MB_ ), 0, 0, LCMP ), NQC0 ) ) * 00427 $ DESCA( MB_ ) ) + DESCA( MB_ ) * DESCA( MB_ ) 00428 ELSE 00429 LWMIN = MAX( ( DESCA( MB_ ) * ( DESCA( MB_ ) - 1 ) ) 00430 $ / 2, ( MPC0 + NQC0 ) * DESCA( MB_ ) ) + 00431 $ DESCA( MB_ ) * DESCA( MB_ ) 00432 END IF 00433 * 00434 END IF 00435 * 00436 WORK( 1 ) = CMPLX( REAL( LWMIN ) ) 00437 LQUERY = ( LWORK.EQ.-1 ) 00438 IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN 00439 INFO = -1 00440 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 00441 INFO = -2 00442 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 00443 INFO = -3 00444 ELSE IF( K.LT.0 ) THEN 00445 INFO = -6 00446 ELSE IF( APPLYQ .AND. .NOT.LEFT .AND. 00447 $ DESCA( MB_ ).NE.DESCC( NB_ ) ) THEN 00448 INFO = -(1000+NB_) 00449 ELSE IF( APPLYQ .AND. LEFT .AND. IROFFA.NE.IROFFC ) THEN 00450 INFO = -13 00451 ELSE IF( APPLYQ .AND. LEFT .AND. IAROW.NE.ICROW ) THEN 00452 INFO = -13 00453 ELSE IF( .NOT.APPLYQ .AND. LEFT .AND. 00454 $ ICOFFA.NE.IROFFC ) THEN 00455 INFO = -13 00456 ELSE IF( .NOT.APPLYQ .AND. .NOT.LEFT .AND. 00457 $ IACOL.NE.ICCOL ) THEN 00458 INFO = -14 00459 ELSE IF( APPLYQ .AND. .NOT.LEFT .AND. 00460 $ IROFFA.NE.ICOFFC ) THEN 00461 INFO = -14 00462 ELSE IF( .NOT.APPLYQ .AND. .NOT.LEFT .AND. 00463 $ ICOFFA.NE.ICOFFC ) THEN 00464 INFO = -14 00465 ELSE IF( APPLYQ .AND. LEFT .AND. 00466 $ DESCA( MB_ ).NE.DESCC( MB_ ) ) THEN 00467 INFO = -(1500+MB_) 00468 ELSE IF( .NOT.APPLYQ .AND. LEFT .AND. 00469 $ DESCA( MB_ ).NE.DESCC( MB_ ) ) THEN 00470 INFO = -(1500+MB_) 00471 ELSE IF( APPLYQ .AND. .NOT.LEFT .AND. 00472 $ DESCA( MB_ ).NE.DESCC( NB_ ) ) THEN 00473 INFO = -(1500+NB_) 00474 ELSE IF( .NOT.APPLYQ .AND. .NOT.LEFT .AND. 00475 $ DESCA( NB_ ).NE.DESCC( NB_ ) ) THEN 00476 INFO = -(1500+NB_) 00477 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 00478 INFO = -17 00479 END IF 00480 END IF 00481 * 00482 IF( APPLYQ ) THEN 00483 IDUM1( 1 ) = ICHAR( 'Q' ) 00484 ELSE 00485 IDUM1( 1 ) = ICHAR( 'P' ) 00486 END IF 00487 IDUM2( 1 ) = 1 00488 IF( LEFT ) THEN 00489 IDUM1( 2 ) = ICHAR( 'L' ) 00490 ELSE 00491 IDUM1( 2 ) = ICHAR( 'R' ) 00492 END IF 00493 IDUM2( 2 ) = 2 00494 IF( NOTRAN ) THEN 00495 IDUM1( 3 ) = ICHAR( 'N' ) 00496 ELSE 00497 IDUM1( 3 ) = ICHAR( 'C' ) 00498 END IF 00499 IDUM2( 3 ) = 3 00500 IDUM1( 4 ) = K 00501 IDUM2( 4 ) = 6 00502 IF( LWORK.EQ.-1 ) THEN 00503 IDUM1( 5 ) = -1 00504 ELSE 00505 IDUM1( 5 ) = 1 00506 END IF 00507 IDUM2( 5 ) = 17 00508 IF( APPLYQ ) THEN 00509 IF( LEFT ) THEN 00510 CALL PCHK2MAT( M, 4, K, 6, IA, JA, DESCA, 10, M, 4, N, 00511 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 00512 $ INFO ) 00513 ELSE 00514 CALL PCHK2MAT( N, 5, K, 6, IA, JA, DESCA, 10, M, 4, N, 00515 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 00516 $ INFO ) 00517 END IF 00518 ELSE 00519 IF( LEFT ) THEN 00520 CALL PCHK2MAT( K, 6, M, 4, IA, JA, DESCA, 10, M, 4, N, 00521 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 00522 $ INFO ) 00523 ELSE 00524 CALL PCHK2MAT( K, 6, N, 5, IA, JA, DESCA, 10, M, 4, N, 00525 $ 5, IC, JC, DESCC, 15, 5, IDUM1, IDUM2, 00526 $ INFO ) 00527 END IF 00528 END IF 00529 END IF 00530 * 00531 IF( INFO.NE.0 ) THEN 00532 CALL PXERBLA( ICTXT, 'PCUNMBR', -INFO ) 00533 RETURN 00534 ELSE IF( LQUERY ) THEN 00535 RETURN 00536 END IF 00537 * 00538 * Quick return if possible 00539 * 00540 IF( M.EQ.0 .OR. N.EQ.0 ) 00541 $ RETURN 00542 * 00543 IF( APPLYQ ) THEN 00544 * 00545 * Apply Q 00546 * 00547 IF( NQ.GE.K ) THEN 00548 * 00549 * Q was determined by a call to PCGEBRD with nq >= k 00550 * 00551 CALL PCUNMQR( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, 00552 $ C, IC, JC, DESCC, WORK, LWORK, IINFO ) 00553 ELSE IF( NQ.GT.1 ) THEN 00554 * 00555 * Q was determined by a call to PCGEBRD with nq < k 00556 * 00557 CALL PCUNMQR( SIDE, TRANS, MI, NI, NQ-1, A, IA+1, JA, DESCA, 00558 $ TAU, C, ICC, JCC, DESCC, WORK, LWORK, IINFO ) 00559 END IF 00560 ELSE 00561 * 00562 * Apply P 00563 * 00564 IF( NOTRAN ) THEN 00565 TRANST = 'C' 00566 ELSE 00567 TRANST = 'N' 00568 END IF 00569 IF( NQ.GT.K ) THEN 00570 * 00571 * P was determined by a call to PCGEBRD with nq > k 00572 * 00573 CALL PCUNMLQ( SIDE, TRANST, M, N, K, A, IA, JA, DESCA, TAU, 00574 $ C, IC, JC, DESCC, WORK, LWORK, IINFO ) 00575 ELSE IF( NQ.GT.1 ) THEN 00576 * 00577 * P was determined by a call to PCGEBRD with nq <= k 00578 * 00579 CALL PCUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A, IA, JA+1, 00580 $ DESCA, TAU, C, ICC, JCC, DESCC, WORK, LWORK, 00581 $ IINFO ) 00582 END IF 00583 END IF 00584 * 00585 WORK( 1 ) = CMPLX( REAL( LWMIN ) ) 00586 * 00587 RETURN 00588 * 00589 * End of PCUNMBR 00590 * 00591 END
