|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
00001 SUBROUTINE PZOPTEE( 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 * PZOPTEE 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 PZCHKOPT 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 PZCHKOPT( 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 PZCHKOPT( 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 PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00177 * 00178 * Check 2nd option 00179 * 00180 APOS = 2 00181 CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00182 * 00183 * Check 3rd option 00184 * 00185 APOS = 3 00186 CALL PZCHKOPT( 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 PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00196 * 00197 * Check 2'nd option 00198 * 00199 APOS = 2 00200 CALL PZCHKOPT( 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 PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS ) 00208 * 00209 * Check 2nd option 00210 * 00211 APOS = 2 00212 CALL PZCHKOPT( 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 PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00221 * 00222 * Check 2'nd option 00223 * 00224 APOS = 2 00225 CALL PZCHKOPT( 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 PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS ) 00233 * 00234 * Check 2nd option 00235 * 00236 APOS = 2 00237 CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS ) 00238 * 00239 * Check 3rd option 00240 * 00241 APOS = 3 00242 CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00243 * 00244 * Check 4th option 00245 * 00246 APOS = 4 00247 CALL PZCHKOPT( 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 PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 00256 * 00257 END IF 00258 * 00259 RETURN 00260 * 00261 * End of PZOPTEE 00262 * 00263 END 00264 SUBROUTINE PZCHKOPT( 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 * PZCHKOPT 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 PCHKPBE, PZCALLSUB, PZSETPBLAS 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 PZSETPBLAS( 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 PZCALLSUB( SUBPTR, SCODE ) 00447 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 00448 * 00449 RETURN 00450 * 00451 * End of PZCHKOPT 00452 * 00453 END 00454 SUBROUTINE PZDIMEE( 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 * PZDIMEE 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 PZCHKDIM 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 PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00625 * 00626 * Check 2nd dimension 00627 * 00628 APOS = 3 00629 CALL PZCHKDIM( 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 PZCHKDIM( 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 PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00652 * 00653 * Check 2nd dimension 00654 * 00655 APOS = 2 00656 CALL PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00666 * 00667 * Check 2nd dimension 00668 * 00669 APOS = 4 00670 CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00671 * 00672 * Check 3rd dimension 00673 * 00674 APOS = 5 00675 CALL PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00683 * 00684 * Check 2nd dimension 00685 * 00686 APOS = 4 00687 CALL PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00696 * 00697 * Check 2nd dimension 00698 * 00699 APOS = 4 00700 CALL PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00708 * 00709 * Check 2nd dimension 00710 * 00711 APOS = 2 00712 CALL PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00720 * 00721 * Check 2nd dimension 00722 * 00723 APOS = 6 00724 CALL PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00732 * 00733 * Check 2nd dimension 00734 * 00735 APOS = 3 00736 CALL PZCHKDIM( 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 PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS ) 00744 * 00745 * Check 2nd dimension 00746 * 00747 APOS = 4 00748 CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS ) 00749 * 00750 END IF 00751 * 00752 RETURN 00753 * 00754 * End of PZDIMEE 00755 * 00756 END 00757 SUBROUTINE PZCHKDIM( 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 * PZCHKDIM 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 PCHKPBE, PZCALLSUB, PZSETPBLAS 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 PZSETPBLAS( 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 PZCALLSUB( SUBPTR, SCODE ) 00928 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 00929 * 00930 RETURN 00931 * 00932 * End of PZCHKDIM 00933 * 00934 END 00935 SUBROUTINE PZVECEE( 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 * PZVECEE 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 PZCHKMAT 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01098 * 01099 * Check 2nd vector 01100 * 01101 APOS = 7 01102 CALL PZCHKMAT( 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 PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01117 * 01118 * Check 2nd vector 01119 * 01120 APOS = 8 01121 CALL PZCHKMAT( 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 PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01138 * 01139 * Check 2nd vector 01140 * 01141 APOS = 15 01142 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01150 * 01151 * Check 2nd vector 01152 * 01153 APOS = 14 01154 CALL PZCHKMAT( 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 PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01169 * 01170 * Check 2nd vector 01171 * 01172 APOS = 9 01173 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS ) 01181 * 01182 END IF 01183 * 01184 RETURN 01185 * 01186 * End of PZVECEE 01187 * 01188 END 01189 SUBROUTINE PZMATEE( 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 * PZMATEE 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 PZCHKMAT 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 PZCHKMAT( 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 PZCHKMAT( 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 PZCHKMAT( 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 PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01382 * 01383 * Check 2nd matrix 01384 * 01385 APOS = 11 01386 CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS ) 01387 * 01388 * Check 3nd matrix 01389 * 01390 APOS = 16 01391 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01399 * 01400 * Check 2nd matrix 01401 * 01402 APOS = 10 01403 CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS ) 01404 * 01405 * Check 3nd matrix 01406 * 01407 APOS = 15 01408 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01416 * 01417 * Check 2nd matrix 01418 * 01419 APOS = 11 01420 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01428 * 01429 * Check 2nd matrix 01430 * 01431 APOS = 9 01432 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01440 * 01441 * Check 2nd matrix 01442 * 01443 APOS = 12 01444 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01452 * 01453 * Check 2nd matrix 01454 * 01455 APOS = 10 01456 CALL PZCHKMAT( 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 PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS ) 01464 * 01465 * Check 2nd matrix 01466 * 01467 APOS = 11 01468 CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS ) 01469 * 01470 END IF 01471 * 01472 RETURN 01473 * 01474 * End of PZMATEE 01475 * 01476 END 01477 SUBROUTINE PZSETPBLAS( 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 * PZSETPBLAS 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 DOUBLE PRECISION RONE 01578 COMPLEX*16 ONE 01579 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 01580 $ RONE = 1.0D+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 DOUBLE PRECISION USCLR 01590 COMPLEX*16 SCLR 01591 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ), 01592 $ DESCX( DLEN_ ), DESCY( DLEN_ ) 01593 COMPLEX*16 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 PZSETPBLAS 01673 * 01674 END 01675 SUBROUTINE PZCHKMAT( 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 * PZCHKMAT 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, PCHKPBE, PZCALLSUB, PZSETPBLAS 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 PZSETPBLAS( ICTXT ) 01839 IA = -1 01840 INFOT = ARGPOS + 1 01841 CALL PZCALLSUB( SUBPTR, SCODE ) 01842 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01843 * 01844 * Check JA. Set all other OK, bad JA 01845 * 01846 CALL PZSETPBLAS( ICTXT ) 01847 JA = -1 01848 INFOT = ARGPOS + 2 01849 CALL PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 01859 DESCA( I ) = -2 01860 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01861 CALL PZCALLSUB( 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 PZSETPBLAS( 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 PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 01904 IB = -1 01905 INFOT = ARGPOS + 1 01906 CALL PZCALLSUB( SUBPTR, SCODE ) 01907 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01908 * 01909 * Check JB. Set all other OK, bad JB 01910 * 01911 CALL PZSETPBLAS( ICTXT ) 01912 JB = -1 01913 INFOT = ARGPOS + 2 01914 CALL PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 01924 DESCB( I ) = -2 01925 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01926 CALL PZCALLSUB( 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 PZSETPBLAS( 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 PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 01969 IC = -1 01970 INFOT = ARGPOS + 1 01971 CALL PZCALLSUB( SUBPTR, SCODE ) 01972 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01973 * 01974 * Check JC. Set all other OK, bad JC 01975 * 01976 CALL PZSETPBLAS( ICTXT ) 01977 JC = -1 01978 INFOT = ARGPOS + 2 01979 CALL PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 01989 DESCC( I ) = -2 01990 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 01991 CALL PZCALLSUB( 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 PZSETPBLAS( 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 PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 02034 IX = -1 02035 INFOT = ARGPOS + 1 02036 CALL PZCALLSUB( SUBPTR, SCODE ) 02037 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02038 * 02039 * Check JX. Set all other OK, bad JX 02040 * 02041 CALL PZSETPBLAS( ICTXT ) 02042 JX = -1 02043 INFOT = ARGPOS + 2 02044 CALL PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 02054 DESCX( I ) = -2 02055 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 02056 CALL PZCALLSUB( 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 PZSETPBLAS( 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 PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 02097 INCX = -1 02098 INFOT = ARGPOS + 4 02099 CALL PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 02107 IY = -1 02108 INFOT = ARGPOS + 1 02109 CALL PZCALLSUB( SUBPTR, SCODE ) 02110 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02111 * 02112 * Check JY. Set all other OK, bad JY 02113 * 02114 CALL PZSETPBLAS( ICTXT ) 02115 JY = -1 02116 INFOT = ARGPOS + 2 02117 CALL PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 02127 DESCY( I ) = -2 02128 INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I 02129 CALL PZCALLSUB( 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 PZSETPBLAS( 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 PZCALLSUB( 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 PZSETPBLAS( ICTXT ) 02170 INCY = -1 02171 INFOT = ARGPOS + 4 02172 CALL PZCALLSUB( SUBPTR, SCODE ) 02173 CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 02174 * 02175 END IF 02176 * 02177 RETURN 02178 * 02179 * End of PZCHKMAT 02180 * 02181 END 02182 SUBROUTINE PZCALLSUB( 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 * PZCALLSUB 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 DOUBLE PRECISION USCLR 02324 COMPLEX*16 SCLR 02325 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ), 02326 $ DESCX( DLEN_ ), DESCY( DLEN_ ) 02327 COMPLEX*16 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 PZCALLSUB 02457 * 02458 END 02459 SUBROUTINE PZERRSET( 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 DOUBLE PRECISION ERR, ERRMAX 02468 COMPLEX*16 X, XTRUE 02469 * .. 02470 * 02471 * Purpose 02472 * ======= 02473 * 02474 * PZERRSET 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) DOUBLE PRECISION 02544 * On exit, ERR specifies the absolute difference |XTRUE - X|. 02545 * 02546 * ERRMAX (local input/local output) DOUBLE PRECISION 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*16 02551 * On entry, XTRUE specifies the true value. 02552 * 02553 * X (local input) COMPLEX*16 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 DOUBLE PRECISION PDDIFF 02563 EXTERNAL PDDIFF 02564 * .. 02565 * .. Intrinsic Functions .. 02566 INTRINSIC ABS, DBLE, DIMAG, MAX 02567 * .. 02568 * .. Executable Statements .. 02569 * 02570 ERR = ABS( PDDIFF( DBLE( XTRUE ), DBLE( X ) ) ) 02571 ERR = MAX( ERR, ABS( PDDIFF( DIMAG( XTRUE ), DIMAG( X ) ) ) ) 02572 * 02573 ERRMAX = MAX( ERRMAX, ERR ) 02574 * 02575 RETURN 02576 * 02577 * End of PZERRSET 02578 * 02579 END 02580 SUBROUTINE PZCHKVIN( 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 DOUBLE PRECISION ERRMAX 02591 * .. 02592 * .. Array Arguments .. 02593 INTEGER DESCX( * ) 02594 COMPLEX*16 PX( * ), X( * ) 02595 * .. 02596 * 02597 * Purpose 02598 * ======= 02599 * 02600 * PZCHKVIN 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) DOUBLE PRECISION 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*16 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*16 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 DOUBLE PRECISION ZERO 02726 PARAMETER ( ZERO = 0.0D+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 DOUBLE PRECISION ERR, EPS 02734 * .. 02735 * .. External Subroutines .. 02736 EXTERNAL BLACS_GRIDINFO, DGAMX2D, PB_INFOG2L, PZERRSET 02737 * .. 02738 * .. External Functions .. 02739 DOUBLE PRECISION PDLAMCH 02740 EXTERNAL PDLAMCH 02741 * .. 02742 * .. Intrinsic Functions .. 02743 INTRINSIC ABS, DBLE, DIMAG, MAX, MIN, MOD 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 = PDLAMCH( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 DGAMX2D( 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 PZCHKVIN 02873 * 02874 END 02875 SUBROUTINE PZCHKVOUT( 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*16 PX( * ), X( * ) 02888 * .. 02889 * 02890 * Purpose 02891 * ======= 02892 * 02893 * PZCHKVOUT 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*16 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*16 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 DOUBLE PRECISION ZERO 03015 PARAMETER ( ZERO = 0.0D+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 DOUBLE PRECISION EPS, ERR, ERRMAX 03024 * .. 03025 * .. External Subroutines .. 03026 EXTERNAL BLACS_GRIDINFO, DGAMX2D, PZERRSET 03027 * .. 03028 * .. External Functions .. 03029 INTEGER PB_NUMROC 03030 DOUBLE PRECISION PDLAMCH 03031 EXTERNAL PDLAMCH, PB_NUMROC 03032 * .. 03033 * .. Intrinsic Functions .. 03034 INTRINSIC ABS, DBLE, DIMAG, MAX, MIN, MOD 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 = PDLAMCH( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 DGAMX2D( 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 PZCHKVOUT 03329 * 03330 END 03331 SUBROUTINE PZCHKMIN( 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 DOUBLE PRECISION ERRMAX 03341 * .. 03342 * .. Array Arguments .. 03343 INTEGER DESCA( * ) 03344 COMPLEX*16 PA( * ), A( * ) 03345 * .. 03346 * 03347 * Purpose 03348 * ======= 03349 * 03350 * PZCHKMIN 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) DOUBLE PRECISION 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*16 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*16 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 DOUBLE PRECISION ZERO 03475 PARAMETER ( ZERO = 0.0D+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 DOUBLE PRECISION ERR, EPS 03483 * .. 03484 * .. External Subroutines .. 03485 EXTERNAL BLACS_GRIDINFO, DGAMX2D, PB_INFOG2L, PZERRSET 03486 * .. 03487 * .. External Functions .. 03488 DOUBLE PRECISION PDLAMCH 03489 EXTERNAL PDLAMCH 03490 * .. 03491 * .. Intrinsic Functions .. 03492 INTRINSIC ABS, DBLE, DIMAG, MAX, MIN, MOD 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 = PDLAMCH( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 DGAMX2D( 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 PZCHKMIN 03630 * 03631 END 03632 SUBROUTINE PZCHKMOUT( 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*16 A( * ), PA( * ) 03645 * .. 03646 * 03647 * Purpose 03648 * ======= 03649 * 03650 * PZCHKMOUT 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*16 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*16 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 DOUBLE PRECISION ZERO 03771 PARAMETER ( ZERO = 0.0D+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 DOUBLE PRECISION EPS, ERR, ERRMAX 03779 * .. 03780 * .. External Subroutines .. 03781 EXTERNAL BLACS_GRIDINFO, DGAMX2D, PZERRSET 03782 * .. 03783 * .. External Functions .. 03784 INTEGER PB_NUMROC 03785 DOUBLE PRECISION PDLAMCH 03786 EXTERNAL PDLAMCH, 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 = PDLAMCH( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 PZERRSET( 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 DGAMX2D( 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 PZCHKMOUT 03951 * 03952 END 03953 SUBROUTINE PZMPRNT( 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*16 A( LDA, * ) 03967 * .. 03968 * 03969 * Purpose 03970 * ======= 03971 * 03972 * PZMPRNT 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*16 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 DBLE, DIMAG 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 $ DBLE( A( I, J ) ), DIMAG( A( I, J ) ) 04050 * 04051 10 CONTINUE 04052 * 04053 20 CONTINUE 04054 * 04055 END IF 04056 * 04057 9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', D30.18, '+i*(', 04058 $ D30.18, ')' ) 04059 * 04060 RETURN 04061 * 04062 * End of PZMPRNT 04063 * 04064 END 04065 SUBROUTINE PZVPRNT( 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*16 X( * ) 04079 * .. 04080 * 04081 * Purpose 04082 * ======= 04083 * 04084 * PZVPRNT 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*16 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 DBLE, DIMAG 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, DBLE( X( I ) ), 04156 $ DIMAG( X( I ) ) 04157 * 04158 10 CONTINUE 04159 * 04160 END IF 04161 * 04162 9999 FORMAT( 1X, A, '(', I6, ')=', D30.18, '+i*(', D30.18, ')' ) 04163 * 04164 RETURN 04165 * 04166 * End of PZVPRNT 04167 * 04168 END 04169 SUBROUTINE PZMVCH( 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 DOUBLE PRECISION ERR 04183 COMPLEX*16 ALPHA, BETA 04184 * .. 04185 * .. Array Arguments .. 04186 INTEGER DESCA( * ), DESCX( * ), DESCY( * ) 04187 DOUBLE PRECISION G( * ) 04188 COMPLEX*16 A( * ), PY( * ), X( * ), Y( * ) 04189 * .. 04190 * 04191 * Purpose 04192 * ======= 04193 * 04194 * PZMVCH 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*16 04286 * On entry, ALPHA specifies the scalar alpha. 04287 * 04288 * A (local input) COMPLEX*16 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*16 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*16 04326 * On entry, BETA specifies the scalar beta. 04327 * 04328 * Y (local input/local output) COMPLEX*16 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*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DOUBLE PRECISION RZERO, RONE 04377 PARAMETER ( RZERO = 0.0D+0, RONE = 1.0D+0 ) 04378 COMPLEX*16 ZERO, ONE 04379 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 04380 $ ONE = ( 1.0D+0, 0.0D+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 DOUBLE PRECISION EPS, ERRI, GTMP 04389 COMPLEX*16 C, TBETA, YTMP 04390 * .. 04391 * .. External Subroutines .. 04392 EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L 04393 * .. 04394 * .. External Functions .. 04395 LOGICAL LSAME 04396 DOUBLE PRECISION PDLAMCH 04397 EXTERNAL LSAME, PDLAMCH 04398 * .. 04399 * .. Intrinsic Functions .. 04400 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT 04401 * .. 04402 * .. Statement Functions .. 04403 DOUBLE PRECISION ABS1 04404 ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) ) 04405 * .. 04406 * .. Executable Statements .. 04407 * 04408 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 04409 * 04410 EPS = PDLAMCH( 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 + DCONJG( 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 DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 04596 $ MYCOL ) 04597 * 04598 RETURN 04599 * 04600 * End of PZMVCH 04601 * 04602 END 04603 SUBROUTINE PZVMCH( 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 DOUBLE PRECISION ERR 04617 COMPLEX*16 ALPHA 04618 * .. 04619 * .. Array Arguments .. 04620 INTEGER DESCA( * ), DESCX( * ), DESCY( * ) 04621 DOUBLE PRECISION G( * ) 04622 COMPLEX*16 A( * ), PA( * ), X( * ), Y( * ) 04623 * .. 04624 * 04625 * Purpose 04626 * ======= 04627 * 04628 * PZVMCH 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*16 04725 * On entry, ALPHA specifies the scalar alpha. 04726 * 04727 * X (local input) COMPLEX*16 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*16 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*16 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*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, ONE 04813 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+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 DOUBLE PRECISION EPS, ERRI, GTMP 04821 COMPLEX*16 ATMP, C 04822 * .. 04823 * .. External Subroutines .. 04824 EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L 04825 * .. 04826 * .. External Functions .. 04827 LOGICAL LSAME 04828 DOUBLE PRECISION PDLAMCH 04829 EXTERNAL LSAME, PDLAMCH 04830 * .. 04831 * .. Intrinsic Functions .. 04832 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT 04833 * .. 04834 * .. Statement Functions .. 04835 DOUBLE PRECISION ABS1 04836 ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) ) 04837 * .. 04838 * .. Executable Statements .. 04839 * 04840 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 04841 * 04842 EPS = PDLAMCH( 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 ) * DCONJG( 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 DGAMX2D( 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 PZVMCH 04970 * 04971 END 04972 SUBROUTINE PZVMCH2( 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 DOUBLE PRECISION ERR 04986 COMPLEX*16 ALPHA 04987 * .. 04988 * .. Array Arguments .. 04989 INTEGER DESCA( * ), DESCX( * ), DESCY( * ) 04990 DOUBLE PRECISION G( * ) 04991 COMPLEX*16 A( * ), PA( * ), X( * ), Y( * ) 04992 * .. 04993 * 04994 * Purpose 04995 * ======= 04996 * 04997 * PZVMCH2 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*16 05086 * On entry, ALPHA specifies the scalar alpha. 05087 * 05088 * X (local input) COMPLEX*16 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*16 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*16 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*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, ONE 05174 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+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 DOUBLE PRECISION EPS, ERRI, GTMP 05183 COMPLEX*16 C, ATMP 05184 * .. 05185 * .. External Subroutines .. 05186 EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L 05187 * .. 05188 * .. External Functions .. 05189 LOGICAL LSAME 05190 DOUBLE PRECISION PDLAMCH 05191 EXTERNAL LSAME, PDLAMCH 05192 * .. 05193 * .. Intrinsic Functions .. 05194 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT 05195 * .. 05196 * .. Statement Functions .. 05197 DOUBLE PRECISION ABS1 05198 ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) ) 05199 * .. 05200 * .. Executable Statements .. 05201 * 05202 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 05203 * 05204 EPS = PDLAMCH( 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 ) * DCONJG( Y( IOFFYJ ) ) 05244 ATMP = ATMP + Y( IOFFYI ) * DCONJG( ALPHA * X( IOFFXJ ) ) 05245 GTMP = ABS1( ALPHA * X( IOFFXI ) ) * ABS1( Y( IOFFYJ ) ) 05246 GTMP = GTMP + ABS1( Y( IOFFYI ) ) * 05247 $ ABS1( DCONJG( 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 DGAMX2D( 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 PZVMCH2 05331 * 05332 END 05333 SUBROUTINE PZMMCH( 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 DOUBLE PRECISION ERR 05346 COMPLEX*16 ALPHA, BETA 05347 * .. 05348 * .. Array Arguments .. 05349 INTEGER DESCA( * ), DESCB( * ), DESCC( * ) 05350 DOUBLE PRECISION G( * ) 05351 COMPLEX*16 A( * ), B( * ), C( * ), CT( * ), PC( * ) 05352 * .. 05353 * 05354 * Purpose 05355 * ======= 05356 * 05357 * PZMMCH 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*16 05450 * On entry, ALPHA specifies the scalar alpha. 05451 * 05452 * A (local input) COMPLEX*16 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*16 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*16 05485 * On entry, BETA specifies the scalar beta. 05486 * 05487 * C (local input/local output) COMPLEX*16 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*16 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*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DOUBLE PRECISION RZERO, RONE 05535 PARAMETER ( RZERO = 0.0D+0, RONE = 1.0D+0 ) 05536 COMPLEX*16 ZERO 05537 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+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 DOUBLE PRECISION EPS, ERRI 05545 COMPLEX*16 Z 05546 * .. 05547 * .. External Subroutines .. 05548 EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L 05549 * .. 05550 * .. External Functions .. 05551 LOGICAL LSAME 05552 DOUBLE PRECISION PDLAMCH 05553 EXTERNAL LSAME, PDLAMCH 05554 * .. 05555 * .. Intrinsic Functions .. 05556 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT 05557 * .. 05558 * .. Statement Functions .. 05559 DOUBLE PRECISION ABS1 05560 ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) 05561 * .. 05562 * .. Executable Statements .. 05563 * 05564 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 05565 * 05566 EPS = PDLAMCH( 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 ) + DCONJG( 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 $ DCONJG( 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 ) + DCONJG( A( IOFFA ) ) * 05653 $ DCONJG( 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 ) + DCONJG( 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 $ DCONJG( 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 DGAMX2D( 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 PZMMCH 05784 * 05785 END 05786 SUBROUTINE PZMMCH1( 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 DOUBLE PRECISION ERR 05799 COMPLEX*16 ALPHA, BETA 05800 * .. 05801 * .. Array Arguments .. 05802 INTEGER DESCA( * ), DESCC( * ) 05803 DOUBLE PRECISION G( * ) 05804 COMPLEX*16 A( * ), C( * ), CT( * ), PC( * ) 05805 * .. 05806 * 05807 * Purpose 05808 * ======= 05809 * 05810 * PZMMCH1 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*16 05901 * On entry, ALPHA specifies the scalar alpha. 05902 * 05903 * A (local input) COMPLEX*16 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*16 05920 * On entry, BETA specifies the scalar beta. 05921 * 05922 * C (local input/local output) COMPLEX*16 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*16 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*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DOUBLE PRECISION RZERO, RONE 05970 PARAMETER ( RZERO = 0.0D+0, RONE = 1.0D+0 ) 05971 COMPLEX*16 ZERO 05972 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+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 DOUBLE PRECISION EPS, ERRI 05980 COMPLEX*16 Z 05981 * .. 05982 * .. External Subroutines .. 05983 EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L 05984 * .. 05985 * .. External Functions .. 05986 LOGICAL LSAME 05987 DOUBLE PRECISION PDLAMCH 05988 EXTERNAL LSAME, PDLAMCH 05989 * .. 05990 * .. Intrinsic Functions .. 05991 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT 05992 * .. 05993 * .. Statement Functions .. 05994 DOUBLE PRECISION ABS1 05995 ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) 05996 * .. 05997 * .. Executable Statements .. 05998 * 05999 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 06000 * 06001 EPS = PDLAMCH( 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 $ DCONJG( 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 ) + DCONJG( A( IOFFAN ) ) * 06067 $ A( IOFFAK ) 06068 G( I ) = G( I ) + ABS1( DCONJG( A( IOFFAN ) ) ) * 06069 $ ABS1( A( IOFFAK ) ) 06070 80 CONTINUE 06071 90 CONTINUE 06072 END IF 06073 * 06074 IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC 06075 * 06076 DO 100 I = IBEG, IEND 06077 CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC ) 06078 G( I ) = ABS1( ALPHA )*G( I ) + 06079 $ ABS1( BETA )*ABS1( C( IOFFC ) ) 06080 C( IOFFC ) = CT( I ) 06081 IOFFC = IOFFC + 1 06082 100 CONTINUE 06083 * 06084 * Compute the error ratio for this result. 06085 * 06086 ERR = RZERO 06087 INFO = 0 06088 LDPC = DESCC( LLD_ ) 06089 IOFFC = IC + ( JC + J - 2 ) * LDC 06090 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06091 $ IIC, JJC, ICROW, ICCOL ) 06092 ICURROW = ICROW 06093 ROWREP = ( ICROW.EQ.-1 ) 06094 COLREP = ( ICCOL.EQ.-1 ) 06095 * 06096 IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN 06097 * 06098 IBB = DESCC( IMB_ ) - IC + 1 06099 IF( IBB.LE.0 ) 06100 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB 06101 IBB = MIN( IBB, N ) 06102 IN = IC + IBB - 1 06103 * 06104 DO 110 I = IC, IN 06105 * 06106 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06107 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06108 $ C( IOFFC ) ) / EPS 06109 IF( G( I-IC+1 ).NE.RZERO ) 06110 $ ERRI = ERRI / G( I-IC+1 ) 06111 ERR = MAX( ERR, ERRI ) 06112 IF( ERR*SQRT( EPS ).GE.RONE ) 06113 $ INFO = 1 06114 IIC = IIC + 1 06115 END IF 06116 * 06117 IOFFC = IOFFC + 1 06118 * 06119 110 CONTINUE 06120 * 06121 ICURROW = MOD( ICURROW+1, NPROW ) 06122 * 06123 DO 130 I = IN+1, IC+N-1, DESCC( MB_ ) 06124 IBB = MIN( IC+N-I, DESCC( MB_ ) ) 06125 * 06126 DO 120 KK = 0, IBB-1 06127 * 06128 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06129 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06130 $ C( IOFFC ) )/EPS 06131 IF( G( I+KK-IC+1 ).NE.RZERO ) 06132 $ ERRI = ERRI / G( I+KK-IC+1 ) 06133 ERR = MAX( ERR, ERRI ) 06134 IF( ERR*SQRT( EPS ).GE.RONE ) 06135 $ INFO = 1 06136 IIC = IIC + 1 06137 END IF 06138 * 06139 IOFFC = IOFFC + 1 06140 * 06141 120 CONTINUE 06142 * 06143 ICURROW = MOD( ICURROW+1, NPROW ) 06144 * 06145 130 CONTINUE 06146 * 06147 END IF 06148 * 06149 * If INFO = 0, all results are at least half accurate. 06150 * 06151 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 06152 CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 06153 $ MYCOL ) 06154 IF( INFO.NE.0 ) 06155 $ GO TO 150 06156 * 06157 140 CONTINUE 06158 * 06159 150 CONTINUE 06160 * 06161 RETURN 06162 * 06163 * End of PZMMCH1 06164 * 06165 END 06166 SUBROUTINE PZMMCH2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA, 06167 $ DESCA, B, IB, JB, DESCB, BETA, C, PC, IC, 06168 $ JC, DESCC, CT, G, ERR, INFO ) 06169 * 06170 * -- PBLAS test routine (version 2.0) -- 06171 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 06172 * and University of California, Berkeley. 06173 * April 1, 1998 06174 * 06175 * .. Scalar Arguments .. 06176 CHARACTER*1 TRANS, UPLO 06177 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N 06178 DOUBLE PRECISION ERR 06179 COMPLEX*16 ALPHA, BETA 06180 * .. 06181 * .. Array Arguments .. 06182 INTEGER DESCA( * ), DESCB( * ), DESCC( * ) 06183 DOUBLE PRECISION G( * ) 06184 COMPLEX*16 A( * ), B( * ), C( * ), CT( * ), 06185 $ PC( * ) 06186 * .. 06187 * 06188 * Purpose 06189 * ======= 06190 * 06191 * PZMMCH2 checks the results of the computational tests. 06192 * 06193 * Notes 06194 * ===== 06195 * 06196 * A description vector is associated with each 2D block-cyclicly dis- 06197 * tributed matrix. This vector stores the information required to 06198 * establish the mapping between a matrix entry and its corresponding 06199 * process and memory location. 06200 * 06201 * In the following comments, the character _ should be read as 06202 * "of the distributed matrix". Let A be a generic term for any 2D 06203 * block cyclicly distributed matrix. Its description vector is DESCA: 06204 * 06205 * NOTATION STORED IN EXPLANATION 06206 * ---------------- --------------- ------------------------------------ 06207 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 06208 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 06209 * the NPROW x NPCOL BLACS process grid 06210 * A is distributed over. The context 06211 * itself is global, but the handle 06212 * (the integer value) may vary. 06213 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 06214 * ted matrix A, M_A >= 0. 06215 * N_A (global) DESCA( N_ ) The number of columns in the distri- 06216 * buted matrix A, N_A >= 0. 06217 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 06218 * block of the matrix A, IMB_A > 0. 06219 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 06220 * left block of the matrix A, 06221 * INB_A > 0. 06222 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 06223 * bute the last M_A-IMB_A rows of A, 06224 * MB_A > 0. 06225 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 06226 * bute the last N_A-INB_A columns of 06227 * A, NB_A > 0. 06228 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 06229 * row of the matrix A is distributed, 06230 * NPROW > RSRC_A >= 0. 06231 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 06232 * first column of A is distributed. 06233 * NPCOL > CSRC_A >= 0. 06234 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 06235 * array storing the local blocks of 06236 * the distributed matrix A, 06237 * IF( Lc( 1, N_A ) > 0 ) 06238 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 06239 * ELSE 06240 * LLD_A >= 1. 06241 * 06242 * Let K be the number of rows of a matrix A starting at the global in- 06243 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 06244 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 06245 * receive if these K rows were distributed over NPROW processes. If K 06246 * is the number of columns of a matrix A starting at the global index 06247 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 06248 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 06249 * these K columns were distributed over NPCOL processes. 06250 * 06251 * The values of Lr() and Lc() may be determined via a call to the func- 06252 * tion PB_NUMROC: 06253 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 06254 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 06255 * 06256 * Arguments 06257 * ========= 06258 * 06259 * ICTXT (local input) INTEGER 06260 * On entry, ICTXT specifies the BLACS context handle, indica- 06261 * ting the global context of the operation. The context itself 06262 * is global, but the value of ICTXT is local. 06263 * 06264 * UPLO (global input) CHARACTER*1 06265 * On entry, UPLO specifies which part of C should contain the 06266 * result. 06267 * 06268 * TRANS (global input) CHARACTER*1 06269 * On entry, TRANS specifies whether the matrices A and B have 06270 * to be transposed or not before computing the matrix-matrix 06271 * product. 06272 * 06273 * N (global input) INTEGER 06274 * On entry, N specifies the order the submatrix operand C. N 06275 * must be at least zero. 06276 * 06277 * K (global input) INTEGER 06278 * On entry, K specifies the number of columns (resp. rows) of A 06279 * and B when TRANS = 'N' (resp. TRANS <> 'N'). K must be at 06280 * least zero. 06281 * 06282 * ALPHA (global input) COMPLEX*16 06283 * On entry, ALPHA specifies the scalar alpha. 06284 * 06285 * A (local input) COMPLEX*16 array 06286 * On entry, A is an array of dimension (DESCA( M_ ),*). This 06287 * array contains a local copy of the initial entire matrix PA. 06288 * 06289 * IA (global input) INTEGER 06290 * On entry, IA specifies A's global row index, which points to 06291 * the beginning of the submatrix sub( A ). 06292 * 06293 * JA (global input) INTEGER 06294 * On entry, JA specifies A's global column index, which points 06295 * to the beginning of the submatrix sub( A ). 06296 * 06297 * DESCA (global and local input) INTEGER array 06298 * On entry, DESCA is an integer array of dimension DLEN_. This 06299 * is the array descriptor for the matrix A. 06300 * 06301 * B (local input) COMPLEX*16 array 06302 * On entry, B is an array of dimension (DESCB( M_ ),*). This 06303 * array contains a local copy of the initial entire matrix PB. 06304 * 06305 * IB (global input) INTEGER 06306 * On entry, IB specifies B's global row index, which points to 06307 * the beginning of the submatrix sub( B ). 06308 * 06309 * JB (global input) INTEGER 06310 * On entry, JB specifies B's global column index, which points 06311 * to the beginning of the submatrix sub( B ). 06312 * 06313 * DESCB (global and local input) INTEGER array 06314 * On entry, DESCB is an integer array of dimension DLEN_. This 06315 * is the array descriptor for the matrix B. 06316 * 06317 * BETA (global input) COMPLEX*16 06318 * On entry, BETA specifies the scalar beta. 06319 * 06320 * C (local input/local output) COMPLEX*16 array 06321 * On entry, C is an array of dimension (DESCC( M_ ),*). This 06322 * array contains a local copy of the initial entire matrix PC. 06323 * 06324 * PC (local input) COMPLEX*16 array 06325 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This 06326 * array contains the local pieces of the matrix PC. 06327 * 06328 * IC (global input) INTEGER 06329 * On entry, IC specifies C's global row index, which points to 06330 * the beginning of the submatrix sub( C ). 06331 * 06332 * JC (global input) INTEGER 06333 * On entry, JC specifies C's global column index, which points 06334 * to the beginning of the submatrix sub( C ). 06335 * 06336 * DESCC (global and local input) INTEGER array 06337 * On entry, DESCC is an integer array of dimension DLEN_. This 06338 * is the array descriptor for the matrix C. 06339 * 06340 * CT (workspace) COMPLEX*16 array 06341 * On entry, CT is an array of dimension at least MAX(M,N,K). CT 06342 * holds a copy of the current column of C. 06343 * 06344 * G (workspace) DOUBLE PRECISION array 06345 * On entry, G is an array of dimension at least MAX(M,N,K). G 06346 * is used to compute the gauges. 06347 * 06348 * ERR (global output) DOUBLE PRECISION 06349 * On exit, ERR specifies the largest error in absolute value. 06350 * 06351 * INFO (global output) INTEGER 06352 * On exit, if INFO <> 0, the result is less than half accurate. 06353 * 06354 * -- Written on April 1, 1998 by 06355 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 06356 * 06357 * ===================================================================== 06358 * 06359 * .. Parameters .. 06360 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 06361 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 06362 $ RSRC_ 06363 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 06364 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 06365 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 06366 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 06367 DOUBLE PRECISION RZERO, RONE 06368 PARAMETER ( RZERO = 0.0D+0, RONE = 1.0D+0 ) 06369 COMPLEX*16 ZERO 06370 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 06371 * .. 06372 * .. Local Scalars .. 06373 LOGICAL COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER 06374 INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC, 06375 $ IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J, 06376 $ JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW, 06377 $ NPCOL, NPROW 06378 DOUBLE PRECISION EPS, ERRI 06379 COMPLEX*16 Z 06380 * .. 06381 * .. External Subroutines .. 06382 EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L 06383 * .. 06384 * .. External Functions .. 06385 LOGICAL LSAME 06386 DOUBLE PRECISION PDLAMCH 06387 EXTERNAL LSAME, PDLAMCH 06388 * .. 06389 * .. Intrinsic Functions .. 06390 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT 06391 * .. 06392 * .. Statement Functions .. 06393 DOUBLE PRECISION ABS1 06394 ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) 06395 * .. 06396 * .. Executable Statements .. 06397 * 06398 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 06399 * 06400 EPS = PDLAMCH( ICTXT, 'eps' ) 06401 * 06402 UPPER = LSAME( UPLO, 'U' ) 06403 HTRAN = LSAME( TRANS, 'H' ) 06404 NOTRAN = LSAME( TRANS, 'N' ) 06405 TRAN = LSAME( TRANS, 'T' ) 06406 * 06407 LDA = MAX( 1, DESCA( M_ ) ) 06408 LDB = MAX( 1, DESCB( M_ ) ) 06409 LDC = MAX( 1, DESCC( M_ ) ) 06410 * 06411 * Compute expected result in C using data in A, B and C. 06412 * Compute gauges in G. This part of the computation is performed 06413 * by every process in the grid. 06414 * 06415 DO 140 J = 1, N 06416 * 06417 IF( UPPER ) THEN 06418 IBEG = 1 06419 IEND = J 06420 ELSE 06421 IBEG = J 06422 IEND = N 06423 END IF 06424 * 06425 DO 10 I = 1, N 06426 CT( I ) = ZERO 06427 G( I ) = RZERO 06428 10 CONTINUE 06429 * 06430 IF( NOTRAN ) THEN 06431 DO 30 KK = 1, K 06432 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA 06433 IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB 06434 DO 20 I = IBEG, IEND 06435 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA 06436 IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB 06437 CT( I ) = CT( I ) + ALPHA * ( 06438 $ A( IOFFAN ) * B( IOFFBK ) + 06439 $ B( IOFFBN ) * A( IOFFAK ) ) 06440 G( I ) = G( I ) + ABS( ALPHA ) * ( 06441 $ ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) + 06442 $ ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) ) 06443 20 CONTINUE 06444 30 CONTINUE 06445 ELSE IF( TRAN ) THEN 06446 DO 50 KK = 1, K 06447 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA 06448 IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB 06449 DO 40 I = IBEG, IEND 06450 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA 06451 IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB 06452 CT( I ) = CT( I ) + ALPHA * ( 06453 $ A( IOFFAN ) * B( IOFFBK ) + 06454 $ B( IOFFBN ) * A( IOFFAK ) ) 06455 G( I ) = G( I ) + ABS( ALPHA ) * ( 06456 $ ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) + 06457 $ ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) ) 06458 40 CONTINUE 06459 50 CONTINUE 06460 ELSE IF( HTRAN ) THEN 06461 DO 70 KK = 1, K 06462 IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA 06463 IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB 06464 DO 60 I = IBEG, IEND 06465 IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA 06466 IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB 06467 CT( I ) = CT( I ) + 06468 $ ALPHA * A( IOFFAN ) * DCONJG( B( IOFFBK ) ) + 06469 $ B( IOFFBN ) * DCONJG( ALPHA * A( IOFFAK ) ) 06470 G( I ) = G( I ) + ABS1( ALPHA ) * ( 06471 $ ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) + 06472 $ ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) ) 06473 60 CONTINUE 06474 70 CONTINUE 06475 ELSE 06476 DO 90 KK = 1, K 06477 IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA 06478 IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB 06479 DO 80 I = IBEG, IEND 06480 IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA 06481 IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB 06482 CT( I ) = CT( I ) + 06483 $ ALPHA * DCONJG( A( IOFFAN ) ) * B( IOFFBK ) + 06484 $ DCONJG( ALPHA * B( IOFFBN ) ) * A( IOFFAK ) 06485 G( I ) = G( I ) + ABS1( ALPHA ) * ( 06486 $ ABS1( DCONJG( A( IOFFAN ) ) * B( IOFFBK ) ) + 06487 $ ABS1( DCONJG( B( IOFFBN ) ) * A( IOFFAK ) ) ) 06488 80 CONTINUE 06489 90 CONTINUE 06490 END IF 06491 * 06492 IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC 06493 * 06494 DO 100 I = IBEG, IEND 06495 CT( I ) = CT( I ) + BETA * C( IOFFC ) 06496 G( I ) = G( I ) + ABS1( BETA )*ABS1( C( IOFFC ) ) 06497 C( IOFFC ) = CT( I ) 06498 IOFFC = IOFFC + 1 06499 100 CONTINUE 06500 * 06501 * Compute the error ratio for this result. 06502 * 06503 ERR = RZERO 06504 INFO = 0 06505 LDPC = DESCC( LLD_ ) 06506 IOFFC = IC + ( JC + J - 2 ) * LDC 06507 CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06508 $ IIC, JJC, ICROW, ICCOL ) 06509 ICURROW = ICROW 06510 ROWREP = ( ICROW.EQ.-1 ) 06511 COLREP = ( ICCOL.EQ.-1 ) 06512 * 06513 IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN 06514 * 06515 IBB = DESCC( IMB_ ) - IC + 1 06516 IF( IBB.LE.0 ) 06517 $ IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB 06518 IBB = MIN( IBB, N ) 06519 IN = IC + IBB - 1 06520 * 06521 DO 110 I = IC, IN 06522 * 06523 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06524 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06525 $ C( IOFFC ) ) / EPS 06526 IF( G( I-IC+1 ).NE.RZERO ) 06527 $ ERRI = ERRI / G( I-IC+1 ) 06528 ERR = MAX( ERR, ERRI ) 06529 IF( ERR*SQRT( EPS ).GE.RONE ) 06530 $ INFO = 1 06531 IIC = IIC + 1 06532 END IF 06533 * 06534 IOFFC = IOFFC + 1 06535 * 06536 110 CONTINUE 06537 * 06538 ICURROW = MOD( ICURROW+1, NPROW ) 06539 * 06540 DO 130 I = IN+1, IC+N-1, DESCC( MB_ ) 06541 IBB = MIN( IC+N-I, DESCC( MB_ ) ) 06542 * 06543 DO 120 KK = 0, IBB-1 06544 * 06545 IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN 06546 ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) - 06547 $ C( IOFFC ) )/EPS 06548 IF( G( I+KK-IC+1 ).NE.RZERO ) 06549 $ ERRI = ERRI / G( I+KK-IC+1 ) 06550 ERR = MAX( ERR, ERRI ) 06551 IF( ERR*SQRT( EPS ).GE.RONE ) 06552 $ INFO = 1 06553 IIC = IIC + 1 06554 END IF 06555 * 06556 IOFFC = IOFFC + 1 06557 * 06558 120 CONTINUE 06559 * 06560 ICURROW = MOD( ICURROW+1, NPROW ) 06561 * 06562 130 CONTINUE 06563 * 06564 END IF 06565 * 06566 * If INFO = 0, all results are at least half accurate. 06567 * 06568 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 06569 CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 06570 $ MYCOL ) 06571 IF( INFO.NE.0 ) 06572 $ GO TO 150 06573 * 06574 140 CONTINUE 06575 * 06576 150 CONTINUE 06577 * 06578 RETURN 06579 * 06580 * End of PZMMCH2 06581 * 06582 END 06583 SUBROUTINE PZMMCH3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA, 06584 $ BETA, C, PC, IC, JC, DESCC, ERR, INFO ) 06585 * 06586 * -- PBLAS test routine (version 2.0) -- 06587 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 06588 * and University of California, Berkeley. 06589 * April 1, 1998 06590 * 06591 * .. Scalar Arguments .. 06592 CHARACTER*1 TRANS, UPLO 06593 INTEGER IA, IC, INFO, JA, JC, M, N 06594 DOUBLE PRECISION ERR 06595 COMPLEX*16 ALPHA, BETA 06596 * .. 06597 * .. Array Arguments .. 06598 INTEGER DESCA( * ), DESCC( * ) 06599 COMPLEX*16 A( * ), C( * ), PC( * ) 06600 * .. 06601 * 06602 * Purpose 06603 * ======= 06604 * 06605 * PZMMCH3 checks the results of the computational tests. 06606 * 06607 * Notes 06608 * ===== 06609 * 06610 * A description vector is associated with each 2D block-cyclicly dis- 06611 * tributed matrix. This vector stores the information required to 06612 * establish the mapping between a matrix entry and its corresponding 06613 * process and memory location. 06614 * 06615 * In the following comments, the character _ should be read as 06616 * "of the distributed matrix". Let A be a generic term for any 2D 06617 * block cyclicly distributed matrix. Its description vector is DESCA: 06618 * 06619 * NOTATION STORED IN EXPLANATION 06620 * ---------------- --------------- ------------------------------------ 06621 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 06622 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 06623 * the NPROW x NPCOL BLACS process grid 06624 * A is distributed over. The context 06625 * itself is global, but the handle 06626 * (the integer value) may vary. 06627 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 06628 * ted matrix A, M_A >= 0. 06629 * N_A (global) DESCA( N_ ) The number of columns in the distri- 06630 * buted matrix A, N_A >= 0. 06631 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 06632 * block of the matrix A, IMB_A > 0. 06633 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 06634 * left block of the matrix A, 06635 * INB_A > 0. 06636 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 06637 * bute the last M_A-IMB_A rows of A, 06638 * MB_A > 0. 06639 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 06640 * bute the last N_A-INB_A columns of 06641 * A, NB_A > 0. 06642 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 06643 * row of the matrix A is distributed, 06644 * NPROW > RSRC_A >= 0. 06645 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 06646 * first column of A is distributed. 06647 * NPCOL > CSRC_A >= 0. 06648 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 06649 * array storing the local blocks of 06650 * the distributed matrix A, 06651 * IF( Lc( 1, N_A ) > 0 ) 06652 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 06653 * ELSE 06654 * LLD_A >= 1. 06655 * 06656 * Let K be the number of rows of a matrix A starting at the global in- 06657 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 06658 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 06659 * receive if these K rows were distributed over NPROW processes. If K 06660 * is the number of columns of a matrix A starting at the global index 06661 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 06662 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 06663 * these K columns were distributed over NPCOL processes. 06664 * 06665 * The values of Lr() and Lc() may be determined via a call to the func- 06666 * tion PB_NUMROC: 06667 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 06668 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 06669 * 06670 * Arguments 06671 * ========= 06672 * 06673 * UPLO (global input) CHARACTER*1 06674 * On entry, UPLO specifies which part of C should contain the 06675 * result. 06676 * 06677 * TRANS (global input) CHARACTER*1 06678 * On entry, TRANS specifies whether the matrix A has to be 06679 * transposed or not before computing the matrix-matrix addi- 06680 * tion. 06681 * 06682 * M (global input) INTEGER 06683 * On entry, M specifies the number of rows of C. 06684 * 06685 * N (global input) INTEGER 06686 * On entry, N specifies the number of columns of C. 06687 * 06688 * ALPHA (global input) COMPLEX*16 06689 * On entry, ALPHA specifies the scalar alpha. 06690 * 06691 * A (local input) COMPLEX*16 array 06692 * On entry, A is an array of dimension (DESCA( M_ ),*). This 06693 * array contains a local copy of the initial entire matrix PA. 06694 * 06695 * IA (global input) INTEGER 06696 * On entry, IA specifies A's global row index, which points to 06697 * the beginning of the submatrix sub( A ). 06698 * 06699 * JA (global input) INTEGER 06700 * On entry, JA specifies A's global column index, which points 06701 * to the beginning of the submatrix sub( A ). 06702 * 06703 * DESCA (global and local input) INTEGER array 06704 * On entry, DESCA is an integer array of dimension DLEN_. This 06705 * is the array descriptor for the matrix A. 06706 * 06707 * BETA (global input) COMPLEX*16 06708 * On entry, BETA specifies the scalar beta. 06709 * 06710 * C (local input/local output) COMPLEX*16 array 06711 * On entry, C is an array of dimension (DESCC( M_ ),*). This 06712 * array contains a local copy of the initial entire matrix PC. 06713 * 06714 * PC (local input) COMPLEX*16 array 06715 * On entry, PC is an array of dimension (DESCC( LLD_ ),*). This 06716 * array contains the local pieces of the matrix PC. 06717 * 06718 * IC (global input) INTEGER 06719 * On entry, IC specifies C's global row index, which points to 06720 * the beginning of the submatrix sub( C ). 06721 * 06722 * JC (global input) INTEGER 06723 * On entry, JC specifies C's global column index, which points 06724 * to the beginning of the submatrix sub( C ). 06725 * 06726 * DESCC (global and local input) INTEGER array 06727 * On entry, DESCC is an integer array of dimension DLEN_. This 06728 * is the array descriptor for the matrix C. 06729 * 06730 * ERR (global output) DOUBLE PRECISION 06731 * On exit, ERR specifies the largest error in absolute value. 06732 * 06733 * INFO (global output) INTEGER 06734 * On exit, if INFO <> 0, the result is less than half accurate. 06735 * 06736 * -- Written on April 1, 1998 by 06737 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 06738 * 06739 * ===================================================================== 06740 * 06741 * .. Parameters .. 06742 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 06743 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 06744 $ RSRC_ 06745 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 06746 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 06747 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 06748 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 06749 DOUBLE PRECISION ZERO 06750 PARAMETER ( ZERO = 0.0D+0 ) 06751 * .. 06752 * .. Local Scalars .. 06753 LOGICAL COLREP, CTRAN, LOWER, NOTRAN, ROWREP, UPPER 06754 INTEGER I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J, 06755 $ JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL, 06756 $ NPROW 06757 DOUBLE PRECISION ERR0, ERRI, PREC 06758 * .. 06759 * .. External Subroutines .. 06760 EXTERNAL BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L, 06761 $ PZERRAXPBY 06762 * .. 06763 * .. External Functions .. 06764 LOGICAL LSAME 06765 DOUBLE PRECISION PDLAMCH 06766 EXTERNAL LSAME, PDLAMCH 06767 * .. 06768 * .. Intrinsic Functions .. 06769 INTRINSIC ABS, DCONJG, MAX 06770 * .. 06771 * .. Executable Statements .. 06772 * 06773 ICTXT = DESCC( CTXT_ ) 06774 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 06775 * 06776 PREC = PDLAMCH( ICTXT, 'eps' ) 06777 * 06778 UPPER = LSAME( UPLO, 'U' ) 06779 LOWER = LSAME( UPLO, 'L' ) 06780 NOTRAN = LSAME( TRANS, 'N' ) 06781 CTRAN = LSAME( TRANS, 'C' ) 06782 * 06783 * Compute expected result in C using data in A and C. This part of 06784 * the computation is performed by every process in the grid. 06785 * 06786 INFO = 0 06787 ERR = ZERO 06788 * 06789 LDA = MAX( 1, DESCA( M_ ) ) 06790 LDC = MAX( 1, DESCC( M_ ) ) 06791 LDPC = MAX( 1, DESCC( LLD_ ) ) 06792 ROWREP = ( DESCC( RSRC_ ).EQ.-1 ) 06793 COLREP = ( DESCC( CSRC_ ).EQ.-1 ) 06794 * 06795 IF( NOTRAN ) THEN 06796 * 06797 DO 20 J = JC, JC + N - 1 06798 * 06799 IOFFC = IC + ( J - 1 ) * LDC 06800 IOFFA = IA + ( JA - 1 + J - JC ) * LDA 06801 * 06802 DO 10 I = IC, IC + M - 1 06803 * 06804 IF( UPPER ) THEN 06805 IF( ( J - JC ).GE.( I - IC ) ) THEN 06806 CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06807 $ C( IOFFC ), PREC ) 06808 ELSE 06809 ERRI = ZERO 06810 END IF 06811 ELSE IF( LOWER ) THEN 06812 IF( ( J - JC ).LE.( I - IC ) ) THEN 06813 CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06814 $ C( IOFFC ), PREC ) 06815 ELSE 06816 ERRI = ZERO 06817 END IF 06818 ELSE 06819 CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06820 $ C( IOFFC ), PREC ) 06821 END IF 06822 * 06823 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06824 $ IIC, JJC, ICROW, ICCOL ) 06825 IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND. 06826 $ ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN 06827 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) ) 06828 IF( ERR0.GT.ERRI ) 06829 $ INFO = 1 06830 ERR = MAX( ERR, ERR0 ) 06831 END IF 06832 * 06833 IOFFA = IOFFA + 1 06834 IOFFC = IOFFC + 1 06835 * 06836 10 CONTINUE 06837 * 06838 20 CONTINUE 06839 * 06840 ELSE IF( CTRAN ) THEN 06841 * 06842 DO 40 J = JC, JC + N - 1 06843 * 06844 IOFFC = IC + ( J - 1 ) * LDC 06845 IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA 06846 * 06847 DO 30 I = IC, IC + M - 1 06848 * 06849 IF( UPPER ) THEN 06850 IF( ( J - JC ).GE.( I - IC ) ) THEN 06851 CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ), 06852 $ BETA, C( IOFFC ), PREC ) 06853 ELSE 06854 ERRI = ZERO 06855 END IF 06856 ELSE IF( LOWER ) THEN 06857 IF( ( J - JC ).LE.( I - IC ) ) THEN 06858 CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ), 06859 $ BETA, C( IOFFC ), PREC ) 06860 ELSE 06861 ERRI = ZERO 06862 END IF 06863 ELSE 06864 CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ), 06865 $ BETA, C( IOFFC ), PREC ) 06866 END IF 06867 * 06868 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06869 $ IIC, JJC, ICROW, ICCOL ) 06870 IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND. 06871 $ ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN 06872 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) ) 06873 IF( ERR0.GT.ERRI ) 06874 $ INFO = 1 06875 ERR = MAX( ERR, ERR0 ) 06876 END IF 06877 * 06878 IOFFC = IOFFC + 1 06879 IOFFA = IOFFA + LDA 06880 * 06881 30 CONTINUE 06882 * 06883 40 CONTINUE 06884 * 06885 ELSE 06886 * 06887 DO 60 J = JC, JC + N - 1 06888 * 06889 IOFFC = IC + ( J - 1 ) * LDC 06890 IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA 06891 * 06892 DO 50 I = IC, IC + M - 1 06893 * 06894 IF( UPPER ) THEN 06895 IF( ( J - JC ).GE.( I - IC ) ) THEN 06896 CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06897 $ C( IOFFC ), PREC ) 06898 ELSE 06899 ERRI = ZERO 06900 END IF 06901 ELSE IF( LOWER ) THEN 06902 IF( ( J - JC ).LE.( I - IC ) ) THEN 06903 CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06904 $ C( IOFFC ), PREC ) 06905 ELSE 06906 ERRI = ZERO 06907 END IF 06908 ELSE 06909 CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA, 06910 $ C( IOFFC ), PREC ) 06911 END IF 06912 * 06913 CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL, 06914 $ IIC, JJC, ICROW, ICCOL ) 06915 IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND. 06916 $ ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN 06917 ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) ) 06918 IF( ERR0.GT.ERRI ) 06919 $ INFO = 1 06920 ERR = MAX( ERR, ERR0 ) 06921 END IF 06922 * 06923 IOFFC = IOFFC + 1 06924 IOFFA = IOFFA + LDA 06925 * 06926 50 CONTINUE 06927 * 06928 60 CONTINUE 06929 * 06930 END IF 06931 * 06932 * If INFO = 0, all results are at least half accurate. 06933 * 06934 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL ) 06935 CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1, 06936 $ MYCOL ) 06937 * 06938 RETURN 06939 * 06940 * End of PZMMCH3 06941 * 06942 END 06943 SUBROUTINE PZERRAXPBY( ERRBND, ALPHA, X, BETA, Y, PREC ) 06944 * 06945 * -- PBLAS test routine (version 2.0) -- 06946 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 06947 * and University of California, Berkeley. 06948 * April 1, 1998 06949 * 06950 * .. Scalar Arguments .. 06951 DOUBLE PRECISION ERRBND, PREC 06952 COMPLEX*16 ALPHA, BETA, X, Y 06953 * .. 06954 * 06955 * Purpose 06956 * ======= 06957 * 06958 * PZERRAXPBY serially computes y := beta*y + alpha * x and returns a 06959 * scaled relative acceptable error bound on the result. 06960 * 06961 * Arguments 06962 * ========= 06963 * 06964 * ERRBND (global output) DOUBLE PRECISION 06965 * On exit, ERRBND specifies the scaled relative acceptable er- 06966 * ror bound. 06967 * 06968 * ALPHA (global input) COMPLEX*16 06969 * On entry, ALPHA specifies the scalar alpha. 06970 * 06971 * X (global input) COMPLEX*16 06972 * On entry, X specifies the scalar x to be scaled. 06973 * 06974 * BETA (global input) COMPLEX*16 06975 * On entry, BETA specifies the scalar beta. 06976 * 06977 * Y (global input/global output) COMPLEX*16 06978 * On entry, Y specifies the scalar y to be added. On exit, Y 06979 * contains the resulting scalar y. 06980 * 06981 * PREC (global input) DOUBLE PRECISION 06982 * On entry, PREC specifies the machine precision. 06983 * 06984 * -- Written on April 1, 1998 by 06985 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 06986 * 06987 * ===================================================================== 06988 * 06989 * .. Parameters .. 06990 DOUBLE PRECISION ONE, TWO, ZERO 06991 PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, 06992 $ ZERO = 0.0D+0 ) 06993 * .. 06994 * .. Local Scalars .. 06995 DOUBLE PRECISION ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG, 06996 $ SUMRPOS 06997 COMPLEX*16 TMP 06998 * .. 06999 * .. Intrinsic Functions .. 07000 * .. 07001 * .. Executable Statements .. 07002 * 07003 SUMIPOS = ZERO 07004 SUMINEG = ZERO 07005 SUMRPOS = ZERO 07006 SUMRNEG = ZERO 07007 FACT = ONE + TWO * PREC 07008 ADDBND = TWO * TWO * TWO * PREC 07009 * 07010 TMP = ALPHA * X 07011 IF( DBLE( TMP ).GE.ZERO ) THEN 07012 SUMRPOS = SUMRPOS + DBLE( TMP ) * FACT 07013 ELSE 07014 SUMRNEG = SUMRNEG - DBLE( TMP ) * FACT 07015 END IF 07016 IF( DIMAG( TMP ).GE.ZERO ) THEN 07017 SUMIPOS = SUMIPOS + DIMAG( TMP ) * FACT 07018 ELSE 07019 SUMINEG = SUMINEG - DIMAG( TMP ) * FACT 07020 END IF 07021 * 07022 TMP = BETA * Y 07023 IF( DBLE( TMP ).GE.ZERO ) THEN 07024 SUMRPOS = SUMRPOS + DBLE( TMP ) * FACT 07025 ELSE 07026 SUMRNEG = SUMRNEG - DBLE( TMP ) * FACT 07027 END IF 07028 IF( DIMAG( TMP ).GE.ZERO ) THEN 07029 SUMIPOS = SUMIPOS + DIMAG( TMP ) * FACT 07030 ELSE 07031 SUMINEG = SUMINEG - DIMAG( TMP ) * FACT 07032 END IF 07033 * 07034 Y = ( BETA * Y ) + ( ALPHA * X ) 07035 * 07036 ERRBND = ADDBND * MAX( MAX( SUMRPOS, SUMRNEG ), 07037 $ MAX( SUMIPOS, SUMINEG ) ) 07038 * 07039 RETURN 07040 * 07041 * End of PZERRAXPBY 07042 * 07043 END 07044 SUBROUTINE PZIPSET( TOGGLE, N, A, IA, JA, DESCA ) 07045 * 07046 * -- PBLAS test routine (version 2.0) -- 07047 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07048 * and University of California, Berkeley. 07049 * April 1, 1998 07050 * 07051 * .. Scalar Arguments .. 07052 CHARACTER*1 TOGGLE 07053 INTEGER IA, JA, N 07054 * .. 07055 * .. Array Arguments .. 07056 INTEGER DESCA( * ) 07057 COMPLEX*16 A( * ) 07058 * .. 07059 * 07060 * Purpose 07061 * ======= 07062 * 07063 * PZIPSET sets the imaginary part of the diagonal entries of an n by n 07064 * matrix sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ). This is used to 07065 * test the PBLAS routines for complex Hermitian matrices, which are 07066 * either not supposed to access or use the imaginary parts of the dia- 07067 * gonals, or supposed to set them to zero. The value used to set the 07068 * imaginary part of the diagonals depends on the value of TOGGLE. 07069 * 07070 * Notes 07071 * ===== 07072 * 07073 * A description vector is associated with each 2D block-cyclicly dis- 07074 * tributed matrix. This vector stores the information required to 07075 * establish the mapping between a matrix entry and its corresponding 07076 * process and memory location. 07077 * 07078 * In the following comments, the character _ should be read as 07079 * "of the distributed matrix". Let A be a generic term for any 2D 07080 * block cyclicly distributed matrix. Its description vector is DESCA: 07081 * 07082 * NOTATION STORED IN EXPLANATION 07083 * ---------------- --------------- ------------------------------------ 07084 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 07085 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 07086 * the NPROW x NPCOL BLACS process grid 07087 * A is distributed over. The context 07088 * itself is global, but the handle 07089 * (the integer value) may vary. 07090 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 07091 * ted matrix A, M_A >= 0. 07092 * N_A (global) DESCA( N_ ) The number of columns in the distri- 07093 * buted matrix A, N_A >= 0. 07094 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 07095 * block of the matrix A, IMB_A > 0. 07096 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 07097 * left block of the matrix A, 07098 * INB_A > 0. 07099 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 07100 * bute the last M_A-IMB_A rows of A, 07101 * MB_A > 0. 07102 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 07103 * bute the last N_A-INB_A columns of 07104 * A, NB_A > 0. 07105 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 07106 * row of the matrix A is distributed, 07107 * NPROW > RSRC_A >= 0. 07108 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 07109 * first column of A is distributed. 07110 * NPCOL > CSRC_A >= 0. 07111 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 07112 * array storing the local blocks of 07113 * the distributed matrix A, 07114 * IF( Lc( 1, N_A ) > 0 ) 07115 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 07116 * ELSE 07117 * LLD_A >= 1. 07118 * 07119 * Let K be the number of rows of a matrix A starting at the global in- 07120 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 07121 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 07122 * receive if these K rows were distributed over NPROW processes. If K 07123 * is the number of columns of a matrix A starting at the global index 07124 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 07125 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 07126 * these K columns were distributed over NPCOL processes. 07127 * 07128 * The values of Lr() and Lc() may be determined via a call to the func- 07129 * tion PB_NUMROC: 07130 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 07131 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 07132 * 07133 * Arguments 07134 * ========= 07135 * 07136 * TOGGLE (global input) CHARACTER*1 07137 * On entry, TOGGLE specifies the set-value to be used as fol- 07138 * lows: 07139 * If TOGGLE = 'Z' or 'z', the imaginary part of the diago- 07140 * nals are set to zero, 07141 * If TOGGLE = 'B' or 'b', the imaginary part of the diago- 07142 * nals are set to a large value. 07143 * 07144 * N (global input) INTEGER 07145 * On entry, N specifies the order of sub( A ). N must be at 07146 * least zero. 07147 * 07148 * A (local input/local output) pointer to COMPLEX*16 07149 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 07150 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 07151 * the local entries of the matrix A. On exit, the diagonals of 07152 * sub( A ) have been updated as specified by TOGGLE. 07153 * 07154 * IA (global input) INTEGER 07155 * On entry, IA specifies A's global row index, which points to 07156 * the beginning of the submatrix sub( A ). 07157 * 07158 * JA (global input) INTEGER 07159 * On entry, JA specifies A's global column index, which points 07160 * to the beginning of the submatrix sub( A ). 07161 * 07162 * DESCA (global and local input) INTEGER array 07163 * On entry, DESCA is an integer array of dimension DLEN_. This 07164 * is the array descriptor for the matrix A. 07165 * 07166 * -- Written on April 1, 1998 by 07167 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 07168 * 07169 * ===================================================================== 07170 * 07171 * .. Parameters .. 07172 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 07173 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 07174 $ RSRC_ 07175 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 07176 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 07177 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 07178 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 07179 DOUBLE PRECISION ZERO 07180 PARAMETER ( ZERO = 0.0D+0 ) 07181 * .. 07182 * .. Local Scalars .. 07183 LOGICAL COLREP, GODOWN, GOLEFT, ROWREP 07184 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW, 07185 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, 07186 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1, 07187 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC, 07188 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS, 07189 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP 07190 DOUBLE PRECISION ALPHA, ATMP 07191 * .. 07192 * .. Local Arrays .. 07193 INTEGER DESCA2( DLEN_ ) 07194 * .. 07195 * .. External Subroutines .. 07196 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 07197 $ PB_DESCTRANS 07198 * .. 07199 * .. External Functions .. 07200 LOGICAL LSAME 07201 DOUBLE PRECISION PDLAMCH 07202 EXTERNAL LSAME, PDLAMCH 07203 * .. 07204 * .. Intrinsic Functions .. 07205 INTRINSIC DBLE, DCMPLX, MAX, MIN 07206 * .. 07207 * .. Executable Statements .. 07208 * 07209 * Convert descriptor 07210 * 07211 CALL PB_DESCTRANS( DESCA, DESCA2 ) 07212 * 07213 * Get grid parameters 07214 * 07215 ICTXT = DESCA2( CTXT_ ) 07216 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 07217 * 07218 IF( N.LE.0 ) 07219 $ RETURN 07220 * 07221 IF( LSAME( TOGGLE, 'Z' ) ) THEN 07222 ALPHA = ZERO 07223 ELSE IF( LSAME( TOGGLE, 'B' ) ) THEN 07224 ALPHA = PDLAMCH( ICTXT, 'Epsilon' ) 07225 ALPHA = ALPHA / PDLAMCH( ICTXT, 'Safe minimum' ) 07226 END IF 07227 * 07228 CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 07229 $ MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW, 07230 $ IACOL, MRROW, MRCOL ) 07231 * 07232 IF( NP.LE.0 .OR. NQ.LE.0 ) 07233 $ RETURN 07234 * 07235 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 07236 * ILOW, LOW, IUPP, and UPP. 07237 * 07238 MB = DESCA2( MB_ ) 07239 NB = DESCA2( NB_ ) 07240 CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL, 07241 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 07242 $ LNBLOC, ILOW, LOW, IUPP, UPP ) 07243 * 07244 IOFFA = IIA - 1 07245 JOFFA = JJA - 1 07246 ROWREP = ( DESCA2( RSRC_ ).EQ.-1 ) 07247 COLREP = ( DESCA2( CSRC_ ).EQ.-1 ) 07248 LDA = DESCA2( LLD_ ) 07249 LDAP1 = LDA + 1 07250 * 07251 IF( ROWREP ) THEN 07252 PMB = MB 07253 ELSE 07254 PMB = NPROW * MB 07255 END IF 07256 IF( COLREP ) THEN 07257 QNB = NB 07258 ELSE 07259 QNB = NPCOL * NB 07260 END IF 07261 * 07262 * Handle the first block of rows or columns separately, and update 07263 * LCMT00, MBLKS and NBLKS. 07264 * 07265 GODOWN = ( LCMT00.GT.IUPP ) 07266 GOLEFT = ( LCMT00.LT.ILOW ) 07267 * 07268 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 07269 * 07270 * LCMT00 >= ILOW && LCMT00 <= IUPP 07271 * 07272 IF( LCMT00.GE.0 ) THEN 07273 IJOFFA = IOFFA + LCMT00 + ( JOFFA - 1 ) * LDA 07274 DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) ) 07275 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07276 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07277 10 CONTINUE 07278 ELSE 07279 IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA 07280 DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) ) 07281 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07282 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07283 20 CONTINUE 07284 END IF 07285 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 07286 GODOWN = .NOT.GOLEFT 07287 * 07288 END IF 07289 * 07290 IF( GODOWN ) THEN 07291 * 07292 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07293 MBLKS = MBLKS - 1 07294 IOFFA = IOFFA + IMBLOC 07295 * 07296 30 CONTINUE 07297 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07298 LCMT00 = LCMT00 - PMB 07299 MBLKS = MBLKS - 1 07300 IOFFA = IOFFA + MB 07301 GO TO 30 07302 END IF 07303 * 07304 IF( MBLKS.LE.0 ) 07305 $ RETURN 07306 * 07307 LCMT = LCMT00 07308 MBLKD = MBLKS 07309 IOFFD = IOFFA 07310 * 07311 MBLOC = MB 07312 40 CONTINUE 07313 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 07314 IF( MBLKD.EQ.1 ) 07315 $ MBLOC = LMBLOC 07316 IF( LCMT.GE.0 ) THEN 07317 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 07318 DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) ) 07319 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07320 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07321 50 CONTINUE 07322 ELSE 07323 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 07324 DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) ) 07325 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07326 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07327 60 CONTINUE 07328 END IF 07329 LCMT00 = LCMT 07330 LCMT = LCMT - PMB 07331 MBLKS = MBLKD 07332 MBLKD = MBLKD - 1 07333 IOFFA = IOFFD 07334 IOFFD = IOFFD + MBLOC 07335 GO TO 40 07336 END IF 07337 * 07338 LCMT00 = LCMT00 + LOW - ILOW + QNB 07339 NBLKS = NBLKS - 1 07340 JOFFA = JOFFA + INBLOC 07341 * 07342 ELSE IF( GOLEFT ) THEN 07343 * 07344 LCMT00 = LCMT00 + LOW - ILOW + QNB 07345 NBLKS = NBLKS - 1 07346 JOFFA = JOFFA + INBLOC 07347 * 07348 70 CONTINUE 07349 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 07350 LCMT00 = LCMT00 + QNB 07351 NBLKS = NBLKS - 1 07352 JOFFA = JOFFA + NB 07353 GO TO 70 07354 END IF 07355 * 07356 IF( NBLKS.LE.0 ) 07357 $ RETURN 07358 * 07359 LCMT = LCMT00 07360 NBLKD = NBLKS 07361 JOFFD = JOFFA 07362 * 07363 NBLOC = NB 07364 80 CONTINUE 07365 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 07366 IF( NBLKD.EQ.1 ) 07367 $ NBLOC = LNBLOC 07368 IF( LCMT.GE.0 ) THEN 07369 IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA 07370 DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) ) 07371 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07372 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07373 90 CONTINUE 07374 ELSE 07375 IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA 07376 DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) ) 07377 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07378 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07379 100 CONTINUE 07380 END IF 07381 LCMT00 = LCMT 07382 LCMT = LCMT + QNB 07383 NBLKS = NBLKD 07384 NBLKD = NBLKD - 1 07385 JOFFA = JOFFD 07386 JOFFD = JOFFD + NBLOC 07387 GO TO 80 07388 END IF 07389 * 07390 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07391 MBLKS = MBLKS - 1 07392 IOFFA = IOFFA + IMBLOC 07393 * 07394 END IF 07395 * 07396 NBLOC = NB 07397 110 CONTINUE 07398 IF( NBLKS.GT.0 ) THEN 07399 IF( NBLKS.EQ.1 ) 07400 $ NBLOC = LNBLOC 07401 120 CONTINUE 07402 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07403 LCMT00 = LCMT00 - PMB 07404 MBLKS = MBLKS - 1 07405 IOFFA = IOFFA + MB 07406 GO TO 120 07407 END IF 07408 * 07409 IF( MBLKS.LE.0 ) 07410 $ RETURN 07411 * 07412 LCMT = LCMT00 07413 MBLKD = MBLKS 07414 IOFFD = IOFFA 07415 * 07416 MBLOC = MB 07417 130 CONTINUE 07418 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 07419 IF( MBLKD.EQ.1 ) 07420 $ MBLOC = LMBLOC 07421 IF( LCMT.GE.0 ) THEN 07422 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 07423 DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) ) 07424 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07425 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07426 140 CONTINUE 07427 ELSE 07428 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 07429 DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) ) 07430 ATMP = DBLE( A( IJOFFA + I*LDAP1 ) ) 07431 A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA ) 07432 150 CONTINUE 07433 END IF 07434 LCMT00 = LCMT 07435 LCMT = LCMT - PMB 07436 MBLKS = MBLKD 07437 MBLKD = MBLKD - 1 07438 IOFFA = IOFFD 07439 IOFFD = IOFFD + MBLOC 07440 GO TO 130 07441 END IF 07442 * 07443 LCMT00 = LCMT00 + QNB 07444 NBLKS = NBLKS - 1 07445 JOFFA = JOFFA + NBLOC 07446 GO TO 110 07447 * 07448 END IF 07449 * 07450 RETURN 07451 * 07452 * End of PZIPSET 07453 * 07454 END 07455 DOUBLE PRECISION FUNCTION PDLAMCH( ICTXT, CMACH ) 07456 * 07457 * -- PBLAS test routine (version 2.0) -- 07458 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07459 * and University of California, Berkeley. 07460 * April 1, 1998 07461 * 07462 * .. Scalar Arguments .. 07463 CHARACTER*1 CMACH 07464 INTEGER ICTXT 07465 * .. 07466 * 07467 * Purpose 07468 * ======= 07469 * 07470 * 07471 * .. Local Scalars .. 07472 CHARACTER*1 TOP 07473 INTEGER IDUMM 07474 DOUBLE PRECISION TEMP 07475 * .. 07476 * .. External Subroutines .. 07477 EXTERNAL DGAMN2D, DGAMX2D, PB_TOPGET 07478 * .. 07479 * .. External Functions .. 07480 LOGICAL LSAME 07481 DOUBLE PRECISION DLAMCH 07482 EXTERNAL DLAMCH, LSAME 07483 * .. 07484 * .. Executable Statements .. 07485 * 07486 TEMP = DLAMCH( CMACH ) 07487 * 07488 IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR. 07489 $ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN 07490 CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP ) 07491 IDUMM = 0 07492 CALL DGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM, 07493 $ IDUMM, -1, -1, IDUMM ) 07494 ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN 07495 CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP ) 07496 IDUMM = 0 07497 CALL DGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM, 07498 $ IDUMM, -1, -1, IDUMM ) 07499 END IF 07500 * 07501 PDLAMCH = TEMP 07502 * 07503 RETURN 07504 * 07505 * End of PDLAMCH 07506 * 07507 END 07508 SUBROUTINE PZLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) 07509 * 07510 * -- PBLAS test routine (version 2.0) -- 07511 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07512 * and University of California, Berkeley. 07513 * April 1, 1998 07514 * 07515 * .. Scalar Arguments .. 07516 CHARACTER*1 UPLO 07517 INTEGER IA, JA, M, N 07518 COMPLEX*16 ALPHA, BETA 07519 * .. 07520 * .. Array Arguments .. 07521 INTEGER DESCA( * ) 07522 COMPLEX*16 A( * ) 07523 * .. 07524 * 07525 * Purpose 07526 * ======= 07527 * 07528 * PZLASET initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno- 07529 * ted by sub( A ) to beta on the diagonal and alpha on the offdiago- 07530 * nals. 07531 * 07532 * Notes 07533 * ===== 07534 * 07535 * A description vector is associated with each 2D block-cyclicly dis- 07536 * tributed matrix. This vector stores the information required to 07537 * establish the mapping between a matrix entry and its corresponding 07538 * process and memory location. 07539 * 07540 * In the following comments, the character _ should be read as 07541 * "of the distributed matrix". Let A be a generic term for any 2D 07542 * block cyclicly distributed matrix. Its description vector is DESCA: 07543 * 07544 * NOTATION STORED IN EXPLANATION 07545 * ---------------- --------------- ------------------------------------ 07546 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 07547 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 07548 * the NPROW x NPCOL BLACS process grid 07549 * A is distributed over. The context 07550 * itself is global, but the handle 07551 * (the integer value) may vary. 07552 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 07553 * ted matrix A, M_A >= 0. 07554 * N_A (global) DESCA( N_ ) The number of columns in the distri- 07555 * buted matrix A, N_A >= 0. 07556 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 07557 * block of the matrix A, IMB_A > 0. 07558 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 07559 * left block of the matrix A, 07560 * INB_A > 0. 07561 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 07562 * bute the last M_A-IMB_A rows of A, 07563 * MB_A > 0. 07564 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 07565 * bute the last N_A-INB_A columns of 07566 * A, NB_A > 0. 07567 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 07568 * row of the matrix A is distributed, 07569 * NPROW > RSRC_A >= 0. 07570 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 07571 * first column of A is distributed. 07572 * NPCOL > CSRC_A >= 0. 07573 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 07574 * array storing the local blocks of 07575 * the distributed matrix A, 07576 * IF( Lc( 1, N_A ) > 0 ) 07577 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 07578 * ELSE 07579 * LLD_A >= 1. 07580 * 07581 * Let K be the number of rows of a matrix A starting at the global in- 07582 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 07583 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 07584 * receive if these K rows were distributed over NPROW processes. If K 07585 * is the number of columns of a matrix A starting at the global index 07586 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 07587 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 07588 * these K columns were distributed over NPCOL processes. 07589 * 07590 * The values of Lr() and Lc() may be determined via a call to the func- 07591 * tion PB_NUMROC: 07592 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 07593 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 07594 * 07595 * Arguments 07596 * ========= 07597 * 07598 * UPLO (global input) CHARACTER*1 07599 * On entry, UPLO specifies the part of the submatrix sub( A ) 07600 * to be set: 07601 * = 'L' or 'l': Lower triangular part is set; the strictly 07602 * upper triangular part of sub( A ) is not changed; 07603 * = 'U' or 'u': Upper triangular part is set; the strictly 07604 * lower triangular part of sub( A ) is not changed; 07605 * Otherwise: All of the matrix sub( A ) is set. 07606 * 07607 * M (global input) INTEGER 07608 * On entry, M specifies the number of rows of the submatrix 07609 * sub( A ). M must be at least zero. 07610 * 07611 * N (global input) INTEGER 07612 * On entry, N specifies the number of columns of the submatrix 07613 * sub( A ). N must be at least zero. 07614 * 07615 * ALPHA (global input) COMPLEX*16 07616 * On entry, ALPHA specifies the scalar alpha, i.e., the cons- 07617 * tant to which the offdiagonal elements are to be set. 07618 * 07619 * BETA (global input) COMPLEX*16 07620 * On entry, BETA specifies the scalar beta, i.e., the constant 07621 * to which the diagonal elements are to be set. 07622 * 07623 * A (local input/local output) COMPLEX*16 array 07624 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 07625 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 07626 * the local entries of the matrix A to be set. On exit, the 07627 * leading m by n submatrix sub( A ) is set as follows: 07628 * 07629 * if UPLO = 'U', A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N, 07630 * if UPLO = 'L', A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N, 07631 * otherwise, A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M, 1<=j<=N, 07632 * and IA+i.NE.JA+j, 07633 * and, for all UPLO, A(IA+i-1,JA+i-1) = BETA, 1<=i<=min(M,N). 07634 * 07635 * IA (global input) INTEGER 07636 * On entry, IA specifies A's global row index, which points to 07637 * the beginning of the submatrix sub( A ). 07638 * 07639 * JA (global input) INTEGER 07640 * On entry, JA specifies A's global column index, which points 07641 * to the beginning of the submatrix sub( A ). 07642 * 07643 * DESCA (global and local input) INTEGER array 07644 * On entry, DESCA is an integer array of dimension DLEN_. This 07645 * is the array descriptor for the matrix A. 07646 * 07647 * -- Written on April 1, 1998 by 07648 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 07649 * 07650 * ===================================================================== 07651 * 07652 * .. Parameters .. 07653 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 07654 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 07655 $ RSRC_ 07656 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 07657 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 07658 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 07659 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 07660 * .. 07661 * .. Local Scalars .. 07662 LOGICAL GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER, 07663 $ UPPER 07664 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1, 07665 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA, 07666 $ JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC, 07667 $ LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP, 07668 $ MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD, 07669 $ NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1, 07670 $ UPP 07671 * .. 07672 * .. Local Arrays .. 07673 INTEGER DESCA2( DLEN_ ) 07674 * .. 07675 * .. External Subroutines .. 07676 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 07677 $ PB_DESCTRANS, PB_ZLASET 07678 * .. 07679 * .. External Functions .. 07680 LOGICAL LSAME 07681 EXTERNAL LSAME 07682 * .. 07683 * .. Intrinsic Functions .. 07684 INTRINSIC MIN 07685 * .. 07686 * .. Executable Statements .. 07687 * 07688 IF( M.EQ.0 .OR. N.EQ.0 ) 07689 $ RETURN 07690 * 07691 * Convert descriptor 07692 * 07693 CALL PB_DESCTRANS( DESCA, DESCA2 ) 07694 * 07695 * Get grid parameters 07696 * 07697 ICTXT = DESCA2( CTXT_ ) 07698 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 07699 * 07700 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 07701 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW, 07702 $ IACOL, MRROW, MRCOL ) 07703 * 07704 IF( MP.LE.0 .OR. NQ.LE.0 ) 07705 $ RETURN 07706 * 07707 ISROWREP = ( DESCA2( RSRC_ ).LT.0 ) 07708 ISCOLREP = ( DESCA2( CSRC_ ).LT.0 ) 07709 LDA = DESCA2( LLD_ ) 07710 * 07711 UPPER = .NOT.( LSAME( UPLO, 'L' ) ) 07712 LOWER = .NOT.( LSAME( UPLO, 'U' ) ) 07713 * 07714 IF( ( ( LOWER.AND.UPPER ).AND.( ALPHA.EQ.BETA ) ).OR. 07715 $ ( ISROWREP .AND. ISCOLREP ) ) THEN 07716 IF( ( MP.GT.0 ).AND.( NQ.GT.0 ) ) 07717 $ CALL PB_ZLASET( UPLO, MP, NQ, 0, ALPHA, BETA, 07718 $ A( IIA + ( JJA - 1 ) * LDA ), LDA ) 07719 RETURN 07720 END IF 07721 * 07722 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 07723 * ILOW, LOW, IUPP, and UPP. 07724 * 07725 MB = DESCA2( MB_ ) 07726 NB = DESCA2( NB_ ) 07727 CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL, 07728 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 07729 $ LNBLOC, ILOW, LOW, IUPP, UPP ) 07730 * 07731 IOFFA = IIA - 1 07732 JOFFA = JJA - 1 07733 IIMAX = IOFFA + MP 07734 JJMAX = JOFFA + NQ 07735 * 07736 IF( ISROWREP ) THEN 07737 PMB = MB 07738 ELSE 07739 PMB = NPROW * MB 07740 END IF 07741 IF( ISCOLREP ) THEN 07742 QNB = NB 07743 ELSE 07744 QNB = NPCOL * NB 07745 END IF 07746 * 07747 M1 = MP 07748 N1 = NQ 07749 * 07750 * Handle the first block of rows or columns separately, and update 07751 * LCMT00, MBLKS and NBLKS. 07752 * 07753 GODOWN = ( LCMT00.GT.IUPP ) 07754 GOLEFT = ( LCMT00.LT.ILOW ) 07755 * 07756 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 07757 * 07758 * LCMT00 >= ILOW && LCMT00 <= IUPP 07759 * 07760 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 07761 GODOWN = .NOT.GOLEFT 07762 * 07763 CALL PB_ZLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA, 07764 $ A( IIA+JOFFA*LDA ), LDA ) 07765 IF( GODOWN ) THEN 07766 IF( UPPER .AND. NQ.GT.INBLOC ) 07767 $ CALL PB_ZLASET( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA, 07768 $ ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA ) 07769 IIA = IIA + IMBLOC 07770 M1 = M1 - IMBLOC 07771 ELSE 07772 IF( LOWER .AND. MP.GT.IMBLOC ) 07773 $ CALL PB_ZLASET( 'All', MP-IMBLOC, INBLOC, 0, ALPHA, 07774 $ ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA ) 07775 JJA = JJA + INBLOC 07776 N1 = N1 - INBLOC 07777 END IF 07778 * 07779 END IF 07780 * 07781 IF( GODOWN ) THEN 07782 * 07783 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07784 MBLKS = MBLKS - 1 07785 IOFFA = IOFFA + IMBLOC 07786 * 07787 10 CONTINUE 07788 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07789 LCMT00 = LCMT00 - PMB 07790 MBLKS = MBLKS - 1 07791 IOFFA = IOFFA + MB 07792 GO TO 10 07793 END IF 07794 * 07795 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 07796 IF( UPPER .AND. TMP1.GT.0 ) THEN 07797 CALL PB_ZLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA, 07798 $ A( IIA+JOFFA*LDA ), LDA ) 07799 IIA = IIA + TMP1 07800 M1 = M1 - TMP1 07801 END IF 07802 * 07803 IF( MBLKS.LE.0 ) 07804 $ RETURN 07805 * 07806 LCMT = LCMT00 07807 MBLKD = MBLKS 07808 IOFFD = IOFFA 07809 * 07810 MBLOC = MB 07811 20 CONTINUE 07812 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 07813 IF( MBLKD.EQ.1 ) 07814 $ MBLOC = LMBLOC 07815 CALL PB_ZLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA, 07816 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07817 LCMT00 = LCMT 07818 LCMT = LCMT - PMB 07819 MBLKS = MBLKD 07820 MBLKD = MBLKD - 1 07821 IOFFA = IOFFD 07822 IOFFD = IOFFD + MBLOC 07823 GO TO 20 07824 END IF 07825 * 07826 TMP1 = M1 - IOFFD + IIA - 1 07827 IF( LOWER .AND. TMP1.GT.0 ) 07828 $ CALL PB_ZLASET( 'ALL', TMP1, INBLOC, 0, ALPHA, ALPHA, 07829 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07830 * 07831 TMP1 = IOFFA - IIA + 1 07832 M1 = M1 - TMP1 07833 N1 = N1 - INBLOC 07834 LCMT00 = LCMT00 + LOW - ILOW + QNB 07835 NBLKS = NBLKS - 1 07836 JOFFA = JOFFA + INBLOC 07837 * 07838 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 07839 $ CALL PB_ZLASET( 'ALL', TMP1, N1, 0, ALPHA, ALPHA, 07840 $ A( IIA+JOFFA*LDA ), LDA ) 07841 * 07842 IIA = IOFFA + 1 07843 JJA = JOFFA + 1 07844 * 07845 ELSE IF( GOLEFT ) THEN 07846 * 07847 LCMT00 = LCMT00 + LOW - ILOW + QNB 07848 NBLKS = NBLKS - 1 07849 JOFFA = JOFFA + INBLOC 07850 * 07851 30 CONTINUE 07852 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 07853 LCMT00 = LCMT00 + QNB 07854 NBLKS = NBLKS - 1 07855 JOFFA = JOFFA + NB 07856 GO TO 30 07857 END IF 07858 * 07859 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1 07860 IF( LOWER .AND. TMP1.GT.0 ) THEN 07861 CALL PB_ZLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA, 07862 $ A( IIA+(JJA-1)*LDA ), LDA ) 07863 JJA = JJA + TMP1 07864 N1 = N1 - TMP1 07865 END IF 07866 * 07867 IF( NBLKS.LE.0 ) 07868 $ RETURN 07869 * 07870 LCMT = LCMT00 07871 NBLKD = NBLKS 07872 JOFFD = JOFFA 07873 * 07874 NBLOC = NB 07875 40 CONTINUE 07876 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 07877 IF( NBLKD.EQ.1 ) 07878 $ NBLOC = LNBLOC 07879 CALL PB_ZLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA, 07880 $ A( IIA+JOFFD*LDA ), LDA ) 07881 LCMT00 = LCMT 07882 LCMT = LCMT + QNB 07883 NBLKS = NBLKD 07884 NBLKD = NBLKD - 1 07885 JOFFA = JOFFD 07886 JOFFD = JOFFD + NBLOC 07887 GO TO 40 07888 END IF 07889 * 07890 TMP1 = N1 - JOFFD + JJA - 1 07891 IF( UPPER .AND. TMP1.GT.0 ) 07892 $ CALL PB_ZLASET( 'All', IMBLOC, TMP1, 0, ALPHA, ALPHA, 07893 $ A( IIA+JOFFD*LDA ), LDA ) 07894 * 07895 TMP1 = JOFFA - JJA + 1 07896 M1 = M1 - IMBLOC 07897 N1 = N1 - TMP1 07898 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 07899 MBLKS = MBLKS - 1 07900 IOFFA = IOFFA + IMBLOC 07901 * 07902 IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 ) 07903 $ CALL PB_ZLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA, 07904 $ A( IOFFA+1+(JJA-1)*LDA ), LDA ) 07905 * 07906 IIA = IOFFA + 1 07907 JJA = JOFFA + 1 07908 * 07909 END IF 07910 * 07911 NBLOC = NB 07912 50 CONTINUE 07913 IF( NBLKS.GT.0 ) THEN 07914 IF( NBLKS.EQ.1 ) 07915 $ NBLOC = LNBLOC 07916 60 CONTINUE 07917 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 07918 LCMT00 = LCMT00 - PMB 07919 MBLKS = MBLKS - 1 07920 IOFFA = IOFFA + MB 07921 GO TO 60 07922 END IF 07923 * 07924 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 07925 IF( UPPER .AND. TMP1.GT.0 ) THEN 07926 CALL PB_ZLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA, 07927 $ A( IIA+JOFFA*LDA ), LDA ) 07928 IIA = IIA + TMP1 07929 M1 = M1 - TMP1 07930 END IF 07931 * 07932 IF( MBLKS.LE.0 ) 07933 $ RETURN 07934 * 07935 LCMT = LCMT00 07936 MBLKD = MBLKS 07937 IOFFD = IOFFA 07938 * 07939 MBLOC = MB 07940 70 CONTINUE 07941 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 07942 IF( MBLKD.EQ.1 ) 07943 $ MBLOC = LMBLOC 07944 CALL PB_ZLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA, 07945 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07946 LCMT00 = LCMT 07947 LCMT = LCMT - PMB 07948 MBLKS = MBLKD 07949 MBLKD = MBLKD - 1 07950 IOFFA = IOFFD 07951 IOFFD = IOFFD + MBLOC 07952 GO TO 70 07953 END IF 07954 * 07955 TMP1 = M1 - IOFFD + IIA - 1 07956 IF( LOWER .AND. TMP1.GT.0 ) 07957 $ CALL PB_ZLASET( 'All', TMP1, NBLOC, 0, ALPHA, ALPHA, 07958 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 07959 * 07960 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 07961 M1 = M1 - TMP1 07962 N1 = N1 - NBLOC 07963 LCMT00 = LCMT00 + QNB 07964 NBLKS = NBLKS - 1 07965 JOFFA = JOFFA + NBLOC 07966 * 07967 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 07968 $ CALL PB_ZLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA, 07969 $ A( IIA+JOFFA*LDA ), LDA ) 07970 * 07971 IIA = IOFFA + 1 07972 JJA = JOFFA + 1 07973 * 07974 GO TO 50 07975 * 07976 END IF 07977 * 07978 RETURN 07979 * 07980 * End of PZLASET 07981 * 07982 END 07983 SUBROUTINE PZLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA ) 07984 * 07985 * -- PBLAS test routine (version 2.0) -- 07986 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 07987 * and University of California, Berkeley. 07988 * April 1, 1998 07989 * 07990 * .. Scalar Arguments .. 07991 CHARACTER*1 TYPE 07992 INTEGER IA, JA, M, N 07993 COMPLEX*16 ALPHA 07994 * .. 07995 * .. Array Arguments .. 07996 INTEGER DESCA( * ) 07997 COMPLEX*16 A( * ) 07998 * .. 07999 * 08000 * Purpose 08001 * ======= 08002 * 08003 * PZLASCAL scales the m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted 08004 * by sub( A ) by the scalar alpha. TYPE specifies if sub( A ) is full, 08005 * upper triangular, lower triangular or upper Hessenberg. 08006 * 08007 * Notes 08008 * ===== 08009 * 08010 * A description vector is associated with each 2D block-cyclicly dis- 08011 * tributed matrix. This vector stores the information required to 08012 * establish the mapping between a matrix entry and its corresponding 08013 * process and memory location. 08014 * 08015 * In the following comments, the character _ should be read as 08016 * "of the distributed matrix". Let A be a generic term for any 2D 08017 * block cyclicly distributed matrix. Its description vector is DESCA: 08018 * 08019 * NOTATION STORED IN EXPLANATION 08020 * ---------------- --------------- ------------------------------------ 08021 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 08022 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 08023 * the NPROW x NPCOL BLACS process grid 08024 * A is distributed over. The context 08025 * itself is global, but the handle 08026 * (the integer value) may vary. 08027 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 08028 * ted matrix A, M_A >= 0. 08029 * N_A (global) DESCA( N_ ) The number of columns in the distri- 08030 * buted matrix A, N_A >= 0. 08031 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 08032 * block of the matrix A, IMB_A > 0. 08033 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 08034 * left block of the matrix A, 08035 * INB_A > 0. 08036 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 08037 * bute the last M_A-IMB_A rows of A, 08038 * MB_A > 0. 08039 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 08040 * bute the last N_A-INB_A columns of 08041 * A, NB_A > 0. 08042 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 08043 * row of the matrix A is distributed, 08044 * NPROW > RSRC_A >= 0. 08045 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 08046 * first column of A is distributed. 08047 * NPCOL > CSRC_A >= 0. 08048 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 08049 * array storing the local blocks of 08050 * the distributed matrix A, 08051 * IF( Lc( 1, N_A ) > 0 ) 08052 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 08053 * ELSE 08054 * LLD_A >= 1. 08055 * 08056 * Let K be the number of rows of a matrix A starting at the global in- 08057 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 08058 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 08059 * receive if these K rows were distributed over NPROW processes. If K 08060 * is the number of columns of a matrix A starting at the global index 08061 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 08062 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 08063 * these K columns were distributed over NPCOL processes. 08064 * 08065 * The values of Lr() and Lc() may be determined via a call to the func- 08066 * tion PB_NUMROC: 08067 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 08068 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 08069 * 08070 * Arguments 08071 * ========= 08072 * 08073 * TYPE (global input) CHARACTER*1 08074 * On entry, TYPE specifies the type of the input submatrix as 08075 * follows: 08076 * = 'L' or 'l': sub( A ) is a lower triangular matrix, 08077 * = 'U' or 'u': sub( A ) is an upper triangular matrix, 08078 * = 'H' or 'h': sub( A ) is an upper Hessenberg matrix, 08079 * otherwise sub( A ) is a full matrix. 08080 * 08081 * M (global input) INTEGER 08082 * On entry, M specifies the number of rows of the submatrix 08083 * sub( A ). M must be at least zero. 08084 * 08085 * N (global input) INTEGER 08086 * On entry, N specifies the number of columns of the submatrix 08087 * sub( A ). N must be at least zero. 08088 * 08089 * ALPHA (global input) COMPLEX*16 08090 * On entry, ALPHA specifies the scalar alpha. 08091 * 08092 * A (local input/local output) COMPLEX*16 array 08093 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 08094 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 08095 * the local entries of the matrix A. 08096 * On exit, the local entries of this array corresponding to the 08097 * to the entries of the submatrix sub( A ) are overwritten by 08098 * the local entries of the m by n scaled submatrix. 08099 * 08100 * IA (global input) INTEGER 08101 * On entry, IA specifies A's global row index, which points to 08102 * the beginning of the submatrix sub( A ). 08103 * 08104 * JA (global input) INTEGER 08105 * On entry, JA specifies A's global column index, which points 08106 * to the beginning of the submatrix sub( A ). 08107 * 08108 * DESCA (global and local input) INTEGER array 08109 * On entry, DESCA is an integer array of dimension DLEN_. This 08110 * is the array descriptor for the matrix A. 08111 * 08112 * -- Written on April 1, 1998 by 08113 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 08114 * 08115 * ===================================================================== 08116 * 08117 * .. Parameters .. 08118 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 08119 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 08120 $ RSRC_ 08121 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 08122 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 08123 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 08124 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 08125 * .. 08126 * .. Local Scalars .. 08127 CHARACTER*1 UPLO 08128 LOGICAL GODOWN, GOLEFT, LOWER, UPPER 08129 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1, 08130 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE, 08131 $ IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00, 08132 $ LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS, 08133 $ MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB, 08134 $ NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, 08135 $ QNB, TMP1, UPP 08136 * .. 08137 * .. Local Arrays .. 08138 INTEGER DESCA2( DLEN_ ) 08139 * .. 08140 * .. External Subroutines .. 08141 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 08142 $ PB_DESCTRANS, PB_INFOG2L, PB_ZLASCAL 08143 * .. 08144 * .. External Functions .. 08145 LOGICAL LSAME 08146 INTEGER PB_NUMROC 08147 EXTERNAL LSAME, PB_NUMROC 08148 * .. 08149 * .. Intrinsic Functions .. 08150 INTRINSIC MIN 08151 * .. 08152 * .. Executable Statements .. 08153 * 08154 * Convert descriptor 08155 * 08156 CALL PB_DESCTRANS( DESCA, DESCA2 ) 08157 * 08158 * Get grid parameters 08159 * 08160 ICTXT = DESCA2( CTXT_ ) 08161 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 08162 * 08163 * Quick return if possible 08164 * 08165 IF( M.EQ.0 .OR. N.EQ.0 ) 08166 $ RETURN 08167 * 08168 IF( LSAME( TYPE, 'L' ) ) THEN 08169 ITYPE = 1 08170 UPLO = TYPE 08171 UPPER = .FALSE. 08172 LOWER = .TRUE. 08173 IOFFD = 0 08174 ELSE IF( LSAME( TYPE, 'U' ) ) THEN 08175 ITYPE = 2 08176 UPLO = TYPE 08177 UPPER = .TRUE. 08178 LOWER = .FALSE. 08179 IOFFD = 0 08180 ELSE IF( LSAME( TYPE, 'H' ) ) THEN 08181 ITYPE = 3 08182 UPLO = 'U' 08183 UPPER = .TRUE. 08184 LOWER = .FALSE. 08185 IOFFD = 1 08186 ELSE 08187 ITYPE = 0 08188 UPLO = 'A' 08189 UPPER = .TRUE. 08190 LOWER = .TRUE. 08191 IOFFD = 0 08192 END IF 08193 * 08194 * Compute local indexes 08195 * 08196 IF( ITYPE.EQ.0 ) THEN 08197 * 08198 * Full matrix 08199 * 08200 CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL, 08201 $ IIA, JJA, IAROW, IACOL ) 08202 MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW, 08203 $ DESCA2( RSRC_ ), NPROW ) 08204 NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL, 08205 $ DESCA2( CSRC_ ), NPCOL ) 08206 * 08207 IF( MP.LE.0 .OR. NQ.LE.0 ) 08208 $ RETURN 08209 * 08210 LDA = DESCA2( LLD_ ) 08211 IOFFA = IIA + ( JJA - 1 ) * LDA 08212 * 08213 CALL PB_ZLASCAL( 'All', MP, NQ, 0, ALPHA, A( IOFFA ), LDA ) 08214 * 08215 ELSE 08216 * 08217 * Trapezoidal matrix 08218 * 08219 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 08220 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW, 08221 $ IACOL, MRROW, MRCOL ) 08222 * 08223 IF( MP.LE.0 .OR. NQ.LE.0 ) 08224 $ RETURN 08225 * 08226 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 08227 * LNBLOC, ILOW, LOW, IUPP, and UPP. 08228 * 08229 MB = DESCA2( MB_ ) 08230 NB = DESCA2( NB_ ) 08231 LDA = DESCA2( LLD_ ) 08232 * 08233 CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW, 08234 $ MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, 08235 $ LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP ) 08236 * 08237 M1 = MP 08238 N1 = NQ 08239 IOFFA = IIA - 1 08240 JOFFA = JJA - 1 08241 IIMAX = IOFFA + MP 08242 JJMAX = JOFFA + NQ 08243 * 08244 IF( DESCA2( RSRC_ ).LT.0 ) THEN 08245 PMB = MB 08246 ELSE 08247 PMB = NPROW * MB 08248 END IF 08249 IF( DESCA2( CSRC_ ).LT.0 ) THEN 08250 QNB = NB 08251 ELSE 08252 QNB = NPCOL * NB 08253 END IF 08254 * 08255 * Handle the first block of rows or columns separately, and 08256 * update LCMT00, MBLKS and NBLKS. 08257 * 08258 GODOWN = ( LCMT00.GT.IUPP ) 08259 GOLEFT = ( LCMT00.LT.ILOW ) 08260 * 08261 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 08262 * 08263 * LCMT00 >= ILOW && LCMT00 <= IUPP 08264 * 08265 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 08266 GODOWN = .NOT.GOLEFT 08267 * 08268 CALL PB_ZLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, 08269 $ A( IIA+JOFFA*LDA ), LDA ) 08270 IF( GODOWN ) THEN 08271 IF( UPPER .AND. NQ.GT.INBLOC ) 08272 $ CALL PB_ZLASCAL( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA, 08273 $ A( IIA+(JOFFA+INBLOC)*LDA ), LDA ) 08274 IIA = IIA + IMBLOC 08275 M1 = M1 - IMBLOC 08276 ELSE 08277 IF( LOWER .AND. MP.GT.IMBLOC ) 08278 $ CALL PB_ZLASCAL( 'All', MP-IMBLOC, INBLOC, 0, ALPHA, 08279 $ A( IIA+IMBLOC+JOFFA*LDA ), LDA ) 08280 JJA = JJA + INBLOC 08281 N1 = N1 - INBLOC 08282 END IF 08283 * 08284 END IF 08285 * 08286 IF( GODOWN ) THEN 08287 * 08288 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 08289 MBLKS = MBLKS - 1 08290 IOFFA = IOFFA + IMBLOC 08291 * 08292 10 CONTINUE 08293 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 08294 LCMT00 = LCMT00 - PMB 08295 MBLKS = MBLKS - 1 08296 IOFFA = IOFFA + MB 08297 GO TO 10 08298 END IF 08299 * 08300 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 08301 IF( UPPER .AND. TMP1.GT.0 ) THEN 08302 CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA, 08303 $ A( IIA+JOFFA*LDA ), LDA ) 08304 IIA = IIA + TMP1 08305 M1 = M1 - TMP1 08306 END IF 08307 * 08308 IF( MBLKS.LE.0 ) 08309 $ RETURN 08310 * 08311 LCMT = LCMT00 08312 MBLKD = MBLKS 08313 IOFFD = IOFFA 08314 * 08315 MBLOC = MB 08316 20 CONTINUE 08317 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 08318 IF( MBLKD.EQ.1 ) 08319 $ MBLOC = LMBLOC 08320 CALL PB_ZLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA, 08321 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08322 LCMT00 = LCMT 08323 LCMT = LCMT - PMB 08324 MBLKS = MBLKD 08325 MBLKD = MBLKD - 1 08326 IOFFA = IOFFD 08327 IOFFD = IOFFD + MBLOC 08328 GO TO 20 08329 END IF 08330 * 08331 TMP1 = M1 - IOFFD + IIA - 1 08332 IF( LOWER .AND. TMP1.GT.0 ) 08333 $ CALL PB_ZLASCAL( 'All', TMP1, INBLOC, 0, ALPHA, 08334 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08335 * 08336 TMP1 = IOFFA - IIA + 1 08337 M1 = M1 - TMP1 08338 N1 = N1 - INBLOC 08339 LCMT00 = LCMT00 + LOW - ILOW + QNB 08340 NBLKS = NBLKS - 1 08341 JOFFA = JOFFA + INBLOC 08342 * 08343 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 08344 $ CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA, 08345 $ A( IIA+JOFFA*LDA ), LDA ) 08346 * 08347 IIA = IOFFA + 1 08348 JJA = JOFFA + 1 08349 * 08350 ELSE IF( GOLEFT ) THEN 08351 * 08352 LCMT00 = LCMT00 + LOW - ILOW + QNB 08353 NBLKS = NBLKS - 1 08354 JOFFA = JOFFA + INBLOC 08355 * 08356 30 CONTINUE 08357 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 08358 LCMT00 = LCMT00 + QNB 08359 NBLKS = NBLKS - 1 08360 JOFFA = JOFFA + NB 08361 GO TO 30 08362 END IF 08363 * 08364 TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1 08365 IF( LOWER .AND. TMP1.GT.0 ) THEN 08366 CALL PB_ZLASCAL( 'All', M1, TMP1, 0, ALPHA, 08367 $ A( IIA+(JJA-1)*LDA ), LDA ) 08368 JJA = JJA + TMP1 08369 N1 = N1 - TMP1 08370 END IF 08371 * 08372 IF( NBLKS.LE.0 ) 08373 $ RETURN 08374 * 08375 LCMT = LCMT00 08376 NBLKD = NBLKS 08377 JOFFD = JOFFA 08378 * 08379 NBLOC = NB 08380 40 CONTINUE 08381 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 08382 IF( NBLKD.EQ.1 ) 08383 $ NBLOC = LNBLOC 08384 CALL PB_ZLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, 08385 $ A( IIA+JOFFD*LDA ), LDA ) 08386 LCMT00 = LCMT 08387 LCMT = LCMT + QNB 08388 NBLKS = NBLKD 08389 NBLKD = NBLKD - 1 08390 JOFFA = JOFFD 08391 JOFFD = JOFFD + NBLOC 08392 GO TO 40 08393 END IF 08394 * 08395 TMP1 = N1 - JOFFD + JJA - 1 08396 IF( UPPER .AND. TMP1.GT.0 ) 08397 $ CALL PB_ZLASCAL( 'All', IMBLOC, TMP1, 0, ALPHA, 08398 $ A( IIA+JOFFD*LDA ), LDA ) 08399 * 08400 TMP1 = JOFFA - JJA + 1 08401 M1 = M1 - IMBLOC 08402 N1 = N1 - TMP1 08403 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 08404 MBLKS = MBLKS - 1 08405 IOFFA = IOFFA + IMBLOC 08406 * 08407 IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 ) 08408 $ CALL PB_ZLASCAL( 'All', M1, TMP1, 0, ALPHA, 08409 $ A( IOFFA+1+(JJA-1)*LDA ), LDA ) 08410 * 08411 IIA = IOFFA + 1 08412 JJA = JOFFA + 1 08413 * 08414 END IF 08415 * 08416 NBLOC = NB 08417 50 CONTINUE 08418 IF( NBLKS.GT.0 ) THEN 08419 IF( NBLKS.EQ.1 ) 08420 $ NBLOC = LNBLOC 08421 60 CONTINUE 08422 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 08423 LCMT00 = LCMT00 - PMB 08424 MBLKS = MBLKS - 1 08425 IOFFA = IOFFA + MB 08426 GO TO 60 08427 END IF 08428 * 08429 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 08430 IF( UPPER .AND. TMP1.GT.0 ) THEN 08431 CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA, 08432 $ A( IIA+JOFFA*LDA ), LDA ) 08433 IIA = IIA + TMP1 08434 M1 = M1 - TMP1 08435 END IF 08436 * 08437 IF( MBLKS.LE.0 ) 08438 $ RETURN 08439 * 08440 LCMT = LCMT00 08441 MBLKD = MBLKS 08442 IOFFD = IOFFA 08443 * 08444 MBLOC = MB 08445 70 CONTINUE 08446 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 08447 IF( MBLKD.EQ.1 ) 08448 $ MBLOC = LMBLOC 08449 CALL PB_ZLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA, 08450 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08451 LCMT00 = LCMT 08452 LCMT = LCMT - PMB 08453 MBLKS = MBLKD 08454 MBLKD = MBLKD - 1 08455 IOFFA = IOFFD 08456 IOFFD = IOFFD + MBLOC 08457 GO TO 70 08458 END IF 08459 * 08460 TMP1 = M1 - IOFFD + IIA - 1 08461 IF( LOWER .AND. TMP1.GT.0 ) 08462 $ CALL PB_ZLASCAL( 'All', TMP1, NBLOC, 0, ALPHA, 08463 $ A( IOFFD+1+JOFFA*LDA ), LDA ) 08464 * 08465 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1 08466 M1 = M1 - TMP1 08467 N1 = N1 - NBLOC 08468 LCMT00 = LCMT00 + QNB 08469 NBLKS = NBLKS - 1 08470 JOFFA = JOFFA + NBLOC 08471 * 08472 IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 ) 08473 $ CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA, 08474 $ A( IIA+JOFFA*LDA ), LDA ) 08475 * 08476 IIA = IOFFA + 1 08477 JJA = JOFFA + 1 08478 * 08479 GO TO 50 08480 * 08481 END IF 08482 * 08483 END IF 08484 * 08485 RETURN 08486 * 08487 * End of PZLASCAL 08488 * 08489 END 08490 SUBROUTINE PZLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, 08491 $ DESCA, IASEED, A, LDA ) 08492 * 08493 * -- PBLAS test routine (version 2.0) -- 08494 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 08495 * and University of California, Berkeley. 08496 * April 1, 1998 08497 * 08498 * .. Scalar Arguments .. 08499 LOGICAL INPLACE 08500 CHARACTER*1 AFORM, DIAG 08501 INTEGER IA, IASEED, JA, LDA, M, N, OFFA 08502 * .. 08503 * .. Array Arguments .. 08504 INTEGER DESCA( * ) 08505 COMPLEX*16 A( LDA, * ) 08506 * .. 08507 * 08508 * Purpose 08509 * ======= 08510 * 08511 * PZLAGEN generates (or regenerates) a submatrix sub( A ) denoting 08512 * A(IA:IA+M-1,JA:JA+N-1). 08513 * 08514 * Notes 08515 * ===== 08516 * 08517 * A description vector is associated with each 2D block-cyclicly dis- 08518 * tributed matrix. This vector stores the information required to 08519 * establish the mapping between a matrix entry and its corresponding 08520 * process and memory location. 08521 * 08522 * In the following comments, the character _ should be read as 08523 * "of the distributed matrix". Let A be a generic term for any 2D 08524 * block cyclicly distributed matrix. Its description vector is DESCA: 08525 * 08526 * NOTATION STORED IN EXPLANATION 08527 * ---------------- --------------- ------------------------------------ 08528 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 08529 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 08530 * the NPROW x NPCOL BLACS process grid 08531 * A is distributed over. The context 08532 * itself is global, but the handle 08533 * (the integer value) may vary. 08534 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 08535 * ted matrix A, M_A >= 0. 08536 * N_A (global) DESCA( N_ ) The number of columns in the distri- 08537 * buted matrix A, N_A >= 0. 08538 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 08539 * block of the matrix A, IMB_A > 0. 08540 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 08541 * left block of the matrix A, 08542 * INB_A > 0. 08543 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 08544 * bute the last M_A-IMB_A rows of A, 08545 * MB_A > 0. 08546 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 08547 * bute the last N_A-INB_A columns of 08548 * A, NB_A > 0. 08549 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 08550 * row of the matrix A is distributed, 08551 * NPROW > RSRC_A >= 0. 08552 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 08553 * first column of A is distributed. 08554 * NPCOL > CSRC_A >= 0. 08555 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 08556 * array storing the local blocks of 08557 * the distributed matrix A, 08558 * IF( Lc( 1, N_A ) > 0 ) 08559 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 08560 * ELSE 08561 * LLD_A >= 1. 08562 * 08563 * Let K be the number of rows of a matrix A starting at the global in- 08564 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 08565 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 08566 * receive if these K rows were distributed over NPROW processes. If K 08567 * is the number of columns of a matrix A starting at the global index 08568 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 08569 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 08570 * these K columns were distributed over NPCOL processes. 08571 * 08572 * The values of Lr() and Lc() may be determined via a call to the func- 08573 * tion PB_NUMROC: 08574 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 08575 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 08576 * 08577 * Arguments 08578 * ========= 08579 * 08580 * INPLACE (global input) LOGICAL 08581 * On entry, INPLACE specifies if the matrix should be generated 08582 * in place or not. If INPLACE is .TRUE., the local random array 08583 * to be generated will start in memory at the local memory lo- 08584 * cation A( 1, 1 ), otherwise it will start at the local posi- 08585 * tion induced by IA and JA. 08586 * 08587 * AFORM (global input) CHARACTER*1 08588 * On entry, AFORM specifies the type of submatrix to be genera- 08589 * ted as follows: 08590 * AFORM = 'S', sub( A ) is a symmetric matrix, 08591 * AFORM = 'H', sub( A ) is a Hermitian matrix, 08592 * AFORM = 'T', sub( A ) is overrwritten with the transpose 08593 * of what would normally be generated, 08594 * AFORM = 'C', sub( A ) is overwritten with the conjugate 08595 * transpose of what would normally be genera- 08596 * ted. 08597 * AFORM = 'N', a random submatrix is generated. 08598 * 08599 * DIAG (global input) CHARACTER*1 08600 * On entry, DIAG specifies if the generated submatrix is diago- 08601 * nally dominant or not as follows: 08602 * DIAG = 'D' : sub( A ) is diagonally dominant, 08603 * DIAG = 'N' : sub( A ) is not diagonally dominant. 08604 * 08605 * OFFA (global input) INTEGER 08606 * On entry, OFFA specifies the offdiagonal of the underlying 08607 * matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma- 08608 * trix is symmetric, Hermitian or diagonally dominant. OFFA = 0 08609 * specifies the main diagonal, OFFA > 0 specifies a subdiago- 08610 * nal, and OFFA < 0 specifies a superdiagonal (see further de- 08611 * tails). 08612 * 08613 * M (global input) INTEGER 08614 * On entry, M specifies the global number of matrix rows of the 08615 * submatrix sub( A ) to be generated. M must be at least zero. 08616 * 08617 * N (global input) INTEGER 08618 * On entry, N specifies the global number of matrix columns of 08619 * the submatrix sub( A ) to be generated. N must be at least 08620 * zero. 08621 * 08622 * IA (global input) INTEGER 08623 * On entry, IA specifies A's global row index, which points to 08624 * the beginning of the submatrix sub( A ). 08625 * 08626 * JA (global input) INTEGER 08627 * On entry, JA specifies A's global column index, which points 08628 * to the beginning of the submatrix sub( A ). 08629 * 08630 * DESCA (global and local input) INTEGER array 08631 * On entry, DESCA is an integer array of dimension DLEN_. This 08632 * is the array descriptor for the matrix A. 08633 * 08634 * IASEED (global input) INTEGER 08635 * On entry, IASEED specifies the seed number to generate the 08636 * matrix A. IASEED must be at least zero. 08637 * 08638 * A (local output) COMPLEX*16 array 08639 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 08640 * at least Lc( 1, JA+N-1 ). On exit, this array contains the 08641 * local entries of the randomly generated submatrix sub( A ). 08642 * 08643 * LDA (local input) INTEGER 08644 * On entry, LDA specifies the local leading dimension of the 08645 * array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_). 08646 * This restriction is however not enforced, and this subroutine 08647 * requires only that LDA >= MAX( 1, Mp ) where 08648 * 08649 * Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ). 08650 * 08651 * PB_NUMROC is a ScaLAPACK tool function; MYROW, MYCOL, NPROW 08652 * and NPCOL can be determined by calling the BLACS subroutine 08653 * BLACS_GRIDINFO. 08654 * 08655 * Further Details 08656 * =============== 08657 * 08658 * OFFD is tied to the matrix described by DESCA, as opposed to the 08659 * piece that is currently (re)generated. This is a global information 08660 * independent from the distribution parameters. Below are examples of 08661 * the meaning of OFFD for a global 7 by 5 matrix: 08662 * 08663 * --------------------------------------------------------------------- 08664 * OFFD | 0 -1 -2 -3 -4 0 -1 -2 -3 -4 0 -1 -2 -3 -4 08665 * -------|------------------------------------------------------------- 08666 * | | OFFD=-1 | OFFD=0 OFFD=2 08667 * | V V 08668 * 0 | . d . . . -> d . . . . . . . . . 08669 * 1 | . . d . . . d . . . . . . . . 08670 * 2 | . . . d . . . d . . -> d . . . . 08671 * 3 | . . . . d . . . d . . d . . . 08672 * 4 | . . . . . . . . . d . . d . . 08673 * 5 | . . . . . . . . . . . . . d . 08674 * 6 | . . . . . . . . . . . . . . d 08675 * --------------------------------------------------------------------- 08676 * 08677 * -- Written on April 1, 1998 by 08678 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 08679 * 08680 * ===================================================================== 08681 * 08682 * .. Parameters .. 08683 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 08684 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 08685 $ RSRC_ 08686 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 08687 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 08688 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 08689 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 08690 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN, 08691 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB, 08692 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW 08693 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3, 08694 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6, 08695 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9, 08696 $ JMP_NQNB = 10, JMP_NQINBLOC = 11, 08697 $ JMP_LEN = 11 ) 08698 DOUBLE PRECISION ZERO 08699 PARAMETER ( ZERO = 0.0D+0 ) 08700 * .. 08701 * .. Local Scalars .. 08702 LOGICAL DIAGDO, SYMM, HERM, NOTRAN 08703 INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK, 08704 $ ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB, 08705 $ INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP, 08706 $ IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00, 08707 $ LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP, 08708 $ MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW, 08709 $ NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP 08710 COMPLEX*16 ALPHA 08711 * .. 08712 * .. Local Arrays .. 08713 INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ), 08714 $ IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 ) 08715 * .. 08716 * .. External Subroutines .. 08717 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 08718 $ PB_CHKMAT, PB_DESCTRANS, PB_INITJMP, 08719 $ PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO, 08720 $ PB_SETLOCRAN, PB_SETRAN, PB_ZLAGEN, PXERBLA, 08721 $ PZLADOM 08722 * .. 08723 * .. External Functions .. 08724 LOGICAL LSAME 08725 EXTERNAL LSAME 08726 * .. 08727 * .. Intrinsic Functions .. 08728 INTRINSIC DBLE, DCMPLX, MAX, MIN 08729 * .. 08730 * .. Data Statements .. 08731 DATA ( MULADD0( I ), I = 1, 4 ) / 20077, 16838, 08732 $ 12345, 0 / 08733 * .. 08734 * .. Executable Statements .. 08735 * 08736 * Convert descriptor 08737 * 08738 CALL PB_DESCTRANS( DESCA, DESCA2 ) 08739 * 08740 * Test the input arguments 08741 * 08742 ICTXT = DESCA2( CTXT_ ) 08743 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 08744 * 08745 * Test the input parameters 08746 * 08747 INFO = 0 08748 IF( NPROW.EQ.-1 ) THEN 08749 INFO = -( 1000 + CTXT_ ) 08750 ELSE 08751 SYMM = LSAME( AFORM, 'S' ) 08752 HERM = LSAME( AFORM, 'H' ) 08753 NOTRAN = LSAME( AFORM, 'N' ) 08754 DIAGDO = LSAME( DIAG, 'D' ) 08755 IF( .NOT.( SYMM.OR.HERM.OR.NOTRAN ) .AND. 08756 $ .NOT.( LSAME( AFORM, 'T' ) ) .AND. 08757 $ .NOT.( LSAME( AFORM, 'C' ) ) ) THEN 08758 INFO = -2 08759 ELSE IF( ( .NOT.DIAGDO ) .AND. 08760 $ ( .NOT.LSAME( DIAG, 'N' ) ) ) THEN 08761 INFO = -3 08762 END IF 08763 CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO ) 08764 END IF 08765 * 08766 IF( INFO.NE.0 ) THEN 08767 CALL PXERBLA( ICTXT, 'PZLAGEN', -INFO ) 08768 RETURN 08769 END IF 08770 * 08771 * Quick return if possible 08772 * 08773 IF( ( M.LE.0 ).OR.( N.LE.0 ) ) 08774 $ RETURN 08775 * 08776 * Start the operations 08777 * 08778 MB = DESCA2( MB_ ) 08779 NB = DESCA2( NB_ ) 08780 IMB = DESCA2( IMB_ ) 08781 INB = DESCA2( INB_ ) 08782 RSRC = DESCA2( RSRC_ ) 08783 CSRC = DESCA2( CSRC_ ) 08784 * 08785 * Figure out local information about the distributed matrix operand 08786 * 08787 CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 08788 $ MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW, 08789 $ IACOL, MRROW, MRCOL ) 08790 * 08791 * Decide where the entries shall be stored in memory 08792 * 08793 IF( INPLACE ) THEN 08794 IIA = 1 08795 JJA = 1 08796 END IF 08797 * 08798 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 08799 * ILOW, LOW, IUPP, and UPP. 08800 * 08801 IOFFDA = JA + OFFA - IA 08802 CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW, 08803 $ MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, 08804 $ LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP ) 08805 * 08806 * Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST 08807 * This values correspond to the square virtual underlying matrix 08808 * of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used 08809 * to set up the random sequence. For practical purposes, the size 08810 * of this virtual matrix is upper bounded by M_ + N_ - 1. 08811 * 08812 ITMP = MAX( 0, -OFFA ) 08813 IVIR = IA + ITMP 08814 IMBVIR = IMB + ITMP 08815 NVIR = DESCA2( M_ ) + ITMP 08816 * 08817 CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK, 08818 $ ILOCOFF, MYRDIST ) 08819 * 08820 ITMP = MAX( 0, OFFA ) 08821 JVIR = JA + ITMP 08822 INBVIR = INB + ITMP 08823 NVIR = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ), 08824 $ DESCA2( M_ ) + DESCA2( N_ ) - 1 ) 08825 * 08826 CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK, 08827 $ JLOCOFF, MYCDIST ) 08828 * 08829 IF( SYMM .OR. HERM .OR. NOTRAN ) THEN 08830 * 08831 CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC, 08832 $ MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP ) 08833 * 08834 * Compute constants to jump JMP( * ) numbers in the sequence 08835 * 08836 CALL PB_INITMULADD( MULADD0, JMP, IMULADD ) 08837 * 08838 * Compute and set the random value corresponding to A( IA, JA ) 08839 * 08840 CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF, 08841 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP, 08842 $ IMULADD, IRAN ) 08843 * 08844 CALL PB_ZLAGEN( 'Lower', AFORM, A( IIA, JJA ), LDA, LCMT00, 08845 $ IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC, 08846 $ NB, LNBLOC, JMP, IMULADD ) 08847 * 08848 END IF 08849 * 08850 IF( SYMM .OR. HERM .OR. ( .NOT. NOTRAN ) ) THEN 08851 * 08852 CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC, 08853 $ MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP ) 08854 * 08855 * Compute constants to jump JMP( * ) numbers in the sequence 08856 * 08857 CALL PB_INITMULADD( MULADD0, JMP, IMULADD ) 08858 * 08859 * Compute and set the random value corresponding to A( IA, JA ) 08860 * 08861 CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF, 08862 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP, 08863 $ IMULADD, IRAN ) 08864 * 08865 CALL PB_ZLAGEN( 'Upper', AFORM, A( IIA, JJA ), LDA, LCMT00, 08866 $ IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC, 08867 $ NB, LNBLOC, JMP, IMULADD ) 08868 * 08869 END IF 08870 * 08871 IF( DIAGDO ) THEN 08872 * 08873 MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) ) 08874 IF( HERM ) THEN 08875 ALPHA = DCMPLX( DBLE( 2 * MAXMN ), ZERO ) 08876 ELSE 08877 ALPHA = DCMPLX( DBLE( NVIR ), DBLE( MAXMN ) ) 08878 END IF 08879 * 08880 IF( IOFFDA.GE.0 ) THEN 08881 CALL PZLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA, 08882 $ A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA ) 08883 ELSE 08884 CALL PZLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA, 08885 $ A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA ) 08886 END IF 08887 * 08888 END IF 08889 * 08890 RETURN 08891 * 08892 * End of PZLAGEN 08893 * 08894 END 08895 SUBROUTINE PZLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA ) 08896 * 08897 * -- PBLAS test routine (version 2.0) -- 08898 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 08899 * and University of California, Berkeley. 08900 * April 1, 1998 08901 * 08902 * .. Scalar Arguments .. 08903 LOGICAL INPLACE 08904 INTEGER IA, JA, N 08905 COMPLEX*16 ALPHA 08906 * .. 08907 * .. Array Arguments .. 08908 INTEGER DESCA( * ) 08909 COMPLEX*16 A( * ) 08910 * .. 08911 * 08912 * Purpose 08913 * ======= 08914 * 08915 * PZLADOM adds alpha to the diagonal entries of an n by n submatrix 08916 * sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ). 08917 * 08918 * Notes 08919 * ===== 08920 * 08921 * A description vector is associated with each 2D block-cyclicly dis- 08922 * tributed matrix. This vector stores the information required to 08923 * establish the mapping between a matrix entry and its corresponding 08924 * process and memory location. 08925 * 08926 * In the following comments, the character _ should be read as 08927 * "of the distributed matrix". Let A be a generic term for any 2D 08928 * block cyclicly distributed matrix. Its description vector is DESCA: 08929 * 08930 * NOTATION STORED IN EXPLANATION 08931 * ---------------- --------------- ------------------------------------ 08932 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 08933 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 08934 * the NPROW x NPCOL BLACS process grid 08935 * A is distributed over. The context 08936 * itself is global, but the handle 08937 * (the integer value) may vary. 08938 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 08939 * ted matrix A, M_A >= 0. 08940 * N_A (global) DESCA( N_ ) The number of columns in the distri- 08941 * buted matrix A, N_A >= 0. 08942 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 08943 * block of the matrix A, IMB_A > 0. 08944 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 08945 * left block of the matrix A, 08946 * INB_A > 0. 08947 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 08948 * bute the last M_A-IMB_A rows of A, 08949 * MB_A > 0. 08950 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 08951 * bute the last N_A-INB_A columns of 08952 * A, NB_A > 0. 08953 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 08954 * row of the matrix A is distributed, 08955 * NPROW > RSRC_A >= 0. 08956 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 08957 * first column of A is distributed. 08958 * NPCOL > CSRC_A >= 0. 08959 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 08960 * array storing the local blocks of 08961 * the distributed matrix A, 08962 * IF( Lc( 1, N_A ) > 0 ) 08963 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 08964 * ELSE 08965 * LLD_A >= 1. 08966 * 08967 * Let K be the number of rows of a matrix A starting at the global in- 08968 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 08969 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 08970 * receive if these K rows were distributed over NPROW processes. If K 08971 * is the number of columns of a matrix A starting at the global index 08972 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 08973 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 08974 * these K columns were distributed over NPCOL processes. 08975 * 08976 * The values of Lr() and Lc() may be determined via a call to the func- 08977 * tion PB_NUMROC: 08978 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 08979 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 08980 * 08981 * Arguments 08982 * ========= 08983 * 08984 * INPLACE (global input) LOGICAL 08985 * On entry, INPLACE specifies if the matrix should be generated 08986 * in place or not. If INPLACE is .TRUE., the local random array 08987 * to be generated will start in memory at the local memory lo- 08988 * cation A( 1, 1 ), otherwise it will start at the local posi- 08989 * tion induced by IA and JA. 08990 * 08991 * N (global input) INTEGER 08992 * On entry, N specifies the global order of the submatrix 08993 * sub( A ) to be modified. N must be at least zero. 08994 * 08995 * ALPHA (global input) COMPLEX*16 08996 * On entry, ALPHA specifies the scalar alpha. 08997 * 08998 * A (local input/local output) COMPLEX*16 array 08999 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 09000 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 09001 * the local entries of the matrix A. On exit, the local entries 09002 * of this array corresponding to the main diagonal of sub( A ) 09003 * have been updated. 09004 * 09005 * IA (global input) INTEGER 09006 * On entry, IA specifies A's global row index, which points to 09007 * the beginning of the submatrix sub( A ). 09008 * 09009 * JA (global input) INTEGER 09010 * On entry, JA specifies A's global column index, which points 09011 * to the beginning of the submatrix sub( A ). 09012 * 09013 * DESCA (global and local input) INTEGER array 09014 * On entry, DESCA is an integer array of dimension DLEN_. This 09015 * is the array descriptor for the matrix A. 09016 * 09017 * -- Written on April 1, 1998 by 09018 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 09019 * 09020 * ===================================================================== 09021 * 09022 * .. Parameters .. 09023 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 09024 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 09025 $ RSRC_ 09026 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 09027 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 09028 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 09029 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 09030 * .. 09031 * .. Local Scalars .. 09032 LOGICAL GODOWN, GOLEFT 09033 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW, 09034 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, 09035 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1, 09036 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC, 09037 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS, 09038 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP 09039 COMPLEX*16 ATMP 09040 * .. 09041 * .. Local Scalars .. 09042 INTEGER DESCA2( DLEN_ ) 09043 * .. 09044 * .. External Subroutines .. 09045 EXTERNAL BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO, 09046 $ PB_DESCTRANS 09047 * .. 09048 * .. Intrinsic Functions .. 09049 INTRINSIC ABS, DBLE, DCMPLX, DIMAG, MAX, MIN 09050 * .. 09051 * .. Executable Statements .. 09052 * 09053 * Convert descriptor 09054 * 09055 CALL PB_DESCTRANS( DESCA, DESCA2 ) 09056 * 09057 * Get grid parameters 09058 * 09059 ICTXT = DESCA2( CTXT_ ) 09060 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 09061 * 09062 IF( N.EQ.0 ) 09063 $ RETURN 09064 * 09065 CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW, 09066 $ MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW, 09067 $ IACOL, MRROW, MRCOL ) 09068 * 09069 * Decide where the entries shall be stored in memory 09070 * 09071 IF( INPLACE ) THEN 09072 IIA = 1 09073 JJA = 1 09074 END IF 09075 * 09076 * Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC, 09077 * ILOW, LOW, IUPP, and UPP. 09078 * 09079 MB = DESCA2( MB_ ) 09080 NB = DESCA2( NB_ ) 09081 * 09082 CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL, 09083 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 09084 $ LNBLOC, ILOW, LOW, IUPP, UPP ) 09085 * 09086 IOFFA = IIA - 1 09087 JOFFA = JJA - 1 09088 LDA = DESCA2( LLD_ ) 09089 LDAP1 = LDA + 1 09090 * 09091 IF( DESCA2( RSRC_ ).LT.0 ) THEN 09092 PMB = MB 09093 ELSE 09094 PMB = NPROW * MB 09095 END IF 09096 IF( DESCA2( CSRC_ ).LT.0 ) THEN 09097 QNB = NB 09098 ELSE 09099 QNB = NPCOL * NB 09100 END IF 09101 * 09102 * Handle the first block of rows or columns separately, and update 09103 * LCMT00, MBLKS and NBLKS. 09104 * 09105 GODOWN = ( LCMT00.GT.IUPP ) 09106 GOLEFT = ( LCMT00.LT.ILOW ) 09107 * 09108 IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN 09109 * 09110 * LCMT00 >= ILOW && LCMT00 <= IUPP 09111 * 09112 IF( LCMT00.GE.0 ) THEN 09113 IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA 09114 DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) ) 09115 ATMP = A( IJOFFA + I*LDAP1 ) 09116 A( IJOFFA + I*LDAP1 ) = ALPHA + 09117 $ DCMPLX( ABS( DBLE( ATMP ) ), 09118 $ ABS( DIMAG( ATMP ) ) ) 09119 10 CONTINUE 09120 ELSE 09121 IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA 09122 DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) ) 09123 ATMP = A( IJOFFA + I*LDAP1 ) 09124 A( IJOFFA + I*LDAP1 ) = ALPHA + 09125 $ DCMPLX( ABS( DBLE( ATMP ) ), 09126 $ ABS( DIMAG( ATMP ) ) ) 09127 20 CONTINUE 09128 END IF 09129 GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW ) 09130 GODOWN = .NOT.GOLEFT 09131 * 09132 END IF 09133 * 09134 IF( GODOWN ) THEN 09135 * 09136 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 09137 MBLKS = MBLKS - 1 09138 IOFFA = IOFFA + IMBLOC 09139 * 09140 30 CONTINUE 09141 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 09142 LCMT00 = LCMT00 - PMB 09143 MBLKS = MBLKS - 1 09144 IOFFA = IOFFA + MB 09145 GO TO 30 09146 END IF 09147 * 09148 LCMT = LCMT00 09149 MBLKD = MBLKS 09150 IOFFD = IOFFA 09151 * 09152 MBLOC = MB 09153 40 CONTINUE 09154 IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN 09155 IF( MBLKD.EQ.1 ) 09156 $ MBLOC = LMBLOC 09157 IF( LCMT.GE.0 ) THEN 09158 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 09159 DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) ) 09160 ATMP = A( IJOFFA + I*LDAP1 ) 09161 A( IJOFFA + I*LDAP1 ) = ALPHA + 09162 $ DCMPLX( ABS( DBLE( ATMP ) ), 09163 $ ABS( DIMAG( ATMP ) ) ) 09164 50 CONTINUE 09165 ELSE 09166 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 09167 DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) ) 09168 ATMP = A( IJOFFA + I*LDAP1 ) 09169 A( IJOFFA + I*LDAP1 ) = ALPHA + 09170 $ DCMPLX( ABS( DBLE( ATMP ) ), 09171 $ ABS( DIMAG( ATMP ) ) ) 09172 60 CONTINUE 09173 END IF 09174 LCMT00 = LCMT 09175 LCMT = LCMT - PMB 09176 MBLKS = MBLKD 09177 MBLKD = MBLKD - 1 09178 IOFFA = IOFFD 09179 IOFFD = IOFFD + MBLOC 09180 GO TO 40 09181 END IF 09182 * 09183 LCMT00 = LCMT00 + LOW - ILOW + QNB 09184 NBLKS = NBLKS - 1 09185 JOFFA = JOFFA + INBLOC 09186 * 09187 ELSE IF( GOLEFT ) THEN 09188 * 09189 LCMT00 = LCMT00 + LOW - ILOW + QNB 09190 NBLKS = NBLKS - 1 09191 JOFFA = JOFFA + INBLOC 09192 * 09193 70 CONTINUE 09194 IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN 09195 LCMT00 = LCMT00 + QNB 09196 NBLKS = NBLKS - 1 09197 JOFFA = JOFFA + NB 09198 GO TO 70 09199 END IF 09200 * 09201 LCMT = LCMT00 09202 NBLKD = NBLKS 09203 JOFFD = JOFFA 09204 * 09205 NBLOC = NB 09206 80 CONTINUE 09207 IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN 09208 IF( NBLKD.EQ.1 ) 09209 $ NBLOC = LNBLOC 09210 IF( LCMT.GE.0 ) THEN 09211 IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA 09212 DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) ) 09213 ATMP = A( IJOFFA + I*LDAP1 ) 09214 A( IJOFFA + I*LDAP1 ) = ALPHA + 09215 $ DCMPLX( ABS( DBLE( ATMP ) ), 09216 $ ABS( DIMAG( ATMP ) ) ) 09217 90 CONTINUE 09218 ELSE 09219 IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA 09220 DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) ) 09221 ATMP = A( IJOFFA + I*LDAP1 ) 09222 A( IJOFFA + I*LDAP1 ) = ALPHA + 09223 $ DCMPLX( ABS( DBLE( ATMP ) ), 09224 $ ABS( DIMAG( ATMP ) ) ) 09225 100 CONTINUE 09226 END IF 09227 LCMT00 = LCMT 09228 LCMT = LCMT + QNB 09229 NBLKS = NBLKD 09230 NBLKD = NBLKD - 1 09231 JOFFA = JOFFD 09232 JOFFD = JOFFD + NBLOC 09233 GO TO 80 09234 END IF 09235 * 09236 LCMT00 = LCMT00 - ( IUPP - UPP + PMB ) 09237 MBLKS = MBLKS - 1 09238 IOFFA = IOFFA + IMBLOC 09239 * 09240 END IF 09241 * 09242 NBLOC = NB 09243 110 CONTINUE 09244 IF( NBLKS.GT.0 ) THEN 09245 IF( NBLKS.EQ.1 ) 09246 $ NBLOC = LNBLOC 09247 120 CONTINUE 09248 IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN 09249 LCMT00 = LCMT00 - PMB 09250 MBLKS = MBLKS - 1 09251 IOFFA = IOFFA + MB 09252 GO TO 120 09253 END IF 09254 * 09255 LCMT = LCMT00 09256 MBLKD = MBLKS 09257 IOFFD = IOFFA 09258 * 09259 MBLOC = MB 09260 130 CONTINUE 09261 IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN 09262 IF( MBLKD.EQ.1 ) 09263 $ MBLOC = LMBLOC 09264 IF( LCMT.GE.0 ) THEN 09265 IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA 09266 DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) ) 09267 ATMP = A( IJOFFA + I*LDAP1 ) 09268 A( IJOFFA + I*LDAP1 ) = ALPHA + 09269 $ DCMPLX( ABS( DBLE( ATMP ) ), 09270 $ ABS( DIMAG( ATMP ) ) ) 09271 140 CONTINUE 09272 ELSE 09273 IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA 09274 DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) ) 09275 ATMP = A( IJOFFA + I*LDAP1 ) 09276 A( IJOFFA + I*LDAP1 ) = ALPHA + 09277 $ DCMPLX( ABS( DBLE( ATMP ) ), 09278 $ ABS( DIMAG( ATMP ) ) ) 09279 150 CONTINUE 09280 END IF 09281 LCMT00 = LCMT 09282 LCMT = LCMT - PMB 09283 MBLKS = MBLKD 09284 MBLKD = MBLKD - 1 09285 IOFFA = IOFFD 09286 IOFFD = IOFFD + MBLOC 09287 GO TO 130 09288 END IF 09289 * 09290 LCMT00 = LCMT00 + QNB 09291 NBLKS = NBLKS - 1 09292 JOFFA = JOFFA + NBLOC 09293 GO TO 110 09294 * 09295 END IF 09296 * 09297 RETURN 09298 * 09299 * End of PZLADOM 09300 * 09301 END 09302 SUBROUTINE PB_PZLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, 09303 $ CMATNM, NOUT, WORK ) 09304 * 09305 * -- PBLAS test routine (version 2.0) -- 09306 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09307 * and University of California, Berkeley. 09308 * April 1, 1998 09309 * 09310 * .. Scalar Arguments .. 09311 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT 09312 * .. 09313 * .. Array Arguments .. 09314 CHARACTER*(*) CMATNM 09315 INTEGER DESCA( * ) 09316 COMPLEX*16 A( * ), WORK( * ) 09317 * .. 09318 * 09319 * Purpose 09320 * ======= 09321 * 09322 * PB_PZLAPRNT prints to the standard output a submatrix sub( A ) deno- 09323 * ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by 09324 * the process of coordinates (IRPRNT, ICPRNT). 09325 * 09326 * Notes 09327 * ===== 09328 * 09329 * A description vector is associated with each 2D block-cyclicly dis- 09330 * tributed matrix. This vector stores the information required to 09331 * establish the mapping between a matrix entry and its corresponding 09332 * process and memory location. 09333 * 09334 * In the following comments, the character _ should be read as 09335 * "of the distributed matrix". Let A be a generic term for any 2D 09336 * block cyclicly distributed matrix. Its description vector is DESCA: 09337 * 09338 * NOTATION STORED IN EXPLANATION 09339 * ---------------- --------------- ------------------------------------ 09340 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 09341 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 09342 * the NPROW x NPCOL BLACS process grid 09343 * A is distributed over. The context 09344 * itself is global, but the handle 09345 * (the integer value) may vary. 09346 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 09347 * ted matrix A, M_A >= 0. 09348 * N_A (global) DESCA( N_ ) The number of columns in the distri- 09349 * buted matrix A, N_A >= 0. 09350 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 09351 * block of the matrix A, IMB_A > 0. 09352 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 09353 * left block of the matrix A, 09354 * INB_A > 0. 09355 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 09356 * bute the last M_A-IMB_A rows of A, 09357 * MB_A > 0. 09358 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 09359 * bute the last N_A-INB_A columns of 09360 * A, NB_A > 0. 09361 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 09362 * row of the matrix A is distributed, 09363 * NPROW > RSRC_A >= 0. 09364 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 09365 * first column of A is distributed. 09366 * NPCOL > CSRC_A >= 0. 09367 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 09368 * array storing the local blocks of 09369 * the distributed matrix A, 09370 * IF( Lc( 1, N_A ) > 0 ) 09371 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 09372 * ELSE 09373 * LLD_A >= 1. 09374 * 09375 * Let K be the number of rows of a matrix A starting at the global in- 09376 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 09377 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 09378 * receive if these K rows were distributed over NPROW processes. If K 09379 * is the number of columns of a matrix A starting at the global index 09380 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 09381 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 09382 * these K columns were distributed over NPCOL processes. 09383 * 09384 * The values of Lr() and Lc() may be determined via a call to the func- 09385 * tion PB_NUMROC: 09386 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 09387 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 09388 * 09389 * Arguments 09390 * ========= 09391 * 09392 * M (global input) INTEGER 09393 * On entry, M specifies the number of rows of the submatrix 09394 * sub( A ). M must be at least zero. 09395 * 09396 * N (global input) INTEGER 09397 * On entry, N specifies the number of columns of the submatrix 09398 * sub( A ). N must be at least zero. 09399 * 09400 * A (local input) COMPLEX*16 array 09401 * On entry, A is an array of dimension (LLD_A, Ka), where Ka is 09402 * at least Lc( 1, JA+N-1 ). Before entry, this array contains 09403 * the local entries of the matrix A. 09404 * 09405 * IA (global input) INTEGER 09406 * On entry, IA specifies A's global row index, which points to 09407 * the beginning of the submatrix sub( A ). 09408 * 09409 * JA (global input) INTEGER 09410 * On entry, JA specifies A's global column index, which points 09411 * to the beginning of the submatrix sub( A ). 09412 * 09413 * DESCA (global and local input) INTEGER array 09414 * On entry, DESCA is an integer array of dimension DLEN_. This 09415 * is the array descriptor for the matrix A. 09416 * 09417 * IRPRNT (global input) INTEGER 09418 * On entry, IRPRNT specifies the row index of the printing pro- 09419 * cess. 09420 * 09421 * ICPRNT (global input) INTEGER 09422 * On entry, ICPRNT specifies the column index of the printing 09423 * process. 09424 * 09425 * CMATNM (global input) CHARACTER*(*) 09426 * On entry, CMATNM is the name of the matrix to be printed. 09427 * 09428 * NOUT (global input) INTEGER 09429 * On entry, NOUT specifies the output unit number. When NOUT is 09430 * equal to 6, the submatrix is printed on the screen. 09431 * 09432 * WORK (local workspace) COMPLEX*16 array 09433 * On entry, WORK is a work array of dimension at least equal to 09434 * MAX( IMB_A, MB_A ). 09435 * 09436 * -- Written on April 1, 1998 by 09437 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 09438 * 09439 * ===================================================================== 09440 * 09441 * .. Parameters .. 09442 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 09443 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 09444 $ RSRC_ 09445 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 09446 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 09447 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 09448 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 09449 * .. 09450 * .. Local Scalars .. 09451 INTEGER MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW 09452 * .. 09453 * .. Local Arrays .. 09454 INTEGER DESCA2( DLEN_ ) 09455 * .. 09456 * .. External Subroutines .. 09457 EXTERNAL BLACS_GRIDINFO, PB_DESCTRANS, PB_PZLAPRN2 09458 * .. 09459 * .. Executable Statements .. 09460 * 09461 * Quick return if possible 09462 * 09463 IF( ( M.LE.0 ).OR.( N.LE.0 ) ) 09464 $ RETURN 09465 * 09466 * Convert descriptor 09467 * 09468 CALL PB_DESCTRANS( DESCA, DESCA2 ) 09469 * 09470 CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL ) 09471 * 09472 IF( DESCA2( RSRC_ ).GE.0 ) THEN 09473 IF( DESCA2( CSRC_ ).GE.0 ) THEN 09474 CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT, 09475 $ CMATNM, NOUT, DESCA2( RSRC_ ), 09476 $ DESCA2( CSRC_ ), WORK ) 09477 ELSE 09478 DO 10 PCOL = 0, NPCOL - 1 09479 IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) ) 09480 $ WRITE( NOUT, * ) 'Colum-replicated array -- ' , 09481 $ 'copy in process column: ', PCOL 09482 CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, 09483 $ ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ), 09484 $ PCOL, WORK ) 09485 10 CONTINUE 09486 END IF 09487 ELSE 09488 IF( DESCA2( CSRC_ ).GE.0 ) THEN 09489 DO 20 PROW = 0, NPROW - 1 09490 IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) ) 09491 $ WRITE( NOUT, * ) 'Row-replicated array -- ' , 09492 $ 'copy in process row: ', PROW 09493 CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, 09494 $ ICPRNT, CMATNM, NOUT, PROW, 09495 $ DESCA2( CSRC_ ), WORK ) 09496 20 CONTINUE 09497 ELSE 09498 DO 40 PROW = 0, NPROW - 1 09499 DO 30 PCOL = 0, NPCOL - 1 09500 IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) ) 09501 $ WRITE( NOUT, * ) 'Replicated array -- ' , 09502 $ 'copy in process (', PROW, ',', PCOL, ')' 09503 CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, 09504 $ ICPRNT, CMATNM, NOUT, PROW, PCOL, 09505 $ WORK ) 09506 30 CONTINUE 09507 40 CONTINUE 09508 END IF 09509 END IF 09510 * 09511 RETURN 09512 * 09513 * End of PB_PZLAPRNT 09514 * 09515 END 09516 SUBROUTINE PB_PZLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, 09517 $ CMATNM, NOUT, PROW, PCOL, WORK ) 09518 * 09519 * -- PBLAS test routine (version 2.0) -- 09520 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09521 * and University of California, Berkeley. 09522 * April 1, 1998 09523 * 09524 * .. Scalar Arguments .. 09525 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW 09526 * .. 09527 * .. Array Arguments .. 09528 CHARACTER*(*) CMATNM 09529 INTEGER DESCA( * ) 09530 COMPLEX*16 A( * ), WORK( * ) 09531 * .. 09532 * 09533 * .. Parameters .. 09534 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 09535 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 09536 $ RSRC_ 09537 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 09538 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 09539 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 09540 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 09541 * .. 09542 * .. Local Scalars .. 09543 LOGICAL AISCOLREP, AISROWREP 09544 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL, 09545 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K, 09546 $ LDA, LDW, MYCOL, MYROW, NPCOL, NPROW 09547 * .. 09548 * .. External Subroutines .. 09549 EXTERNAL BLACS_BARRIER, BLACS_GRIDINFO, PB_INFOG2L, 09550 $ ZGERV2D, ZGESD2D 09551 * .. 09552 * .. Intrinsic Functions .. 09553 INTRINSIC DBLE, DIMAG, MIN 09554 * .. 09555 * .. Executable Statements .. 09556 * 09557 * Get grid parameters 09558 * 09559 ICTXT = DESCA( CTXT_ ) 09560 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 09561 CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, 09562 $ IIA, JJA, IAROW, IACOL ) 09563 II = IIA 09564 JJ = JJA 09565 IF( DESCA( RSRC_ ).LT.0 ) THEN 09566 AISROWREP = .TRUE. 09567 IAROW = PROW 09568 ICURROW = PROW 09569 ELSE 09570 AISROWREP = .FALSE. 09571 ICURROW = IAROW 09572 END IF 09573 IF( DESCA( CSRC_ ).LT.0 ) THEN 09574 AISCOLREP = .TRUE. 09575 IACOL = PCOL 09576 ICURCOL = PCOL 09577 ELSE 09578 AISCOLREP = .FALSE. 09579 ICURCOL = IACOL 09580 END IF 09581 LDA = DESCA( LLD_ ) 09582 LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) ) 09583 * 09584 * Handle the first block of column separately 09585 * 09586 JB = DESCA( INB_ ) - JA + 1 09587 IF( JB.LE.0 ) 09588 $ JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB 09589 JB = MIN( JB, N ) 09590 JN = JA+JB-1 09591 DO 60 H = 0, JB-1 09592 IB = DESCA( IMB_ ) - IA + 1 09593 IF( IB.LE.0 ) 09594 $ IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB 09595 IB = MIN( IB, M ) 09596 IN = IA+IB-1 09597 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09598 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09599 DO 10 K = 0, IB-1 09600 WRITE( NOUT, FMT = 9999 ) 09601 $ CMATNM, IA+K, JA+H, 09602 $ DBLE( A( II+K+(JJ+H-1)*LDA ) ), 09603 $ DIMAG( A( II+K+(JJ+H-1)*LDA ) ) 09604 10 CONTINUE 09605 END IF 09606 ELSE 09607 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09608 CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA, 09609 $ IRPRNT, ICPRNT ) 09610 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09611 CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL ) 09612 DO 20 K = 1, IB 09613 WRITE( NOUT, FMT = 9999 ) 09614 $ CMATNM, IA+K-1, JA+H, DBLE( WORK( K ) ), 09615 $ DIMAG( WORK( K ) ) 09616 20 CONTINUE 09617 END IF 09618 END IF 09619 IF( MYROW.EQ.ICURROW ) 09620 $ II = II + IB 09621 IF( .NOT.AISROWREP ) 09622 $ ICURROW = MOD( ICURROW+1, NPROW ) 09623 CALL BLACS_BARRIER( ICTXT, 'All' ) 09624 * 09625 * Loop over remaining block of rows 09626 * 09627 DO 50 I = IN+1, IA+M-1, DESCA( MB_ ) 09628 IB = MIN( DESCA( MB_ ), IA+M-I ) 09629 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09630 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09631 DO 30 K = 0, IB-1 09632 WRITE( NOUT, FMT = 9999 ) 09633 $ CMATNM, I+K, JA+H, 09634 $ DBLE( A( II+K+(JJ+H-1)*LDA ) ), 09635 $ DIMAG( A( II+K+(JJ+H-1)*LDA ) ) 09636 30 CONTINUE 09637 END IF 09638 ELSE 09639 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09640 CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), 09641 $ LDA, IRPRNT, ICPRNT ) 09642 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09643 CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, 09644 $ ICURCOL ) 09645 DO 40 K = 1, IB 09646 WRITE( NOUT, FMT = 9999 ) 09647 $ CMATNM, I+K-1, JA+H, DBLE( WORK( K ) ), 09648 $ DIMAG( WORK( K ) ) 09649 40 CONTINUE 09650 END IF 09651 END IF 09652 IF( MYROW.EQ.ICURROW ) 09653 $ II = II + IB 09654 IF( .NOT.AISROWREP ) 09655 $ ICURROW = MOD( ICURROW+1, NPROW ) 09656 CALL BLACS_BARRIER( ICTXT, 'All' ) 09657 50 CONTINUE 09658 * 09659 II = IIA 09660 ICURROW = IAROW 09661 60 CONTINUE 09662 * 09663 IF( MYCOL.EQ.ICURCOL ) 09664 $ JJ = JJ + JB 09665 IF( .NOT.AISCOLREP ) 09666 $ ICURCOL = MOD( ICURCOL+1, NPCOL ) 09667 CALL BLACS_BARRIER( ICTXT, 'All' ) 09668 * 09669 * Loop over remaining column blocks 09670 * 09671 DO 130 J = JN+1, JA+N-1, DESCA( NB_ ) 09672 JB = MIN( DESCA( NB_ ), JA+N-J ) 09673 DO 120 H = 0, JB-1 09674 IB = DESCA( IMB_ )-IA+1 09675 IF( IB.LE.0 ) 09676 $ IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB 09677 IB = MIN( IB, M ) 09678 IN = IA+IB-1 09679 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09680 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09681 DO 70 K = 0, IB-1 09682 WRITE( NOUT, FMT = 9999 ) 09683 $ CMATNM, IA+K, J+H, 09684 $ DBLE( A( II+K+(JJ+H-1)*LDA ) ), 09685 $ DIMAG( A( II+K+(JJ+H-1)*LDA ) ) 09686 70 CONTINUE 09687 END IF 09688 ELSE 09689 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09690 CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), 09691 $ LDA, IRPRNT, ICPRNT ) 09692 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09693 CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, 09694 $ ICURCOL ) 09695 DO 80 K = 1, IB 09696 WRITE( NOUT, FMT = 9999 ) 09697 $ CMATNM, IA+K-1, J+H, DBLE( WORK( K ) ), 09698 $ DIMAG( WORK( K ) ) 09699 80 CONTINUE 09700 END IF 09701 END IF 09702 IF( MYROW.EQ.ICURROW ) 09703 $ II = II + IB 09704 ICURROW = MOD( ICURROW+1, NPROW ) 09705 CALL BLACS_BARRIER( ICTXT, 'All' ) 09706 * 09707 * Loop over remaining block of rows 09708 * 09709 DO 110 I = IN+1, IA+M-1, DESCA( MB_ ) 09710 IB = MIN( DESCA( MB_ ), IA+M-I ) 09711 IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN 09712 IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09713 DO 90 K = 0, IB-1 09714 WRITE( NOUT, FMT = 9999 ) 09715 $ CMATNM, I+K, J+H, 09716 $ DBLE( A( II+K+(JJ+H-1)*LDA ) ), 09717 $ DIMAG( A( II+K+(JJ+H-1)*LDA ) ) 09718 90 CONTINUE 09719 END IF 09720 ELSE 09721 IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN 09722 CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), 09723 $ LDA, IRPRNT, ICPRNT ) 09724 ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN 09725 CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, 09726 $ ICURCOL ) 09727 DO 100 K = 1, IB 09728 WRITE( NOUT, FMT = 9999 ) 09729 $ CMATNM, I+K-1, J+H, DBLE( WORK( K ) ), 09730 $ DIMAG( WORK( K ) ) 09731 100 CONTINUE 09732 END IF 09733 END IF 09734 IF( MYROW.EQ.ICURROW ) 09735 $ II = II + IB 09736 IF( .NOT.AISROWREP ) 09737 $ ICURROW = MOD( ICURROW+1, NPROW ) 09738 CALL BLACS_BARRIER( ICTXT, 'All' ) 09739 110 CONTINUE 09740 * 09741 II = IIA 09742 ICURROW = IAROW 09743 120 CONTINUE 09744 * 09745 IF( MYCOL.EQ.ICURCOL ) 09746 $ JJ = JJ + JB 09747 IF( .NOT.AISCOLREP ) 09748 $ ICURCOL = MOD( ICURCOL+1, NPCOL ) 09749 CALL BLACS_BARRIER( ICTXT, 'All' ) 09750 * 09751 130 CONTINUE 09752 * 09753 9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', D30.18, '+i*(', 09754 $ D30.18, ')' ) 09755 * 09756 RETURN 09757 * 09758 * End of PB_PZLAPRN2 09759 * 09760 END 09761 SUBROUTINE PB_ZFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL ) 09762 * 09763 * -- PBLAS test routine (version 2.0) -- 09764 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09765 * and University of California, Berkeley. 09766 * April 1, 1998 09767 * 09768 * .. Scalar Arguments .. 09769 INTEGER ICTXT, IPOST, IPRE, LDA, M, N 09770 COMPLEX*16 CHKVAL 09771 * .. 09772 * .. Array Arguments .. 09773 COMPLEX*16 A( * ) 09774 * .. 09775 * 09776 * Purpose 09777 * ======= 09778 * 09779 * PB_ZFILLPAD surrounds a two dimensional local array with a guard-zone 09780 * initialized to the value CHKVAL. The user may later call the routine 09781 * PB_ZCHEKPAD to discover if the guardzone has been violated. There are 09782 * three guardzones. The first is a buffer of size IPRE that is before 09783 * the start of the array. The second is the buffer of size IPOST which 09784 * is after the end of the array to be padded. Finally, there is a guard 09785 * zone inside every column of the array to be padded, in the elements 09786 * of A(M+1:LDA, J). 09787 * 09788 * Arguments 09789 * ========= 09790 * 09791 * ICTXT (local input) INTEGER 09792 * On entry, ICTXT specifies the BLACS context handle, indica- 09793 * ting the global context of the operation. The context itself 09794 * is global, but the value of ICTXT is local. 09795 * 09796 * M (local input) INTEGER 09797 * On entry, M specifies the number of rows in the local array 09798 * A. M must be at least zero. 09799 * 09800 * N (local input) INTEGER 09801 * On entry, N specifies the number of columns in the local ar- 09802 * ray A. N must be at least zero. 09803 * 09804 * A (local input/local output) COMPLEX*16 array 09805 * On entry, A is an array of dimension (LDA,N). On exit, this 09806 * array is the padded array. 09807 * 09808 * LDA (local input) INTEGER 09809 * On entry, LDA specifies the leading dimension of the local 09810 * array to be padded. LDA must be at least MAX( 1, M ). 09811 * 09812 * IPRE (local input) INTEGER 09813 * On entry, IPRE specifies the size of the guard zone to put 09814 * before the start of the padded array. 09815 * 09816 * IPOST (local input) INTEGER 09817 * On entry, IPOST specifies the size of the guard zone to put 09818 * after the end of the padded array. 09819 * 09820 * CHKVAL (local input) COMPLEX*16 09821 * On entry, CHKVAL specifies the value to pad the array with. 09822 * 09823 * -- Written on April 1, 1998 by 09824 * R. Clint Whaley, University of Tennessee, Knoxville 37996, USA. 09825 * 09826 * ===================================================================== 09827 * 09828 * .. Local Scalars .. 09829 INTEGER I, J, K 09830 * .. 09831 * .. Executable Statements .. 09832 * 09833 * Put check buffer in front of A 09834 * 09835 IF( IPRE.GT.0 ) THEN 09836 DO 10 I = 1, IPRE 09837 A( I ) = CHKVAL 09838 10 CONTINUE 09839 ELSE 09840 WRITE( *, FMT = '(A)' ) 09841 $ 'WARNING no pre-guardzone in PB_ZFILLPAD' 09842 END IF 09843 * 09844 * Put check buffer in back of A 09845 * 09846 IF( IPOST.GT.0 ) THEN 09847 J = IPRE+LDA*N+1 09848 DO 20 I = J, J+IPOST-1 09849 A( I ) = CHKVAL 09850 20 CONTINUE 09851 ELSE 09852 WRITE( *, FMT = '(A)' ) 09853 $ 'WARNING no post-guardzone in PB_ZFILLPAD' 09854 END IF 09855 * 09856 * Put check buffer in all (LDA-M) gaps 09857 * 09858 IF( LDA.GT.M ) THEN 09859 K = IPRE + M + 1 09860 DO 40 J = 1, N 09861 DO 30 I = K, K + ( LDA - M ) - 1 09862 A( I ) = CHKVAL 09863 30 CONTINUE 09864 K = K + LDA 09865 40 CONTINUE 09866 END IF 09867 * 09868 RETURN 09869 * 09870 * End of PB_ZFILLPAD 09871 * 09872 END 09873 SUBROUTINE PB_ZCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST, 09874 $ CHKVAL ) 09875 * 09876 * -- PBLAS test routine (version 2.0) -- 09877 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 09878 * and University of California, Berkeley. 09879 * April 1, 1998 09880 * 09881 * .. Scalar Arguments .. 09882 INTEGER ICTXT, IPOST, IPRE, LDA, M, N 09883 COMPLEX*16 CHKVAL 09884 * .. 09885 * .. Array Arguments .. 09886 CHARACTER*(*) MESS 09887 COMPLEX*16 A( * ) 09888 * .. 09889 * 09890 * Purpose 09891 * ======= 09892 * 09893 * PB_ZCHEKPAD checks that the padding around a local array has not been 09894 * overwritten since the call to PB_ZFILLPAD. Three types of errors are 09895 * reported: 09896 * 09897 * 1) Overwrite in pre-guardzone. This indicates a memory overwrite has 09898 * occurred in the first IPRE elements which form a buffer before the 09899 * beginning of A. Therefore, the error message: 09900 * 'Overwrite in pre-guardzone: loc( 5) = 18.00000' 09901 * tells that the 5th element of the IPRE long buffer has been overwrit- 09902 * ten with the value 18, where it should still have the value CHKVAL. 09903 * 09904 * 2) Overwrite in post-guardzone. This indicates a memory overwrite has 09905 * occurred in the last IPOST elements which form a buffer after the end 09906 * of A. Error reports are refered from the end of A. Therefore, 09907 * 'Overwrite in post-guardzone: loc( 19) = 24.00000' 09908 * tells that the 19th element after the end of A was overwritten with 09909 * the value 24, where it should still have the value of CHKVAL. 09910 * 09911 * 3) Overwrite in lda-m gap. Tells you elements between M and LDA were 09912 * overwritten. So, 09913 * 'Overwrite in lda-m gap: A( 12, 3) = 22.00000' 09914 * tells that the element at the 12th row and 3rd column of A was over- 09915 * written with the value of 22, where it should still have the value of 09916 * CHKVAL. 09917 * 09918 * Arguments 09919 * ========= 09920 * 09921 * ICTXT (local input) INTEGER 09922 * On entry, ICTXT specifies the BLACS context handle, indica- 09923 * ting the global context of the operation. The context itself 09924 * is global, but the value of ICTXT is local. 09925 * 09926 * MESS (local input) CHARACTER*(*) 09927 * On entry, MESS is a ttring containing a user-defined message. 09928 * 09929 * M (local input) INTEGER 09930 * On entry, M specifies the number of rows in the local array 09931 * A. M must be at least zero. 09932 * 09933 * N (local input) INTEGER 09934 * On entry, N specifies the number of columns in the local ar- 09935 * ray A. N must be at least zero. 09936 * 09937 * A (local input) COMPLEX*16 array 09938 * On entry, A is an array of dimension (LDA,N). 09939 * 09940 * LDA (local input) INTEGER 09941 * On entry, LDA specifies the leading dimension of the local 09942 * array to be padded. LDA must be at least MAX( 1, M ). 09943 * 09944 * IPRE (local input) INTEGER 09945 * On entry, IPRE specifies the size of the guard zone to put 09946 * before the start of the padded array. 09947 * 09948 * IPOST (local input) INTEGER 09949 * On entry, IPOST specifies the size of the guard zone to put 09950 * after the end of the padded array. 09951 * 09952 * CHKVAL (local input) COMPLEX*16 09953 * On entry, CHKVAL specifies the value to pad the array with. 09954 * 09955 * 09956 * -- Written on April 1, 1998 by 09957 * R. Clint Whaley, University of Tennessee, Knoxville 37996, USA. 09958 * 09959 * ===================================================================== 09960 * 09961 * .. Local Scalars .. 09962 CHARACTER*1 TOP 09963 INTEGER I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL, 09964 $ NPROW 09965 * .. 09966 * .. External Subroutines .. 09967 EXTERNAL BLACS_GRIDINFO, IGAMX2D, PB_TOPGET 09968 * .. 09969 * .. Intrinsic Functions .. 09970 INTRINSIC DBLE, DIMAG 09971 * .. 09972 * .. Executable Statements .. 09973 * 09974 * Get grid parameters 09975 * 09976 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 09977 IAM = MYROW*NPCOL + MYCOL 09978 INFO = -1 09979 * 09980 * Check buffer in front of A 09981 * 09982 IF( IPRE.GT.0 ) THEN 09983 DO 10 I = 1, IPRE 09984 IF( A( I ).NE.CHKVAL ) THEN 09985 WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I, 09986 $ DBLE( A( I ) ), DIMAG( A( I ) ) 09987 INFO = IAM 09988 END IF 09989 10 CONTINUE 09990 ELSE 09991 WRITE( *, FMT = * ) 'WARNING no pre-guardzone in PB_ZCHEKPAD' 09992 END IF 09993 * 09994 * Check buffer after A 09995 * 09996 IF( IPOST.GT.0 ) THEN 09997 J = IPRE+LDA*N+1 09998 DO 20 I = J, J+IPOST-1 09999 IF( A( I ).NE.CHKVAL ) THEN 10000 WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post', 10001 $ I-J+1, DBLE( A( I ) ), 10002 $ DIMAG( A( I ) ) 10003 INFO = IAM 10004 END IF 10005 20 CONTINUE 10006 ELSE 10007 WRITE( *, FMT = * ) 10008 $ 'WARNING no post-guardzone buffer in PB_ZCHEKPAD' 10009 END IF 10010 * 10011 * Check all (LDA-M) gaps 10012 * 10013 IF( LDA.GT.M ) THEN 10014 K = IPRE + M + 1 10015 DO 40 J = 1, N 10016 DO 30 I = K, K + (LDA-M) - 1 10017 IF( A( I ).NE.CHKVAL ) THEN 10018 WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS, 10019 $ I-IPRE-LDA*(J-1), J, DBLE( A( I ) ), 10020 $ DIMAG( A( I ) ) 10021 INFO = IAM 10022 END IF 10023 30 CONTINUE 10024 K = K + LDA 10025 40 CONTINUE 10026 END IF 10027 * 10028 CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP ) 10029 CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1, 10030 $ 0, 0 ) 10031 IF( IAM.EQ.0 .AND. INFO.GE.0 ) THEN 10032 WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS 10033 END IF 10034 * 10035 9999 FORMAT( '{', I5, ',', I5, '}: Memory overwrite in ', A ) 10036 9998 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ', 10037 $ A4, '-guardzone: loc(', I3, ') = ', G20.7, '+ i*', 10038 $ G20.7 ) 10039 9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ', 10040 $ 'lda-m gap: loc(', I3, ',', I3, ') = ', G20.7, 10041 $ '+ i*', G20.7 ) 10042 * 10043 RETURN 10044 * 10045 * End of PB_ZCHEKPAD 10046 * 10047 END 10048 SUBROUTINE PB_ZLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA ) 10049 * 10050 * -- PBLAS test routine (version 2.0) -- 10051 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 10052 * and University of California, Berkeley. 10053 * April 1, 1998 10054 * 10055 * .. Scalar Arguments .. 10056 CHARACTER*1 UPLO 10057 INTEGER IOFFD, LDA, M, N 10058 COMPLEX*16 ALPHA, BETA 10059 * .. 10060 * .. Array Arguments .. 10061 COMPLEX*16 A( LDA, * ) 10062 * .. 10063 * 10064 * Purpose 10065 * ======= 10066 * 10067 * PB_ZLASET initializes a two-dimensional array A to beta on the diago- 10068 * nal specified by IOFFD and alpha on the offdiagonals. 10069 * 10070 * Arguments 10071 * ========= 10072 * 10073 * UPLO (global input) CHARACTER*1 10074 * On entry, UPLO specifies which trapezoidal part of the ar- 10075 * ray A is to be set as follows: 10076 * = 'L' or 'l': Lower triangular part is set; the strictly 10077 * upper triangular part of A is not changed, 10078 * = 'U' or 'u': Upper triangular part is set; the strictly 10079 * lower triangular part of A is not changed, 10080 * = 'D' or 'd' Only the diagonal of A is set, 10081 * Otherwise: All of the array A is set. 10082 * 10083 * M (input) INTEGER 10084 * On entry, M specifies the number of rows of the array A. M 10085 * must be at least zero. 10086 * 10087 * N (input) INTEGER 10088 * On entry, N specifies the number of columns of the array A. 10089 * N must be at least zero. 10090 * 10091 * IOFFD (input) INTEGER 10092 * On entry, IOFFD specifies the position of the offdiagonal de- 10093 * limiting the upper and lower trapezoidal part of A as follows 10094 * (see the notes below): 10095 * 10096 * IOFFD = 0 specifies the main diagonal A( i, i ), 10097 * with i = 1 ... MIN( M, N ), 10098 * IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ), 10099 * with i = 1 ... MIN( M-IOFFD, N ), 10100 * IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ), 10101 * with i = 1 ... MIN( M, N+IOFFD ). 10102 * 10103 * ALPHA (input) COMPLEX*16 10104 * On entry, ALPHA specifies the value to which the offdiagonal 10105 * array elements are set to. 10106 * 10107 * BETA (input) COMPLEX*16 10108 * On entry, BETA specifies the value to which the diagonal ar- 10109 * ray elements are set to. 10110 * 10111 * A (input/output) COMPLEX*16 array 10112 * On entry, A is an array of dimension (LDA,N). Before entry 10113 * with UPLO = 'U' or 'u', the leading m by n part of the array 10114 * A must contain the upper trapezoidal part of the matrix as 10115 * specified by IOFFD to be set, and the strictly lower trape- 10116 * zoidal part of A is not referenced; When IUPLO = 'L' or 'l', 10117 * the leading m by n part of the array A must contain the 10118 * lower trapezoidal part of the matrix as specified by IOFFD to 10119 * be set, and the strictly upper trapezoidal part of A is 10120 * not referenced. 10121 * 10122 * LDA (input) INTEGER 10123 * On entry, LDA specifies the leading dimension of the array A. 10124 * LDA must be at least max( 1, M ). 10125 * 10126 * Notes 10127 * ===== 10128 * N N 10129 * ---------------------------- ----------- 10130 * | d | | | 10131 * M | d 'U' | | 'U' | 10132 * | 'L' 'D' | |d | 10133 * | d | M | d | 10134 * ---------------------------- | 'D' | 10135 * | d | 10136 * IOFFD < 0 | 'L' d | 10137 * | d| 10138 * N | | 10139 * ----------- ----------- 10140 * | d 'U'| 10141 * | d | IOFFD > 0 10142 * M | 'D' | 10143 * | d| N 10144 * | 'L' | ---------------------------- 10145 * | | | 'U' | 10146 * | | |d | 10147 * | | | 'D' | 10148 * | | | d | 10149 * | | |'L' d | 10150 * ----------- ---------------------------- 10151 * 10152 * -- Written on April 1, 1998 by 10153 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 10154 * 10155 * ===================================================================== 10156 * 10157 * .. Local Scalars .. 10158 INTEGER I, J, JTMP, MN 10159 * .. 10160 * .. External Functions .. 10161 LOGICAL LSAME 10162 EXTERNAL LSAME 10163 * .. 10164 * .. Intrinsic Functions .. 10165 INTRINSIC MAX, MIN 10166 * .. 10167 * .. Executable Statements .. 10168 * 10169 * Quick return if possible 10170 * 10171 IF( M.LE.0 .OR. N.LE.0 ) 10172 $ RETURN 10173 * 10174 * Start the operations 10175 * 10176 IF( LSAME( UPLO, 'L' ) ) THEN 10177 * 10178 * Set the diagonal to BETA and the strictly lower triangular 10179 * part of the array to ALPHA. 10180 * 10181 MN = MAX( 0, -IOFFD ) 10182 DO 20 J = 1, MIN( MN, N ) 10183 DO 10 I = 1, M 10184 A( I, J ) = ALPHA 10185 10 CONTINUE 10186 20 CONTINUE 10187 DO 40 J = MN + 1, MIN( M - IOFFD, N ) 10188 JTMP = J + IOFFD 10189 A( JTMP, J ) = BETA 10190 DO 30 I = JTMP + 1, M 10191 A( I, J ) = ALPHA 10192 30 CONTINUE 10193 40 CONTINUE 10194 * 10195 ELSE IF( LSAME( UPLO, 'U' ) ) THEN 10196 * 10197 * Set the diagonal to BETA and the strictly upper triangular 10198 * part of the array to ALPHA. 10199 * 10200 MN = MIN( M - IOFFD, N ) 10201 DO 60 J = MAX( 0, -IOFFD ) + 1, MN 10202 JTMP = J + IOFFD 10203 DO 50 I = 1, JTMP - 1 10204 A( I, J ) = ALPHA 10205 50 CONTINUE 10206 A( JTMP, J ) = BETA 10207 60 CONTINUE 10208 DO 80 J = MAX( 0, MN ) + 1, N 10209 DO 70 I = 1, M 10210 A( I, J ) = ALPHA 10211 70 CONTINUE 10212 80 CONTINUE 10213 * 10214 ELSE IF( LSAME( UPLO, 'D' ) ) THEN 10215 * 10216 * Set the array to BETA on the diagonal. 10217 * 10218 DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N ) 10219 A( J + IOFFD, J ) = BETA 10220 90 CONTINUE 10221 * 10222 ELSE 10223 * 10224 * Set the array to BETA on the diagonal and ALPHA on the 10225 * offdiagonal. 10226 * 10227 DO 110 J = 1, N 10228 DO 100 I = 1, M 10229 A( I, J ) = ALPHA 10230 100 CONTINUE 10231 110 CONTINUE 10232 IF( ALPHA.NE.BETA .AND. IOFFD.LT.M .AND. IOFFD.GT.-N ) THEN 10233 DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N ) 10234 A( J + IOFFD, J ) = BETA 10235 120 CONTINUE 10236 END IF 10237 * 10238 END IF 10239 * 10240 RETURN 10241 * 10242 * End of PB_ZLASET 10243 * 10244 END 10245 SUBROUTINE PB_ZLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA ) 10246 * 10247 * -- PBLAS test routine (version 2.0) -- 10248 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 10249 * and University of California, Berkeley. 10250 * April 1, 1998 10251 * 10252 * .. Scalar Arguments .. 10253 CHARACTER*1 UPLO 10254 INTEGER IOFFD, LDA, M, N 10255 COMPLEX*16 ALPHA 10256 * .. 10257 * .. Array Arguments .. 10258 COMPLEX*16 A( LDA, * ) 10259 * .. 10260 * 10261 * Purpose 10262 * ======= 10263 * 10264 * PB_ZLASCAL scales a two-dimensional array A by the scalar alpha. 10265 * 10266 * Arguments 10267 * ========= 10268 * 10269 * UPLO (input) CHARACTER*1 10270 * On entry, UPLO specifies which trapezoidal part of the ar- 10271 * ray A is to be scaled as follows: 10272 * = 'L' or 'l': the lower trapezoid of A is scaled, 10273 * = 'U' or 'u': the upper trapezoid of A is scaled, 10274 * = 'D' or 'd': diagonal specified by IOFFD is scaled, 10275 * Otherwise: all of the array A is scaled. 10276 * 10277 * M (input) INTEGER 10278 * On entry, M specifies the number of rows of the array A. M 10279 * must be at least zero. 10280 * 10281 * N (input) INTEGER 10282 * On entry, N specifies the number of columns of the array A. 10283 * N must be at least zero. 10284 * 10285 * IOFFD (input) INTEGER 10286 * On entry, IOFFD specifies the position of the offdiagonal de- 10287 * limiting the upper and lower trapezoidal part of A as follows 10288 * (see the notes below): 10289 * 10290 * IOFFD = 0 specifies the main diagonal A( i, i ), 10291 * with i = 1 ... MIN( M, N ), 10292 * IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ), 10293 * with i = 1 ... MIN( M-IOFFD, N ), 10294 * IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ), 10295 * with i = 1 ... MIN( M, N+IOFFD ). 10296 * 10297 * ALPHA (input) COMPLEX*16 10298 * On entry, ALPHA specifies the scalar alpha. 10299 * 10300 * A (input/output) COMPLEX*16 array 10301 * On entry, A is an array of dimension (LDA,N). Before entry 10302 * with UPLO = 'U' or 'u', the leading m by n part of the array 10303 * A must contain the upper trapezoidal part of the matrix as 10304 * specified by IOFFD to be scaled, and the strictly lower tra- 10305 * pezoidal part of A is not referenced; When UPLO = 'L' or 'l', 10306 * the leading m by n part of the array A must contain the lower 10307 * trapezoidal part of the matrix as specified by IOFFD to be 10308 * scaled, and the strictly upper trapezoidal part of A is not 10309 * referenced. On exit, the entries of the trapezoid part of A 10310 * determined by UPLO and IOFFD are scaled. 10311 * 10312 * LDA (input) INTEGER 10313 * On entry, LDA specifies the leading dimension of the array A. 10314 * LDA must be at least max( 1, M ). 10315 * 10316 * Notes 10317 * ===== 10318 * N N 10319 * ---------------------------- ----------- 10320 * | d | | | 10321 * M | d 'U' | | 'U' | 10322 * | 'L' 'D' | |d | 10323 * | d | M | d | 10324 * ---------------------------- | 'D' | 10325 * | d | 10326 * IOFFD < 0 | 'L' d | 10327 * | d| 10328 * N | | 10329 * ----------- ----------- 10330 * | d 'U'| 10331 * | d | IOFFD > 0 10332 * M | 'D' | 10333 * | d| N 10334 * | 'L' | ---------------------------- 10335 * | | | 'U' | 10336 * | | |d | 10337 * | | | 'D' | 10338 * | | | d | 10339 * | | |'L' d | 10340 * ----------- ---------------------------- 10341 * 10342 * -- Written on April 1, 1998 by 10343 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 10344 * 10345 * ===================================================================== 10346 * 10347 * .. Local Scalars .. 10348 INTEGER I, J, JTMP, MN 10349 * .. 10350 * .. External Functions .. 10351 LOGICAL LSAME 10352 EXTERNAL LSAME 10353 * .. 10354 * .. Intrinsic Functions .. 10355 INTRINSIC MAX, MIN 10356 * .. 10357 * .. Executable Statements .. 10358 * 10359 * Quick return if possible 10360 * 10361 IF( M.LE.0 .OR. N.LE.0 ) 10362 $ RETURN 10363 * 10364 * Start the operations 10365 * 10366 IF( LSAME( UPLO, 'L' ) ) THEN 10367 * 10368 * Scales the lower triangular part of the array by ALPHA. 10369 * 10370 MN = MAX( 0, -IOFFD ) 10371 DO 20 J = 1, MIN( MN, N ) 10372 DO 10 I = 1, M 10373 A( I, J ) = ALPHA * A( I, J ) 10374 10 CONTINUE 10375 20 CONTINUE 10376 DO 40 J = MN + 1, MIN( M - IOFFD, N ) 10377 DO 30 I = J + IOFFD, M 10378 A( I, J ) = ALPHA * A( I, J ) 10379 30 CONTINUE 10380 40 CONTINUE 10381 * 10382 ELSE IF( LSAME( UPLO, 'U' ) ) THEN 10383 * 10384 * Scales the upper triangular part of the array by ALPHA. 10385 * 10386 MN = MIN( M - IOFFD, N ) 10387 DO 60 J = MAX( 0, -IOFFD ) + 1, MN 10388 DO 50 I = 1, J + IOFFD 10389 A( I, J ) = ALPHA * A( I, J ) 10390 50 CONTINUE 10391 60 CONTINUE 10392 DO 80 J = MAX( 0, MN ) + 1, N 10393 DO 70 I = 1, M 10394 A( I, J ) = ALPHA * A( I, J ) 10395 70 CONTINUE 10396 80 CONTINUE 10397 * 10398 ELSE IF( LSAME( UPLO, 'D' ) ) THEN 10399 * 10400 * Scales the diagonal entries by ALPHA. 10401 * 10402 DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N ) 10403 JTMP = J + IOFFD 10404 A( JTMP, J ) = ALPHA * A( JTMP, J ) 10405 90 CONTINUE 10406 * 10407 ELSE 10408 * 10409 * Scales the entire array by ALPHA. 10410 * 10411 DO 110 J = 1, N 10412 DO 100 I = 1, M 10413 A( I, J ) = ALPHA * A( I, J ) 10414 100 CONTINUE 10415 110 CONTINUE 10416 * 10417 END IF 10418 * 10419 RETURN 10420 * 10421 * End of PB_ZLASCAL 10422 * 10423 END 10424 SUBROUTINE PB_ZLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS, 10425 $ IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB, 10426 $ LNBLOC, JMP, IMULADD ) 10427 * 10428 * -- PBLAS test routine (version 2.0) -- 10429 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 10430 * and University of California, Berkeley. 10431 * April 1, 1998 10432 * 10433 * .. Scalar Arguments .. 10434 CHARACTER*1 UPLO, AFORM 10435 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC, 10436 $ MB, MBLKS, NB, NBLKS 10437 * .. 10438 * .. Array Arguments .. 10439 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * ) 10440 COMPLEX*16 A( LDA, * ) 10441 * .. 10442 * 10443 * Purpose 10444 * ======= 10445 * 10446 * PB_ZLAGEN locally initializes an array A. 10447 * 10448 * Arguments 10449 * ========= 10450 * 10451 * UPLO (global input) CHARACTER*1 10452 * On entry, UPLO specifies whether the lower (UPLO='L') trape- 10453 * zoidal part or the upper (UPLO='U') trapezoidal part is to be 10454 * generated when the matrix to be generated is symmetric or 10455 * Hermitian. For all the other values of AFORM, the value of 10456 * this input argument is ignored. 10457 * 10458 * AFORM (global input) CHARACTER*1 10459 * On entry, AFORM specifies the type of submatrix to be genera- 10460 * ted as follows: 10461 * AFORM = 'S', sub( A ) is a symmetric matrix, 10462 * AFORM = 'H', sub( A ) is a Hermitian matrix, 10463 * AFORM = 'T', sub( A ) is overrwritten with the transpose 10464 * of what would normally be generated, 10465 * AFORM = 'C', sub( A ) is overwritten with the conjugate 10466 * transpose of what would normally be genera- 10467 * ted. 10468 * AFORM = 'N', a random submatrix is generated. 10469 * 10470 * A (local output) COMPLEX*16 array 10471 * On entry, A is an array of dimension (LLD_A, *). On exit, 10472 * this array contains the local entries of the randomly genera- 10473 * ted submatrix sub( A ). 10474 * 10475 * LDA (local input) INTEGER 10476 * On entry, LDA specifies the local leading dimension of the 10477 * array A. LDA must be at least one. 10478 * 10479 * LCMT00 (global input) INTEGER 10480 * On entry, LCMT00 is the LCM value specifying the off-diagonal 10481 * of the underlying matrix of interest. LCMT00=0 specifies the 10482 * main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0 10483 * specifies superdiagonals. 10484 * 10485 * IRAN (local input) INTEGER array 10486 * On entry, IRAN is an array of dimension 2 containing respec- 10487 * tively the 16-lower and 16-higher bits of the encoding of the 10488 * entry of the random sequence corresponding locally to the 10489 * first local array entry to generate. Usually, this array is 10490 * computed by PB_SETLOCRAN. 10491 * 10492 * MBLKS (local input) INTEGER 10493 * On entry, MBLKS specifies the local number of blocks of rows. 10494 * MBLKS is at least zero. 10495 * 10496 * IMBLOC (local input) INTEGER 10497 * On entry, IMBLOC specifies the number of rows (size) of the 10498 * local uppest blocks. IMBLOC is at least zero. 10499 * 10500 * MB (global input) INTEGER 10501 * On entry, MB specifies the blocking factor used to partition 10502 * the rows of the matrix. MB must be at least one. 10503 * 10504 * LMBLOC (local input) INTEGER 10505 * On entry, LMBLOC specifies the number of rows (size) of the 10506 * local lowest blocks. LMBLOC is at least zero. 10507 * 10508 * NBLKS (local input) INTEGER 10509 * On entry, NBLKS specifies the local number of blocks of co- 10510 * lumns. NBLKS is at least zero. 10511 * 10512 * INBLOC (local input) INTEGER 10513 * On entry, INBLOC specifies the number of columns (size) of 10514 * the local leftmost blocks. INBLOC is at least zero. 10515 * 10516 * NB (global input) INTEGER 10517 * On entry, NB specifies the blocking factor used to partition 10518 * the the columns of the matrix. NB must be at least one. 10519 * 10520 * LNBLOC (local input) INTEGER 10521 * On entry, LNBLOC specifies the number of columns (size) of 10522 * the local rightmost blocks. LNBLOC is at least zero. 10523 * 10524 * JMP (local input) INTEGER array 10525 * On entry, JMP is an array of dimension JMP_LEN containing the 10526 * different jump values used by the random matrix generator. 10527 * 10528 * IMULADD (local input) INTEGER array 10529 * On entry, IMULADD is an array of dimension (4, JMP_LEN). The 10530 * jth column of this array contains the encoded initial cons- 10531 * tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) ) 10532 * (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j) 10533 * contains respectively the 16-lower and 16-higher bits of the 10534 * constant a_j, and IMULADD(3:4,j) contains the 16-lower and 10535 * 16-higher bits of the constant c_j. 10536 * 10537 * -- Written on April 1, 1998 by 10538 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 10539 * 10540 * ===================================================================== 10541 * 10542 * .. Parameters .. 10543 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN, 10544 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB, 10545 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW 10546 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3, 10547 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6, 10548 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9, 10549 $ JMP_NQNB = 10, JMP_NQINBLOC = 11, 10550 $ JMP_LEN = 11 ) 10551 DOUBLE PRECISION ZERO 10552 PARAMETER ( ZERO = 0.0D+0 ) 10553 * .. 10554 * .. Local Scalars .. 10555 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK, 10556 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP 10557 COMPLEX*16 DUMMY 10558 * .. 10559 * .. Local Arrays .. 10560 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 ) 10561 * .. 10562 * .. External Subroutines .. 10563 EXTERNAL PB_JUMPIT 10564 * .. 10565 * .. External Functions .. 10566 LOGICAL LSAME 10567 DOUBLE PRECISION PB_DRAND 10568 EXTERNAL LSAME, PB_DRAND 10569 * .. 10570 * .. Intrinsic Functions .. 10571 INTRINSIC DBLE, DCMPLX, MAX, MIN 10572 * .. 10573 * .. Executable Statements .. 10574 * 10575 DO 10 I = 1, 2 10576 IB1( I ) = IRAN( I ) 10577 IB2( I ) = IRAN( I ) 10578 IB3( I ) = IRAN( I ) 10579 10 CONTINUE 10580 * 10581 IF( LSAME( AFORM, 'N' ) ) THEN 10582 * 10583 * Generate random matrix 10584 * 10585 JJ = 1 10586 * 10587 DO 50 JBLK = 1, NBLKS 10588 * 10589 IF( JBLK.EQ.1 ) THEN 10590 JB = INBLOC 10591 ELSE IF( JBLK.EQ.NBLKS ) THEN 10592 JB = LNBLOC 10593 ELSE 10594 JB = NB 10595 END IF 10596 * 10597 DO 40 JK = JJ, JJ + JB - 1 10598 * 10599 II = 1 10600 * 10601 DO 30 IBLK = 1, MBLKS 10602 * 10603 IF( IBLK.EQ.1 ) THEN 10604 IB = IMBLOC 10605 ELSE IF( IBLK.EQ.MBLKS ) THEN 10606 IB = LMBLOC 10607 ELSE 10608 IB = MB 10609 END IF 10610 * 10611 * Blocks are IB by JB 10612 * 10613 DO 20 IK = II, II + IB - 1 10614 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 10615 $ PB_DRAND( 0 ) ) 10616 20 CONTINUE 10617 * 10618 II = II + IB 10619 * 10620 IF( IBLK.EQ.1 ) THEN 10621 * 10622 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 10623 * 10624 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1, 10625 $ IB0 ) 10626 * 10627 ELSE 10628 * 10629 * Jump NPROW * MB rows 10630 * 10631 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 ) 10632 * 10633 END IF 10634 * 10635 IB1( 1 ) = IB0( 1 ) 10636 IB1( 2 ) = IB0( 2 ) 10637 * 10638 30 CONTINUE 10639 * 10640 * Jump one column 10641 * 10642 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 ) 10643 * 10644 IB1( 1 ) = IB0( 1 ) 10645 IB1( 2 ) = IB0( 2 ) 10646 IB2( 1 ) = IB0( 1 ) 10647 IB2( 2 ) = IB0( 2 ) 10648 * 10649 40 CONTINUE 10650 * 10651 JJ = JJ + JB 10652 * 10653 IF( JBLK.EQ.1 ) THEN 10654 * 10655 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 10656 * 10657 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 ) 10658 * 10659 ELSE 10660 * 10661 * Jump NPCOL * NB columns 10662 * 10663 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 ) 10664 * 10665 END IF 10666 * 10667 IB1( 1 ) = IB0( 1 ) 10668 IB1( 2 ) = IB0( 2 ) 10669 IB2( 1 ) = IB0( 1 ) 10670 IB2( 2 ) = IB0( 2 ) 10671 IB3( 1 ) = IB0( 1 ) 10672 IB3( 2 ) = IB0( 2 ) 10673 * 10674 50 CONTINUE 10675 * 10676 ELSE IF( LSAME( AFORM, 'T' ) ) THEN 10677 * 10678 * Generate the transpose of the matrix that would be normally 10679 * generated. 10680 * 10681 II = 1 10682 * 10683 DO 90 IBLK = 1, MBLKS 10684 * 10685 IF( IBLK.EQ.1 ) THEN 10686 IB = IMBLOC 10687 ELSE IF( IBLK.EQ.MBLKS ) THEN 10688 IB = LMBLOC 10689 ELSE 10690 IB = MB 10691 END IF 10692 * 10693 DO 80 IK = II, II + IB - 1 10694 * 10695 JJ = 1 10696 * 10697 DO 70 JBLK = 1, NBLKS 10698 * 10699 IF( JBLK.EQ.1 ) THEN 10700 JB = INBLOC 10701 ELSE IF( JBLK.EQ.NBLKS ) THEN 10702 JB = LNBLOC 10703 ELSE 10704 JB = NB 10705 END IF 10706 * 10707 * Blocks are IB by JB 10708 * 10709 DO 60 JK = JJ, JJ + JB - 1 10710 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 10711 $ PB_DRAND( 0 ) ) 10712 60 CONTINUE 10713 * 10714 JJ = JJ + JB 10715 * 10716 IF( JBLK.EQ.1 ) THEN 10717 * 10718 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 10719 * 10720 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1, 10721 $ IB0 ) 10722 * 10723 ELSE 10724 * 10725 * Jump NPCOL * NB columns 10726 * 10727 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 ) 10728 * 10729 END IF 10730 * 10731 IB1( 1 ) = IB0( 1 ) 10732 IB1( 2 ) = IB0( 2 ) 10733 * 10734 70 CONTINUE 10735 * 10736 * Jump one row 10737 * 10738 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 ) 10739 * 10740 IB1( 1 ) = IB0( 1 ) 10741 IB1( 2 ) = IB0( 2 ) 10742 IB2( 1 ) = IB0( 1 ) 10743 IB2( 2 ) = IB0( 2 ) 10744 * 10745 80 CONTINUE 10746 * 10747 II = II + IB 10748 * 10749 IF( IBLK.EQ.1 ) THEN 10750 * 10751 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 10752 * 10753 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 ) 10754 * 10755 ELSE 10756 * 10757 * Jump NPROW * MB rows 10758 * 10759 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 ) 10760 * 10761 END IF 10762 * 10763 IB1( 1 ) = IB0( 1 ) 10764 IB1( 2 ) = IB0( 2 ) 10765 IB2( 1 ) = IB0( 1 ) 10766 IB2( 2 ) = IB0( 2 ) 10767 IB3( 1 ) = IB0( 1 ) 10768 IB3( 2 ) = IB0( 2 ) 10769 * 10770 90 CONTINUE 10771 * 10772 ELSE IF( LSAME( AFORM, 'S' ) ) THEN 10773 * 10774 * Generate a symmetric matrix 10775 * 10776 IF( LSAME( UPLO, 'L' ) ) THEN 10777 * 10778 * generate lower trapezoidal part 10779 * 10780 JJ = 1 10781 LCMTC = LCMT00 10782 * 10783 DO 170 JBLK = 1, NBLKS 10784 * 10785 IF( JBLK.EQ.1 ) THEN 10786 JB = INBLOC 10787 LOW = 1 - INBLOC 10788 ELSE IF( JBLK.EQ.NBLKS ) THEN 10789 JB = LNBLOC 10790 LOW = 1 - NB 10791 ELSE 10792 JB = NB 10793 LOW = 1 - NB 10794 END IF 10795 * 10796 DO 160 JK = JJ, JJ + JB - 1 10797 * 10798 II = 1 10799 LCMTR = LCMTC 10800 * 10801 DO 150 IBLK = 1, MBLKS 10802 * 10803 IF( IBLK.EQ.1 ) THEN 10804 IB = IMBLOC 10805 UPP = IMBLOC - 1 10806 ELSE IF( IBLK.EQ.MBLKS ) THEN 10807 IB = LMBLOC 10808 UPP = MB - 1 10809 ELSE 10810 IB = MB 10811 UPP = MB - 1 10812 END IF 10813 * 10814 * Blocks are IB by JB 10815 * 10816 IF( LCMTR.GT.UPP ) THEN 10817 * 10818 DO 100 IK = II, II + IB - 1 10819 DUMMY = DCMPLX( PB_DRAND( 0 ), 10820 $ PB_DRAND( 0 ) ) 10821 100 CONTINUE 10822 * 10823 ELSE IF( LCMTR.GE.LOW ) THEN 10824 * 10825 JTMP = JK - JJ + 1 10826 MNB = MAX( 0, -LCMTR ) 10827 * 10828 IF( JTMP.LE.MIN( MNB, JB ) ) THEN 10829 * 10830 DO 110 IK = II, II + IB - 1 10831 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 10832 $ PB_DRAND( 0 ) ) 10833 110 CONTINUE 10834 * 10835 ELSE IF( ( JTMP.GE.( MNB + 1 ) ) .AND. 10836 $ ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN 10837 * 10838 ITMP = II + JTMP + LCMTR - 1 10839 * 10840 DO 120 IK = II, ITMP - 1 10841 DUMMY = DCMPLX( PB_DRAND( 0 ), 10842 $ PB_DRAND( 0 ) ) 10843 120 CONTINUE 10844 * 10845 DO 130 IK = ITMP, II + IB - 1 10846 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 10847 $ PB_DRAND( 0 ) ) 10848 130 CONTINUE 10849 * 10850 END IF 10851 * 10852 ELSE 10853 * 10854 DO 140 IK = II, II + IB - 1 10855 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 10856 $ PB_DRAND( 0 ) ) 10857 140 CONTINUE 10858 * 10859 END IF 10860 * 10861 II = II + IB 10862 * 10863 IF( IBLK.EQ.1 ) THEN 10864 * 10865 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 10866 * 10867 LCMTR = LCMTR - JMP( JMP_NPIMBLOC ) 10868 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1, 10869 $ IB0 ) 10870 * 10871 ELSE 10872 * 10873 * Jump NPROW * MB rows 10874 * 10875 LCMTR = LCMTR - JMP( JMP_NPMB ) 10876 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, 10877 $ IB0 ) 10878 * 10879 END IF 10880 * 10881 IB1( 1 ) = IB0( 1 ) 10882 IB1( 2 ) = IB0( 2 ) 10883 * 10884 150 CONTINUE 10885 * 10886 * Jump one column 10887 * 10888 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 ) 10889 * 10890 IB1( 1 ) = IB0( 1 ) 10891 IB1( 2 ) = IB0( 2 ) 10892 IB2( 1 ) = IB0( 1 ) 10893 IB2( 2 ) = IB0( 2 ) 10894 * 10895 160 CONTINUE 10896 * 10897 JJ = JJ + JB 10898 * 10899 IF( JBLK.EQ.1 ) THEN 10900 * 10901 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 10902 * 10903 LCMTC = LCMTC + JMP( JMP_NQINBLOC ) 10904 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 ) 10905 * 10906 ELSE 10907 * 10908 * Jump NPCOL * NB columns 10909 * 10910 LCMTC = LCMTC + JMP( JMP_NQNB ) 10911 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 ) 10912 * 10913 END IF 10914 * 10915 IB1( 1 ) = IB0( 1 ) 10916 IB1( 2 ) = IB0( 2 ) 10917 IB2( 1 ) = IB0( 1 ) 10918 IB2( 2 ) = IB0( 2 ) 10919 IB3( 1 ) = IB0( 1 ) 10920 IB3( 2 ) = IB0( 2 ) 10921 * 10922 170 CONTINUE 10923 * 10924 ELSE 10925 * 10926 * generate upper trapezoidal part 10927 * 10928 II = 1 10929 LCMTR = LCMT00 10930 * 10931 DO 250 IBLK = 1, MBLKS 10932 * 10933 IF( IBLK.EQ.1 ) THEN 10934 IB = IMBLOC 10935 UPP = IMBLOC - 1 10936 ELSE IF( IBLK.EQ.MBLKS ) THEN 10937 IB = LMBLOC 10938 UPP = MB - 1 10939 ELSE 10940 IB = MB 10941 UPP = MB - 1 10942 END IF 10943 * 10944 DO 240 IK = II, II + IB - 1 10945 * 10946 JJ = 1 10947 LCMTC = LCMTR 10948 * 10949 DO 230 JBLK = 1, NBLKS 10950 * 10951 IF( JBLK.EQ.1 ) THEN 10952 JB = INBLOC 10953 LOW = 1 - INBLOC 10954 ELSE IF( JBLK.EQ.NBLKS ) THEN 10955 JB = LNBLOC 10956 LOW = 1 - NB 10957 ELSE 10958 JB = NB 10959 LOW = 1 - NB 10960 END IF 10961 * 10962 * Blocks are IB by JB 10963 * 10964 IF( LCMTC.LT.LOW ) THEN 10965 * 10966 DO 180 JK = JJ, JJ + JB - 1 10967 DUMMY = DCMPLX( PB_DRAND( 0 ), 10968 $ PB_DRAND( 0 ) ) 10969 180 CONTINUE 10970 * 10971 ELSE IF( LCMTC.LE.UPP ) THEN 10972 * 10973 ITMP = IK - II + 1 10974 MNB = MAX( 0, LCMTC ) 10975 * 10976 IF( ITMP.LE.MIN( MNB, IB ) ) THEN 10977 * 10978 DO 190 JK = JJ, JJ + JB - 1 10979 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 10980 $ PB_DRAND( 0 ) ) 10981 190 CONTINUE 10982 * 10983 ELSE IF( ( ITMP.GE.( MNB + 1 ) ) .AND. 10984 $ ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN 10985 * 10986 JTMP = JJ + ITMP - LCMTC - 1 10987 * 10988 DO 200 JK = JJ, JTMP - 1 10989 DUMMY = DCMPLX( PB_DRAND( 0 ), 10990 $ PB_DRAND( 0 ) ) 10991 200 CONTINUE 10992 * 10993 DO 210 JK = JTMP, JJ + JB - 1 10994 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 10995 $ PB_DRAND( 0 ) ) 10996 210 CONTINUE 10997 * 10998 END IF 10999 * 11000 ELSE 11001 * 11002 DO 220 JK = JJ, JJ + JB - 1 11003 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 11004 $ PB_DRAND( 0 ) ) 11005 220 CONTINUE 11006 * 11007 END IF 11008 * 11009 JJ = JJ + JB 11010 * 11011 IF( JBLK.EQ.1 ) THEN 11012 * 11013 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 11014 * 11015 LCMTC = LCMTC + JMP( JMP_NQINBLOC ) 11016 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1, 11017 $ IB0 ) 11018 * 11019 ELSE 11020 * 11021 * Jump NPCOL * NB columns 11022 * 11023 LCMTC = LCMTC + JMP( JMP_NQNB ) 11024 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, 11025 $ IB0 ) 11026 * 11027 END IF 11028 * 11029 IB1( 1 ) = IB0( 1 ) 11030 IB1( 2 ) = IB0( 2 ) 11031 * 11032 230 CONTINUE 11033 * 11034 * Jump one row 11035 * 11036 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 ) 11037 * 11038 IB1( 1 ) = IB0( 1 ) 11039 IB1( 2 ) = IB0( 2 ) 11040 IB2( 1 ) = IB0( 1 ) 11041 IB2( 2 ) = IB0( 2 ) 11042 * 11043 240 CONTINUE 11044 * 11045 II = II + IB 11046 * 11047 IF( IBLK.EQ.1 ) THEN 11048 * 11049 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 11050 * 11051 LCMTR = LCMTR - JMP( JMP_NPIMBLOC ) 11052 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 ) 11053 * 11054 ELSE 11055 * 11056 * Jump NPROW * MB rows 11057 * 11058 LCMTR = LCMTR - JMP( JMP_NPMB ) 11059 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 ) 11060 * 11061 END IF 11062 * 11063 IB1( 1 ) = IB0( 1 ) 11064 IB1( 2 ) = IB0( 2 ) 11065 IB2( 1 ) = IB0( 1 ) 11066 IB2( 2 ) = IB0( 2 ) 11067 IB3( 1 ) = IB0( 1 ) 11068 IB3( 2 ) = IB0( 2 ) 11069 * 11070 250 CONTINUE 11071 * 11072 END IF 11073 * 11074 ELSE IF( LSAME( AFORM, 'C' ) ) THEN 11075 * 11076 * Generate the conjugate transpose of the matrix that would be 11077 * normally generated. 11078 * 11079 II = 1 11080 * 11081 DO 290 IBLK = 1, MBLKS 11082 * 11083 IF( IBLK.EQ.1 ) THEN 11084 IB = IMBLOC 11085 ELSE IF( IBLK.EQ.MBLKS ) THEN 11086 IB = LMBLOC 11087 ELSE 11088 IB = MB 11089 END IF 11090 * 11091 DO 280 IK = II, II + IB - 1 11092 * 11093 JJ = 1 11094 * 11095 DO 270 JBLK = 1, NBLKS 11096 * 11097 IF( JBLK.EQ.1 ) THEN 11098 JB = INBLOC 11099 ELSE IF( JBLK.EQ.NBLKS ) THEN 11100 JB = LNBLOC 11101 ELSE 11102 JB = NB 11103 END IF 11104 * 11105 * Blocks are IB by JB 11106 * 11107 DO 260 JK = JJ, JJ + JB - 1 11108 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 11109 $ -PB_DRAND( 0 ) ) 11110 260 CONTINUE 11111 * 11112 JJ = JJ + JB 11113 * 11114 IF( JBLK.EQ.1 ) THEN 11115 * 11116 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 11117 * 11118 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1, 11119 $ IB0 ) 11120 * 11121 ELSE 11122 * 11123 * Jump NPCOL * NB columns 11124 * 11125 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, 11126 $ IB0 ) 11127 * 11128 END IF 11129 * 11130 IB1( 1 ) = IB0( 1 ) 11131 IB1( 2 ) = IB0( 2 ) 11132 * 11133 270 CONTINUE 11134 * 11135 * Jump one row 11136 * 11137 CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 ) 11138 * 11139 IB1( 1 ) = IB0( 1 ) 11140 IB1( 2 ) = IB0( 2 ) 11141 IB2( 1 ) = IB0( 1 ) 11142 IB2( 2 ) = IB0( 2 ) 11143 * 11144 280 CONTINUE 11145 * 11146 II = II + IB 11147 * 11148 IF( IBLK.EQ.1 ) THEN 11149 * 11150 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 11151 * 11152 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 ) 11153 * 11154 ELSE 11155 * 11156 * Jump NPROW * MB rows 11157 * 11158 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 ) 11159 * 11160 END IF 11161 * 11162 IB1( 1 ) = IB0( 1 ) 11163 IB1( 2 ) = IB0( 2 ) 11164 IB2( 1 ) = IB0( 1 ) 11165 IB2( 2 ) = IB0( 2 ) 11166 IB3( 1 ) = IB0( 1 ) 11167 IB3( 2 ) = IB0( 2 ) 11168 * 11169 290 CONTINUE 11170 * 11171 ELSE IF( LSAME( AFORM, 'H' ) ) THEN 11172 * 11173 * Generate a Hermitian matrix 11174 * 11175 IF( LSAME( UPLO, 'L' ) ) THEN 11176 * 11177 * generate lower trapezoidal part 11178 * 11179 JJ = 1 11180 LCMTC = LCMT00 11181 * 11182 DO 370 JBLK = 1, NBLKS 11183 * 11184 IF( JBLK.EQ.1 ) THEN 11185 JB = INBLOC 11186 LOW = 1 - INBLOC 11187 ELSE IF( JBLK.EQ.NBLKS ) THEN 11188 JB = LNBLOC 11189 LOW = 1 - NB 11190 ELSE 11191 JB = NB 11192 LOW = 1 - NB 11193 END IF 11194 * 11195 DO 360 JK = JJ, JJ + JB - 1 11196 * 11197 II = 1 11198 LCMTR = LCMTC 11199 * 11200 DO 350 IBLK = 1, MBLKS 11201 * 11202 IF( IBLK.EQ.1 ) THEN 11203 IB = IMBLOC 11204 UPP = IMBLOC - 1 11205 ELSE IF( IBLK.EQ.MBLKS ) THEN 11206 IB = LMBLOC 11207 UPP = MB - 1 11208 ELSE 11209 IB = MB 11210 UPP = MB - 1 11211 END IF 11212 * 11213 * Blocks are IB by JB 11214 * 11215 IF( LCMTR.GT.UPP ) THEN 11216 * 11217 DO 300 IK = II, II + IB - 1 11218 DUMMY = DCMPLX( PB_DRAND( 0 ), 11219 $ PB_DRAND( 0 ) ) 11220 300 CONTINUE 11221 * 11222 ELSE IF( LCMTR.GE.LOW ) THEN 11223 * 11224 JTMP = JK - JJ + 1 11225 MNB = MAX( 0, -LCMTR ) 11226 * 11227 IF( JTMP.LE.MIN( MNB, JB ) ) THEN 11228 * 11229 DO 310 IK = II, II + IB - 1 11230 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 11231 $ PB_DRAND( 0 ) ) 11232 310 CONTINUE 11233 * 11234 ELSE IF( ( JTMP.GE.( MNB + 1 ) ) .AND. 11235 $ ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN 11236 * 11237 ITMP = II + JTMP + LCMTR - 1 11238 * 11239 DO 320 IK = II, ITMP - 1 11240 DUMMY = DCMPLX( PB_DRAND( 0 ), 11241 $ PB_DRAND( 0 ) ) 11242 320 CONTINUE 11243 * 11244 IF( ITMP.LE.( II + IB - 1 ) ) THEN 11245 DUMMY = DCMPLX( PB_DRAND( 0 ), 11246 $ -PB_DRAND( 0 ) ) 11247 A( ITMP, JK ) = DCMPLX( DBLE( DUMMY ), 11248 $ ZERO ) 11249 END IF 11250 * 11251 DO 330 IK = ITMP + 1, II + IB - 1 11252 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 11253 $ PB_DRAND( 0 ) ) 11254 330 CONTINUE 11255 * 11256 END IF 11257 * 11258 ELSE 11259 * 11260 DO 340 IK = II, II + IB - 1 11261 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 11262 $ PB_DRAND( 0 ) ) 11263 340 CONTINUE 11264 * 11265 END IF 11266 * 11267 II = II + IB 11268 * 11269 IF( IBLK.EQ.1 ) THEN 11270 * 11271 * Jump IMBLOC + ( NPROW - 1 ) * MB rows 11272 * 11273 LCMTR = LCMTR - JMP( JMP_NPIMBLOC ) 11274 CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1, 11275 $ IB0 ) 11276 * 11277 ELSE 11278 * 11279 * Jump NPROW * MB rows 11280 * 11281 LCMTR = LCMTR - JMP( JMP_NPMB ) 11282 CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, 11283 $ IB0 ) 11284 * 11285 END IF 11286 * 11287 IB1( 1 ) = IB0( 1 ) 11288 IB1( 2 ) = IB0( 2 ) 11289 * 11290 350 CONTINUE 11291 * 11292 * Jump one column 11293 * 11294 CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 ) 11295 * 11296 IB1( 1 ) = IB0( 1 ) 11297 IB1( 2 ) = IB0( 2 ) 11298 IB2( 1 ) = IB0( 1 ) 11299 IB2( 2 ) = IB0( 2 ) 11300 * 11301 360 CONTINUE 11302 * 11303 JJ = JJ + JB 11304 * 11305 IF( JBLK.EQ.1 ) THEN 11306 * 11307 * Jump INBLOC + ( NPCOL - 1 ) * NB columns 11308 * 11309 LCMTC = LCMTC + JMP( JMP_NQINBLOC ) 11310 CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 ) 11311 * 11312 ELSE 11313 * 11314 * Jump NPCOL * NB columns 11315 * 11316 LCMTC = LCMTC + JMP( JMP_NQNB ) 11317 CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 ) 11318 * 11319 END IF 11320 * 11321 IB1( 1 ) = IB0( 1 ) 11322 IB1( 2 ) = IB0( 2 ) 11323 IB2( 1 ) = IB0( 1 ) 11324 IB2( 2 ) = IB0( 2 ) 11325 IB3( 1 ) = IB0( 1 ) 11326 IB3( 2 ) = IB0( 2 ) 11327 * 11328 370 CONTINUE 11329 * 11330 ELSE 11331 * 11332 * generate upper trapezoidal part 11333 * 11334 II = 1 11335 LCMTR = LCMT00 11336 * 11337 DO 450 IBLK = 1, MBLKS 11338 * 11339 IF( IBLK.EQ.1 ) THEN 11340 IB = IMBLOC 11341 UPP = IMBLOC - 1 11342 ELSE IF( IBLK.EQ.MBLKS ) THEN 11343 IB = LMBLOC 11344 UPP = MB - 1 11345 ELSE 11346 IB = MB 11347 UPP = MB - 1 11348 END IF 11349 * 11350 DO 440 IK = II, II + IB - 1 11351 * 11352 JJ = 1 11353 LCMTC = LCMTR 11354 * 11355 DO 430 JBLK = 1, NBLKS 11356 * 11357 IF( JBLK.EQ.1 ) THEN 11358 JB = INBLOC 11359 LOW = 1 - INBLOC 11360 ELSE IF( JBLK.EQ.NBLKS ) THEN 11361 JB = LNBLOC 11362 LOW = 1 - NB 11363 ELSE 11364 JB = NB 11365 LOW = 1 - NB 11366 END IF 11367 * 11368 * Blocks are IB by JB 11369 * 11370 IF( LCMTC.LT.LOW ) THEN 11371 * 11372 DO 380 JK = JJ, JJ + JB - 1 11373 DUMMY = DCMPLX( PB_DRAND( 0 ), 11374 $ -PB_DRAND( 0 ) ) 11375 380 CONTINUE 11376 * 11377 ELSE IF( LCMTC.LE.UPP ) THEN 11378 * 11379 ITMP = IK - II + 1 11380 MNB = MAX( 0, LCMTC ) 11381 * 11382 IF( ITMP.LE.MIN( MNB, IB ) ) THEN 11383 * 11384 DO 390 JK = JJ, JJ + JB - 1 11385 A( IK, JK ) = DCMPLX( PB_DRAND( 0 ), 11386 $ -PB_DRAND( 0 ) ) 11387 390 CONTINUE 11388 * 11389 ELSE IF( ( ITMP.GE.( MNB + 1 ) ) .AND. 11390 $ ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN 11391 * 11392 JTMP = JJ + ITMP - LCMTC - 1 11393 * 11394 DO 400 JK = JJ, JTMP - 1 11395 DUMMY = DCMPLX( PB_DRAND( 0 ), 11396 $ -PB_DRAND( 0 ) ) 11397 400 CONTINUE 11398 * 11399 IF( JTMP.LE.( JJ + JB - 1 ) ) THEN 11400 DUMMY = DCMPLX( PB_DRAND( 0 ), 11401 $ -PB_DRAND( 0 ) ) 11402 A( IK, JTMP ) = DCMPLX( DBLE( DUMMY ), 11403 $ ZERO ) 11404
