|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
00001 SUBROUTINE PCOPTEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME ) 00002 * 00003 * -- PBLAS test routine (version 2.0) -- 00004 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00005 * and University of California, Berkeley. 00006 * April 1, 1998 00007 * 00008 * .. Scalar Arguments .. 00009 INTEGER ICTXT, NOUT, SCODE 00010 * .. 00011 * .. Array Arguments .. 00012 CHARACTER*(*) SNAME 00013 * .. 00014 * .. Subroutine Arguments .. 00015 EXTERNAL SUBPTR 00016 * .. 00017 * 00018 * Purpose 00019 * ======= 00020 * 00021 * PCOPTEE tests whether the PBLAS respond correctly to a bad option 00022 * argument. 00023 * 00024 * Notes 00025 * ===== 00026 * 00027 * A description vector is associated with each 2D block-cyclicly dis- 00028 * tributed matrix. This vector stores the information required to 00029 * establish the mapping between a matrix entry and its corresponding 00030 * process and memory location. 00031 * 00032 * In the following comments, the character _ should be read as 00033 * "of the distributed matrix". Let A be a generic term for any 2D 00034 * block cyclicly distributed matrix. Its description vector is DESCA: 00035 * 00036 * NOTATION STORED IN EXPLANATION 00037 * ---------------- --------------- ------------------------------------ 00038 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00039 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00040 * the NPROW x NPCOL BLACS process grid 00041 * A is distributed over. The context 00042 * itself is global, but the handle 00043 * (the integer value) may vary. 00044 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00045 * ted matrix A, M_A >= 0. 00046 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00047 * buted matrix A, N_A >= 0. 00048 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00049 * block of the matrix A, IMB_A > 0. 00050 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00051 * left block of the matrix A, 00052 * INB_A > 0. 00053 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00054 * bute the last M_A-IMB_A rows of A, 00055 * MB_A > 0. 00056 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00057 * bute the last N_A-INB_A columns of 00058 * A, NB_A > 0. 00059 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00060 * row of the matrix A is distributed, 00061 * NPROW > RSRC_A >= 0. 00062 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00063 * first column of A is distributed. 00064 * NPCOL > CSRC_A >= 0. 00065 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00066 * array storing the local blocks of 00067 * the distributed matrix A, 00068 * IF( Lc( 1, N_A ) > 0 ) 00069 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00070 * ELSE 00071 * LLD_A >= 1. 00072 * 00073 * Let K be the number of rows of a matrix A starting at the global in- 00074 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00075 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00076 * receive if these K rows were distributed over NPROW processes. If K 00077 * is the number of columns of a matrix A starting at the global index 00078 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00079 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00080 * these K columns were distributed over NPCOL processes. 00081 * 00082 * The values of Lr() and Lc() may be determined via a call to the func- 00083 * tion PB_NUMROC: 00084 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00085 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00086 * 00087 * Arguments 00088 * ========= 00089 * 00090 * ICTXT (local input) INTEGER 00091 * On entry, ICTXT specifies the BLACS context handle, indica- 00092 * ting the global context of the operation. The context itself 00093 * is global, but the value of ICTXT is local. 00094 * 00095 * NOUT (global input) INTEGER 00096 * On entry, NOUT specifies the unit number for the output file. 00097 * When NOUT is 6, output to screen, when NOUT is 0, output to 00098 * stderr. NOUT is only defined for process 0. 00099 * 00100 * SUBPTR (global input) SUBROUTINE 00101 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 00102 * EXTERNAL in the calling subroutine. 00103 * 00104 * SCODE (global input) INTEGER 00105 * On entry, SCODE specifies the calling sequence code. 00106 * 00107 * SNAME (global input) CHARACTER*(*) 00108 * On entry, SNAME specifies the subroutine name calling this 00109 * subprogram. 00110 * 00111 * Calling sequence encodings 00112 * ========================== 00113 * 00114 * code Formal argument list Examples 00115 * 00116 * 11 (n, v1,v2) _SWAP, _COPY 00117 * 12 (n,s1, v1 ) _SCAL, _SCAL 00118 * 13 (n,s1, v1,v2) _AXPY, _DOT_ 00119 * 14 (n,s1,i1,v1 ) _AMAX 00120 * 15 (n,u1, v1 ) _ASUM, _NRM2 00121 * 00122 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV 00123 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV 00124 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV 00125 * 24 ( m,n,s1,v1,v2,m1) _GER_ 00126 * 25 (uplo, n,s1,v1, m1) _SYR 00127 * 26 (uplo, n,u1,v1, m1) _HER 00128 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2 00129 * 00130 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM 00131 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM 00132 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK 00133 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK 00134 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K 00135 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K 00136 * 37 ( m,n, s1,m1, s2,m3) _TRAN_ 00137 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM 00138 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD 00139 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD 00140 * 00141 * -- Written on April 1, 1998 by 00142 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00143 * 00144 * ===================================================================== 00145 * 00146 * .. Local Scalars .. 00147 INTEGER APOS 00148 * .. 00149 * .. External Subroutines .. 00150 EXTERNAL PCCHKOPT 00151 * .. 00152 * .. Executable Statements .. 00153 * 00154 * Level 2 PBLAS 00155 * 00156 IF( SCODE.EQ.21 ) THEN 00157 * 00158 * Check 1st (and only) option 00159 * 00160 APOS = 1 00161 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00162 * 00163 ELSE IF( SCODE.EQ.22 .OR. SCODE.EQ.25 .OR. SCODE.EQ.26 .OR. 00164 $ SCODE.EQ.27 ) THEN 00165 * 00166 * Check 1st (and only) option 00167 * 00168 APOS = 1 00169 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00170 * 00171 ELSE IF( SCODE.EQ.23 ) THEN 00172 * 00173 * Check 1st option 00174 * 00175 APOS = 1 00176 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00177 * 00178 * Check 2nd option 00179 * 00180 APOS = 2 00181 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00182 * 00183 * Check 3rd option 00184 * 00185 APOS = 3 00186 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'D', APOS ) 00187 * 00188 * Level 3 PBLAS 00189 * 00190 ELSE IF( SCODE.EQ.31 ) THEN 00191 * 00192 * Check 1st option 00193 * 00194 APOS = 1 00195 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00196 * 00197 * Check 2'nd option 00198 * 00199 APOS = 2 00200 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS ) 00201 * 00202 ELSE IF( SCODE.EQ.32 ) THEN 00203 * 00204 * Check 1st option 00205 * 00206 APOS = 1 00207 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS ) 00208 * 00209 * Check 2nd option 00210 * 00211 APOS = 2 00212 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00213 * 00214 ELSE IF( SCODE.EQ.33 .OR. SCODE.EQ.34 .OR. SCODE.EQ.35 .OR. 00215 $ SCODE.EQ.36 .OR. SCODE.EQ.40 ) THEN 00216 * 00217 * Check 1st option 00218 * 00219 APOS = 1 00220 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00221 * 00222 * Check 2'nd option 00223 * 00224 APOS = 2 00225 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00226 * 00227 ELSE IF( SCODE.EQ.38 ) THEN 00228 * 00229 * Check 1st option 00230 * 00231 APOS = 1 00232 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS ) 00233 * 00234 * Check 2nd option 00235 * 00236 APOS = 2 00237 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00238 * 00239 * Check 3rd option 00240 * 00241 APOS = 3 00242 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00243 * 00244 * Check 4th option 00245 * 00246 APOS = 4 00247 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'D', APOS ) 00248 * 00249 * 00250 ELSE IF( SCODE.EQ.39 ) THEN 00251 * 00252 * Check 1st option 00253 * 00254 APOS = 1 00255 CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00256 * 00257 END IF 00258 * 00259 RETURN 00260 * 00261 * End of PCOPTEE 00262 * 00263 END 00264 SUBROUTINE PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM, 00265 $ ARGPOS ) 00266 * 00267 * -- PBLAS test routine (version 2.0) -- 00268 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00269 * and University of California, Berkeley. 00270 * April 1, 1998 00271 * 00272 * .. Scalar Arguments .. 00273 CHARACTER*1 ARGNAM 00274 INTEGER ARGPOS, ICTXT, NOUT, SCODE 00275 * .. 00276 * .. Array Arguments .. 00277 CHARACTER*(*) SNAME 00278 * .. 00279 * .. Subroutine Arguments .. 00280 EXTERNAL SUBPTR 00281 * .. 00282 * 00283 * Purpose 00284 * ======= 00285 * 00286 * PCCHKOPT tests the option ARGNAM in any PBLAS routine. 00287 * 00288 * Notes 00289 * ===== 00290 * 00291 * A description vector is associated with each 2D block-cyclicly dis- 00292 * tributed matrix. This vector stores the information required to 00293 * establish the mapping between a matrix entry and its corresponding 00294 * process and memory location. 00295 * 00296 * In the following comments, the character _ should be read as 00297 * "of the distributed matrix". Let A be a generic term for any 2D 00298 * block cyclicly distributed matrix. Its description vector is DESCA: 00299 * 00300 * NOTATION STORED IN EXPLANATION 00301 * ---------------- --------------- ------------------------------------ 00302 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00303 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00304 * the NPROW x NPCOL BLACS process grid 00305 * A is distributed over. The context 00306 * itself is global, but the handle 00307 * (the integer value) may vary. 00308 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00309 * ted matrix A, M_A >= 0. 00310 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00311 * buted matrix A, N_A >= 0. 00312 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00313 * block of the matrix A, IMB_A > 0. 00314 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00315 * left block of the matrix A, 00316 * INB_A > 0. 00317 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00318 * bute the last M_A-IMB_A rows of A, 00319 * MB_A > 0. 00320 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00321 * bute the last N_A-INB_A columns of 00322 * A, NB_A > 0. 00323 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00324 * row of the matrix A is distributed, 00325 * NPROW > RSRC_A >= 0. 00326 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00327 * first column of A is distributed. 00328 * NPCOL > CSRC_A >= 0. 00329 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00330 * array storing the local blocks of 00331 * the distributed matrix A, 00332 * IF( Lc( 1, N_A ) > 0 ) 00333 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00334 * ELSE 00335 * LLD_A >= 1. 00336 * 00337 * Let K be the number of rows of a matrix A starting at the global in- 00338 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00339 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00340 * receive if these K rows were distributed over NPROW processes. If K 00341 * is the number of columns of a matrix A starting at the global index 00342 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00343 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00344 * these K columns were distributed over NPCOL processes. 00345 * 00346 * The values of Lr() and Lc() may be determined via a call to the func- 00347 * tion PB_NUMROC: 00348 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00349 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00350 * 00351 * Arguments 00352 * ========= 00353 * 00354 * ICTXT (local input) INTEGER 00355 * On entry, ICTXT specifies the BLACS context handle, indica- 00356 * ting the global context of the operation. The context itself 00357 * is global, but the value of ICTXT is local. 00358 * 00359 * NOUT (global input) INTEGER 00360 * On entry, NOUT specifies the unit number for the output file. 00361 * When NOUT is 6, output to screen, when NOUT is 0, output to 00362 * stderr. NOUT is only defined for process 0. 00363 * 00364 * SUBPTR (global input) SUBROUTINE 00365 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 00366 * EXTERNAL in the calling subroutine. 00367 * 00368 * SCODE (global input) INTEGER 00369 * On entry, SCODE specifies the calling sequence code. 00370 * 00371 * SNAME (global input) CHARACTER*(*) 00372 * On entry, SNAME specifies the subroutine name calling this 00373 * subprogram. 00374 * 00375 * ARGNAM (global input) CHARACTER*(*) 00376 * On entry, ARGNAM specifies the name of the option to be 00377 * checked. ARGNAM can either be 'D', 'S', 'A', 'B', or 'U'. 00378 * 00379 * ARGPOS (global input) INTEGER 00380 * On entry, ARGPOS indicates the position of the option ARGNAM 00381 * to be tested. 00382 * 00383 * -- Written on April 1, 1998 by 00384 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00385 * 00386 * ===================================================================== 00387 * 00388 * .. Local Scalars .. 00389 INTEGER INFOT 00390 * .. 00391 * .. External Subroutines .. 00392 EXTERNAL PCCALLSUB, PCHKPBE, PCSETPBLAS 00393 * .. 00394 * .. External Functions .. 00395 LOGICAL LSAME 00396 EXTERNAL LSAME 00397 * .. 00398 * .. Common Blocks .. 00399 CHARACTER DIAG, SIDE, TRANSA, TRANSB, UPLO 00400 COMMON /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO 00401 * .. 00402 * .. Executable Statements .. 00403 * 00404 * Reiniatilize the dummy arguments to correct values 00405 * 00406 CALL PCSETPBLAS( ICTXT ) 00407 * 00408 IF( LSAME( ARGNAM, 'D' ) ) THEN 00409 * 00410 * Generate bad DIAG option 00411 * 00412 DIAG = '/' 00413 * 00414 ELSE IF( LSAME( ARGNAM, 'S' ) ) THEN 00415 * 00416 * Generate bad SIDE option 00417 * 00418 SIDE = '/' 00419 * 00420 ELSE IF( LSAME( ARGNAM, 'A' ) ) THEN 00421 * 00422 * Generate bad TRANSA option 00423 * 00424 TRANSA = '/' 00425 * 00426 ELSE IF( LSAME( ARGNAM, 'B' ) ) THEN 00427 * 00428 * Generate bad TRANSB option 00429 * 00430 TRANSB = '/' 00431 * 00432 ELSE IF( LSAME( ARGNAM, 'U' ) ) THEN 00433 * 00434 * Generate bad UPLO option 00435 * 00436 UPLO = '/' 00437 * 00438 END IF 00439 * 00440 * Set INFOT to the position of the bad dimension argument 00441 * 00442 INFOT = ARGPOS 00443 * 00444 * Call the PBLAS routine 00445 * 00446 CALL PCCALLSUB( SUBPTR, SCODE ) 00447 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 00448 * 00449 RETURN 00450 * 00451 * End of PCCHKOPT 00452 * 00453 END 00454 SUBROUTINE PCDIMEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME ) 00455 * 00456 * -- PBLAS test routine (version 2.0) -- 00457 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00458 * and University of California, Berkeley. 00459 * April 1, 1998 00460 * 00461 * .. Scalar Arguments .. 00462 INTEGER ICTXT, NOUT, SCODE 00463 * .. 00464 * .. Array Arguments .. 00465 CHARACTER*(*) SNAME 00466 * .. 00467 * .. Subroutine Arguments .. 00468 EXTERNAL SUBPTR 00469 * .. 00470 * 00471 * Purpose 00472 * ======= 00473 * 00474 * PCDIMEE tests whether the PBLAS respond correctly to a bad dimension 00475 * argument. 00476 * 00477 * Notes 00478 * ===== 00479 * 00480 * A description vector is associated with each 2D block-cyclicly dis- 00481 * tributed matrix. This vector stores the information required to 00482 * establish the mapping between a matrix entry and its corresponding 00483 * process and memory location. 00484 * 00485 * In the following comments, the character _ should be read as 00486 * "of the distributed matrix". Let A be a generic term for any 2D 00487 * block cyclicly distributed matrix. Its description vector is DESCA: 00488 * 00489 * NOTATION STORED IN EXPLANATION 00490 * ---------------- --------------- ------------------------------------ 00491 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00492 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00493 * the NPROW x NPCOL BLACS process grid 00494 * A is distributed over. The context 00495 * itself is global, but the handle 00496 * (the integer value) may vary. 00497 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00498 * ted matrix A, M_A >= 0. 00499 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00500 * buted matrix A, N_A >= 0. 00501 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00502 * block of the matrix A, IMB_A > 0. 00503 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00504 * left block of the matrix A, 00505 * INB_A > 0. 00506 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00507 * bute the last M_A-IMB_A rows of A, 00508 * MB_A > 0. 00509 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00510 * bute the last N_A-INB_A columns of 00511 * A, NB_A > 0. 00512 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00513 * row of the matrix A is distributed, 00514 * NPROW > RSRC_A >= 0. 00515 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00516 * first column of A is distributed. 00517 * NPCOL > CSRC_A >= 0. 00518 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00519 * array storing the local blocks of 00520 * the distributed matrix A, 00521 * IF( Lc( 1, N_A ) > 0 ) 00522 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00523 * ELSE 00524 * LLD_A >= 1. 00525 * 00526 * Let K be the number of rows of a matrix A starting at the global in- 00527 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00528 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00529 * receive if these K rows were distributed over NPROW processes. If K 00530 * is the number of columns of a matrix A starting at the global index 00531 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00532 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00533 * these K columns were distributed over NPCOL processes. 00534 * 00535 * The values of Lr() and Lc() may be determined via a call to the func- 00536 * tion PB_NUMROC: 00537 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00538 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00539 * 00540 * Arguments 00541 * ========= 00542 * 00543 * ICTXT (local input) INTEGER 00544 * On entry, ICTXT specifies the BLACS context handle, indica- 00545 * ting the global context of the operation. The context itself 00546 * is global, but the value of ICTXT is local. 00547 * 00548 * NOUT (global input) INTEGER 00549 * On entry, NOUT specifies the unit number for the output file. 00550 * When NOUT is 6, output to screen, when NOUT is 0, output to 00551 * stderr. NOUT is only defined for process 0. 00552 * 00553 * SUBPTR (global input) SUBROUTINE 00554 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 00555 * EXTERNAL in the calling subroutine. 00556 * 00557 * SCODE (global input) INTEGER 00558 * On entry, SCODE specifies the calling sequence code. 00559 * 00560 * SNAME (global input) CHARACTER*(*) 00561 * On entry, SNAME specifies the subroutine name calling this 00562 * subprogram. 00563 * 00564 * Calling sequence encodings 00565 * ========================== 00566 * 00567 * code Formal argument list Examples 00568 * 00569 * 11 (n, v1,v2) _SWAP, _COPY 00570 * 12 (n,s1, v1 ) _SCAL, _SCAL 00571 * 13 (n,s1, v1,v2) _AXPY, _DOT_ 00572 * 14 (n,s1,i1,v1 ) _AMAX 00573 * 15 (n,u1, v1 ) _ASUM, _NRM2 00574 * 00575 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV 00576 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV 00577 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV 00578 * 24 ( m,n,s1,v1,v2,m1) _GER_ 00579 * 25 (uplo, n,s1,v1, m1) _SYR 00580 * 26 (uplo, n,u1,v1, m1) _HER 00581 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2 00582 * 00583 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM 00584 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM 00585 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK 00586 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK 00587 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K 00588 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K 00589 * 37 ( m,n, s1,m1, s2,m3) _TRAN_ 00590 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM 00591 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD 00592 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD 00593 * 00594 * -- Written on April 1, 1998 by 00595 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00596 * 00597 * ===================================================================== 00598 * 00599 * .. Local Scalars .. 00600 INTEGER APOS 00601 * .. 00602 * .. External Subroutines .. 00603 EXTERNAL PCCHKDIM 00604 * .. 00605 * .. Executable Statements .. 00606 * 00607 * Level 1 PBLAS 00608 * 00609 IF( SCODE.EQ.11 .OR. SCODE.EQ.12 .OR. SCODE.EQ.13 .OR. 00610 $ SCODE.EQ.14 .OR. SCODE.EQ.15 ) THEN 00611 * 00612 * Check 1st (and only) dimension 00613 * 00614 APOS = 1 00615 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00616 * 00617 * Level 2 PBLAS 00618 * 00619 ELSE IF( SCODE.EQ.21 ) THEN 00620 * 00621 * Check 1st dimension 00622 * 00623 APOS = 2 00624 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00625 * 00626 * Check 2nd dimension 00627 * 00628 APOS = 3 00629 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00630 * 00631 ELSE IF( SCODE.EQ.22 .OR. SCODE.EQ.25 .OR. SCODE.EQ.26 .OR. 00632 $ SCODE.EQ.27 ) THEN 00633 * 00634 * Check 1st (and only) dimension 00635 * 00636 APOS = 2 00637 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00638 * 00639 ELSE IF( SCODE.EQ.23 ) THEN 00640 * 00641 * Check 1st (and only) dimension 00642 * 00643 APOS = 4 00644 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00645 * 00646 ELSE IF( SCODE.EQ.24 ) THEN 00647 * 00648 * Check 1st dimension 00649 * 00650 APOS = 1 00651 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00652 * 00653 * Check 2nd dimension 00654 * 00655 APOS = 2 00656 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00657 * 00658 * Level 3 PBLAS 00659 * 00660 ELSE IF( SCODE.EQ.31 ) THEN 00661 * 00662 * Check 1st dimension 00663 * 00664 APOS = 3 00665 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00666 * 00667 * Check 2nd dimension 00668 * 00669 APOS = 4 00670 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00671 * 00672 * Check 3rd dimension 00673 * 00674 APOS = 5 00675 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'K', APOS ) 00676 * 00677 ELSE IF( SCODE.EQ.32 ) THEN 00678 * 00679 * Check 1st dimension 00680 * 00681 APOS = 3 00682 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00683 * 00684 * Check 2nd dimension 00685 * 00686 APOS = 4 00687 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00688 * 00689 ELSE IF( SCODE.EQ.33 .OR. SCODE.EQ.34 .OR. SCODE.EQ.35 .OR. 00690 $ SCODE.EQ.36 ) THEN 00691 * 00692 * Check 1st dimension 00693 * 00694 APOS = 3 00695 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00696 * 00697 * Check 2nd dimension 00698 * 00699 APOS = 4 00700 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'K', APOS ) 00701 * 00702 ELSE IF( SCODE.EQ.37 ) THEN 00703 * 00704 * Check 1st dimension 00705 * 00706 APOS = 1 00707 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00708 * 00709 * Check 2nd dimension 00710 * 00711 APOS = 2 00712 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00713 * 00714 ELSE IF( SCODE.EQ.38 ) THEN 00715 * 00716 * Check 1st dimension 00717 * 00718 APOS = 5 00719 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00720 * 00721 * Check 2nd dimension 00722 * 00723 APOS = 6 00724 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00725 * 00726 ELSE IF( SCODE.EQ.39 ) THEN 00727 * 00728 * Check 1st dimension 00729 * 00730 APOS = 2 00731 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00732 * 00733 * Check 2nd dimension 00734 * 00735 APOS = 3 00736 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00737 * 00738 ELSE IF( SCODE.EQ.40 ) THEN 00739 * 00740 * Check 1st dimension 00741 * 00742 APOS = 3 00743 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00744 * 00745 * Check 2nd dimension 00746 * 00747 APOS = 4 00748 CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00749 * 00750 END IF 00751 * 00752 RETURN 00753 * 00754 * End of PCDIMEE 00755 * 00756 END 00757 SUBROUTINE PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM, 00758 $ ARGPOS ) 00759 * 00760 * -- PBLAS test routine (version 2.0) -- 00761 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00762 * and University of California, Berkeley. 00763 * April 1, 1998 00764 * 00765 * .. Scalar Arguments .. 00766 CHARACTER*1 ARGNAM 00767 INTEGER ARGPOS, ICTXT, NOUT, SCODE 00768 * .. 00769 * .. Array Arguments .. 00770 CHARACTER*(*) SNAME 00771 * .. 00772 * .. Subroutine Arguments .. 00773 EXTERNAL SUBPTR 00774 * .. 00775 * 00776 * Purpose 00777 * ======= 00778 * 00779 * PCCHKDIM tests the dimension ARGNAM in any PBLAS routine. 00780 * 00781 * Notes 00782 * ===== 00783 * 00784 * A description vector is associated with each 2D block-cyclicly dis- 00785 * tributed matrix. This vector stores the information required to 00786 * establish the mapping between a matrix entry and its corresponding 00787 * process and memory location. 00788 * 00789 * In the following comments, the character _ should be read as 00790 * "of the distributed matrix". Let A be a generic term for any 2D 00791 * block cyclicly distributed matrix. Its description vector is DESCA: 00792 * 00793 * NOTATION STORED IN EXPLANATION 00794 * ---------------- --------------- ------------------------------------ 00795 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00796 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00797 * the NPROW x NPCOL BLACS process grid 00798 * A is distributed over. The context 00799 * itself is global, but the handle 00800 * (the integer value) may vary. 00801 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00802 * ted matrix A, M_A >= 0. 00803 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00804 * buted matrix A, N_A >= 0. 00805 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00806 * block of the matrix A, IMB_A > 0. 00807 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00808 * left block of the matrix A, 00809 * INB_A > 0. 00810 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00811 * bute the last M_A-IMB_A rows of A, 00812 * MB_A > 0. 00813 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00814 * bute the last N_A-INB_A columns of 00815 * A, NB_A > 0. 00816 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00817 * row of the matrix A is distributed, 00818 * NPROW > RSRC_A >= 0. 00819 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00820 * first column of A is distributed. 00821 * NPCOL > CSRC_A >= 0. 00822 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00823 * array storing the local blocks of 00824 * the distributed matrix A, 00825 * IF( Lc( 1, N_A ) > 0 ) 00826 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00827 * ELSE 00828 * LLD_A >= 1. 00829 * 00830 * Let K be the number of rows of a matrix A starting at the global in- 00831 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00832 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00833 * receive if these K rows were distributed over NPROW processes. If K 00834 * is the number of columns of a matrix A starting at the global index 00835 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00836 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00837 * these K columns were distributed over NPCOL processes. 00838 * 00839 * The values of Lr() and Lc() may be determined via a call to the func- 00840 * tion PB_NUMROC: 00841 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00842 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00843 * 00844 * Arguments 00845 * ========= 00846 * 00847 * ICTXT (local input) INTEGER 00848 * On entry, ICTXT specifies the BLACS context handle, indica- 00849 * ting the global context of the operation. The context itself 00850 * is global, but the value of ICTXT is local. 00851 * 00852 * NOUT (global input) INTEGER 00853 * On entry, NOUT specifies the unit number for the output file. 00854 * When NOUT is 6, output to screen, when NOUT is 0, output to 00855 * stderr. NOUT is only defined for process 0. 00856 * 00857 * SUBPTR (global input) SUBROUTINE 00858 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 00859 * EXTERNAL in the calling subroutine. 00860 * 00861 * SCODE (global input) INTEGER 00862 * On entry, SCODE specifies the calling sequence code. 00863 * 00864 * SNAME (global input) CHARACTER*(*) 00865 * On entry, SNAME specifies the subroutine name calling this 00866 * subprogram. 00867 * 00868 * ARGNAM (global input) CHARACTER*(*) 00869 * On entry, ARGNAM specifies the name of the dimension to be 00870 * checked. ARGNAM can either be 'M', 'N' or 'K'. 00871 * 00872 * ARGPOS (global input) INTEGER 00873 * On entry, ARGPOS indicates the position of the option ARGNAM 00874 * to be tested. 00875 * 00876 * -- Written on April 1, 1998 by 00877 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00878 * 00879 * ===================================================================== 00880 * 00881 * .. Local Scalars .. 00882 INTEGER INFOT 00883 * .. 00884 * .. External Subroutines .. 00885 EXTERNAL PCCALLSUB, PCHKPBE, PCSETPBLAS 00886 * .. 00887 * .. External Functions .. 00888 LOGICAL LSAME 00889 EXTERNAL LSAME 00890 * .. 00891 * .. Common Blocks .. 00892 INTEGER KDIM, MDIM, NDIM 00893 COMMON /PBLASN/KDIM, MDIM, NDIM 00894 * .. 00895 * .. Executable Statements .. 00896 * 00897 * Reiniatilize the dummy arguments to correct values 00898 * 00899 CALL PCSETPBLAS( ICTXT ) 00900 * 00901 IF( LSAME( ARGNAM, 'M' ) ) THEN 00902 * 00903 * Generate bad MDIM 00904 * 00905 MDIM = -1 00906 * 00907 ELSE IF( LSAME( ARGNAM, 'N' ) ) THEN 00908 * 00909 * Generate bad NDIM 00910 * 00911 NDIM = -1 00912 * 00913 ELSE 00914 * 00915 * Generate bad KDIM 00916 * 00917 KDIM = -1 00918 * 00919 END IF 00920 * 00921 * Set INFOT to the position of the bad dimension argument 00922 * 00923 INFOT = ARGPOS 00924 * 00925 * Call the PBLAS routine 00926 * 00927 CALL PCCALLSUB( SUBPTR, SCODE ) 00928 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 00929 * 00930 RETURN 00931 * 00932 * End of PCCHKDIM 00933 * 00934 END 00935 SUBROUTINE PCVECEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME ) 00936 * 00937 * -- PBLAS test routine (version 2.0) -- 00938 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00939 * and University of California, Berkeley. 00940 * April 1, 1998 00941 * 00942 * .. Scalar Arguments .. 00943 INTEGER ICTXT, NOUT, SCODE 00944 * .. 00945 * .. Array Arguments .. 00946 CHARACTER*7 SNAME 00947 * .. 00948 * .. Subroutine Arguments .. 00949 EXTERNAL SUBPTR 00950 * .. 00951 * 00952 * Purpose 00953 * ======= 00954 * 00955 * PCVECEE tests whether the PBLAS respond correctly to a bad vector 00956 * argument. Each vector <vec> is described by: <vec>, I<vec>, J<vec>, 00957 * DESC<vec>, INC<vec>. Out of all these, only I<vec>, J<vec>, 00958 * DESC<vec>, and INC<vec> can be tested. 00959 * 00960 * Notes 00961 * ===== 00962 * 00963 * A description vector is associated with each 2D block-cyclicly dis- 00964 * tributed matrix. This vector stores the information required to 00965 * establish the mapping between a matrix entry and its corresponding 00966 * process and memory location. 00967 * 00968 * In the following comments, the character _ should be read as 00969 * "of the distributed matrix". Let A be a generic term for any 2D 00970 * block cyclicly distributed matrix. Its description vector is DESCA: 00971 * 00972 * NOTATION STORED IN EXPLANATION 00973 * ---------------- --------------- ------------------------------------ 00974 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00975 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00976 * the NPROW x NPCOL BLACS process grid 00977 * A is distributed over. The context 00978 * itself is global, but the handle 00979 * (the integer value) may vary. 00980 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00981 * ted matrix A, M_A >= 0. 00982 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00983 * buted matrix A, N_A >= 0. 00984 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00985 * block of the matrix A, IMB_A > 0. 00986 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00987 * left block of the matrix A, 00988 * INB_A > 0. 00989 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00990 * bute the last M_A-IMB_A rows of A, 00991 * MB_A > 0. 00992 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00993 * bute the last N_A-INB_A columns of 00994 * A, NB_A > 0. 00995 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00996 * row of the matrix A is distributed, 00997 * NPROW > RSRC_A >= 0. 00998 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00999 * first column of A is distributed. 01000 * NPCOL > CSRC_A >= 0. 01001 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01002 * array storing the local blocks of 01003 * the distributed matrix A, 01004 * IF( Lc( 1, N_A ) > 0 ) 01005 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01006 * ELSE 01007 * LLD_A >= 1. 01008 * 01009 * Let K be the number of rows of a matrix A starting at the global in- 01010 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01011 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01012 * receive if these K rows were distributed over NPROW processes. If K 01013 * is the number of columns of a matrix A starting at the global index 01014 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01015 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01016 * these K columns were distributed over NPCOL processes. 01017 * 01018 * The values of Lr() and Lc() may be determined via a call to the func- 01019 * tion PB_NUMROC: 01020 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01021 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01022 * 01023 * Arguments 01024 * ========= 01025 * 01026 * ICTXT (local input) INTEGER 01027 * On entry, ICTXT specifies the BLACS context handle, indica- 01028 * ting the global context of the operation. The context itself 01029 * is global, but the value of ICTXT is local. 01030 * 01031 * NOUT (global input) INTEGER 01032 * On entry, NOUT specifies the unit number for the output file. 01033 * When NOUT is 6, output to screen, when NOUT is 0, output to 01034 * stderr. NOUT is only defined for process 0. 01035 * 01036 * SUBPTR (global input) SUBROUTINE 01037 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 01038 * EXTERNAL in the calling subroutine. 01039 * 01040 * SCODE (global input) INTEGER 01041 * On entry, SCODE specifies the calling sequence code. 01042 * 01043 * SNAME (global input) CHARACTER*(*) 01044 * On entry, SNAME specifies the subroutine name calling this 01045 * subprogram. 01046 * 01047 * Calling sequence encodings 01048 * ========================== 01049 * 01050 * code Formal argument list Examples 01051 * 01052 * 11 (n, v1,v2) _SWAP, _COPY 01053 * 12 (n,s1, v1 ) _SCAL, _SCAL 01054 * 13 (n,s1, v1,v2) _AXPY, _DOT_ 01055 * 14 (n,s1,i1,v1 ) _AMAX 01056 * 15 (n,u1, v1 ) _ASUM, _NRM2 01057 * 01058 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV 01059 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV 01060 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV 01061 * 24 ( m,n,s1,v1,v2,m1) _GER_ 01062 * 25 (uplo, n,s1,v1, m1) _SYR 01063 * 26 (uplo, n,u1,v1, m1) _HER 01064 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2 01065 * 01066 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM 01067 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM 01068 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK 01069 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK 01070 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K 01071 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K 01072 * 37 ( m,n, s1,m1, s2,m3) _TRAN_ 01073 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM 01074 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD 01075 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD 01076 * 01077 * -- Written on April 1, 1998 by 01078 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01079 * 01080 * ===================================================================== 01081 * 01082 * .. Local Scalars .. 01083 INTEGER APOS 01084 * .. 01085 * .. External Subroutines .. 01086 EXTERNAL PCCHKMAT 01087 * .. 01088 * .. Executable Statements .. 01089 * 01090 * Level 1 PBLAS 01091 * 01092 IF( SCODE.EQ.11 ) THEN 01093 * 01094 * Check 1st vector 01095 * 01096 APOS = 2 01097 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01098 * 01099 * Check 2nd vector 01100 * 01101 APOS = 7 01102 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS ) 01103 * 01104 ELSE IF( SCODE.EQ.12 .OR. SCODE.EQ.15 ) THEN 01105 * 01106 * Check 1st (and only) vector 01107 * 01108 APOS = 3 01109 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01110 * 01111 ELSE IF( SCODE.EQ.13 ) THEN 01112 * 01113 * Check 1st vector 01114 * 01115 APOS = 3 01116 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01117 * 01118 * Check 2nd vector 01119 * 01120 APOS = 8 01121 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS ) 01122 * 01123 ELSE IF( SCODE.EQ.14 ) THEN 01124 * 01125 * Check 1st (and only) vector 01126 * 01127 APOS = 4 01128 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01129 * 01130 * Level 2 PBLAS 01131 * 01132 ELSE IF( SCODE.EQ.21 ) THEN 01133 * 01134 * Check 1st vector 01135 * 01136 APOS = 9 01137 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01138 * 01139 * Check 2nd vector 01140 * 01141 APOS = 15 01142 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS ) 01143 * 01144 ELSE IF( SCODE.EQ.22 ) THEN 01145 * 01146 * Check 1st vector 01147 * 01148 APOS = 8 01149 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01150 * 01151 * Check 2nd vector 01152 * 01153 APOS = 14 01154 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS ) 01155 * 01156 ELSE IF( SCODE.EQ.23 ) THEN 01157 * 01158 * Check 1st (and only) vector 01159 * 01160 APOS = 9 01161 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01162 * 01163 ELSE IF( SCODE.EQ.24 .OR. SCODE.EQ.27 ) THEN 01164 * 01165 * Check 1st vector 01166 * 01167 APOS = 4 01168 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01169 * 01170 * Check 2nd vector 01171 * 01172 APOS = 9 01173 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS ) 01174 * 01175 ELSE IF( SCODE.EQ.26 .OR. SCODE.EQ.27 ) THEN 01176 * 01177 * Check 1'st (and only) vector 01178 * 01179 APOS = 4 01180 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01181 * 01182 END IF 01183 * 01184 RETURN 01185 * 01186 * End of PCVECEE 01187 * 01188 END 01189 SUBROUTINE PCMATEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME ) 01190 * 01191 * -- PBLAS test routine (version 2.0) -- 01192 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01193 * and University of California, Berkeley. 01194 * April 1, 1998 01195 * 01196 * .. Scalar Arguments .. 01197 INTEGER ICTXT, NOUT, SCODE 01198 * .. 01199 * .. Array Arguments .. 01200 CHARACTER*7 SNAME 01201 * .. 01202 * .. Subroutine Arguments .. 01203 EXTERNAL SUBPTR 01204 * .. 01205 * 01206 * Purpose 01207 * ======= 01208 * 01209 * PCMATEE tests whether the PBLAS respond correctly to a bad matrix 01210 * argument. Each matrix <mat> is described by: <mat>, I<mat>, J<mat>, 01211 * and DESC<mat>. Out of all these, only I<vec>, J<vec> and DESC<mat> 01212 * can be tested. 01213 * 01214 * Notes 01215 * ===== 01216 * 01217 * A description vector is associated with each 2D block-cyclicly dis- 01218 * tributed matrix. This vector stores the information required to 01219 * establish the mapping between a matrix entry and its corresponding 01220 * process and memory location. 01221 * 01222 * In the following comments, the character _ should be read as 01223 * "of the distributed matrix". Let A be a generic term for any 2D 01224 * block cyclicly distributed matrix. Its description vector is DESCA: 01225 * 01226 * NOTATION STORED IN EXPLANATION 01227 * ---------------- --------------- ------------------------------------ 01228 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 01229 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 01230 * the NPROW x NPCOL BLACS process grid 01231 * A is distributed over. The context 01232 * itself is global, but the handle 01233 * (the integer value) may vary. 01234 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 01235 * ted matrix A, M_A >= 0. 01236 * N_A (global) DESCA( N_ ) The number of columns in the distri- 01237 * buted matrix A, N_A >= 0. 01238 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 01239 * block of the matrix A, IMB_A > 0. 01240 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 01241 * left block of the matrix A, 01242 * INB_A > 0. 01243 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 01244 * bute the last M_A-IMB_A rows of A, 01245 * MB_A > 0. 01246 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 01247 * bute the last N_A-INB_A columns of 01248 * A, NB_A > 0. 01249 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 01250 * row of the matrix A is distributed, 01251 * NPROW > RSRC_A >= 0. 01252 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 01253 * first column of A is distributed. 01254 * NPCOL > CSRC_A >= 0. 01255 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01256 * array storing the local blocks of 01257 * the distributed matrix A, 01258 * IF( Lc( 1, N_A ) > 0 ) 01259 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01260 * ELSE 01261 * LLD_A >= 1. 01262 * 01263 * Let K be the number of rows of a matrix A starting at the global in- 01264 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01265 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01266 * receive if these K rows were distributed over NPROW processes. If K 01267 * is the number of columns of a matrix A starting at the global index 01268 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01269 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01270 * these K columns were distributed over NPCOL processes. 01271 * 01272 * The values of Lr() and Lc() may be determined via a call to the func- 01273 * tion PB_NUMROC: 01274 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01275 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01276 * 01277 * Arguments 01278 * ========= 01279 * 01280 * ICTXT (local input) INTEGER 01281 * On entry, ICTXT specifies the BLACS context handle, indica- 01282 * ting the global context of the operation. The context itself 01283 * is global, but the value of ICTXT is local. 01284 * 01285 * NOUT (global input) INTEGER 01286 * On entry, NOUT specifies the unit number for the output file. 01287 * When NOUT is 6, output to screen, when NOUT is 0, output to 01288 * stderr. NOUT is only defined for process 0. 01289 * 01290 * SUBPTR (global input) SUBROUTINE 01291 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 01292 * EXTERNAL in the calling subroutine. 01293 * 01294 * SCODE (global input) INTEGER 01295 * On entry, SCODE specifies the calling sequence code. 01296 * 01297 * SNAME (global input) CHARACTER*(*) 01298 * On entry, SNAME specifies the subroutine name calling this 01299 * subprogram. 01300 * 01301 * Calling sequence encodings 01302 * ========================== 01303 * 01304 * code Formal argument list Examples 01305 * 01306 * 11 (n, v1,v2) _SWAP, _COPY 01307 * 12 (n,s1, v1 ) _SCAL, _SCAL 01308 * 13 (n,s1, v1,v2) _AXPY, _DOT_ 01309 * 14 (n,s1,i1,v1 ) _AMAX 01310 * 15 (n,u1, v1 ) _ASUM, _NRM2 01311 * 01312 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV 01313 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV 01314 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV 01315 * 24 ( m,n,s1,v1,v2,m1) _GER_ 01316 * 25 (uplo, n,s1,v1, m1) _SYR 01317 * 26 (uplo, n,u1,v1, m1) _HER 01318 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2 01319 * 01320 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM 01321 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM 01322 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK 01323 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK 01324 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K 01325 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K 01326 * 37 ( m,n, s1,m1, s2,m3) _TRAN_ 01327 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM 01328 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD 01329 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD 01330 * 01331 * -- Written on April 1, 1998 by 01332 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01333 * 01334 * ===================================================================== 01335 * 01336 * .. Local Scalars .. 01337 INTEGER APOS 01338 * .. 01339 * .. External Subroutines .. 01340 EXTERNAL PCCHKMAT 01341 * .. 01342 * .. Executable Statements .. 01343 * 01344 * Level 2 PBLAS 01345 * 01346 IF( SCODE.EQ.21 .OR. SCODE.EQ.23 ) THEN 01347 * 01348 * Check 1st (and only) matrix 01349 * 01350 APOS = 5 01351 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01352 * 01353 ELSE IF( SCODE.EQ.22 ) THEN 01354 * 01355 * Check 1st (and only) matrix 01356 * 01357 APOS = 4 01358 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01359 * 01360 ELSE IF( SCODE.EQ.24 .OR. SCODE.EQ.27 ) THEN 01361 * 01362 * Check 1st (and only) matrix 01363 * 01364 APOS = 14 01365 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01366 * 01367 ELSE IF( SCODE.EQ.25 .OR. SCODE.EQ.26 ) THEN 01368 * 01369 * Check 1st (and only) matrix 01370 * 01371 APOS = 9 01372 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01373 * 01374 * Level 3 PBLAS 01375 * 01376 ELSE IF( SCODE.EQ.31 ) THEN 01377 * 01378 * Check 1st matrix 01379 * 01380 APOS = 7 01381 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01382 * 01383 * Check 2nd matrix 01384 * 01385 APOS = 11 01386 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS ) 01387 * 01388 * Check 3nd matrix 01389 * 01390 APOS = 16 01391 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS ) 01392 * 01393 ELSE IF( SCODE.EQ.32 .OR. SCODE.EQ.35 .OR. SCODE.EQ.36 ) THEN 01394 * 01395 * Check 1st matrix 01396 * 01397 APOS = 6 01398 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01399 * 01400 * Check 2nd matrix 01401 * 01402 APOS = 10 01403 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS ) 01404 * 01405 * Check 3nd matrix 01406 * 01407 APOS = 15 01408 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS ) 01409 * 01410 ELSE IF( SCODE.EQ.33 .OR. SCODE.EQ.34 ) THEN 01411 * 01412 * Check 1st matrix 01413 * 01414 APOS = 6 01415 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01416 * 01417 * Check 2nd matrix 01418 * 01419 APOS = 11 01420 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS ) 01421 * 01422 ELSE IF( SCODE.EQ.37 ) THEN 01423 * 01424 * Check 1st matrix 01425 * 01426 APOS = 4 01427 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01428 * 01429 * Check 2nd matrix 01430 * 01431 APOS = 9 01432 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS ) 01433 * 01434 ELSE IF( SCODE.EQ.38 ) THEN 01435 * 01436 * Check 1st matrix 01437 * 01438 APOS = 8 01439 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01440 * 01441 * Check 2nd matrix 01442 * 01443 APOS = 12 01444 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS ) 01445 * 01446 ELSE IF( SCODE.EQ.39 ) THEN 01447 * 01448 * Check 1st matrix 01449 * 01450 APOS = 5 01451 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01452 * 01453 * Check 2nd matrix 01454 * 01455 APOS = 10 01456 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS ) 01457 * 01458 ELSE IF( SCODE.EQ.40 ) THEN 01459 * 01460 * Check 1st matrix 01461 * 01462 APOS = 6 01463 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01464 * 01465 * Check 2nd matrix 01466 * 01467 APOS = 11 01468 CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS ) 01469 * 01470 END IF 01471 * 01472 RETURN 01473 * 01474 * End of PCMATEE 01475 * 01476 END 01477 SUBROUTINE PCSETPBLAS( ICTXT ) 01478 * 01479 * -- PBLAS test routine (version 2.0) -- 01480 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01481 * and University of California, Berkeley. 01482 * April 1, 1998 01483 * 01484 * .. Scalar Arguments .. 01485 INTEGER ICTXT 01486 * .. 01487 * 01488 * Purpose 01489 * ======= 01490 * 01491 * PCSETPBLAS initializes *all* the dummy arguments to correct values. 01492 * 01493 * Notes 01494 * ===== 01495 * 01496 * A description vector is associated with each 2D block-cyclicly dis- 01497 * tributed matrix. This vector stores the information required to 01498 * establish the mapping between a matrix entry and its corresponding 01499 * process and memory location. 01500 * 01501 * In the following comments, the character _ should be read as 01502 * "of the distributed matrix". Let A be a generic term for any 2D 01503 * block cyclicly distributed matrix. Its description vector is DESCA: 01504 * 01505 * NOTATION STORED IN EXPLANATION 01506 * ---------------- --------------- ------------------------------------ 01507 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 01508 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 01509 * the NPROW x NPCOL BLACS process grid 01510 * A is distributed over. The context 01511 * itself is global, but the handle 01512 * (the integer value) may vary. 01513 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 01514 * ted matrix A, M_A >= 0. 01515 * N_A (global) DESCA( N_ ) The number of columns in the distri- 01516 * buted matrix A, N_A >= 0. 01517 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 01518 * block of the matrix A, IMB_A > 0. 01519 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 01520 * left block of the matrix A, 01521 * INB_A > 0. 01522 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 01523 * bute the last M_A-IMB_A rows of A, 01524 * MB_A > 0. 01525 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 01526 * bute the last N_A-INB_A columns of 01527 * A, NB_A > 0. 01528 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 01529 * row of the matrix A is distributed, 01530 * NPROW > RSRC_A >= 0. 01531 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 01532 * first column of A is distributed. 01533 * NPCOL > CSRC_A >= 0. 01534 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01535 * array storing the local blocks of 01536 * the distributed matrix A, 01537 * IF( Lc( 1, N_A ) > 0 ) 01538 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01539 * ELSE 01540 * LLD_A >= 1. 01541 * 01542 * Let K be the number of rows of a matrix A starting at the global in- 01543 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01544 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01545 * receive if these K rows were distributed over NPROW processes. If K 01546 * is the number of columns of a matrix A starting at the global index 01547 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01548 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01549 * these K columns were distributed over NPCOL processes. 01550 * 01551 * The values of Lr() and Lc() may be determined via a call to the func- 01552 * tion PB_NUMROC: 01553 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01554 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01555 * 01556 * Arguments 01557 * ========= 01558 * 01559 * ICTXT (local input) INTEGER 01560 * On entry, ICTXT specifies the BLACS context handle, indica- 01561 * ting the global context of the operation. The context itself 01562 * is global, but the value of ICTXT is local. 01563 * 01564 * -- Written on April 1, 1998 by 01565 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01566 * 01567 * ===================================================================== 01568 * 01569 * .. Parameters .. 01570 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 01571 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 01572 $ RSRC_ 01573 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 01574 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 01575 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 01576 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 01577 REAL RONE 01578 COMPLEX ONE 01579 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), 01580 $ RONE = 1.0E+0 ) 01581 * .. 01582 * .. External Subroutines .. 01583 EXTERNAL PB_DESCSET2 01584 * .. 01585 * .. Common Blocks .. 01586 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO 01587 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB, 01588 $ JC, JX, JY, KDIM, MDIM, NDIM 01589 REAL USCLR 01590 COMPLEX SCLR 01591 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ), 01592 $ DESCX( DLEN_ ), DESCY( DLEN_ ) 01593 COMPLEX A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 ) 01594 COMMON /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO 01595 COMMON /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY 01596 COMMON /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY, 01597 $ JA, JB, JC, JX, JY 01598 COMMON /PBLASM/A, B, C 01599 COMMON /PBLASN/KDIM, MDIM, NDIM 01600 COMMON /PBLASS/SCLR, USCLR 01601 COMMON /PBLASV/X, Y 01602 * .. 01603 * .. Executable Statements .. 01604 * 01605 * Set default values for options 01606 * 01607 DIAG = 'N' 01608 SIDE = 'L' 01609 TRANSA = 'N' 01610 TRANSB = 'N' 01611 UPLO = 'U' 01612 * 01613 * Set default values for scalars 01614 * 01615 KDIM = 1 01616 MDIM = 1 01617 NDIM = 1 01618 ISCLR = 1 01619 SCLR = ONE 01620 USCLR = RONE 01621 * 01622 * Set default values for distributed matrix A 01623 * 01624 A( 1, 1 ) = ONE 01625 A( 2, 1 ) = ONE 01626 A( 1, 2 ) = ONE 01627 A( 2, 2 ) = ONE 01628 IA = 1 01629 JA = 1 01630 CALL PB_DESCSET2( DESCA, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 ) 01631 * 01632 * Set default values for distributed matrix B 01633 * 01634 B( 1, 1 ) = ONE 01635 B( 2, 1 ) = ONE 01636 B( 1, 2 ) = ONE 01637 B( 2, 2 ) = ONE 01638 IB = 1 01639 JB = 1 01640 CALL PB_DESCSET2( DESCB, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 ) 01641 * 01642 * Set default values for distributed matrix C 01643 * 01644 C( 1, 1 ) = ONE 01645 C( 2, 1 ) = ONE 01646 C( 1, 2 ) = ONE 01647 C( 2, 2 ) = ONE 01648 IC = 1 01649 JC = 1 01650 CALL PB_DESCSET2( DESCC, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 ) 01651 * 01652 * Set default values for distributed matrix X 01653 * 01654 X( 1 ) = ONE 01655 X( 2 ) = ONE 01656 IX = 1 01657 JX = 1 01658 CALL PB_DESCSET2( DESCX, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 ) 01659 INCX = 1 01660 * 01661 * Set default values for distributed matrix Y 01662 * 01663 Y( 1 ) = ONE 01664 Y( 2 ) = ONE 01665 IY = 1 01666 JY = 1 01667 CALL PB_DESCSET2( DESCY, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 ) 01668 INCY = 1 01669 * 01670 RETURN 01671 * 01672 * End of PCSETPBLAS 01673 * 01674 END 01675 SUBROUTINE PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM, 01676 $ ARGPOS ) 01677 * 01678 * -- PBLAS test routine (version 2.0) -- 01679 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01680 * and University of California, Berkeley. 01681 * April 1, 1998 01682 * 01683 * .. Scalar Arguments .. 01684 CHARACTER*1 ARGNAM 01685 INTEGER ARGPOS, ICTXT, NOUT, SCODE 01686 * .. 01687 * .. Array Arguments .. 01688 CHARACTER*(*) SNAME 01689 * .. 01690 * .. Subroutine Arguments .. 01691 EXTERNAL SUBPTR 01692 * .. 01693 * 01694 * Purpose 01695 * ======= 01696 * 01697 * PCCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine. 01698 * 01699 * Notes 01700 * ===== 01701 * 01702 * A description vector is associated with each 2D block-cyclicly dis- 01703 * tributed matrix. This vector stores the information required to 01704 * establish the mapping between a matrix entry and its corresponding 01705 * process and memory location. 01706 * 01707 * In the following comments, the character _ should be read as 01708 * "of the distributed matrix". Let A be a generic term for any 2D 01709 * block cyclicly distributed matrix. Its description vector is DESCA: 01710 * 01711 * NOTATION STORED IN EXPLANATION 01712 * ---------------- --------------- ------------------------------------ 01713 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 01714 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 01715 * the NPROW x NPCOL BLACS process grid 01716 * A is distributed over. The context 01717 * itself is global, but the handle 01718 * (the integer value) may vary. 01719 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 01720 * ted matrix A, M_A >= 0. 01721 * N_A (global) DESCA( N_ ) The number of columns in the distri- 01722 * buted matrix A, N_A >= 0. 01723 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 01724 * block of the matrix A, IMB_A > 0. 01725 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 01726 * left block of the matrix A, 01727 * INB_A > 0. 01728 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 01729 * bute the last M_A-IMB_A rows of A, 01730 * MB_A > 0. 01731 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 01732 * bute the last N_A-INB_A columns of 01733 * A, NB_A > 0. 01734 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 01735 * row of the matrix A is distributed, 01736 * NPROW > RSRC_A >= 0. 01737 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 01738 * first column of A is distributed. 01739 * NPCOL > CSRC_A >= 0. 01740 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01741 * array storing the local blocks of 01742 * the distributed matrix A, 01743 * IF( Lc( 1, N_A ) > 0 ) 01744 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01745 * ELSE 01746 * LLD_A >= 1. 01747 * 01748 * Let K be the number of rows of a matrix A starting at the global in- 01749 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01750 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01751 * receive if these K rows were distributed over NPROW processes. If K 01752 * is the number of columns of a matrix A starting at the global index 01753 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01754 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01755 * these K columns were distributed over NPCOL processes. 01756 * 01757 * The values of Lr() and Lc() may be determined via a call to the func- 01758 * tion PB_NUMROC: 01759 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01760 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01761 * 01762 * Arguments 01763 * ========= 01764 * 01765 * ICTXT (local input) INTEGER 01766 * On entry, ICTXT specifies the BLACS context handle, indica- 01767 * ting the global context of the operation. The context itself 01768 * is global, but the value of ICTXT is local. 01769 * 01770 * NOUT (global input) INTEGER 01771 * On entry, NOUT specifies the unit number for the output file. 01772 * When NOUT is 6, output to screen, when NOUT is 0, output to 01773 * stderr. NOUT is only defined for process 0. 01774 * 01775 * SUBPTR (global input) SUBROUTINE 01776 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 01777 * EXTERNAL in the calling subroutine. 01778 * 01779 * SCODE (global input) INTEGER 01780 * On entry, SCODE specifies the calling sequence code. 01781 * 01782 * SNAME (global input) CHARACTER*(*) 01783 * On entry, SNAME specifies the subroutine name calling this 01784 * subprogram. 01785 * 01786 * ARGNAM (global input) CHARACTER*(*) 01787 * On entry, ARGNAM specifies the name of the matrix or vector 01788 * to be checked. ARGNAM can either be 'A', 'B' or 'C' when one 01789 * wants to check a matrix, and 'X' or 'Y' for a vector. 01790 * 01791 * ARGPOS (global input) INTEGER 01792 * On entry, ARGPOS indicates the position of the first argument 01793 * of the matrix (or vector) ARGNAM. 01794 * 01795 * -- Written on April 1, 1998 by 01796 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01797 * 01798 * ===================================================================== 01799 * 01800 * .. Parameters .. 01801 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 01802 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 01803 $ RSRC_ 01804 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 01805 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 01806 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 01807 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 01808 INTEGER DESCMULT 01809 PARAMETER ( DESCMULT = 100 ) 01810 * .. 01811 * .. Local Scalars .. 01812 INTEGER I, INFOT, NPROW, NPCOL, MYROW, MYCOL 01813 * .. 01814 * .. External Subroutines .. 01815 EXTERNAL BLACS_GRIDINFO, PCCALLSUB, PCHKPBE, PCSETPBLAS 01816 * .. 01817 * .. External Functions .. 01818 LOGICAL LSAME 01819 EXTERNAL LSAME 01820 * .. 01821 * .. Common Blocks .. 01822 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB, 01823 $ JC, JX, JY 01824 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ), 01825 $ DESCX( DLEN_ ), DESCY( DLEN_ ) 01826 COMMON /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY 01827 COMMON /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY, 01828 $ JA, JB, JC, JX, JY 01829 * .. 01830 * .. Executable Statements .. 01831 * 01832 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 01833 * 01834 IF( LSAME( ARGNAM, 'A' ) ) THEN 01835 * 01836 * Check IA. Set all other OK, bad IA 01837 * 01838 CALL PCSETPBLAS( ICTXT ) 01839 IA = -1 01840 INFOT = ARGPOS + 1 01841 CALL PCCALLSUB( SUBPTR, SCODE ) 01842 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01843 * 01844 * Check JA. Set all other OK, bad JA 01845 * 01846 CALL PCSETPBLAS( ICTXT ) 01847 JA = -1 01848 INFOT = ARGPOS + 2 01849 CALL PCCALLSUB( SUBPTR, SCODE ) 01850 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01851 * 01852 * Check DESCA. Set all other OK, bad DESCA 01853 * 01854 DO 10 I = 1, DLEN_ 01855 * 01856 * Set I'th entry of DESCA to incorrect value, rest ok. 01857 * 01858 CALL PCSETPBLAS( ICTXT ) 01859 DESCA( I ) = -2 01860 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01861 CALL PCCALLSUB( SUBPTR, SCODE ) 01862 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01863 * 01864 * Extra tests for RSRCA, CSRCA, LDA 01865 * 01866 IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR. 01867 $ ( I.EQ.LLD_ ) ) THEN 01868 * 01869 CALL PCSETPBLAS( ICTXT ) 01870 * 01871 * Test RSRCA >= NPROW 01872 * 01873 IF( I.EQ.RSRC_ ) 01874 $ DESCA( I ) = NPROW 01875 * 01876 * Test CSRCA >= NPCOL 01877 * 01878 IF( I.EQ.CSRC_ ) 01879 $ DESCA( I ) = NPCOL 01880 * 01881 * Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2. 01882 * 01883 IF( I.EQ.LLD_ ) THEN 01884 IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN 01885 DESCA( I ) = 1 01886 ELSE 01887 DESCA( I ) = 0 01888 END IF 01889 END IF 01890 * 01891 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01892 CALL PCCALLSUB( SUBPTR, SCODE ) 01893 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01894 * 01895 END IF 01896 * 01897 10 CONTINUE 01898 * 01899 ELSE IF( LSAME( ARGNAM, 'B' ) ) THEN 01900 * 01901 * Check IB. Set all other OK, bad IB 01902 * 01903 CALL PCSETPBLAS( ICTXT ) 01904 IB = -1 01905 INFOT = ARGPOS + 1 01906 CALL PCCALLSUB( SUBPTR, SCODE ) 01907 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01908 * 01909 * Check JB. Set all other OK, bad JB 01910 * 01911 CALL PCSETPBLAS( ICTXT ) 01912 JB = -1 01913 INFOT = ARGPOS + 2 01914 CALL PCCALLSUB( SUBPTR, SCODE ) 01915 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01916 * 01917 * Check DESCB. Set all other OK, bad DESCB 01918 * 01919 DO 20 I = 1, DLEN_ 01920 * 01921 * Set I'th entry of DESCB to incorrect value, rest ok. 01922 * 01923 CALL PCSETPBLAS( ICTXT ) 01924 DESCB( I ) = -2 01925 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01926 CALL PCCALLSUB( SUBPTR, SCODE ) 01927 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01928 * 01929 * Extra tests for RSRCB, CSRCB, LDB 01930 * 01931 IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR. 01932 $ ( I.EQ.LLD_ ) ) THEN 01933 * 01934 CALL PCSETPBLAS( ICTXT ) 01935 * 01936 * Test RSRCB >= NPROW 01937 * 01938 IF( I.EQ.RSRC_ ) 01939 $ DESCB( I ) = NPROW 01940 * 01941 * Test CSRCB >= NPCOL 01942 * 01943 IF( I.EQ.CSRC_ ) 01944 $ DESCB( I ) = NPCOL 01945 * 01946 * Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2. 01947 * 01948 IF( I.EQ.LLD_ ) THEN 01949 IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN 01950 DESCB( I ) = 1 01951 ELSE 01952 DESCB( I ) = 0 01953 END IF 01954 END IF 01955 * 01956 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01957 CALL PCCALLSUB( SUBPTR, SCODE ) 01958 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01959 * 01960 END IF 01961 * 01962 20 CONTINUE 01963 * 01964 ELSE IF( LSAME( ARGNAM, 'C' ) ) THEN 01965 * 01966 * Check IC. Set all other OK, bad IC 01967 * 01968 CALL PCSETPBLAS( ICTXT ) 01969 IC = -1 01970 INFOT = ARGPOS + 1 01971 CALL PCCALLSUB( SUBPTR, SCODE ) 01972 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01973 * 01974 * Check JC. Set all other OK, bad JC 01975 * 01976 CALL PCSETPBLAS( ICTXT ) 01977 JC = -1 01978 INFOT = ARGPOS + 2 01979 CALL PCCALLSUB( SUBPTR, SCODE ) 01980 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01981 * 01982 * Check DESCC. Set all other OK, bad DESCC 01983 * 01984 DO 30 I = 1, DLEN_ 01985 * 01986 * Set I'th entry of DESCC to incorrect value, rest ok. 01987 * 01988 CALL PCSETPBLAS( ICTXT ) 01989 DESCC( I ) = -2 01990 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01991 CALL PCCALLSUB( SUBPTR, SCODE ) 01992 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01993 * 01994 * Extra tests for RSRCC, CSRCC, LDC 01995 * 01996 IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR. 01997 $ ( I.EQ.LLD_ ) ) THEN 01998 * 01999 CALL PCSETPBLAS( ICTXT ) 02000 * 02001 * Test RSRCC >= NPROW 02002 * 02003 IF( I.EQ.RSRC_ ) 02004 $ DESCC( I ) = NPROW 02005 * 02006 * Test CSRCC >= NPCOL 02007 * 02008 IF( I.EQ.CSRC_ ) 02009 $ DESCC( I ) = NPCOL 02010 * 02011 * Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2. 02012 * 02013 IF( I.EQ.LLD_ ) THEN 02014 IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN 02015 DESCC( I ) = 1 02016 ELSE 02017 DESCC( I ) = 0 02018 END IF 02019 END IF 02020 * 02021 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 02022 CALL PCCALLSUB( SUBPTR, SCODE ) 02023 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02024 * 02025 END IF 02026 * 02027 30 CONTINUE 02028 * 02029 ELSE IF( LSAME( ARGNAM, 'X' ) ) THEN 02030 * 02031 * Check IX. Set all other OK, bad IX 02032 * 02033 CALL PCSETPBLAS( ICTXT ) 02034 IX = -1 02035 INFOT = ARGPOS + 1 02036 CALL PCCALLSUB( SUBPTR, SCODE ) 02037 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02038 * 02039 * Check JX. Set all other OK, bad JX 02040 * 02041 CALL PCSETPBLAS( ICTXT ) 02042 JX = -1 02043 INFOT = ARGPOS + 2 02044 CALL PCCALLSUB( SUBPTR, SCODE ) 02045 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02046 * 02047 * Check DESCX. Set all other OK, bad DESCX 02048 * 02049 DO 40 I = 1, DLEN_ 02050 * 02051 * Set I'th entry of DESCX to incorrect value, rest ok. 02052 * 02053 CALL PCSETPBLAS( ICTXT ) 02054 DESCX( I ) = -2 02055 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 02056 CALL PCCALLSUB( SUBPTR, SCODE ) 02057 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02058 * 02059 * Extra tests for RSRCX, CSRCX, LDX 02060 * 02061 IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR. 02062 $ ( I.EQ.LLD_ ) ) THEN 02063 * 02064 CALL PCSETPBLAS( ICTXT ) 02065 * 02066 * Test RSRCX >= NPROW 02067 * 02068 IF( I.EQ.RSRC_ ) 02069 $ DESCX( I ) = NPROW 02070 * 02071 * Test CSRCX >= NPCOL 02072 * 02073 IF( I.EQ.CSRC_ ) 02074 $ DESCX( I ) = NPCOL 02075 * 02076 * Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2. 02077 * 02078 IF( I.EQ.LLD_ ) THEN 02079 IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN 02080 DESCX( I ) = 1 02081 ELSE 02082 DESCX( I ) = 0 02083 END IF 02084 END IF 02085 * 02086 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 02087 CALL PCCALLSUB( SUBPTR, SCODE ) 02088 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02089 * 02090 END IF 02091 * 02092 40 CONTINUE 02093 * 02094 * Check INCX. Set all other OK, bad INCX 02095 * 02096 CALL PCSETPBLAS( ICTXT ) 02097 INCX = -1 02098 INFOT = ARGPOS + 4 02099 CALL PCCALLSUB( SUBPTR, SCODE ) 02100 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02101 * 02102 ELSE 02103 * 02104 * Check IY. Set all other OK, bad IY 02105 * 02106 CALL PCSETPBLAS( ICTXT ) 02107 IY = -1 02108 INFOT = ARGPOS + 1 02109 CALL PCCALLSUB( SUBPTR, SCODE ) 02110 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02111 * 02112 * Check JY. Set all other OK, bad JY 02113 * 02114 CALL PCSETPBLAS( ICTXT ) 02115 JY = -1 02116 INFOT = ARGPOS + 2 02117 CALL PCCALLSUB( SUBPTR, SCODE ) 02118 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02119 * 02120 * Check DESCY. Set all other OK, bad DESCY 02121 * 02122 DO 50 I = 1, DLEN_ 02123 * 02124 * Set I'th entry of DESCY to incorrect value, rest ok. 02125 * 02126 CALL PCSETPBLAS( ICTXT ) 02127 DESCY( I ) = -2 02128 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 02129 CALL PCCALLSUB( SUBPTR, SCODE ) 02130 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02131 * 02132 * Extra tests for RSRCY, CSRCY, LDY 02133 * 02134 IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR. 02135 $ ( I.EQ.LLD_ ) ) THEN 02136 * 02137 CALL PCSETPBLAS( ICTXT ) 02138 * 02139 * Test RSRCY >= NPROW 02140 * 02141 IF( I.EQ.RSRC_ ) 02142 $ DESCY( I ) = NPROW 02143 * 02144 * Test CSRCY >= NPCOL 02145 * 02146 IF( I.EQ.CSRC_ ) 02147 $ DESCY( I ) = NPCOL 02148 * 02149 * Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2. 02150 * 02151 IF( I.EQ.LLD_ ) THEN 02152 IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN 02153 DESCY( I ) = 1 02154 ELSE 02155 DESCY( I ) = 0 02156 END IF 02157 END IF 02158 * 02159 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 02160 CALL PCCALLSUB( SUBPTR, SCODE ) 02161 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02162 * 02163 END IF 02164 * 02165 50 CONTINUE 02166 * 02167 * Check INCY. Set all other OK, bad INCY 02168 * 02169 CALL PCSETPBLAS( ICTXT ) 02170 INCY = -1 02171 INFOT = ARGPOS + 4 02172 CALL PCCALLSUB( SUBPTR, SCODE ) 02173 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02174 * 02175 END IF 02176 * 02177 RETURN 02178 * 02179 * End of PCCHKMAT 02180 * 02181 END 02182 SUBROUTINE PCCALLSUB( SUBPTR, SCODE ) 02183 * 02184 * -- PBLAS test routine (version 2.0) -- 02185 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02186 * and University of California, Berkeley. 02187 * April 1, 1998 02188 * 02189 * .. Scalar Arguments .. 02190 INTEGER SCODE 02191 * .. 02192 * .. Subroutine Arguments .. 02193 EXTERNAL SUBPTR 02194 * .. 02195 * 02196 * Purpose 02197 * ======= 02198 * 02199 * PCCALLSUB calls the subroutine SUBPTR with the calling sequence iden- 02200 * tified by SCODE. 02201 * 02202 * Notes 02203 * ===== 02204 * 02205 * A description vector is associated with each 2D block-cyclicly dis- 02206 * tributed matrix. This vector stores the information required to 02207 * establish the mapping between a matrix entry and its corresponding 02208 * process and memory location. 02209 * 02210 * In the following comments, the character _ should be read as 02211 * "of the distributed matrix". Let A be a generic term for any 2D 02212 * block cyclicly distributed matrix. Its description vector is DESCA: 02213 * 02214 * NOTATION STORED IN EXPLANATION 02215 * ---------------- --------------- ------------------------------------ 02216 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 02217 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 02218 * the NPROW x NPCOL BLACS process grid 02219 * A is distributed over. The context 02220 * itself is global, but the handle 02221 * (the integer value) may vary. 02222 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 02223 * ted matrix A, M_A >= 0. 02224 * N_A (global) DESCA( N_ ) The number of columns in the distri- 02225 * buted matrix A, N_A >= 0. 02226 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 02227 * block of the matrix A, IMB_A > 0. 02228 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 02229 * left block of the matrix A, 02230 * INB_A > 0. 02231 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 02232 * bute the last M_A-IMB_A rows of A, 02233 * MB_A > 0. 02234 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 02235 * bute the last N_A-INB_A columns of 02236 * A, NB_A > 0. 02237 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 02238 * row of the matrix A is distributed, 02239 * NPROW > RSRC_A >= 0. 02240 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 02241 * first column of A is distributed. 02242 * NPCOL > CSRC_A >= 0. 02243 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 02244 * array storing the local blocks of 02245 * the distributed matrix A, 02246 * IF( Lc( 1, N_A ) > 0 ) 02247 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 02248 * ELSE 02249 * LLD_A >= 1. 02250 * 02251 * Let K be the number of rows of a matrix A starting at the global in- 02252 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 02253 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 02254 * receive if these K rows were distributed over NPROW processes. If K 02255 * is the number of columns of a matrix A starting at the global index 02256 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 02257 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 02258 * these K columns were distributed over NPCOL processes. 02259 * 02260 * The values of Lr() and Lc() may be determined via a call to the func- 02261 * tion PB_NUMROC: 02262 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 02263 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 02264 * 02265 * Arguments 02266 * ========= 02267 * 02268 * SUBPTR (global input) SUBROUTINE 02269 * On entry, SUBPTR is a subroutine. SUBPTR must be declared 02270 * EXTERNAL in the calling subroutine. 02271 * 02272 * SCODE (global input) INTEGER 02273 * On entry, SCODE specifies the calling sequence code. 02274 * 02275 * Calling sequence encodings 02276 * ========================== 02277 * 02278 * code Formal argument list Examples 02279 * 02280 * 11 (n, v1,v2) _SWAP, _COPY 02281 * 12 (n,s1, v1 ) _SCAL, _SCAL 02282 * 13 (n,s1, v1,v2) _AXPY, _DOT_ 02283 * 14 (n,s1,i1,v1 ) _AMAX 02284 * 15 (n,u1, v1 ) _ASUM, _NRM2 02285 * 02286 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV 02287 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV 02288 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV 02289 * 24 ( m,n,s1,v1,v2,m1) _GER_ 02290 * 25 (uplo, n,s1,v1, m1) _SYR 02291 * 26 (uplo, n,u1,v1, m1) _HER 02292 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2 02293 * 02294 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM 02295 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM 02296 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK 02297 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK 02298 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K 02299 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K 02300 * 37 ( m,n, s1,m1, s2,m3) _TRAN_ 02301 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM 02302 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD 02303 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD 02304 * 02305 * -- Written on April 1, 1998 by 02306 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02307 * 02308 * ===================================================================== 02309 * 02310 * .. Parameters .. 02311 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 02312 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 02313 $ RSRC_ 02314 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 02315 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 02316 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 02317 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 02318 * .. 02319 * .. Common Blocks .. 02320 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO 02321 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB, 02322 $ JC, JX, JY, KDIM, MDIM, NDIM 02323 REAL USCLR 02324 COMPLEX SCLR 02325 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ), 02326 $ DESCX( DLEN_ ), DESCY( DLEN_ ) 02327 COMPLEX A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 ) 02328 COMMON /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO 02329 COMMON /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY 02330 COMMON /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY, 02331 $ JA, JB, JC, JX, JY 02332 COMMON /PBLASM/A, B, C 02333 COMMON /PBLASN/KDIM, MDIM, NDIM 02334 COMMON /PBLASS/SCLR, USCLR 02335 COMMON /PBLASV/X, Y 02336 * .. 02337 * .. Executable Statements .. 02338 * 02339 * Level 1 PBLAS 02340 * 02341 IF( SCODE.EQ.11 ) THEN 02342 * 02343 CALL SUBPTR( NDIM, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, 02344 $ INCY ) 02345 * 02346 ELSE IF( SCODE.EQ.12 ) THEN 02347 * 02348 CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX ) 02349 * 02350 ELSE IF( SCODE.EQ.13 ) THEN 02351 * 02352 CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY, JY, 02353 $ DESCY, INCY ) 02354 * 02355 ELSE IF( SCODE.EQ.14 ) THEN 02356 * 02357 CALL SUBPTR( NDIM, SCLR, ISCLR, X, IX, JX, DESCX, INCX ) 02358 * 02359 ELSE IF( SCODE.EQ.15 ) THEN 02360 * 02361 CALL SUBPTR( NDIM, USCLR, X, IX, JX, DESCX, INCX ) 02362 * 02363 * Level 2 PBLAS 02364 * 02365 ELSE IF( SCODE.EQ.21 ) THEN 02366 * 02367 CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, X, IX, 02368 $ JX, DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY ) 02369 * 02370 ELSE IF( SCODE.EQ.22 ) THEN 02371 * 02372 CALL SUBPTR( UPLO, NDIM, SCLR, A, IA, JA, DESCA, X, IX, JX, 02373 $ DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY ) 02374 * 02375 ELSE IF( SCODE.EQ.23 ) THEN 02376 * 02377 CALL SUBPTR( UPLO, TRANSA, DIAG, NDIM, A, IA, JA, DESCA, X, IX, 02378 $ JX, DESCX, INCX ) 02379 * 02380 ELSE IF( SCODE.EQ.24 ) THEN 02381 * 02382 CALL SUBPTR( MDIM, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY, 02383 $ JY, DESCY, INCY, A, IA, JA, DESCA ) 02384 * 02385 ELSE IF( SCODE.EQ.25 ) THEN 02386 * 02387 CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, A, IA, 02388 $ JA, DESCA ) 02389 * 02390 ELSE IF( SCODE.EQ.26 ) THEN 02391 * 02392 CALL SUBPTR( UPLO, NDIM, USCLR, X, IX, JX, DESCX, INCX, A, IA, 02393 $ JA, DESCA ) 02394 * 02395 ELSE IF( SCODE.EQ.27 ) THEN 02396 * 02397 CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY, 02398 $ JY, DESCY, INCY, A, IA, JA, DESCA ) 02399 * 02400 * Level 3 PBLAS 02401 * 02402 ELSE IF( SCODE.EQ.31 ) THEN 02403 * 02404 CALL SUBPTR( TRANSA, TRANSB, MDIM, NDIM, KDIM, SCLR, A, IA, JA, 02405 $ DESCA, B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC ) 02406 * 02407 ELSE IF( SCODE.EQ.32 ) THEN 02408 * 02409 CALL SUBPTR( SIDE, UPLO, MDIM, NDIM, SCLR, A, IA, JA, DESCA, B, 02410 $ IB, JB, DESCB, SCLR, C, IC, JC, DESCC ) 02411 * 02412 ELSE IF( SCODE.EQ.33 ) THEN 02413 * 02414 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA, 02415 $ SCLR, C, IC, JC, DESCC ) 02416 * 02417 ELSE IF( SCODE.EQ.34 ) THEN 02418 * 02419 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, USCLR, A, IA, JA, DESCA, 02420 $ USCLR, C, IC, JC, DESCC ) 02421 * 02422 ELSE IF( SCODE.EQ.35 ) THEN 02423 * 02424 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA, 02425 $ B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC ) 02426 * 02427 ELSE IF( SCODE.EQ.36 ) THEN 02428 * 02429 CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA, 02430 $ B, IB, JB, DESCB, USCLR, C, IC, JC, DESCC ) 02431 * 02432 ELSE IF( SCODE.EQ.37 ) THEN 02433 * 02434 CALL SUBPTR( MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR, C, IC, 02435 $ JC, DESCC ) 02436 * 02437 ELSE IF( SCODE.EQ.38 ) THEN 02438 * 02439 CALL SUBPTR( SIDE, UPLO, TRANSA, DIAG, MDIM, NDIM, SCLR, A, IA, 02440 $ JA, DESCA, B, IB, JB, DESCB ) 02441 * 02442 ELSE IF( SCODE.EQ.39 ) THEN 02443 * 02444 CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR, 02445 $ C, IC, JC, DESCC ) 02446 * 02447 ELSE IF( SCODE.EQ.40 ) THEN 02448 * 02449 CALL SUBPTR( UPLO, TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, 02450 $ SCLR, C, IC, JC, DESCC ) 02451 * 02452 END IF 02453 * 02454 RETURN 02455 * 02456 * End of PCCALLSUB 02457 * 02458 END 02459 SUBROUTINE PCERRSET( ERR, ERRMAX, XTRUE, X ) 02460 * 02461 * -- PBLAS test routine (version 2.0) -- 02462 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02463 * and University of California, Berkeley. 02464 * April 1, 1998 02465 * 02466 * .. Scalar Arguments .. 02467 REAL ERR, ERRMAX 02468 COMPLEX X, XTRUE 02469 * .. 02470 * 02471 * Purpose 02472 * ======= 02473 * 02474 * PCERRSET computes the absolute difference ERR = |XTRUE - X| and com- 02475 * pares it with zero. ERRMAX accumulates the absolute error difference. 02476 * 02477 * Notes 02478 * ===== 02479 * 02480 * A description vector is associated with each 2D block-cyclicly dis- 02481 * tributed matrix. This vector stores the information required to 02482 * establish the mapping between a matrix entry and its corresponding 02483 * process and memory location. 02484 * 02485 * In the following comments, the character _ should be read as 02486 * "of the distributed matrix". Let A be a generic term for any 2D 02487 * block cyclicly distributed matrix. Its description vector is DESCA: 02488 * 02489 * NOTATION STORED IN EXPLANATION 02490 * ---------------- --------------- ------------------------------------ 02491 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 02492 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 02493 * the NPROW x NPCOL BLACS process grid 02494 * A is distributed over. The context 02495 * itself is global, but the handle 02496 * (the integer value) may vary. 02497 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 02498 * ted matrix A, M_A >= 0. 02499 * N_A (global) DESCA( N_ ) The number of columns in the distri- 02500 * buted matrix A, N_A >= 0. 02501 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 02502 * block of the matrix A, IMB_A > 0. 02503 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 02504 * left block of the matrix A, 02505 * INB_A > 0. 02506 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 02507 * bute the last M_A-IMB_A rows of A, 02508 * MB_A > 0. 02509 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 02510 * bute the last N_A-INB_A columns of 02511 * A, NB_A > 0. 02512 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 02513 * row of the matrix A is distributed, 02514 * NPROW > RSRC_A >= 0. 02515 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 02516 * first column of A is distributed. 02517 * NPCOL > CSRC_A >= 0. 02518 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 02519 * array storing the local blocks of 02520 * the distributed matrix A, 02521 * IF( Lc( 1, N_A ) > 0 ) 02522 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 02523 * ELSE 02524 * LLD_A >= 1. 02525 * 02526 * Let K be the number of rows of a matrix A starting at the global in- 02527 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 02528 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 02529 * receive if these K rows were distributed over NPROW processes. If K 02530 * is the number of columns of a matrix A starting at the global index 02531 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 02532 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 02533 * these K columns were distributed over NPCOL processes. 02534 * 02535 * The values of Lr() and Lc() may be determined via a call to the func- 02536 * tion PB_NUMROC: 02537 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 02538 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 02539 * 02540 * Arguments 02541 * ========= 02542 * 02543 * ERR (local output) REAL 02544 * On exit, ERR specifies the absolute difference |XTRUE - X|. 02545 * 02546 * ERRMAX (local input/local output) REAL 02547 * On entry, ERRMAX specifies a previously computed error. On 02548 * exit ERRMAX is the accumulated error MAX( ERRMAX, ERR ). 02549 * 02550 * XTRUE (local input) COMPLEX 02551 * On entry, XTRUE specifies the true value. 02552 * 02553 * X (local input) COMPLEX 02554 * On entry, X specifies the value to be compared to XTRUE. 02555 * 02556 * -- Written on April 1, 1998 by 02557 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02558 * 02559 * ===================================================================== 02560 * 02561 * .. External Functions .. 02562 REAL PSDIFF 02563 EXTERNAL PSDIFF 02564 * .. 02565 * .. Intrinsic Functions .. 02566 INTRINSIC ABS, AIMAG, MAX, REAL 02567 * .. 02568 * .. Executable Statements .. 02569 * 02570 ERR = ABS( PSDIFF( REAL( XTRUE ), REAL( X ) ) ) 02571 ERR = MAX( ERR, ABS( PSDIFF( AIMAG( XTRUE ), AIMAG( X ) ) ) ) 02572 * 02573 ERRMAX = MAX( ERRMAX, ERR ) 02574 * 02575 RETURN 02576 * 02577 * End of PCERRSET 02578 * 02579 END 02580 SUBROUTINE PCCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02581 $ INFO ) 02582 * 02583 * -- PBLAS test routine (version 2.0) -- 02584 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02585 * and University of California, Berkeley. 02586 * April 1, 1998 02587 * 02588 * .. Scalar Arguments .. 02589 INTEGER INCX, INFO, IX, JX, N 02590 REAL ERRMAX 02591 * .. 02592 * .. Array Arguments .. 02593 INTEGER DESCX( * ) 02594 COMPLEX PX( * ), X( * ) 02595 * .. 02596 * 02597 * Purpose 02598 * ======= 02599 * 02600 * PCCHKVIN checks that the submatrix sub( PX ) remained unchanged. The 02601 * local array entries are compared element by element, and their dif- 02602 * ference is tested against 0.0 as well as the epsilon machine. Notice 02603 * that this difference should be numerically exactly the zero machine, 02604 * but because of the possible fluctuation of some of the data we flag- 02605 * ged differently a difference less than twice the epsilon machine. The 02606 * largest error is also returned. 02607 * 02608 * Notes 02609 * ===== 02610 * 02611 * A description vector is associated with each 2D block-cyclicly dis- 02612 * tributed matrix. This vector stores the information required to 02613 * establish the mapping between a matrix entry and its corresponding 02614 * process and memory location. 02615 * 02616 * In the following comments, the character _ should be read as 02617 * "of the distributed matrix". Let A be a generic term for any 2D 02618 * block cyclicly distributed matrix. Its description vector is DESCA: 02619 * 02620 * NOTATION STORED IN EXPLANATION 02621 * ---------------- --------------- ------------------------------------ 02622 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 02623 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 02624 * the NPROW x NPCOL BLACS process grid 02625 * A is distributed over. The context 02626 * itself is global, but the handle 02627 * (the integer value) may vary. 02628 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 02629 * ted matrix A, M_A >= 0. 02630 * N_A (global) DESCA( N_ ) The number of columns in the distri- 02631 * buted matrix A, N_A >= 0. 02632 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 02633 * block of the matrix A, IMB_A > 0. 02634 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 02635 * left block of the matrix A, 02636 * INB_A > 0. 02637 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 02638 * bute the last M_A-IMB_A rows of A, 02639 * MB_A > 0. 02640 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 02641 * bute the last N_A-INB_A columns of 02642 * A, NB_A > 0. 02643 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 02644 * row of the matrix A is distributed, 02645 * NPROW > RSRC_A >= 0. 02646 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 02647 * first column of A is distributed. 02648 * NPCOL > CSRC_A >= 0. 02649 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 02650 * array storing the local blocks of 02651 * the distributed matrix A, 02652 * IF( Lc( 1, N_A ) > 0 ) 02653 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 02654 * ELSE 02655 * LLD_A >= 1. 02656 * 02657 * Let K be the number of rows of a matrix A starting at the global in- 02658 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 02659 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 02660 * receive if these K rows were distributed over NPROW processes. If K 02661 * is the number of columns of a matrix A starting at the global index 02662 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 02663 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 02664 * these K columns were distributed over NPCOL processes. 02665 * 02666 * The values of Lr() and Lc() may be determined via a call to the func- 02667 * tion PB_NUMROC: 02668 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 02669 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 02670 * 02671 * Arguments 02672 * ========= 02673 * 02674 * ERRMAX (global output) REAL 02675 * On exit, ERRMAX specifies the largest absolute element-wise 02676 * difference between sub( X ) and sub( PX ). 02677 * 02678 * N (global input) INTEGER 02679 * On entry, N specifies the length of the subvector operand 02680 * sub( X ). N must be at least zero. 02681 * 02682 * X (local input) COMPLEX array 02683 * On entry, X is an array of dimension (DESCX( M_ ),*). This 02684 * array contains a local copy of the initial entire matrix PX. 02685 * 02686 * PX (local input) COMPLEX array 02687 * On entry, PX is an array of dimension (DESCX( LLD_ ),*). This 02688 * array contains the local entries of the matrix PX. 02689 * 02690 * IX (global input) INTEGER 02691 * On entry, IX specifies X's global row index, which points to 02692 * the beginning of the submatrix sub( X ). 02693 * 02694 * JX (global input) INTEGER 02695 * On entry, JX specifies X's global column index, which points 02696 * to the beginning of the submatrix sub( X ). 02697 * 02698 * DESCX (global and local input) INTEGER array 02699 * On entry, DESCX is an integer array of dimension DLEN_. This 02700 * is the array descriptor for the matrix X. 02701 * 02702 * INCX (global input) INTEGER 02703 * On entry, INCX specifies the global increment for the 02704 * elements of X. Only two values of INCX are supported in 02705 * this version, namely 1 and M_X. INCX must not be zero. 02706 * 02707 * INFO (global output) INTEGER 02708 * On exit, if INFO = 0, no error has been found, 02709 * If INFO > 0, the maximum abolute error found is in (0,eps], 02710 * If INFO < 0, the maximum abolute error found is in (eps,+oo). 02711 * 02712 * -- Written on April 1, 1998 by 02713 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02714 * 02715 * ===================================================================== 02716 * 02717 * .. Parameters .. 02718 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 02719 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 02720 $ RSRC_ 02721 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 02722 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 02723 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 02724 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 02725 REAL ZERO 02726 PARAMETER ( ZERO = 0.0E+0 ) 02727 * .. 02728 * .. Local Scalars .. 02729 LOGICAL COLREP, ROWREP 02730 INTEGER I, IB, ICTXT, ICURCOL, ICURROW, IIX, IN, IXCOL, 02731 $ IXROW, J, JB, JJX, JN, KK, LDPX, LDX, LL, 02732 $ MYCOL, MYROW, NPCOL, NPROW 02733 REAL ERR, EPS 02734 * .. 02735 * .. External Subroutines .. 02736 EXTERNAL BLACS_GRIDINFO, PB_INFOG2L, PCERRSET, SGAMX2D 02737 * .. 02738 * .. External Functions .. 02739 REAL PSLAMCH 02740 EXTERNAL PSLAMCH 02741 * .. 02742 * .. Intrinsic Functions .. 02743 INTRINSIC ABS, AIMAG, MAX, MIN, MOD, REAL 02744 * .. 02745 * .. Executable Statements .. 02746 * 02747 INFO = 0 02748 ERRMAX = ZERO 02749 * 02750 * Quick return if possible 02751 * 02752 IF( N.LE.0 ) 02753 $ RETURN 02754 * 02755 ICTXT = DESCX( CTXT_ ) 02756 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 02757 * 02758 EPS = PSLAMCH( ICTXT, 'eps' ) 02759 * 02760 CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, IIX, 02761 $ JJX, IXROW, IXCOL ) 02762 * 02763 LDX = DESCX( M_ ) 02764 LDPX = DESCX( LLD_ ) 02765 ROWREP = ( IXROW.EQ.-1 ) 02766 COLREP = ( IXCOL.EQ.-1 ) 02767 * 02768 IF( N.EQ.1 ) THEN 02769 * 02770 IF( ( MYROW.EQ.IXROW .OR. ROWREP ) .AND. 02771 $ ( MYCOL.EQ.IXCOL .OR. COLREP ) ) 02772 $ CALL PCERRSET( ERR, ERRMAX, X( IX+(JX-1)*LDX ), 02773 $ PX( IIX+(JJX-1)*LDPX ) ) 02774 * 02775 ELSE IF( INCX.EQ.DESCX( M_ ) ) THEN 02776 * 02777 * sub( X ) is a row vector 02778 * 02779 JB = DESCX( INB_ ) - JX + 1 02780 IF( JB.LE.0 ) 02781 $ JB = ( ( -JB ) / DESCX( NB_ ) + 1 ) * DESCX( NB_ ) + JB 02782 JB = MIN( JB, N ) 02783 JN = JX + JB - 1 02784 * 02785 IF( MYROW.EQ.IXROW .OR. ROWREP ) THEN 02786 * 02787 ICURCOL = IXCOL 02788 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 02789 DO 10 J = JX, JN 02790 CALL PCERRSET( ERR, ERRMAX, X( IX+(J-1)*LDX ), 02791 $ PX( IIX+(JJX-1)*LDPX ) ) 02792 JJX = JJX + 1 02793 10 CONTINUE 02794 END IF 02795 ICURCOL = MOD( ICURCOL+1, NPCOL ) 02796 * 02797 DO 30 J = JN+1, JX+N-1, DESCX( NB_ ) 02798 JB = MIN( JX+N-J, DESCX( NB_ ) ) 02799 * 02800 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 02801 * 02802 DO 20 KK = 0, JB-1 02803 CALL PCERRSET( ERR, ERRMAX, X( IX+(J+KK-1)*LDX ), 02804 $ PX( IIX+(JJX+KK-1)*LDPX ) ) 02805 20 CONTINUE 02806 * 02807 JJX = JJX + JB 02808 * 02809 END IF 02810 * 02811 ICURCOL = MOD( ICURCOL+1, NPCOL ) 02812 * 02813 30 CONTINUE 02814 * 02815 END IF 02816 * 02817 ELSE 02818 * 02819 * sub( X ) is a column vector 02820 * 02821 IB = DESCX( IMB_ ) - IX + 1 02822 IF( IB.LE.0 ) 02823 $ IB = ( ( -IB ) / DESCX( MB_ ) + 1 ) * DESCX( MB_ ) + IB 02824 IB = MIN( IB, N ) 02825 IN = IX + IB - 1 02826 * 02827 IF( MYCOL.EQ.IXCOL .OR. COLREP ) THEN 02828 * 02829 ICURROW = IXROW 02830 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 02831 DO 40 I = IX, IN 02832 CALL PCERRSET( ERR, ERRMAX, X( I+(JX-1)*LDX ), 02833 $ PX( IIX+(JJX-1)*LDPX ) ) 02834 IIX = IIX + 1 02835 40 CONTINUE 02836 END IF 02837 ICURROW = MOD( ICURROW+1, NPROW ) 02838 * 02839 DO 60 I = IN+1, IX+N-1, DESCX( MB_ ) 02840 IB = MIN( IX+N-I, DESCX( MB_ ) ) 02841 * 02842 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 02843 * 02844 DO 50 KK = 0, IB-1 02845 CALL PCERRSET( ERR, ERRMAX, X( I+KK+(JX-1)*LDX ), 02846 $ PX( IIX+KK+(JJX-1)*LDPX ) ) 02847 50 CONTINUE 02848 * 02849 IIX = IIX + IB 02850 * 02851 END IF 02852 * 02853 ICURROW = MOD( ICURROW+1, NPROW ) 02854 * 02855 60 CONTINUE 02856 * 02857 END IF 02858 * 02859 END IF 02860 * 02861 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1, 02862 $ -1, -1 ) 02863 * 02864 IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN 02865 INFO = 1 02866 ELSE IF( ERRMAX.GT.EPS ) THEN 02867 INFO = -1 02868 END IF 02869 * 02870 RETURN 02871 * 02872 * End of PCCHKVIN 02873 * 02874 END 02875 SUBROUTINE PCCHKVOUT( N, X, PX, IX, JX, DESCX, INCX, INFO ) 02876 * 02877 * -- PBLAS test routine (version 2.0) -- 02878 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02879 * and University of California, Berkeley. 02880 * April 1, 1998 02881 * 02882 * .. Scalar Arguments .. 02883 INTEGER INCX, INFO, IX, JX, N 02884 * .. 02885 * .. Array Arguments .. 02886 INTEGER DESCX( * ) 02887 COMPLEX PX( * ), X( * ) 02888 * .. 02889 * 02890 * Purpose 02891 * ======= 02892 * 02893 * PCCHKVOUT checks that the matrix PX \ sub( PX ) remained unchanged. 02894 * The local array entries are compared element by element, and their 02895 * difference is tested against 0.0 as well as the epsilon machine. No- 02896 * tice that this difference should be numerically exactly the zero ma- 02897 * chine, but because of the possible movement of some of the data we 02898 * flagged differently a difference less than twice the epsilon machine. 02899 * The largest error is reported. 02900 * 02901 * Notes 02902 * ===== 02903 * 02904 * A description vector is associated with each 2D block-cyclicly dis- 02905 * tributed matrix. This vector stores the information required to 02906 * establish the mapping between a matrix entry and its corresponding 02907 * process and memory location. 02908 * 02909 * In the following comments, the character _ should be read as 02910 * "of the distributed matrix". Let A be a generic term for any 2D 02911 * block cyclicly distributed matrix. Its description vector is DESCA: 02912 * 02913 * NOTATION STORED IN EXPLANATION 02914 * ---------------- --------------- ------------------------------------ 02915 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 02916 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 02917 * the NPROW x NPCOL BLACS process grid 02918 * A is distributed over. The context 02919 * itself is global, but the handle 02920 * (the integer value) may vary. 02921 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 02922 * ted matrix A, M_A >= 0. 02923 * N_A (global) DESCA( N_ ) The number of columns in the distri- 02924 * buted matrix A, N_A >= 0. 02925 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 02926 * block of the matrix A, IMB_A > 0. 02927 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 02928 * left block of the matrix A, 02929 * INB_A > 0. 02930 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 02931 * bute the last M_A-IMB_A rows of A, 02932 * MB_A > 0. 02933 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 02934 * bute the last N_A-INB_A columns of 02935 * A, NB_A > 0. 02936 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 02937 * row of the matrix A is distributed, 02938 * NPROW > RSRC_A >= 0. 02939 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 02940 * first column of A is distributed. 02941 * NPCOL > CSRC_A >= 0. 02942 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 02943 * array storing the local blocks of 02944 * the distributed matrix A, 02945 * IF( Lc( 1, N_A ) > 0 ) 02946 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 02947 * ELSE 02948 * LLD_A >= 1. 02949 * 02950 * Let K be the number of rows of a matrix A starting at the global in- 02951 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 02952 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 02953 * receive if these K rows were distributed over NPROW processes. If K 02954 * is the number of columns of a matrix A starting at the global index 02955 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 02956 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 02957 * these K columns were distributed over NPCOL processes. 02958 * 02959 * The values of Lr() and Lc() may be determined via a call to the func- 02960 * tion PB_NUMROC: 02961 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 02962 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 02963 * 02964 * Arguments 02965 * ========= 02966 * 02967 * N (global input) INTEGER 02968 * On entry, N specifies the length of the subvector operand 02969 * sub( X ). N must be at least zero. 02970 * 02971 * X (local input) COMPLEX array 02972 * On entry, X is an array of dimension (DESCX( M_ ),*). This 02973 * array contains a local copy of the initial entire matrix PX. 02974 * 02975 * PX (local input) COMPLEX array 02976 * On entry, PX is an array of dimension (DESCX( LLD_ ),*). This 02977 * array contains the local entries of the matrix PX. 02978 * 02979 * IX (global input) INTEGER 02980 * On entry, IX specifies X's global row index, which points to 02981 * the beginning of the submatrix sub( X ). 02982 * 02983 * JX (global input) INTEGER 02984 * On entry, JX specifies X's global column index, which points 02985 * to the beginning of the submatrix sub( X ). 02986 * 02987 * DESCX (global and local input) INTEGER array 02988 * On entry, DESCX is an integer array of dimension DLEN_. This 02989 * is the array descriptor for the matrix X. 02990 * 02991 * INCX (global input) INTEGER 02992 * On entry, INCX specifies the global increment for the 02993 * elements of X. Only two values of INCX are supported in 02994 * this version, namely 1 and M_X. INCX must not be zero. 02995 * 02996 * INFO (global output) INTEGER 02997 * On exit, if INFO = 0, no error has been found, 02998 * If INFO > 0, the maximum abolute error found is in (0,eps], 02999 * If INFO < 0, the maximum abolute error found is in (eps,+oo). 03000 * 03001 * -- Written on April 1, 1998 by 03002 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03003 * 03004 * ===================================================================== 03005 * 03006 * .. Parameters .. 03007 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 03008 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 03009 $ RSRC_ 03010 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 03011 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 03012 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 03013 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 03014 REAL ZERO 03015 PARAMETER ( ZERO = 0.0E+0 ) 03016 * .. 03017 * .. Local Scalars .. 03018 LOGICAL COLREP, ROWREP 03019 INTEGER I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX, 03020 $ J, JB, JJ, KK, LDPX, LDX, LL, MBX, MPALL, 03021 $ MYCOL, MYCOLDIST, MYROW, MYROWDIST, NBX, NPCOL, 03022 $ NPROW, NQALL 03023 REAL EPS, ERR, ERRMAX 03024 * .. 03025 * .. External Subroutines .. 03026 EXTERNAL BLACS_GRIDINFO, PCERRSET, SGAMX2D 03027 * .. 03028 * .. External Functions .. 03029 INTEGER PB_NUMROC 03030 REAL PSLAMCH 03031 EXTERNAL PSLAMCH, PB_NUMROC 03032 * .. 03033 * .. Intrinsic Functions .. 03034 INTRINSIC ABS, AIMAG, MAX, MIN, MOD, REAL 03035 * .. 03036 * .. Executable Statements .. 03037 * 03038 INFO = 0 03039 ERRMAX = ZERO 03040 * 03041 * Quick return if possible 03042 * 03043 IF( ( DESCX( M_ ).LE.0 ).OR.( DESCX( N_ ).LE.0 ) ) 03044 $ RETURN 03045 * 03046 * Start the operations 03047 * 03048 ICTXT = DESCX( CTXT_ ) 03049 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 03050 * 03051 EPS = PSLAMCH( ICTXT, 'eps' ) 03052 * 03053 MPALL = PB_NUMROC( DESCX( M_ ), 1, DESCX( IMB_ ), DESCX( MB_ ), 03054 $ MYROW, DESCX( RSRC_ ), NPROW ) 03055 NQALL = PB_NUMROC( DESCX( N_ ), 1, DESCX( INB_ ), DESCX( NB_ ), 03056 $ MYCOL, DESCX( CSRC_ ), NPCOL ) 03057 * 03058 MBX = DESCX( MB_ ) 03059 NBX = DESCX( NB_ ) 03060 LDX = DESCX( M_ ) 03061 LDPX = DESCX( LLD_ ) 03062 ICURROW = DESCX( RSRC_ ) 03063 ICURCOL = DESCX( CSRC_ ) 03064 ROWREP = ( ICURROW.EQ.-1 ) 03065 COLREP = ( ICURCOL.EQ.-1 ) 03066 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 03067 IMBX = DESCX( IMB_ ) 03068 ELSE 03069 IMBX = MBX 03070 END IF 03071 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 03072 INBX = DESCX( INB_ ) 03073 ELSE 03074 INBX = NBX 03075 END IF 03076 IF( ROWREP ) THEN 03077 MYROWDIST = 0 03078 ELSE 03079 MYROWDIST = MOD( MYROW - ICURROW + NPROW, NPROW ) 03080 END IF 03081 IF( COLREP ) THEN 03082 MYCOLDIST = 0 03083 ELSE 03084 MYCOLDIST = MOD( MYCOL - ICURCOL + NPCOL, NPCOL ) 03085 END IF 03086 II = 1 03087 JJ = 1 03088 * 03089 IF( INCX.EQ.DESCX( M_ ) ) THEN 03090 * 03091 * sub( X ) is a row vector 03092 * 03093 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 03094 * 03095 I = 1 03096 IF( MYCOLDIST.EQ.0 ) THEN 03097 J = 1 03098 ELSE 03099 J = DESCX( INB_ ) + ( MYCOLDIST - 1 ) * NBX + 1 03100 END IF 03101 JB = MIN( MAX( 0, DESCX( N_ ) - J + 1 ), INBX ) 03102 IB = MIN( DESCX( M_ ), DESCX( IMB_ ) ) 03103 * 03104 DO 20 KK = 0, JB-1 03105 DO 10 LL = 0, IB-1 03106 IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR. J+KK.GT.JX+N-1 ) 03107 $ CALL PCERRSET( ERR, ERRMAX, 03108 $ X( I+LL+(J+KK-1)*LDX ), 03109 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03110 10 CONTINUE 03111 20 CONTINUE 03112 IF( COLREP ) THEN 03113 J = J + INBX 03114 ELSE 03115 J = J + INBX + ( NPCOL - 1 ) * NBX 03116 END IF 03117 * 03118 DO 50 JJ = INBX+1, NQALL, NBX 03119 JB = MIN( NQALL-JJ+1, NBX ) 03120 * 03121 DO 40 KK = 0, JB-1 03122 DO 30 LL = 0, IB-1 03123 IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR. 03124 $ J+KK.GT.JX+N-1 ) 03125 $ CALL PCERRSET( ERR, ERRMAX, 03126 $ X( I+LL+(J+KK-1)*LDX ), 03127 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03128 30 CONTINUE 03129 40 CONTINUE 03130 * 03131 IF( COLREP ) THEN 03132 J = J + NBX 03133 ELSE 03134 J = J + NPCOL * NBX 03135 END IF 03136 * 03137 50 CONTINUE 03138 * 03139 II = II + IB 03140 * 03141 END IF 03142 * 03143 ICURROW = MOD( ICURROW + 1, NPROW ) 03144 * 03145 DO 110 I = DESCX( IMB_ ) + 1, DESCX( M_ ), MBX 03146 IB = MIN( DESCX( M_ ) - I + 1, MBX ) 03147 * 03148 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 03149 * 03150 IF( MYCOLDIST.EQ.0 ) THEN 03151 J = 1 03152 ELSE 03153 J = DESCX( INB_ ) + ( MYCOLDIST - 1 ) * NBX + 1 03154 END IF 03155 * 03156 JJ = 1 03157 JB = MIN( MAX( 0, DESCX( N_ ) - J + 1 ), INBX ) 03158 DO 70 KK = 0, JB-1 03159 DO 60 LL = 0, IB-1 03160 IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR. 03161 $ J+KK.GT.JX+N-1 ) 03162 $ CALL PCERRSET( ERR, ERRMAX, 03163 $ X( I+LL+(J+KK-1)*LDX ), 03164 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03165 60 CONTINUE 03166 70 CONTINUE 03167 IF( COLREP ) THEN 03168 J = J + INBX 03169 ELSE 03170 J = J + INBX + ( NPCOL - 1 ) * NBX 03171 END IF 03172 * 03173 DO 100 JJ = INBX+1, NQALL, NBX 03174 JB = MIN( NQALL-JJ+1, NBX ) 03175 * 03176 DO 90 KK = 0, JB-1 03177 DO 80 LL = 0, IB-1 03178 IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR. 03179 $ J+KK.GT.JX+N-1 ) 03180 $ CALL PCERRSET( ERR, ERRMAX, 03181 $ X( I+LL+(J+KK-1)*LDX ), 03182 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03183 80 CONTINUE 03184 90 CONTINUE 03185 * 03186 IF( COLREP ) THEN 03187 J = J + NBX 03188 ELSE 03189 J = J + NPCOL * NBX 03190 END IF 03191 * 03192 100 CONTINUE 03193 * 03194 II = II + IB 03195 * 03196 END IF 03197 * 03198 ICURROW = MOD( ICURROW + 1, NPROW ) 03199 * 03200 110 CONTINUE 03201 * 03202 ELSE 03203 * 03204 * sub( X ) is a column vector 03205 * 03206 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 03207 * 03208 J = 1 03209 IF( MYROWDIST.EQ.0 ) THEN 03210 I = 1 03211 ELSE 03212 I = DESCX( IMB_ ) + ( MYROWDIST - 1 ) * MBX + 1 03213 END IF 03214 IB = MIN( MAX( 0, DESCX( M_ ) - I + 1 ), IMBX ) 03215 JB = MIN( DESCX( N_ ), DESCX( INB_ ) ) 03216 * 03217 DO 130 KK = 0, JB-1 03218 DO 120 LL = 0, IB-1 03219 IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR. I+LL.GT.IX+N-1 ) 03220 $ CALL PCERRSET( ERR, ERRMAX, 03221 $ X( I+LL+(J+KK-1)*LDX ), 03222 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03223 120 CONTINUE 03224 130 CONTINUE 03225 IF( ROWREP ) THEN 03226 I = I + IMBX 03227 ELSE 03228 I = I + IMBX + ( NPROW - 1 ) * MBX 03229 END IF 03230 * 03231 DO 160 II = IMBX+1, MPALL, MBX 03232 IB = MIN( MPALL-II+1, MBX ) 03233 * 03234 DO 150 KK = 0, JB-1 03235 DO 140 LL = 0, IB-1 03236 IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR. 03237 $ I+LL.GT.IX+N-1 ) 03238 $ CALL PCERRSET( ERR, ERRMAX, 03239 $ X( I+LL+(J+KK-1)*LDX ), 03240 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03241 140 CONTINUE 03242 150 CONTINUE 03243 * 03244 IF( ROWREP ) THEN 03245 I = I + MBX 03246 ELSE 03247 I = I + NPROW * MBX 03248 END IF 03249 * 03250 160 CONTINUE 03251 * 03252 JJ = JJ + JB 03253 * 03254 END IF 03255 * 03256 ICURCOL = MOD( ICURCOL + 1, NPCOL ) 03257 * 03258 DO 220 J = DESCX( INB_ ) + 1, DESCX( N_ ), NBX 03259 JB = MIN( DESCX( N_ ) - J + 1, NBX ) 03260 * 03261 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 03262 * 03263 IF( MYROWDIST.EQ.0 ) THEN 03264 I = 1 03265 ELSE 03266 I = DESCX( IMB_ ) + ( MYROWDIST - 1 ) * MBX + 1 03267 END IF 03268 * 03269 II = 1 03270 IB = MIN( MAX( 0, DESCX( M_ ) - I + 1 ), IMBX ) 03271 DO 180 KK = 0, JB-1 03272 DO 170 LL = 0, IB-1 03273 IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR. 03274 $ I+LL.GT.IX+N-1 ) 03275 $ CALL PCERRSET( ERR, ERRMAX, 03276 $ X( I+LL+(J+KK-1)*LDX ), 03277 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03278 170 CONTINUE 03279 180 CONTINUE 03280 IF( ROWREP ) THEN 03281 I = I + IMBX 03282 ELSE 03283 I = I + IMBX + ( NPROW - 1 ) * MBX 03284 END IF 03285 * 03286 DO 210 II = IMBX+1, MPALL, MBX 03287 IB = MIN( MPALL-II+1, MBX ) 03288 * 03289 DO 200 KK = 0, JB-1 03290 DO 190 LL = 0, IB-1 03291 IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR. 03292 $ I+LL.GT.IX+N-1 ) 03293 $ CALL PCERRSET( ERR, ERRMAX, 03294 $ X( I+LL+(J+KK-1)*LDX ), 03295 $ PX( II+LL+(JJ+KK-1)*LDPX ) ) 03296 190 CONTINUE 03297 200 CONTINUE 03298 * 03299 IF( ROWREP ) THEN 03300 I = I + MBX 03301 ELSE 03302 I = I + NPROW * MBX 03303 END IF 03304 * 03305 210 CONTINUE 03306 * 03307 JJ = JJ + JB 03308 * 03309 END IF 03310 * 03311 ICURCOL = MOD( ICURCOL + 1, NPCOL ) 03312 * 03313 220 CONTINUE 03314 * 03315 END IF 03316 * 03317 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1, 03318 $ -1, -1 ) 03319 * 03320 IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN 03321 INFO = 1 03322 ELSE IF( ERRMAX.GT.EPS ) THEN 03323 INFO = -1 03324 END IF 03325 * 03326 RETURN 03327 * 03328 * End of PCCHKVOUT 03329 * 03330 END 03331 SUBROUTINE PCCHKMIN( ERRMAX, M, N, A, PA, IA, JA, DESCA, INFO ) 03332 * 03333 * -- PBLAS test routine (version 2.0) -- 03334 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03335 * and University of California, Berkeley. 03336 * April 1, 1998 03337 * 03338 * .. Scalar Arguments .. 03339 INTEGER IA, INFO, JA, M, N 03340 REAL ERRMAX 03341 * .. 03342 * .. Array Arguments .. 03343 INTEGER DESCA( * ) 03344 COMPLEX PA( * ), A( * ) 03345 * .. 03346 * 03347 * Purpose 03348 * ======= 03349 * 03350 * PCCHKMIN checks that the submatrix sub( PA ) remained unchanged. The 03351 * local array entries are compared element by element, and their dif- 03352 * ference is tested against 0.0 as well as the epsilon machine. Notice 03353 * that this difference should be numerically exactly the zero machine, 03354 * but because of the possible fluctuation of some of the data we flag- 03355 * ged differently a difference less than twice the epsilon machine. The 03356 * largest error is also returned. 03357 * 03358 * Notes 03359 * ===== 03360 * 03361 * A description vector is associated with each 2D block-cyclicly dis- 03362 * tributed matrix. This vector stores the information required to 03363 * establish the mapping between a matrix entry and its corresponding 03364 * process and memory location. 03365 * 03366 * In the following comments, the character _ should be read as 03367 * "of the distributed matrix". Let A be a generic term for any 2D 03368 * block cyclicly distributed matrix. Its description vector is DESCA: 03369 * 03370 * NOTATION STORED IN EXPLANATION 03371 * ---------------- --------------- ------------------------------------ 03372 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 03373 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 03374 * the NPROW x NPCOL BLACS process grid 03375 * A is distributed over. The context 03376 * itself is global, but the handle 03377 * (the integer value) may vary. 03378 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 03379 * ted matrix A, M_A >= 0. 03380 * N_A (global) DESCA( N_ ) The number of columns in the distri- 03381 * buted matrix A, N_A >= 0. 03382 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 03383 * block of the matrix A, IMB_A > 0. 03384 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 03385 * left block of the matrix A, 03386 * INB_A > 0. 03387 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 03388 * bute the last M_A-IMB_A rows of A, 03389 * MB_A > 0. 03390 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 03391 * bute the last N_A-INB_A columns of 03392 * A, NB_A > 0. 03393 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 03394 * row of the matrix A is distributed, 03395 * NPROW > RSRC_A >= 0. 03396 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 03397 * first column of A is distributed. 03398 * NPCOL > CSRC_A >= 0. 03399 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 03400 * array storing the local blocks of 03401 * the distributed matrix A, 03402 * IF( Lc( 1, N_A ) > 0 ) 03403 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 03404 * ELSE 03405 * LLD_A >= 1. 03406 * 03407 * Let K be the number of rows of a matrix A starting at the global in- 03408 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 03409 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 03410 * receive if these K rows were distributed over NPROW processes. If K 03411 * is the number of columns of a matrix A starting at the global index 03412 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 03413 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 03414 * these K columns were distributed over NPCOL processes. 03415 * 03416 * The values of Lr() and Lc() may be determined via a call to the func- 03417 * tion PB_NUMROC: 03418 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 03419 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 03420 * 03421 * Arguments 03422 * ========= 03423 * 03424 * ERRMAX (global output) REAL 03425 * On exit, ERRMAX specifies the largest absolute element-wise 03426 * difference between sub( A ) and sub( PA ). 03427 * 03428 * M (global input) INTEGER 03429 * On entry, M specifies the number of rows of the submatrix 03430 * operand sub( A ). M must be at least zero. 03431 * 03432 * N (global input) INTEGER 03433 * On entry, N specifies the number of columns of the submatrix 03434 * operand sub( A ). N must be at least zero. 03435 * 03436 * A (local input) COMPLEX array 03437 * On entry, A is an array of dimension (DESCA( M_ ),*). This 03438 * array contains a local copy of the initial entire matrix PA. 03439 * 03440 * PA (local input) COMPLEX array 03441 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This 03442 * array contains the local entries of the matrix PA. 03443 * 03444 * IA (global input) INTEGER 03445 * On entry, IA specifies A's global row index, which points to 03446 * the beginning of the submatrix sub( A ). 03447 * 03448 * JA (global input) INTEGER 03449 * On entry, JA specifies A's global column index, which points 03450 * to the beginning of the submatrix sub( A ). 03451 * 03452 * DESCA (global and local input) INTEGER array 03453 * On entry, DESCA is an integer array of dimension DLEN_. This 03454 * is the array descriptor for the matrix A. 03455 * 03456 * INFO (global output) INTEGER 03457 * On exit, if INFO = 0, no error has been found, 03458 * If INFO > 0, the maximum abolute error found is in (0,eps], 03459 * If INFO < 0, the maximum abolute error found is in (eps,+oo). 03460 * 03461 * -- Written on April 1, 1998 by 03462 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03463 * 03464 * ===================================================================== 03465 * 03466 * .. Parameters .. 03467 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 03468 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 03469 $ RSRC_ 03470 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 03471 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 03472 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 03473 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 03474 REAL ZERO 03475 PARAMETER ( ZERO = 0.0E+0 ) 03476 * .. 03477 * .. Local Scalars .. 03478 LOGICAL COLREP, ROWREP 03479 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL, 03480 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K, 03481 $ KK, LDA, LDPA, LL, MYCOL, MYROW, NPCOL, NPROW 03482 REAL ERR, EPS 03483 * .. 03484 * .. External Subroutines .. 03485 EXTERNAL BLACS_GRIDINFO, PB_INFOG2L, PCERRSET, SGAMX2D 03486 * .. 03487 * .. External Functions .. 03488 REAL PSLAMCH 03489 EXTERNAL PSLAMCH 03490 * .. 03491 * .. Intrinsic Functions .. 03492 INTRINSIC ABS, AIMAG, MAX, MIN, MOD, REAL 03493 * .. 03494 * .. Executable Statements .. 03495 * 03496 INFO = 0 03497 ERRMAX = ZERO 03498 * 03499 * Quick return if posssible 03500 * 03501 IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) 03502 $ RETURN 03503 * 03504 * Start the operations 03505 * 03506 ICTXT = DESCA( CTXT_ ) 03507 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 03508 * 03509 EPS = PSLAMCH( ICTXT, 'eps' ) 03510 * 03511 CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, 03512 $ JJA, IAROW, IACOL ) 03513 * 03514 II = IIA 03515 JJ = JJA 03516 LDA = DESCA( M_ ) 03517 LDPA = DESCA( LLD_ ) 03518 ICURROW = IAROW 03519 ICURCOL = IACOL 03520 ROWREP = ( IAROW.EQ.-1 ) 03521 COLREP = ( IACOL.EQ.-1 ) 03522 * 03523 * Handle the first block of column separately 03524 * 03525 JB = DESCA( INB_ ) - JA + 1 03526 IF( JB.LE.0 ) 03527 $ JB = ( ( -JB ) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB 03528 JB = MIN( JB, N ) 03529 JN = JA + JB - 1 03530 * 03531 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 03532 * 03533 DO 40 H = 0, JB-1 03534 IB = DESCA( IMB_ ) - IA + 1 03535 IF( IB.LE.0 ) 03536 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB 03537 IB = MIN( IB, M ) 03538 IN = IA + IB - 1 03539 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 03540 DO 10 K = 0, IB-1 03541 CALL PCERRSET( ERR, ERRMAX, A( IA+K+(JA+H-1)*LDA ), 03542 $ PA( II+K+(JJ+H-1)*LDPA ) ) 03543 10 CONTINUE 03544 II = II + IB 03545 END IF 03546 ICURROW = MOD( ICURROW+1, NPROW ) 03547 * 03548 * Loop over remaining block of rows 03549 * 03550 DO 30 I = IN+1, IA+M-1, DESCA( MB_ ) 03551 IB = MIN( DESCA( MB_ ), IA+M-I ) 03552 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 03553 DO 20 K = 0, IB-1 03554 CALL PCERRSET( ERR, ERRMAX, A( I+K+(JA+H-1)*LDA ), 03555 $ PA( II+K+(JJ+H-1)*LDPA ) ) 03556 20 CONTINUE 03557 II = II + IB 03558 END IF 03559 ICURROW = MOD( ICURROW+1, NPROW ) 03560 30 CONTINUE 03561 * 03562 II = IIA 03563 ICURROW = IAROW 03564 40 CONTINUE 03565 * 03566 JJ = JJ + JB 03567 * 03568 END IF 03569 * 03570 ICURCOL = MOD( ICURCOL+1, NPCOL ) 03571 * 03572 * Loop over remaining column blocks 03573 * 03574 DO 90 J = JN+1, JA+N-1, DESCA( NB_ ) 03575 JB = MIN( DESCA( NB_ ), JA+N-J ) 03576 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 03577 DO 80 H = 0, JB-1 03578 IB = DESCA( IMB_ ) - IA + 1 03579 IF( IB.LE.0 ) 03580 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 )*DESCA( MB_ ) + IB 03581 IB = MIN( IB, M ) 03582 IN = IA + IB - 1 03583 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 03584 DO 50 K = 0, IB-1 03585 CALL PCERRSET( ERR, ERRMAX, A( IA+K+(J+H-1)*LDA ), 03586 $ PA( II+K+(JJ+H-1)*LDPA ) ) 03587 50 CONTINUE 03588 II = II + IB 03589 END IF 03590 ICURROW = MOD( ICURROW+1, NPROW ) 03591 * 03592 * Loop over remaining block of rows 03593 * 03594 DO 70 I = IN+1, IA+M-1, DESCA( MB_ ) 03595 IB = MIN( DESCA( MB_ ), IA+M-I ) 03596 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 03597 DO 60 K = 0, IB-1 03598 CALL PCERRSET( ERR, ERRMAX, 03599 $ A( I+K+(J+H-1)*LDA ), 03600 $ PA( II+K+(JJ+H-1)*LDPA ) ) 03601 60 CONTINUE 03602 II = II + IB 03603 END IF 03604 ICURROW = MOD( ICURROW+1, NPROW ) 03605 70 CONTINUE 03606 * 03607 II = IIA 03608 ICURROW = IAROW 03609 80 CONTINUE 03610 * 03611 JJ = JJ + JB 03612 END IF 03613 * 03614 ICURCOL = MOD( ICURCOL+1, NPCOL ) 03615 * 03616 90 CONTINUE 03617 * 03618 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1, 03619 $ -1, -1 ) 03620 * 03621 IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN 03622 INFO = 1 03623 ELSE IF( ERRMAX.GT.EPS ) THEN 03624 INFO = -1 03625 END IF 03626 * 03627 RETURN 03628 * 03629 * End of PCCHKMIN 03630 * 03631 END 03632 SUBROUTINE PCCHKMOUT( M, N, A, PA, IA, JA, DESCA, INFO ) 03633 * 03634 * -- PBLAS test routine (version 2.0) -- 03635 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03636 * and University of California, Berkeley. 03637 * April 1, 1998 03638 * 03639 * .. Scalar Arguments .. 03640 INTEGER IA, INFO, JA, M, N 03641 * .. 03642 * .. Array Arguments .. 03643 INTEGER DESCA( * ) 03644 COMPLEX A( * ), PA( * ) 03645 * .. 03646 * 03647 * Purpose 03648 * ======= 03649 * 03650 * PCCHKMOUT checks that the matrix PA \ sub( PA ) remained unchanged. 03651 * The local array entries are compared element by element, and their 03652 * difference is tested against 0.0 as well as the epsilon machine. No- 03653 * tice that this difference should be numerically exactly the zero ma- 03654 * chine, but because of the possible movement of some of the data we 03655 * flagged differently a difference less than twice the epsilon machine. 03656 * The largest error is reported. 03657 * 03658 * Notes 03659 * ===== 03660 * 03661 * A description vector is associated with each 2D block-cyclicly dis- 03662 * tributed matrix. This vector stores the information required to 03663 * establish the mapping between a matrix entry and its corresponding 03664 * process and memory location. 03665 * 03666 * In the following comments, the character _ should be read as 03667 * "of the distributed matrix". Let A be a generic term for any 2D 03668 * block cyclicly distributed matrix. Its description vector is DESCA: 03669 * 03670 * NOTATION STORED IN EXPLANATION 03671 * ---------------- --------------- ------------------------------------ 03672 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 03673 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 03674 * the NPROW x NPCOL BLACS process grid 03675 * A is distributed over. The context 03676 * itself is global, but the handle 03677 * (the integer value) may vary. 03678 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 03679 * ted matrix A, M_A >= 0. 03680 * N_A (global) DESCA( N_ ) The number of columns in the distri- 03681 * buted matrix A, N_A >= 0. 03682 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 03683 * block of the matrix A, IMB_A > 0. 03684 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 03685 * left block of the matrix A, 03686 * INB_A > 0. 03687 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 03688 * bute the last M_A-IMB_A rows of A, 03689 * MB_A > 0. 03690 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 03691 * bute the last N_A-INB_A columns of 03692 * A, NB_A > 0. 03693 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 03694 * row of the matrix A is distributed, 03695 * NPROW > RSRC_A >= 0. 03696 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 03697 * first column of A is distributed. 03698 * NPCOL > CSRC_A >= 0. 03699 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 03700 * array storing the local blocks of 03701 * the distributed matrix A, 03702 * IF( Lc( 1, N_A ) > 0 ) 03703 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 03704 * ELSE 03705 * LLD_A >= 1. 03706 * 03707 * Let K be the number of rows of a matrix A starting at the global in- 03708 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 03709 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 03710 * receive if these K rows were distributed over NPROW processes. If K 03711 * is the number of columns of a matrix A starting at the global index 03712 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 03713 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 03714 * these K columns were distributed over NPCOL processes. 03715 * 03716 * The values of Lr() and Lc() may be determined via a call to the func- 03717 * tion PB_NUMROC: 03718 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 03719 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 03720 * 03721 * Arguments 03722 * ========= 03723 * 03724 * M (global input) INTEGER 03725 * On entry, M specifies the number of rows of the submatrix 03726 * sub( PA ). M must be at least zero. 03727 * 03728 * N (global input) INTEGER 03729 * On entry, N specifies the number of columns of the submatrix 03730 * sub( PA ). N must be at least zero. 03731 * 03732 * A (local input) COMPLEX array 03733 * On entry, A is an array of dimension (DESCA( M_ ),*). This 03734 * array contains a local copy of the initial entire matrix PA. 03735 * 03736 * PA (local input) COMPLEX array 03737 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This 03738 * array contains the local entries of the matrix PA. 03739 * 03740 * IA (global input) INTEGER 03741 * On entry, IA specifies A's global row index, which points to 03742 * the beginning of the submatrix sub( A ). 03743 * 03744 * JA (global input) INTEGER 03745 * On entry, JA specifies A's global column index, which points 03746 * to the beginning of the submatrix sub( A ). 03747 * 03748 * DESCA (global and local input) INTEGER array 03749 * On entry, DESCA is an integer array of dimension DLEN_. This 03750 * is the array descriptor for the matrix A. 03751 * 03752 * INFO (global output) INTEGER 03753 * On exit, if INFO = 0, no error has been found, 03754 * If INFO > 0, the maximum abolute error found is in (0,eps], 03755 * If INFO < 0, the maximum abolute error found is in (eps,+oo). 03756 * 03757 * -- Written on April 1, 1998 by 03758 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03759 * 03760 * ===================================================================== 03761 * 03762 * .. Parameters .. 03763 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 03764 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 03765 $ RSRC_ 03766 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 03767 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 03768 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 03769 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 03770 REAL ZERO 03771 PARAMETER ( ZERO = 0.0E+0 ) 03772 * .. 03773 * .. Local Scalars .. 03774 LOGICAL COLREP, ROWREP 03775 INTEGER I, IB, ICTXT, ICURCOL, II, IMBA, J, JB, JJ, KK, 03776 $ LDA, LDPA, LL, MPALL, MYCOL, MYROW, MYROWDIST, 03777 $ NPCOL, NPROW 03778 REAL EPS, ERR, ERRMAX 03779 * .. 03780 * .. External Subroutines .. 03781 EXTERNAL BLACS_GRIDINFO, PCERRSET, SGAMX2D 03782 * .. 03783 * .. External Functions .. 03784 INTEGER PB_NUMROC 03785 REAL PSLAMCH 03786 EXTERNAL PSLAMCH, PB_NUMROC 03787 * .. 03788 * .. Intrinsic Functions .. 03789 INTRINSIC MAX, MIN, MOD 03790 * .. 03791 * .. Executable Statements .. 03792 * 03793 INFO = 0 03794 ERRMAX = ZERO 03795 * 03796 * Quick return if possible 03797 * 03798 IF( ( DESCA( M_ ).LE.0 ).OR.( DESCA( N_ ).LE.0 ) ) 03799 $ RETURN 03800 * 03801 * Start the operations 03802 * 03803 ICTXT = DESCA( CTXT_ ) 03804 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 03805 * 03806 EPS = PSLAMCH( ICTXT, 'eps' ) 03807 * 03808 MPALL = PB_NUMROC( DESCA( M_ ), 1, DESCA( IMB_ ), DESCA( MB_ ), 03809 $ MYROW, DESCA( RSRC_ ), NPROW ) 03810 * 03811 LDA = DESCA( M_ ) 03812 LDPA = DESCA( LLD_ ) 03813 * 03814 II = 1 03815 JJ = 1 03816 ROWREP = ( DESCA( RSRC_ ).EQ.-1 ) 03817 COLREP = ( DESCA( CSRC_ ).EQ.-1 ) 03818 ICURCOL = DESCA( CSRC_ ) 03819 IF( MYROW.EQ.DESCA( RSRC_ ) .OR. ROWREP ) THEN 03820 IMBA = DESCA( IMB_ ) 03821 ELSE 03822 IMBA = DESCA( MB_ ) 03823 END IF 03824 IF( ROWREP ) THEN 03825 MYROWDIST = 0 03826 ELSE 03827 MYROWDIST = MOD( MYROW - DESCA( RSRC_ ) + NPROW, NPROW ) 03828 END IF 03829 * 03830 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 03831 * 03832 J = 1 03833 IF( MYROWDIST.EQ.0 ) THEN 03834 I = 1 03835 ELSE 03836 I = DESCA( IMB_ ) + ( MYROWDIST - 1 ) * DESCA( MB_ ) + 1 03837 END IF 03838 IB = MIN( MAX( 0, DESCA( M_ ) - I + 1 ), IMBA ) 03839 JB = MIN( DESCA( N_ ), DESCA( INB_ ) ) 03840 * 03841 DO 20 KK = 0, JB-1 03842 DO 10 LL = 0, IB-1 03843 IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR. 03844 $ J+KK.LT.JA .OR. J+KK.GT.JA+N-1 ) 03845 $ CALL PCERRSET( ERR, ERRMAX, A( I+LL+(J+KK-1)*LDA ), 03846 $ PA( II+LL+(JJ+KK-1)*LDPA ) ) 03847 10 CONTINUE 03848 20 CONTINUE 03849 IF( ROWREP ) THEN 03850 I = I + IMBA 03851 ELSE 03852 I = I + IMBA + ( NPROW - 1 ) * DESCA( MB_ ) 03853 END IF 03854 * 03855 DO 50 II = IMBA + 1, MPALL, DESCA( MB_ ) 03856 IB = MIN( MPALL-II+1, DESCA( MB_ ) ) 03857 * 03858 DO 40 KK = 0, JB-1 03859 DO 30 LL = 0, IB-1 03860 IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR. 03861 $ J+KK.LT.JA .OR. J+KK.GT.JA+N-1 ) 03862 $ CALL PCERRSET( ERR, ERRMAX, 03863 $ A( I+LL+(J+KK-1)*LDA ), 03864 $ PA( II+LL+(JJ+KK-1)*LDPA ) ) 03865 30 CONTINUE 03866 40 CONTINUE 03867 * 03868 IF( ROWREP ) THEN 03869 I = I + DESCA( MB_ ) 03870 ELSE 03871 I = I + NPROW * DESCA( MB_ ) 03872 END IF 03873 * 03874 50 CONTINUE 03875 * 03876 JJ = JJ + JB 03877 * 03878 END IF 03879 * 03880 ICURCOL = MOD( ICURCOL + 1, NPCOL ) 03881 * 03882 DO 110 J = DESCA( INB_ ) + 1, DESCA( N_ ), DESCA( NB_ ) 03883 JB = MIN( DESCA( N_ ) - J + 1, DESCA( NB_ ) ) 03884 * 03885 IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN 03886 * 03887 IF( MYROWDIST.EQ.0 ) THEN 03888 I = 1 03889 ELSE 03890 I = DESCA( IMB_ ) + ( MYROWDIST - 1 ) * DESCA( MB_ ) + 1 03891 END IF 03892 * 03893 II = 1 03894 IB = MIN( MAX( 0, DESCA( M_ ) - I + 1 ), IMBA ) 03895 DO 70 KK = 0, JB-1 03896 DO 60 LL = 0, IB-1 03897 IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR. 03898 $ J+KK.LT.JA .OR. J+KK.GT.JA+N-1 ) 03899 $ CALL PCERRSET( ERR, ERRMAX, 03900 $ A( I+LL+(J+KK-1)*LDA ), 03901 $ PA( II+LL+(JJ+KK-1)*LDPA ) ) 03902 60 CONTINUE 03903 70 CONTINUE 03904 IF( ROWREP ) THEN 03905 I = I + IMBA 03906 ELSE 03907 I = I + IMBA + ( NPROW - 1 ) * DESCA( MB_ ) 03908 END IF 03909 * 03910 DO 100 II = IMBA+1, MPALL, DESCA( MB_ ) 03911 IB = MIN( MPALL-II+1, DESCA( MB_ ) ) 03912 * 03913 DO 90 KK = 0, JB-1 03914 DO 80 LL = 0, IB-1 03915 IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR. 03916 $ J+KK.LT.JA .OR. J+KK.GT.JA+N-1 ) 03917 $ CALL PCERRSET( ERR, ERRMAX, 03918 $ A( I+LL+(J+KK-1)*LDA ), 03919 $ PA( II+LL+(JJ+KK-1)*LDPA ) ) 03920 80 CONTINUE 03921 90 CONTINUE 03922 * 03923 IF( ROWREP ) THEN 03924 I = I + DESCA( MB_ ) 03925 ELSE 03926 I = I + NPROW * DESCA( MB_ ) 03927 END IF 03928 * 03929 100 CONTINUE 03930 * 03931 JJ = JJ + JB 03932 * 03933 END IF 03934 * 03935 ICURCOL = MOD( ICURCOL + 1, NPCOL ) 03936 * INSERT MODE 03937 110 CONTINUE 03938 * 03939 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1, 03940 $ -1, -1 ) 03941 * 03942 IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN 03943 INFO = 1 03944 ELSE IF( ERRMAX.GT.EPS ) THEN 03945 INFO = -1 03946 END IF 03947 * 03948 RETURN 03949 * 03950 * End of PCCHKMOUT 03951 * 03952 END 03953 SUBROUTINE PCMPRNT( ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT, 03954 $ CMATNM ) 03955 * 03956 * -- PBLAS test routine (version 2.0) -- 03957 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03958 * and University of California, Berkeley. 03959 * April 1, 1998 03960 * 03961 * .. Scalar Arguments .. 03962 INTEGER ICPRNT, ICTXT, IRPRNT, LDA, M, N, NOUT 03963 * .. 03964 * .. Array Arguments .. 03965 CHARACTER*(*) CMATNM 03966 COMPLEX A( LDA, * ) 03967 * .. 03968 * 03969 * Purpose 03970 * ======= 03971 * 03972 * PCMPRNT prints to the standard output an array A of size m by n. Only 03973 * the process of coordinates ( IRPRNT, ICPRNT ) is printing. 03974 * 03975 * Arguments 03976 * ========= 03977 * 03978 * ICTXT (local input) INTEGER 03979 * On entry, ICTXT specifies the BLACS context handle, indica- 03980 * ting the global context of the operation. The context itself 03981 * is global, but the value of ICTXT is local. 03982 * 03983 * NOUT (global input) INTEGER 03984 * On entry, NOUT specifies the unit number for the output file. 03985 * When NOUT is 6, output to screen, when NOUT is 0, output to 03986 * stderr. NOUT is only defined for process 0. 03987 * 03988 * M (global input) INTEGER 03989 * On entry, M specifies the number of rows of the matrix A. M 03990 * must be at least zero. 03991 * 03992 * N (global input) INTEGER 03993 * On entry, N specifies the number of columns of the matrix A. 03994 * N must be at least zero. 03995 * 03996 * A (local input) COMPLEX array 03997 * On entry, A is an array of dimension (LDA,N). The leading m 03998 * by n part of this array is printed. 03999 * 04000 * LDA (local input) INTEGER 04001 * On entry, LDA specifies the leading dimension of the local 04002 * array A to be printed. LDA must be at least MAX( 1, M ). 04003 * 04004 * IRPRNT (global input) INTEGER 04005 * On entry, IRPRNT specifies the process row coordinate of the 04006 * printing process. 04007 * 04008 * ICPRNT (global input) INTEGER 04009 * On entry, ICPRNT specifies the process column coordinate of 04010 * the printing process. 04011 * 04012 * CMATNM (global input) CHARACTER*(*) 04013 * On entry, CMATNM specifies the identifier of the matrix to be 04014 * printed. 04015 * 04016 * -- Written on April 1, 1998 by 04017 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04018 * 04019 * ===================================================================== 04020 * 04021 * .. Local Scalars .. 04022 INTEGER I, J, MYCOL, MYROW, NPCOL, NPROW 04023 * .. 04024 * .. External Subroutines .. 04025 EXTERNAL BLACS_GRIDINFO 04026 * .. 04027 * .. Intrinsic Functions .. 04028 INTRINSIC AIMAG, REAL 04029 * .. 04030 * .. Executable Statements .. 04031 * 04032 * Quick return if possible 04033 * 04034 IF( ( M.LE.0 ).OR.( N.LE.0 ) ) 04035 $ RETURN 04036 * 04037 * Get grid parameters 04038 * 04039 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 04040 * 04041 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 04042 * 04043 WRITE( NOUT, FMT = * ) 04044 DO 20 J = 1, N 04045 * 04046 DO 10 I = 1, M 04047 * 04048 WRITE( NOUT, FMT = 9999 ) CMATNM, I, J, 04049 $ REAL( A( I, J ) ), AIMAG( A( I, J ) ) 04050 * 04051 10 CONTINUE 04052 * 04053 20 CONTINUE 04054 * 04055 END IF 04056 * 04057 9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', E16.8, '+i*(', 04058 $ E16.8, ')' ) 04059 * 04060 RETURN 04061 * 04062 * End of PCMPRNT 04063 * 04064 END 04065 SUBROUTINE PCVPRNT( ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT, 04066 $ CVECNM ) 04067 * 04068 * -- PBLAS test routine (version 2.0) -- 04069 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04070 * and University of California, Berkeley. 04071 * April 1, 1998 04072 * 04073 * .. Scalar Arguments .. 04074 INTEGER ICPRNT, ICTXT, INCX, IRPRNT, N, NOUT 04075 * .. 04076 * .. Array Arguments .. 04077 CHARACTER*(*) CVECNM 04078 COMPLEX X( * ) 04079 * .. 04080 * 04081 * Purpose 04082 * ======= 04083 * 04084 * PCVPRNT prints to the standard output an vector x of length n. Only 04085 * the process of coordinates ( IRPRNT, ICPRNT ) is printing. 04086 * 04087 * Arguments 04088 * ========= 04089 * 04090 * ICTXT (local input) INTEGER 04091 * On entry, ICTXT specifies the BLACS context handle, indica- 04092 * ting the global context of the operation. The context itself 04093 * is global, but the value of ICTXT is local. 04094 * 04095 * NOUT (global input) INTEGER 04096 * On entry, NOUT specifies the unit number for the output file. 04097 * When NOUT is 6, output to screen, when NOUT is 0, output to 04098 * stderr. NOUT is only defined for process 0. 04099 * 04100 * N (global input) INTEGER 04101 * On entry, N specifies the length of the vector X. N must be 04102 * at least zero. 04103 * 04104 * X (global input) COMPLEX array 04105 * On entry, X is an array of dimension at least 04106 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen- 04107 * ted array X must contain the vector x. 04108 * 04109 * INCX (global input) INTEGER. 04110 * On entry, INCX specifies the increment for the elements of X. 04111 * INCX must not be zero. 04112 * 04113 * IRPRNT (global input) INTEGER 04114 * On entry, IRPRNT specifies the process row coordinate of the 04115 * printing process. 04116 * 04117 * ICPRNT (global input) INTEGER 04118 * On entry, ICPRNT specifies the process column coordinate of 04119 * the printing process. 04120 * 04121 * CVECNM (global input) CHARACTER*(*) 04122 * On entry, CVECNM specifies the identifier of the vector to be 04123 * printed. 04124 * 04125 * -- Written on April 1, 1998 by 04126 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04127 * 04128 * ===================================================================== 04129 * 04130 * .. Local Scalars .. 04131 INTEGER I, MYCOL, MYROW, NPCOL, NPROW 04132 * .. 04133 * .. External Subroutines .. 04134 EXTERNAL BLACS_GRIDINFO 04135 * .. 04136 * .. Intrinsic Functions .. 04137 INTRINSIC AIMAG, REAL 04138 * .. 04139 * .. Executable Statements .. 04140 * 04141 * Quick return if possible 04142 * 04143 IF( N.LE.0 ) 04144 $ RETURN 04145 * 04146 * Get grid parameters 04147 * 04148 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 04149 * 04150 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 04151 * 04152 WRITE( NOUT, FMT = * ) 04153 DO 10 I = 1, 1 + ( N-1 )*INCX, INCX 04154 * 04155 WRITE( NOUT, FMT = 9999 ) CVECNM, I, REAL( X( I ) ), 04156 $ AIMAG( X( I ) ) 04157 * 04158 10 CONTINUE 04159 * 04160 END IF 04161 * 04162 9999 FORMAT( 1X, A, '(', I6, ')=', E16.8, '+i*(', E16.8, ')' ) 04163 * 04164 RETURN 04165 * 04166 * End of PCVPRNT 04167 * 04168 END 04169 SUBROUTINE PCMVCH( ICTXT, TRANS, M, N, ALPHA, A, IA, JA, DESCA, 04170 $ X, IX, JX, DESCX, INCX, BETA, Y, PY, IY, JY, 04171 $ DESCY, INCY, G, ERR, INFO ) 04172 * 04173 * -- PBLAS test routine (version 2.0) -- 04174 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04175 * and University of California, Berkeley. 04176 * April 1, 1998 04177 * 04178 * .. Scalar Arguments .. 04179 CHARACTER*1 TRANS 04180 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX, 04181 $ JY, M, N 04182 REAL ERR 04183 COMPLEX ALPHA, BETA 04184 * .. 04185 * .. Array Arguments .. 04186 INTEGER DESCA( * ), DESCX( * ), DESCY( * ) 04187 REAL G( * ) 04188 COMPLEX A( * ), PY( * ), X( * ), Y( * ) 04189 * .. 04190 * 04191 * Purpose 04192 * ======= 04193 * 04194 * PCMVCH checks the results of the computational tests. 04195 * 04196 * Notes 04197 * ===== 04198 * 04199 * A description vector is associated with each 2D block-cyclicly dis- 04200 * tributed matrix. This vector stores the information required to 04201 * establish the mapping between a matrix entry and its corresponding 04202 * process and memory location. 04203 * 04204 * In the following comments, the character _ should be read as 04205 * "of the distributed matrix". Let A be a generic term for any 2D 04206 * block cyclicly distributed matrix. Its description vector is DESCA: 04207 * 04208 * NOTATION STORED IN EXPLANATION 04209 * ---------------- --------------- ------------------------------------ 04210 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 04211 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 04212 * the NPROW x NPCOL BLACS process grid 04213 * A is distributed over. The context 04214 * itself is global, but the handle 04215 * (the integer value) may vary. 04216 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 04217 * ted matrix A, M_A >= 0. 04218 * N_A (global) DESCA( N_ ) The number of columns in the distri- 04219 * buted matrix A, N_A >= 0. 04220 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 04221 * block of the matrix A, IMB_A > 0. 04222 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 04223 * left block of the matrix A, 04224 * INB_A > 0. 04225 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 04226 * bute the last M_A-IMB_A rows of A, 04227 * MB_A > 0. 04228 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 04229 * bute the last N_A-INB_A columns of 04230 * A, NB_A > 0. 04231 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 04232 * row of the matrix A is distributed, 04233 * NPROW > RSRC_A >= 0. 04234 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 04235 * first column of A is distributed. 04236 * NPCOL > CSRC_A >= 0. 04237 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 04238 * array storing the local blocks of 04239 * the distributed matrix A, 04240 * IF( Lc( 1, N_A ) > 0 ) 04241 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 04242 * ELSE 04243 * LLD_A >= 1. 04244 * 04245 * Let K be the number of rows of a matrix A starting at the global in- 04246 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 04247 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 04248 * receive if these K rows were distributed over NPROW processes. If K 04249 * is the number of columns of a matrix A starting at the global index 04250 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 04251 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 04252 * these K columns were distributed over NPCOL processes. 04253 * 04254 * The values of Lr() and Lc() may be determined via a call to the func- 04255 * tion PB_NUMROC: 04256 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 04257 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 04258 * 04259 * Arguments 04260 * ========= 04261 * 04262 * ICTXT (local input) INTEGER 04263 * On entry, ICTXT specifies the BLACS context handle, indica- 04264 * ting the global context of the operation. The context itself 04265 * is global, but the value of ICTXT is local. 04266 * 04267 * TRANS (global input) CHARACTER*1 04268 * On entry, TRANS specifies which matrix-vector product is to 04269 * be computed as follows: 04270 * If TRANS = 'T', 04271 * sub( Y ) = BETA * sub( Y ) + sub( A )**T * sub( X ), 04272 * else if TRANS = 'C', 04273 * sub( Y ) = BETA * sub( Y ) + sub( A )**H * sub( X ), 04274 * otherwise 04275 * sub( Y ) = BETA * sub( Y ) + sub( A ) * sub( X ). 04276 * 04277 * M (global input) INTEGER 04278 * On entry, M specifies the number of rows of the submatrix 04279 * operand matrix A. M must be at least zero. 04280 * 04281 * N (global input) INTEGER 04282 * On entry, N specifies the number of columns of the subma- 04283 * trix operand matrix A. N must be at least zero. 04284 * 04285 * ALPHA (global input) COMPLEX 04286 * On entry, ALPHA specifies the scalar alpha. 04287 * 04288 * A (local input) COMPLEX array 04289 * On entry, A is an array of dimension (DESCA( M_ ),*). This 04290 * array contains a local copy of the initial entire matrix PA. 04291 * 04292 * IA (global input) INTEGER 04293 * On entry, IA specifies A's global row index, which points to 04294 * the beginning of the submatrix sub( A ). 04295 * 04296 * JA (global input) INTEGER 04297 * On entry, JA specifies A's global column index, which points 04298 * to the beginning of the submatrix sub( A ). 04299 * 04300 * DESCA (global and local input) INTEGER array 04301 * On entry, DESCA is an integer array of dimension DLEN_. This 04302 * is the array descriptor for the matrix A. 04303 * 04304 * X (local input) COMPLEX array 04305 * On entry, X is an array of dimension (DESCX( M_ ),*). This 04306 * array contains a local copy of the initial entire matrix PX. 04307 * 04308 * IX (global input) INTEGER 04309 * On entry, IX specifies X's global row index, which points to 04310 * the beginning of the submatrix sub( X ). 04311 * 04312 * JX (global input) INTEGER 04313 * On entry, JX specifies X's global column index, which points 04314 * to the beginning of the submatrix sub( X ). 04315 * 04316 * DESCX (global and local input) INTEGER array 04317 * On entry, DESCX is an integer array of dimension DLEN_. This 04318 * is the array descriptor for the matrix X. 04319 * 04320 * INCX (global input) INTEGER 04321 * On entry, INCX specifies the global increment for the 04322 * elements of X. Only two values of INCX are supported in 04323 * this version, namely 1 and M_X. INCX must not be zero. 04324 * 04325 * BETA (global input) COMPLEX 04326 * On entry, BETA specifies the scalar beta. 04327 * 04328 * Y (local input/local output) COMPLEX array 04329 * On entry, Y is an array of dimension (DESCY( M_ ),*). This 04330 * array contains a local copy of the initial entire matrix PY. 04331 * 04332 * PY (local input) COMPLEX array 04333 * On entry, PY is an array of dimension (DESCY( LLD_ ),*). This 04334 * array contains the local entries of the matrix PY. 04335 * 04336 * IY (global input) INTEGER 04337 * On entry, IY specifies Y's global row index, which points to 04338 * the beginning of the submatrix sub( Y ). 04339 * 04340 * JY (global input) INTEGER 04341 * On entry, JY specifies Y's global column index, which points 04342 * to the beginning of the submatrix sub( Y ). 04343 * 04344 * DESCY (global and local input) INTEGER array 04345 * On entry, DESCY is an integer array of dimension DLEN_. This 04346 * is the array descriptor for the matrix Y. 04347 * 04348 * INCY (global input) INTEGER 04349 * On entry, INCY specifies the global increment for the 04350 * elements of Y. Only two values of INCY are supported in 04351 * this version, namely 1 and M_Y. INCY must not be zero. 04352 * 04353 * G (workspace) REAL array 04354 * On entry, G is an array of dimension at least MAX( M, N ). G 04355 * is used to compute the gauges. 04356 * 04357 * ERR (global output) REAL 04358 * On exit, ERR specifies the largest error in absolute value. 04359 * 04360 * INFO (global output) INTEGER 04361 * On exit, if INFO <> 0, the result is less than half accurate. 04362 * 04363 * -- Written on April 1, 1998 by 04364 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04365 * 04366 * ===================================================================== 04367 * 04368 * .. Parameters .. 04369 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 04370 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 04371 $ RSRC_ 04372 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 04373 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 04374 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 04375 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 04376 REAL RZERO, RONE 04377 PARAMETER ( RZERO = 0.0E+0, RONE = 1.0E+0 ) 04378 COMPLEX ZERO, ONE 04379 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), 04380 $ ONE = ( 1.0E+0, 0.0E+0 ) ) 04381 * .. 04382 * .. Local Scalars .. 04383 LOGICAL COLREP, CTRAN, ROWREP, TRAN 04384 INTEGER I, IB, ICURCOL, ICURROW, IIY, IN, IOFFA, IOFFX, 04385 $ IOFFY, IYCOL, IYROW, J, JB, JJY, JN, KK, LDA, 04386 $ LDPY, LDX, LDY, ML, MYCOL, MYROW, NL, NPCOL, 04387 $ NPROW 04388 REAL EPS, ERRI, GTMP 04389 COMPLEX C, TBETA, YTMP 04390 * .. 04391 * .. External Subroutines .. 04392 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D 04393 * .. 04394 * .. External Functions .. 04395 LOGICAL LSAME 04396 REAL PSLAMCH 04397 EXTERNAL LSAME, PSLAMCH 04398 * .. 04399 * .. Intrinsic Functions .. 04400 INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT 04401 * .. 04402 * .. Statement Functions .. 04403 REAL ABS1 04404 ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) 04405 * .. 04406 * .. Executable Statements .. 04407 * 04408 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 04409 * 04410 EPS = PSLAMCH( ICTXT, 'eps' ) 04411 * 04412 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 04413 TBETA = ONE 04414 ELSE 04415 TBETA = BETA 04416 END IF 04417 * 04418 TRAN = LSAME( TRANS, 'T' ) 04419 CTRAN = LSAME( TRANS, 'C' ) 04420 IF( TRAN.OR.CTRAN ) THEN 04421 ML = N 04422 NL = M 04423 ELSE 04424 ML = M 04425 NL = N 04426 END IF 04427 * 04428 LDA = MAX( 1, DESCA( M_ ) ) 04429 LDX = MAX( 1, DESCX( M_ ) ) 04430 LDY = MAX( 1, DESCY( M_ ) ) 04431 * 04432 * Compute expected result in Y using data in A, X and Y. 04433 * Compute gauges in G. This part of the computation is performed 04434 * by every process in the grid. 04435 * 04436 IOFFY = IY + ( JY - 1 ) * LDY 04437 DO 40 I = 1, ML 04438 YTMP = ZERO 04439 GTMP = RZERO 04440 IOFFX = IX + ( JX - 1 ) * LDX 04441 IF( TRAN )THEN 04442 IOFFA = IA + ( JA + I - 2 ) * LDA 04443 DO 10 J = 1, NL 04444 YTMP = YTMP + A( IOFFA ) * X( IOFFX ) 04445 GTMP = GTMP + ABS1( A( IOFFA ) ) * ABS1( X( IOFFX ) ) 04446 IOFFA = IOFFA + 1 04447 IOFFX = IOFFX + INCX 04448 10 CONTINUE 04449 ELSE IF( CTRAN )THEN 04450 IOFFA = IA + ( JA + I - 2 ) * LDA 04451 DO 20 J = 1, NL 04452 YTMP = YTMP + CONJG( A( IOFFA ) ) * X( IOFFX ) 04453 GTMP = GTMP + ABS1( A( IOFFA ) ) * ABS1( X( IOFFX ) ) 04454 IOFFA = IOFFA + 1 04455 IOFFX = IOFFX + INCX 04456 20 CONTINUE 04457 ELSE 04458 IOFFA = IA + I - 1 + ( JA - 1 ) * LDA 04459 DO 30 J = 1, NL 04460 YTMP = YTMP + A( IOFFA ) * X( IOFFX ) 04461 GTMP = GTMP + ABS1( A( IOFFA ) ) * ABS1( X( IOFFX ) ) 04462 IOFFA = IOFFA + LDA 04463 IOFFX = IOFFX + INCX 04464 30 CONTINUE 04465 END IF 04466 G( I ) = ABS1( ALPHA )*GTMP + ABS1( TBETA )*ABS1( Y( IOFFY ) ) 04467 Y( IOFFY ) = ALPHA * YTMP + TBETA * Y( IOFFY ) 04468 IOFFY = IOFFY + INCY 04469 40 CONTINUE 04470 * 04471 * Compute the error ratio for this result. 04472 * 04473 ERR = RZERO 04474 INFO = 0 04475 LDPY = DESCY( LLD_ ) 04476 IOFFY = IY + ( JY - 1 ) * LDY 04477 CALL PB_INFOG2L( IY, JY, DESCY, NPROW, NPCOL, MYROW, MYCOL, IIY, 04478 $ JJY, IYROW, IYCOL ) 04479 ICURROW = IYROW 04480 ICURCOL = IYCOL 04481 ROWREP = ( IYROW.EQ.-1 ) 04482 COLREP = ( IYCOL.EQ.-1 ) 04483 * 04484 IF( INCY.EQ.DESCY( M_ ) ) THEN 04485 * 04486 * sub( Y ) is a row vector 04487 * 04488 JB = DESCY( INB_ ) - JY + 1 04489 IF( JB.LE.0 ) 04490 $ JB = ( ( -JB ) / DESCY( NB_ ) + 1 ) * DESCY( NB_ ) + JB 04491 JB = MIN( JB, ML ) 04492 JN = JY + JB - 1 04493 * 04494 DO 50 J = JY, JN 04495 * 04496 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 04497 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 04498 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS 04499 IF( G( J-JY+1 ).NE.RZERO ) 04500 $ ERRI = ERRI / G( J-JY+1 ) 04501 ERR = MAX( ERR, ERRI ) 04502 IF( ERR*SQRT( EPS ).GE.RONE ) 04503 $ INFO = 1 04504 JJY = JJY + 1 04505 END IF 04506 * 04507 IOFFY = IOFFY + INCY 04508 * 04509 50 CONTINUE 04510 * 04511 ICURCOL = MOD( ICURCOL+1, NPCOL ) 04512 * 04513 DO 70 J = JN+1, JY+ML-1, DESCY( NB_ ) 04514 JB = MIN( JY+ML-J, DESCY( NB_ ) ) 04515 * 04516 DO 60 KK = 0, JB-1 04517 * 04518 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 04519 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 04520 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS 04521 IF( G( J+KK-JY+1 ).NE.RZERO ) 04522 $ ERRI = ERRI / G( J+KK-JY+1 ) 04523 ERR = MAX( ERR, ERRI ) 04524 IF( ERR*SQRT( EPS ).GE.RONE ) 04525 $ INFO = 1 04526 JJY = JJY + 1 04527 END IF 04528 * 04529 IOFFY = IOFFY + INCY 04530 * 04531 60 CONTINUE 04532 * 04533 ICURCOL = MOD( ICURCOL+1, NPCOL ) 04534 * 04535 70 CONTINUE 04536 * 04537 ELSE 04538 * 04539 * sub( Y ) is a column vector 04540 * 04541 IB = DESCY( IMB_ ) - IY + 1 04542 IF( IB.LE.0 ) 04543 $ IB = ( ( -IB ) / DESCY( MB_ ) + 1 ) * DESCY( MB_ ) + IB 04544 IB = MIN( IB, ML ) 04545 IN = IY + IB - 1 04546 * 04547 DO 80 I = IY, IN 04548 * 04549 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 04550 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 04551 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS 04552 IF( G( I-IY+1 ).NE.RZERO ) 04553 $ ERRI = ERRI / G( I-IY+1 ) 04554 ERR = MAX( ERR, ERRI ) 04555 IF( ERR*SQRT( EPS ).GE.RONE ) 04556 $ INFO = 1 04557 IIY = IIY + 1 04558 END IF 04559 * 04560 IOFFY = IOFFY + INCY 04561 * 04562 80 CONTINUE 04563 * 04564 ICURROW = MOD( ICURROW+1, NPROW ) 04565 * 04566 DO 100 I = IN+1, IY+ML-1, DESCY( MB_ ) 04567 IB = MIN( IY+ML-I, DESCY( MB_ ) ) 04568 * 04569 DO 90 KK = 0, IB-1 04570 * 04571 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 04572 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 04573 ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS 04574 IF( G( I+KK-IY+1 ).NE.RZERO ) 04575 $ ERRI = ERRI / G( I+KK-IY+1 ) 04576 ERR = MAX( ERR, ERRI ) 04577 IF( ERR*SQRT( EPS ).GE.RONE ) 04578 $ INFO = 1 04579 IIY = IIY + 1 04580 END IF 04581 * 04582 IOFFY = IOFFY + INCY 04583 * 04584 90 CONTINUE 04585 * 04586 ICURROW = MOD( ICURROW+1, NPROW ) 04587 * 04588 100 CONTINUE 04589 * 04590 END IF 04591 * 04592 * If INFO = 0, all results are at least half accurate. 04593 * 04594 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 04595 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 04596 $ MYCOL ) 04597 * 04598 RETURN 04599 * 04600 * End of PCMVCH 04601 * 04602 END 04603 SUBROUTINE PCVMCH( ICTXT, TRANS, UPLO, M, N, ALPHA, X, IX, JX, 04604 $ DESCX, INCX, Y, IY, JY, DESCY, INCY, A, PA, 04605 $ IA, JA, DESCA, G, ERR, INFO ) 04606 * 04607 * -- PBLAS test routine (version 2.0) -- 04608 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04609 * and University of California, Berkeley. 04610 * April 1, 1998 04611 * 04612 * .. Scalar Arguments .. 04613 CHARACTER*1 TRANS, UPLO 04614 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX, 04615 $ JY, M, N 04616 REAL ERR 04617 COMPLEX ALPHA 04618 * .. 04619 * .. Array Arguments .. 04620 INTEGER DESCA( * ), DESCX( * ), DESCY( * ) 04621 REAL G( * ) 04622 COMPLEX A( * ), PA( * ), X( * ), Y( * ) 04623 * .. 04624 * 04625 * Purpose 04626 * ======= 04627 * 04628 * PCVMCH checks the results of the computational tests. 04629 * 04630 * Notes 04631 * ===== 04632 * 04633 * A description vector is associated with each 2D block-cyclicly dis- 04634 * tributed matrix. This vector stores the information required to 04635 * establish the mapping between a matrix entry and its corresponding 04636 * process and memory location. 04637 * 04638 * In the following comments, the character _ should be read as 04639 * "of the distributed matrix". Let A be a generic term for any 2D 04640 * block cyclicly distributed matrix. Its description vector is DESCA: 04641 * 04642 * NOTATION STORED IN EXPLANATION 04643 * ---------------- --------------- ------------------------------------ 04644 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 04645 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 04646 * the NPROW x NPCOL BLACS process grid 04647 * A is distributed over. The context 04648 * itself is global, but the handle 04649 * (the integer value) may vary. 04650 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 04651 * ted matrix A, M_A >= 0. 04652 * N_A (global) DESCA( N_ ) The number of columns in the distri- 04653 * buted matrix A, N_A >= 0. 04654 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 04655 * block of the matrix A, IMB_A > 0. 04656 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 04657 * left block of the matrix A, 04658 * INB_A > 0. 04659 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 04660 * bute the last M_A-IMB_A rows of A, 04661 * MB_A > 0. 04662 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 04663 * bute the last N_A-INB_A columns of 04664 * A, NB_A > 0. 04665 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 04666 * row of the matrix A is distributed, 04667 * NPROW > RSRC_A >= 0. 04668 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 04669 * first column of A is distributed. 04670 * NPCOL > CSRC_A >= 0. 04671 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 04672 * array storing the local blocks of 04673 * the distributed matrix A, 04674 * IF( Lc( 1, N_A ) > 0 ) 04675 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 04676 * ELSE 04677 * LLD_A >= 1. 04678 * 04679 * Let K be the number of rows of a matrix A starting at the global in- 04680 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 04681 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 04682 * receive if these K rows were distributed over NPROW processes. If K 04683 * is the number of columns of a matrix A starting at the global index 04684 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 04685 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 04686 * these K columns were distributed over NPCOL processes. 04687 * 04688 * The values of Lr() and Lc() may be determined via a call to the func- 04689 * tion PB_NUMROC: 04690 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 04691 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 04692 * 04693 * Arguments 04694 * ========= 04695 * 04696 * ICTXT (local input) INTEGER 04697 * On entry, ICTXT specifies the BLACS context handle, indica- 04698 * ting the global context of the operation. The context itself 04699 * is global, but the value of ICTXT is local. 04700 * 04701 * TRANS (global input) CHARACTER*1 04702 * On entry, TRANS specifies the operation to be performed in 04703 * the complex cases: 04704 * if TRANS = 'C', 04705 * sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**H, 04706 * otherwise 04707 * sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**T. 04708 * 04709 * UPLO (global input) CHARACTER*1 04710 * On entry, UPLO specifies which part of the submatrix sub( A ) 04711 * is to be referenced as follows: 04712 * If UPLO = 'L', only the lower triangular part, 04713 * If UPLO = 'U', only the upper triangular part, 04714 * else the entire matrix is to be referenced. 04715 * 04716 * M (global input) INTEGER 04717 * On entry, M specifies the number of rows of the submatrix 04718 * operand matrix A. M must be at least zero. 04719 * 04720 * N (global input) INTEGER 04721 * On entry, N specifies the number of columns of the subma- 04722 * trix operand matrix A. N must be at least zero. 04723 * 04724 * ALPHA (global input) COMPLEX 04725 * On entry, ALPHA specifies the scalar alpha. 04726 * 04727 * X (local input) COMPLEX array 04728 * On entry, X is an array of dimension (DESCX( M_ ),*). This 04729 * array contains a local copy of the initial entire matrix PX. 04730 * 04731 * IX (global input) INTEGER 04732 * On entry, IX specifies X's global row index, which points to 04733 * the beginning of the submatrix sub( X ). 04734 * 04735 * JX (global input) INTEGER 04736 * On entry, JX specifies X's global column index, which points 04737 * to the beginning of the submatrix sub( X ). 04738 * 04739 * DESCX (global and local input) INTEGER array 04740 * On entry, DESCX is an integer array of dimension DLEN_. This 04741 * is the array descriptor for the matrix X. 04742 * 04743 * INCX (global input) INTEGER 04744 * On entry, INCX specifies the global increment for the 04745 * elements of X. Only two values of INCX are supported in 04746 * this version, namely 1 and M_X. INCX must not be zero. 04747 * 04748 * Y (local input) COMPLEX array 04749 * On entry, Y is an array of dimension (DESCY( M_ ),*). This 04750 * array contains a local copy of the initial entire matrix PY. 04751 * 04752 * IY (global input) INTEGER 04753 * On entry, IY specifies Y's global row index, which points to 04754 * the beginning of the submatrix sub( Y ). 04755 * 04756 * JY (global input) INTEGER 04757 * On entry, JY specifies Y's global column index, which points 04758 * to the beginning of the submatrix sub( Y ). 04759 * 04760 * DESCY (global and local input) INTEGER array 04761 * On entry, DESCY is an integer array of dimension DLEN_. This 04762 * is the array descriptor for the matrix Y. 04763 * 04764 * INCY (global input) INTEGER 04765 * On entry, INCY specifies the global increment for the 04766 * elements of Y. Only two values of INCY are supported in 04767 * this version, namely 1 and M_Y. INCY must not be zero. 04768 * 04769 * A (local input/local output) COMPLEX array 04770 * On entry, A is an array of dimension (DESCA( M_ ),*). This 04771 * array contains a local copy of the initial entire matrix PA. 04772 * 04773 * PA (local input) COMPLEX array 04774 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This 04775 * array contains the local entries of the matrix PA. 04776 * 04777 * IA (global input) INTEGER 04778 * On entry, IA specifies A's global row index, which points to 04779 * the beginning of the submatrix sub( A ). 04780 * 04781 * JA (global input) INTEGER 04782 * On entry, JA specifies A's global column index, which points 04783 * to the beginning of the submatrix sub( A ). 04784 * 04785 * DESCA (global and local input) INTEGER array 04786 * On entry, DESCA is an integer array of dimension DLEN_. This 04787 * is the array descriptor for the matrix A. 04788 * 04789 * G (workspace) REAL array 04790 * On entry, G is an array of dimension at least MAX( M, N ). G 04791 * is used to compute the gauges. 04792 * 04793 * ERR (global output) REAL 04794 * On exit, ERR specifies the largest error in absolute value. 04795 * 04796 * INFO (global output) INTEGER 04797 * On exit, if INFO <> 0, the result is less than half accurate. 04798 * 04799 * -- Written on April 1, 1998 by 04800 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04801 * 04802 * ===================================================================== 04803 * 04804 * .. Parameters .. 04805 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 04806 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 04807 $ RSRC_ 04808 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 04809 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 04810 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 04811 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 04812 REAL ZERO, ONE 04813 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) 04814 * .. 04815 * .. Local Scalars .. 04816 LOGICAL COLREP, CTRAN, LOWER, ROWREP, UPPER 04817 INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA, 04818 $ IN, IOFFA, IOFFX, IOFFY, J, JJA, KK, LDA, LDPA, 04819 $ LDX, LDY, MYCOL, MYROW, NPCOL, NPROW 04820 REAL EPS, ERRI, GTMP 04821 COMPLEX ATMP, C 04822 * .. 04823 * .. External Subroutines .. 04824 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D 04825 * .. 04826 * .. External Functions .. 04827 LOGICAL LSAME 04828 REAL PSLAMCH 04829 EXTERNAL LSAME, PSLAMCH 04830 * .. 04831 * .. Intrinsic Functions .. 04832 INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT 04833 * .. 04834 * .. Statement Functions .. 04835 REAL ABS1 04836 ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) 04837 * .. 04838 * .. Executable Statements .. 04839 * 04840 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 04841 * 04842 EPS = PSLAMCH( ICTXT, 'eps' ) 04843 * 04844 CTRAN = LSAME( TRANS, 'C' ) 04845 UPPER = LSAME( UPLO, 'U' ) 04846 LOWER = LSAME( UPLO, 'L' ) 04847 * 04848 LDA = MAX( 1, DESCA( M_ ) ) 04849 LDX = MAX( 1, DESCX( M_ ) ) 04850 LDY = MAX( 1, DESCY( M_ ) ) 04851 * 04852 * Compute expected result in A using data in A, X and Y. 04853 * Compute gauges in G. This part of the computation is performed 04854 * by every process in the grid. 04855 * 04856 DO 70 J = 1, N 04857 * 04858 IOFFY = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY 04859 * 04860 IF( LOWER ) THEN 04861 IBEG = J 04862 IEND = M 04863 DO 10 I = 1, J-1 04864 G( I ) = ZERO 04865 10 CONTINUE 04866 ELSE IF( UPPER ) THEN 04867 IBEG = 1 04868 IEND = J 04869 DO 20 I = J+1, M 04870 G( I ) = ZERO 04871 20 CONTINUE 04872 ELSE 04873 IBEG = 1 04874 IEND = M 04875 END IF 04876 * 04877 DO 30 I = IBEG, IEND 04878 * 04879 IOFFX = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX 04880 IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA 04881 IF( CTRAN ) THEN 04882 ATMP = X( IOFFX ) * CONJG( Y( IOFFY ) ) 04883 ELSE 04884 ATMP = X( IOFFX ) * Y( IOFFY ) 04885 END IF 04886 GTMP = ABS1( X( IOFFX ) ) * ABS1( Y( IOFFY ) ) 04887 G( I ) = ABS1( ALPHA ) * GTMP + ABS1( A( IOFFA ) ) 04888 A( IOFFA ) = ALPHA * ATMP + A( IOFFA ) 04889 * 04890 30 CONTINUE 04891 * 04892 * Compute the error ratio for this result. 04893 * 04894 INFO = 0 04895 ERR = ZERO 04896 LDPA = DESCA( LLD_ ) 04897 IOFFA = IA + ( JA + J - 2 ) * LDA 04898 CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL, 04899 $ IIA, JJA, IAROW, IACOL ) 04900 ROWREP = ( IAROW.EQ.-1 ) 04901 COLREP = ( IACOL.EQ.-1 ) 04902 * 04903 IF( MYCOL.EQ.IACOL .OR. COLREP ) THEN 04904 * 04905 ICURROW = IAROW 04906 IB = DESCA( IMB_ ) - IA + 1 04907 IF( IB.LE.0 ) 04908 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB 04909 IB = MIN( IB, M ) 04910 IN = IA + IB - 1 04911 * 04912 DO 40 I = IA, IN 04913 * 04914 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 04915 ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS 04916 IF( G( I-IA+1 ).NE.ZERO ) 04917 $ ERRI = ERRI / G( I-IA+1 ) 04918 ERR = MAX( ERR, ERRI ) 04919 IF( ERR*SQRT( EPS ).GE.ONE ) 04920 $ INFO = 1 04921 IIA = IIA + 1 04922 END IF 04923 * 04924 IOFFA = IOFFA + 1 04925 * 04926 40 CONTINUE 04927 * 04928 ICURROW = MOD( ICURROW+1, NPROW ) 04929 * 04930 DO 60 I = IN+1, IA+M-1, DESCA( MB_ ) 04931 IB = MIN( IA+M-I, DESCA( MB_ ) ) 04932 * 04933 DO 50 KK = 0, IB-1 04934 * 04935 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 04936 ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS 04937 IF( G( I+KK-IA+1 ).NE.ZERO ) 04938 $ ERRI = ERRI / G( I+KK-IA+1 ) 04939 ERR = MAX( ERR, ERRI ) 04940 IF( ERR*SQRT( EPS ).GE.ONE ) 04941 $ INFO = 1 04942 IIA = IIA + 1 04943 END IF 04944 * 04945 IOFFA = IOFFA + 1 04946 * 04947 50 CONTINUE 04948 * 04949 ICURROW = MOD( ICURROW+1, NPROW ) 04950 * 04951 60 CONTINUE 04952 * 04953 END IF 04954 * 04955 * If INFO = 0, all results are at least half accurate. 04956 * 04957 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 04958 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 04959 $ MYCOL ) 04960 IF( INFO.NE.0 ) 04961 $ GO TO 80 04962 * 04963 70 CONTINUE 04964 * 04965 80 CONTINUE 04966 * 04967 RETURN 04968 * 04969 * End of PCVMCH 04970 * 04971 END 04972 SUBROUTINE PCVMCH2( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX, 04973 $ INCX, Y, IY, JY, DESCY, INCY, A, PA, IA, 04974 $ JA, DESCA, G, ERR, INFO ) 04975 * 04976 * -- PBLAS test routine (version 2.0) -- 04977 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04978 * and University of California, Berkeley. 04979 * April 1, 1998 04980 * 04981 * .. Scalar Arguments .. 04982 CHARACTER*1 UPLO 04983 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX, 04984 $ JY, M, N 04985 REAL ERR 04986 COMPLEX ALPHA 04987 * .. 04988 * .. Array Arguments .. 04989 INTEGER DESCA( * ), DESCX( * ), DESCY( * ) 04990 REAL G( * ) 04991 COMPLEX A( * ), PA( * ), X( * ), Y( * ) 04992 * .. 04993 * 04994 * Purpose 04995 * ======= 04996 * 04997 * PCVMCH2 checks the results of the computational tests. 04998 * 04999 * Notes 05000 * ===== 05001 * 05002 * A description vector is associated with each 2D block-cyclicly dis- 05003 * tributed matrix. This vector stores the information required to 05004 * establish the mapping between a matrix entry and its corresponding 05005 * process and memory location. 05006 * 05007 * In the following comments, the character _ should be read as 05008 * "of the distributed matrix". Let A be a generic term for any 2D 05009 * block cyclicly distributed matrix. Its description vector is DESCA: 05010 * 05011 * NOTATION STORED IN EXPLANATION 05012 * ---------------- --------------- ------------------------------------ 05013 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 05014 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 05015 * the NPROW x NPCOL BLACS process grid 05016 * A is distributed over. The context 05017 * itself is global, but the handle 05018 * (the integer value) may vary. 05019 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 05020 * ted matrix A, M_A >= 0. 05021 * N_A (global) DESCA( N_ ) The number of columns in the distri- 05022 * buted matrix A, N_A >= 0. 05023 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 05024 * block of the matrix A, IMB_A > 0. 05025 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 05026 * left block of the matrix A, 05027 * INB_A > 0. 05028 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 05029 * bute the last M_A-IMB_A rows of A, 05030 * MB_A > 0. 05031 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 05032 * bute the last N_A-INB_A columns of 05033 * A, NB_A > 0. 05034 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 05035 * row of the matrix A is distributed, 05036 * NPROW > RSRC_A >= 0. 05037 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 05038 * first column of A is distributed. 05039 * NPCOL > CSRC_A >= 0. 05040 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 05041 * array storing the local blocks of 05042 * the distributed matrix A, 05043 * IF( Lc( 1, N_A ) > 0 ) 05044 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 05045 * ELSE 05046 * LLD_A >= 1. 05047 * 05048 * Let K be the number of rows of a matrix A starting at the global in- 05049 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 05050 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 05051 * receive if these K rows were distributed over NPROW processes. If K 05052 * is the number of columns of a matrix A starting at the global index 05053 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 05054 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 05055 * these K columns were distributed over NPCOL processes. 05056 * 05057 * The values of Lr() and Lc() may be determined via a call to the func- 05058 * tion PB_NUMROC: 05059 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 05060 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 05061 * 05062 * Arguments 05063 * ========= 05064 * 05065 * ICTXT (local input) INTEGER 05066 * On entry, ICTXT specifies the BLACS context handle, indica- 05067 * ting the global context of the operation. The context itself 05068 * is global, but the value of ICTXT is local. 05069 * 05070 * UPLO (global input) CHARACTER*1 05071 * On entry, UPLO specifies which part of the submatrix sub( A ) 05072 * is to be referenced as follows: 05073 * If UPLO = 'L', only the lower triangular part, 05074 * If UPLO = 'U', only the upper triangular part, 05075 * else the entire matrix is to be referenced. 05076 * 05077 * M (global input) INTEGER 05078 * On entry, M specifies the number of rows of the submatrix 05079 * operand matrix A. M must be at least zero. 05080 * 05081 * N (global input) INTEGER 05082 * On entry, N specifies the number of columns of the subma- 05083 * trix operand matrix A. N must be at least zero. 05084 * 05085 * ALPHA (global input) COMPLEX 05086 * On entry, ALPHA specifies the scalar alpha. 05087 * 05088 * X (local input) COMPLEX array 05089 * On entry, X is an array of dimension (DESCX( M_ ),*). This 05090 * array contains a local copy of the initial entire matrix PX. 05091 * 05092 * IX (global input) INTEGER 05093 * On entry, IX specifies X's global row index, which points to 05094 * the beginning of the submatrix sub( X ). 05095 * 05096 * JX (global input) INTEGER 05097 * On entry, JX specifies X's global column index, which points 05098 * to the beginning of the submatrix sub( X ). 05099 * 05100 * DESCX (global and local input) INTEGER array 05101 * On entry, DESCX is an integer array of dimension DLEN_. This 05102 * is the array descriptor for the matrix X. 05103 * 05104 * INCX (global input) INTEGER 05105 * On entry, INCX specifies the global increment for the 05106 * elements of X. Only two values of INCX are supported in 05107 * this version, namely 1 and M_X. INCX must not be zero. 05108 * 05109 * Y (local input) COMPLEX array 05110 * On entry, Y is an array of dimension (DESCY( M_ ),*). This 05111 * array contains a local copy of the initial entire matrix PY. 05112 * 05113 * IY (global input) INTEGER 05114 * On entry, IY specifies Y's global row index, which points to 05115 * the beginning of the submatrix sub( Y ). 05116 * 05117 * JY (global input) INTEGER 05118 * On entry, JY specifies Y's global column index, which points 05119 * to the beginning of the submatrix sub( Y ). 05120 * 05121 * DESCY (global and local input) INTEGER array 05122 * On entry, DESCY is an integer array of dimension DLEN_. This 05123 * is the array descriptor for the matrix Y. 05124 * 05125 * INCY (global input) INTEGER 05126 * On entry, INCY specifies the global increment for the 05127 * elements of Y. Only two values of INCY are supported in 05128 * this version, namely 1 and M_Y. INCY must not be zero. 05129 * 05130 * A (local input/local output) COMPLEX array 05131 * On entry, A is an array of dimension (DESCA( M_ ),*). This 05132 * array contains a local copy of the initial entire matrix PA. 05133 * 05134 * PA (local input) COMPLEX array 05135 * On entry, PA is an array of dimension (DESCA( LLD_ ),*). This 05136 * array contains the local entries of the matrix PA. 05137 * 05138 * IA (global input) INTEGER 05139 * On entry, IA specifies A's global row index, which points to 05140 * the beginning of the submatrix sub( A ). 05141 * 05142 * JA (global input) INTEGER 05143 * On entry, JA specifies A's global column index, which points 05144 * to the beginning of the submatrix sub( A ). 05145 * 05146 * DESCA (global and local input) INTEGER array 05147 * On entry, DESCA is an integer array of dimension DLEN_. This 05148 * is the array descriptor for the matrix A. 05149 * 05150 * G (workspace) REAL array 05151 * On entry, G is an array of dimension at least MAX( M, N ). G 05152 * is used to compute the gauges. 05153 * 05154 * ERR (global output) REAL 05155 * On exit, ERR specifies the largest error in absolute value. 05156 * 05157 * INFO (global output) INTEGER 05158 * On exit, if INFO <> 0, the result is less than half accurate. 05159 * 05160 * -- Written on April 1, 1998 by 05161 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 05162 * 05163 * ===================================================================== 05164 * 05165 * .. Parameters .. 05166 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 05167 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 05168 $ RSRC_ 05169 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 05170 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 05171 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 05172 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 05173 REAL ZERO, ONE 05174 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) 05175 * .. 05176 * .. Local Scalars .. 05177 LOGICAL COLREP, LOWER, ROWREP, UPPER 05178 INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA, 05179 $ IN, IOFFA, IOFFXI, IOFFXJ, IOFFYI, IOFFYJ, J, 05180 $ JJA, KK, LDA, LDPA, LDX, LDY, MYCOL, MYROW, 05181 $ NPCOL, NPROW 05182 REAL EPS, ERRI, GTMP 05183 COMPLEX C, ATMP 05184 * .. 05185 * .. External Subroutines .. 05186 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D 05187 * .. 05188 * .. External Functions .. 05189 LOGICAL LSAME 05190 REAL PSLAMCH 05191 EXTERNAL LSAME, PSLAMCH 05192 * .. 05193 * .. Intrinsic Functions .. 05194 INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT 05195 * .. 05196 * .. Statement Functions .. 05197 REAL ABS1 05198 ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) 05199 * .. 05200 * .. Executable Statements .. 05201 * 05202 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 05203 * 05204 EPS = PSLAMCH( ICTXT, 'eps' ) 05205 * 05206 UPPER = LSAME( UPLO, 'U' ) 05207 LOWER = LSAME( UPLO, 'L' ) 05208 * 05209 LDA = MAX( 1, DESCA( M_ ) ) 05210 LDX = MAX( 1, DESCX( M_ ) ) 05211 LDY = MAX( 1, DESCY( M_ ) ) 05212 * 05213 * Compute expected result in A using data in A, X and Y. 05214 * Compute gauges in G. This part of the computation is performed 05215 * by every process in the grid. 05216 * 05217 DO 70 J = 1, N 05218 * 05219 IOFFXJ = IX + ( JX - 1 ) * LDX + ( J - 1 ) * INCX 05220 IOFFYJ = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY 05221 * 05222 IF( LOWER ) THEN 05223 IBEG = J 05224 IEND = M 05225 DO 10 I = 1, J-1 05226 G( I ) = ZERO 05227 10 CONTINUE 05228 ELSE IF( UPPER ) THEN 05229 IBEG = 1 05230 IEND = J 05231 DO 20 I = J+1, M 05232 G( I ) = ZERO 05233 20 CONTINUE 05234 ELSE 05235 IBEG = 1 05236 IEND = M 05237 END IF 05238 * 05239 DO 30 I = IBEG, IEND 05240 IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA 05241 IOFFXI = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX 05242 IOFFYI = IY + ( JY - 1 ) * LDY + ( I - 1 ) * INCY 05243 ATMP = ALPHA * X( IOFFXI ) * CONJG( Y( IOFFYJ ) ) 05244 ATMP = ATMP + Y( IOFFYI ) * CONJG( ALPHA * X( IOFFXJ ) ) 05245 GTMP = ABS1( ALPHA * X( IOFFXI ) ) * ABS1( Y( IOFFYJ ) ) 05246 GTMP = GTMP + ABS1( Y( IOFFYI ) ) * 05247 $ ABS1( CONJG( ALPHA * X( IOFFXJ ) ) ) 05248 G( I ) = GTMP + ABS1( A( IOFFA ) ) 05249 A( IOFFA ) = A( IOFFA ) + ATMP 05250 * 05251 30 CONTINUE 05252 * 05253 * Compute the error ratio for this result. 05254 * 05255 INFO = 0 05256 ERR = ZERO 05257 LDPA = DESCA( LLD_ ) 05258 IOFFA = IA + ( JA + J - 2 ) * LDA 05259 CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL, 05260 $ IIA, JJA, IAROW, IACOL ) 05261 ROWREP = ( IAROW.EQ.-1 ) 05262 COLREP = ( IACOL.EQ.-1 ) 05263 * 05264 IF( MYCOL.EQ.IACOL .OR. COLREP ) THEN 05265 * 05266 ICURROW = IAROW 05267 IB = DESCA( IMB_ ) - IA + 1 05268 IF( IB.LE.0 ) 05269 $ IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB 05270 IB = MIN( IB, M ) 05271 IN = IA + IB - 1 05272 * 05273 DO 40 I = IA, IN 05274 * 05275 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 05276 ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS 05277 IF( G( I-IA+1 ).NE.ZERO ) 05278 $ ERRI = ERRI / G( I-IA+1 ) 05279 ERR = MAX( ERR, ERRI ) 05280 IF( ERR*SQRT( EPS ).GE.ONE ) 05281 $ INFO = 1 05282 IIA = IIA + 1 05283 END IF 05284 * 05285 IOFFA = IOFFA + 1 05286 * 05287 40 CONTINUE 05288 * 05289 ICURROW = MOD( ICURROW+1, NPROW ) 05290 * 05291 DO 60 I = IN+1, IA+M-1, DESCA( MB_ ) 05292 IB = MIN( IA+M-I, DESCA( MB_ ) ) 05293 * 05294 DO 50 KK = 0, IB-1 05295 * 05296 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 05297 ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS 05298 IF( G( I+KK-IA+1 ).NE.ZERO ) 05299 $ ERRI = ERRI / G( I+KK-IA+1 ) 05300 ERR = MAX( ERR, ERRI ) 05301 IF( ERR*SQRT( EPS ).GE.ONE ) 05302 $ INFO = 1 05303 IIA = IIA + 1 05304 END IF 05305 * 05306 IOFFA = IOFFA + 1 05307 * 05308 50 CONTINUE 05309 * 05310 ICURROW = MOD( ICURROW+1, NPROW ) 05311 * 05312 60 CONTINUE 05313 * 05314 END IF 05315 * 05316 * If INFO = 0, all results are at least half accurate. 05317 * 05318 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 05319 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 05320 $ MYCOL ) 05321 IF( INFO.NE.0 ) 05322 $ GO TO 80 05323 * 05324 70 CONTINUE 05325 * 05326 80 CONTINUE 05327 * 05328 RETURN 05329 * 05330 * End of PCVMCH2 05331 * 05332 END 05333 SUBROUTINE PCMMCH( ICTXT, TRANSA, TRANSB, M, N, K, ALPHA, A, IA, 05334 $ JA, DESCA, B, IB, JB, DESCB, BETA, C, PC, IC, 05335 $ JC, DESCC, CT, G, ERR, INFO ) 05336 * 05337 * -- PBLAS test routine (version 2.0) -- 05338 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 05339 * and University of California, Berkeley. 05340 * April 1, 1998 05341 * 05342 * .. Scalar Arguments .. 05343 CHARACTER*1 TRANSA, TRANSB 05344 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N 05345 REAL ERR 05346 COMPLEX ALPHA, BETA 05347 * .. 05348 * .. Array Arguments .. 05349 INTEGER DESCA( * ), DESCB( * ), DESCC( * ) 05350 REAL G( * ) 05351 COMPLEX A( * ), B( * ), C( * ), CT( * ), PC( * ) 05352 * .. 05353 * 05354 * Purpose 05355 * ======= 05356 * 05357 * PCMMCH checks the results of the computational tests. 05358 * 05359 * Notes 05360 * ===== 05361 * 05362 * A description vector is associated with each 2D block-cyclicly dis- 05363 * tributed matrix. This vector stores the information required to 05364 * establish the mapping between a matrix entry and its corresponding 05365 * process and memory location. 05366 * 05367 * In the following comments, the character _ should be read as 05368 * "of the distributed matrix". Let A be a generic term for any 2D 05369 * block cyclicly distributed matrix. Its description vector is DESCA: 05370 * 05371 * NOTATION STORED IN EXPLANATION 05372 * ---------------- --------------- ------------------------------------ 05373 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 05374 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 05375 * the NPROW x NPCOL BLACS process grid 05376 * A is distributed over. The context 05377 * itself is global, but the handle 05378 * (the integer value) may vary. 05379 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 05380 * ted matrix A, M_A >= 0. 05381 * N_A (global) DESCA( N_ ) The number of columns in the distri- 05382 * buted matrix A, N_A >= 0. 05383 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 05384 * block of the matrix A, IMB_A > 0. 05385 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 05386 * left block of the matrix A, 05387 * INB_A > 0. 05388 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 05389 * bute the last M_A-IMB_A rows of A, 05390 * MB_A > 0. 05391 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 05392 * bute the last N_A-INB_A columns of 05393 * A, NB_A > 0. 05394 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 05395 * row of the matrix A is distributed, 05396 * NPROW > RSRC_A >= 0. 05397 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 05398 * first column of A is distributed. 05399 * NPCOL > CSRC_A >= 0. 05400 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 05401 * array storing the local blocks of 05402 * the distributed matrix A, 05403 * IF( Lc( 1, N_A ) > 0 ) 05404 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 05405 * ELSE 05406 * LLD_A >= 1. 05407 * 05408 * Let K be the number of rows of a matrix A starting at the global in- 05409 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 05410 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 05411 * receive if these K rows were distributed over NPROW processes. If K 05412 * is the number of columns of a matrix A starting at the global index 05413 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 05414 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 05415 * these K columns were distributed over NPCOL processes. 05416 * 05417 * The values of Lr() and Lc() may be determined via a call to the func- 05418 * tion PB_NUMROC: 05419 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 05420 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 05421 * 05422 * Arguments 05423 * ========= 05424 * 05425 * ICTXT (local input) INTEGER 05426 * On entry, ICTXT specifies the BLACS context handle, indica- 05427 * ting the global context of the operation. The context itself 05428 * is global, but the value of ICTXT is local. 05429 * 05430 * TRANSA (global input) CHARACTER*1 05431 * On entry, TRANSA specifies if the matrix operand A is to be 05432 * transposed. 05433 * 05434 * TRANSB (global input) CHARACTER*1 05435 * On entry, TRANSB specifies if the matrix operand B is to be 05436 * transposed. 05437 * 05438 * M (global input) INTEGER 05439 * On entry, M specifies the number of rows of C. 05440 * 05441 * N (global input) INTEGER 05442 * On entry, N specifies the number of columns of C. 05443 * 05444 * K (global input) INTEGER 05445 * On entry, K specifies the number of columns (resp. rows) of A 05446 * when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK, 05447 * PxSYR2K, PxHERK and PxHER2K. 05448 * 05449 * ALPHA (global input) COMPLEX 05450 * On entry, ALPHA specifies the scalar alpha. 05451 * 05452 * A (local input) COMPLEX array 05453 * On entry, A is an array of dimension (DESCA( M_ ),*). This 05454 * array contains a local copy of the initial entire matrix PA. 05455 * 05456 * IA (global input) INTEGER 05457 * On entry, IA specifies A's global row index, which points to 05458 * the beginning of the submatrix sub( A ). 05459 * 05460 * JA (global input) INTEGER 05461 * On entry, JA specifies A's global column index, which points 05462 * to the beginning of the submatrix sub( A ). 05463 * 05464 * DESCA (global and local input) INTEGER array 05465 * On entry, DESCA is an integer array of dimension DLEN_. This 05466 * is the array descriptor for the matrix A. 05467 * 05468 * B (local input) COMPLEX array 05469 * On entry, B is an array of dimension (DESCB( M_ ),*). This 05470 * array contains a local copy of the initial entire matrix PB. 05471 * 05472 * IB (global input) INTEGER 05473 * On entry, IB specifies B's global row index, which points to 05474 * the beginning of the submatrix sub( B ). 05475 * 05476 * JB (global input) INTEGER 05477 * On entry, JB specifies B's global column index, which points 05478 * to the beginning of the submatrix sub( B ). 05479 * 05480 * DESCB (global and local input) INTEGER array 05481 * On entry, DESCB is an integer array of dimension DLEN_. This 05482 * is the array descriptor for the matrix B. 05483 * 05484 * BETA (global input) COMPLEX 05485 * On entry, BETA specifies the scalar beta. 05486 * 05487 * C (local input/local output) COMPLEX array 05488 * On entry, C is an array of dimension (DESCC( M_ ),*). This 05489 * array contains a local copy of the initial entire matrix PC. 05490 * 05491 * PC (local input) COMPLEX array 05492 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This 05493 * array contains the local pieces of the matrix PC. 05494 * 05495 * IC (global input) INTEGER 05496 * On entry, IC specifies C's global row index, which points to 05497 * the beginning of the submatrix sub( C ). 05498 * 05499 * JC (global input) INTEGER 05500 * On entry, JC specifies C's global column index, which points 05501 * to the beginning of the submatrix sub( C ). 05502 * 05503 * DESCC (global and local input) INTEGER array 05504 * On entry, DESCC is an integer array of dimension DLEN_. This 05505 * is the array descriptor for the matrix C. 05506 * 05507 * CT (workspace) COMPLEX array 05508 * On entry, CT is an array of dimension at least MAX(M,N,K). CT 05509 * holds a copy of the current column of C. 05510 * 05511 * G (workspace) REAL array 05512 * On entry, G is an array of dimension at least MAX(M,N,K). G 05513 * is used to compute the gauges. 05514 * 05515 * ERR (global output) REAL 05516 * On exit, ERR specifies the largest error in absolute value. 05517 * 05518 * INFO (global output) INTEGER 05519 * On exit, if INFO <> 0, the result is less than half accurate. 05520 * 05521 * -- Written on April 1, 1998 by 05522 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 05523 * 05524 * ===================================================================== 05525 * 05526 * .. Parameters .. 05527 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 05528 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 05529 $ RSRC_ 05530 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 05531 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 05532 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 05533 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 05534 REAL RZERO, RONE 05535 PARAMETER ( RZERO = 0.0E+0, RONE = 1.0E+0 ) 05536 COMPLEX ZERO 05537 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) 05538 * .. 05539 * .. Local Scalars .. 05540 LOGICAL COLREP, CTRANA, CTRANB, ROWREP, TRANA, TRANB 05541 INTEGER I, IBB, ICCOL, ICROW, ICURROW, IIC, IN, IOFFA, 05542 $ IOFFB, IOFFC, J, JJC, KK, LDA, LDB, LDC, LDPC, 05543 $ MYCOL, MYROW, NPCOL, NPROW 05544 REAL EPS, ERRI 05545 COMPLEX Z 05546 * .. 05547 * .. External Subroutines .. 05548 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D 05549 * .. 05550 * .. External Functions .. 05551 LOGICAL LSAME 05552 REAL PSLAMCH 05553 EXTERNAL LSAME, PSLAMCH 05554 * .. 05555 * .. Intrinsic Functions .. 05556 INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT 05557 * .. 05558 * .. Statement Functions .. 05559 REAL ABS1 05560 ABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) 05561 * .. 05562 * .. Executable Statements .. 05563 * 05564 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 05565 * 05566 EPS = PSLAMCH( ICTXT, 'eps' ) 05567 * 05568 TRANA = LSAME( TRANSA, 'T' ).OR.LSAME( TRANSA, 'C' ) 05569 TRANB = LSAME( TRANSB, 'T' ).OR.LSAME( TRANSB, 'C' ) 05570 CTRANA = LSAME( TRANSA, 'C' ) 05571 CTRANB = LSAME( TRANSB, 'C' ) 05572 * 05573 LDA = MAX( 1, DESCA( M_ ) ) 05574 LDB = MAX( 1, DESCB( M_ ) ) 05575 LDC = MAX( 1, DESCC( M_ ) ) 05576 * 05577 * Compute expected result in C using data in A, B and C. 05578 * Compute gauges in G. This part of the computation is performed 05579 * by every process in the grid. 05580 * 05581 DO 240 J = 1, N 05582 * 05583 IOFFC = IC + ( JC + J - 2 ) * LDC 05584 DO 10 I = 1, M 05585 CT( I ) = ZERO 05586 G( I ) = RZERO 05587 10 CONTINUE 05588 * 05589 IF( .NOT.TRANA .AND. .NOT.TRANB ) THEN 05590 DO 30 KK = 1, K 05591 IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB 05592 DO 20 I = 1, M 05593 IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA 05594 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB ) 05595 G( I ) = G( I ) + ABS( A( IOFFA ) ) * 05596 $ ABS( B( IOFFB ) ) 05597 20 CONTINUE 05598 30 CONTINUE 05599 ELSE IF( TRANA .AND. .NOT.TRANB ) THEN 05600 IF( CTRANA ) THEN 05601 DO 50 KK = 1, K 05602 IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB 05603 DO 40 I = 1, M 05604 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA 05605 CT( I ) = CT( I ) + CONJG( A( IOFFA ) ) * 05606 $ B( IOFFB ) 05607 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05608 $ ABS1( B( IOFFB ) ) 05609 40 CONTINUE 05610 50 CONTINUE 05611 ELSE 05612 DO 70 KK = 1, K 05613 IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB 05614 DO 60 I = 1, M 05615 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA 05616 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB ) 05617 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05618 $ ABS1( B( IOFFB ) ) 05619 60 CONTINUE 05620 70 CONTINUE 05621 END IF 05622 ELSE IF( .NOT.TRANA .AND. TRANB ) THEN 05623 IF( CTRANB ) THEN 05624 DO 90 KK = 1, K 05625 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB 05626 DO 80 I = 1, M 05627 IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA 05628 CT( I ) = CT( I ) + A( IOFFA ) * 05629 $ CONJG( B( IOFFB ) ) 05630 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05631 $ ABS1( B( IOFFB ) ) 05632 80 CONTINUE 05633 90 CONTINUE 05634 ELSE 05635 DO 110 KK = 1, K 05636 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB 05637 DO 100 I = 1, M 05638 IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA 05639 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB ) 05640 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05641 $ ABS1( B( IOFFB ) ) 05642 100 CONTINUE 05643 110 CONTINUE 05644 END IF 05645 ELSE IF( TRANA .AND. TRANB ) THEN 05646 IF( CTRANA ) THEN 05647 IF( CTRANB ) THEN 05648 DO 130 KK = 1, K 05649 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB 05650 DO 120 I = 1, M 05651 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA 05652 CT( I ) = CT( I ) + CONJG( A( IOFFA ) ) * 05653 $ CONJG( B( IOFFB ) ) 05654 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05655 $ ABS1( B( IOFFB ) ) 05656 120 CONTINUE 05657 130 CONTINUE 05658 ELSE 05659 DO 150 KK = 1, K 05660 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB 05661 DO 140 I = 1, M 05662 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA 05663 CT( I ) = CT( I ) + CONJG( A( IOFFA ) ) * 05664 $ B( IOFFB ) 05665 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05666 $ ABS1( B( IOFFB ) ) 05667 140 CONTINUE 05668 150 CONTINUE 05669 END IF 05670 ELSE 05671 IF( CTRANB ) THEN 05672 DO 170 KK = 1, K 05673 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB 05674 DO 160 I = 1, M 05675 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA 05676 CT( I ) = CT( I ) + A( IOFFA ) * 05677 $ CONJG( B( IOFFB ) ) 05678 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05679 $ ABS1( B( IOFFB ) ) 05680 160 CONTINUE 05681 170 CONTINUE 05682 ELSE 05683 DO 190 KK = 1, K 05684 IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB 05685 DO 180 I = 1, M 05686 IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA 05687 CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB ) 05688 G( I ) = G( I ) + ABS1( A( IOFFA ) ) * 05689 $ ABS1( B( IOFFB ) ) 05690 180 CONTINUE 05691 190 CONTINUE 05692 END IF 05693 END IF 05694 END IF 05695 * 05696 DO 200 I = 1, M 05697 CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC ) 05698 G( I ) = ABS1( ALPHA )*G( I ) + 05699 $ ABS1( BETA )*ABS1( C( IOFFC ) ) 05700 C( IOFFC ) = CT( I ) 05701 IOFFC = IOFFC + 1 05702 200 CONTINUE 05703 * 05704 * Compute the error ratio for this result. 05705 * 05706 ERR = RZERO 05707 INFO = 0 05708 LDPC = DESCC( LLD_ ) 05709 IOFFC = IC + ( JC + J - 2 ) * LDC 05710 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL, 05711 $ IIC, JJC, ICROW, ICCOL ) 05712 ICURROW = ICROW 05713 ROWREP = ( ICROW.EQ.-1 ) 05714 COLREP = ( ICCOL.EQ.-1 ) 05715 * 05716 IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN 05717 * 05718 IBB = DESCC( IMB_ ) - IC + 1 05719 IF( IBB.LE.0 ) 05720 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB 05721 IBB = MIN( IBB, M ) 05722 IN = IC + IBB - 1 05723 * 05724 DO 210 I = IC, IN 05725 * 05726 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 05727 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 05728 $ C( IOFFC ) ) / EPS 05729 IF( G( I-IC+1 ).NE.RZERO ) 05730 $ ERRI = ERRI / G( I-IC+1 ) 05731 ERR = MAX( ERR, ERRI ) 05732 IF( ERR*SQRT( EPS ).GE.RONE ) 05733 $ INFO = 1 05734 IIC = IIC + 1 05735 END IF 05736 * 05737 IOFFC = IOFFC + 1 05738 * 05739 210 CONTINUE 05740 * 05741 ICURROW = MOD( ICURROW+1, NPROW ) 05742 * 05743 DO 230 I = IN+1, IC+M-1, DESCC( MB_ ) 05744 IBB = MIN( IC+M-I, DESCC( MB_ ) ) 05745 * 05746 DO 220 KK = 0, IBB-1 05747 * 05748 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 05749 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 05750 $ C( IOFFC ) )/EPS 05751 IF( G( I+KK-IC+1 ).NE.RZERO ) 05752 $ ERRI = ERRI / G( I+KK-IC+1 ) 05753 ERR = MAX( ERR, ERRI ) 05754 IF( ERR*SQRT( EPS ).GE.RONE ) 05755 $ INFO = 1 05756 IIC = IIC + 1 05757 END IF 05758 * 05759 IOFFC = IOFFC + 1 05760 * 05761 220 CONTINUE 05762 * 05763 ICURROW = MOD( ICURROW+1, NPROW ) 05764 * 05765 230 CONTINUE 05766 * 05767 END IF 05768 * 05769 * If INFO = 0, all results are at least half accurate. 05770 * 05771 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 05772 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 05773 $ MYCOL ) 05774 IF( INFO.NE.0 ) 05775 $ GO TO 250 05776 * 05777 240 CONTINUE 05778 * 05779 250 CONTINUE 05780 * 05781 RETURN 05782 * 05783 * End of PCMMCH 05784 * 05785 END 05786 SUBROUTINE PCMMCH1( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA, 05787 $ DESCA, BETA, C, PC, IC, JC, DESCC, CT, G, 05788 $ ERR, INFO ) 05789 * 05790 * -- PBLAS test routine (version 2.0) -- 05791 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 05792 * and University of California, Berkeley. 05793 * April 1, 1998 05794 * 05795 * .. Scalar Arguments .. 05796 CHARACTER*1 TRANS, UPLO 05797 INTEGER IA, IC, ICTXT, INFO, JA, JC, K, N 05798 REAL ERR 05799 COMPLEX ALPHA, BETA 05800 * .. 05801 * .. Array Arguments .. 05802 INTEGER DESCA( * ), DESCC( * ) 05803 REAL G( * ) 05804 COMPLEX A( * ), C( * ), CT( * ), PC( * ) 05805 * .. 05806 * 05807 * Purpose 05808 * ======= 05809 * 05810 * PCMMCH1 checks the results of the computational tests. 05811 * 05812 * Notes 05813 * ===== 05814 * 05815 * A description vector is associated with each 2D block-cyclicly dis- 05816 * tributed matrix. This vector stores the information required to 05817 * establish the mapping between a matrix entry and its corresponding 05818 * process and memory location. 05819 * 05820 * In the following comments, the character _ should be read as 05821 * "of the distributed matrix". Let A be a generic term for any 2D 05822 * block cyclicly distributed matrix. Its description vector is DESCA: 05823 * 05824 * NOTATION STORED IN EXPLANATION 05825 * ---------------- --------------- ------------------------------------ 05826 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 05827 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 05828 * the NPROW x NPCOL BLACS process grid 05829 * A is distributed over. The context 05830 * itself is global, but the handle 05831 * (the integer value) may vary. 05832 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 05833 * ted matrix A, M_A >= 0. 05834 * N_A (global) DESCA( N_ ) The number of columns in the distri- 05835 * buted matrix A, N_A >= 0. 05836 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 05837 * block of the matrix A, IMB_A > 0. 05838 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 05839 * left block of the matrix A, 05840 * INB_A > 0. 05841 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 05842 * bute the last M_A-IMB_A rows of A, 05843 * MB_A > 0. 05844 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 05845 * bute the last N_A-INB_A columns of 05846 * A, NB_A > 0. 05847 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 05848 * row of the matrix A is distributed, 05849 * NPROW > RSRC_A >= 0. 05850 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 05851 * first column of A is distributed. 05852 * NPCOL > CSRC_A >= 0. 05853 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 05854 * array storing the local blocks of 05855 * the distributed matrix A, 05856 * IF( Lc( 1, N_A ) > 0 ) 05857 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 05858 * ELSE 05859 * LLD_A >= 1. 05860 * 05861 * Let K be the number of rows of a matrix A starting at the global in- 05862 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 05863 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 05864 * receive if these K rows were distributed over NPROW processes. If K 05865 * is the number of columns of a matrix A starting at the global index 05866 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 05867 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 05868 * these K columns were distributed over NPCOL processes. 05869 * 05870 * The values of Lr() and Lc() may be determined via a call to the func- 05871 * tion PB_NUMROC: 05872 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 05873 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 05874 * 05875 * Arguments 05876 * ========= 05877 * 05878 * ICTXT (local input) INTEGER 05879 * On entry, ICTXT specifies the BLACS context handle, indica- 05880 * ting the global context of the operation. The context itself 05881 * is global, but the value of ICTXT is local. 05882 * 05883 * UPLO (global input) CHARACTER*1 05884 * On entry, UPLO specifies which part of C should contain the 05885 * result. 05886 * 05887 * TRANS (global input) CHARACTER*1 05888 * On entry, TRANS specifies whether the matrix A has to be 05889 * transposed or not before computing the matrix-matrix product. 05890 * 05891 * N (global input) INTEGER 05892 * On entry, N specifies the order the submatrix operand C. N 05893 * must be at least zero. 05894 * 05895 * K (global input) INTEGER 05896 * On entry, K specifies the number of columns (resp. rows) of A 05897 * when TRANS = 'N' (resp. TRANS <> 'N'). K must be at least 05898 * zero. 05899 * 05900 * ALPHA (global input) COMPLEX 05901 * On entry, ALPHA specifies the scalar alpha. 05902 * 05903 * A (local input) COMPLEX array 05904 * On entry, A is an array of dimension (DESCA( M_ ),*). This 05905 * array contains a local copy of the initial entire matrix PA. 05906 * 05907 * IA (global input) INTEGER 05908 * On entry, IA specifies A's global row index, which points to 05909 * the beginning of the submatrix sub( A ). 05910 * 05911 * JA (global input) INTEGER 05912 * On entry, JA specifies A's global column index, which points 05913 * to the beginning of the submatrix sub( A ). 05914 * 05915 * DESCA (global and local input) INTEGER array 05916 * On entry, DESCA is an integer array of dimension DLEN_. This 05917 * is the array descriptor for the matrix A. 05918 * 05919 * BETA (global input) COMPLEX 05920 * On entry, BETA specifies the scalar beta. 05921 * 05922 * C (local input/local output) COMPLEX array 05923 * On entry, C is an array of dimension (DESCC( M_ ),*). This 05924 * array contains a local copy of the initial entire matrix PC. 05925 * 05926 * PC (local input) COMPLEX array 05927 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This 05928 * array contains the local pieces of the matrix PC. 05929 * 05930 * IC (global input) INTEGER 05931 * On entry, IC specifies C's global row index, which points to 05932 * the beginning of the submatrix sub( C ). 05933 * 05934 * JC (global input) INTEGER 05935 * On entry, JC specifies C's global column index, which points 05936 * to the beginning of the submatrix sub( C ). 05937 * 05938 * DESCC (global and local input) INTEGER array 05939 * On entry, DESCC is an integer array of dimension DLEN_. This 05940 * is the array descriptor for the matrix C. 05941 * 05942 * CT (workspace) COMPLEX array 05943 * On entry, CT is an array of dimension at least MAX(M,N,K). CT 05944 * holds a copy of the current column of C. 05945 * 05946 * G (workspace) REAL array 05947 * On entry, G is an array of dimension at least MAX(M,N,K). G 05948 * is used to compute the gauges. 05949 * 05950 * ERR (global output) REAL 05951 * On exit, ERR specifies the largest error in absolute value. 05952 * 05953 * INFO (global output) INTEGER 05954 * On exit, if INFO <> 0, the result is less than half accurate. 05955 * 05956 * -- Written on April 1, 1998 by 05957 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 05958 * 05959 * ===================================================================== 05960 * 05961 * .. Parameters .. 05962 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 05963 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 05964 $ RSRC_ 05965 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 05966 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 05967 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 05968 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 05969 REAL RZERO, RONE 05970 PARAMETER ( RZERO = 0.0E+0, RONE = 1.0E+0 ) 05971 COMPLEX ZERO 05972 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) 05973 * .. 05974 * .. Local Scalars .. 05975 LOGICAL COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER 05976 INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC, 05977 $ IN, IOFFAK, IOFFAN, IOFFC, J, JJC, KK, LDA, 05978 $ LDC, LDPC, MYCOL, MYROW, NPCOL, NPROW 05979 REAL EPS, ERRI 05980 COMPLEX Z 05981 * .. 05982 * .. External Subroutines .. 05983 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D 05984 * .. 05985 * .. External Functions .. 05986 LOGICAL LSAME 05987 REAL PSLAMCH 05988 EXTERNAL LSAME, PSLAMCH 05989 * .. 05990 * .. Intrinsic Functions .. 05991 INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT 05992 * .. 05993 * .. Statement Functions .. 05994 REAL ABS1 05995 ABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) 05996 * .. 05997 * .. Executable Statements .. 05998 * 05999 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 06000 * 06001 EPS = PSLAMCH( ICTXT, 'eps' ) 06002 * 06003 UPPER = LSAME( UPLO, 'U' ) 06004 NOTRAN = LSAME( TRANS, 'N' ) 06005 TRAN = LSAME( TRANS, 'T' ) 06006 HTRAN = LSAME( TRANS, 'H' ) 06007 * 06008 LDA = MAX( 1, DESCA( M_ ) ) 06009 LDC = MAX( 1, DESCC( M_ ) ) 06010 * 06011 * Compute expected result in C using data in A, B and C. 06012 * Compute gauges in G. This part of the computation is performed 06013 * by every process in the grid. 06014 * 06015 DO 140 J = 1, N 06016 * 06017 IF( UPPER ) THEN 06018 IBEG = 1 06019 IEND = J 06020 ELSE 06021 IBEG = J 06022 IEND = N 06023 END IF 06024 * 06025 DO 10 I = 1, N 06026 CT( I ) = ZERO 06027 G( I ) = RZERO 06028 10 CONTINUE 06029 * 06030 IF( NOTRAN ) THEN 06031 DO 30 KK = 1, K 06032 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA 06033 DO 20 I = IBEG, IEND 06034 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA 06035 CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN ) 06036 G( I ) = G( I ) + ABS1( A( IOFFAK ) ) * 06037 $ ABS1( A( IOFFAN ) ) 06038 20 CONTINUE 06039 30 CONTINUE 06040 ELSE IF( TRAN ) THEN 06041 DO 50 KK = 1, K 06042 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA 06043 DO 40 I = IBEG, IEND 06044 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA 06045 CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN ) 06046 G( I ) = G( I ) + ABS1( A( IOFFAK ) ) * 06047 $ ABS1( A( IOFFAN ) ) 06048 40 CONTINUE 06049 50 CONTINUE 06050 ELSE IF( HTRAN ) THEN 06051 DO 70 KK = 1, K 06052 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA 06053 DO 60 I = IBEG, IEND 06054 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA 06055 CT( I ) = CT( I ) + A( IOFFAN ) * 06056 $ CONJG( A( IOFFAK ) ) 06057 G( I ) = G( I ) + ABS1( A( IOFFAK ) ) * 06058 $ ABS1( A( IOFFAN ) ) 06059 60 CONTINUE 06060 70 CONTINUE 06061 ELSE 06062 DO 90 KK = 1, K 06063 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA 06064 DO 80 I = IBEG, IEND 06065 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA 06066 CT( I ) = CT( I ) + CONJG( A( IOFFAN ) ) * A( IOFFAK ) 06067 G( I ) = G( I ) + ABS1( CONJG( A( IOFFAN ) ) ) * 06068 $ ABS1( A( IOFFAK ) ) 06069 80 CONTINUE 06070 90 CONTINUE 06071 END IF 06072 * 06073 IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC 06074 * 06075 DO 100 I = IBEG, IEND 06076 CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC ) 06077 G( I ) = ABS1( ALPHA )*G( I ) + 06078 $ ABS1( BETA )*ABS1( C( IOFFC ) ) 06079 C( IOFFC ) = CT( I ) 06080 IOFFC = IOFFC + 1 06081 100 CONTINUE 06082 * 06083 * Compute the error ratio for this result. 06084 * 06085 ERR = RZERO 06086 INFO = 0 06087 LDPC = DESCC( LLD_ ) 06088 IOFFC = IC + ( JC + J - 2 ) * LDC 06089 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06090 $ IIC, JJC, ICROW, ICCOL ) 06091 ICURROW = ICROW 06092 ROWREP = ( ICROW.EQ.-1 ) 06093 COLREP = ( ICCOL.EQ.-1 ) 06094 * 06095 IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN 06096 * 06097 IBB = DESCC( IMB_ ) - IC + 1 06098 IF( IBB.LE.0 ) 06099 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB 06100 IBB = MIN( IBB, N ) 06101 IN = IC + IBB - 1 06102 * 06103 DO 110 I = IC, IN 06104 * 06105 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06106 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06107 $ C( IOFFC ) ) / EPS 06108 IF( G( I-IC+1 ).NE.RZERO ) 06109 $ ERRI = ERRI / G( I-IC+1 ) 06110 ERR = MAX( ERR, ERRI ) 06111 IF( ERR*SQRT( EPS ).GE.RONE ) 06112 $ INFO = 1 06113 IIC = IIC + 1 06114 END IF 06115 * 06116 IOFFC = IOFFC + 1 06117 * 06118 110 CONTINUE 06119 * 06120 ICURROW = MOD( ICURROW+1, NPROW ) 06121 * 06122 DO 130 I = IN+1, IC+N-1, DESCC( MB_ ) 06123 IBB = MIN( IC+N-I, DESCC( MB_ ) ) 06124 * 06125 DO 120 KK = 0, IBB-1 06126 * 06127 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06128 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06129 $ C( IOFFC ) )/EPS 06130 IF( G( I+KK-IC+1 ).NE.RZERO ) 06131 $ ERRI = ERRI / G( I+KK-IC+1 ) 06132 ERR = MAX( ERR, ERRI ) 06133 IF( ERR*SQRT( EPS ).GE.RONE ) 06134 $ INFO = 1 06135 IIC = IIC + 1 06136 END IF 06137 * 06138 IOFFC = IOFFC + 1 06139 * 06140 120 CONTINUE 06141 * 06142 ICURROW = MOD( ICURROW+1, NPROW ) 06143 * 06144 130 CONTINUE 06145 * 06146 END IF 06147 * 06148 * If INFO = 0, all results are at least half accurate. 06149 * 06150 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 06151 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 06152 $ MYCOL ) 06153 IF( INFO.NE.0 ) 06154 $ GO TO 150 06155 * 06156 140 CONTINUE 06157 * 06158 150 CONTINUE 06159 * 06160 RETURN 06161 * 06162 * End of PCMMCH1 06163 * 06164 END 06165 SUBROUTINE PCMMCH2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA, 06166 $ DESCA, B, IB, JB, DESCB, BETA, C, PC, IC, 06167 $ JC, DESCC, CT, G, ERR, INFO ) 06168 * 06169 * -- PBLAS test routine (version 2.0) -- 06170 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 06171 * and University of California, Berkeley. 06172 * April 1, 1998 06173 * 06174 * .. Scalar Arguments .. 06175 CHARACTER*1 TRANS, UPLO 06176 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N 06177 REAL ERR 06178 COMPLEX ALPHA, BETA 06179 * .. 06180 * .. Array Arguments .. 06181 INTEGER DESCA( * ), DESCB( * ), DESCC( * ) 06182 REAL G( * ) 06183 COMPLEX A( * ), B( * ), C( * ), CT( * ), 06184 $ PC( * ) 06185 * .. 06186 * 06187 * Purpose 06188 * ======= 06189 * 06190 * PCMMCH2 checks the results of the computational tests. 06191 * 06192 * Notes 06193 * ===== 06194 * 06195 * A description vector is associated with each 2D block-cyclicly dis- 06196 * tributed matrix. This vector stores the information required to 06197 * establish the mapping between a matrix entry and its corresponding 06198 * process and memory location. 06199 * 06200 * In the following comments, the character _ should be read as 06201 * "of the distributed matrix". Let A be a generic term for any 2D 06202 * block cyclicly distributed matrix. Its description vector is DESCA: 06203 * 06204 * NOTATION STORED IN EXPLANATION 06205 * ---------------- --------------- ------------------------------------ 06206 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 06207 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 06208 * the NPROW x NPCOL BLACS process grid 06209 * A is distributed over. The context 06210 * itself is global, but the handle 06211 * (the integer value) may vary. 06212 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 06213 * ted matrix A, M_A >= 0. 06214 * N_A (global) DESCA( N_ ) The number of columns in the distri- 06215 * buted matrix A, N_A >= 0. 06216 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 06217 * block of the matrix A, IMB_A > 0. 06218 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 06219 * left block of the matrix A, 06220 * INB_A > 0. 06221 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 06222 * bute the last M_A-IMB_A rows of A, 06223 * MB_A > 0. 06224 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 06225 * bute the last N_A-INB_A columns of 06226 * A, NB_A > 0. 06227 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 06228 * row of the matrix A is distributed, 06229 * NPROW > RSRC_A >= 0. 06230 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 06231 * first column of A is distributed. 06232 * NPCOL > CSRC_A >= 0. 06233 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 06234 * array storing the local blocks of 06235 * the distributed matrix A, 06236 * IF( Lc( 1, N_A ) > 0 ) 06237 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 06238 * ELSE 06239 * LLD_A >= 1. 06240 * 06241 * Let K be the number of rows of a matrix A starting at the global in- 06242 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 06243 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 06244 * receive if these K rows were distributed over NPROW processes. If K 06245 * is the number of columns of a matrix A starting at the global index 06246 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 06247 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 06248 * these K columns were distributed over NPCOL processes. 06249 * 06250 * The values of Lr() and Lc() may be determined via a call to the func- 06251 * tion PB_NUMROC: 06252 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 06253 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 06254 * 06255 * Arguments 06256 * ========= 06257 * 06258 * ICTXT (local input) INTEGER 06259 * On entry, ICTXT specifies the BLACS context handle, indica- 06260 * ting the global context of the operation. The context itself 06261 * is global, but the value of ICTXT is local. 06262 * 06263 * UPLO (global input) CHARACTER*1 06264 * On entry, UPLO specifies which part of C should contain the 06265 * result. 06266 * 06267 * TRANS (global input) CHARACTER*1 06268 * On entry, TRANS specifies whether the matrices A and B have 06269 * to be transposed or not before computing the matrix-matrix 06270 * product. 06271 * 06272 * N (global input) INTEGER 06273 * On entry, N specifies the order the submatrix operand C. N 06274 * must be at least zero. 06275 * 06276 * K (global input) INTEGER 06277 * On entry, K specifies the number of columns (resp. rows) of A 06278 * and B when TRANS = 'N' (resp. TRANS <> 'N'). K must be at 06279 * least zero. 06280 * 06281 * ALPHA (global input) COMPLEX 06282 * On entry, ALPHA specifies the scalar alpha. 06283 * 06284 * A (local input) COMPLEX array 06285 * On entry, A is an array of dimension (DESCA( M_ ),*). This 06286 * array contains a local copy of the initial entire matrix PA. 06287 * 06288 * IA (global input) INTEGER 06289 * On entry, IA specifies A's global row index, which points to 06290 * the beginning of the submatrix sub( A ). 06291 * 06292 * JA (global input) INTEGER 06293 * On entry, JA specifies A's global column index, which points 06294 * to the beginning of the submatrix sub( A ). 06295 * 06296 * DESCA (global and local input) INTEGER array 06297 * On entry, DESCA is an integer array of dimension DLEN_. This 06298 * is the array descriptor for the matrix A. 06299 * 06300 * B (local input) COMPLEX array 06301 * On entry, B is an array of dimension (DESCB( M_ ),*). This 06302 * array contains a local copy of the initial entire matrix PB. 06303 * 06304 * IB (global input) INTEGER 06305 * On entry, IB specifies B's global row index, which points to 06306 * the beginning of the submatrix sub( B ). 06307 * 06308 * JB (global input) INTEGER 06309 * On entry, JB specifies B's global column index, which points 06310 * to the beginning of the submatrix sub( B ). 06311 * 06312 * DESCB (global and local input) INTEGER array 06313 * On entry, DESCB is an integer array of dimension DLEN_. This 06314 * is the array descriptor for the matrix B. 06315 * 06316 * BETA (global input) COMPLEX 06317 * On entry, BETA specifies the scalar beta. 06318 * 06319 * C (local input/local output) COMPLEX array 06320 * On entry, C is an array of dimension (DESCC( M_ ),*). This 06321 * array contains a local copy of the initial entire matrix PC. 06322 * 06323 * PC (local input) COMPLEX array 06324 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This 06325 * array contains the local pieces of the matrix PC. 06326 * 06327 * IC (global input) INTEGER 06328 * On entry, IC specifies C's global row index, which points to 06329 * the beginning of the submatrix sub( C ). 06330 * 06331 * JC (global input) INTEGER 06332 * On entry, JC specifies C's global column index, which points 06333 * to the beginning of the submatrix sub( C ). 06334 * 06335 * DESCC (global and local input) INTEGER array 06336 * On entry, DESCC is an integer array of dimension DLEN_. This 06337 * is the array descriptor for the matrix C. 06338 * 06339 * CT (workspace) COMPLEX array 06340 * On entry, CT is an array of dimension at least MAX(M,N,K). CT 06341 * holds a copy of the current column of C. 06342 * 06343 * G (workspace) REAL array 06344 * On entry, G is an array of dimension at least MAX(M,N,K). G 06345 * is used to compute the gauges. 06346 * 06347 * ERR (global output) REAL 06348 * On exit, ERR specifies the largest error in absolute value. 06349 * 06350 * INFO (global output) INTEGER 06351 * On exit, if INFO <> 0, the result is less than half accurate. 06352 * 06353 * -- Written on April 1, 1998 by 06354 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 06355 * 06356 * ===================================================================== 06357 * 06358 * .. Parameters .. 06359 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 06360 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 06361 $ RSRC_ 06362 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 06363 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 06364 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 06365 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 06366 REAL RZERO, RONE 06367 PARAMETER ( RZERO = 0.0E+0, RONE = 1.0E+0 ) 06368 COMPLEX ZERO 06369 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) 06370 * .. 06371 * .. Local Scalars .. 06372 LOGICAL COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER 06373 INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC, 06374 $ IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J, 06375 $ JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW, 06376 $ NPCOL, NPROW 06377 REAL EPS, ERRI 06378 COMPLEX Z 06379 * .. 06380 * .. External Subroutines .. 06381 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D 06382 * .. 06383 * .. External Functions .. 06384 LOGICAL LSAME 06385 REAL PSLAMCH 06386 EXTERNAL LSAME, PSLAMCH 06387 * .. 06388 * .. Intrinsic Functions .. 06389 INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT 06390 * .. 06391 * .. Statement Functions .. 06392 REAL ABS1 06393 ABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) 06394 * .. 06395 * .. Executable Statements .. 06396 * 06397 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 06398 * 06399 EPS = PSLAMCH( ICTXT, 'eps' ) 06400 * 06401 UPPER = LSAME( UPLO, 'U' ) 06402 HTRAN = LSAME( TRANS, 'H' ) 06403 NOTRAN = LSAME( TRANS, 'N' ) 06404 TRAN = LSAME( TRANS, 'T' ) 06405 * 06406 LDA = MAX( 1, DESCA( M_ ) ) 06407 LDB = MAX( 1, DESCB( M_ ) ) 06408 LDC = MAX( 1, DESCC( M_ ) ) 06409 * 06410 * Compute expected result in C using data in A, B and C. 06411 * Compute gauges in G. This part of the computation is performed 06412 * by every process in the grid. 06413 * 06414 DO 140 J = 1, N 06415 * 06416 IF( UPPER ) THEN 06417 IBEG = 1 06418 IEND = J 06419 ELSE 06420 IBEG = J 06421 IEND = N 06422 END IF 06423 * 06424 DO 10 I = 1, N 06425 CT( I ) = ZERO 06426 G( I ) = RZERO 06427 10 CONTINUE 06428 * 06429 IF( NOTRAN ) THEN 06430 DO 30 KK = 1, K 06431 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA 06432 IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB 06433 DO 20 I = IBEG, IEND 06434 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA 06435 IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB 06436 CT( I ) = CT( I ) + ALPHA * ( 06437 $ A( IOFFAN ) * B( IOFFBK ) + 06438 $ B( IOFFBN ) * A( IOFFAK ) ) 06439 G( I ) = G( I ) + ABS( ALPHA ) * ( 06440 $ ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) + 06441 $ ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) ) 06442 20 CONTINUE 06443 30 CONTINUE 06444 ELSE IF( TRAN ) THEN 06445 DO 50 KK = 1, K 06446 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA 06447 IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB 06448 DO 40 I = IBEG, IEND 06449 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA 06450 IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB 06451 CT( I ) = CT( I ) + ALPHA * ( 06452 $ A( IOFFAN ) * B( IOFFBK ) + 06453 $ B( IOFFBN ) * A( IOFFAK ) ) 06454 G( I ) = G( I ) + ABS( ALPHA ) * ( 06455 $ ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) + 06456 $ ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) ) 06457 40 CONTINUE 06458 50 CONTINUE 06459 ELSE IF( HTRAN ) THEN 06460 DO 70 KK = 1, K 06461 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA 06462 IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB 06463 DO 60 I = IBEG, IEND 06464 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA 06465 IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB 06466 CT( I ) = CT( I ) + 06467 $ ALPHA * A( IOFFAN ) * CONJG( B( IOFFBK ) ) + 06468 $ B( IOFFBN ) * CONJG( ALPHA * A( IOFFAK ) ) 06469 G( I ) = G( I ) + ABS1( ALPHA ) * ( 06470 $ ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) + 06471 $ ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) ) 06472 60 CONTINUE 06473 70 CONTINUE 06474 ELSE 06475 DO 90 KK = 1, K 06476 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA 06477 IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB 06478 DO 80 I = IBEG, IEND 06479 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA 06480 IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB 06481 CT( I ) = CT( I ) + 06482 $ ALPHA * CONJG( A( IOFFAN ) ) * B( IOFFBK ) + 06483 $ CONJG( ALPHA * B( IOFFBN ) ) * A( IOFFAK ) 06484 G( I ) = G( I ) + ABS1( ALPHA ) * ( 06485 $ ABS1( CONJG( A( IOFFAN ) ) * B( IOFFBK ) ) + 06486 $ ABS1( CONJG( B( IOFFBN ) ) * A( IOFFAK ) ) ) 06487 80 CONTINUE 06488 90 CONTINUE 06489 END IF 06490 * 06491 IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC 06492 * 06493 DO 100 I = IBEG, IEND 06494 CT( I ) = CT( I ) + BETA * C( IOFFC ) 06495 G( I ) = G( I ) + ABS1( BETA )*ABS1( C( IOFFC ) ) 06496 C( IOFFC ) = CT( I ) 06497 IOFFC = IOFFC + 1 06498 100 CONTINUE 06499 * 06500 * Compute the error ratio for this result. 06501 * 06502 ERR = RZERO 06503 INFO = 0 06504 LDPC = DESCC( LLD_ ) 06505 IOFFC = IC + ( JC + J - 2 ) * LDC 06506 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06507 $ IIC, JJC, ICROW, ICCOL ) 06508 ICURROW = ICROW 06509 ROWREP = ( ICROW.EQ.-1 ) 06510 COLREP = ( ICCOL.EQ.-1 ) 06511 * 06512 IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN 06513 * 06514 IBB = DESCC( IMB_ ) - IC + 1 06515 IF( IBB.LE.0 ) 06516 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB 06517 IBB = MIN( IBB, N ) 06518 IN = IC + IBB - 1 06519 * 06520 DO 110 I = IC, IN 06521 * 06522 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06523 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06524 $ C( IOFFC ) ) / EPS 06525 IF( G( I-IC+1 ).NE.RZERO ) 06526 $ ERRI = ERRI / G( I-IC+1 ) 06527 ERR = MAX( ERR, ERRI ) 06528 IF( ERR*SQRT( EPS ).GE.RONE ) 06529 $ INFO = 1 06530 IIC = IIC + 1 06531 END IF 06532 * 06533 IOFFC = IOFFC + 1 06534 * 06535 110 CONTINUE 06536 * 06537 ICURROW = MOD( ICURROW+1, NPROW ) 06538 * 06539 DO 130 I = IN+1, IC+N-1, DESCC( MB_ ) 06540 IBB = MIN( IC+N-I, DESCC( MB_ ) ) 06541 * 06542 DO 120 KK = 0, IBB-1 06543 * 06544 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06545 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06546 $ C( IOFFC ) )/EPS 06547 IF( G( I+KK-IC+1 ).NE.RZERO ) 06548 $ ERRI = ERRI / G( I+KK-IC+1 ) 06549 ERR = MAX( ERR, ERRI ) 06550 IF( ERR*SQRT( EPS ).GE.RONE ) 06551 $ INFO = 1 06552 IIC = IIC + 1 06553 END IF 06554 * 06555 IOFFC = IOFFC + 1 06556 * 06557 120 CONTINUE 06558 * 06559 ICURROW = MOD( ICURROW+1, NPROW ) 06560 * 06561 130 CONTINUE 06562 * 06563 END IF 06564 * 06565 * If INFO = 0, all results are at least half accurate. 06566 * 06567 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 06568 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 06569 $ MYCOL ) 06570 IF( INFO.NE.0 ) 06571 $ GO TO 150 06572 * 06573 140 CONTINUE 06574 * 06575 150 CONTINUE 06576 * 06577 RETURN 06578 * 06579 * End of PCMMCH2 06580 * 06581 END 06582 SUBROUTINE PCMMCH3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA, 06583 $ BETA, C, PC, IC, JC, DESCC, ERR, INFO ) 06584 * 06585 * -- PBLAS test routine (version 2.0) -- 06586 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 06587 * and University of California, Berkeley. 06588 * April 1, 1998 06589 * 06590 * .. Scalar Arguments .. 06591 CHARACTER*1 TRANS, UPLO 06592 INTEGER IA, IC, INFO, JA, JC, M, N 06593 REAL ERR 06594 COMPLEX ALPHA, BETA 06595 * .. 06596 * .. Array Arguments .. 06597 INTEGER DESCA( * ), DESCC( * ) 06598 COMPLEX A( * ), C( * ), PC( * ) 06599 * .. 06600 * 06601 * Purpose 06602 * ======= 06603 * 06604 * PCMMCH3 checks the results of the computational tests. 06605 * 06606 * Notes 06607 * ===== 06608 * 06609 * A description vector is associated with each 2D block-cyclicly dis- 06610 * tributed matrix. This vector stores the information required to 06611 * establish the mapping between a matrix entry and its corresponding 06612 * process and memory location. 06613 * 06614 * In the following comments, the character _ should be read as 06615 * "of the distributed matrix". Let A be a generic term for any 2D 06616 * block cyclicly distributed matrix. Its description vector is DESCA: 06617 * 06618 * NOTATION STORED IN EXPLANATION 06619 * ---------------- --------------- ------------------------------------ 06620 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 06621 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 06622 * the NPROW x NPCOL BLACS process grid 06623 * A is distributed over. The context 06624 * itself is global, but the handle 06625 * (the integer value) may vary. 06626 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 06627 * ted matrix A, M_A >= 0. 06628 * N_A (global) DESCA( N_ ) The number of columns in the distri- 06629 * buted matrix A, N_A >= 0. 06630 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 06631 * block of the matrix A, IMB_A > 0. 06632 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 06633 * left block of the matrix A, 06634 * INB_A > 0. 06635 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 06636 * bute the last M_A-IMB_A rows of A, 06637 * MB_A > 0. 06638 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 06639 * bute the last N_A-INB_A columns of 06640 * A, NB_A > 0. 06641 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 06642 * row of the matrix A is distributed, 06643 * NPROW > RSRC_A >= 0. 06644 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 06645 * first column of A is distributed. 06646 * NPCOL > CSRC_A >= 0. 06647 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 06648 * array storing the local blocks of 06649 * the distributed matrix A, 06650 * IF( Lc( 1, N_A ) > 0 ) 06651 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 06652 * ELSE 06653 * LLD_A >= 1. 06654 * 06655 * Let K be the number of rows of a matrix A starting at the global in- 06656 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 06657 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 06658 * receive if these K rows were distributed over NPROW processes. If K 06659 * is the number of columns of a matrix A starting at the global index 06660 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 06661 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 06662 * these K columns were distributed over NPCOL processes. 06663 * 06664 * The values of Lr() and Lc() may be determined via a call to the func- 06665 * tion PB_NUMROC: 06666 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 06667 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 06668 * 06669 * Arguments 06670 * ========= 06671 * 06672 * UPLO (global input) CHARACTER*1 06673 * On entry, UPLO specifies which part of C should contain the 06674 * result. 06675 * 06676 * TRANS (global input) CHARACTER*1 06677 * On entry, TRANS specifies whether the matrix A has to be 06678 * transposed or not before computing the matrix-matrix addi- 06679 * tion. 06680 * 06681 * M (global input) INTEGER 06682 * On entry, M specifies the number of rows of C. 06683 * 06684 * N (global input) INTEGER 06685 * On entry, N specifies the number of columns of C. 06686 * 06687 * ALPHA (global input) COMPLEX 06688 * On entry, ALPHA specifies the scalar alpha. 06689 * 06690 * A (local input) COMPLEX array 06691 * On entry, A is an array of dimension (DESCA( M_ ),*). This 06692 * array contains a local copy of the initial entire matrix PA. 06693 * 06694 * IA (global input) INTEGER 06695 * On entry, IA specifies A's global row index, which points to 06696 * the beginning of the submatrix sub( A ). 06697 * 06698 * JA (global input) INTEGER 06699 * On entry, JA specifies A's global column index, which points 06700 * to the beginning of the submatrix sub( A ). 06701 * 06702 * DESCA (global and local input) INTEGER array 06703 * On entry, DESCA is an integer array of dimension DLEN_. This 06704 * is the array descriptor for the matrix A. 06705 * 06706 * BETA (global input) COMPLEX 06707 * On entry, BETA specifies the scalar beta. 06708 * 06709 * C (local input/local output) COMPLEX array 06710 * On entry, C is an array of dimension (DESCC( M_ ),*). This 06711 * array contains a local copy of the initial entire matrix PC. 06712 * 06713 * PC (local input) COMPLEX array 06714 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This 06715 * array contains the local pieces of the matrix PC. 06716 * 06717 * IC (global input) INTEGER 06718 * On entry, IC specifies C's global row index, which points to 06719 * the beginning of the submatrix sub( C ). 06720 * 06721 * JC (global input) INTEGER 06722 * On entry, JC specifies C's global column index, which points 06723 * to the beginning of the submatrix sub( C ). 06724 * 06725 * DESCC (global and local input) INTEGER array 06726 * On entry, DESCC is an integer array of dimension DLEN_. This 06727 * is the array descriptor for the matrix C. 06728 * 06729 * ERR (global output) REAL 06730 * On exit, ERR specifies the largest error in absolute value. 06731 * 06732 * INFO (global output) INTEGER 06733 * On exit, if INFO <> 0, the result is less than half accurate. 06734 * 06735 * -- Written on April 1, 1998 by 06736 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 06737 * 06738 * ===================================================================== 06739 * 06740 * .. Parameters .. 06741 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 06742 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 06743 $ RSRC_ 06744 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 06745 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 06746 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 06747 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 06748 REAL ZERO 06749 PARAMETER ( ZERO = 0.0E+0 ) 06750 * .. 06751 * .. Local Scalars .. 06752 LOGICAL COLREP, CTRAN, LOWER, NOTRAN, ROWREP, UPPER 06753 INTEGER I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J, 06754 $ JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL, 06755 $ NPROW 06756 REAL ERR0, ERRI, PREC 06757 * .. 06758 * .. External Subroutines .. 06759 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, 06760 $ PCERRAXPBY, SGAMX2D 06761 * .. 06762 * .. External Functions .. 06763 LOGICAL LSAME 06764 REAL PSLAMCH 06765 EXTERNAL LSAME, PSLAMCH 06766 * .. 06767 * .. Intrinsic Functions .. 06768 INTRINSIC ABS, CONJG, MAX 06769 * .. 06770 * .. Executable Statements .. 06771 * 06772 ICTXT = DESCC( CTXT_ ) 06773 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 06774 * 06775 PREC = PSLAMCH( ICTXT, 'eps' ) 06776 * 06777 UPPER = LSAME( UPLO, 'U' ) 06778 LOWER = LSAME( UPLO, 'L' ) 06779 NOTRAN = LSAME( TRANS, 'N' ) 06780 CTRAN = LSAME( TRANS, 'C' ) 06781 * 06782 * Compute expected result in C using data in A and C. This part of 06783 * the computation is performed by every process in the grid. 06784 * 06785 INFO = 0 06786 ERR = ZERO 06787 * 06788 LDA = MAX( 1, DESCA( M_ ) ) 06789 LDC = MAX( 1, DESCC( M_ ) ) 06790 LDPC = MAX( 1, DESCC( LLD_ ) ) 06791 ROWREP = ( DESCC( RSRC_ ).EQ.-1 ) 06792 COLREP = ( DESCC( CSRC_ ).EQ.-1 ) 06793 * 06794 IF( NOTRAN ) THEN 06795 * 06796 DO 20 J = JC, JC + N - 1 06797 * 06798 IOFFC = IC + ( J - 1 ) * LDC 06799 IOFFA = IA + ( JA - 1 + J - JC ) * LDA 06800 * 06801 DO 10 I = IC, IC + M - 1 06802 * 06803 IF( UPPER ) THEN 06804 IF( ( J - JC ).GE.( I - IC ) ) THEN 06805 CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06806 $ C( IOFFC ), PREC ) 06807 ELSE 06808 ERRI = ZERO 06809 END IF 06810 ELSE IF( LOWER ) THEN 06811 IF( ( J - JC ).LE.( I - IC ) ) THEN 06812 CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06813 $ C( IOFFC ), PREC ) 06814 ELSE 06815 ERRI = ZERO 06816 END IF 06817 ELSE 06818 CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06819 $ C( IOFFC ), PREC ) 06820 END IF 06821 * 06822 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06823 $ IIC, JJC, ICROW, ICCOL ) 06824 IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND. 06825 $ ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN 06826 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) ) 06827 IF( ERR0.GT.ERRI ) 06828 $ INFO = 1 06829 ERR = MAX( ERR, ERR0 ) 06830 END IF 06831 * 06832 IOFFA = IOFFA + 1 06833 IOFFC = IOFFC + 1 06834 * 06835 10 CONTINUE 06836 * 06837 20 CONTINUE 06838 * 06839 ELSE IF( CTRAN ) THEN 06840 * 06841 DO 40 J = JC, JC + N - 1 06842 * 06843 IOFFC = IC + ( J - 1 ) * LDC 06844 IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA 06845 * 06846 DO 30 I = IC, IC + M - 1 06847 * 06848 IF( UPPER ) THEN 06849 IF( ( J - JC ).GE.( I - IC ) ) THEN 06850 CALL PCERRAXPBY( ERRI, ALPHA, CONJG( A( IOFFA ) ), 06851 $ BETA, C( IOFFC ), PREC ) 06852 ELSE 06853 ERRI = ZERO 06854 END IF 06855 ELSE IF( LOWER ) THEN 06856 IF( ( J - JC ).LE.( I - IC ) ) THEN 06857 CALL PCERRAXPBY( ERRI, ALPHA, CONJG( A( IOFFA ) ), 06858 $ BETA, C( IOFFC ), PREC ) 06859 ELSE 06860 ERRI = ZERO 06861 END IF 06862 ELSE 06863 CALL PCERRAXPBY( ERRI, ALPHA, CONJG( A( IOFFA ) ), 06864 $ BETA, C( IOFFC ), PREC ) 06865 END IF 06866 * 06867 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06868 $ IIC, JJC, ICROW, ICCOL ) 06869 IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND. 06870 $ ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN 06871 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) ) 06872 IF( ERR0.GT.ERRI ) 06873 $ INFO = 1 06874 ERR = MAX( ERR, ERR0 ) 06875 END IF 06876 * 06877 IOFFC = IOFFC + 1 06878 IOFFA = IOFFA + LDA 06879 * 06880 30 CONTINUE 06881 * 06882 40 CONTINUE 06883 * 06884 ELSE 06885 * 06886 DO 60 J = JC, JC + N - 1 06887 * 06888 IOFFC = IC + ( J - 1 ) * LDC 06889 IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA 06890 * 06891 DO 50 I = IC, IC + M - 1 06892 * 06893 IF( UPPER ) THEN 06894 IF( ( J - JC ).GE.( I - IC ) ) THEN 06895 CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06896 $ C( IOFFC ), PREC ) 06897 ELSE 06898 ERRI = ZERO 06899 END IF 06900 ELSE IF( LOWER ) THEN 06901 IF( ( J - JC ).LE.( I - IC ) ) THEN 06902 CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06903 $ C( IOFFC ), PREC ) 06904 ELSE 06905 ERRI = ZERO 06906 END IF 06907 ELSE 06908 CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06909 $ C( IOFFC ), PREC ) 06910 END IF 06911 * 06912 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06913 $ IIC, JJC, ICROW, ICCOL ) 06914 IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND. 06915 $ ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN 06916 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) ) 06917 IF( ERR0.GT.ERRI ) 06918 $ INFO = 1 06919 ERR = MAX( ERR, ERR0 ) 06920 END IF 06921 * 06922 IOFFC = IOFFC + 1 06923 IOFFA = IOFFA + LDA 06924 * 06925 50 CONTINUE 06926 * 06927 60 CONTINUE 06928 * 06929 END IF 06930 * 06931 * If INFO = 0, all results are at least half accurate. 06932 * 06933 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 06934 CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 06935 $ MYCOL ) 06936 * 06937 RETURN 06938 * 06939 * End of PCMMCH3 06940 * 06941 END 06942 SUBROUTINE PCERRAXPBY( ERRBND, ALPHA, X, BETA, Y, PREC ) 06943 * 06944 * -- PBLAS test routine (version 2.0) -- 06945 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 06946 * and University of California, Berkeley. 06947 * April 1, 1998 06948 * 06949 * .. Scalar Arguments .. 06950 REAL ERRBND, PREC 06951 COMPLEX ALPHA, BETA, X, Y 06952 * .. 06953 * 06954 * Purpose 06955 * ======= 06956 * 06957 * PCERRAXPBY serially computes y := beta*y + alpha * x and returns a 06958 * scaled relative acceptable error bound on the result. 06959 * 06960 * Arguments 06961 * ========= 06962 * 06963 * ERRBND (global output) REAL 06964 * On exit, ERRBND specifies the scaled relative acceptable er- 06965 * ror bound. 06966 * 06967 * ALPHA (global input) COMPLEX 06968 * On entry, ALPHA specifies the scalar alpha. 06969 * 06970 * X (global input) COMPLEX 06971 * On entry, X specifies the scalar x to be scaled. 06972 * 06973 * BETA (global input) COMPLEX 06974 * On entry, BETA specifies the scalar beta. 06975 * 06976 * Y (global input/global output) COMPLEX 06977 * On entry, Y specifies the scalar y to be added. On exit, Y 06978 * contains the resulting scalar y. 06979 * 06980 * PREC (global input) REAL 06981 * On entry, PREC specifies the machine precision. 06982 * 06983 * -- Written on April 1, 1998 by 06984 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 06985 * 06986 * ===================================================================== 06987 * 06988 * .. Parameters .. 06989 REAL ONE, TWO, ZERO 06990 PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, 06991 $ ZERO = 0.0E+0 ) 06992 * .. 06993 * .. Local Scalars .. 06994 REAL ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG, 06995 $ SUMRPOS 06996 COMPLEX TMP 06997 * .. 06998 * .. Intrinsic Functions .. 06999 * .. 07000 * .. Executable Statements .. 07001 * 07002 SUMIPOS = ZERO 07003 SUMINEG = ZERO 07004 SUMRPOS = ZERO 07005 SUMRNEG = ZERO 07006 FACT = ONE + TWO * PREC 07007 ADDBND = TWO * TWO * TWO * PREC 07008 * 07009 TMP = ALPHA * X 07010 IF( REAL( TMP ).GE.ZERO ) THEN 07011 SUMRPOS = SUMRPOS + REAL( TMP ) * FACT 07012 ELSE 07013 SUMRNEG = SUMRNEG - REAL( TMP ) * FACT 07014 END IF 07015 IF( AIMAG( TMP ).GE.ZERO ) THEN 07016 SUMIPOS = SUMIPOS + AIMAG( TMP ) * FACT 07017 ELSE 07018 SUMINEG = SUMINEG - AIMAG( TMP ) * FACT 07019 END IF 07020 * 07021 TMP = BETA * Y 07022 IF( REAL( TMP ).GE.ZERO ) THEN 07023 SUMRPOS = SUMRPOS + REAL( TMP ) * FACT 07024 ELSE 07025 SUMRNEG = SUMRNEG - REAL( TMP ) * FACT 07026 END IF 07027 IF( AIMAG( TMP ).GE.ZERO ) THEN 07028 SUMIPOS = SUMIPOS + AIMAG( TMP ) * FACT 07029 ELSE 07030 SUMINEG = SUMINEG - AIMAG( TMP ) * FACT 07031 END IF 07032 * 07033 Y = ( BETA * Y ) + ( ALPHA * X ) 07034 * 07035 ERRBND = ADDBND * MAX( MAX( SUMRPOS, SUMRNEG ), 07036 $ MAX( SUMIPOS, SUMINEG ) ) 07037 * 07038 RETURN 07039 * 07040 * End of PCERRAXPBY 07041 * 07042 END 07043 SUBROUTINE PCIPSET( TOGGLE, N, A, IA, JA, DESCA ) 07044 * 07045 * -- PBLAS test routine (version 2.0) -- 07046 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07047 * and University of California, Berkeley. 07048 * April 1, 1998 07049 * 07050 * .. Scalar Arguments .. 07051 CHARACTER*1 TOGGLE 07052 INTEGER IA, JA, N 07053 * .. 07054 * .. Array Arguments .. 07055 INTEGER DESCA( * ) 07056 COMPLEX A( * ) 07057 * .. 07058 * 07059 * Purpose 07060 * ======= 07061 * 07062 * PCIPSET sets the imaginary part of the diagonal entries of an n by n 07063 * matrix sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ). This is used to 07064 * test the PBLAS routines for complex Hermitian matrices, which are 07065 * either not supposed to access or use the imaginary parts of the dia- 07066 * gonals, or supposed to set them to zero. The value used to set the 07067 * imaginary part of the diagonals depends on the value of TOGGLE. 07068 * 07069 * Notes 07070 * ===== 07071 * 07072 * A description vector is associated with each 2D block-cyclicly dis- 07073 * tributed matrix. This vector stores the information required to 07074 * establish the mapping between a matrix entry and its corresponding 07075 * process and memory location. 07076 * 07077 * In the following comments, the character _ should be read as 07078 * "of the distributed matrix". Let A be a generic term for any 2D 07079 * block cyclicly distributed matrix. Its description vector is DESCA: 07080 * 07081 * NOTATION STORED IN EXPLANATION 07082 * ---------------- --------------- ------------------------------------ 07083 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 07084 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 07085 * the NPROW x NPCOL BLACS process grid 07086 * A is distributed over. The context 07087 * itself is global, but the handle 07088 * (the integer value) may vary. 07089 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 07090 * ted matrix A, M_A >= 0. 07091 * N_A (global) DESCA( N_ ) The number of columns in the distri- 07092 * buted matrix A, N_A >= 0. 07093 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 07094 * block of the matrix A, IMB_A > 0. 07095 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 07096 * left block of the matrix A, 07097 * INB_A > 0. 07098 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 07099 * bute the last M_A-IMB_A rows of A, 07100 * MB_A > 0. 07101 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 07102 * bute the last N_A-INB_A columns of 07103 * A, NB_A > 0. 07104 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 07105 * row of the matrix A is distributed, 07106 * NPROW > RSRC_A >= 0. 07107 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 07108 * first column of A is distributed. 07109 * NPCOL > CSRC_A >= 0. 07110 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 07111 * array storing the local blocks of 07112 * the distributed matrix A, 07113 * IF( Lc( 1, N_A ) > 0 ) 07114 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 07115 * ELSE 07116 * LLD_A >= 1. 07117 * 07118 * Let K be the number of rows of a matrix A starting at the global in- 07119 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 07120 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 07121 * receive if these K rows were distributed over NPROW processes. If K 07122 * is the number of columns of a matrix A starting at the global index 07123 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 07124 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 07125 * these K columns were distributed over NPCOL processes. 07126 * 07127 * The values of Lr() and Lc() may be determined via a call to the func- 07128 * tion PB_NUMROC: 07129 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 07130 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 07131 * 07132 * Arguments 07133 * ========= 07134 * 07135 * TOGGLE (global input) CHARACTER*1 07136 * On entry, TOGGLE specifies the set-value to be used as fol- 07137 * lows: 07138 * If TOGGLE = 'Z' or 'z', the imaginary part of the diago- 07139 * nals are set to zero, 07140 * If TOGGLE = 'B' or 'b', the imaginary part of the diago- 07141 * nals are set to a large value. 07142 * 07143 * N (global input) INTEGER 07144 * On entry, N specifies the order of sub( A ). N must be at 07145 * least zero. 07146 * 07147 * A (local input/local output) pointer to COMPLEX 07148 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 07149 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 07150 * the local entries of the matrix A. On exit, the diagonals of 07151 * sub( A ) have been updated as specified by TOGGLE. 07152 * 07153 * IA (global input) INTEGER 07154 * On entry, IA specifies A's global row index, which points to 07155 * the beginning of the submatrix sub( A ). 07156 * 07157 * JA (global input) INTEGER 07158 * On entry, JA specifies A's global column index, which points 07159 * to the beginning of the submatrix sub( A ). 07160 * 07161 * DESCA (global and local input) INTEGER array 07162 * On entry, DESCA is an integer array of dimension DLEN_. This 07163 * is the array descriptor for the matrix A. 07164 * 07165 * -- Written on April 1, 1998 by 07166 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 07167 * 07168 * ===================================================================== 07169 * 07170 * .. Parameters .. 07171 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 07172 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 07173 $ RSRC_ 07174 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 07175 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 07176 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 07177 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 07178 REAL ZERO 07179 PARAMETER ( ZERO = 0.0E+0 ) 07180 * .. 07181 * .. Local Scalars .. 07182 LOGICAL COLREP, GODOWN, GOLEFT, ROWREP 07183 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW, 07184 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, 07185 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1, 07186 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC, 07187 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS, 07188 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP 07189 REAL ALPHA, ATMP 07190 * .. 07191 * .. Local Arrays .. 07192 INTEGER DESCA2( DLEN_ ) 07193 * .. 07194 * .. External Subroutines .. 07195 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 07196 $ PB_DESCTRANS 07197 * .. 07198 * .. External Functions .. 07199 LOGICAL LSAME 07200 REAL PSLAMCH 07201 EXTERNAL LSAME, PSLAMCH 07202 * .. 07203 * .. Intrinsic Functions .. 07204 INTRINSIC CMPLX, MAX, MIN, REAL 07205 * .. 07206 * .. Executable Statements .. 07207 * 07208 * Convert descriptor 07209 * 07210 CALL PB_DESCTRANS( DESCA, DESCA2 ) 07211 * 07212 * Get grid parameters 07213 * 07214 ICTXT = DESCA2( CTXT_ ) 07215 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 07216 * 07217 IF( N.LE.0 ) 07218 $ RETURN 07219 * 07220 IF( LSAME( TOGGLE, 'Z' ) ) THEN 07221 ALPHA = ZERO 07222 ELSE IF( LSAME( TOGGLE, 'B' ) ) THEN 07223 ALPHA = PSLAMCH( ICTXT, 'Epsilon' ) 07224 ALPHA = ALPHA / PSLAMCH( ICTXT, 'Safe minimum' ) 07225 END IF 07226 * 07227 CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 07228 $ MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW, 07229 $ IACOL, MRROW, MRCOL ) 07230 * 07231 IF( NP.LE.0 .OR. NQ.LE.0 ) 07232 $ RETURN 07233 * 07234 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 07235 * ILOW, LOW, IUPP, and UPP. 07236 * 07237 MB = DESCA2( MB_ ) 07238 NB = DESCA2( NB_ ) 07239 CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL, 07240 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 07241 $ LNBLOC, ILOW, LOW, IUPP, UPP ) 07242 * 07243 IOFFA = IIA - 1 07244 JOFFA = JJA - 1 07245 ROWREP = ( DESCA2( RSRC_ ).EQ.-1 ) 07246 COLREP = ( DESCA2( CSRC_ ).EQ.-1 ) 07247 LDA = DESCA2( LLD_ ) 07248 LDAP1 = LDA + 1 07249 * 07250 IF( ROWREP ) THEN 07251 PMB = MB 07252 ELSE 07253 PMB = NPROW * MB 07254 END IF 07255 IF( COLREP ) THEN 07256 QNB = NB 07257 ELSE 07258 QNB = NPCOL * NB 07259 END IF 07260 * 07261 * Handle the first block of rows or columns separately, and update 07262 * LCMT00, MBLKS and NBLKS. 07263 * 07264 GODOWN = ( LCMT00.GT.IUPP ) 07265 GOLEFT = ( LCMT00.LT.ILOW ) 07266 * 07267 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 07268 * 07269 * LCMT00 >= ILOW && LCMT00 <= IUPP 07270 * 07271 IF( LCMT00.GE.0 ) THEN 07272 IJOFFA = IOFFA + LCMT00 + ( JOFFA - 1 ) * LDA 07273 DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) ) 07274 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07275 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07276 10 CONTINUE 07277 ELSE 07278 IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA 07279 DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) ) 07280 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07281 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07282 20 CONTINUE 07283 END IF 07284 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 07285 GODOWN = .NOT.GOLEFT 07286 * 07287 END IF 07288 * 07289 IF( GODOWN ) THEN 07290 * 07291 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07292 MBLKS = MBLKS - 1 07293 IOFFA = IOFFA + IMBLOC 07294 * 07295 30 CONTINUE 07296 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07297 LCMT00 = LCMT00 - PMB 07298 MBLKS = MBLKS - 1 07299 IOFFA = IOFFA + MB 07300 GO TO 30 07301 END IF 07302 * 07303 IF( MBLKS.LE.0 ) 07304 $ RETURN 07305 * 07306 LCMT = LCMT00 07307 MBLKD = MBLKS 07308 IOFFD = IOFFA 07309 * 07310 MBLOC = MB 07311 40 CONTINUE 07312 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 07313 IF( MBLKD.EQ.1 ) 07314 $ MBLOC = LMBLOC 07315 IF( LCMT.GE.0 ) THEN 07316 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 07317 DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) ) 07318 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07319 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07320 50 CONTINUE 07321 ELSE 07322 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 07323 DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) ) 07324 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07325 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07326 60 CONTINUE 07327 END IF 07328 LCMT00 = LCMT 07329 LCMT = LCMT - PMB 07330 MBLKS = MBLKD 07331 MBLKD = MBLKD - 1 07332 IOFFA = IOFFD 07333 IOFFD = IOFFD + MBLOC 07334 GO TO 40 07335 END IF 07336 * 07337 LCMT00 = LCMT00 + LOW - ILOW + QNB 07338 NBLKS = NBLKS - 1 07339 JOFFA = JOFFA + INBLOC 07340 * 07341 ELSE IF( GOLEFT ) THEN 07342 * 07343 LCMT00 = LCMT00 + LOW - ILOW + QNB 07344 NBLKS = NBLKS - 1 07345 JOFFA = JOFFA + INBLOC 07346 * 07347 70 CONTINUE 07348 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 07349 LCMT00 = LCMT00 + QNB 07350 NBLKS = NBLKS - 1 07351 JOFFA = JOFFA + NB 07352 GO TO 70 07353 END IF 07354 * 07355 IF( NBLKS.LE.0 ) 07356 $ RETURN 07357 * 07358 LCMT = LCMT00 07359 NBLKD = NBLKS 07360 JOFFD = JOFFA 07361 * 07362 NBLOC = NB 07363 80 CONTINUE 07364 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 07365 IF( NBLKD.EQ.1 ) 07366 $ NBLOC = LNBLOC 07367 IF( LCMT.GE.0 ) THEN 07368 IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA 07369 DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) ) 07370 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07371 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07372 90 CONTINUE 07373 ELSE 07374 IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA 07375 DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) ) 07376 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07377 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07378 100 CONTINUE 07379 END IF 07380 LCMT00 = LCMT 07381 LCMT = LCMT + QNB 07382 NBLKS = NBLKD 07383 NBLKD = NBLKD - 1 07384 JOFFA = JOFFD 07385 JOFFD = JOFFD + NBLOC 07386 GO TO 80 07387 END IF 07388 * 07389 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07390 MBLKS = MBLKS - 1 07391 IOFFA = IOFFA + IMBLOC 07392 * 07393 END IF 07394 * 07395 NBLOC = NB 07396 110 CONTINUE 07397 IF( NBLKS.GT.0 ) THEN 07398 IF( NBLKS.EQ.1 ) 07399 $ NBLOC = LNBLOC 07400 120 CONTINUE 07401 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07402 LCMT00 = LCMT00 - PMB 07403 MBLKS = MBLKS - 1 07404 IOFFA = IOFFA + MB 07405 GO TO 120 07406 END IF 07407 * 07408 IF( MBLKS.LE.0 ) 07409 $ RETURN 07410 * 07411 LCMT = LCMT00 07412 MBLKD = MBLKS 07413 IOFFD = IOFFA 07414 * 07415 MBLOC = MB 07416 130 CONTINUE 07417 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 07418 IF( MBLKD.EQ.1 ) 07419 $ MBLOC = LMBLOC 07420 IF( LCMT.GE.0 ) THEN 07421 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 07422 DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) ) 07423 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07424 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07425 140 CONTINUE 07426 ELSE 07427 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 07428 DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) ) 07429 ATMP = REAL( A( IJOFFA + I*LDAP1 ) ) 07430 A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA ) 07431 150 CONTINUE 07432 END IF 07433 LCMT00 = LCMT 07434 LCMT = LCMT - PMB 07435 MBLKS = MBLKD 07436 MBLKD = MBLKD - 1 07437 IOFFA = IOFFD 07438 IOFFD = IOFFD + MBLOC 07439 GO TO 130 07440 END IF 07441 * 07442 LCMT00 = LCMT00 + QNB 07443 NBLKS = NBLKS - 1 07444 JOFFA = JOFFA + NBLOC 07445 GO TO 110 07446 * 07447 END IF 07448 * 07449 RETURN 07450 * 07451 * End of PCIPSET 07452 * 07453 END 07454 REAL FUNCTION PSLAMCH( ICTXT, CMACH ) 07455 * 07456 * -- PBLAS test routine (version 2.0) -- 07457 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07458 * and University of California, Berkeley. 07459 * April 1, 1998 07460 * 07461 * .. Scalar Arguments .. 07462 CHARACTER*1 CMACH 07463 INTEGER ICTXT 07464 * .. 07465 * 07466 * Purpose 07467 * ======= 07468 * 07469 * 07470 * .. Local Scalars .. 07471 CHARACTER*1 TOP 07472 INTEGER IDUMM 07473 REAL TEMP 07474 * .. 07475 * .. External Subroutines .. 07476 EXTERNAL PB_TOPGET, SGAMN2D, SGAMX2D 07477 * .. 07478 * .. External Functions .. 07479 LOGICAL LSAME 07480 REAL SLAMCH 07481 EXTERNAL LSAME, SLAMCH 07482 * .. 07483 * .. Executable Statements .. 07484 * 07485 TEMP = SLAMCH( CMACH ) 07486 * 07487 IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR. 07488 $ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN 07489 CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP ) 07490 IDUMM = 0 07491 CALL SGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM, 07492 $ IDUMM, -1, -1, IDUMM ) 07493 ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN 07494 CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP ) 07495 IDUMM = 0 07496 CALL SGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM, 07497 $ IDUMM, -1, -1, IDUMM ) 07498 END IF 07499 * 07500 PSLAMCH = TEMP 07501 * 07502 RETURN 07503 * 07504 * End of PSLAMCH 07505 * 07506 END 07507 SUBROUTINE PCLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) 07508 * 07509 * -- PBLAS test routine (version 2.0) -- 07510 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07511 * and University of California, Berkeley. 07512 * April 1, 1998 07513 * 07514 * .. Scalar Arguments .. 07515 CHARACTER*1 UPLO 07516 INTEGER IA, JA, M, N 07517 COMPLEX ALPHA, BETA 07518 * .. 07519 * .. Array Arguments .. 07520 INTEGER DESCA( * ) 07521 COMPLEX A( * ) 07522 * .. 07523 * 07524 * Purpose 07525 * ======= 07526 * 07527 * PCLASET initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno- 07528 * ted by sub( A ) to beta on the diagonal and alpha on the offdiago- 07529 * nals. 07530 * 07531 * Notes 07532 * ===== 07533 * 07534 * A description vector is associated with each 2D block-cyclicly dis- 07535 * tributed matrix. This vector stores the information required to 07536 * establish the mapping between a matrix entry and its corresponding 07537 * process and memory location. 07538 * 07539 * In the following comments, the character _ should be read as 07540 * "of the distributed matrix". Let A be a generic term for any 2D 07541 * block cyclicly distributed matrix. Its description vector is DESCA: 07542 * 07543 * NOTATION STORED IN EXPLANATION 07544 * ---------------- --------------- ------------------------------------ 07545 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 07546 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 07547 * the NPROW x NPCOL BLACS process grid 07548 * A is distributed over. The context 07549 * itself is global, but the handle 07550 * (the integer value) may vary. 07551 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 07552 * ted matrix A, M_A >= 0. 07553 * N_A (global) DESCA( N_ ) The number of columns in the distri- 07554 * buted matrix A, N_A >= 0. 07555 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 07556 * block of the matrix A, IMB_A > 0. 07557 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 07558 * left block of the matrix A, 07559 * INB_A > 0. 07560 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 07561 * bute the last M_A-IMB_A rows of A, 07562 * MB_A > 0. 07563 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 07564 * bute the last N_A-INB_A columns of 07565 * A, NB_A > 0. 07566 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 07567 * row of the matrix A is distributed, 07568 * NPROW > RSRC_A >= 0. 07569 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 07570 * first column of A is distributed. 07571 * NPCOL > CSRC_A >= 0. 07572 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 07573 * array storing the local blocks of 07574 * the distributed matrix A, 07575 * IF( Lc( 1, N_A ) > 0 ) 07576 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 07577 * ELSE 07578 * LLD_A >= 1. 07579 * 07580 * Let K be the number of rows of a matrix A starting at the global in- 07581 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 07582 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 07583 * receive if these K rows were distributed over NPROW processes. If K 07584 * is the number of columns of a matrix A starting at the global index 07585 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 07586 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 07587 * these K columns were distributed over NPCOL processes. 07588 * 07589 * The values of Lr() and Lc() may be determined via a call to the func- 07590 * tion PB_NUMROC: 07591 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 07592 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 07593 * 07594 * Arguments 07595 * ========= 07596 * 07597 * UPLO (global input) CHARACTER*1 07598 * On entry, UPLO specifies the part of the submatrix sub( A ) 07599 * to be set: 07600 * = 'L' or 'l': Lower triangular part is set; the strictly 07601 * upper triangular part of sub( A ) is not changed; 07602 * = 'U' or 'u': Upper triangular part is set; the strictly 07603 * lower triangular part of sub( A ) is not changed; 07604 * Otherwise: All of the matrix sub( A ) is set. 07605 * 07606 * M (global input) INTEGER 07607 * On entry, M specifies the number of rows of the submatrix 07608 * sub( A ). M must be at least zero. 07609 * 07610 * N (global input) INTEGER 07611 * On entry, N specifies the number of columns of the submatrix 07612 * sub( A ). N must be at least zero. 07613 * 07614 * ALPHA (global input) COMPLEX 07615 * On entry, ALPHA specifies the scalar alpha, i.e., the cons- 07616 * tant to which the offdiagonal elements are to be set. 07617 * 07618 * BETA (global input) COMPLEX 07619 * On entry, BETA specifies the scalar beta, i.e., the constant 07620 * to which the diagonal elements are to be set. 07621 * 07622 * A (local input/local output) COMPLEX array 07623 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 07624 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 07625 * the local entries of the matrix A to be set. On exit, the 07626 * leading m by n submatrix sub( A ) is set as follows: 07627 * 07628 * if UPLO = 'U', A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N, 07629 * if UPLO = 'L', A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N, 07630 * otherwise, A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M, 1<=j<=N, 07631 * and IA+i.NE.JA+j, 07632 * and, for all UPLO, A(IA+i-1,JA+i-1) = BETA, 1<=i<=min(M,N). 07633 * 07634 * IA (global input) INTEGER 07635 * On entry, IA specifies A's global row index, which points to 07636 * the beginning of the submatrix sub( A ). 07637 * 07638 * JA (global input) INTEGER 07639 * On entry, JA specifies A's global column index, which points 07640 * to the beginning of the submatrix sub( A ). 07641 * 07642 * DESCA (global and local input) INTEGER array 07643 * On entry, DESCA is an integer array of dimension DLEN_. This 07644 * is the array descriptor for the matrix A. 07645 * 07646 * -- Written on April 1, 1998 by 07647 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 07648 * 07649 * ===================================================================== 07650 * 07651 * .. Parameters .. 07652 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 07653 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 07654 $ RSRC_ 07655 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 07656 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 07657 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 07658 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 07659 * .. 07660 * .. Local Scalars .. 07661 LOGICAL GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER, 07662 $ UPPER 07663 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1, 07664 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA, 07665 $ JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC, 07666 $ LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP, 07667 $ MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD, 07668 $ NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1, 07669 $ UPP 07670 * .. 07671 * .. Local Arrays .. 07672 INTEGER DESCA2( DLEN_ ) 07673 * .. 07674 * .. External Subroutines .. 07675 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 07676 $ PB_CLASET, PB_DESCTRANS 07677 * .. 07678 * .. External Functions .. 07679 LOGICAL LSAME 07680 EXTERNAL LSAME 07681 * .. 07682 * .. Intrinsic Functions .. 07683 INTRINSIC MIN 07684 * .. 07685 * .. Executable Statements .. 07686 * 07687 IF( M.EQ.0 .OR. N.EQ.0 ) 07688 $ RETURN 07689 * 07690 * Convert descriptor 07691 * 07692 CALL PB_DESCTRANS( DESCA, DESCA2 ) 07693 * 07694 * Get grid parameters 07695 * 07696 ICTXT = DESCA2( CTXT_ ) 07697 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 07698 * 07699 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 07700 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW, 07701 $ IACOL, MRROW, MRCOL ) 07702 * 07703 IF( MP.LE.0 .OR. NQ.LE.0 ) 07704 $ RETURN 07705 * 07706 ISROWREP = ( DESCA2( RSRC_ ).LT.0 ) 07707 ISCOLREP = ( DESCA2( CSRC_ ).LT.0 ) 07708 LDA = DESCA2( LLD_ ) 07709 * 07710 UPPER = .NOT.( LSAME( UPLO, 'L' ) ) 07711 LOWER = .NOT.( LSAME( UPLO, 'U' ) ) 07712 * 07713 IF( ( ( LOWER.AND.UPPER ).AND.( ALPHA.EQ.BETA ) ).OR. 07714 $ ( ISROWREP .AND. ISCOLREP ) ) THEN 07715 IF( ( MP.GT.0 ).AND.( NQ.GT.0 ) ) 07716 $ CALL PB_CLASET( UPLO, MP, NQ, 0, ALPHA, BETA, 07717 $ A( IIA + ( JJA - 1 ) * LDA ), LDA ) 07718 RETURN 07719 END IF 07720 * 07721 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 07722 * ILOW, LOW, IUPP, and UPP. 07723 * 07724 MB = DESCA2( MB_ ) 07725 NB = DESCA2( NB_ ) 07726 CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL, 07727 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 07728 $ LNBLOC, ILOW, LOW, IUPP, UPP ) 07729 * 07730 IOFFA = IIA - 1 07731 JOFFA = JJA - 1 07732 IIMAX = IOFFA + MP 07733 JJMAX = JOFFA + NQ 07734 * 07735 IF( ISROWREP ) THEN 07736 PMB = MB 07737 ELSE 07738 PMB = NPROW * MB 07739 END IF 07740 IF( ISCOLREP ) THEN 07741 QNB = NB 07742 ELSE 07743 QNB = NPCOL * NB 07744 END IF 07745 * 07746 M1 = MP 07747 N1 = NQ 07748 * 07749 * Handle the first block of rows or columns separately, and update 07750 * LCMT00, MBLKS and NBLKS. 07751 * 07752 GODOWN = ( LCMT00.GT.IUPP ) 07753 GOLEFT = ( LCMT00.LT.ILOW ) 07754 * 07755 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 07756 * 07757 * LCMT00 >= ILOW && LCMT00 <= IUPP 07758 * 07759 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 07760 GODOWN = .NOT.GOLEFT 07761 * 07762 CALL PB_CLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA, 07763 $ A( IIA+JOFFA*LDA ), LDA ) 07764 IF( GODOWN ) THEN 07765 IF( UPPER .AND. NQ.GT.INBLOC ) 07766 $ CALL PB_CLASET( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA, 07767 $ ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA ) 07768 IIA = IIA + IMBLOC 07769 M1 = M1 - IMBLOC 07770 ELSE 07771 IF( LOWER .AND. MP.GT.IMBLOC ) 07772 $ CALL PB_CLASET( 'All', MP-IMBLOC, INBLOC, 0, ALPHA, 07773 $ ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA ) 07774 JJA = JJA + INBLOC 07775 N1 = N1 - INBLOC 07776 END IF 07777 * 07778 END IF 07779 * 07780 IF( GODOWN ) THEN 07781 * 07782 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07783 MBLKS = MBLKS - 1 07784 IOFFA = IOFFA + IMBLOC 07785 * 07786 10 CONTINUE 07787 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07788 LCMT00 = LCMT00 - PMB 07789 MBLKS = MBLKS - 1 07790 IOFFA = IOFFA + MB 07791 GO TO 10 07792 END IF 07793 * 07794 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 07795 IF( UPPER .AND. TMP1.GT.0 ) THEN 07796 CALL PB_CLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA, 07797 $ A( IIA+JOFFA*LDA ), LDA ) 07798 IIA = IIA + TMP1 07799 M1 = M1 - TMP1 07800 END IF 07801 * 07802 IF( MBLKS.LE.0 ) 07803 $ RETURN 07804 * 07805 LCMT = LCMT00 07806 MBLKD = MBLKS 07807 IOFFD = IOFFA 07808 * 07809 MBLOC = MB 07810 20 CONTINUE 07811 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 07812 IF( MBLKD.EQ.1 ) 07813 $ MBLOC = LMBLOC 07814 CALL PB_CLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA, 07815 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07816 LCMT00 = LCMT 07817 LCMT = LCMT - PMB 07818 MBLKS = MBLKD 07819 MBLKD = MBLKD - 1 07820 IOFFA = IOFFD 07821 IOFFD = IOFFD + MBLOC 07822 GO TO 20 07823 END IF 07824 * 07825 TMP1 = M1 - IOFFD + IIA - 1 07826 IF( LOWER .AND. TMP1.GT.0 ) 07827 $ CALL PB_CLASET( 'ALL', TMP1, INBLOC, 0, ALPHA, ALPHA, 07828 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07829 * 07830 TMP1 = IOFFA - IIA + 1 07831 M1 = M1 - TMP1 07832 N1 = N1 - INBLOC 07833 LCMT00 = LCMT00 + LOW - ILOW + QNB 07834 NBLKS = NBLKS - 1 07835 JOFFA = JOFFA + INBLOC 07836 * 07837 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 07838 $ CALL PB_CLASET( 'ALL', TMP1, N1, 0, ALPHA, ALPHA, 07839 $ A( IIA+JOFFA*LDA ), LDA ) 07840 * 07841 IIA = IOFFA + 1 07842 JJA = JOFFA + 1 07843 * 07844 ELSE IF( GOLEFT ) THEN 07845 * 07846 LCMT00 = LCMT00 + LOW - ILOW + QNB 07847 NBLKS = NBLKS - 1 07848 JOFFA = JOFFA + INBLOC 07849 * 07850 30 CONTINUE 07851 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 07852 LCMT00 = LCMT00 + QNB 07853 NBLKS = NBLKS - 1 07854 JOFFA = JOFFA + NB 07855 GO TO 30 07856 END IF 07857 * 07858 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1 07859 IF( LOWER .AND. TMP1.GT.0 ) THEN 07860 CALL PB_CLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA, 07861 $ A( IIA+(JJA-1)*LDA ), LDA ) 07862 JJA = JJA + TMP1 07863 N1 = N1 - TMP1 07864 END IF 07865 * 07866 IF( NBLKS.LE.0 ) 07867 $ RETURN 07868 * 07869 LCMT = LCMT00 07870 NBLKD = NBLKS 07871 JOFFD = JOFFA 07872 * 07873 NBLOC = NB 07874 40 CONTINUE 07875 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 07876 IF( NBLKD.EQ.1 ) 07877 $ NBLOC = LNBLOC 07878 CALL PB_CLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA, 07879 $ A( IIA+JOFFD*LDA ), LDA ) 07880 LCMT00 = LCMT 07881 LCMT = LCMT + QNB 07882 NBLKS = NBLKD 07883 NBLKD = NBLKD - 1 07884 JOFFA = JOFFD 07885 JOFFD = JOFFD + NBLOC 07886 GO TO 40 07887 END IF 07888 * 07889 TMP1 = N1 - JOFFD + JJA - 1 07890 IF( UPPER .AND. TMP1.GT.0 ) 07891 $ CALL PB_CLASET( 'All', IMBLOC, TMP1, 0, ALPHA, ALPHA, 07892 $ A( IIA+JOFFD*LDA ), LDA ) 07893 * 07894 TMP1 = JOFFA - JJA + 1 07895 M1 = M1 - IMBLOC 07896 N1 = N1 - TMP1 07897 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07898 MBLKS = MBLKS - 1 07899 IOFFA = IOFFA + IMBLOC 07900 * 07901 IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 ) 07902 $ CALL PB_CLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA, 07903 $ A( IOFFA+1+(JJA-1)*LDA ), LDA ) 07904 * 07905 IIA = IOFFA + 1 07906 JJA = JOFFA + 1 07907 * 07908 END IF 07909 * 07910 NBLOC = NB 07911 50 CONTINUE 07912 IF( NBLKS.GT.0 ) THEN 07913 IF( NBLKS.EQ.1 ) 07914 $ NBLOC = LNBLOC 07915 60 CONTINUE 07916 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07917 LCMT00 = LCMT00 - PMB 07918 MBLKS = MBLKS - 1 07919 IOFFA = IOFFA + MB 07920 GO TO 60 07921 END IF 07922 * 07923 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 07924 IF( UPPER .AND. TMP1.GT.0 ) THEN 07925 CALL PB_CLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA, 07926 $ A( IIA+JOFFA*LDA ), LDA ) 07927 IIA = IIA + TMP1 07928 M1 = M1 - TMP1 07929 END IF 07930 * 07931 IF( MBLKS.LE.0 ) 07932 $ RETURN 07933 * 07934 LCMT = LCMT00 07935 MBLKD = MBLKS 07936 IOFFD = IOFFA 07937 * 07938 MBLOC = MB 07939 70 CONTINUE 07940 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 07941 IF( MBLKD.EQ.1 ) 07942 $ MBLOC = LMBLOC 07943 CALL PB_CLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA, 07944 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07945 LCMT00 = LCMT 07946 LCMT = LCMT - PMB 07947 MBLKS = MBLKD 07948 MBLKD = MBLKD - 1 07949 IOFFA = IOFFD 07950 IOFFD = IOFFD + MBLOC 07951 GO TO 70 07952 END IF 07953 * 07954 TMP1 = M1 - IOFFD + IIA - 1 07955 IF( LOWER .AND. TMP1.GT.0 ) 07956 $ CALL PB_CLASET( 'All', TMP1, NBLOC, 0, ALPHA, ALPHA, 07957 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07958 * 07959 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 07960 M1 = M1 - TMP1 07961 N1 = N1 - NBLOC 07962 LCMT00 = LCMT00 + QNB 07963 NBLKS = NBLKS - 1 07964 JOFFA = JOFFA + NBLOC 07965 * 07966 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 07967 $ CALL PB_CLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA, 07968 $ A( IIA+JOFFA*LDA ), LDA ) 07969 * 07970 IIA = IOFFA + 1 07971 JJA = JOFFA + 1 07972 * 07973 GO TO 50 07974 * 07975 END IF 07976 * 07977 RETURN 07978 * 07979 * End of PCLASET 07980 * 07981 END 07982 SUBROUTINE PCLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA ) 07983 * 07984 * -- PBLAS test routine (version 2.0) -- 07985 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07986 * and University of California, Berkeley. 07987 * April 1, 1998 07988 * 07989 * .. Scalar Arguments .. 07990 CHARACTER*1 TYPE 07991 INTEGER IA, JA, M, N 07992 COMPLEX ALPHA 07993 * .. 07994 * .. Array Arguments .. 07995 INTEGER DESCA( * ) 07996 COMPLEX A( * ) 07997 * .. 07998 * 07999 * Purpose 08000 * ======= 08001 * 08002 * PCLASCAL scales the m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted 08003 * by sub( A ) by the scalar alpha. TYPE specifies if sub( A ) is full, 08004 * upper triangular, lower triangular or upper Hessenberg. 08005 * 08006 * Notes 08007 * ===== 08008 * 08009 * A description vector is associated with each 2D block-cyclicly dis- 08010 * tributed matrix. This vector stores the information required to 08011 * establish the mapping between a matrix entry and its corresponding 08012 * process and memory location. 08013 * 08014 * In the following comments, the character _ should be read as 08015 * "of the distributed matrix". Let A be a generic term for any 2D 08016 * block cyclicly distributed matrix. Its description vector is DESCA: 08017 * 08018 * NOTATION STORED IN EXPLANATION 08019 * ---------------- --------------- ------------------------------------ 08020 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 08021 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 08022 * the NPROW x NPCOL BLACS process grid 08023 * A is distributed over. The context 08024 * itself is global, but the handle 08025 * (the integer value) may vary. 08026 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 08027 * ted matrix A, M_A >= 0. 08028 * N_A (global) DESCA( N_ ) The number of columns in the distri- 08029 * buted matrix A, N_A >= 0. 08030 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 08031 * block of the matrix A, IMB_A > 0. 08032 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 08033 * left block of the matrix A, 08034 * INB_A > 0. 08035 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 08036 * bute the last M_A-IMB_A rows of A, 08037 * MB_A > 0. 08038 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 08039 * bute the last N_A-INB_A columns of 08040 * A, NB_A > 0. 08041 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 08042 * row of the matrix A is distributed, 08043 * NPROW > RSRC_A >= 0. 08044 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 08045 * first column of A is distributed. 08046 * NPCOL > CSRC_A >= 0. 08047 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 08048 * array storing the local blocks of 08049 * the distributed matrix A, 08050 * IF( Lc( 1, N_A ) > 0 ) 08051 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 08052 * ELSE 08053 * LLD_A >= 1. 08054 * 08055 * Let K be the number of rows of a matrix A starting at the global in- 08056 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 08057 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 08058 * receive if these K rows were distributed over NPROW processes. If K 08059 * is the number of columns of a matrix A starting at the global index 08060 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 08061 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 08062 * these K columns were distributed over NPCOL processes. 08063 * 08064 * The values of Lr() and Lc() may be determined via a call to the func- 08065 * tion PB_NUMROC: 08066 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 08067 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 08068 * 08069 * Arguments 08070 * ========= 08071 * 08072 * TYPE (global input) CHARACTER*1 08073 * On entry, TYPE specifies the type of the input submatrix as 08074 * follows: 08075 * = 'L' or 'l': sub( A ) is a lower triangular matrix, 08076 * = 'U' or 'u': sub( A ) is an upper triangular matrix, 08077 * = 'H' or 'h': sub( A ) is an upper Hessenberg matrix, 08078 * otherwise sub( A ) is a full matrix. 08079 * 08080 * M (global input) INTEGER 08081 * On entry, M specifies the number of rows of the submatrix 08082 * sub( A ). M must be at least zero. 08083 * 08084 * N (global input) INTEGER 08085 * On entry, N specifies the number of columns of the submatrix 08086 * sub( A ). N must be at least zero. 08087 * 08088 * ALPHA (global input) COMPLEX 08089 * On entry, ALPHA specifies the scalar alpha. 08090 * 08091 * A (local input/local output) COMPLEX array 08092 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 08093 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 08094 * the local entries of the matrix A. 08095 * On exit, the local entries of this array corresponding to the 08096 * to the entries of the submatrix sub( A ) are overwritten by 08097 * the local entries of the m by n scaled submatrix. 08098 * 08099 * IA (global input) INTEGER 08100 * On entry, IA specifies A's global row index, which points to 08101 * the beginning of the submatrix sub( A ). 08102 * 08103 * JA (global input) INTEGER 08104 * On entry, JA specifies A's global column index, which points 08105 * to the beginning of the submatrix sub( A ). 08106 * 08107 * DESCA (global and local input) INTEGER array 08108 * On entry, DESCA is an integer array of dimension DLEN_. This 08109 * is the array descriptor for the matrix A. 08110 * 08111 * -- Written on April 1, 1998 by 08112 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 08113 * 08114 * ===================================================================== 08115 * 08116 * .. Parameters .. 08117 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 08118 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 08119 $ RSRC_ 08120 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 08121 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 08122 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 08123 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 08124 * .. 08125 * .. Local Scalars .. 08126 CHARACTER*1 UPLO 08127 LOGICAL GODOWN, GOLEFT, LOWER, UPPER 08128 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1, 08129 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE, 08130 $ IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00, 08131 $ LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS, 08132 $ MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB, 08133 $ NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, 08134 $ QNB, TMP1, UPP 08135 * .. 08136 * .. Local Arrays .. 08137 INTEGER DESCA2( DLEN_ ) 08138 * .. 08139 * .. External Subroutines .. 08140 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 08141 $ PB_CLASCAL, PB_DESCTRANS, PB_INFOG2L 08142 * .. 08143 * .. External Functions .. 08144 LOGICAL LSAME 08145 INTEGER PB_NUMROC 08146 EXTERNAL LSAME, PB_NUMROC 08147 * .. 08148 * .. Intrinsic Functions .. 08149 INTRINSIC MIN 08150 * .. 08151 * .. Executable Statements .. 08152 * 08153 * Convert descriptor 08154 * 08155 CALL PB_DESCTRANS( DESCA, DESCA2 ) 08156 * 08157 * Get grid parameters 08158 * 08159 ICTXT = DESCA2( CTXT_ ) 08160 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 08161 * 08162 * Quick return if possible 08163 * 08164 IF( M.EQ.0 .OR. N.EQ.0 ) 08165 $ RETURN 08166 * 08167 IF( LSAME( TYPE, 'L' ) ) THEN 08168 ITYPE = 1 08169 UPLO = TYPE 08170 UPPER = .FALSE. 08171 LOWER = .TRUE. 08172 IOFFD = 0 08173 ELSE IF( LSAME( TYPE, 'U' ) ) THEN 08174 ITYPE = 2 08175 UPLO = TYPE 08176 UPPER = .TRUE. 08177 LOWER = .FALSE. 08178 IOFFD = 0 08179 ELSE IF( LSAME( TYPE, 'H' ) ) THEN 08180 ITYPE = 3 08181 UPLO = 'U' 08182 UPPER = .TRUE. 08183 LOWER = .FALSE. 08184 IOFFD = 1 08185 ELSE 08186 ITYPE = 0 08187 UPLO = 'A' 08188 UPPER = .TRUE. 08189 LOWER = .TRUE. 08190 IOFFD = 0 08191 END IF 08192 * 08193 * Compute local indexes 08194 * 08195 IF( ITYPE.EQ.0 ) THEN 08196 * 08197 * Full matrix 08198 * 08199 CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL, 08200 $ IIA, JJA, IAROW, IACOL ) 08201 MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW, 08202 $ DESCA2( RSRC_ ), NPROW ) 08203 NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL, 08204 $ DESCA2( CSRC_ ), NPCOL ) 08205 * 08206 IF( MP.LE.0 .OR. NQ.LE.0 ) 08207 $ RETURN 08208 * 08209 LDA = DESCA2( LLD_ ) 08210 IOFFA = IIA + ( JJA - 1 ) * LDA 08211 * 08212 CALL PB_CLASCAL( 'All', MP, NQ, 0, ALPHA, A( IOFFA ), LDA ) 08213 * 08214 ELSE 08215 * 08216 * Trapezoidal matrix 08217 * 08218 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 08219 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW, 08220 $ IACOL, MRROW, MRCOL ) 08221 * 08222 IF( MP.LE.0 .OR. NQ.LE.0 ) 08223 $ RETURN 08224 * 08225 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 08226 * LNBLOC, ILOW, LOW, IUPP, and UPP. 08227 * 08228 MB = DESCA2( MB_ ) 08229 NB = DESCA2( NB_ ) 08230 LDA = DESCA2( LLD_ ) 08231 * 08232 CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW, 08233 $ MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, 08234 $ LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP ) 08235 * 08236 M1 = MP 08237 N1 = NQ 08238 IOFFA = IIA - 1 08239 JOFFA = JJA - 1 08240 IIMAX = IOFFA + MP 08241 JJMAX = JOFFA + NQ 08242 * 08243 IF( DESCA2( RSRC_ ).LT.0 ) THEN 08244 PMB = MB 08245 ELSE 08246 PMB = NPROW * MB 08247 END IF 08248 IF( DESCA2( CSRC_ ).LT.0 ) THEN 08249 QNB = NB 08250 ELSE 08251 QNB = NPCOL * NB 08252 END IF 08253 * 08254 * Handle the first block of rows or columns separately, and 08255 * update LCMT00, MBLKS and NBLKS. 08256 * 08257 GODOWN = ( LCMT00.GT.IUPP ) 08258 GOLEFT = ( LCMT00.LT.ILOW ) 08259 * 08260 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 08261 * 08262 * LCMT00 >= ILOW && LCMT00 <= IUPP 08263 * 08264 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 08265 GODOWN = .NOT.GOLEFT 08266 * 08267 CALL PB_CLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, 08268 $ A( IIA+JOFFA*LDA ), LDA ) 08269 IF( GODOWN ) THEN 08270 IF( UPPER .AND. NQ.GT.INBLOC ) 08271 $ CALL PB_CLASCAL( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA, 08272 $ A( IIA+(JOFFA+INBLOC)*LDA ), LDA ) 08273 IIA = IIA + IMBLOC 08274 M1 = M1 - IMBLOC 08275 ELSE 08276 IF( LOWER .AND. MP.GT.IMBLOC ) 08277 $ CALL PB_CLASCAL( 'All', MP-IMBLOC, INBLOC, 0, ALPHA, 08278 $ A( IIA+IMBLOC+JOFFA*LDA ), LDA ) 08279 JJA = JJA + INBLOC 08280 N1 = N1 - INBLOC 08281 END IF 08282 * 08283 END IF 08284 * 08285 IF( GODOWN ) THEN 08286 * 08287 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 08288 MBLKS = MBLKS - 1 08289 IOFFA = IOFFA + IMBLOC 08290 * 08291 10 CONTINUE 08292 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 08293 LCMT00 = LCMT00 - PMB 08294 MBLKS = MBLKS - 1 08295 IOFFA = IOFFA + MB 08296 GO TO 10 08297 END IF 08298 * 08299 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 08300 IF( UPPER .AND. TMP1.GT.0 ) THEN 08301 CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA, 08302 $ A( IIA+JOFFA*LDA ), LDA ) 08303 IIA = IIA + TMP1 08304 M1 = M1 - TMP1 08305 END IF 08306 * 08307 IF( MBLKS.LE.0 ) 08308 $ RETURN 08309 * 08310 LCMT = LCMT00 08311 MBLKD = MBLKS 08312 IOFFD = IOFFA 08313 * 08314 MBLOC = MB 08315 20 CONTINUE 08316 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 08317 IF( MBLKD.EQ.1 ) 08318 $ MBLOC = LMBLOC 08319 CALL PB_CLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA, 08320 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08321 LCMT00 = LCMT 08322 LCMT = LCMT - PMB 08323 MBLKS = MBLKD 08324 MBLKD = MBLKD - 1 08325 IOFFA = IOFFD 08326 IOFFD = IOFFD + MBLOC 08327 GO TO 20 08328 END IF 08329 * 08330 TMP1 = M1 - IOFFD + IIA - 1 08331 IF( LOWER .AND. TMP1.GT.0 ) 08332 $ CALL PB_CLASCAL( 'All', TMP1, INBLOC, 0, ALPHA, 08333 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08334 * 08335 TMP1 = IOFFA - IIA + 1 08336 M1 = M1 - TMP1 08337 N1 = N1 - INBLOC 08338 LCMT00 = LCMT00 + LOW - ILOW + QNB 08339 NBLKS = NBLKS - 1 08340 JOFFA = JOFFA + INBLOC 08341 * 08342 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 08343 $ CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA, 08344 $ A( IIA+JOFFA*LDA ), LDA ) 08345 * 08346 IIA = IOFFA + 1 08347 JJA = JOFFA + 1 08348 * 08349 ELSE IF( GOLEFT ) THEN 08350 * 08351 LCMT00 = LCMT00 + LOW - ILOW + QNB 08352 NBLKS = NBLKS - 1 08353 JOFFA = JOFFA + INBLOC 08354 * 08355 30 CONTINUE 08356 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 08357 LCMT00 = LCMT00 + QNB 08358 NBLKS = NBLKS - 1 08359 JOFFA = JOFFA + NB 08360 GO TO 30 08361 END IF 08362 * 08363 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1 08364 IF( LOWER .AND. TMP1.GT.0 ) THEN 08365 CALL PB_CLASCAL( 'All', M1, TMP1, 0, ALPHA, 08366 $ A( IIA+(JJA-1)*LDA ), LDA ) 08367 JJA = JJA + TMP1 08368 N1 = N1 - TMP1 08369 END IF 08370 * 08371 IF( NBLKS.LE.0 ) 08372 $ RETURN 08373 * 08374 LCMT = LCMT00 08375 NBLKD = NBLKS 08376 JOFFD = JOFFA 08377 * 08378 NBLOC = NB 08379 40 CONTINUE 08380 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 08381 IF( NBLKD.EQ.1 ) 08382 $ NBLOC = LNBLOC 08383 CALL PB_CLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, 08384 $ A( IIA+JOFFD*LDA ), LDA ) 08385 LCMT00 = LCMT 08386 LCMT = LCMT + QNB 08387 NBLKS = NBLKD 08388 NBLKD = NBLKD - 1 08389 JOFFA = JOFFD 08390 JOFFD = JOFFD + NBLOC 08391 GO TO 40 08392 END IF 08393 * 08394 TMP1 = N1 - JOFFD + JJA - 1 08395 IF( UPPER .AND. TMP1.GT.0 ) 08396 $ CALL PB_CLASCAL( 'All', IMBLOC, TMP1, 0, ALPHA, 08397 $ A( IIA+JOFFD*LDA ), LDA ) 08398 * 08399 TMP1 = JOFFA - JJA + 1 08400 M1 = M1 - IMBLOC 08401 N1 = N1 - TMP1 08402 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 08403 MBLKS = MBLKS - 1 08404 IOFFA = IOFFA + IMBLOC 08405 * 08406 IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 ) 08407 $ CALL PB_CLASCAL( 'All', M1, TMP1, 0, ALPHA, 08408 $ A( IOFFA+1+(JJA-1)*LDA ), LDA ) 08409 * 08410 IIA = IOFFA + 1 08411 JJA = JOFFA + 1 08412 * 08413 END IF 08414 * 08415 NBLOC = NB 08416 50 CONTINUE 08417 IF( NBLKS.GT.0 ) THEN 08418 IF( NBLKS.EQ.1 ) 08419 $ NBLOC = LNBLOC 08420 60 CONTINUE 08421 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 08422 LCMT00 = LCMT00 - PMB 08423 MBLKS = MBLKS - 1 08424 IOFFA = IOFFA + MB 08425 GO TO 60 08426 END IF 08427 * 08428 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 08429 IF( UPPER .AND. TMP1.GT.0 ) THEN 08430 CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA, 08431 $ A( IIA+JOFFA*LDA ), LDA ) 08432 IIA = IIA + TMP1 08433 M1 = M1 - TMP1 08434 END IF 08435 * 08436 IF( MBLKS.LE.0 ) 08437 $ RETURN 08438 * 08439 LCMT = LCMT00 08440 MBLKD = MBLKS 08441 IOFFD = IOFFA 08442 * 08443 MBLOC = MB 08444 70 CONTINUE 08445 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 08446 IF( MBLKD.EQ.1 ) 08447 $ MBLOC = LMBLOC 08448 CALL PB_CLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA, 08449 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08450 LCMT00 = LCMT 08451 LCMT = LCMT - PMB 08452 MBLKS = MBLKD 08453 MBLKD = MBLKD - 1 08454 IOFFA = IOFFD 08455 IOFFD = IOFFD + MBLOC 08456 GO TO 70 08457 END IF 08458 * 08459 TMP1 = M1 - IOFFD + IIA - 1 08460 IF( LOWER .AND. TMP1.GT.0 ) 08461 $ CALL PB_CLASCAL( 'All', TMP1, NBLOC, 0, ALPHA, 08462 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08463 * 08464 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 08465 M1 = M1 - TMP1 08466 N1 = N1 - NBLOC 08467 LCMT00 = LCMT00 + QNB 08468 NBLKS = NBLKS - 1 08469 JOFFA = JOFFA + NBLOC 08470 * 08471 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 08472 $ CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA, 08473 $ A( IIA+JOFFA*LDA ), LDA ) 08474 * 08475 IIA = IOFFA + 1 08476 JJA = JOFFA + 1 08477 * 08478 GO TO 50 08479 * 08480 END IF 08481 * 08482 END IF 08483 * 08484 RETURN 08485 * 08486 * End of PCLASCAL 08487 * 08488 END 08489 SUBROUTINE PCLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, 08490 $ DESCA, IASEED, A, LDA ) 08491 * 08492 * -- PBLAS test routine (version 2.0) -- 08493 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 08494 * and University of California, Berkeley. 08495 * April 1, 1998 08496 * 08497 * .. Scalar Arguments .. 08498 LOGICAL INPLACE 08499 CHARACTER*1 AFORM, DIAG 08500 INTEGER IA, IASEED, JA, LDA, M, N, OFFA 08501 * .. 08502 * .. Array Arguments .. 08503 INTEGER DESCA( * ) 08504 COMPLEX A( LDA, * ) 08505 * .. 08506 * 08507 * Purpose 08508 * ======= 08509 * 08510 * PCLAGEN generates (or regenerates) a submatrix sub( A ) denoting 08511 * A(IA:IA+M-1,JA:JA+N-1). 08512 * 08513 * Notes 08514 * ===== 08515 * 08516 * A description vector is associated with each 2D block-cyclicly dis- 08517 * tributed matrix. This vector stores the information required to 08518 * establish the mapping between a matrix entry and its corresponding 08519 * process and memory location. 08520 * 08521 * In the following comments, the character _ should be read as 08522 * "of the distributed matrix". Let A be a generic term for any 2D 08523 * block cyclicly distributed matrix. Its description vector is DESCA: 08524 * 08525 * NOTATION STORED IN EXPLANATION 08526 * ---------------- --------------- ------------------------------------ 08527 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 08528 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 08529 * the NPROW x NPCOL BLACS process grid 08530 * A is distributed over. The context 08531 * itself is global, but the handle 08532 * (the integer value) may vary. 08533 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 08534 * ted matrix A, M_A >= 0. 08535 * N_A (global) DESCA( N_ ) The number of columns in the distri- 08536 * buted matrix A, N_A >= 0. 08537 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 08538 * block of the matrix A, IMB_A > 0. 08539 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 08540 * left block of the matrix A, 08541 * INB_A > 0. 08542 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 08543 * bute the last M_A-IMB_A rows of A, 08544 * MB_A > 0. 08545 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 08546 * bute the last N_A-INB_A columns of 08547 * A, NB_A > 0. 08548 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 08549 * row of the matrix A is distributed, 08550 * NPROW > RSRC_A >= 0. 08551 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 08552 * first column of A is distributed. 08553 * NPCOL > CSRC_A >= 0. 08554 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 08555 * array storing the local blocks of 08556 * the distributed matrix A, 08557 * IF( Lc( 1, N_A ) > 0 ) 08558 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 08559 * ELSE 08560 * LLD_A >= 1. 08561 * 08562 * Let K be the number of rows of a matrix A starting at the global in- 08563 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 08564 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 08565 * receive if these K rows were distributed over NPROW processes. If K 08566 * is the number of columns of a matrix A starting at the global index 08567 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 08568 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 08569 * these K columns were distributed over NPCOL processes. 08570 * 08571 * The values of Lr() and Lc() may be determined via a call to the func- 08572 * tion PB_NUMROC: 08573 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 08574 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 08575 * 08576 * Arguments 08577 * ========= 08578 * 08579 * INPLACE (global input) LOGICAL 08580 * On entry, INPLACE specifies if the matrix should be generated 08581 * in place or not. If INPLACE is .TRUE., the local random array 08582 * to be generated will start in memory at the local memory lo- 08583 * cation A( 1, 1 ), otherwise it will start at the local posi- 08584 * tion induced by IA and JA. 08585 * 08586 * AFORM (global input) CHARACTER*1 08587 * On entry, AFORM specifies the type of submatrix to be genera- 08588 * ted as follows: 08589 * AFORM = 'S', sub( A ) is a symmetric matrix, 08590 * AFORM = 'H', sub( A ) is a Hermitian matrix, 08591 * AFORM = 'T', sub( A ) is overrwritten with the transpose 08592 * of what would normally be generated, 08593 * AFORM = 'C', sub( A ) is overwritten with the conjugate 08594 * transpose of what would normally be genera- 08595 * ted. 08596 * AFORM = 'N', a random submatrix is generated. 08597 * 08598 * DIAG (global input) CHARACTER*1 08599 * On entry, DIAG specifies if the generated submatrix is diago- 08600 * nally dominant or not as follows: 08601 * DIAG = 'D' : sub( A ) is diagonally dominant, 08602 * DIAG = 'N' : sub( A ) is not diagonally dominant. 08603 * 08604 * OFFA (global input) INTEGER 08605 * On entry, OFFA specifies the offdiagonal of the underlying 08606 * matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma- 08607 * trix is symmetric, Hermitian or diagonally dominant. OFFA = 0 08608 * specifies the main diagonal, OFFA > 0 specifies a subdiago- 08609 * nal, and OFFA < 0 specifies a superdiagonal (see further de- 08610 * tails). 08611 * 08612 * M (global input) INTEGER 08613 * On entry, M specifies the global number of matrix rows of the 08614 * submatrix sub( A ) to be generated. M must be at least zero. 08615 * 08616 * N (global input) INTEGER 08617 * On entry, N specifies the global number of matrix columns of 08618 * the submatrix sub( A ) to be generated. N must be at least 08619 * zero. 08620 * 08621 * IA (global input) INTEGER 08622 * On entry, IA specifies A's global row index, which points to 08623 * the beginning of the submatrix sub( A ). 08624 * 08625 * JA (global input) INTEGER 08626 * On entry, JA specifies A's global column index, which points 08627 * to the beginning of the submatrix sub( A ). 08628 * 08629 * DESCA (global and local input) INTEGER array 08630 * On entry, DESCA is an integer array of dimension DLEN_. This 08631 * is the array descriptor for the matrix A. 08632 * 08633 * IASEED (global input) INTEGER 08634 * On entry, IASEED specifies the seed number to generate the 08635 * matrix A. IASEED must be at least zero. 08636 * 08637 * A (local output) COMPLEX array 08638 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 08639 * at least Lc( 1, JA+N-1 ). On exit, this array contains the 08640 * local entries of the randomly generated submatrix sub( A ). 08641 * 08642 * LDA (local input) INTEGER 08643 * On entry, LDA specifies the local leading dimension of the 08644 * array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_). 08645 * This restriction is however not enforced, and this subroutine 08646 * requires only that LDA >= MAX( 1, Mp ) where 08647 * 08648 * Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ). 08649 * 08650 * PB_NUMROC is a ScaLAPACK tool function; MYROW, MYCOL, NPROW 08651 * and NPCOL can be determined by calling the BLACS subroutine 08652 * BLACS_GRIDINFO. 08653 * 08654 * Further Details 08655 * =============== 08656 * 08657 * OFFD is tied to the matrix described by DESCA, as opposed to the 08658 * piece that is currently (re)generated. This is a global information 08659 * independent from the distribution parameters. Below are examples of 08660 * the meaning of OFFD for a global 7 by 5 matrix: 08661 * 08662 * --------------------------------------------------------------------- 08663 * OFFD | 0 -1 -2 -3 -4 0 -1 -2 -3 -4 0 -1 -2 -3 -4 08664 * -------|------------------------------------------------------------- 08665 * | | OFFD=-1 | OFFD=0 OFFD=2 08666 * | V V 08667 * 0 | . d . . . -> d . . . . . . . . . 08668 * 1 | . . d . . . d . . . . . . . . 08669 * 2 | . . . d . . . d . . -> d . . . . 08670 * 3 | . . . . d . . . d . . d . . . 08671 * 4 | . . . . . . . . . d . . d . . 08672 * 5 | . . . . . . . . . . . . . d . 08673 * 6 | . . . . . . . . . . . . . . d 08674 * --------------------------------------------------------------------- 08675 * 08676 * -- Written on April 1, 1998 by 08677 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 08678 * 08679 * ===================================================================== 08680 * 08681 * .. Parameters .. 08682 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 08683 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 08684 $ RSRC_ 08685 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 08686 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 08687 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 08688 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 08689 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN, 08690 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB, 08691 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW 08692 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3, 08693 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6, 08694 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9, 08695 $ JMP_NQNB = 10, JMP_NQINBLOC = 11, 08696 $ JMP_LEN = 11 ) 08697 REAL ZERO 08698 PARAMETER ( ZERO = 0.0E+0 ) 08699 * .. 08700 * .. Local Scalars .. 08701 LOGICAL DIAGDO, SYMM, HERM, NOTRAN 08702 INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK, 08703 $ ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB, 08704 $ INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP, 08705 $ IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00, 08706 $ LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP, 08707 $ MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW, 08708 $ NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP 08709 COMPLEX ALPHA 08710 * .. 08711 * .. Local Arrays .. 08712 INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ), 08713 $ IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 ) 08714 * .. 08715 * .. External Subroutines .. 08716 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 08717 $ PB_CHKMAT, PB_CLAGEN, PB_DESCTRANS, PB_INITJMP, 08718 $ PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO, 08719 $ PB_SETLOCRAN, PB_SETRAN, PCLADOM, PXERBLA 08720 * .. 08721 * .. External Functions .. 08722 LOGICAL LSAME 08723 EXTERNAL LSAME 08724 * .. 08725 * .. Intrinsic Functions .. 08726 INTRINSIC CMPLX, MAX, MIN, REAL 08727 * .. 08728 * .. Data Statements .. 08729 DATA ( MULADD0( I ), I = 1, 4 ) / 20077, 16838, 08730 $ 12345, 0 / 08731 * .. 08732 * .. Executable Statements .. 08733 * 08734 * Convert descriptor 08735 * 08736 CALL PB_DESCTRANS( DESCA, DESCA2 ) 08737 * 08738 * Test the input arguments 08739 * 08740 ICTXT = DESCA2( CTXT_ ) 08741 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 08742 * 08743 * Test the input parameters 08744 * 08745 INFO = 0 08746 IF( NPROW.EQ.-1 ) THEN 08747 INFO = -( 1000 + CTXT_ ) 08748 ELSE 08749 SYMM = LSAME( AFORM, 'S' ) 08750 HERM = LSAME( AFORM, 'H' ) 08751 NOTRAN = LSAME( AFORM, 'N' ) 08752 DIAGDO = LSAME( DIAG, 'D' ) 08753 IF( .NOT.( SYMM.OR.HERM.OR.NOTRAN ) .AND. 08754 $ .NOT.( LSAME( AFORM, 'T' ) ) .AND. 08755 $ .NOT.( LSAME( AFORM, 'C' ) ) ) THEN 08756 INFO = -2 08757 ELSE IF( ( .NOT.DIAGDO ) .AND. 08758 $ ( .NOT.LSAME( DIAG, 'N' ) ) ) THEN 08759 INFO = -3 08760 END IF 08761 CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO ) 08762 END IF 08763 * 08764 IF( INFO.NE.0 ) THEN 08765 CALL PXERBLA( ICTXT, 'PCLAGEN', -INFO ) 08766 RETURN 08767 END IF 08768 * 08769 * Quick return if possible 08770 * 08771 IF( ( M.LE.0 ).OR.( N.LE.0 ) ) 08772 $ RETURN 08773 * 08774 * Start the operations 08775 * 08776 MB = DESCA2( MB_ ) 08777 NB = DESCA2( NB_ ) 08778 IMB = DESCA2( IMB_ ) 08779 INB = DESCA2( INB_ ) 08780 RSRC = DESCA2( RSRC_ ) 08781 CSRC = DESCA2( CSRC_ ) 08782 * 08783 * Figure out local information about the distributed matrix operand 08784 * 08785 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 08786 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW, 08787 $ IACOL, MRROW, MRCOL ) 08788 * 08789 * Decide where the entries shall be stored in memory 08790 * 08791 IF( INPLACE ) THEN 08792 IIA = 1 08793 JJA = 1 08794 END IF 08795 * 08796 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 08797 * ILOW, LOW, IUPP, and UPP. 08798 * 08799 IOFFDA = JA + OFFA - IA 08800 CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW, 08801 $ MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, 08802 $ LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP ) 08803 * 08804 * Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST 08805 * This values correspond to the square virtual underlying matrix 08806 * of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used 08807 * to set up the random sequence. For practical purposes, the size 08808 * of this virtual matrix is upper bounded by M_ + N_ - 1. 08809 * 08810 ITMP = MAX( 0, -OFFA ) 08811 IVIR = IA + ITMP 08812 IMBVIR = IMB + ITMP 08813 NVIR = DESCA2( M_ ) + ITMP 08814 * 08815 CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK, 08816 $ ILOCOFF, MYRDIST ) 08817 * 08818 ITMP = MAX( 0, OFFA ) 08819 JVIR = JA + ITMP 08820 INBVIR = INB + ITMP 08821 NVIR = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ), 08822 $ DESCA2( M_ ) + DESCA2( N_ ) - 1 ) 08823 * 08824 CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK, 08825 $ JLOCOFF, MYCDIST ) 08826 * 08827 IF( SYMM .OR. HERM .OR. NOTRAN ) THEN 08828 * 08829 CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC, 08830 $ MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP ) 08831 * 08832 * Compute constants to jump JMP( * ) numbers in the sequence 08833 * 08834 CALL PB_INITMULADD( MULADD0, JMP, IMULADD ) 08835 * 08836 * Compute and set the random value corresponding to A( IA, JA ) 08837 * 08838 CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF, 08839 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP, 08840 $ IMULADD, IRAN ) 08841 * 08842 CALL PB_CLAGEN( 'Lower', AFORM, A( IIA, JJA ), LDA, LCMT00, 08843 $ IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC, 08844 $ NB, LNBLOC, JMP, IMULADD ) 08845 * 08846 END IF 08847 * 08848 IF( SYMM .OR. HERM .OR. ( .NOT. NOTRAN ) ) THEN 08849 * 08850 CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC, 08851 $ MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP ) 08852 * 08853 * Compute constants to jump JMP( * ) numbers in the sequence 08854 * 08855 CALL PB_INITMULADD( MULADD0, JMP, IMULADD ) 08856 * 08857 * Compute and set the random value corresponding to A( IA, JA ) 08858 * 08859 CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF, 08860 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP, 08861 $ IMULADD, IRAN ) 08862 * 08863 CALL PB_CLAGEN( 'Upper', AFORM, A( IIA, JJA ), LDA, LCMT00, 08864 $ IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC, 08865 $ NB, LNBLOC, JMP, IMULADD ) 08866 * 08867 END IF 08868 * 08869 IF( DIAGDO ) THEN 08870 * 08871 MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) ) 08872 IF( HERM ) THEN 08873 ALPHA = CMPLX( REAL( 2 * MAXMN ), ZERO ) 08874 ELSE 08875 ALPHA = CMPLX( REAL( MAXMN ), REAL( MAXMN ) ) 08876 END IF 08877 * 08878 IF( IOFFDA.GE.0 ) THEN 08879 CALL PCLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA, 08880 $ A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA ) 08881 ELSE 08882 CALL PCLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA, 08883 $ A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA ) 08884 END IF 08885 * 08886 END IF 08887 * 08888 RETURN 08889 * 08890 * End of PCLAGEN 08891 * 08892 END 08893 SUBROUTINE PCLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA ) 08894 * 08895 * -- PBLAS test routine (version 2.0) -- 08896 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 08897 * and University of California, Berkeley. 08898 * April 1, 1998 08899 * 08900 * .. Scalar Arguments .. 08901 LOGICAL INPLACE 08902 INTEGER IA, JA, N 08903 COMPLEX ALPHA 08904 * .. 08905 * .. Array Arguments .. 08906 INTEGER DESCA( * ) 08907 COMPLEX A( * ) 08908 * .. 08909 * 08910 * Purpose 08911 * ======= 08912 * 08913 * PCLADOM adds alpha to the diagonal entries of an n by n submatrix 08914 * sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ). 08915 * 08916 * Notes 08917 * ===== 08918 * 08919 * A description vector is associated with each 2D block-cyclicly dis- 08920 * tributed matrix. This vector stores the information required to 08921 * establish the mapping between a matrix entry and its corresponding 08922 * process and memory location. 08923 * 08924 * In the following comments, the character _ should be read as 08925 * "of the distributed matrix". Let A be a generic term for any 2D 08926 * block cyclicly distributed matrix. Its description vector is DESCA: 08927 * 08928 * NOTATION STORED IN EXPLANATION 08929 * ---------------- --------------- ------------------------------------ 08930 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 08931 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 08932 * the NPROW x NPCOL BLACS process grid 08933 * A is distributed over. The context 08934 * itself is global, but the handle 08935 * (the integer value) may vary. 08936 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 08937 * ted matrix A, M_A >= 0. 08938 * N_A (global) DESCA( N_ ) The number of columns in the distri- 08939 * buted matrix A, N_A >= 0. 08940 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 08941 * block of the matrix A, IMB_A > 0. 08942 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 08943 * left block of the matrix A, 08944 * INB_A > 0. 08945 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 08946 * bute the last M_A-IMB_A rows of A, 08947 * MB_A > 0. 08948 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 08949 * bute the last N_A-INB_A columns of 08950 * A, NB_A > 0. 08951 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 08952 * row of the matrix A is distributed, 08953 * NPROW > RSRC_A >= 0. 08954 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 08955 * first column of A is distributed. 08956 * NPCOL > CSRC_A >= 0. 08957 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 08958 * array storing the local blocks of 08959 * the distributed matrix A, 08960 * IF( Lc( 1, N_A ) > 0 ) 08961 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 08962 * ELSE 08963 * LLD_A >= 1. 08964 * 08965 * Let K be the number of rows of a matrix A starting at the global in- 08966 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 08967 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 08968 * receive if these K rows were distributed over NPROW processes. If K 08969 * is the number of columns of a matrix A starting at the global index 08970 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 08971 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 08972 * these K columns were distributed over NPCOL processes. 08973 * 08974 * The values of Lr() and Lc() may be determined via a call to the func- 08975 * tion PB_NUMROC: 08976 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 08977 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 08978 * 08979 * Arguments 08980 * ========= 08981 * 08982 * INPLACE (global input) LOGICAL 08983 * On entry, INPLACE specifies if the matrix should be generated 08984 * in place or not. If INPLACE is .TRUE., the local random array 08985 * to be generated will start in memory at the local memory lo- 08986 * cation A( 1, 1 ), otherwise it will start at the local posi- 08987 * tion induced by IA and JA. 08988 * 08989 * N (global input) INTEGER 08990 * On entry, N specifies the global order of the submatrix 08991 * sub( A ) to be modified. N must be at least zero. 08992 * 08993 * ALPHA (global input) COMPLEX 08994 * On entry, ALPHA specifies the scalar alpha. 08995 * 08996 * A (local input/local output) COMPLEX array 08997 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 08998 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 08999 * the local entries of the matrix A. On exit, the local entries 09000 * of this array corresponding to the main diagonal of sub( A ) 09001 * have been updated. 09002 * 09003 * IA (global input) INTEGER 09004 * On entry, IA specifies A's global row index, which points to 09005 * the beginning of the submatrix sub( A ). 09006 * 09007 * JA (global input) INTEGER 09008 * On entry, JA specifies A's global column index, which points 09009 * to the beginning of the submatrix sub( A ). 09010 * 09011 * DESCA (global and local input) INTEGER array 09012 * On entry, DESCA is an integer array of dimension DLEN_. This 09013 * is the array descriptor for the matrix A. 09014 * 09015 * -- Written on April 1, 1998 by 09016 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 09017 * 09018 * ===================================================================== 09019 * 09020 * .. Parameters .. 09021 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 09022 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 09023 $ RSRC_ 09024 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 09025 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 09026 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 09027 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 09028 * .. 09029 * .. Local Scalars .. 09030 LOGICAL GODOWN, GOLEFT 09031 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW, 09032 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, 09033 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1, 09034 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC, 09035 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS, 09036 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP 09037 COMPLEX ATMP 09038 * .. 09039 * .. Local Scalars .. 09040 INTEGER DESCA2( DLEN_ ) 09041 * .. 09042 * .. External Subroutines .. 09043 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 09044 $ PB_DESCTRANS 09045 * .. 09046 * .. Intrinsic Functions .. 09047 INTRINSIC ABS, AIMAG, CMPLX, MAX, MIN, REAL 09048 * .. 09049 * .. Executable Statements .. 09050 * 09051 * Convert descriptor 09052 * 09053 CALL PB_DESCTRANS( DESCA, DESCA2 ) 09054 * 09055 * Get grid parameters 09056 * 09057 ICTXT = DESCA2( CTXT_ ) 09058 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 09059 * 09060 IF( N.EQ.0 ) 09061 $ RETURN 09062 * 09063 CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 09064 $ MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW, 09065 $ IACOL, MRROW, MRCOL ) 09066 * 09067 * Decide where the entries shall be stored in memory 09068 * 09069 IF( INPLACE ) THEN 09070 IIA = 1 09071 JJA = 1 09072 END IF 09073 * 09074 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 09075 * ILOW, LOW, IUPP, and UPP. 09076 * 09077 MB = DESCA2( MB_ ) 09078 NB = DESCA2( NB_ ) 09079 * 09080 CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL, 09081 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 09082 $ LNBLOC, ILOW, LOW, IUPP, UPP ) 09083 * 09084 IOFFA = IIA - 1 09085 JOFFA = JJA - 1 09086 LDA = DESCA2( LLD_ ) 09087 LDAP1 = LDA + 1 09088 * 09089 IF( DESCA2( RSRC_ ).LT.0 ) THEN 09090 PMB = MB 09091 ELSE 09092 PMB = NPROW * MB 09093 END IF 09094 IF( DESCA2( CSRC_ ).LT.0 ) THEN 09095 QNB = NB 09096 ELSE 09097 QNB = NPCOL * NB 09098 END IF 09099 * 09100 * Handle the first block of rows or columns separately, and update 09101 * LCMT00, MBLKS and NBLKS. 09102 * 09103 GODOWN = ( LCMT00.GT.IUPP ) 09104 GOLEFT = ( LCMT00.LT.ILOW ) 09105 * 09106 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 09107 * 09108 * LCMT00 >= ILOW && LCMT00 <= IUPP 09109 * 09110 IF( LCMT00.GE.0 ) THEN 09111 IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA 09112 DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) ) 09113 ATMP = A( IJOFFA + I*LDAP1 ) 09114 A( IJOFFA + I*LDAP1 ) = ALPHA + 09115 $ CMPLX( ABS( REAL( ATMP ) ), 09116 $ ABS( AIMAG( ATMP ) ) ) 09117 10 CONTINUE 09118 ELSE 09119 IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA 09120 DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) ) 09121 ATMP = A( IJOFFA + I*LDAP1 ) 09122 A( IJOFFA + I*LDAP1 ) = ALPHA + 09123 $ CMPLX( ABS( REAL( ATMP ) ), 09124 $ ABS( AIMAG( ATMP ) ) ) 09125 20 CONTINUE 09126 END IF 09127 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 09128 GODOWN = .NOT.GOLEFT 09129 * 09130 END IF 09131 * 09132 IF( GODOWN ) THEN 09133 * 09134 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 09135 MBLKS = MBLKS - 1 09136 IOFFA = IOFFA + IMBLOC 09137 * 09138 30 CONTINUE 09139 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 09140 LCMT00 = LCMT00 - PMB 09141 MBLKS = MBLKS - 1 09142 IOFFA = IOFFA + MB 09143 GO TO 30 09144 END IF 09145 * 09146 LCMT = LCMT00 09147 MBLKD = MBLKS 09148 IOFFD = IOFFA 09149 * 09150 MBLOC = MB 09151 40 CONTINUE 09152 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 09153 IF( MBLKD.EQ.1 ) 09154 $ MBLOC = LMBLOC 09155 IF( LCMT.GE.0 ) THEN 09156 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 09157 DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) ) 09158 ATMP = A( IJOFFA + I*LDAP1 ) 09159 A( IJOFFA + I*LDAP1 ) = ALPHA + 09160 $ CMPLX( ABS( REAL( ATMP ) ), 09161 $ ABS( AIMAG( ATMP ) ) ) 09162 50 CONTINUE 09163 ELSE 09164 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 09165 DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) ) 09166 ATMP = A( IJOFFA + I*LDAP1 ) 09167 A( IJOFFA + I*LDAP1 ) = ALPHA + 09168 $ CMPLX( ABS( REAL( ATMP ) ), 09169 $ ABS( AIMAG( ATMP ) ) ) 09170 60 CONTINUE 09171 END IF 09172 LCMT00 = LCMT 09173 LCMT = LCMT - PMB 09174 MBLKS = MBLKD 09175 MBLKD = MBLKD - 1 09176 IOFFA = IOFFD 09177 IOFFD = IOFFD + MBLOC 09178 GO TO 40 09179 END IF 09180 * 09181 LCMT00 = LCMT00 + LOW - ILOW + QNB 09182 NBLKS = NBLKS - 1 09183 JOFFA = JOFFA + INBLOC 09184 * 09185 ELSE IF( GOLEFT ) THEN 09186 * 09187 LCMT00 = LCMT00 + LOW - ILOW + QNB 09188 NBLKS = NBLKS - 1 09189 JOFFA = JOFFA + INBLOC 09190 * 09191 70 CONTINUE 09192 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 09193 LCMT00 = LCMT00 + QNB 09194 NBLKS = NBLKS - 1 09195 JOFFA = JOFFA + NB 09196 GO TO 70 09197 END IF 09198 * 09199 LCMT = LCMT00 09200 NBLKD = NBLKS 09201 JOFFD = JOFFA 09202 * 09203 NBLOC = NB 09204 80 CONTINUE 09205 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 09206 IF( NBLKD.EQ.1 ) 09207 $ NBLOC = LNBLOC 09208 IF( LCMT.GE.0 ) THEN 09209 IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA 09210 DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) ) 09211 ATMP = A( IJOFFA + I*LDAP1 ) 09212 A( IJOFFA + I*LDAP1 ) = ALPHA + 09213 $ CMPLX( ABS( REAL( ATMP ) ), 09214 $ ABS( AIMAG( ATMP ) ) ) 09215 90 CONTINUE 09216 ELSE 09217 IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA 09218 DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) ) 09219 ATMP = A( IJOFFA + I*LDAP1 ) 09220 A( IJOFFA + I*LDAP1 ) = ALPHA + 09221 $ CMPLX( ABS( REAL( ATMP ) ), 09222 $ ABS( AIMAG( ATMP ) ) ) 09223 100 CONTINUE 09224 END IF 09225 LCMT00 = LCMT 09226 LCMT = LCMT + QNB 09227 NBLKS = NBLKD 09228 NBLKD = NBLKD - 1 09229 JOFFA = JOFFD 09230 JOFFD = JOFFD + NBLOC 09231 GO TO 80 09232 END IF 09233 * 09234 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 09235 MBLKS = MBLKS - 1 09236 IOFFA = IOFFA + IMBLOC 09237 * 09238 END IF 09239 * 09240 NBLOC = NB 09241 110 CONTINUE 09242 IF( NBLKS.GT.0 ) THEN 09243 IF( NBLKS.EQ.1 ) 09244 $ NBLOC = LNBLOC 09245 120 CONTINUE 09246 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 09247 LCMT00 = LCMT00 - PMB 09248 MBLKS = MBLKS - 1 09249 IOFFA = IOFFA + MB 09250 GO TO 120 09251 END IF 09252 * 09253 LCMT = LCMT00 09254 MBLKD = MBLKS 09255 IOFFD = IOFFA 09256 * 09257 MBLOC = MB 09258 130 CONTINUE 09259 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 09260 IF( MBLKD.EQ.1 ) 09261 $ MBLOC = LMBLOC 09262 IF( LCMT.GE.0 ) THEN 09263 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 09264 DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) ) 09265 ATMP = A( IJOFFA + I*LDAP1 ) 09266 A( IJOFFA + I*LDAP1 ) = ALPHA + 09267 $ CMPLX( ABS( REAL( ATMP ) ), 09268 $ ABS( AIMAG( ATMP ) ) ) 09269 140 CONTINUE 09270 ELSE 09271 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 09272 DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) ) 09273 ATMP = A( IJOFFA + I*LDAP1 ) 09274 A( IJOFFA + I*LDAP1 ) = ALPHA + 09275 $ CMPLX( ABS( REAL( ATMP ) ), 09276 $ ABS( AIMAG( ATMP ) ) ) 09277 150 CONTINUE 09278 END IF 09279 LCMT00 = LCMT 09280 LCMT = LCMT - PMB 09281 MBLKS = MBLKD 09282 MBLKD = MBLKD - 1 09283 IOFFA = IOFFD 09284 IOFFD = IOFFD + MBLOC 09285 GO TO 130 09286 END IF 09287 * 09288 LCMT00 = LCMT00 + QNB 09289 NBLKS = NBLKS - 1 09290 JOFFA = JOFFA + NBLOC 09291 GO TO 110 09292 * 09293 END IF 09294 * 09295 RETURN 09296 * 09297 * End of PCLADOM 09298 * 09299 END 09300 SUBROUTINE PB_PCLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, 09301 $ CMATNM, NOUT, WORK ) 09302 * 09303 * -- PBLAS test routine (version 2.0) -- 09304 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09305 * and University of California, Berkeley. 09306 * April 1, 1998 09307 * 09308 * .. Scalar Arguments .. 09309 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT 09310 * .. 09311 * .. Array Arguments .. 09312 CHARACTER*(*) CMATNM 09313 INTEGER DESCA( * ) 09314 COMPLEX A( * ), WORK( * ) 09315 * .. 09316 * 09317 * Purpose 09318 * ======= 09319 * 09320 * PB_PCLAPRNT prints to the standard output a submatrix sub( A ) deno- 09321 * ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by 09322 * the process of coordinates (IRPRNT, ICPRNT). 09323 * 09324 * Notes 09325 * ===== 09326 * 09327 * A description vector is associated with each 2D block-cyclicly dis- 09328 * tributed matrix. This vector stores the information required to 09329 * establish the mapping between a matrix entry and its corresponding 09330 * process and memory location. 09331 * 09332 * In the following comments, the character _ should be read as 09333 * "of the distributed matrix". Let A be a generic term for any 2D 09334 * block cyclicly distributed matrix. Its description vector is DESCA: 09335 * 09336 * NOTATION STORED IN EXPLANATION 09337 * ---------------- --------------- ------------------------------------ 09338 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 09339 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 09340 * the NPROW x NPCOL BLACS process grid 09341 * A is distributed over. The context 09342 * itself is global, but the handle 09343 * (the integer value) may vary. 09344 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 09345 * ted matrix A, M_A >= 0. 09346 * N_A (global) DESCA( N_ ) The number of columns in the distri- 09347 * buted matrix A, N_A >= 0. 09348 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 09349 * block of the matrix A, IMB_A > 0. 09350 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 09351 * left block of the matrix A, 09352 * INB_A > 0. 09353 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 09354 * bute the last M_A-IMB_A rows of A, 09355 * MB_A > 0. 09356 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 09357 * bute the last N_A-INB_A columns of 09358 * A, NB_A > 0. 09359 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 09360 * row of the matrix A is distributed, 09361 * NPROW > RSRC_A >= 0. 09362 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 09363 * first column of A is distributed. 09364 * NPCOL > CSRC_A >= 0. 09365 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 09366 * array storing the local blocks of 09367 * the distributed matrix A, 09368 * IF( Lc( 1, N_A ) > 0 ) 09369 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 09370 * ELSE 09371 * LLD_A >= 1. 09372 * 09373 * Let K be the number of rows of a matrix A starting at the global in- 09374 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 09375 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 09376 * receive if these K rows were distributed over NPROW processes. If K 09377 * is the number of columns of a matrix A starting at the global index 09378 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 09379 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 09380 * these K columns were distributed over NPCOL processes. 09381 * 09382 * The values of Lr() and Lc() may be determined via a call to the func- 09383 * tion PB_NUMROC: 09384 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 09385 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 09386 * 09387 * Arguments 09388 * ========= 09389 * 09390 * M (global input) INTEGER 09391 * On entry, M specifies the number of rows of the submatrix 09392 * sub( A ). M must be at least zero. 09393 * 09394 * N (global input) INTEGER 09395 * On entry, N specifies the number of columns of the submatrix 09396 * sub( A ). N must be at least zero. 09397 * 09398 * A (local input) COMPLEX array 09399 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 09400 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 09401 * the local entries of the matrix A. 09402 * 09403 * IA (global input) INTEGER 09404 * On entry, IA specifies A's global row index, which points to 09405 * the beginning of the submatrix sub( A ). 09406 * 09407 * JA (global input) INTEGER 09408 * On entry, JA specifies A's global column index, which points 09409 * to the beginning of the submatrix sub( A ). 09410 * 09411 * DESCA (global and local input) INTEGER array 09412 * On entry, DESCA is an integer array of dimension DLEN_. This 09413 * is the array descriptor for the matrix A. 09414 * 09415 * IRPRNT (global input) INTEGER 09416 * On entry, IRPRNT specifies the row index of the printing pro- 09417 * cess. 09418 * 09419 * ICPRNT (global input) INTEGER 09420 * On entry, ICPRNT specifies the column index of the printing 09421 * process. 09422 * 09423 * CMATNM (global input) CHARACTER*(*) 09424 * On entry, CMATNM is the name of the matrix to be printed. 09425 * 09426 * NOUT (global input) INTEGER 09427 * On entry, NOUT specifies the output unit number. When NOUT is 09428 * equal to 6, the submatrix is printed on the screen. 09429 * 09430 * WORK (local workspace) COMPLEX array 09431 * On entry, WORK is a work array of dimension at least equal to 09432 * MAX( IMB_A, MB_A ). 09433 * 09434 * -- Written on April 1, 1998 by 09435 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 09436 * 09437 * ===================================================================== 09438 * 09439 * .. Parameters .. 09440 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 09441 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 09442 $ RSRC_ 09443 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 09444 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 09445 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 09446 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 09447 * .. 09448 * .. Local Scalars .. 09449 INTEGER MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW 09450 * .. 09451 * .. Local Arrays .. 09452 INTEGER DESCA2( DLEN_ ) 09453 * .. 09454 * .. External Subroutines .. 09455 EXTERNAL BLACS_GRIDINFO, PB_DESCTRANS, PB_PCLAPRN2 09456 * .. 09457 * .. Executable Statements .. 09458 * 09459 * Quick return if possible 09460 * 09461 IF( ( M.LE.0 ).OR.( N.LE.0 ) ) 09462 $ RETURN 09463 * 09464 * Convert descriptor 09465 * 09466 CALL PB_DESCTRANS( DESCA, DESCA2 ) 09467 * 09468 CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL ) 09469 * 09470 IF( DESCA2( RSRC_ ).GE.0 ) THEN 09471 IF( DESCA2( CSRC_ ).GE.0 ) THEN 09472 CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT, 09473 $ CMATNM, NOUT, DESCA2( RSRC_ ), 09474 $ DESCA2( CSRC_ ), WORK ) 09475 ELSE 09476 DO 10 PCOL = 0, NPCOL - 1 09477 IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) ) 09478 $ WRITE( NOUT, * ) 'Colum-replicated array -- ' , 09479 $ 'copy in process column: ', PCOL 09480 CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, 09481 $ ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ), 09482 $ PCOL, WORK ) 09483 10 CONTINUE 09484 END IF 09485 ELSE 09486 IF( DESCA2( CSRC_ ).GE.0 ) THEN 09487 DO 20 PROW = 0, NPROW - 1 09488 IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) ) 09489 $ WRITE( NOUT, * ) 'Row-replicated array -- ' , 09490 $ 'copy in process row: ', PROW 09491 CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, 09492 $ ICPRNT, CMATNM, NOUT, PROW, 09493 $ DESCA2( CSRC_ ), WORK ) 09494 20 CONTINUE 09495 ELSE 09496 DO 40 PROW = 0, NPROW - 1 09497 DO 30 PCOL = 0, NPCOL - 1 09498 IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) ) 09499 $ WRITE( NOUT, * ) 'Replicated array -- ' , 09500 $ 'copy in process (', PROW, ',', PCOL, ')' 09501 CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, 09502 $ ICPRNT, CMATNM, NOUT, PROW, PCOL, 09503 $ WORK ) 09504 30 CONTINUE 09505 40 CONTINUE 09506 END IF 09507 END IF 09508 * 09509 RETURN 09510 * 09511 * End of PB_PCLAPRNT 09512 * 09513 END 09514 SUBROUTINE PB_PCLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, 09515 $ CMATNM, NOUT, PROW, PCOL, WORK ) 09516 * 09517 * -- PBLAS test routine (version 2.0) -- 09518 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09519 * and University of California, Berkeley. 09520 * April 1, 1998 09521 * 09522 * .. Scalar Arguments .. 09523 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW 09524 * .. 09525 * .. Array Arguments .. 09526 CHARACTER*(*) CMATNM 09527 INTEGER DESCA( * ) 09528 COMPLEX A( * ), WORK( * ) 09529 * .. 09530 * 09531 * .. Parameters .. 09532 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 09533 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 09534 $ RSRC_ 09535 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 09536 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 09537 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 09538 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 09539 * .. 09540 * .. Local Scalars .. 09541 LOGICAL AISCOLREP, AISROWREP 09542 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL, 09543 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K, 09544 $ LDA, LDW, MYCOL, MYROW, NPCOL, NPROW 09545 * .. 09546 * .. External Subroutines .. 09547 EXTERNAL BLACS_BARRIER, BLACS_GRIDINFO, CGERV2D, 09548 $ CGESD2D, PB_INFOG2L 09549 * .. 09550 * .. Intrinsic Functions .. 09551 INTRINSIC AIMAG, MIN, REAL 09552 * .. 09553 * .. Executable Statements .. 09554 * 09555 * Get grid parameters 09556 * 09557 ICTXT = DESCA( CTXT_ ) 09558 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 09559 CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, 09560 $ IIA, JJA, IAROW, IACOL ) 09561 II = IIA 09562 JJ = JJA 09563 IF( DESCA( RSRC_ ).LT.0 ) THEN 09564 AISROWREP = .TRUE. 09565 IAROW = PROW 09566 ICURROW = PROW 09567 ELSE 09568 AISROWREP = .FALSE. 09569 ICURROW = IAROW 09570 END IF 09571 IF( DESCA( CSRC_ ).LT.0 ) THEN 09572 AISCOLREP = .TRUE. 09573 IACOL = PCOL 09574 ICURCOL = PCOL 09575 ELSE 09576 AISCOLREP = .FALSE. 09577 ICURCOL = IACOL 09578 END IF 09579 LDA = DESCA( LLD_ ) 09580 LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) ) 09581 * 09582 * Handle the first block of column separately 09583 * 09584 JB = DESCA( INB_ ) - JA + 1 09585 IF( JB.LE.0 ) 09586 $ JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB 09587 JB = MIN( JB, N ) 09588 JN = JA+JB-1 09589 DO 60 H = 0, JB-1 09590 IB = DESCA( IMB_ ) - IA + 1 09591 IF( IB.LE.0 ) 09592 $ IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB 09593 IB = MIN( IB, M ) 09594 IN = IA+IB-1 09595 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09596 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09597 DO 10 K = 0, IB-1 09598 WRITE( NOUT, FMT = 9999 ) 09599 $ CMATNM, IA+K, JA+H, 09600 $ REAL( A(II+K+(JJ+H-1)*LDA) ), 09601 $ AIMAG( A(II+K+(JJ+H-1)*LDA) ) 09602 10 CONTINUE 09603 END IF 09604 ELSE 09605 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09606 CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA, 09607 $ IRPRNT, ICPRNT ) 09608 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09609 CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL ) 09610 DO 20 K = 1, IB 09611 WRITE( NOUT, FMT = 9999 ) 09612 $ CMATNM, IA+K-1, JA+H, REAL( WORK( K ) ), 09613 $ AIMAG( WORK( K ) ) 09614 20 CONTINUE 09615 END IF 09616 END IF 09617 IF( MYROW.EQ.ICURROW ) 09618 $ II = II + IB 09619 IF( .NOT.AISROWREP ) 09620 $ ICURROW = MOD( ICURROW+1, NPROW ) 09621 CALL BLACS_BARRIER( ICTXT, 'All' ) 09622 * 09623 * Loop over remaining block of rows 09624 * 09625 DO 50 I = IN+1, IA+M-1, DESCA( MB_ ) 09626 IB = MIN( DESCA( MB_ ), IA+M-I ) 09627 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09628 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09629 DO 30 K = 0, IB-1 09630 WRITE( NOUT, FMT = 9999 ) 09631 $ CMATNM, I+K, JA+H, 09632 $ REAL( A( II+K+(JJ+H-1)*LDA ) ), 09633 $ AIMAG( A( II+K+(JJ+H-1)*LDA ) ) 09634 30 CONTINUE 09635 END IF 09636 ELSE 09637 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09638 CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), 09639 $ LDA, IRPRNT, ICPRNT ) 09640 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09641 CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, 09642 $ ICURCOL ) 09643 DO 40 K = 1, IB 09644 WRITE( NOUT, FMT = 9999 ) 09645 $ CMATNM, I+K-1, JA+H, REAL( WORK( K ) ), 09646 $ AIMAG( WORK( K ) ) 09647 40 CONTINUE 09648 END IF 09649 END IF 09650 IF( MYROW.EQ.ICURROW ) 09651 $ II = II + IB 09652 IF( .NOT.AISROWREP ) 09653 $ ICURROW = MOD( ICURROW+1, NPROW ) 09654 CALL BLACS_BARRIER( ICTXT, 'All' ) 09655 50 CONTINUE 09656 * 09657 II = IIA 09658 ICURROW = IAROW 09659 60 CONTINUE 09660 * 09661 IF( MYCOL.EQ.ICURCOL ) 09662 $ JJ = JJ + JB 09663 IF( .NOT.AISCOLREP ) 09664 $ ICURCOL = MOD( ICURCOL+1, NPCOL ) 09665 CALL BLACS_BARRIER( ICTXT, 'All' ) 09666 * 09667 * Loop over remaining column blocks 09668 * 09669 DO 130 J = JN+1, JA+N-1, DESCA( NB_ ) 09670 JB = MIN( DESCA( NB_ ), JA+N-J ) 09671 DO 120 H = 0, JB-1 09672 IB = DESCA( IMB_ )-IA+1 09673 IF( IB.LE.0 ) 09674 $ IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB 09675 IB = MIN( IB, M ) 09676 IN = IA+IB-1 09677 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09678 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09679 DO 70 K = 0, IB-1 09680 WRITE( NOUT, FMT = 9999 ) 09681 $ CMATNM, IA+K, J+H, 09682 $ REAL( A( II+K+(JJ+H-1)*LDA ) ), 09683 $ AIMAG( A( II+K+(JJ+H-1)*LDA ) ) 09684 70 CONTINUE 09685 END IF 09686 ELSE 09687 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09688 CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), 09689 $ LDA, IRPRNT, ICPRNT ) 09690 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09691 CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, 09692 $ ICURCOL ) 09693 DO 80 K = 1, IB 09694 WRITE( NOUT, FMT = 9999 ) 09695 $ CMATNM, IA+K-1, J+H, REAL( WORK( K ) ), 09696 $ AIMAG( WORK( K ) ) 09697 80 CONTINUE 09698 END IF 09699 END IF 09700 IF( MYROW.EQ.ICURROW ) 09701 $ II = II + IB 09702 ICURROW = MOD( ICURROW+1, NPROW ) 09703 CALL BLACS_BARRIER( ICTXT, 'All' ) 09704 * 09705 * Loop over remaining block of rows 09706 * 09707 DO 110 I = IN+1, IA+M-1, DESCA( MB_ ) 09708 IB = MIN( DESCA( MB_ ), IA+M-I ) 09709 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09710 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09711 DO 90 K = 0, IB-1 09712 WRITE( NOUT, FMT = 9999 ) 09713 $ CMATNM, I+K, J+H, 09714 $ REAL( A( II+K+(JJ+H-1)*LDA ) ), 09715 $ AIMAG( A( II+K+(JJ+H-1)*LDA ) ) 09716 90 CONTINUE 09717 END IF 09718 ELSE 09719 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09720 CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), 09721 $ LDA, IRPRNT, ICPRNT ) 09722 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09723 CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, 09724 $ ICURCOL ) 09725 DO 100 K = 1, IB 09726 WRITE( NOUT, FMT = 9999 ) 09727 $ CMATNM, I+K-1, J+H, REAL( WORK( K ) ), 09728 $ AIMAG( WORK( K ) ) 09729 100 CONTINUE 09730 END IF 09731 END IF 09732 IF( MYROW.EQ.ICURROW ) 09733 $ II = II + IB 09734 IF( .NOT.AISROWREP ) 09735 $ ICURROW = MOD( ICURROW+1, NPROW ) 09736 CALL BLACS_BARRIER( ICTXT, 'All' ) 09737 110 CONTINUE 09738 * 09739 II = IIA 09740 ICURROW = IAROW 09741 120 CONTINUE 09742 * 09743 IF( MYCOL.EQ.ICURCOL ) 09744 $ JJ = JJ + JB 09745 IF( .NOT.AISCOLREP ) 09746 $ ICURCOL = MOD( ICURCOL+1, NPCOL ) 09747 CALL BLACS_BARRIER( ICTXT, 'All' ) 09748 * 09749 130 CONTINUE 09750 * 09751 9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', E16.8, '+i*(', 09752 $ E16.8, ')' ) 09753 * 09754 RETURN 09755 * 09756 * End of PB_PCLAPRN2 09757 * 09758 END 09759 SUBROUTINE PB_CFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL ) 09760 * 09761 * -- PBLAS test routine (version 2.0) -- 09762 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09763 * and University of California, Berkeley. 09764 * April 1, 1998 09765 * 09766 * .. Scalar Arguments .. 09767 INTEGER ICTXT, IPOST, IPRE, LDA, M, N 09768 COMPLEX CHKVAL 09769 * .. 09770 * .. Array Arguments .. 09771 COMPLEX A( * ) 09772 * .. 09773 * 09774 * Purpose 09775 * ======= 09776 * 09777 * PB_CFILLPAD surrounds a two dimensional local array with a guard-zone 09778 * initialized to the value CHKVAL. The user may later call the routine 09779 * PB_CCHEKPAD to discover if the guardzone has been violated. There are 09780 * three guardzones. The first is a buffer of size IPRE that is before 09781 * the start of the array. The second is the buffer of size IPOST which 09782 * is after the end of the array to be padded. Finally, there is a guard 09783 * zone inside every column of the array to be padded, in the elements 09784 * of A(M+1:LDA, J). 09785 * 09786 * Arguments 09787 * ========= 09788 * 09789 * ICTXT (local input) INTEGER 09790 * On entry, ICTXT specifies the BLACS context handle, indica- 09791 * ting the global context of the operation. The context itself 09792 * is global, but the value of ICTXT is local. 09793 * 09794 * M (local input) INTEGER 09795 * On entry, M specifies the number of rows in the local array 09796 * A. M must be at least zero. 09797 * 09798 * N (local input) INTEGER 09799 * On entry, N specifies the number of columns in the local ar- 09800 * ray A. N must be at least zero. 09801 * 09802 * A (local input/local output) COMPLEX array 09803 * On entry, A is an array of dimension (LDA,N). On exit, this 09804 * array is the padded array. 09805 * 09806 * LDA (local input) INTEGER 09807 * On entry, LDA specifies the leading dimension of the local 09808 * array to be padded. LDA must be at least MAX( 1, M ). 09809 * 09810 * IPRE (local input) INTEGER 09811 * On entry, IPRE specifies the size of the guard zone to put 09812 * before the start of the padded array. 09813 * 09814 * IPOST (local input) INTEGER 09815 * On entry, IPOST specifies the size of the guard zone to put 09816 * after the end of the padded array. 09817 * 09818 * CHKVAL (local input) COMPLEX 09819 * On entry, CHKVAL specifies the value to pad the array with. 09820 * 09821 * -- Written on April 1, 1998 by 09822 * R. Clint Whaley, University of Tennessee, Knoxville 37996, USA. 09823 * 09824 * ===================================================================== 09825 * 09826 * .. Local Scalars .. 09827 INTEGER I, J, K 09828 * .. 09829 * .. Executable Statements .. 09830 * 09831 * Put check buffer in front of A 09832 * 09833 IF( IPRE.GT.0 ) THEN 09834 DO 10 I = 1, IPRE 09835 A( I ) = CHKVAL 09836 10 CONTINUE 09837 ELSE 09838 WRITE( *, FMT = '(A)' ) 09839 $ 'WARNING no pre-guardzone in PB_CFILLPAD' 09840 END IF 09841 * 09842 * Put check buffer in back of A 09843 * 09844 IF( IPOST.GT.0 ) THEN 09845 J = IPRE+LDA*N+1 09846 DO 20 I = J, J+IPOST-1 09847 A( I ) = CHKVAL 09848 20 CONTINUE 09849 ELSE 09850 WRITE( *, FMT = '(A)' ) 09851 $ 'WARNING no post-guardzone in PB_CFILLPAD' 09852 END IF 09853 * 09854 * Put check buffer in all (LDA-M) gaps 09855 * 09856 IF( LDA.GT.M ) THEN 09857 K = IPRE + M + 1 09858 DO 40 J = 1, N 09859 DO 30 I = K, K + ( LDA - M ) - 1 09860 A( I ) = CHKVAL 09861 30 CONTINUE 09862 K = K + LDA 09863 40 CONTINUE 09864 END IF 09865 * 09866 RETURN 09867 * 09868 * End of PB_CFILLPAD 09869 * 09870 END 09871 SUBROUTINE PB_CCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST, 09872 $ CHKVAL ) 09873 * 09874 * -- PBLAS test routine (version 2.0) -- 09875 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09876 * and University of California, Berkeley. 09877 * April 1, 1998 09878 * 09879 * .. Scalar Arguments .. 09880 INTEGER ICTXT, IPOST, IPRE, LDA, M, N 09881 COMPLEX CHKVAL 09882 * .. 09883 * .. Array Arguments .. 09884 CHARACTER*(*) MESS 09885 COMPLEX A( * ) 09886 * .. 09887 * 09888 * Purpose 09889 * ======= 09890 * 09891 * PB_CCHEKPAD checks that the padding around a local array has not been 09892 * overwritten since the call to PB_CFILLPAD. Three types of errors are 09893 * reported: 09894 * 09895 * 1) Overwrite in pre-guardzone. This indicates a memory overwrite has 09896 * occurred in the first IPRE elements which form a buffer before the 09897 * beginning of A. Therefore, the error message: 09898 * 'Overwrite in pre-guardzone: loc( 5) = 18.00000' 09899 * tells that the 5th element of the IPRE long buffer has been overwrit- 09900 * ten with the value 18, where it should still have the value CHKVAL. 09901 * 09902 * 2) Overwrite in post-guardzone. This indicates a memory overwrite has 09903 * occurred in the last IPOST elements which form a buffer after the end 09904 * of A. Error reports are refered from the end of A. Therefore, 09905 * 'Overwrite in post-guardzone: loc( 19) = 24.00000' 09906 * tells that the 19th element after the end of A was overwritten with 09907 * the value 24, where it should still have the value of CHKVAL. 09908 * 09909 * 3) Overwrite in lda-m gap. Tells you elements between M and LDA were 09910 * overwritten. So, 09911 * 'Overwrite in lda-m gap: A( 12, 3) = 22.00000' 09912 * tells that the element at the 12th row and 3rd column of A was over- 09913 * written with the value of 22, where it should still have the value of 09914 * CHKVAL. 09915 * 09916 * Arguments 09917 * ========= 09918 * 09919 * ICTXT (local input) INTEGER 09920 * On entry, ICTXT specifies the BLACS context handle, indica- 09921 * ting the global context of the operation. The context itself 09922 * is global, but the value of ICTXT is local. 09923 * 09924 * MESS (local input) CHARACTER*(*) 09925 * On entry, MESS is a ttring containing a user-defined message. 09926 * 09927 * M (local input) INTEGER 09928 * On entry, M specifies the number of rows in the local array 09929 * A. M must be at least zero. 09930 * 09931 * N (local input) INTEGER 09932 * On entry, N specifies the number of columns in the local ar- 09933 * ray A. N must be at least zero. 09934 * 09935 * A (local input) COMPLEX array 09936 * On entry, A is an array of dimension (LDA,N). 09937 * 09938 * LDA (local input) INTEGER 09939 * On entry, LDA specifies the leading dimension of the local 09940 * array to be padded. LDA must be at least MAX( 1, M ). 09941 * 09942 * IPRE (local input) INTEGER 09943 * On entry, IPRE specifies the size of the guard zone to put 09944 * before the start of the padded array. 09945 * 09946 * IPOST (local input) INTEGER 09947 * On entry, IPOST specifies the size of the guard zone to put 09948 * after the end of the padded array. 09949 * 09950 * CHKVAL (local input) COMPLEX 09951 * On entry, CHKVAL specifies the value to pad the array with. 09952 * 09953 * 09954 * -- Written on April 1, 1998 by 09955 * R. Clint Whaley, University of Tennessee, Knoxville 37996, USA. 09956 * 09957 * ===================================================================== 09958 * 09959 * .. Local Scalars .. 09960 CHARACTER*1 TOP 09961 INTEGER I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL, 09962 $ NPROW 09963 * .. 09964 * .. External Subroutines .. 09965 EXTERNAL BLACS_GRIDINFO, IGAMX2D, PB_TOPGET 09966 * .. 09967 * .. Intrinsic Functions .. 09968 INTRINSIC AIMAG, REAL 09969 * .. 09970 * .. Executable Statements .. 09971 * 09972 * Get grid parameters 09973 * 09974 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 09975 IAM = MYROW*NPCOL + MYCOL 09976 INFO = -1 09977 * 09978 * Check buffer in front of A 09979 * 09980 IF( IPRE.GT.0 ) THEN 09981 DO 10 I = 1, IPRE 09982 IF( A( I ).NE.CHKVAL ) THEN 09983 WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I, 09984 $ REAL( A( I ) ), AIMAG( A( I ) ) 09985 INFO = IAM 09986 END IF 09987 10 CONTINUE 09988 ELSE 09989 WRITE( *, FMT = * ) 'WARNING no pre-guardzone in PB_CCHEKPAD' 09990 END IF 09991 * 09992 * Check buffer after A 09993 * 09994 IF( IPOST.GT.0 ) THEN 09995 J = IPRE+LDA*N+1 09996 DO 20 I = J, J+IPOST-1 09997 IF( A( I ).NE.CHKVAL ) THEN 09998 WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post', 09999 $ I-J+1, REAL( A( I ) ), 10000 $ AIMAG( A( I ) ) 10001 INFO = IAM 10002 END IF 10003 20 CONTINUE 10004 ELSE 10005 WRITE( *, FMT = * ) 10006 $ 'WARNING no post-guardzone buffer in PB_CCHEKPAD' 10007 END IF 10008 * 10009 * Check all (LDA-M) gaps 10010 * 10011 IF( LDA.GT.M ) THEN 10012 K = IPRE + M + 1 10013 DO 40 J = 1, N 10014 DO 30 I = K, K + (LDA-M) - 1 10015 IF( A( I ).NE.CHKVAL ) THEN 10016 WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS, 10017 $ I-IPRE-LDA*(J-1), J, REAL( A( I ) ), 10018 $ AIMAG( A( I ) ) 10019 INFO = IAM 10020 END IF 10021 30 CONTINUE 10022 K = K + LDA 10023 40 CONTINUE 10024 END IF 10025 * 10026 CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP ) 10027 CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1, 10028 $ 0, 0 ) 10029 IF( IAM.EQ.0 .AND. INFO.GE.0 ) THEN 10030 WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS 10031 END IF 10032 * 10033 9999 FORMAT( '{', I5, ',', I5, '}: Memory overwrite in ', A ) 10034 9998 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ', 10035 $ A4, '-guardzone: loc(', I3, ') = ', G11.4, '+ i*', 10036 $ G11.4 ) 10037 9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ', 10038 $ 'lda-m gap: loc(', I3, ',', I3, ') = ', G11.4, 10039 $ '+ i*', G11.4 ) 10040 * 10041 RETURN 10042 * 10043 * End of PB_CCHEKPAD 10044 * 10045 END 10046 SUBROUTINE PB_CLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA ) 10047 * 10048 * -- PBLAS test routine (version 2.0) -- 10049 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 10050 * and University of California, Berkeley. 10051 * April 1, 1998 10052 * 10053 * .. Scalar Arguments .. 10054 CHARACTER*1 UPLO 10055 INTEGER IOFFD, LDA, M, N 10056 COMPLEX ALPHA, BETA 10057 * .. 10058 * .. Array Arguments .. 10059 COMPLEX A( LDA, * ) 10060 * .. 10061 * 10062 * Purpose 10063 * ======= 10064 * 10065 * PB_CLASET initializes a two-dimensional array A to beta on the diago- 10066 * nal specified by IOFFD and alpha on the offdiagonals. 10067 * 10068 * Arguments 10069 * ========= 10070 * 10071 * UPLO (global input) CHARACTER*1 10072 * On entry, UPLO specifies which trapezoidal part of the ar- 10073 * ray A is to be set as follows: 10074 * = 'L' or 'l': Lower triangular part is set; the strictly 10075 * upper triangular part of A is not changed, 10076 * = 'U' or 'u': Upper triangular part is set; the strictly 10077 * lower triangular part of A is not changed, 10078 * = 'D' or 'd' Only the diagonal of A is set, 10079 * Otherwise: All of the array A is set. 10080 * 10081 * M (input) INTEGER 10082 * On entry, M specifies the number of rows of the array A. M 10083 * must be at least zero. 10084 * 10085 * N (input) INTEGER 10086 * On entry, N specifies the number of columns of the array A. 10087 * N must be at least zero. 10088 * 10089 * IOFFD (input) INTEGER 10090 * On entry, IOFFD specifies the position of the offdiagonal de- 10091 * limiting the upper and lower trapezoidal part of A as follows 10092 * (see the notes below): 10093 * 10094 * IOFFD = 0 specifies the main diagonal A( i, i ), 10095 * with i = 1 ... MIN( M, N ), 10096 * IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ), 10097 * with i = 1 ... MIN( M-IOFFD, N ), 10098 * IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ), 10099 * with i = 1 ... MIN( M, N+IOFFD ). 10100 * 10101 * ALPHA (input) COMPLEX 10102 * On entry, ALPHA specifies the value to which the offdiagonal 10103 * array elements are set to. 10104 * 10105 * BETA (input) COMPLEX 10106 * On entry, BETA specifies the value to which the diagonal ar- 10107 * ray elements are set to. 10108 * 10109 * A (input/output) COMPLEX array 10110 * On entry, A is an array of dimension (LDA,N). Before entry 10111 * with UPLO = 'U' or 'u', the leading m by n part of the array 10112 * A must contain the upper trapezoidal part of the matrix as 10113 * specified by IOFFD to be set, and the strictly lower trape- 10114 * zoidal part of A is not referenced; When IUPLO = 'L' or 'l', 10115 * the leading m by n part of the array A must contain the 10116 * lower trapezoidal part of the matrix as specified by IOFFD to 10117 * be set, and the strictly upper trapezoidal part of A is 10118 * not referenced. 10119 * 10120 * LDA (input) INTEGER 10121 * On entry, LDA specifies the leading dimension of the array A. 10122 * LDA must be at least max( 1, M ). 10123 * 10124 * Notes 10125 * ===== 10126 * N N 10127 * ---------------------------- ----------- 10128 * | d | | | 10129 * M | d 'U' | | 'U' | 10130 * | 'L' 'D' | |d | 10131 * | d | M | d | 10132 * ---------------------------- | 'D' | 10133 * | d | 10134 * IOFFD < 0 | 'L' d | 10135 * | d| 10136 * N | | 10137 * ----------- ----------- 10138 * | d 'U'| 10139 * | d | IOFFD > 0 10140 * M | 'D' | 10141 * | d| N 10142 * | 'L' | ---------------------------- 10143 * | | | 'U' | 10144 * | | |d | 10145 * | | | 'D' | 10146 * | | | d | 10147 * | | |'L' d | 10148 * ----------- ---------------------------- 10149 * 10150 * -- Written on April 1, 1998 by 10151 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 10152 * 10153 * ===================================================================== 10154 * 10155 * .. Local Scalars .. 10156 INTEGER I, J, JTMP, MN 10157 * .. 10158 * .. External Functions .. 10159 LOGICAL LSAME 10160 EXTERNAL LSAME 10161 * .. 10162 * .. Intrinsic Functions .. 10163 INTRINSIC MAX, MIN 10164 * .. 10165 * .. Executable Statements .. 10166 * 10167 * Quick return if possible 10168 * 10169 IF( M.LE.0 .OR. N.LE.0 ) 10170 $ RETURN 10171 * 10172 * Start the operations 10173 * 10174 IF( LSAME( UPLO, 'L' ) ) THEN 10175 * 10176 * Set the diagonal to BETA and the strictly lower triangular 10177 * part of the array to ALPHA. 10178 * 10179 MN = MAX( 0, -IOFFD ) 10180 DO 20 J = 1, MIN( MN, N ) 10181 DO 10 I = 1, M 10182 A( I, J ) = ALPHA 10183 10 CONTINUE 10184 20 CONTINUE 10185 DO 40 J = MN + 1, MIN( M - IOFFD, N ) 10186 JTMP = J + IOFFD 10187 A( JTMP, J ) = BETA 10188 DO 30 I = JTMP + 1, M 10189 A( I, J ) = ALPHA 10190 30 CONTINUE 10191 40 CONTINUE 10192 * 10193 ELSE IF( LSAME( UPLO, 'U' ) ) THEN 10194 * 10195 * Set the diagonal to BETA and the strictly upper triangular 10196 * part of the array to ALPHA. 10197 * 10198 MN = MIN( M - IOFFD, N ) 10199 DO 60 J = MAX( 0, -IOFFD ) + 1, MN 10200 JTMP = J + IOFFD 10201 DO 50 I = 1, JTMP - 1 10202 A( I, J ) = ALPHA 10203 50 CONTINUE 10204 A( JTMP, J ) = BETA 10205 60 CONTINUE 10206 DO 80 J = MAX( 0, MN ) + 1, N 10207 DO 70 I = 1, M 10208 A( I, J ) = ALPHA 10209 70 CONTINUE 10210 80 CONTINUE 10211 * 10212 ELSE IF( LSAME( UPLO, 'D' ) ) THEN 10213 * 10214 * Set the array to BETA on the diagonal. 10215 * 10216 DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N ) 10217 A( J + IOFFD, J ) = BETA 10218 90 CONTINUE 10219 * 10220 ELSE 10221 * 10222 * Set the array to BETA on the diagonal and ALPHA on the 10223 * offdiagonal. 10224 * 10225 DO 110 J = 1, N 10226 DO 100 I = 1, M 10227 A( I, J ) = ALPHA 10228 100 CONTINUE 10229 110 CONTINUE 10230 IF( ALPHA.NE.BETA .AND. IOFFD.LT.M .AND. IOFFD.GT.-N ) THEN 10231 DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N ) 10232 A( J + IOFFD, J ) = BETA 10233 120 CONTINUE 10234 END IF 10235 * 10236 END IF 10237 * 10238 RETURN 10239 * 10240 * End of PB_CLASET 10241 * 10242 END 10243 SUBROUTINE PB_CLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA ) 10244 * 10245 * -- PBLAS test routine (version 2.0) -- 10246 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 10247 * and University of California, Berkeley. 10248 * April 1, 1998 10249 * 10250 * .. Scalar Arguments .. 10251 CHARACTER*1 UPLO 10252 INTEGER IOFFD, LDA, M, N 10253 COMPLEX ALPHA 10254 * .. 10255 * .. Array Arguments .. 10256 COMPLEX A( LDA, * ) 10257 * .. 10258 * 10259 * Purpose 10260 * ======= 10261 * 10262 * PB_CLASCAL scales a two-dimensional array A by the scalar alpha. 10263 * 10264 * Arguments 10265 * ========= 10266 * 10267 * UPLO (input) CHARACTER*1 10268 * On entry, UPLO specifies which trapezoidal part of the ar- 10269 * ray A is to be scaled as follows: 10270 * = 'L' or 'l': the lower trapezoid of A is scaled, 10271 * = 'U' or 'u': the upper trapezoid of A is scaled, 10272 * = 'D' or 'd': diagonal specified by IOFFD is scaled, 10273 * Otherwise: all of the array A is scaled. 10274 * 10275 * M (input) INTEGER 10276 * On entry, M specifies the number of rows of the array A. M 10277 * must be at least zero. 10278 * 10279 * N (input) INTEGER 10280 * On entry, N specifies the number of columns of the array A. 10281 * N must be at least zero. 10282 * 10283 * IOFFD (input) INTEGER 10284 * On entry, IOFFD specifies the position of the offdiagonal de- 10285 * limiting the upper and lower trapezoidal part of A as follows 10286 * (see the notes below): 10287 * 10288 * IOFFD = 0 specifies the main diagonal A( i, i ), 10289 * with i = 1 ... MIN( M, N ), 10290 * IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ), 10291 * with i = 1 ... MIN( M-IOFFD, N ), 10292 * IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ), 10293 * with i = 1 ... MIN( M, N+IOFFD ). 10294 * 10295 * ALPHA (input) COMPLEX 10296 * On entry, ALPHA specifies the scalar alpha. 10297 * 10298 * A (input/output) COMPLEX array 10299 * On entry, A is an array of dimension (LDA,N). Before entry 10300 * with UPLO = 'U' or 'u', the leading m by n part of the array 10301 * A must contain the upper trapezoidal part of the matrix as 10302 * specified by IOFFD to be scaled, and the strictly lower tra- 10303 * pezoidal part of A is not referenced; When UPLO = 'L' or 'l', 10304 * the leading m by n part of the array A must contain the lower 10305 * trapezoidal part of the matrix as specified by IOFFD to be 10306 * scaled, and the strictly upper trapezoidal part of A is not 10307 * referenced. On exit, the entries of the trapezoid part of A 10308 * determined by UPLO and IOFFD are scaled. 10309 * 10310 * LDA (input) INTEGER 10311 * On entry, LDA specifies the leading dimension of the array A. 10312 * LDA must be at least max( 1, M ). 10313 * 10314 * Notes 10315 * ===== 10316 * N N 10317 * ---------------------------- ----------- 10318 * | d | | | 10319 * M | d 'U' | | 'U' | 10320 * | 'L' 'D' | |d | 10321 * | d | M | d | 10322 * ---------------------------- | 'D' | 10323 * | d | 10324 * IOFFD < 0 | 'L' d | 10325 * | d| 10326 * N | | 10327 * ----------- ----------- 10328 * | d 'U'| 10329 * | d | IOFFD > 0 10330 * M | 'D' | 10331 * | d| N 10332 * | 'L' | ---------------------------- 10333 * | | | 'U' | 10334 * | | |d | 10335 * | | | 'D' | 10336 * | | | d | 10337 * | | |'L' d | 10338 * ----------- ---------------------------- 10339 * 10340 * -- Written on April 1, 1998 by 10341 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 10342 * 10343 * ===================================================================== 10344 * 10345 * .. Local Scalars .. 10346 INTEGER I, J, JTMP, MN 10347 * .. 10348 * .. External Functions .. 10349 LOGICAL LSAME 10350 EXTERNAL LSAME 10351 * .. 10352 * .. Intrinsic Functions .. 10353 INTRINSIC MAX, MIN 10354 * .. 10355 * .. Executable Statements .. 10356 * 10357 * Quick return if possible 10358 * 10359 IF( M.LE.0 .OR. N.LE.0 ) 10360 $ RETURN 10361 * 10362 * Start the operations 10363 * 10364 IF( LSAME( UPLO, 'L' ) ) THEN 10365 * 10366 * Scales the lower triangular part of the array by ALPHA. 10367 * 10368 MN = MAX( 0, -IOFFD ) 10369 DO 20 J = 1, MIN( MN, N ) 10370 DO 10 I = 1, M 10371 A( I, J ) = ALPHA * A( I, J ) 10372 10 CONTINUE 10373 20 CONTINUE 10374 DO 40 J = MN + 1, MIN( M - IOFFD, N ) 10375 DO 30 I = J + IOFFD, M 10376 A( I, J ) = ALPHA * A( I, J ) 10377 30 CONTINUE 10378 40 CONTINUE 10379 * 10380 ELSE IF( LSAME( UPLO, 'U' ) ) THEN 10381 * 10382 * Scales the upper triangular part of the array by ALPHA. 10383 * 10384 MN = MIN( M - IOFFD, N ) 10385 DO 60 J = MAX( 0, -IOFFD ) + 1, MN 10386 DO 50 I = 1, J + IOFFD 10387 A( I, J ) = ALPHA * A( I, J ) 10388 50 CONTINUE 10389 60 CONTINUE 10390 DO 80 J = MAX( 0, MN ) + 1, N 10391 DO 70 I = 1, M 10392 A( I, J ) = ALPHA * A( I, J ) 10393 70 CONTINUE 10394 80 CONTINUE 10395 * 10396 ELSE IF( LSAME( UPLO, 'D' ) ) THEN 10397 * 10398 * Scales the diagonal entries by ALPHA. 10399 * 10400 DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N ) 10401 JTMP = J + IOFFD 10402 A( JTMP, J ) = ALPHA * A( JTMP, J ) 10403 90 CONTINUE 10404 * 10405 ELSE 10406 * 10407 * Scales the entire array by ALPHA. 10408 * 10409 DO 110 J = 1, N 10410 DO 100 I = 1, M 10411 A( I, J ) = ALPHA * A( I, J ) 10412 100 CONTINUE 10413 110 CONTINUE 10414 * 10415 END IF 10416 * 10417 RETURN 10418 * 10419 * End of PB_CLASCAL 10420 * 10421 END 10422 SUBROUTINE PB_CLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS, 10423 $ IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB, 10424 $ LNBLOC, JMP, IMULADD ) 10425 * 10426 * -- PBLAS test routine (version 2.0) -- 10427 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 10428 * and University of California, Berkeley. 10429 * April 1, 1998 10430 * 10431 * .. Scalar Arguments .. 10432 CHARACTER*1 UPLO, AFORM 10433 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC, 10434 $ MB, MBLKS, NB, NBLKS 10435 * .. 10436 * .. Array Arguments .. 10437 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * ) 10438 COMPLEX A( LDA, * ) 10439 * .. 10440 * 10441 * Purpose 10442 * ======= 10443 * 10444 * PB_CLAGEN locally initializes an array A. 10445 * 10446 * Arguments 10447 * ========= 10448 * 10449 * UPLO (global input) CHARACTER*1 10450 * On entry, UPLO specifies whether the lower (UPLO='L') trape- 10451 * zoidal part or the upper (UPLO='U') trapezoidal part is to be 10452 * generated when the matrix to be generated is symmetric or 10453 * Hermitian. For all the other values of AFORM, the value of 10454 * this input argument is ignored. 10455 * 10456 * AFORM (global input) CHARACTER*1 10457 * On entry, AFORM specifies the type of submatrix to be genera- 10458 * ted as follows: 10459 * AFORM = 'S', sub( A ) is a symmetric matrix, 10460 * AFORM = 'H', sub( A ) is a Hermitian matrix, 10461 * AFORM = 'T', sub( A ) is overrwritten with the transpose 10462 * of what would normally be generated, 10463 * AFORM = 'C', sub( A ) is overwritten with the conjugate 10464 * transpose of what would normally be genera- 10465 * ted. 10466 * AFORM = 'N', a random submatrix is generated. 10467 * 10468 * A (local output) COMPLEX array 10469 * On entry, A is an array of dimension (LLD_A, *). On exit, 10470 * this array contains the local entries of the randomly genera- 10471 * ted submatrix sub( A ). 10472 * 10473 * LDA (local input) INTEGER 10474 * On entry, LDA specifies the local leading dimension of the 10475 * array A. LDA must be at least one. 10476 * 10477 * LCMT00 (global input) INTEGER 10478 * On entry, LCMT00 is the LCM value specifying the off-diagonal 10479 * of the underlying matrix of interest. LCMT00=0 specifies the 10480 * main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0 10481 * specifies superdiagonals. 10482 * 10483 * IRAN (local input) INTEGER array 10484 * On entry, IRAN is an array of dimension 2 containing respec- 10485 * tively the 16-lower and 16-higher bits of the encoding of the 10486 * entry of the random sequence corresponding locally to the 10487 * first local array entry to generate. Usually, this array is 10488 * computed by PB_SETLOCRAN. 10489 * 10490 * MBLKS (local input) INTEGER 10491 * On entry, MBLKS specifies the local number of blocks of rows. 10492 * MBLKS is at least zero. 10493 * 10494 * IMBLOC (local input) INTEGER 10495 * On entry, IMBLOC specifies the number of rows (size) of the 10496 * local uppest blocks. IMBLOC is at least zero. 10497 * 10498 * MB (global input) INTEGER 10499 * On entry, MB specifies the blocking factor used to partition 10500 * the rows of the matrix. MB must be at least one. 10501 * 10502 * LMBLOC (local input) INTEGER 10503 * On entry, LMBLOC specifies the number of rows (size) of the 10504 * local lowest blocks. LMBLOC is at least zero. 10505 * 10506 * NBLKS (local input) INTEGER 10507 * On entry, NBLKS specifies the local number of blocks of co- 10508 * lumns. NBLKS is at least zero. 10509 * 10510 * INBLOC (local input) INTEGER 10511 * On entry, INBLOC specifies the number of columns (size) of 10512 * the local leftmost blocks. INBLOC is at least zero. 10513 * 10514 * NB (global input) INTEGER 10515 * On entry, NB specifies the blocking factor used to partition 10516 * the the columns of the matrix. NB must be at least one. 10517 * 10518 * LNBLOC (local input) INTEGER 10519 * On entry, LNBLOC specifies the number of columns (size) of 10520 * the local rightmost blocks. LNBLOC is at least zero. 10521 * 10522 * JMP (local input) INTEGER array 10523 * On entry, JMP is an array of dimension JMP_LEN containing the 10524 * different jump values used by the random matrix generator. 10525 * 10526 * IMULADD (local input) INTEGER array 10527 * On entry, IMULADD is an array of dimension (4, JMP_LEN). The 10528 * jth column of this array contains the encoded initial cons- 10529 * tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) ) 10530 * (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j) 10531 * contains respectively the 16-lower and 16-higher bits of the 10532 * constant a_j, and IMULADD(3:4,j) contains the 16-lower and 10533 * 16-higher bits of the constant c_j. 10534 * 10535 * -- Written on April 1, 1998 by 10536 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 10537 * 10538 * ===================================================================== 10539 * 10540 * .. Parameters .. 10541 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN, 10542 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB, 10543 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW 10544 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3, 10545 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6, 10546 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9, 10547 $ JMP_NQNB = 10, JMP_NQINBLOC = 11, 10548 $ JMP_LEN = 11 ) 10549 REAL ZERO 10550 PARAMETER ( ZERO = 0.0E+0 ) 10551 * .. 10552 * .. Local Scalars .. 10553 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK, 10554 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP 10555 COMPLEX DUMMY 10556 * .. 10557 * .. Local Arrays .. 10558 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 ) 10559 * .. 10560 * .. External Subroutines .. 10561 EXTERNAL PB_JUMPIT 10562 * .. 10563 * .. External Functions .. 10564 LOGICAL LSAME 10565 REAL PB_SRAND 10566 EXTERNAL LSAME, PB_SRAND 10567 * .. 10568 * .. Intrinsic Functions .. 10569 INTRINSIC CMPLX, MAX, MIN, REAL 10570 * .. 10571 * .. Executable Statements .. 10572 * 10573 DO 10 I = 1, 2 10574 IB1( I ) = IRAN( I ) 10575 IB2( I ) = IRAN( I ) 10576 IB3( I ) = IRAN( I ) 10577 10 CONTINUE 10578 * 10579 IF( LSAME( AFORM, 'N' ) ) THEN 10580 * 10581 * Generate random matrix 10582 * 10583 JJ = 1 10584 * 10585 DO 50 JBLK = 1, NBLKS 10586 * 10587 IF( JBLK.EQ.1 ) THEN 10588 JB = INBLOC 10589 ELSE IF( JBLK.EQ.NBLKS ) THEN 10590 JB = LNBLOC 10591 ELSE 10592 JB = NB 10593 END IF 10594 * 10595 DO 40 JK = JJ, JJ + JB - 1 10596 * 10597 II = 1 10598 * 10599 DO 30 IBLK = 1, MBLKS 10600 * 10601 IF( IBLK.EQ.1 ) THEN 10602 IB = IMBLOC 10603 ELSE IF( IBLK.EQ.MBLKS ) THEN 10604 IB = LMBLOC 10605 ELSE 10606 IB = MB 10607 END IF 10608 * 10609 * Blocks are IB by JB 10610 * 10611 DO 20 IK = II, II + IB - 1 10612 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) ) 10613 20 CONTINUE 10614 * 10615 II = II + IB 10616 * 10617 IF( IBLK.EQ.1 ) THEN 10618 * 10619 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 10620 * 10621 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1, 10622 $ IB0 ) 10623 * 10624 ELSE 10625 * 10626 * Jump NPROW * MB rows 10627 * 10628 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 ) 10629 * 10630 END IF 10631 * 10632 IB1( 1 ) = IB0( 1 ) 10633 IB1( 2 ) = IB0( 2 ) 10634 * 10635 30 CONTINUE 10636 * 10637 * Jump one column 10638 * 10639 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 ) 10640 * 10641 IB1( 1 ) = IB0( 1 ) 10642 IB1( 2 ) = IB0( 2 ) 10643 IB2( 1 ) = IB0( 1 ) 10644 IB2( 2 ) = IB0( 2 ) 10645 * 10646 40 CONTINUE 10647 * 10648 JJ = JJ + JB 10649 * 10650 IF( JBLK.EQ.1 ) THEN 10651 * 10652 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 10653 * 10654 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 ) 10655 * 10656 ELSE 10657 * 10658 * Jump NPCOL * NB columns 10659 * 10660 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 ) 10661 * 10662 END IF 10663 * 10664 IB1( 1 ) = IB0( 1 ) 10665 IB1( 2 ) = IB0( 2 ) 10666 IB2( 1 ) = IB0( 1 ) 10667 IB2( 2 ) = IB0( 2 ) 10668 IB3( 1 ) = IB0( 1 ) 10669 IB3( 2 ) = IB0( 2 ) 10670 * 10671 50 CONTINUE 10672 * 10673 ELSE IF( LSAME( AFORM, 'T' ) ) THEN 10674 * 10675 * Generate the transpose of the matrix that would be normally 10676 * generated. 10677 * 10678 II = 1 10679 * 10680 DO 90 IBLK = 1, MBLKS 10681 * 10682 IF( IBLK.EQ.1 ) THEN 10683 IB = IMBLOC 10684 ELSE IF( IBLK.EQ.MBLKS ) THEN 10685 IB = LMBLOC 10686 ELSE 10687 IB = MB 10688 END IF 10689 * 10690 DO 80 IK = II, II + IB - 1 10691 * 10692 JJ = 1 10693 * 10694 DO 70 JBLK = 1, NBLKS 10695 * 10696 IF( JBLK.EQ.1 ) THEN 10697 JB = INBLOC 10698 ELSE IF( JBLK.EQ.NBLKS ) THEN 10699 JB = LNBLOC 10700 ELSE 10701 JB = NB 10702 END IF 10703 * 10704 * Blocks are IB by JB 10705 * 10706 DO 60 JK = JJ, JJ + JB - 1 10707 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) ) 10708 60 CONTINUE 10709 * 10710 JJ = JJ + JB 10711 * 10712 IF( JBLK.EQ.1 ) THEN 10713 * 10714 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 10715 * 10716 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1, 10717 $ IB0 ) 10718 * 10719 ELSE 10720 * 10721 * Jump NPCOL * NB columns 10722 * 10723 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 ) 10724 * 10725 END IF 10726 * 10727 IB1( 1 ) = IB0( 1 ) 10728 IB1( 2 ) = IB0( 2 ) 10729 * 10730 70 CONTINUE 10731 * 10732 * Jump one row 10733 * 10734 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 ) 10735 * 10736 IB1( 1 ) = IB0( 1 ) 10737 IB1( 2 ) = IB0( 2 ) 10738 IB2( 1 ) = IB0( 1 ) 10739 IB2( 2 ) = IB0( 2 ) 10740 * 10741 80 CONTINUE 10742 * 10743 II = II + IB 10744 * 10745 IF( IBLK.EQ.1 ) THEN 10746 * 10747 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 10748 * 10749 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 ) 10750 * 10751 ELSE 10752 * 10753 * Jump NPROW * MB rows 10754 * 10755 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 ) 10756 * 10757 END IF 10758 * 10759 IB1( 1 ) = IB0( 1 ) 10760 IB1( 2 ) = IB0( 2 ) 10761 IB2( 1 ) = IB0( 1 ) 10762 IB2( 2 ) = IB0( 2 ) 10763 IB3( 1 ) = IB0( 1 ) 10764 IB3( 2 ) = IB0( 2 ) 10765 * 10766 90 CONTINUE 10767 * 10768 ELSE IF( LSAME( AFORM, 'S' ) ) THEN 10769 * 10770 * Generate a symmetric matrix 10771 * 10772 IF( LSAME( UPLO, 'L' ) ) THEN 10773 * 10774 * generate lower trapezoidal part 10775 * 10776 JJ = 1 10777 LCMTC = LCMT00 10778 * 10779 DO 170 JBLK = 1, NBLKS 10780 * 10781 IF( JBLK.EQ.1 ) THEN 10782 JB = INBLOC 10783 LOW = 1 - INBLOC 10784 ELSE IF( JBLK.EQ.NBLKS ) THEN 10785 JB = LNBLOC 10786 LOW = 1 - NB 10787 ELSE 10788 JB = NB 10789 LOW = 1 - NB 10790 END IF 10791 * 10792 DO 160 JK = JJ, JJ + JB - 1 10793 * 10794 II = 1 10795 LCMTR = LCMTC 10796 * 10797 DO 150 IBLK = 1, MBLKS 10798 * 10799 IF( IBLK.EQ.1 ) THEN 10800 IB = IMBLOC 10801 UPP = IMBLOC - 1 10802 ELSE IF( IBLK.EQ.MBLKS ) THEN 10803 IB = LMBLOC 10804 UPP = MB - 1 10805 ELSE 10806 IB = MB 10807 UPP = MB - 1 10808 END IF 10809 * 10810 * Blocks are IB by JB 10811 * 10812 IF( LCMTR.GT.UPP ) THEN 10813 * 10814 DO 100 IK = II, II + IB - 1 10815 DUMMY = CMPLX( PB_SRAND( 0 ), 10816 $ PB_SRAND( 0 ) ) 10817 100 CONTINUE 10818 * 10819 ELSE IF( LCMTR.GE.LOW ) THEN 10820 * 10821 JTMP = JK - JJ + 1 10822 MNB = MAX( 0, -LCMTR ) 10823 * 10824 IF( JTMP.LE.MIN( MNB, JB ) ) THEN 10825 * 10826 DO 110 IK = II, II + IB - 1 10827 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 10828 $ PB_SRAND( 0 ) ) 10829 110 CONTINUE 10830 * 10831 ELSE IF( ( JTMP.GE.( MNB + 1 ) ) .AND. 10832 $ ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN 10833 * 10834 ITMP = II + JTMP + LCMTR - 1 10835 * 10836 DO 120 IK = II, ITMP - 1 10837 DUMMY = CMPLX( PB_SRAND( 0 ), 10838 $ PB_SRAND( 0 ) ) 10839 120 CONTINUE 10840 * 10841 DO 130 IK = ITMP, II + IB - 1 10842 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 10843 $ PB_SRAND( 0 ) ) 10844 130 CONTINUE 10845 * 10846 END IF 10847 * 10848 ELSE 10849 * 10850 DO 140 IK = II, II + IB - 1 10851 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 10852 $ PB_SRAND( 0 ) ) 10853 140 CONTINUE 10854 * 10855 END IF 10856 * 10857 II = II + IB 10858 * 10859 IF( IBLK.EQ.1 ) THEN 10860 * 10861 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 10862 * 10863 LCMTR = LCMTR - JMP( JMP_NPIMBLOC ) 10864 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1, 10865 $ IB0 ) 10866 * 10867 ELSE 10868 * 10869 * Jump NPROW * MB rows 10870 * 10871 LCMTR = LCMTR - JMP( JMP_NPMB ) 10872 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, 10873 $ IB0 ) 10874 * 10875 END IF 10876 * 10877 IB1( 1 ) = IB0( 1 ) 10878 IB1( 2 ) = IB0( 2 ) 10879 * 10880 150 CONTINUE 10881 * 10882 * Jump one column 10883 * 10884 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 ) 10885 * 10886 IB1( 1 ) = IB0( 1 ) 10887 IB1( 2 ) = IB0( 2 ) 10888 IB2( 1 ) = IB0( 1 ) 10889 IB2( 2 ) = IB0( 2 ) 10890 * 10891 160 CONTINUE 10892 * 10893 JJ = JJ + JB 10894 * 10895 IF( JBLK.EQ.1 ) THEN 10896 * 10897 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 10898 * 10899 LCMTC = LCMTC + JMP( JMP_NQINBLOC ) 10900 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 ) 10901 * 10902 ELSE 10903 * 10904 * Jump NPCOL * NB columns 10905 * 10906 LCMTC = LCMTC + JMP( JMP_NQNB ) 10907 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 ) 10908 * 10909 END IF 10910 * 10911 IB1( 1 ) = IB0( 1 ) 10912 IB1( 2 ) = IB0( 2 ) 10913 IB2( 1 ) = IB0( 1 ) 10914 IB2( 2 ) = IB0( 2 ) 10915 IB3( 1 ) = IB0( 1 ) 10916 IB3( 2 ) = IB0( 2 ) 10917 * 10918 170 CONTINUE 10919 * 10920 ELSE 10921 * 10922 * generate upper trapezoidal part 10923 * 10924 II = 1 10925 LCMTR = LCMT00 10926 * 10927 DO 250 IBLK = 1, MBLKS 10928 * 10929 IF( IBLK.EQ.1 ) THEN 10930 IB = IMBLOC 10931 UPP = IMBLOC - 1 10932 ELSE IF( IBLK.EQ.MBLKS ) THEN 10933 IB = LMBLOC 10934 UPP = MB - 1 10935 ELSE 10936 IB = MB 10937 UPP = MB - 1 10938 END IF 10939 * 10940 DO 240 IK = II, II + IB - 1 10941 * 10942 JJ = 1 10943 LCMTC = LCMTR 10944 * 10945 DO 230 JBLK = 1, NBLKS 10946 * 10947 IF( JBLK.EQ.1 ) THEN 10948 JB = INBLOC 10949 LOW = 1 - INBLOC 10950 ELSE IF( JBLK.EQ.NBLKS ) THEN 10951 JB = LNBLOC 10952 LOW = 1 - NB 10953 ELSE 10954 JB = NB 10955 LOW = 1 - NB 10956 END IF 10957 * 10958 * Blocks are IB by JB 10959 * 10960 IF( LCMTC.LT.LOW ) THEN 10961 * 10962 DO 180 JK = JJ, JJ + JB - 1 10963 DUMMY = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) ) 10964 180 CONTINUE 10965 * 10966 ELSE IF( LCMTC.LE.UPP ) THEN 10967 * 10968 ITMP = IK - II + 1 10969 MNB = MAX( 0, LCMTC ) 10970 * 10971 IF( ITMP.LE.MIN( MNB, IB ) ) THEN 10972 * 10973 DO 190 JK = JJ, JJ + JB - 1 10974 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 10975 $ PB_SRAND( 0 ) ) 10976 190 CONTINUE 10977 * 10978 ELSE IF( ( ITMP.GE.( MNB + 1 ) ) .AND. 10979 $ ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN 10980 * 10981 JTMP = JJ + ITMP - LCMTC - 1 10982 * 10983 DO 200 JK = JJ, JTMP - 1 10984 DUMMY = CMPLX( PB_SRAND( 0 ), 10985 $ PB_SRAND( 0 ) ) 10986 200 CONTINUE 10987 * 10988 DO 210 JK = JTMP, JJ + JB - 1 10989 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 10990 $ PB_SRAND( 0 ) ) 10991 210 CONTINUE 10992 * 10993 END IF 10994 * 10995 ELSE 10996 * 10997 DO 220 JK = JJ, JJ + JB - 1 10998 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 10999 $ PB_SRAND( 0 ) ) 11000 220 CONTINUE 11001 * 11002 END IF 11003 * 11004 JJ = JJ + JB 11005 * 11006 IF( JBLK.EQ.1 ) THEN 11007 * 11008 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 11009 * 11010 LCMTC = LCMTC + JMP( JMP_NQINBLOC ) 11011 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1, 11012 $ IB0 ) 11013 * 11014 ELSE 11015 * 11016 * Jump NPCOL * NB columns 11017 * 11018 LCMTC = LCMTC + JMP( JMP_NQNB ) 11019 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, 11020 $ IB0 ) 11021 * 11022 END IF 11023 * 11024 IB1( 1 ) = IB0( 1 ) 11025 IB1( 2 ) = IB0( 2 ) 11026 * 11027 230 CONTINUE 11028 * 11029 * Jump one row 11030 * 11031 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 ) 11032 * 11033 IB1( 1 ) = IB0( 1 ) 11034 IB1( 2 ) = IB0( 2 ) 11035 IB2( 1 ) = IB0( 1 ) 11036 IB2( 2 ) = IB0( 2 ) 11037 * 11038 240 CONTINUE 11039 * 11040 II = II + IB 11041 * 11042 IF( IBLK.EQ.1 ) THEN 11043 * 11044 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 11045 * 11046 LCMTR = LCMTR - JMP( JMP_NPIMBLOC ) 11047 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 ) 11048 * 11049 ELSE 11050 * 11051 * Jump NPROW * MB rows 11052 * 11053 LCMTR = LCMTR - JMP( JMP_NPMB ) 11054 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 ) 11055 * 11056 END IF 11057 * 11058 IB1( 1 ) = IB0( 1 ) 11059 IB1( 2 ) = IB0( 2 ) 11060 IB2( 1 ) = IB0( 1 ) 11061 IB2( 2 ) = IB0( 2 ) 11062 IB3( 1 ) = IB0( 1 ) 11063 IB3( 2 ) = IB0( 2 ) 11064 * 11065 250 CONTINUE 11066 * 11067 END IF 11068 * 11069 ELSE IF( LSAME( AFORM, 'C' ) ) THEN 11070 * 11071 * Generate the conjugate transpose of the matrix that would be 11072 * normally generated. 11073 * 11074 II = 1 11075 * 11076 DO 290 IBLK = 1, MBLKS 11077 * 11078 IF( IBLK.EQ.1 ) THEN 11079 IB = IMBLOC 11080 ELSE IF( IBLK.EQ.MBLKS ) THEN 11081 IB = LMBLOC 11082 ELSE 11083 IB = MB 11084 END IF 11085 * 11086 DO 280 IK = II, II + IB - 1 11087 * 11088 JJ = 1 11089 * 11090 DO 270 JBLK = 1, NBLKS 11091 * 11092 IF( JBLK.EQ.1 ) THEN 11093 JB = INBLOC 11094 ELSE IF( JBLK.EQ.NBLKS ) THEN 11095 JB = LNBLOC 11096 ELSE 11097 JB = NB 11098 END IF 11099 * 11100 * Blocks are IB by JB 11101 * 11102 DO 260 JK = JJ, JJ + JB - 1 11103 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 11104 $ -PB_SRAND( 0 ) ) 11105 260 CONTINUE 11106 * 11107 JJ = JJ + JB 11108 * 11109 IF( JBLK.EQ.1 ) THEN 11110 * 11111 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 11112 * 11113 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1, 11114 $ IB0 ) 11115 * 11116 ELSE 11117 * 11118 * Jump NPCOL * NB columns 11119 * 11120 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, 11121 $ IB0 ) 11122 * 11123 END IF 11124 * 11125 IB1( 1 ) = IB0( 1 ) 11126 IB1( 2 ) = IB0( 2 ) 11127 * 11128 270 CONTINUE 11129 * 11130 * Jump one row 11131 * 11132 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 ) 11133 * 11134 IB1( 1 ) = IB0( 1 ) 11135 IB1( 2 ) = IB0( 2 ) 11136 IB2( 1 ) = IB0( 1 ) 11137 IB2( 2 ) = IB0( 2 ) 11138 * 11139 280 CONTINUE 11140 * 11141 II = II + IB 11142 * 11143 IF( IBLK.EQ.1 ) THEN 11144 * 11145 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 11146 * 11147 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 ) 11148 * 11149 ELSE 11150 * 11151 * Jump NPROW * MB rows 11152 * 11153 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 ) 11154 * 11155 END IF 11156 * 11157 IB1( 1 ) = IB0( 1 ) 11158 IB1( 2 ) = IB0( 2 ) 11159 IB2( 1 ) = IB0( 1 ) 11160 IB2( 2 ) = IB0( 2 ) 11161 IB3( 1 ) = IB0( 1 ) 11162 IB3( 2 ) = IB0( 2 ) 11163 * 11164 290 CONTINUE 11165 * 11166 ELSE IF( LSAME( AFORM, 'H' ) ) THEN 11167 * 11168 * Generate a Hermitian matrix 11169 * 11170 IF( LSAME( UPLO, 'L' ) ) THEN 11171 * 11172 * generate lower trapezoidal part 11173 * 11174 JJ = 1 11175 LCMTC = LCMT00 11176 * 11177 DO 370 JBLK = 1, NBLKS 11178 * 11179 IF( JBLK.EQ.1 ) THEN 11180 JB = INBLOC 11181 LOW = 1 - INBLOC 11182 ELSE IF( JBLK.EQ.NBLKS ) THEN 11183 JB = LNBLOC 11184 LOW = 1 - NB 11185 ELSE 11186 JB = NB 11187 LOW = 1 - NB 11188 END IF 11189 * 11190 DO 360 JK = JJ, JJ + JB - 1 11191 * 11192 II = 1 11193 LCMTR = LCMTC 11194 * 11195 DO 350 IBLK = 1, MBLKS 11196 * 11197 IF( IBLK.EQ.1 ) THEN 11198 IB = IMBLOC 11199 UPP = IMBLOC - 1 11200 ELSE IF( IBLK.EQ.MBLKS ) THEN 11201 IB = LMBLOC 11202 UPP = MB - 1 11203 ELSE 11204 IB = MB 11205 UPP = MB - 1 11206 END IF 11207 * 11208 * Blocks are IB by JB 11209 * 11210 IF( LCMTR.GT.UPP ) THEN 11211 * 11212 DO 300 IK = II, II + IB - 1 11213 DUMMY = CMPLX( PB_SRAND( 0 ), 11214 $ PB_SRAND( 0 ) ) 11215 300 CONTINUE 11216 * 11217 ELSE IF( LCMTR.GE.LOW ) THEN 11218 * 11219 JTMP = JK - JJ + 1 11220 MNB = MAX( 0, -LCMTR ) 11221 * 11222 IF( JTMP.LE.MIN( MNB, JB ) ) THEN 11223 * 11224 DO 310 IK = II, II + IB - 1 11225 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 11226 $ PB_SRAND( 0 ) ) 11227 310 CONTINUE 11228 * 11229 ELSE IF( ( JTMP.GE.( MNB + 1 ) ) .AND. 11230 $ ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN 11231 * 11232 ITMP = II + JTMP + LCMTR - 1 11233 * 11234 DO 320 IK = II, ITMP - 1 11235 DUMMY = CMPLX( PB_SRAND( 0 ), 11236 $ PB_SRAND( 0 ) ) 11237 320 CONTINUE 11238 * 11239 IF( ITMP.LE.( II + IB - 1 ) ) THEN 11240 DUMMY = CMPLX( PB_SRAND( 0 ), 11241 $ -PB_SRAND( 0 ) ) 11242 A( ITMP, JK ) = CMPLX( REAL( DUMMY ), 11243 $ ZERO ) 11244 END IF 11245 * 11246 DO 330 IK = ITMP + 1, II + IB - 1 11247 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 11248 $ PB_SRAND( 0 ) ) 11249 330 CONTINUE 11250 * 11251 END IF 11252 * 11253 ELSE 11254 * 11255 DO 340 IK = II, II + IB - 1 11256 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 11257 $ PB_SRAND( 0 ) ) 11258 340 CONTINUE 11259 * 11260 END IF 11261 * 11262 II = II + IB 11263 * 11264 IF( IBLK.EQ.1 ) THEN 11265 * 11266 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 11267 * 11268 LCMTR = LCMTR - JMP( JMP_NPIMBLOC ) 11269 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1, 11270 $ IB0 ) 11271 * 11272 ELSE 11273 * 11274 * Jump NPROW * MB rows 11275 * 11276 LCMTR = LCMTR - JMP( JMP_NPMB ) 11277 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, 11278 $ IB0 ) 11279 * 11280 END IF 11281 * 11282 IB1( 1 ) = IB0( 1 ) 11283 IB1( 2 ) = IB0( 2 ) 11284 * 11285 350 CONTINUE 11286 * 11287 * Jump one column 11288 * 11289 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 ) 11290 * 11291 IB1( 1 ) = IB0( 1 ) 11292 IB1( 2 ) = IB0( 2 ) 11293 IB2( 1 ) = IB0( 1 ) 11294 IB2( 2 ) = IB0( 2 ) 11295 * 11296 360 CONTINUE 11297 * 11298 JJ = JJ + JB 11299 * 11300 IF( JBLK.EQ.1 ) THEN 11301 * 11302 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 11303 * 11304 LCMTC = LCMTC + JMP( JMP_NQINBLOC ) 11305 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 ) 11306 * 11307 ELSE 11308 * 11309 * Jump NPCOL * NB columns 11310 * 11311 LCMTC = LCMTC + JMP( JMP_NQNB ) 11312 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 ) 11313 * 11314 END IF 11315 * 11316 IB1( 1 ) = IB0( 1 ) 11317 IB1( 2 ) = IB0( 2 ) 11318 IB2( 1 ) = IB0( 1 ) 11319 IB2( 2 ) = IB0( 2 ) 11320 IB3( 1 ) = IB0( 1 ) 11321 IB3( 2 ) = IB0( 2 ) 11322 * 11323 370 CONTINUE 11324 * 11325 ELSE 11326 * 11327 * generate upper trapezoidal part 11328 * 11329 II = 1 11330 LCMTR = LCMT00 11331 * 11332 DO 450 IBLK = 1, MBLKS 11333 * 11334 IF( IBLK.EQ.1 ) THEN 11335 IB = IMBLOC 11336 UPP = IMBLOC - 1 11337 ELSE IF( IBLK.EQ.MBLKS ) THEN 11338 IB = LMBLOC 11339 UPP = MB - 1 11340 ELSE 11341 IB = MB 11342 UPP = MB - 1 11343 END IF 11344 * 11345 DO 440 IK = II, II + IB - 1 11346 * 11347 JJ = 1 11348 LCMTC = LCMTR 11349 * 11350 DO 430 JBLK = 1, NBLKS 11351 * 11352 IF( JBLK.EQ.1 ) THEN 11353 JB = INBLOC 11354 LOW = 1 - INBLOC 11355 ELSE IF( JBLK.EQ.NBLKS ) THEN 11356 JB = LNBLOC 11357 LOW = 1 - NB 11358 ELSE 11359 JB = NB 11360 LOW = 1 - NB 11361 END IF 11362 * 11363 * Blocks are IB by JB 11364 * 11365 IF( LCMTC.LT.LOW ) THEN 11366 * 11367 DO 380 JK = JJ, JJ + JB - 1 11368 DUMMY = CMPLX( PB_SRAND( 0 ), 11369 $ -PB_SRAND( 0 ) ) 11370 380 CONTINUE 11371 * 11372 ELSE IF( LCMTC.LE.UPP ) THEN 11373 * 11374 ITMP = IK - II + 1 11375 MNB = MAX( 0, LCMTC ) 11376 * 11377 IF( ITMP.LE.MIN( MNB, IB ) ) THEN 11378 * 11379 DO 390 JK = JJ, JJ + JB - 1 11380 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 11381 $ -PB_SRAND( 0 ) ) 11382 390 CONTINUE 11383 * 11384 ELSE IF( ( ITMP.GE.( MNB + 1 ) ) .AND. 11385 $ ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN 11386 * 11387 JTMP = JJ + ITMP - LCMTC - 1 11388 * 11389 DO 400 JK = JJ, JTMP - 1 11390 DUMMY = CMPLX( PB_SRAND( 0 ), 11391 $ -PB_SRAND( 0 ) ) 11392 400 CONTINUE 11393 * 11394 IF( JTMP.LE.( JJ + JB - 1 ) ) THEN 11395 DUMMY = CMPLX( PB_SRAND( 0 ), 11396 $ -PB_SRAND( 0 ) ) 11397 A( IK, JTMP ) = CMPLX( REAL( DUMMY ), 11398 $ ZERO ) 11399 END IF 11400 * 11401 DO 410 JK = JTMP + 1, JJ + JB - 1 11402 A( IK, JK ) = CMPLX( PB_SRAND( 0 ), 11403 $ -PB_SRAND( 0 ) ) 11404 410 CONTINUE 11405 * 11406 END IF
