|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
00001 SUBROUTINE PVDIMCHK( ICTXT, NOUT, N, MATRIX, IX, JX, DESCX, INCX, 00002 $ INFO ) 00003 * 00004 * -- PBLAS test routine (version 2.0) -- 00005 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00006 * and University of California, Berkeley. 00007 * April 1, 1998 00008 * 00009 * .. Scalar Arguments .. 00010 CHARACTER*1 MATRIX 00011 INTEGER ICTXT, INCX, INFO, IX, JX, N, NOUT 00012 * .. 00013 * .. Array Arguments .. 00014 INTEGER DESCX( * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * PVDIMCHK checks the validity of the input test dimensions. In case of 00021 * an invalid parameter or discrepancy between the parameters, this rou- 00022 * tine displays error messages and returns an non-zero error code in 00023 * INFO. 00024 * 00025 * Notes 00026 * ===== 00027 * 00028 * A description vector is associated with each 2D block-cyclicly dis- 00029 * tributed matrix. This vector stores the information required to 00030 * establish the mapping between a matrix entry and its corresponding 00031 * process and memory location. 00032 * 00033 * In the following comments, the character _ should be read as 00034 * "of the distributed matrix". Let A be a generic term for any 2D 00035 * block cyclicly distributed matrix. Its description vector is DESCA: 00036 * 00037 * NOTATION STORED IN EXPLANATION 00038 * ---------------- --------------- ------------------------------------ 00039 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00040 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00041 * the NPROW x NPCOL BLACS process grid 00042 * A is distributed over. The context 00043 * itself is global, but the handle 00044 * (the integer value) may vary. 00045 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00046 * ted matrix A, M_A >= 0. 00047 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00048 * buted matrix A, N_A >= 0. 00049 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00050 * block of the matrix A, IMB_A > 0. 00051 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00052 * left block of the matrix A, 00053 * INB_A > 0. 00054 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00055 * bute the last M_A-IMB_A rows of A, 00056 * MB_A > 0. 00057 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00058 * bute the last N_A-INB_A columns of 00059 * A, NB_A > 0. 00060 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00061 * row of the matrix A is distributed, 00062 * NPROW > RSRC_A >= 0. 00063 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00064 * first column of A is distributed. 00065 * NPCOL > CSRC_A >= 0. 00066 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00067 * array storing the local blocks of 00068 * the distributed matrix A, 00069 * IF( Lc( 1, N_A ) > 0 ) 00070 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00071 * ELSE 00072 * LLD_A >= 1. 00073 * 00074 * Let K be the number of rows of a matrix A starting at the global in- 00075 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00076 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00077 * receive if these K rows were distributed over NPROW processes. If K 00078 * is the number of columns of a matrix A starting at the global index 00079 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00080 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00081 * these K columns were distributed over NPCOL processes. 00082 * 00083 * The values of Lr() and Lc() may be determined via a call to the func- 00084 * tion PB_NUMROC: 00085 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00086 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00087 * 00088 * Arguments 00089 * ========= 00090 * 00091 * ICTXT (local input) INTEGER 00092 * On entry, ICTXT specifies the BLACS context handle, indica- 00093 * ting the global context of the operation. The context itself 00094 * is global, but the value of ICTXT is local. 00095 * 00096 * NOUT (global input) INTEGER 00097 * On entry, NOUT specifies the unit number for the output file. 00098 * When NOUT is 6, output to screen, when NOUT is 0, output to 00099 * stderr. NOUT is only defined for process 0. 00100 * 00101 * MATRIX (global input) CHARACTER*1 00102 * On entry, MATRIX specifies the one character matrix identi- 00103 * fier. 00104 * 00105 * IX (global input) INTEGER 00106 * On entry, IX specifies X's global row index, which points to 00107 * the beginning of the submatrix sub( X ). 00108 * 00109 * JX (global input) INTEGER 00110 * On entry, JX specifies X's global column index, which points 00111 * to the beginning of the submatrix sub( X ). 00112 * 00113 * DESCX (global and local input) INTEGER array 00114 * On entry, DESCX is an integer array of dimension DLEN_. This 00115 * is the array descriptor for the matrix X. 00116 * 00117 * INCX (global input) INTEGER 00118 * On entry, INCX specifies the global increment for the 00119 * elements of X. Only two values of INCX are supported in 00120 * this version, namely 1 and M_X. INCX must not be zero. 00121 * 00122 * INFO (global output) INTEGER 00123 * On exit, when INFO is zero, no error has been detected, 00124 * otherwise an error has been detected. 00125 * 00126 * -- Written on April 1, 1998 by 00127 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00128 * 00129 * ===================================================================== 00130 * 00131 * .. Parameters .. 00132 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 00133 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 00134 $ RSRC_ 00135 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 00136 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 00137 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 00138 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 00139 * .. 00140 * .. Local Scalars .. 00141 INTEGER MYCOL, MYROW, NPCOL, NPROW 00142 * .. 00143 * .. External Subroutines .. 00144 EXTERNAL BLACS_GRIDINFO, IGSUM2D 00145 * .. 00146 * .. Executable Statements .. 00147 * 00148 INFO = 0 00149 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 00150 * 00151 IF( N.LT.0 ) THEN 00152 INFO = 1 00153 ELSE IF( N.EQ.0 ) THEN 00154 IF( DESCX( M_ ).LT.0 ) 00155 $ INFO = 1 00156 IF( DESCX( N_ ).LT.0 ) 00157 $ INFO = 1 00158 ELSE 00159 IF( INCX.EQ.DESCX( M_ ) .AND. 00160 $ DESCX( N_ ).LT.( JX+N-1 ) ) THEN 00161 INFO = 1 00162 ELSE IF( INCX.EQ.1 .AND. INCX.NE.DESCX( M_ ) .AND. 00163 $ DESCX( M_ ).LT.( IX+N-1 ) ) THEN 00164 INFO = 1 00165 ELSE 00166 IF( IX.GT.DESCX( M_ ) ) THEN 00167 INFO = 1 00168 ELSE IF( JX.GT.DESCX( N_ ) ) THEN 00169 INFO = 1 00170 END IF 00171 END IF 00172 END IF 00173 * 00174 * Check all processes for an error 00175 * 00176 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 ) 00177 * 00178 IF( INFO.NE.0 ) THEN 00179 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 00180 WRITE( NOUT, FMT = 9999 ) MATRIX 00181 WRITE( NOUT, FMT = 9998 ) N, MATRIX, IX, MATRIX, JX, MATRIX, 00182 $ INCX 00183 WRITE( NOUT, FMT = 9997 ) MATRIX, DESCX( M_ ), MATRIX, 00184 $ DESCX( N_ ) 00185 WRITE( NOUT, FMT = * ) 00186 END IF 00187 END IF 00188 * 00189 9999 FORMAT( 'Incompatible arguments for matrix ', A1, ':' ) 00190 9998 FORMAT( 'N = ', I6, ', I', A1, ' = ', I6, ', J', A1, ' = ', 00191 $ I6, ',INC', A1, ' = ', I6 ) 00192 9997 FORMAT( 'DESC', A1, '( M_ ) = ', I6, ', DESC', A1, '( N_ ) = ', 00193 $ I6, '.' ) 00194 * 00195 RETURN 00196 * 00197 * End of PVDIMCHK 00198 * 00199 END 00200 SUBROUTINE PMDIMCHK( ICTXT, NOUT, M, N, MATRIX, IA, JA, DESCA, 00201 $ INFO ) 00202 * 00203 * -- PBLAS test routine (version 2.0) -- 00204 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00205 * and University of California, Berkeley. 00206 * April 1, 1998 00207 * 00208 * .. Scalar Arguments .. 00209 CHARACTER*1 MATRIX 00210 INTEGER ICTXT, INFO, IA, JA, M, N, NOUT 00211 * .. 00212 * .. Array Arguments .. 00213 INTEGER DESCA( * ) 00214 * .. 00215 * 00216 * Purpose 00217 * ======= 00218 * 00219 * PMDIMCHK checks the validity of the input test dimensions. In case of 00220 * an invalid parameter or discrepancy between the parameters, this rou- 00221 * tine displays error messages and returns an non-zero error code in 00222 * INFO. 00223 * 00224 * Notes 00225 * ===== 00226 * 00227 * A description vector is associated with each 2D block-cyclicly dis- 00228 * tributed matrix. This vector stores the information required to 00229 * establish the mapping between a matrix entry and its corresponding 00230 * process and memory location. 00231 * 00232 * In the following comments, the character _ should be read as 00233 * "of the distributed matrix". Let A be a generic term for any 2D 00234 * block cyclicly distributed matrix. Its description vector is DESCA: 00235 * 00236 * NOTATION STORED IN EXPLANATION 00237 * ---------------- --------------- ------------------------------------ 00238 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00239 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00240 * the NPROW x NPCOL BLACS process grid 00241 * A is distributed over. The context 00242 * itself is global, but the handle 00243 * (the integer value) may vary. 00244 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00245 * ted matrix A, M_A >= 0. 00246 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00247 * buted matrix A, N_A >= 0. 00248 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00249 * block of the matrix A, IMB_A > 0. 00250 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00251 * left block of the matrix A, 00252 * INB_A > 0. 00253 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00254 * bute the last M_A-IMB_A rows of A, 00255 * MB_A > 0. 00256 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00257 * bute the last N_A-INB_A columns of 00258 * A, NB_A > 0. 00259 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00260 * row of the matrix A is distributed, 00261 * NPROW > RSRC_A >= 0. 00262 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00263 * first column of A is distributed. 00264 * NPCOL > CSRC_A >= 0. 00265 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00266 * array storing the local blocks of 00267 * the distributed matrix A, 00268 * IF( Lc( 1, N_A ) > 0 ) 00269 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00270 * ELSE 00271 * LLD_A >= 1. 00272 * 00273 * Let K be the number of rows of a matrix A starting at the global in- 00274 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00275 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00276 * receive if these K rows were distributed over NPROW processes. If K 00277 * is the number of columns of a matrix A starting at the global index 00278 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00279 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00280 * these K columns were distributed over NPCOL processes. 00281 * 00282 * The values of Lr() and Lc() may be determined via a call to the func- 00283 * tion PB_NUMROC: 00284 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00285 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00286 * 00287 * Arguments 00288 * ========= 00289 * 00290 * ICTXT (local input) INTEGER 00291 * On entry, ICTXT specifies the BLACS context handle, indica- 00292 * ting the global context of the operation. The context itself 00293 * is global, but the value of ICTXT is local. 00294 * 00295 * NOUT (global input) INTEGER 00296 * On entry, NOUT specifies the unit number for the output file. 00297 * When NOUT is 6, output to screen, when NOUT is 0, output to 00298 * stderr. NOUT is only defined for process 0. 00299 * 00300 * MATRIX (global input) CHARACTER*1 00301 * On entry, MATRIX specifies the one character matrix identi- 00302 * fier. 00303 * 00304 * IA (global input) INTEGER 00305 * On entry, IA specifies A's global row index, which points to 00306 * the beginning of the submatrix sub( A ). 00307 * 00308 * JA (global input) INTEGER 00309 * On entry, JA specifies A's global column index, which points 00310 * to the beginning of the submatrix sub( A ). 00311 * 00312 * DESCA (global and local input) INTEGER array 00313 * On entry, DESCA is an integer array of dimension DLEN_. This 00314 * is the array descriptor for the matrix A. 00315 * 00316 * INFO (global output) INTEGER 00317 * On exit, when INFO is zero, no error has been detected, 00318 * otherwise an error has been detected. 00319 * 00320 * -- Written on April 1, 1998 by 00321 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00322 * 00323 * ===================================================================== 00324 * 00325 * .. Parameters .. 00326 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 00327 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 00328 $ RSRC_ 00329 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 00330 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 00331 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 00332 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 00333 * .. 00334 * .. Local Scalars .. 00335 INTEGER MYCOL, MYROW, NPCOL, NPROW 00336 * .. 00337 * .. External Subroutines .. 00338 EXTERNAL BLACS_GRIDINFO, IGSUM2D 00339 * .. 00340 * .. Executable Statements .. 00341 * 00342 INFO = 0 00343 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 00344 * 00345 IF( ( M.LT.0 ).OR.( N.LT.0 ) ) THEN 00346 INFO = 1 00347 ELSE IF( ( M.EQ.0 ).OR.( N.EQ.0 ) )THEN 00348 IF( DESCA( M_ ).LT.0 ) 00349 $ INFO = 1 00350 IF( DESCA( N_ ).LT.0 ) 00351 $ INFO = 1 00352 ELSE 00353 IF( DESCA( M_ ).LT.( IA+M-1 ) ) 00354 $ INFO = 1 00355 IF( DESCA( N_ ).LT.( JA+N-1 ) ) 00356 $ INFO = 1 00357 END IF 00358 * 00359 * Check all processes for an error 00360 * 00361 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 ) 00362 * 00363 IF( INFO.NE.0 ) THEN 00364 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 00365 WRITE( NOUT, FMT = 9999 ) MATRIX 00366 WRITE( NOUT, FMT = 9998 ) M, N, MATRIX, IA, MATRIX, JA 00367 WRITE( NOUT, FMT = 9997 ) MATRIX, DESCA( M_ ), MATRIX, 00368 $ DESCA( N_ ) 00369 WRITE( NOUT, FMT = * ) 00370 END IF 00371 END IF 00372 * 00373 9999 FORMAT( 'Incompatible arguments for matrix ', A1, ':' ) 00374 9998 FORMAT( 'M = ', I6, ', N = ', I6, ', I', A1, ' = ', I6, 00375 $ ', J', A1, ' = ', I6 ) 00376 9997 FORMAT( 'DESC', A1, '( M_ ) = ', I6, ', DESC', A1, '( N_ ) = ', 00377 $ I6, '.' ) 00378 * 00379 RETURN 00380 * 00381 * End of PMDIMCHK 00382 * 00383 END 00384 SUBROUTINE PVDESCCHK( ICTXT, NOUT, MATRIX, DESCX, DTX, MX, NX, 00385 $ IMBX, INBX, MBX, NBX, RSRCX, CSRCX, INCX, 00386 $ MPX, NQX, IPREX, IMIDX, IPOSTX, IGAP, 00387 $ GAPMUL, INFO ) 00388 * 00389 * -- PBLAS test routine (version 2.0) -- 00390 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00391 * and University of California, Berkeley. 00392 * April 1, 1998 00393 * 00394 * .. Scalar Arguments .. 00395 CHARACTER*1 MATRIX 00396 INTEGER CSRCX, DTX, GAPMUL, ICTXT, IGAP, IMBX, IMIDX, 00397 $ INBX, INCX, INFO, IPOSTX, IPREX, MBX, MPX, MX, 00398 $ NBX, NOUT, NQX, NX, RSRCX 00399 * .. 00400 * .. Array Arguments .. 00401 INTEGER DESCX( * ) 00402 * .. 00403 * 00404 * Purpose 00405 * ======= 00406 * 00407 * PVDESCCHK checks the validity of the input test parameters and ini- 00408 * tializes the descriptor DESCX and the scalar variables MPX, NQX. In 00409 * case of an invalid parameter, this routine displays error messages 00410 * and return an non-zero error code in INFO. 00411 * 00412 * Notes 00413 * ===== 00414 * 00415 * A description vector is associated with each 2D block-cyclicly dis- 00416 * tributed matrix. This vector stores the information required to 00417 * establish the mapping between a matrix entry and its corresponding 00418 * process and memory location. 00419 * 00420 * In the following comments, the character _ should be read as 00421 * "of the distributed matrix". Let A be a generic term for any 2D 00422 * block cyclicly distributed matrix. Its description vector is DESCA: 00423 * 00424 * NOTATION STORED IN EXPLANATION 00425 * ---------------- --------------- ------------------------------------ 00426 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00427 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00428 * the NPROW x NPCOL BLACS process grid 00429 * A is distributed over. The context 00430 * itself is global, but the handle 00431 * (the integer value) may vary. 00432 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00433 * ted matrix A, M_A >= 0. 00434 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00435 * buted matrix A, N_A >= 0. 00436 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00437 * block of the matrix A, IMB_A > 0. 00438 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00439 * left block of the matrix A, 00440 * INB_A > 0. 00441 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00442 * bute the last M_A-IMB_A rows of A, 00443 * MB_A > 0. 00444 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00445 * bute the last N_A-INB_A columns of 00446 * A, NB_A > 0. 00447 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00448 * row of the matrix A is distributed, 00449 * NPROW > RSRC_A >= 0. 00450 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00451 * first column of A is distributed. 00452 * NPCOL > CSRC_A >= 0. 00453 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00454 * array storing the local blocks of 00455 * the distributed matrix A, 00456 * IF( Lc( 1, N_A ) > 0 ) 00457 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00458 * ELSE 00459 * LLD_A >= 1. 00460 * 00461 * Let K be the number of rows of a matrix A starting at the global in- 00462 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00463 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00464 * receive if these K rows were distributed over NPROW processes. If K 00465 * is the number of columns of a matrix A starting at the global index 00466 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00467 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00468 * these K columns were distributed over NPCOL processes. 00469 * 00470 * The values of Lr() and Lc() may be determined via a call to the func- 00471 * tion PB_NUMROC: 00472 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00473 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00474 * 00475 * Arguments 00476 * ========= 00477 * 00478 * ICTXT (local input) INTEGER 00479 * On entry, ICTXT specifies the BLACS context handle, indica- 00480 * ting the global context of the operation. The context itself 00481 * is global, but the value of ICTXT is local. 00482 * 00483 * NOUT (global input) INTEGER 00484 * On entry, NOUT specifies the unit number for the output file. 00485 * When NOUT is 6, output to screen, when NOUT is 0, output to 00486 * stderr. NOUT is only defined for process 0. 00487 * 00488 * MATRIX (global input) CHARACTER*1 00489 * On entry, MATRIX specifies the one character matrix identi- 00490 * fier. 00491 * 00492 * DESCX (global output) INTEGER array 00493 * On entry, DESCX is an array of dimension DLEN_. DESCX is the 00494 * array descriptor to be set. 00495 * 00496 * DTYPEX (global input) INTEGER 00497 * On entry, DTYPEX specifies the descriptor type. In this ver- 00498 * sion, DTYPEX must be BLOCK_CYCLIC_INB_2D. 00499 * 00500 * MX (global input) INTEGER 00501 * On entry, MX specifies the number of rows in the matrix. MX 00502 * must be at least zero. 00503 * 00504 * NX (global input) INTEGER 00505 * On entry, NX specifies the number of columns in the matrix. 00506 * NX must be at least zero. 00507 * 00508 * IMBX (global input) INTEGER 00509 * On entry, IMBX specifies the row blocking factor used to dis- 00510 * tribute the first IMBX rows of the matrix. IMBX must be at 00511 * least one. 00512 * 00513 * INBX (global input) INTEGER 00514 * On entry, INBX specifies the column blocking factor used to 00515 * distribute the first INBX columns of the matrix. INBX must 00516 * be at least one. 00517 * 00518 * MBX (global input) INTEGER 00519 * On entry, MBX specifies the row blocking factor used to dis- 00520 * tribute the rows of the matrix. MBX must be at least one. 00521 * 00522 * NBX (global input) INTEGER 00523 * On entry, NBX specifies the column blocking factor used to 00524 * distribute the columns of the matrix. NBX must be at least 00525 * one. 00526 * 00527 * RSRCX (global input) INTEGER 00528 * On entry, RSRCX specifies the process row in which the first 00529 * row of the matrix resides. When RSRCX is -1, the matrix is 00530 * row replicated, otherwise RSCRX must be at least zero and 00531 * strictly less than NPROW. 00532 * 00533 * CSRCX (global input) INTEGER 00534 * On entry, CSRCX specifies the process column in which the 00535 * first column of the matrix resides. When CSRCX is -1, the 00536 * matrix is column replicated, otherwise CSCRX must be at least 00537 * zero and strictly less than NPCOL. 00538 * 00539 * INCX (global input) INTEGER 00540 * On entry, INCX specifies the global vector increment. INCX 00541 * must be one or MX. 00542 * 00543 * MPX (local output) INTEGER 00544 * On exit, MPX is Lr( 1, MX ). 00545 * 00546 * NQX (local output) INTEGER 00547 * On exit, NQX is Lc( 1, NX ). 00548 * 00549 * IPREX (local output) INTEGER 00550 * On exit, IPREX specifies the size of the guard zone to put 00551 * before the start of the local padded array. 00552 * 00553 * IMIDX (local output) INTEGER 00554 * On exit, IMIDX specifies the ldx-gap of the guard zone to 00555 * put after each column of the local padded array. 00556 * 00557 * IPOSTX (local output) INTEGER 00558 * On exit, IPOSTX specifies the size of the guard zone to put 00559 * after the local padded array. 00560 * 00561 * IGAP (global input) INTEGER 00562 * On entry, IGAP specifies the size of the ldx-gap. 00563 * 00564 * GAPMUL (global input) INTEGER 00565 * On entry, GAPMUL is a constant factor controlling the size 00566 * of the pre- and post guardzone. 00567 * 00568 * INFO (global output) INTEGER 00569 * On exit, when INFO is zero, no error has been detected, 00570 * otherwise an error has been detected. 00571 * 00572 * -- Written on April 1, 1998 by 00573 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00574 * 00575 * ===================================================================== 00576 * 00577 * .. Parameters .. 00578 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 00579 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 00580 $ RSRC_ 00581 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 00582 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 00583 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 00584 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 00585 * .. 00586 * .. Local Scalars .. 00587 INTEGER LLDX, MYCOL, MYROW, NPCOL, NPROW 00588 * .. 00589 * .. External Subroutines .. 00590 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_DESCINIT2 00591 * .. 00592 * .. External Functions .. 00593 INTEGER PB_NUMROC 00594 EXTERNAL PB_NUMROC 00595 * .. 00596 * .. Intrinsic Functions .. 00597 INTRINSIC MAX 00598 * .. 00599 * .. Executable Statements .. 00600 * 00601 INFO = 0 00602 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 00603 * 00604 * Verify descriptor type DTYPE_ 00605 * 00606 IF( DTX.NE.BLOCK_CYCLIC_2D_INB ) THEN 00607 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00608 $ WRITE( NOUT, FMT = 9999 ) MATRIX, 'DTYPE', MATRIX, DTX, 00609 $ BLOCK_CYCLIC_2D_INB 00610 INFO = 1 00611 END IF 00612 * 00613 * Verify global matrix dimensions (M_,N_) are correct 00614 * 00615 IF( MX.LT.0 ) THEN 00616 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00617 $ WRITE( NOUT, FMT = 9998 ) MATRIX, 'M', MATRIX, MX 00618 INFO = 1 00619 ELSE IF( NX.LT.0 ) THEN 00620 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00621 $ WRITE( NOUT, FMT = 9997 ) MATRIX, 'N', MATRIX, NX 00622 INFO = 1 00623 END IF 00624 * 00625 * Verify if blocking factors (IMB_, INB_) are correct 00626 * 00627 IF( IMBX.LT.1 ) THEN 00628 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00629 $ WRITE( NOUT, FMT = 9996 ) MATRIX, 'IMB', MATRIX, IMBX 00630 INFO = 1 00631 ELSE IF( INBX.LT.1 ) THEN 00632 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00633 $ WRITE( NOUT, FMT = 9995 ) MATRIX, 'INB', MATRIX, INBX 00634 INFO = 1 00635 END IF 00636 * 00637 * Verify if blocking factors (MB_, NB_) are correct 00638 * 00639 IF( MBX.LT.1 ) THEN 00640 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00641 $ WRITE( NOUT, FMT = 9994 ) MATRIX, 'MB', MATRIX, MBX 00642 INFO = 1 00643 ELSE IF( NBX.LT.1 ) THEN 00644 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00645 $ WRITE( NOUT, FMT = 9993 ) MATRIX, 'NB', MATRIX, NBX 00646 INFO = 1 00647 END IF 00648 * 00649 * Verify if origin process coordinates (RSRC_, CSRC_) are valid 00650 * 00651 IF( RSRCX.LT.-1 .OR. RSRCX.GE.NPROW ) THEN 00652 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 00653 WRITE( NOUT, FMT = 9992 ) MATRIX 00654 WRITE( NOUT, FMT = 9990 ) 'RSRC', MATRIX, RSRCX, NPROW 00655 END IF 00656 INFO = 1 00657 ELSE IF( CSRCX.LT.-1 .OR. CSRCX.GE.NPCOL ) THEN 00658 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 00659 WRITE( NOUT, FMT = 9991 ) MATRIX 00660 WRITE( NOUT, FMT = 9990 ) 'CSRC', MATRIX, CSRCX, NPCOL 00661 END IF 00662 INFO = 1 00663 END IF 00664 * 00665 * Check input increment value 00666 * 00667 IF( INCX.NE.1 .AND. INCX.NE.MX ) THEN 00668 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 00669 WRITE( NOUT, FMT = 9989 ) MATRIX 00670 WRITE( NOUT, FMT = 9988 ) 'INC', MATRIX, INCX, MATRIX, MX 00671 END IF 00672 INFO = 1 00673 END IF 00674 * 00675 * Check all processes for an error 00676 * 00677 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 ) 00678 * 00679 IF( INFO.NE.0 ) THEN 00680 * 00681 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 00682 WRITE( NOUT, FMT = 9987 ) MATRIX 00683 WRITE( NOUT, FMT = * ) 00684 END IF 00685 * 00686 ELSE 00687 * 00688 * Compute local testing leading dimension 00689 * 00690 MPX = PB_NUMROC( MX, 1, IMBX, MBX, MYROW, RSRCX, NPROW ) 00691 NQX = PB_NUMROC( NX, 1, INBX, NBX, MYCOL, CSRCX, NPCOL ) 00692 IPREX = MAX( GAPMUL*NBX, MPX ) 00693 IMIDX = IGAP 00694 IPOSTX = MAX( GAPMUL*NBX, NQX ) 00695 LLDX = MAX( 1, MPX ) + IMIDX 00696 * 00697 CALL PB_DESCINIT2( DESCX, MX, NX, IMBX, INBX, MBX, NBX, RSRCX, 00698 $ CSRCX, ICTXT, LLDX, INFO ) 00699 * 00700 * Check all processes for an error 00701 * 00702 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 ) 00703 * 00704 IF( INFO.NE.0 ) THEN 00705 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 00706 WRITE( NOUT, FMT = 9987 ) MATRIX 00707 WRITE( NOUT, FMT = * ) 00708 END IF 00709 END IF 00710 * 00711 END IF 00712 * 00713 9999 FORMAT( 2X, '>> Invalid matrix ', A1, ' descriptor type ', A5, A1, 00714 $ ': ', I6, ' should be ', I3, '.' ) 00715 9998 FORMAT( 2X, '>> Invalid matrix ', A1, ' row dimension ', A1, A1, 00716 $ ': ', I6, ' should be at least 1.' ) 00717 9997 FORMAT( 2X, '>> Invalid matrix ', A1, ' column dimension ', A1, 00718 $ A1, ': ', I6, ' should be at least 1.' ) 00719 9996 FORMAT( 2X, '>> Invalid matrix ', A1, ' first row block size ', 00720 $ A3, A1, ': ', I6, ' should be at least 1.' ) 00721 9995 FORMAT( 2X, '>> Invalid matrix ', A1, ' first column block size ', 00722 $ A3, A1,': ', I6, ' should be at least 1.' ) 00723 9994 FORMAT( 2X, '>> Invalid matrix ', A1, ' row block size ', A2, A1, 00724 $ ': ', I6, ' should be at least 1.' ) 00725 9993 FORMAT( 2X, '>> Invalid matrix ', A1, ' column block size ', A2, 00726 $ A1,': ', I6, ' should be at least 1.' ) 00727 9992 FORMAT( 2X, '>> Invalid matrix ', A1, ' row process source:' ) 00728 9991 FORMAT( 2X, '>> Invalid matrix ', A1, ' column process source:' ) 00729 9990 FORMAT( 2X, '>> ', A4, A1, '= ', I6, ' should be >= -1 and < ', 00730 $ I6, '.' ) 00731 9989 FORMAT( 2X, '>> Invalid vector ', A1, ' increment:' ) 00732 9988 FORMAT( 2X, '>> ', A3, A1, '= ', I6, ' should be 1 or M', A1, 00733 $ ' = ', I6, '.' ) 00734 9987 FORMAT( 2X, '>> Invalid matrix ', A1, ' descriptor: going on to ', 00735 $ 'next test case.' ) 00736 * 00737 RETURN 00738 * 00739 * End of PVDESCCHK 00740 * 00741 END 00742 SUBROUTINE PMDESCCHK( ICTXT, NOUT, MATRIX, DESCA, DTA, MA, NA, 00743 $ IMBA, INBA, MBA, NBA, RSRCA, CSRCA, MPA, 00744 $ NQA, IPREA, IMIDA, IPOSTA, IGAP, GAPMUL, 00745 $ INFO ) 00746 * 00747 * -- PBLAS test routine (version 2.0) -- 00748 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00749 * and University of California, Berkeley. 00750 * April 1, 1998 00751 * 00752 * .. Scalar Arguments .. 00753 CHARACTER*1 MATRIX 00754 INTEGER CSRCA, DTA, GAPMUL, ICTXT, IGAP, IMBA, IMIDA, 00755 $ INBA, INFO, IPOSTA, IPREA, MA, MBA, MPA, NA, 00756 $ NBA, NOUT, NQA, RSRCA 00757 * .. 00758 * .. Array Arguments .. 00759 INTEGER DESCA( * ) 00760 * .. 00761 * 00762 * Purpose 00763 * ======= 00764 * 00765 * PMDESCCHK checks the validity of the input test parameters and ini- 00766 * tializes the descriptor DESCA and the scalar variables MPA, NQA. In 00767 * case of an invalid parameter, this routine displays error messages 00768 * and return an non-zero error code in INFO. 00769 * 00770 * Notes 00771 * ===== 00772 * 00773 * A description vector is associated with each 2D block-cyclicly dis- 00774 * tributed matrix. This vector stores the information required to 00775 * establish the mapping between a matrix entry and its corresponding 00776 * process and memory location. 00777 * 00778 * In the following comments, the character _ should be read as 00779 * "of the distributed matrix". Let A be a generic term for any 2D 00780 * block cyclicly distributed matrix. Its description vector is DESCA: 00781 * 00782 * NOTATION STORED IN EXPLANATION 00783 * ---------------- --------------- ------------------------------------ 00784 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 00785 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 00786 * the NPROW x NPCOL BLACS process grid 00787 * A is distributed over. The context 00788 * itself is global, but the handle 00789 * (the integer value) may vary. 00790 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 00791 * ted matrix A, M_A >= 0. 00792 * N_A (global) DESCA( N_ ) The number of columns in the distri- 00793 * buted matrix A, N_A >= 0. 00794 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 00795 * block of the matrix A, IMB_A > 0. 00796 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 00797 * left block of the matrix A, 00798 * INB_A > 0. 00799 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 00800 * bute the last M_A-IMB_A rows of A, 00801 * MB_A > 0. 00802 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 00803 * bute the last N_A-INB_A columns of 00804 * A, NB_A > 0. 00805 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 00806 * row of the matrix A is distributed, 00807 * NPROW > RSRC_A >= 0. 00808 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 00809 * first column of A is distributed. 00810 * NPCOL > CSRC_A >= 0. 00811 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 00812 * array storing the local blocks of 00813 * the distributed matrix A, 00814 * IF( Lc( 1, N_A ) > 0 ) 00815 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 00816 * ELSE 00817 * LLD_A >= 1. 00818 * 00819 * Let K be the number of rows of a matrix A starting at the global in- 00820 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 00821 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 00822 * receive if these K rows were distributed over NPROW processes. If K 00823 * is the number of columns of a matrix A starting at the global index 00824 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 00825 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 00826 * these K columns were distributed over NPCOL processes. 00827 * 00828 * The values of Lr() and Lc() may be determined via a call to the func- 00829 * tion PB_NUMROC: 00830 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 00831 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 00832 * 00833 * Arguments 00834 * ========= 00835 * 00836 * ICTXT (local input) INTEGER 00837 * On entry, ICTXT specifies the BLACS context handle, indica- 00838 * ting the global context of the operation. The context itself 00839 * is global, but the value of ICTXT is local. 00840 * 00841 * NOUT (global input) INTEGER 00842 * On entry, NOUT specifies the unit number for the output file. 00843 * When NOUT is 6, output to screen, when NOUT is 0, output to 00844 * stderr. NOUT is only defined for process 0. 00845 * 00846 * MATRIX (global input) CHARACTER*1 00847 * On entry, MATRIX specifies the one character matrix identi- 00848 * fier. 00849 * 00850 * DESCA (global output) INTEGER array 00851 * On entry, DESCA is an array of dimension DLEN_. DESCA is the 00852 * array descriptor to be set. 00853 * 00854 * DTYPEA (global input) INTEGER 00855 * On entry, DTYPEA specifies the descriptor type. In this ver- 00856 * sion, DTYPEA must be BLOCK_CYCLIC_INB_2D. 00857 * 00858 * MA (global input) INTEGER 00859 * On entry, MA specifies the number of rows in the matrix. MA 00860 * must be at least zero. 00861 * 00862 * NA (global input) INTEGER 00863 * On entry, NA specifies the number of columns in the matrix. 00864 * NA must be at least zero. 00865 * 00866 * IMBA (global input) INTEGER 00867 * On entry, IMBA specifies the row blocking factor used to dis- 00868 * tribute the first IMBA rows of the matrix. IMBA must be at 00869 * least one. 00870 * 00871 * INBA (global input) INTEGER 00872 * On entry, INBA specifies the column blocking factor used to 00873 * distribute the first INBA columns of the matrix. INBA must 00874 * be at least one. 00875 * 00876 * MBA (global input) INTEGER 00877 * On entry, MBA specifies the row blocking factor used to dis- 00878 * tribute the rows of the matrix. MBA must be at least one. 00879 * 00880 * NBA (global input) INTEGER 00881 * On entry, NBA specifies the column blocking factor used to 00882 * distribute the columns of the matrix. NBA must be at least 00883 * one. 00884 * 00885 * RSRCA (global input) INTEGER 00886 * On entry, RSRCA specifies the process row in which the first 00887 * row of the matrix resides. When RSRCA is -1, the matrix is 00888 * row replicated, otherwise RSCRA must be at least zero and 00889 * strictly less than NPROW. 00890 * 00891 * CSRCA (global input) INTEGER 00892 * On entry, CSRCA specifies the process column in which the 00893 * first column of the matrix resides. When CSRCA is -1, the 00894 * matrix is column replicated, otherwise CSCRA must be at least 00895 * zero and strictly less than NPCOL. 00896 * 00897 * MPA (local output) INTEGER 00898 * On exit, MPA is Lr( 1, MA ). 00899 * 00900 * NQA (local output) INTEGER 00901 * On exit, NQA is Lc( 1, NA ). 00902 * 00903 * IPREA (local output) INTEGER 00904 * On exit, IPREA specifies the size of the guard zone to put 00905 * before the start of the local padded array. 00906 * 00907 * IMIDA (local output) INTEGER 00908 * On exit, IMIDA specifies the lda-gap of the guard zone to 00909 * put after each column of the local padded array. 00910 * 00911 * IPOSTA (local output) INTEGER 00912 * On exit, IPOSTA specifies the size of the guard zone to put 00913 * after the local padded array. 00914 * 00915 * IGAP (global input) INTEGER 00916 * On entry, IGAP specifies the size of the lda-gap. 00917 * 00918 * GAPMUL (global input) INTEGER 00919 * On entry, GAPMUL is a constant factor controlling the size 00920 * of the pre- and post guardzone. 00921 * 00922 * INFO (global output) INTEGER 00923 * On exit, when INFO is zero, no error has been detected, 00924 * otherwise an error has been detected. 00925 * 00926 * -- Written on April 1, 1998 by 00927 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00928 * 00929 * ===================================================================== 00930 * 00931 * .. Parameters .. 00932 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 00933 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 00934 $ RSRC_ 00935 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 00936 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 00937 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 00938 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 00939 * .. 00940 * .. Local Scalars .. 00941 INTEGER LLDA, MYCOL, MYROW, NPCOL, NPROW 00942 * .. 00943 * .. External Subroutines .. 00944 EXTERNAL BLACS_GRIDINFO, IGSUM2D, PB_DESCINIT2 00945 * .. 00946 * .. External Functions .. 00947 INTEGER PB_NUMROC 00948 EXTERNAL PB_NUMROC 00949 * .. 00950 * .. Intrinsic Functions .. 00951 INTRINSIC MAX 00952 * .. 00953 * .. Executable Statements .. 00954 * 00955 INFO = 0 00956 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 00957 * 00958 * Verify descriptor type DTYPE_ 00959 * 00960 IF( DTA.NE.BLOCK_CYCLIC_2D_INB ) THEN 00961 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00962 $ WRITE( NOUT, FMT = 9999 ) MATRIX, 'DTYPE', MATRIX, DTA, 00963 $ BLOCK_CYCLIC_2D_INB 00964 INFO = 1 00965 END IF 00966 * 00967 * Verify global matrix dimensions (M_,N_) are correct 00968 * 00969 IF( MA.LT.0 ) THEN 00970 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00971 $ WRITE( NOUT, FMT = 9998 ) MATRIX, 'M', MATRIX, MA 00972 INFO = 1 00973 ELSE IF( NA.LT.0 ) THEN 00974 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00975 $ WRITE( NOUT, FMT = 9997 ) MATRIX, 'N', MATRIX, NA 00976 INFO = 1 00977 END IF 00978 * 00979 * Verify if blocking factors (IMB_, INB_) are correct 00980 * 00981 IF( IMBA.LT.1 ) THEN 00982 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00983 $ WRITE( NOUT, FMT = 9996 ) MATRIX, 'IMB', MATRIX, IMBA 00984 INFO = 1 00985 ELSE IF( INBA.LT.1 ) THEN 00986 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00987 $ WRITE( NOUT, FMT = 9995 ) MATRIX, 'INB', MATRIX, INBA 00988 INFO = 1 00989 END IF 00990 * 00991 * Verify if blocking factors (MB_, NB_) are correct 00992 * 00993 IF( MBA.LT.1 ) THEN 00994 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00995 $ WRITE( NOUT, FMT = 9994 ) MATRIX, 'MB', MATRIX, MBA 00996 INFO = 1 00997 ELSE IF( NBA.LT.1 ) THEN 00998 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 00999 $ WRITE( NOUT, FMT = 9993 ) MATRIX, 'NB', MATRIX, NBA 01000 INFO = 1 01001 END IF 01002 * 01003 * Verify if origin process coordinates (RSRC_, CSRC_) are valid 01004 * 01005 IF( RSRCA.LT.-1 .OR. RSRCA.GE.NPROW ) THEN 01006 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 01007 WRITE( NOUT, FMT = 9992 ) MATRIX 01008 WRITE( NOUT, FMT = 9990 ) 'RSRC', MATRIX, RSRCA, NPROW 01009 END IF 01010 INFO = 1 01011 ELSE IF( CSRCA.LT.-1 .OR. CSRCA.GE.NPCOL ) THEN 01012 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 01013 WRITE( NOUT, FMT = 9991 ) MATRIX 01014 WRITE( NOUT, FMT = 9990 ) 'CSRC', MATRIX, CSRCA, NPCOL 01015 END IF 01016 INFO = 1 01017 END IF 01018 * 01019 * Check all processes for an error 01020 * 01021 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 ) 01022 * 01023 IF( INFO.NE.0 ) THEN 01024 * 01025 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 01026 WRITE( NOUT, FMT = 9989 ) MATRIX 01027 WRITE( NOUT, FMT = * ) 01028 END IF 01029 * 01030 ELSE 01031 * 01032 * Compute local testing leading dimension 01033 * 01034 MPA = PB_NUMROC( MA, 1, IMBA, MBA, MYROW, RSRCA, NPROW ) 01035 NQA = PB_NUMROC( NA, 1, INBA, NBA, MYCOL, CSRCA, NPCOL ) 01036 IPREA = MAX( GAPMUL*NBA, MPA ) 01037 IMIDA = IGAP 01038 IPOSTA = MAX( GAPMUL*NBA, NQA ) 01039 LLDA = MAX( 1, MPA ) + IMIDA 01040 * 01041 CALL PB_DESCINIT2( DESCA, MA, NA, IMBA, INBA, MBA, NBA, RSRCA, 01042 $ CSRCA, ICTXT, LLDA, INFO ) 01043 * 01044 * Check all processes for an error 01045 * 01046 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 ) 01047 * 01048 IF( INFO.NE.0 ) THEN 01049 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 01050 WRITE( NOUT, FMT = 9989 ) MATRIX 01051 WRITE( NOUT, FMT = * ) 01052 END IF 01053 END IF 01054 * 01055 END IF 01056 * 01057 9999 FORMAT( 2X, '>> Invalid matrix ', A1, ' descriptor type ', A5, A1, 01058 $ ': ', I6, ' should be ', I3, '.' ) 01059 9998 FORMAT( 2X, '>> Invalid matrix ', A1, ' row dimension ', A1, A1, 01060 $ ': ', I6, ' should be at least 1.' ) 01061 9997 FORMAT( 2X, '>> Invalid matrix ', A1, ' column dimension ', A1, 01062 $ A1, ': ', I6, ' should be at least 1.' ) 01063 9996 FORMAT( 2X, '>> Invalid matrix ', A1, ' first row block size ', 01064 $ A3, A1, ': ', I6, ' should be at least 1.' ) 01065 9995 FORMAT( 2X, '>> Invalid matrix ', A1, ' first column block size ', 01066 $ A3, A1,': ', I6, ' should be at least 1.' ) 01067 9994 FORMAT( 2X, '>> Invalid matrix ', A1, ' row block size ', A2, A1, 01068 $ ': ', I6, ' should be at least 1.' ) 01069 9993 FORMAT( 2X, '>> Invalid matrix ', A1, ' column block size ', A2, 01070 $ A1,': ', I6, ' should be at least 1.' ) 01071 9992 FORMAT( 2X, '>> Invalid matrix ', A1, ' row process source:' ) 01072 9991 FORMAT( 2X, '>> Invalid matrix ', A1, ' column process source:' ) 01073 9990 FORMAT( 2X, '>> ', A4, A1, '= ', I6, ' should be >= -1 and < ', 01074 $ I6, '.' ) 01075 9989 FORMAT( 2X, '>> Invalid matrix ', A1, ' descriptor: going on to ', 01076 $ 'next test case.' ) 01077 * 01078 RETURN 01079 * 01080 * End of PMDESCCHK 01081 * 01082 END 01083 SUBROUTINE PCHKPBE( ICTXT, NOUT, SNAME, INFOT ) 01084 * 01085 * -- PBLAS test routine (version 2.0) -- 01086 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01087 * and University of California, Berkeley. 01088 * April 1, 1998 01089 * 01090 * .. Scalar Arguments .. 01091 INTEGER ICTXT, INFOT, NOUT 01092 CHARACTER*(*) SNAME 01093 * .. 01094 * 01095 * Purpose 01096 * ======= 01097 * 01098 * PCHKPBE tests whether a PBLAS routine has detected an error when it 01099 * should. This routine does a global operation to ensure all processes 01100 * have detected this error. If an error has been detected an error 01101 * message is displayed. 01102 * 01103 * Notes 01104 * ===== 01105 * 01106 * A description vector is associated with each 2D block-cyclicly dis- 01107 * tributed matrix. This vector stores the information required to 01108 * establish the mapping between a matrix entry and its corresponding 01109 * process and memory location. 01110 * 01111 * In the following comments, the character _ should be read as 01112 * "of the distributed matrix". Let A be a generic term for any 2D 01113 * block cyclicly distributed matrix. Its description vector is DESCA: 01114 * 01115 * NOTATION STORED IN EXPLANATION 01116 * ---------------- --------------- ------------------------------------ 01117 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 01118 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 01119 * the NPROW x NPCOL BLACS process grid 01120 * A is distributed over. The context 01121 * itself is global, but the handle 01122 * (the integer value) may vary. 01123 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 01124 * ted matrix A, M_A >= 0. 01125 * N_A (global) DESCA( N_ ) The number of columns in the distri- 01126 * buted matrix A, N_A >= 0. 01127 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 01128 * block of the matrix A, IMB_A > 0. 01129 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 01130 * left block of the matrix A, 01131 * INB_A > 0. 01132 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 01133 * bute the last M_A-IMB_A rows of A, 01134 * MB_A > 0. 01135 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 01136 * bute the last N_A-INB_A columns of 01137 * A, NB_A > 0. 01138 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 01139 * row of the matrix A is distributed, 01140 * NPROW > RSRC_A >= 0. 01141 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 01142 * first column of A is distributed. 01143 * NPCOL > CSRC_A >= 0. 01144 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01145 * array storing the local blocks of 01146 * the distributed matrix A, 01147 * IF( Lc( 1, N_A ) > 0 ) 01148 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01149 * ELSE 01150 * LLD_A >= 1. 01151 * 01152 * Let K be the number of rows of a matrix A starting at the global in- 01153 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01154 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01155 * receive if these K rows were distributed over NPROW processes. If K 01156 * is the number of columns of a matrix A starting at the global index 01157 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01158 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01159 * these K columns were distributed over NPCOL processes. 01160 * 01161 * The values of Lr() and Lc() may be determined via a call to the func- 01162 * tion PB_NUMROC: 01163 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01164 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01165 * 01166 * Arguments 01167 * ========= 01168 * 01169 * ICTXT (local input) INTEGER 01170 * On entry, ICTXT specifies the BLACS context handle, indica- 01171 * ting the global context of the operation. The context itself 01172 * is global, but the value of ICTXT is local. 01173 * 01174 * NOUT (global input) INTEGER 01175 * On entry, NOUT specifies the unit number for the output file. 01176 * When NOUT is 6, output to screen, when NOUT is 0, output to 01177 * stderr. NOUT is only defined for process 0. 01178 * 01179 * SNAME (global input) CHARACTER*(*) 01180 * On entry, SNAME specifies the subroutine name calling this 01181 * subprogram. 01182 * 01183 * INFOT (global input) INTEGER 01184 * On entry, INFOT specifies the position of the wrong argument. 01185 * If the PBLAS error handler is called, INFO will be set to 01186 * -INFOT. This routine verifies if the error was reported by 01187 * all processes by doing a global sum, and assert the result to 01188 * be NPROW * NPCOL. 01189 * 01190 * -- Written on April 1, 1998 by 01191 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01192 * 01193 * ===================================================================== 01194 * 01195 * .. Local Scalars .. 01196 INTEGER GERR, MYCOL, MYROW, NPCOL, NPROW 01197 * .. 01198 * .. External Subroutines .. 01199 EXTERNAL BLACS_GRIDINFO, IGSUM2D 01200 * .. 01201 * .. Common Blocks .. 01202 INTEGER INFO, NBLOG 01203 COMMON /INFOC/INFO, NBLOG 01204 * .. 01205 * .. Executable Statements .. 01206 * 01207 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 01208 * 01209 GERR = 0 01210 IF( INFO.NE.-INFOT ) 01211 $ GERR = 1 01212 * 01213 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, GERR, 1, -1, 0 ) 01214 * 01215 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 01216 IF( GERR.EQ.( NPROW * NPCOL ) ) THEN 01217 WRITE( NOUT, FMT = 9999 ) SNAME, INFO, -INFOT 01218 END IF 01219 END IF 01220 * 01221 9999 FORMAT( 1X, A7, ': *** ERROR *** ERROR CODE RETURNED = ', I6, 01222 $ ' SHOULD HAVE BEEN ', I6 ) 01223 * 01224 RETURN 01225 * 01226 * End of PCHKPBE 01227 * 01228 END 01229 REAL FUNCTION PSDIFF( X, Y ) 01230 * 01231 * -- PBLAS test routine (version 2.0) -- 01232 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01233 * and University of California, Berkeley. 01234 * April 1, 1998 01235 * 01236 * .. Scalar Arguments .. 01237 REAL X, Y 01238 * .. 01239 * 01240 * Purpose 01241 * ======= 01242 * 01243 * PSDIFF returns the scalar difference X - Y. Similarly to the 01244 * BLAS tester, this routine allows for the possibility of computing a 01245 * more accurate difference if necessary. 01246 * 01247 * Arguments 01248 * ========= 01249 * 01250 * X (input) REAL 01251 * The real scalar X. 01252 * 01253 * Y (input) REAL 01254 * The real scalar Y. 01255 * 01256 * ===================================================================== 01257 * 01258 * .. Executable Statements .. 01259 * 01260 PSDIFF = X - Y 01261 * 01262 RETURN 01263 * 01264 * End of PSDIFF 01265 * 01266 END 01267 * 01268 DOUBLE PRECISION FUNCTION PDDIFF( X, Y ) 01269 * 01270 * -- PBLAS test routine (version 2.0) -- 01271 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01272 * and University of California, Berkeley. 01273 * April 1, 1998 01274 * 01275 * .. Scalar Arguments .. 01276 DOUBLE PRECISION X, Y 01277 * .. 01278 * 01279 * Purpose 01280 * ======= 01281 * 01282 * PDDIFF returns the scalar difference X - Y. Similarly to the 01283 * BLAS tester, this routine allows for the possibility of computing a 01284 * more accurate difference if necessary. 01285 * 01286 * Arguments 01287 * ========= 01288 * 01289 * X (input) DOUBLE PRECISION 01290 * The real scalar X. 01291 * 01292 * Y (input) DOUBLE PRECISION 01293 * The real scalar Y. 01294 * 01295 * ===================================================================== 01296 * 01297 * .. Executable Statements .. 01298 * 01299 PDDIFF = X - Y 01300 * 01301 RETURN 01302 * 01303 * End of PDDIFF 01304 * 01305 END 01306 SUBROUTINE PXERBLA( ICTXT, SRNAME, INFO ) 01307 * 01308 * -- PBLAS test routine (version 2.0) -- 01309 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01310 * and University of California, Berkeley. 01311 * April 1, 1998 01312 * 01313 * .. Scalar Arguments .. 01314 INTEGER ICTXT, INFO 01315 * .. 01316 * .. Array Arguments .. 01317 CHARACTER*(*) SRNAME 01318 * .. 01319 * 01320 * Purpose 01321 * ======= 01322 * 01323 * PXERBLA is an error handler for the ScaLAPACK routines. It is called 01324 * by a ScaLAPACK routine if an input parameter has an invalid value. A 01325 * message is printed. Installers may consider modifying this routine in 01326 * order to call system-specific exception-handling facilities. 01327 * 01328 * Arguments 01329 * ========= 01330 * 01331 * ICTXT (local input) INTEGER 01332 * On entry, ICTXT specifies the BLACS context handle, indica- 01333 * ting the global context of the operation. The context itself 01334 * is global, but the value of ICTXT is local. 01335 * 01336 * SRNAME (global input) CHARACTER*(*) 01337 * On entry, SRNAME specifies the name of the routine which cal- 01338 * ling PXERBLA. 01339 * 01340 * INFO (global input) INTEGER 01341 * On entry, INFO specifies the position of the invalid parame- 01342 * ter in the parameter list of the calling routine. 01343 * 01344 * -- Written on April 1, 1998 by 01345 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01346 * 01347 * ===================================================================== 01348 * 01349 * .. Local Scalars .. 01350 INTEGER MYCOL, MYROW, NPCOL, NPROW 01351 * .. 01352 * .. External Subroutines .. 01353 EXTERNAL BLACS_GRIDINFO 01354 * .. 01355 * .. Executable Statements .. 01356 * 01357 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 01358 * 01359 WRITE( *, FMT = 9999 ) MYROW, MYCOL, SRNAME, INFO 01360 * 01361 9999 FORMAT( '{', I5, ',', I5, '}: On entry to ', A, 01362 $ ' parameter number ', I4, ' had an illegal value' ) 01363 * 01364 RETURN 01365 * 01366 * End of PXERBLA 01367 * 01368 END 01369 LOGICAL FUNCTION LSAME( CA, CB ) 01370 * 01371 * -- LAPACK auxiliary routine (version 2.1) -- 01372 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 01373 * Courant Institute, Argonne National Lab, and Rice University 01374 * September 30, 1994 01375 * 01376 * .. Scalar Arguments .. 01377 CHARACTER CA, CB 01378 * .. 01379 * 01380 * Purpose 01381 * ======= 01382 * 01383 * LSAME returns .TRUE. if CA is the same letter as CB regardless of 01384 * case. 01385 * 01386 * Arguments 01387 * ========= 01388 * 01389 * CA (input) CHARACTER*1 01390 * CB (input) CHARACTER*1 01391 * CA and CB specify the single characters to be compared. 01392 * 01393 * ===================================================================== 01394 * 01395 * .. Intrinsic Functions .. 01396 INTRINSIC ICHAR 01397 * .. 01398 * .. Local Scalars .. 01399 INTEGER INTA, INTB, ZCODE 01400 * .. 01401 * .. Executable Statements .. 01402 * 01403 * Test if the characters are equal 01404 * 01405 LSAME = CA.EQ.CB 01406 IF( LSAME ) 01407 $ RETURN 01408 * 01409 * Now test for equivalence if both characters are alphabetic. 01410 * 01411 ZCODE = ICHAR( 'Z' ) 01412 * 01413 * Use 'Z' rather than 'A' so that ASCII can be detected on Prime 01414 * machines, on which ICHAR returns a value with bit 8 set. 01415 * ICHAR('A') on Prime machines returns 193 which is the same as 01416 * ICHAR('A') on an EBCDIC machine. 01417 * 01418 INTA = ICHAR( CA ) 01419 INTB = ICHAR( CB ) 01420 * 01421 IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN 01422 * 01423 * ASCII is assumed - ZCODE is the ASCII code of either lower or 01424 * upper case 'Z'. 01425 * 01426 IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 01427 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 01428 * 01429 ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN 01430 * 01431 * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or 01432 * upper case 'Z'. 01433 * 01434 IF( INTA.GE.129 .AND. INTA.LE.137 .OR. 01435 $ INTA.GE.145 .AND. INTA.LE.153 .OR. 01436 $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 01437 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. 01438 $ INTB.GE.145 .AND. INTB.LE.153 .OR. 01439 $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 01440 * 01441 ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN 01442 * 01443 * ASCII is assumed, on Prime machines - ZCODE is the ASCII code 01444 * plus 128 of either lower or upper case 'Z'. 01445 * 01446 IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 01447 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 01448 END IF 01449 LSAME = INTA.EQ.INTB 01450 * 01451 * RETURN 01452 * 01453 * End of LSAME 01454 * 01455 END 01456 LOGICAL FUNCTION LSAMEN( N, CA, CB ) 01457 * 01458 * -- LAPACK auxiliary routine (version 2.1) -- 01459 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 01460 * Courant Institute, Argonne National Lab, and Rice University 01461 * September 30, 1994 01462 * 01463 * .. Scalar Arguments .. 01464 CHARACTER*( * ) CA, CB 01465 INTEGER N 01466 * .. 01467 * 01468 * Purpose 01469 * ======= 01470 * 01471 * LSAMEN tests if the first N letters of CA are the same as the 01472 * first N letters of CB, regardless of case. 01473 * LSAMEN returns .TRUE. if CA and CB are equivalent except for case 01474 * and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) 01475 * or LEN( CB ) is less than N. 01476 * 01477 * Arguments 01478 * ========= 01479 * 01480 * N (input) INTEGER 01481 * The number of characters in CA and CB to be compared. 01482 * 01483 * CA (input) CHARACTER*(*) 01484 * CB (input) CHARACTER*(*) 01485 * CA and CB specify two character strings of length at least N. 01486 * Only the first N characters of each string will be accessed. 01487 * 01488 * ===================================================================== 01489 * 01490 * .. Local Scalars .. 01491 INTEGER I 01492 * .. 01493 * .. External Functions .. 01494 LOGICAL LSAME 01495 EXTERNAL LSAME 01496 * .. 01497 * .. Intrinsic Functions .. 01498 INTRINSIC LEN 01499 * .. 01500 * .. Executable Statements .. 01501 * 01502 LSAMEN = .FALSE. 01503 IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N ) 01504 $ GO TO 20 01505 * 01506 * Do for each character in the two strings. 01507 * 01508 DO 10 I = 1, N 01509 * 01510 * Test if the characters are equal using LSAME. 01511 * 01512 IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) ) 01513 $ GO TO 20 01514 * 01515 10 CONTINUE 01516 LSAMEN = .TRUE. 01517 * 01518 20 CONTINUE 01519 RETURN 01520 * 01521 * End of LSAMEN 01522 * 01523 END 01524 SUBROUTINE ICOPY( N, SX, INCX, SY, INCY ) 01525 * 01526 * -- LAPACK auxiliary test routine (version 2.1) -- 01527 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 01528 * Courant Institute, Argonne National Lab, and Rice University 01529 * February 29, 1992 01530 * 01531 * .. Scalar Arguments .. 01532 INTEGER INCX, INCY, N 01533 * .. 01534 * .. Array Arguments .. 01535 INTEGER SX( * ), SY( * ) 01536 * .. 01537 * 01538 * Purpose 01539 * ======= 01540 * 01541 * ICOPY copies an integer vector x to an integer vector y. 01542 * Uses unrolled loops for increments equal to 1. 01543 * 01544 * Arguments 01545 * ========= 01546 * 01547 * N (input) INTEGER 01548 * The length of the vectors SX and SY. 01549 * 01550 * SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX)) 01551 * The vector X. 01552 * 01553 * INCX (input) INTEGER 01554 * The spacing between consecutive elements of SX. 01555 * 01556 * SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY)) 01557 * The vector Y. 01558 * 01559 * INCY (input) INTEGER 01560 * The spacing between consecutive elements of SY. 01561 * 01562 * ===================================================================== 01563 * 01564 * .. Local Scalars .. 01565 INTEGER I, IX, IY, M, MP1 01566 * .. 01567 * .. Intrinsic Functions .. 01568 INTRINSIC MOD 01569 * .. 01570 * .. Executable Statements .. 01571 * 01572 IF( N.LE.0 ) 01573 $ RETURN 01574 IF( INCX.EQ.1 .AND. INCY.EQ.1 ) 01575 $ GO TO 20 01576 * 01577 * Code for unequal increments or equal increments not equal to 1 01578 * 01579 IX = 1 01580 IY = 1 01581 IF( INCX.LT.0 ) 01582 $ IX = ( -N+1 )*INCX + 1 01583 IF( INCY.LT.0 ) 01584 $ IY = ( -N+1 )*INCY + 1 01585 DO 10 I = 1, N 01586 SY( IY ) = SX( IX ) 01587 IX = IX + INCX 01588 IY = IY + INCY 01589 10 CONTINUE 01590 RETURN 01591 * 01592 * Code for both increments equal to 1 01593 * 01594 * Clean-up loop 01595 * 01596 20 CONTINUE 01597 M = MOD( N, 7 ) 01598 IF( M.EQ.0 ) 01599 $ GO TO 40 01600 DO 30 I = 1, M 01601 SY( I ) = SX( I ) 01602 30 CONTINUE 01603 IF( N.LT.7 ) 01604 $ RETURN 01605 40 CONTINUE 01606 MP1 = M + 1 01607 DO 50 I = MP1, N, 7 01608 SY( I ) = SX( I ) 01609 SY( I+1 ) = SX( I+1 ) 01610 SY( I+2 ) = SX( I+2 ) 01611 SY( I+3 ) = SX( I+3 ) 01612 SY( I+4 ) = SX( I+4 ) 01613 SY( I+5 ) = SX( I+5 ) 01614 SY( I+6 ) = SX( I+6 ) 01615 50 CONTINUE 01616 RETURN 01617 * 01618 * End of ICOPY 01619 * 01620 END 01621 INTEGER FUNCTION PB_NOABORT( CINFO ) 01622 * 01623 * -- PBLAS test routine (version 2.0) -- 01624 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01625 * and University of California, Berkeley. 01626 * April 1, 1998 01627 * 01628 * .. Scalar Arguments .. 01629 INTEGER CINFO 01630 * .. 01631 * 01632 * Purpose 01633 * ======= 01634 * 01635 * PB_NOABORT transmits the info parameter of a PBLAS routine to the 01636 * tester and tells the PBLAS error handler to avoid aborting on erro- 01637 * neous input arguments. 01638 * 01639 * Notes 01640 * ===== 01641 * 01642 * This routine is necessary because of the CRAY C fortran interface 01643 * and the fact that the usual PBLAS error handler routine has been 01644 * initially written in C. 01645 * 01646 * -- Written on April 1, 1998 by 01647 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01648 * 01649 * ===================================================================== 01650 * 01651 * .. Common Blocks .. 01652 INTEGER INFO, NBLOG, NOUT 01653 LOGICAL ABRTFLG 01654 COMMON /INFOC/INFO, NBLOG 01655 COMMON /PBERRORC/NOUT, ABRTFLG 01656 * .. 01657 * .. Executable Statements .. 01658 * 01659 INFO = CINFO 01660 IF( ABRTFLG ) THEN 01661 PB_NOABORT = 0 01662 ELSE 01663 PB_NOABORT = 1 01664 END IF 01665 * 01666 RETURN 01667 * 01668 * End of PB_NOABORT 01669 * 01670 END 01671 SUBROUTINE PB_INFOG2L( I, J, DESC, NPROW, NPCOL, MYROW, MYCOL, II, 01672 $ JJ, PROW, PCOL ) 01673 * 01674 * -- PBLAS test routine (version 2.0) -- 01675 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01676 * and University of California, Berkeley. 01677 * April 1, 1998 01678 * 01679 * .. Scalar Arguments .. 01680 INTEGER I, II, J, JJ, MYCOL, MYROW, NPCOL, NPROW, PCOL, 01681 $ PROW 01682 * .. 01683 * .. Array Arguments .. 01684 INTEGER DESC( * ) 01685 * .. 01686 * 01687 * Purpose 01688 * ======= 01689 * 01690 * PB_INFOG2L computes the starting local index II, JJ corresponding to 01691 * the submatrix starting globally at the entry pointed by I, J. This 01692 * routine returns the coordinates in the grid of the process owning the 01693 * matrix entry of global indexes I, J, namely PROW and PCOL. 01694 * 01695 * Notes 01696 * ===== 01697 * 01698 * A description vector is associated with each 2D block-cyclicly dis- 01699 * tributed matrix. This vector stores the information required to 01700 * establish the mapping between a matrix entry and its corresponding 01701 * process and memory location. 01702 * 01703 * In the following comments, the character _ should be read as 01704 * "of the distributed matrix". Let A be a generic term for any 2D 01705 * block cyclicly distributed matrix. Its description vector is DESCA: 01706 * 01707 * NOTATION STORED IN EXPLANATION 01708 * ---------------- --------------- ------------------------------------ 01709 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 01710 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 01711 * the NPROW x NPCOL BLACS process grid 01712 * A is distributed over. The context 01713 * itself is global, but the handle 01714 * (the integer value) may vary. 01715 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 01716 * ted matrix A, M_A >= 0. 01717 * N_A (global) DESCA( N_ ) The number of columns in the distri- 01718 * buted matrix A, N_A >= 0. 01719 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 01720 * block of the matrix A, IMB_A > 0. 01721 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 01722 * left block of the matrix A, 01723 * INB_A > 0. 01724 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 01725 * bute the last M_A-IMB_A rows of A, 01726 * MB_A > 0. 01727 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 01728 * bute the last N_A-INB_A columns of 01729 * A, NB_A > 0. 01730 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 01731 * row of the matrix A is distributed, 01732 * NPROW > RSRC_A >= 0. 01733 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 01734 * first column of A is distributed. 01735 * NPCOL > CSRC_A >= 0. 01736 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01737 * array storing the local blocks of 01738 * the distributed matrix A, 01739 * IF( Lc( 1, N_A ) > 0 ) 01740 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01741 * ELSE 01742 * LLD_A >= 1. 01743 * 01744 * Let K be the number of rows of a matrix A starting at the global in- 01745 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01746 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01747 * receive if these K rows were distributed over NPROW processes. If K 01748 * is the number of columns of a matrix A starting at the global index 01749 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01750 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01751 * these K columns were distributed over NPCOL processes. 01752 * 01753 * The values of Lr() and Lc() may be determined via a call to the func- 01754 * tion PB_NUMROC: 01755 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01756 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01757 * 01758 * Arguments 01759 * ========= 01760 * 01761 * I (global input) INTEGER 01762 * On entry, I specifies the global starting row index of the 01763 * submatrix. I must at least one. 01764 * 01765 * J (global input) INTEGER 01766 * On entry, J specifies the global starting column index of 01767 * the submatrix. J must at least one. 01768 * 01769 * DESC (global and local input) INTEGER array 01770 * On entry, DESC is an integer array of dimension DLEN_. This 01771 * is the array descriptor of the underlying matrix. 01772 * 01773 * NPROW (global input) INTEGER 01774 * On entry, NPROW specifies the total number of process rows 01775 * over which the matrix is distributed. NPROW must be at least 01776 * one. 01777 * 01778 * NPCOL (global input) INTEGER 01779 * On entry, NPCOL specifies the total number of process columns 01780 * over which the matrix is distributed. NPCOL must be at least 01781 * one. 01782 * 01783 * MYROW (local input) INTEGER 01784 * On entry, MYROW specifies the row coordinate of the process 01785 * whose local index II is determined. MYROW must be at least 01786 * zero and strictly less than NPROW. 01787 * 01788 * MYCOL (local input) INTEGER 01789 * On entry, MYCOL specifies the column coordinate of the pro- 01790 * cess whose local index JJ is determined. MYCOL must be at 01791 * least zero and strictly less than NPCOL. 01792 * 01793 * II (local output) INTEGER 01794 * On exit, II specifies the local starting row index of the 01795 * submatrix. On exit, II is at least one. 01796 * 01797 * JJ (local output) INTEGER 01798 * On exit, JJ specifies the local starting column index of the 01799 * submatrix. On exit, JJ is at least one. 01800 * 01801 * PROW (global output) INTEGER 01802 * On exit, PROW specifies the row coordinate of the process 01803 * that possesses the first row of the submatrix. On exit, PROW 01804 * is -1 if DESC( RSRC_ ) is -1 on input, and, at least zero 01805 * and strictly less than NPROW otherwise. 01806 * 01807 * PCOL (global output) INTEGER 01808 * On exit, PCOL specifies the column coordinate of the process 01809 * that possesses the first column of the submatrix. On exit, 01810 * PCOL is -1 if DESC( CSRC_ ) is -1 on input, and, at least 01811 * zero and strictly less than NPCOL otherwise. 01812 * 01813 * -- Written on April 1, 1998 by 01814 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01815 * 01816 * ===================================================================== 01817 * 01818 * .. Parameters .. 01819 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 01820 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 01821 $ RSRC_ 01822 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 01823 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 01824 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 01825 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 01826 * .. 01827 * .. Local Scalars .. 01828 INTEGER CSRC, I1, ILOCBLK, IMB, INB, J1, MB, MYDIST, 01829 $ NB, NBLOCKS, RSRC 01830 * .. 01831 * .. Local Arrays .. 01832 INTEGER DESC2( DLEN_ ) 01833 * .. 01834 * .. External Subroutines .. 01835 EXTERNAL PB_DESCTRANS 01836 * .. 01837 * .. Executable Statements .. 01838 * 01839 * Convert descriptor 01840 * 01841 CALL PB_DESCTRANS( DESC, DESC2 ) 01842 * 01843 IMB = DESC2( IMB_ ) 01844 PROW = DESC2( RSRC_ ) 01845 * 01846 * Has every process row I ? 01847 * 01848 IF( ( PROW.EQ.-1 ).OR.( NPROW.EQ.1 ) ) THEN 01849 * 01850 II = I 01851 * 01852 ELSE IF( I.LE.IMB ) THEN 01853 * 01854 * I is in range of first block 01855 * 01856 IF( MYROW.EQ.PROW ) THEN 01857 II = I 01858 ELSE 01859 II = 1 01860 END IF 01861 * 01862 ELSE 01863 * 01864 * I is not in first block of matrix, figure out who has it. 01865 * 01866 RSRC = PROW 01867 MB = DESC2( MB_ ) 01868 * 01869 IF( MYROW.EQ.RSRC ) THEN 01870 * 01871 NBLOCKS = ( I - IMB - 1 ) / MB + 1 01872 PROW = PROW + NBLOCKS 01873 PROW = PROW - ( PROW / NPROW ) * NPROW 01874 * 01875 ILOCBLK = NBLOCKS / NPROW 01876 * 01877 IF( ILOCBLK.GT.0 ) THEN 01878 IF( ( ILOCBLK*NPROW ).GE.NBLOCKS ) THEN 01879 IF( MYROW.EQ.PROW ) THEN 01880 II = I + ( ILOCBLK - NBLOCKS ) * MB 01881 ELSE 01882 II = IMB + ( ILOCBLK - 1 ) * MB + 1 01883 END IF 01884 ELSE 01885 II = IMB + ILOCBLK * MB + 1 01886 END IF 01887 ELSE 01888 II = IMB + 1 01889 END IF 01890 * 01891 ELSE 01892 * 01893 I1 = I - IMB 01894 NBLOCKS = ( I1 - 1 ) / MB + 1 01895 PROW = PROW + NBLOCKS 01896 PROW = PROW - ( PROW / NPROW ) * NPROW 01897 * 01898 MYDIST = MYROW - RSRC 01899 IF( MYDIST.LT.0 ) 01900 $ MYDIST = MYDIST + NPROW 01901 * 01902 ILOCBLK = NBLOCKS / NPROW 01903 * 01904 IF( ILOCBLK.GT.0 ) THEN 01905 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW 01906 IF( MYDIST.LT.0 ) THEN 01907 II = MB + ILOCBLK * MB + 1 01908 ELSE 01909 IF( MYROW.EQ.PROW ) THEN 01910 II = I1 + ( ILOCBLK - NBLOCKS + 1 ) * MB 01911 ELSE 01912 II = ILOCBLK * MB + 1 01913 END IF 01914 END IF 01915 ELSE 01916 MYDIST = MYDIST - NBLOCKS 01917 IF( MYDIST.LT.0 ) THEN 01918 II = MB + 1 01919 ELSE IF( MYROW.EQ.PROW ) THEN 01920 II = I1 + ( 1 - NBLOCKS ) * MB 01921 ELSE 01922 II = 1 01923 END IF 01924 END IF 01925 END IF 01926 * 01927 END IF 01928 * 01929 INB = DESC2( INB_ ) 01930 PCOL = DESC2( CSRC_ ) 01931 * 01932 * Has every process column J ? 01933 * 01934 IF( ( PCOL.EQ.-1 ).OR.( NPCOL.EQ.1 ) ) THEN 01935 * 01936 JJ = J 01937 * 01938 ELSE IF( J.LE.INB ) THEN 01939 * 01940 * J is in range of first block 01941 * 01942 IF( MYCOL.EQ.PCOL ) THEN 01943 JJ = J 01944 ELSE 01945 JJ = 1 01946 END IF 01947 * 01948 ELSE 01949 * 01950 * J is not in first block of matrix, figure out who has it. 01951 * 01952 CSRC = PCOL 01953 NB = DESC2( NB_ ) 01954 * 01955 IF( MYCOL.EQ.CSRC ) THEN 01956 * 01957 NBLOCKS = ( J - INB - 1 ) / NB + 1 01958 PCOL = PCOL + NBLOCKS 01959 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL 01960 * 01961 ILOCBLK = NBLOCKS / NPCOL 01962 * 01963 IF( ILOCBLK.GT.0 ) THEN 01964 IF( ( ILOCBLK*NPCOL ).GE.NBLOCKS ) THEN 01965 IF( MYCOL.EQ.PCOL ) THEN 01966 JJ = J + ( ILOCBLK - NBLOCKS ) * NB 01967 ELSE 01968 JJ = INB + ( ILOCBLK - 1 ) * NB + 1 01969 END IF 01970 ELSE 01971 JJ = INB + ILOCBLK * NB + 1 01972 END IF 01973 ELSE 01974 JJ = INB + 1 01975 END IF 01976 * 01977 ELSE 01978 * 01979 J1 = J - INB 01980 NBLOCKS = ( J1 - 1 ) / NB + 1 01981 PCOL = PCOL + NBLOCKS 01982 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL 01983 * 01984 MYDIST = MYCOL - CSRC 01985 IF( MYDIST.LT.0 ) 01986 $ MYDIST = MYDIST + NPCOL 01987 * 01988 ILOCBLK = NBLOCKS / NPCOL 01989 * 01990 IF( ILOCBLK.GT.0 ) THEN 01991 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL 01992 IF( MYDIST.LT.0 ) THEN 01993 JJ = NB + ILOCBLK * NB + 1 01994 ELSE 01995 IF( MYCOL.EQ.PCOL ) THEN 01996 JJ = J1 + ( ILOCBLK - NBLOCKS + 1 ) * NB 01997 ELSE 01998 JJ = ILOCBLK * NB + 1 01999 END IF 02000 END IF 02001 ELSE 02002 MYDIST = MYDIST - NBLOCKS 02003 IF( MYDIST.LT.0 ) THEN 02004 JJ = NB + 1 02005 ELSE IF( MYCOL.EQ.PCOL ) THEN 02006 JJ = J1 + ( 1 - NBLOCKS ) * NB 02007 ELSE 02008 JJ = 1 02009 END IF 02010 END IF 02011 END IF 02012 * 02013 END IF 02014 * 02015 RETURN 02016 * 02017 * End of PB_INFOG2L 02018 * 02019 END 02020 SUBROUTINE PB_AINFOG2L( M, N, I, J, DESC, NPROW, NPCOL, MYROW, 02021 $ MYCOL, IMB1, INB1, MP, NQ, II, JJ, PROW, 02022 $ PCOL, RPROW, RPCOL ) 02023 * 02024 * -- PBLAS test routine (version 2.0) -- 02025 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02026 * and University of California, Berkeley. 02027 * April 1, 1998 02028 * 02029 * .. Scalar Arguments .. 02030 INTEGER I, II, IMB1, INB1, J, JJ, M, MP, MYCOL, MYROW, 02031 $ N, NPCOL, NPROW, NQ, PCOL, PROW, RPCOL, RPROW 02032 * .. 02033 * .. Array Arguments .. 02034 INTEGER DESC( * ) 02035 * .. 02036 * 02037 * Purpose 02038 * ======= 02039 * 02040 * PB_AINFOG2L computes the starting local row and column indexes II, 02041 * JJ corresponding to the submatrix starting globally at the entry 02042 * pointed by I, J. This routine returns the coordinates in the grid of 02043 * the process owning the matrix entry of global indexes I, J, namely 02044 * PROW and PCOL. In addition, this routine computes the quantities MP 02045 * and NQ, which are respectively the local number of rows and columns 02046 * owned by the process of coordinate MYROW, MYCOL corresponding to the 02047 * global submatrix A(I:I+M-1,J:J+N-1). Finally, the size of the first 02048 * partial block and the relative process coordinates are also returned 02049 * respectively in IMB, INB and RPROW, RPCOL. 02050 * 02051 * Notes 02052 * ===== 02053 * 02054 * A description vector is associated with each 2D block-cyclicly dis- 02055 * tributed matrix. This vector stores the information required to 02056 * establish the mapping between a matrix entry and its corresponding 02057 * process and memory location. 02058 * 02059 * In the following comments, the character _ should be read as 02060 * "of the distributed matrix". Let A be a generic term for any 2D 02061 * block cyclicly distributed matrix. Its description vector is DESCA: 02062 * 02063 * NOTATION STORED IN EXPLANATION 02064 * ---------------- --------------- ------------------------------------ 02065 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 02066 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 02067 * the NPROW x NPCOL BLACS process grid 02068 * A is distributed over. The context 02069 * itself is global, but the handle 02070 * (the integer value) may vary. 02071 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 02072 * ted matrix A, M_A >= 0. 02073 * N_A (global) DESCA( N_ ) The number of columns in the distri- 02074 * buted matrix A, N_A >= 0. 02075 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 02076 * block of the matrix A, IMB_A > 0. 02077 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 02078 * left block of the matrix A, 02079 * INB_A > 0. 02080 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 02081 * bute the last M_A-IMB_A rows of A, 02082 * MB_A > 0. 02083 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 02084 * bute the last N_A-INB_A columns of 02085 * A, NB_A > 0. 02086 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 02087 * row of the matrix A is distributed, 02088 * NPROW > RSRC_A >= 0. 02089 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 02090 * first column of A is distributed. 02091 * NPCOL > CSRC_A >= 0. 02092 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 02093 * array storing the local blocks of 02094 * the distributed matrix A, 02095 * IF( Lc( 1, N_A ) > 0 ) 02096 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 02097 * ELSE 02098 * LLD_A >= 1. 02099 * 02100 * Let K be the number of rows of a matrix A starting at the global in- 02101 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 02102 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 02103 * receive if these K rows were distributed over NPROW processes. If K 02104 * is the number of columns of a matrix A starting at the global index 02105 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 02106 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 02107 * these K columns were distributed over NPCOL processes. 02108 * 02109 * The values of Lr() and Lc() may be determined via a call to the func- 02110 * tion PB_NUMROC: 02111 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 02112 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 02113 * 02114 * Arguments 02115 * ========= 02116 * 02117 * M (global input) INTEGER 02118 * On entry, M specifies the global number of rows of the subma- 02119 * trix. M must be at least zero. 02120 * 02121 * N (global input) INTEGER 02122 * On entry, N specifies the global number of columns of the 02123 * submatrix. N must be at least zero. 02124 * 02125 * I (global input) INTEGER 02126 * On entry, I specifies the global starting row index of the 02127 * submatrix. I must at least one. 02128 * 02129 * J (global input) INTEGER 02130 * On entry, J specifies the global starting column index of 02131 * the submatrix. J must at least one. 02132 * 02133 * DESC (global and local input) INTEGER array 02134 * On entry, DESC is an integer array of dimension DLEN_. This 02135 * is the array descriptor of the underlying matrix. 02136 * 02137 * NPROW (global input) INTEGER 02138 * On entry, NPROW specifies the total number of process rows 02139 * over which the matrix is distributed. NPROW must be at least 02140 * one. 02141 * 02142 * NPCOL (global input) INTEGER 02143 * On entry, NPCOL specifies the total number of process columns 02144 * over which the matrix is distributed. NPCOL must be at least 02145 * one. 02146 * 02147 * MYROW (local input) INTEGER 02148 * On entry, MYROW specifies the row coordinate of the process 02149 * whose local index II is determined. MYROW must be at least 02150 * zero and strictly less than NPROW. 02151 * 02152 * MYCOL (local input) INTEGER 02153 * On entry, MYCOL specifies the column coordinate of the pro- 02154 * cess whose local index JJ is determined. MYCOL must be at 02155 * least zero and strictly less than NPCOL. 02156 * 02157 * IMB1 (global output) INTEGER 02158 * On exit, IMB1 specifies the number of rows of the upper left 02159 * block of the submatrix. On exit, IMB1 is less or equal than 02160 * M and greater or equal than MIN( 1, M ). 02161 * 02162 * INB1 (global output) INTEGER 02163 * On exit, INB1 specifies the number of columns of the upper 02164 * left block of the submatrix. On exit, INB1 is less or equal 02165 * than N and greater or equal than MIN( 1, N ). 02166 * 02167 * MP (local output) INTEGER 02168 * On exit, MP specifies the local number of rows of the subma- 02169 * trix, that the processes of row coordinate MYROW own. MP is 02170 * at least zero. 02171 * 02172 * NQ (local output) INTEGER 02173 * On exit, NQ specifies the local number of columns of the 02174 * submatrix, that the processes of column coordinate MYCOL 02175 * own. NQ is at least zero. 02176 * 02177 * II (local output) INTEGER 02178 * On exit, II specifies the local starting row index of the 02179 * submatrix. On exit, II is at least one. 02180 * 02181 * JJ (local output) INTEGER 02182 * On exit, JJ specifies the local starting column index of 02183 * the submatrix. On exit, II is at least one. 02184 * 02185 * PROW (global output) INTEGER 02186 * On exit, PROW specifies the row coordinate of the process 02187 * that possesses the first row of the submatrix. On exit, PROW 02188 * is -1 if DESC(RSRC_) is -1 on input, and, at least zero and 02189 * strictly less than NPROW otherwise. 02190 * 02191 * PCOL (global output) INTEGER 02192 * On exit, PCOL specifies the column coordinate of the process 02193 * that possesses the first column of the submatrix. On exit, 02194 * PCOL is -1 if DESC(CSRC_) is -1 on input, and, at least zero 02195 * and strictly less than NPCOL otherwise. 02196 * 02197 * RPROW (global output) INTEGER 02198 * On exit, RPROW specifies the relative row coordinate of the 02199 * process that possesses the first row I of the submatrix. On 02200 * exit, RPROW is -1 if DESC(RSRC_) is -1 on input, and, at 02201 * least zero and strictly less than NPROW otherwise. 02202 * 02203 * RPCOL (global output) INTEGER 02204 * On exit, RPCOL specifies the relative column coordinate of 02205 * the process that possesses the first column J of the subma- 02206 * trix. On exit, RPCOL is -1 if DESC(CSRC_) is -1 on input, 02207 * and, at least zero and strictly less than NPCOL otherwise. 02208 * 02209 * -- Written on April 1, 1998 by 02210 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02211 * 02212 * ===================================================================== 02213 * 02214 * .. Parameters .. 02215 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 02216 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 02217 $ RSRC_ 02218 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 02219 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 02220 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 02221 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 02222 * .. 02223 * .. Local Scalars .. 02224 INTEGER CSRC, I1, ILOCBLK, J1, M1, MB, MYDIST, N1, NB, 02225 $ NBLOCKS, RSRC 02226 * .. 02227 * .. Local Arrays .. 02228 INTEGER DESC2( DLEN_ ) 02229 * .. 02230 * .. External Subroutines .. 02231 EXTERNAL PB_DESCTRANS 02232 * .. 02233 * .. Intrinsic Functions .. 02234 INTRINSIC MIN 02235 * .. 02236 * .. Executable Statements .. 02237 * 02238 * Convert descriptor 02239 * 02240 CALL PB_DESCTRANS( DESC, DESC2 ) 02241 * 02242 MB = DESC2( MB_ ) 02243 IMB1 = DESC2( IMB_ ) 02244 RSRC = DESC2( RSRC_ ) 02245 * 02246 IF( ( RSRC.EQ.-1 ).OR.( NPROW.EQ.1 ) ) THEN 02247 * 02248 II = I 02249 IMB1 = IMB1 - I + 1 02250 IF( IMB1.LE.0 ) 02251 $ IMB1 = ( ( -IMB1 ) / MB + 1 ) * MB + IMB1 02252 IMB1 = MIN( IMB1, M ) 02253 MP = M 02254 PROW = RSRC 02255 RPROW = 0 02256 * 02257 ELSE 02258 * 02259 * Figure out PROW, II and IMB1 first 02260 * 02261 IF( I.LE.IMB1 ) THEN 02262 * 02263 PROW = RSRC 02264 * 02265 IF( MYROW.EQ.PROW ) THEN 02266 II = I 02267 ELSE 02268 II = 1 02269 END IF 02270 * 02271 IMB1 = IMB1 - I + 1 02272 * 02273 ELSE 02274 * 02275 I1 = I - IMB1 - 1 02276 NBLOCKS = I1 / MB + 1 02277 PROW = RSRC + NBLOCKS 02278 PROW = PROW - ( PROW / NPROW ) * NPROW 02279 * 02280 IF( MYROW.EQ.RSRC ) THEN 02281 * 02282 ILOCBLK = NBLOCKS / NPROW 02283 * 02284 IF( ILOCBLK.GT.0 ) THEN 02285 IF( ( ILOCBLK*NPROW ).GE.NBLOCKS ) THEN 02286 IF( MYROW.EQ.PROW ) THEN 02287 II = I + ( ILOCBLK - NBLOCKS ) * MB 02288 ELSE 02289 II = IMB1 + ( ILOCBLK - 1 ) * MB + 1 02290 END IF 02291 ELSE 02292 II = IMB1 + ILOCBLK * MB + 1 02293 END IF 02294 ELSE 02295 II = IMB1 + 1 02296 END IF 02297 * 02298 ELSE 02299 * 02300 MYDIST = MYROW - RSRC 02301 IF( MYDIST.LT.0 ) 02302 $ MYDIST = MYDIST + NPROW 02303 * 02304 ILOCBLK = NBLOCKS / NPROW 02305 * 02306 IF( ILOCBLK.GT.0 ) THEN 02307 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW 02308 IF( MYDIST.LT.0 ) THEN 02309 II = ( ILOCBLK + 1 ) * MB + 1 02310 ELSE IF( MYROW.EQ.PROW ) THEN 02311 II = I1 + ( ILOCBLK - NBLOCKS + 1 ) * MB + 1 02312 ELSE 02313 II = ILOCBLK * MB + 1 02314 END IF 02315 ELSE 02316 MYDIST = MYDIST - NBLOCKS 02317 IF( MYDIST.LT.0 ) THEN 02318 II = MB + 1 02319 ELSE IF( MYROW.EQ.PROW ) THEN 02320 II = I1 + ( 1 - NBLOCKS ) * MB + 1 02321 ELSE 02322 II = 1 02323 END IF 02324 END IF 02325 END IF 02326 * 02327 IMB1 = NBLOCKS * MB - I1 02328 * 02329 END IF 02330 * 02331 * Figure out MP 02332 * 02333 IF( M.LE.IMB1 ) THEN 02334 * 02335 IF( MYROW.EQ.PROW ) THEN 02336 MP = M 02337 ELSE 02338 MP = 0 02339 END IF 02340 * 02341 ELSE 02342 * 02343 M1 = M - IMB1 02344 NBLOCKS = M1 / MB + 1 02345 * 02346 IF( MYROW.EQ.PROW ) THEN 02347 ILOCBLK = NBLOCKS / NPROW 02348 IF( ILOCBLK.GT.0 ) THEN 02349 IF( ( NBLOCKS - ILOCBLK * NPROW ).GT.0 ) THEN 02350 MP = IMB1 + ILOCBLK * MB 02351 ELSE 02352 MP = M + MB * ( ILOCBLK - NBLOCKS ) 02353 END IF 02354 ELSE 02355 MP = IMB1 02356 END IF 02357 ELSE 02358 MYDIST = MYROW - PROW 02359 IF( MYDIST.LT.0 ) 02360 $ MYDIST = MYDIST + NPROW 02361 ILOCBLK = NBLOCKS / NPROW 02362 IF( ILOCBLK.GT.0 ) THEN 02363 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROW 02364 IF( MYDIST.LT.0 ) THEN 02365 MP = ( ILOCBLK + 1 ) * MB 02366 ELSE IF( MYDIST.GT.0 ) THEN 02367 MP = ILOCBLK * MB 02368 ELSE 02369 MP = M1 + MB * ( ILOCBLK - NBLOCKS + 1 ) 02370 END IF 02371 ELSE 02372 MYDIST = MYDIST - NBLOCKS 02373 IF( MYDIST.LT.0 ) THEN 02374 MP = MB 02375 ELSE IF( MYDIST.GT.0 ) THEN 02376 MP = 0 02377 ELSE 02378 MP = M1 + MB * ( 1 - NBLOCKS ) 02379 END IF 02380 END IF 02381 END IF 02382 * 02383 END IF 02384 * 02385 IMB1 = MIN( IMB1, M ) 02386 RPROW = MYROW - PROW 02387 IF( RPROW.LT.0 ) 02388 $ RPROW = RPROW + NPROW 02389 * 02390 END IF 02391 * 02392 NB = DESC2( NB_ ) 02393 INB1 = DESC2( INB_ ) 02394 CSRC = DESC2( CSRC_ ) 02395 * 02396 IF( ( CSRC.EQ.-1 ).OR.( NPCOL.EQ.1 ) ) THEN 02397 * 02398 JJ = J 02399 INB1 = INB1 - I + 1 02400 IF( INB1.LE.0 ) 02401 $ INB1 = ( ( -INB1 ) / NB + 1 ) * NB + INB1 02402 INB1 = MIN( INB1, N ) 02403 NQ = N 02404 PCOL = CSRC 02405 RPCOL = 0 02406 * 02407 ELSE 02408 * 02409 * Figure out PCOL, JJ and INB1 first 02410 * 02411 IF( J.LE.INB1 ) THEN 02412 * 02413 PCOL = CSRC 02414 * 02415 IF( MYCOL.EQ.PCOL ) THEN 02416 JJ = J 02417 ELSE 02418 JJ = 1 02419 END IF 02420 * 02421 INB1 = INB1 - J + 1 02422 * 02423 ELSE 02424 * 02425 J1 = J - INB1 - 1 02426 NBLOCKS = J1 / NB + 1 02427 PCOL = CSRC + NBLOCKS 02428 PCOL = PCOL - ( PCOL / NPCOL ) * NPCOL 02429 * 02430 IF( MYCOL.EQ.CSRC ) THEN 02431 * 02432 ILOCBLK = NBLOCKS / NPCOL 02433 * 02434 IF( ILOCBLK.GT.0 ) THEN 02435 IF( ( ILOCBLK*NPCOL ).GE.NBLOCKS ) THEN 02436 IF( MYCOL.EQ.PCOL ) THEN 02437 JJ = J + ( ILOCBLK - NBLOCKS ) * NB 02438 ELSE 02439 JJ = INB1 + ( ILOCBLK - 1 ) * NB + 1 02440 END IF 02441 ELSE 02442 JJ = INB1 + ILOCBLK * NB + 1 02443 END IF 02444 ELSE 02445 JJ = INB1 + 1 02446 END IF 02447 * 02448 ELSE 02449 * 02450 MYDIST = MYCOL - CSRC 02451 IF( MYDIST.LT.0 ) 02452 $ MYDIST = MYDIST + NPCOL 02453 * 02454 ILOCBLK = NBLOCKS / NPCOL 02455 * 02456 IF( ILOCBLK.GT.0 ) THEN 02457 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL 02458 IF( MYDIST.LT.0 ) THEN 02459 JJ = ( ILOCBLK + 1 ) * NB + 1 02460 ELSE IF( MYCOL.EQ.PCOL ) THEN 02461 JJ = J1 + ( ILOCBLK - NBLOCKS + 1 ) * NB + 1 02462 ELSE 02463 JJ = ILOCBLK * NB + 1 02464 END IF 02465 ELSE 02466 MYDIST = MYDIST - NBLOCKS 02467 IF( MYDIST.LT.0 ) THEN 02468 JJ = NB + 1 02469 ELSE IF( MYCOL.EQ.PCOL ) THEN 02470 JJ = J1 + ( 1 - NBLOCKS ) * NB + 1 02471 ELSE 02472 JJ = 1 02473 END IF 02474 END IF 02475 END IF 02476 * 02477 INB1 = NBLOCKS * NB - J1 02478 * 02479 END IF 02480 * 02481 * Figure out NQ 02482 * 02483 IF( N.LE.INB1 ) THEN 02484 * 02485 IF( MYCOL.EQ.PCOL ) THEN 02486 NQ = N 02487 ELSE 02488 NQ = 0 02489 END IF 02490 * 02491 ELSE 02492 * 02493 N1 = N - INB1 02494 NBLOCKS = N1 / NB + 1 02495 * 02496 IF( MYCOL.EQ.PCOL ) THEN 02497 ILOCBLK = NBLOCKS / NPCOL 02498 IF( ILOCBLK.GT.0 ) THEN 02499 IF( ( NBLOCKS - ILOCBLK * NPCOL ).GT.0 ) THEN 02500 NQ = INB1 + ILOCBLK * NB 02501 ELSE 02502 NQ = N + NB * ( ILOCBLK - NBLOCKS ) 02503 END IF 02504 ELSE 02505 NQ = INB1 02506 END IF 02507 ELSE 02508 MYDIST = MYCOL - PCOL 02509 IF( MYDIST.LT.0 ) 02510 $ MYDIST = MYDIST + NPCOL 02511 ILOCBLK = NBLOCKS / NPCOL 02512 IF( ILOCBLK.GT.0 ) THEN 02513 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPCOL 02514 IF( MYDIST.LT.0 ) THEN 02515 NQ = ( ILOCBLK + 1 ) * NB 02516 ELSE IF( MYDIST.GT.0 ) THEN 02517 NQ = ILOCBLK * NB 02518 ELSE 02519 NQ = N1 + NB * ( ILOCBLK - NBLOCKS + 1 ) 02520 END IF 02521 ELSE 02522 MYDIST = MYDIST - NBLOCKS 02523 IF( MYDIST.LT.0 ) THEN 02524 NQ = NB 02525 ELSE IF( MYDIST.GT.0 ) THEN 02526 NQ = 0 02527 ELSE 02528 NQ = N1 + NB * ( 1 - NBLOCKS ) 02529 END IF 02530 END IF 02531 END IF 02532 * 02533 END IF 02534 * 02535 INB1 = MIN( INB1, N ) 02536 RPCOL = MYCOL - PCOL 02537 IF( RPCOL.LT.0 ) 02538 $ RPCOL = RPCOL + NPCOL 02539 * 02540 END IF 02541 * 02542 RETURN 02543 * 02544 * End of PB_AINFOG2L 02545 * 02546 END 02547 INTEGER FUNCTION PB_NUMROC( N, I, INB, NB, PROC, SRCPROC, NPROCS ) 02548 * 02549 * -- PBLAS test routine (version 2.0) -- 02550 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02551 * and University of California, Berkeley. 02552 * April 1, 1998 02553 * 02554 * .. Scalar Arguments .. 02555 INTEGER I, INB, N, NB, NPROCS, PROC, SRCPROC 02556 * .. 02557 * 02558 * Purpose 02559 * ======= 02560 * 02561 * PB_NUMROC returns the local number of matrix rows/columns process 02562 * PROC will get if we give out N rows/columns starting from global in- 02563 * dex I. 02564 * 02565 * Arguments 02566 * ========= 02567 * 02568 * N (global input) INTEGER 02569 * On entry, N specifies the number of rows/columns being dealt 02570 * out. N must be at least zero. 02571 * 02572 * I (global input) INTEGER 02573 * On entry, I specifies the global index of the matrix entry. 02574 * I must be at least one. 02575 * 02576 * INB (global input) INTEGER 02577 * On entry, INB specifies the size of the first block of the 02578 * global matrix. INB must be at least one. 02579 * 02580 * NB (global input) INTEGER 02581 * On entry, NB specifies the size of the blocks used to parti- 02582 * tion the matrix. NB must be at least one. 02583 * 02584 * PROC (local input) INTEGER 02585 * On entry, PROC specifies the coordinate of the process whose 02586 * local portion is determined. PROC must be at least zero and 02587 * strictly less than NPROCS. 02588 * 02589 * SRCPROC (global input) INTEGER 02590 * On entry, SRCPROC specifies the coordinate of the process 02591 * that possesses the first row or column of the matrix. When 02592 * SRCPROC = -1, the data is not distributed but replicated, 02593 * otherwise SRCPROC must be at least zero and strictly less 02594 * than NPROCS. 02595 * 02596 * NPROCS (global input) INTEGER 02597 * On entry, NPROCS specifies the total number of process rows 02598 * or columns over which the matrix is distributed. NPROCS must 02599 * be at least one. 02600 * 02601 * -- Written on April 1, 1998 by 02602 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02603 * 02604 * ===================================================================== 02605 * 02606 * .. Local Scalars .. 02607 INTEGER I1, ILOCBLK, INB1, MYDIST, N1, NBLOCKS, 02608 $ SRCPROC1 02609 * .. 02610 * .. Executable Statements .. 02611 * 02612 IF( ( SRCPROC.EQ.-1 ).OR.( NPROCS.EQ.1 ) ) THEN 02613 PB_NUMROC = N 02614 RETURN 02615 END IF 02616 * 02617 * Compute coordinate of process owning I and corresponding INB 02618 * 02619 IF( I.LE.INB ) THEN 02620 * 02621 * I is in range of first block, i.e SRCPROC owns I. 02622 * 02623 SRCPROC1 = SRCPROC 02624 INB1 = INB - I + 1 02625 * 02626 ELSE 02627 * 02628 * I is not in first block of matrix, figure out who has it 02629 * 02630 I1 = I - 1 - INB 02631 NBLOCKS = I1 / NB + 1 02632 SRCPROC1 = SRCPROC + NBLOCKS 02633 SRCPROC1 = SRCPROC1 - ( SRCPROC1 / NPROCS ) * NPROCS 02634 INB1 = NBLOCKS*NB - I1 02635 * 02636 END IF 02637 * 02638 * Now everything is just like I=1. Search now who has N-1, Is N-1 02639 * in the first block ? 02640 * 02641 IF( N.LE.INB1 ) THEN 02642 IF( PROC.EQ.SRCPROC1 ) THEN 02643 PB_NUMROC = N 02644 ELSE 02645 PB_NUMROC = 0 02646 END IF 02647 RETURN 02648 END IF 02649 * 02650 N1 = N - INB1 02651 NBLOCKS = N1 / NB + 1 02652 * 02653 IF( PROC.EQ.SRCPROC1 ) THEN 02654 ILOCBLK = NBLOCKS / NPROCS 02655 IF( ILOCBLK.GT.0 ) THEN 02656 IF( ( NBLOCKS - ILOCBLK * NPROCS ).GT.0 ) THEN 02657 PB_NUMROC = INB1 + ILOCBLK * NB 02658 ELSE 02659 PB_NUMROC = N + NB * ( ILOCBLK - NBLOCKS ) 02660 END IF 02661 ELSE 02662 PB_NUMROC = INB1 02663 END IF 02664 ELSE 02665 MYDIST = PROC - SRCPROC1 02666 IF( MYDIST.LT.0 ) 02667 $ MYDIST = MYDIST + NPROCS 02668 ILOCBLK = NBLOCKS / NPROCS 02669 IF( ILOCBLK.GT.0 ) THEN 02670 MYDIST = MYDIST - NBLOCKS + ILOCBLK * NPROCS 02671 IF( MYDIST.LT.0 ) THEN 02672 PB_NUMROC = ( ILOCBLK + 1 ) * NB 02673 ELSE IF( MYDIST.GT.0 ) THEN 02674 PB_NUMROC = ILOCBLK * NB 02675 ELSE 02676 PB_NUMROC = N1 + NB * ( ILOCBLK - NBLOCKS + 1 ) 02677 END IF 02678 ELSE 02679 MYDIST = MYDIST - NBLOCKS 02680 IF( MYDIST.LT.0 ) THEN 02681 PB_NUMROC = NB 02682 ELSE IF( MYDIST.GT.0 ) THEN 02683 PB_NUMROC = 0 02684 ELSE 02685 PB_NUMROC = N1 + NB * ( 1 - NBLOCKS ) 02686 END IF 02687 END IF 02688 END IF 02689 * 02690 RETURN 02691 * 02692 * End of PB_NUMROC 02693 * 02694 END 02695 INTEGER FUNCTION PB_FCEIL( NUM, DENOM ) 02696 * 02697 * -- PBLAS test routine (version 2.0) -- 02698 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02699 * and University of California, Berkeley. 02700 * April 1, 1998 02701 * 02702 * .. Scalar Arguments .. 02703 REAL DENOM, NUM 02704 * .. 02705 * 02706 * Purpose 02707 * ======= 02708 * 02709 * PB_FCEIL returns the ceiling of the division of two integers. The 02710 * integer operands are passed as real to avoid integer overflow. 02711 * 02712 * Arguments 02713 * ========= 02714 * 02715 * NUM (local input) REAL 02716 * On entry, NUM specifies the numerator of the fraction to be 02717 * evaluated. 02718 * 02719 * DENOM (local input) REAL 02720 * On entry, DENOM specifies the denominator of the fraction to 02721 * be evaluated. 02722 * 02723 * -- Written on April 1, 1998 by 02724 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02725 * 02726 * ===================================================================== 02727 * 02728 * .. Intrinsic Functions .. 02729 INTRINSIC NINT 02730 * .. 02731 * .. Executable Statements .. 02732 * 02733 PB_FCEIL = NINT( ( ( NUM + DENOM - 1.0E+0 ) / DENOM ) - 0.5E+0 ) 02734 * 02735 RETURN 02736 * 02737 * End of PB_FCEIL 02738 * 02739 END 02740 SUBROUTINE PB_CHKMAT( ICTXT, M, MPOS0, N, NPOS0, IA, JA, DESCA, 02741 $ DPOS0, INFO ) 02742 * 02743 * -- PBLAS test routine (version 2.0) -- 02744 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02745 * and University of California, Berkeley. 02746 * April 1, 1998 02747 * 02748 * .. Scalar Arguments .. 02749 INTEGER DPOS0, IA, ICTXT, INFO, JA, M, MPOS0, N, NPOS0 02750 * .. 02751 * .. Array Arguments .. 02752 INTEGER DESCA( * ) 02753 * .. 02754 * 02755 * Purpose 02756 * ======= 02757 * 02758 * PB_CHKMAT checks the validity of a descriptor vector DESCA, the re- 02759 * lated global indexes IA, JA from a local view point. If an inconsis- 02760 * tency is found among its parameters IA, JA and DESCA, the routine re- 02761 * turns an error code in INFO. 02762 * 02763 * Arguments 02764 * ========= 02765 * 02766 * ICTXT (local input) INTEGER 02767 * On entry, ICTXT specifies the BLACS context handle, indica- 02768 * ting the global context of the operation. The context itself 02769 * is global, but the value of ICTXT is local. 02770 * 02771 * M (global input) INTEGER 02772 * On entry, M specifies the number of rows the submatrix 02773 * sub( A ). 02774 * 02775 * MPOS0 (global input) INTEGER 02776 * On entry, MPOS0 specifies the position in the calling rou- 02777 * tine's parameter list where the formal parameter M appears. 02778 * 02779 * N (global input) INTEGER 02780 * On entry, N specifies the number of columns the submatrix 02781 * sub( A ). 02782 * 02783 * NPOS0 (global input) INTEGER 02784 * On entry, NPOS0 specifies the position in the calling rou- 02785 * tine's parameter list where the formal parameter N appears. 02786 * 02787 * IA (global input) INTEGER 02788 * On entry, IA specifies A's global row index, which points to 02789 * the beginning of the submatrix sub( A ). 02790 * 02791 * JA (global input) INTEGER 02792 * On entry, JA specifies A's global column index, which points 02793 * to the beginning of the submatrix sub( A ). 02794 * 02795 * DESCA (global and local input) INTEGER array 02796 * On entry, DESCA is an integer array of dimension DLEN_. This 02797 * is the array descriptor for the matrix A. 02798 * 02799 * DPOS0 (global input) INTEGER 02800 * On entry, DPOS0 specifies the position in the calling rou- 02801 * tine's parameter list where the formal parameter DESCA ap- 02802 * pears. Note that it is assumed that IA and JA are respecti- 02803 * vely 2 and 1 entries behind DESCA. 02804 * 02805 * INFO (local input/local output) INTEGER 02806 * = 0: successful exit 02807 * < 0: If the i-th argument is an array and the j-entry had an 02808 * illegal value, then INFO = -(i*100+j), if the i-th 02809 * argument is a scalar and had an illegal value, then 02810 * INFO = -i. 02811 * 02812 * -- Written on April 1, 1998 by 02813 * R. Clint Whaley, University of Tennessee, Knoxville 37996, USA. 02814 * 02815 * ===================================================================== 02816 * 02817 * .. Parameters .. 02818 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 02819 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 02820 $ RSRC_ 02821 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 02822 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 02823 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 02824 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 02825 INTEGER DESCMULT, BIGNUM 02826 PARAMETER ( DESCMULT = 100, BIGNUM = DESCMULT*DESCMULT ) 02827 * .. 02828 * .. Local Scalars .. 02829 INTEGER DPOS, IAPOS, JAPOS, MP, MPOS, MYCOL, MYROW, 02830 $ NPCOL, NPOS, NPROW, NQ 02831 * .. 02832 * .. Local Arrays .. 02833 INTEGER DESCA2( DLEN_ ) 02834 * .. 02835 * .. External Subroutines .. 02836 EXTERNAL BLACS_GRIDINFO, PB_DESCTRANS 02837 * .. 02838 * .. External Functions .. 02839 INTEGER PB_NUMROC 02840 EXTERNAL PB_NUMROC 02841 * .. 02842 * .. Intrinsic Functions .. 02843 INTRINSIC MIN, MAX 02844 * .. 02845 * .. Executable Statements .. 02846 * 02847 * Convert descriptor 02848 * 02849 CALL PB_DESCTRANS( DESCA, DESCA2 ) 02850 * 02851 * Want to find errors with MIN( ), so if no error, set it to a big 02852 * number. If there already is an error, multiply by the the des- 02853 * criptor multiplier 02854 * 02855 IF( INFO.GE.0 ) THEN 02856 INFO = BIGNUM 02857 ELSE IF( INFO.LT.-DESCMULT ) THEN 02858 INFO = -INFO 02859 ELSE 02860 INFO = -INFO * DESCMULT 02861 END IF 02862 * 02863 * Figure where in parameter list each parameter was, factoring in 02864 * descriptor multiplier 02865 * 02866 MPOS = MPOS0 * DESCMULT 02867 NPOS = NPOS0 * DESCMULT 02868 IAPOS = ( DPOS0 - 2 ) * DESCMULT 02869 JAPOS = ( DPOS0 - 1 ) * DESCMULT 02870 DPOS = DPOS0 * DESCMULT 02871 * 02872 * Get grid parameters 02873 * 02874 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 02875 * 02876 * Check that matrix values make sense from local viewpoint 02877 * 02878 IF( M.LT.0 ) 02879 $ INFO = MIN( INFO, MPOS ) 02880 IF( N.LT.0 ) 02881 $ INFO = MIN( INFO, NPOS ) 02882 IF( IA.LT.1 ) 02883 $ INFO = MIN( INFO, IAPOS ) 02884 IF( JA.LT.1 ) 02885 $ INFO = MIN( INFO, JAPOS ) 02886 IF( DESCA2( DTYPE_ ).NE.BLOCK_CYCLIC_2D_INB ) 02887 $ INFO = MIN( INFO, DPOS + DTYPE_ ) 02888 IF( DESCA2( IMB_ ).LT.1 ) 02889 $ INFO = MIN( INFO, DPOS + IMB_ ) 02890 IF( DESCA2( INB_ ).LT.1 ) 02891 $ INFO = MIN( INFO, DPOS + INB_ ) 02892 IF( DESCA2( MB_ ).LT.1 ) 02893 $ INFO = MIN( INFO, DPOS + MB_ ) 02894 IF( DESCA2( NB_ ).LT.1 ) 02895 $ INFO = MIN( INFO, DPOS + NB_ ) 02896 IF( DESCA2( RSRC_ ).LT.-1 .OR. DESCA2( RSRC_ ).GE.NPROW ) 02897 $ INFO = MIN( INFO, DPOS + RSRC_ ) 02898 IF( DESCA2( CSRC_ ).LT.-1 .OR. DESCA2( CSRC_ ).GE.NPCOL ) 02899 $ INFO = MIN( INFO, DPOS + CSRC_ ) 02900 IF( DESCA2( CTXT_ ).NE.ICTXT ) 02901 $ INFO = MIN( INFO, DPOS + CTXT_ ) 02902 * 02903 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 02904 * 02905 * NULL matrix, relax some checks 02906 * 02907 IF( DESCA2( M_ ).LT.0 ) 02908 $ INFO = MIN( INFO, DPOS + M_ ) 02909 IF( DESCA2( N_ ).LT.0 ) 02910 $ INFO = MIN( INFO, DPOS + N_ ) 02911 IF( DESCA2( LLD_ ).LT.1 ) 02912 $ INFO = MIN( INFO, DPOS + LLD_ ) 02913 * 02914 ELSE 02915 * 02916 * more rigorous checks for non-degenerate matrices 02917 * 02918 MP = PB_NUMROC( DESCA2( M_ ), 1, DESCA2( IMB_ ), DESCA2( MB_ ), 02919 $ MYROW, DESCA2( RSRC_ ), NPROW ) 02920 * 02921 IF( DESCA2( M_ ).LT.1 ) 02922 $ INFO = MIN( INFO, DPOS + M_ ) 02923 IF( DESCA2( N_ ).LT.1 ) 02924 $ INFO = MIN( INFO, DPOS + N_ ) 02925 IF( IA.GT.DESCA2( M_ ) ) 02926 $ INFO = MIN( INFO, IAPOS ) 02927 IF( JA.GT.DESCA2( N_ ) ) 02928 $ INFO = MIN( INFO, JAPOS ) 02929 IF( IA+M-1.GT.DESCA2( M_ ) ) 02930 $ INFO = MIN( INFO, MPOS ) 02931 IF( JA+N-1.GT.DESCA2( N_ ) ) 02932 $ INFO = MIN( INFO, NPOS ) 02933 * 02934 IF( DESCA2( LLD_ ).LT.MAX( 1, MP ) ) THEN 02935 NQ = PB_NUMROC( DESCA2( N_ ), 1, DESCA2( INB_ ), 02936 $ DESCA2( NB_ ), MYCOL, DESCA2( CSRC_ ), 02937 $ NPCOL ) 02938 IF( DESCA2( LLD_ ).LT.1 ) THEN 02939 INFO = MIN( INFO, DPOS + LLD_ ) 02940 ELSE IF( NQ.GT.0 ) THEN 02941 INFO = MIN( INFO, DPOS + LLD_ ) 02942 END IF 02943 END IF 02944 * 02945 END IF 02946 * 02947 * Prepare output: set info = 0 if no error, and divide by 02948 * DESCMULT if error is not in a descriptor entry 02949 * 02950 IF( INFO.EQ.BIGNUM ) THEN 02951 INFO = 0 02952 ELSE IF( MOD( INFO, DESCMULT ).EQ.0 ) THEN 02953 INFO = -( INFO / DESCMULT ) 02954 ELSE 02955 INFO = -INFO 02956 END IF 02957 * 02958 RETURN 02959 * 02960 * End of PB_CHKMAT 02961 * 02962 END 02963 SUBROUTINE PB_DESCTRANS( DESCIN, DESCOUT ) 02964 * 02965 * -- PBLAS test routine (version 2.0) -- 02966 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02967 * and University of California, Berkeley. 02968 * April 1, 1998 02969 * 02970 * .. Array Arguments .. 02971 INTEGER DESCIN( * ), DESCOUT( * ) 02972 * .. 02973 * 02974 * Purpose 02975 * ======= 02976 * 02977 * PB_DESCTRANS converts a descriptor DESCIN of type BLOCK_CYCLIC_2D 02978 * or BLOCK_CYCLIC_INB_2D into a descriptor DESCOUT of type 02979 * BLOCK_CYCLIC_INB_2D. 02980 * 02981 * Notes 02982 * ===== 02983 * 02984 * A description vector is associated with each 2D block-cyclicly dis- 02985 * tributed matrix. This vector stores the information required to 02986 * establish the mapping between a matrix entry and its corresponding 02987 * process and memory location. 02988 * 02989 * In the following comments, the character _ should be read as 02990 * "of the distributed matrix". Let A be a generic term for any 2D 02991 * block cyclicly distributed matrix. Its description vector is DESCA: 02992 * 02993 * NOTATION STORED IN EXPLANATION 02994 * ---------------- --------------- ----------------------------------- 02995 * DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type. 02996 * CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating 02997 * the NPROW x NPCOL BLACS process 02998 * grid A is distributed over. The 02999 * context itself is global, but the 03000 * handle (the integer value) may 03001 * vary. 03002 * M_A (global) DESCA( M1_ ) The number of rows in the distri- 03003 * buted matrix A, M_A >= 0. 03004 * N_A (global) DESCA( N1_ ) The number of columns in the dis- 03005 * tributed matrix A, N_A >= 0. 03006 * MB_A (global) DESCA( MB1_ ) The blocking factor used to distri- 03007 * bute the rows of A, MB_A > 0. 03008 * NB_A (global) DESCA( NB1_ ) The blocking factor used to distri- 03009 * bute the columns of A, NB_A > 0. 03010 * RSRC_A (global) DESCA( RSRC1_ ) The process row over which the 03011 * first row of the matrix A is dis- 03012 * tributed, NPROW > RSRC_A >= 0. 03013 * CSRC_A (global) DESCA( CSRC1_ ) The process column over which the 03014 * first column of A is distributed. 03015 * NPCOL > CSRC_A >= 0. 03016 * LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local 03017 * array storing the local blocks of 03018 * the distributed matrix A, 03019 * IF( Lc( 1, N_A ) > 0 ) 03020 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 03021 * ELSE 03022 * LLD_A >= 1. 03023 * 03024 * Let K be the number of rows of a matrix A starting at the global in- 03025 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 03026 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 03027 * receive if these K rows were distributed over NPROW processes. If K 03028 * is the number of columns of a matrix A starting at the global index 03029 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 03030 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 03031 * these K columns were distributed over NPCOL processes. 03032 * 03033 * The values of Lr() and Lc() may be determined via a call to the func- 03034 * tion PB_NUMROC: 03035 * Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW ) 03036 * Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 03037 * 03038 * A description vector is associated with each 2D block-cyclicly dis- 03039 * tributed matrix. This vector stores the information required to 03040 * establish the mapping between a matrix entry and its corresponding 03041 * process and memory location. 03042 * 03043 * In the following comments, the character _ should be read as 03044 * "of the distributed matrix". Let A be a generic term for any 2D 03045 * block cyclicly distributed matrix. Its description vector is DESCA: 03046 * 03047 * NOTATION STORED IN EXPLANATION 03048 * ---------------- --------------- ------------------------------------ 03049 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 03050 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 03051 * the NPROW x NPCOL BLACS process grid 03052 * A is distributed over. The context 03053 * itself is global, but the handle 03054 * (the integer value) may vary. 03055 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 03056 * ted matrix A, M_A >= 0. 03057 * N_A (global) DESCA( N_ ) The number of columns in the distri- 03058 * buted matrix A, N_A >= 0. 03059 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 03060 * block of the matrix A, IMB_A > 0. 03061 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 03062 * left block of the matrix A, 03063 * INB_A > 0. 03064 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 03065 * bute the last M_A-IMB_A rows of A, 03066 * MB_A > 0. 03067 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 03068 * bute the last N_A-INB_A columns of 03069 * A, NB_A > 0. 03070 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 03071 * row of the matrix A is distributed, 03072 * NPROW > RSRC_A >= 0. 03073 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 03074 * first column of A is distributed. 03075 * NPCOL > CSRC_A >= 0. 03076 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 03077 * array storing the local blocks of 03078 * the distributed matrix A, 03079 * IF( Lc( 1, N_A ) > 0 ) 03080 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 03081 * ELSE 03082 * LLD_A >= 1. 03083 * 03084 * Let K be the number of rows of a matrix A starting at the global in- 03085 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 03086 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 03087 * receive if these K rows were distributed over NPROW processes. If K 03088 * is the number of columns of a matrix A starting at the global index 03089 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 03090 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 03091 * these K columns were distributed over NPCOL processes. 03092 * 03093 * The values of Lr() and Lc() may be determined via a call to the func- 03094 * tion PB_NUMROC: 03095 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 03096 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 03097 * 03098 * Arguments 03099 * ========= 03100 * 03101 * DESCIN (global and local input) INTEGER array 03102 * On entry, DESCIN is an array of dimension DLEN1_ or DLEN_ as 03103 * specified by its first entry DESCIN( DTYPE_ ). DESCIN is the 03104 * source array descriptor of type BLOCK_CYCLIC_2D or of type 03105 * BLOCK_CYCLIC_2D_INB. 03106 * 03107 * DESCOUT (global and local output) INTEGER array 03108 * On entry, DESCOUT is an array of dimension DLEN_. DESCOUT is 03109 * the target array descriptor of type BLOCK_CYCLIC_2D_INB. 03110 * 03111 * -- Written on April 1, 1998 by 03112 * R. Clint Whaley, University of Tennessee, Knoxville 37996, USA. 03113 * 03114 * ===================================================================== 03115 * 03116 * .. Parameters .. 03117 INTEGER BLOCK_CYCLIC_2D, CSRC1_, CTXT1_, DLEN1_, 03118 $ DTYPE1_, LLD1_, M1_, MB1_, N1_, NB1_, RSRC1_ 03119 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN1_ = 9, DTYPE1_ = 1, 03120 $ CTXT1_ = 2, M1_ = 3, N1_ = 4, MB1_ = 5, 03121 $ NB1_ = 6, RSRC1_ = 7, CSRC1_ = 8, LLD1_ = 9 ) 03122 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 03123 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 03124 $ RSRC_ 03125 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 03126 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 03127 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 03128 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 03129 * .. 03130 * .. Local Scalars .. 03131 INTEGER I 03132 * .. 03133 * .. Executable Statements .. 03134 * 03135 IF( DESCIN( DTYPE_ ).EQ.BLOCK_CYCLIC_2D ) THEN 03136 DESCOUT( DTYPE_ ) = BLOCK_CYCLIC_2D_INB 03137 DESCOUT( CTXT_ ) = DESCIN( CTXT1_ ) 03138 DESCOUT( M_ ) = DESCIN( M1_ ) 03139 DESCOUT( N_ ) = DESCIN( N1_ ) 03140 DESCOUT( IMB_ ) = DESCIN( MB1_ ) 03141 DESCOUT( INB_ ) = DESCIN( NB1_ ) 03142 DESCOUT( MB_ ) = DESCIN( MB1_ ) 03143 DESCOUT( NB_ ) = DESCIN( NB1_ ) 03144 DESCOUT( RSRC_ ) = DESCIN( RSRC1_ ) 03145 DESCOUT( CSRC_ ) = DESCIN( CSRC1_ ) 03146 DESCOUT( LLD_ ) = DESCIN( LLD1_ ) 03147 ELSE IF( DESCIN( DTYPE_ ).EQ.BLOCK_CYCLIC_2D_INB ) THEN 03148 DO 10 I = 1, DLEN_ 03149 DESCOUT( I ) = DESCIN( I ) 03150 10 CONTINUE 03151 ELSE 03152 DESCOUT( DTYPE_ ) = DESCIN( 1 ) 03153 DESCOUT( CTXT_ ) = DESCIN( 2 ) 03154 DESCOUT( M_ ) = 0 03155 DESCOUT( N_ ) = 0 03156 DESCOUT( IMB_ ) = 1 03157 DESCOUT( INB_ ) = 1 03158 DESCOUT( MB_ ) = 1 03159 DESCOUT( NB_ ) = 1 03160 DESCOUT( RSRC_ ) = 0 03161 DESCOUT( CSRC_ ) = 0 03162 DESCOUT( LLD_ ) = 1 03163 END IF 03164 * 03165 RETURN 03166 * 03167 * End of PB_DESCTRANS 03168 * 03169 END 03170 SUBROUTINE PB_DESCSET2( DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC, 03171 $ CTXT, LLD ) 03172 * 03173 * -- PBLAS test routine (version 2.0) -- 03174 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03175 * and University of California, Berkeley. 03176 * April 1, 1998 03177 * 03178 * .. Scalar Arguments .. 03179 INTEGER CSRC, CTXT, IMB, INB, LLD, M, MB, N, NB, RSRC 03180 * .. 03181 * .. Array Arguments .. 03182 INTEGER DESC( * ) 03183 * .. 03184 * 03185 * Purpose 03186 * ======= 03187 * 03188 * PB_DESCSET2 uses its 10 input arguments M, N, IMB, INB, MB, NB, 03189 * RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type 03190 * BLOCK_CYCLIC_2D_INB. 03191 * 03192 * Notes 03193 * ===== 03194 * 03195 * A description vector is associated with each 2D block-cyclicly dis- 03196 * tributed matrix. This vector stores the information required to 03197 * establish the mapping between a matrix entry and its corresponding 03198 * process and memory location. 03199 * 03200 * In the following comments, the character _ should be read as 03201 * "of the distributed matrix". Let A be a generic term for any 2D 03202 * block cyclicly distributed matrix. Its description vector is DESCA: 03203 * 03204 * NOTATION STORED IN EXPLANATION 03205 * ---------------- --------------- ----------------------------------- 03206 * DTYPE_A (global) DESCA( DTYPE1_ ) The descriptor type. 03207 * CTXT_A (global) DESCA( CTXT1_ ) The BLACS context handle indicating 03208 * the NPROW x NPCOL BLACS process 03209 * grid A is distributed over. The 03210 * context itself is global, but the 03211 * handle (the integer value) may 03212 * vary. 03213 * M_A (global) DESCA( M1_ ) The number of rows in the distri- 03214 * buted matrix A, M_A >= 0. 03215 * N_A (global) DESCA( N1_ ) The number of columns in the dis- 03216 * tributed matrix A, N_A >= 0. 03217 * MB_A (global) DESCA( MB1_ ) The blocking factor used to distri- 03218 * bute the rows of A, MB_A > 0. 03219 * NB_A (global) DESCA( NB1_ ) The blocking factor used to distri- 03220 * bute the columns of A, NB_A > 0. 03221 * RSRC_A (global) DESCA( RSRC1_ ) The process row over which the 03222 * first row of the matrix A is dis- 03223 * tributed, NPROW > RSRC_A >= 0. 03224 * CSRC_A (global) DESCA( CSRC1_ ) The process column over which the 03225 * first column of A is distributed. 03226 * NPCOL > CSRC_A >= 0. 03227 * LLD_A (local) DESCA( LLD1_ ) The leading dimension of the local 03228 * array storing the local blocks of 03229 * the distributed matrix A, 03230 * IF( Lc( 1, N_A ) > 0 ) 03231 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 03232 * ELSE 03233 * LLD_A >= 1. 03234 * 03235 * Let K be the number of rows of a matrix A starting at the global in- 03236 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 03237 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 03238 * receive if these K rows were distributed over NPROW processes. If K 03239 * is the number of columns of a matrix A starting at the global index 03240 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 03241 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 03242 * these K columns were distributed over NPCOL processes. 03243 * 03244 * The values of Lr() and Lc() may be determined via a call to the func- 03245 * tion PB_NUMROC: 03246 * Lr( IA, K ) = PB_NUMROC( K, IA, MB_A, MB_A, MYROW, RSRC_A, NPROW ) 03247 * Lc( JA, K ) = PB_NUMROC( K, JA, NB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 03248 * 03249 * Arguments 03250 * ========= 03251 * 03252 * DESC (global and local output) INTEGER array 03253 * On entry, DESC is an array of dimension DLEN_. DESC is the 03254 * array descriptor to be set. 03255 * 03256 * M (global input) INTEGER 03257 * On entry, M specifies the number of rows of the matrix. 03258 * M must be at least zero. 03259 * 03260 * N (global input) INTEGER 03261 * On entry, N specifies the number of columns of the matrix. 03262 * N must be at least zero. 03263 * 03264 * IMB (global input) INTEGER 03265 * On entry, IMB specifies the row size of the first block of 03266 * the global matrix distribution. IMB must be at least one. 03267 * 03268 * INB (global input) INTEGER 03269 * On entry, INB specifies the column size of the first block 03270 * of the global matrix distribution. INB must be at least one. 03271 * 03272 * MB (global input) INTEGER 03273 * On entry, MB specifies the row size of the blocks used to 03274 * partition the matrix. MB must be at least one. 03275 * 03276 * NB (global input) INTEGER 03277 * On entry, NB specifies the column size of the blocks used to 03278 * partition the matrix. NB must be at least one. 03279 * 03280 * RSRC (global input) INTEGER 03281 * On entry, RSRC specifies the row coordinate of the process 03282 * that possesses the first row of the matrix. When RSRC = -1, 03283 * the data is not distributed but replicated, otherwise RSRC 03284 * must be at least zero and strictly less than NPROW. 03285 * 03286 * CSRC (global input) INTEGER 03287 * On entry, CSRC specifies the column coordinate of the pro- 03288 * cess that possesses the first column of the matrix. When 03289 * CSRC = -1, the data is not distributed but replicated, other- 03290 * wise CSRC must be at least zero and strictly less than NPCOL. 03291 * 03292 * CTXT (local input) INTEGER 03293 * On entry, CTXT specifies the BLACS context handle, indicating 03294 * the global communication context. The value of the context 03295 * itself is local. 03296 * 03297 * LLD (local input) INTEGER 03298 * On entry, LLD specifies the leading dimension of the local 03299 * array storing the local entries of the matrix. LLD must be at 03300 * least MAX( 1, Lr(1,M) ). 03301 * 03302 * -- Written on April 1, 1998 by 03303 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03304 * 03305 * ===================================================================== 03306 * 03307 * .. Parameters .. 03308 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 03309 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 03310 $ RSRC_ 03311 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 03312 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 03313 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 03314 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 03315 * .. 03316 * .. Executable Statements .. 03317 * 03318 DESC( DTYPE_ ) = BLOCK_CYCLIC_2D_INB 03319 DESC( CTXT_ ) = CTXT 03320 DESC( M_ ) = M 03321 DESC( N_ ) = N 03322 DESC( IMB_ ) = IMB 03323 DESC( INB_ ) = INB 03324 DESC( MB_ ) = MB 03325 DESC( NB_ ) = NB 03326 DESC( RSRC_ ) = RSRC 03327 DESC( CSRC_ ) = CSRC 03328 DESC( LLD_ ) = LLD 03329 * 03330 RETURN 03331 * 03332 * End of PB_DESCSET2 03333 * 03334 END 03335 SUBROUTINE PB_DESCINIT2( DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC, 03336 $ CTXT, LLD, INFO ) 03337 * 03338 * -- PBLAS test routine (version 2.0) -- 03339 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03340 * and University of California, Berkeley. 03341 * April 1, 1998 03342 * 03343 * .. Scalar Arguments .. 03344 INTEGER CSRC, CTXT, IMB, INB, INFO, LLD, M, MB, N, NB, 03345 $ RSRC 03346 * .. 03347 * .. Array Arguments .. 03348 INTEGER DESC( * ) 03349 * .. 03350 * 03351 * Purpose 03352 * ======= 03353 * 03354 * PB_DESCINIT2 uses its 10 input arguments M, N, IMB, INB, MB, NB, 03355 * RSRC, CSRC, CTXT and LLD to initialize a descriptor vector of type 03356 * BLOCK_CYCLIC_2D_INB. 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 * DESC (global and local output) INTEGER array 03425 * On entry, DESC is an array of dimension DLEN_. DESC is the 03426 * array descriptor to be set. 03427 * 03428 * M (global input) INTEGER 03429 * On entry, M specifies the number of rows of the matrix. 03430 * M must be at least zero. 03431 * 03432 * N (global input) INTEGER 03433 * On entry, N specifies the number of columns of the matrix. 03434 * N must be at least zero. 03435 * 03436 * IMB (global input) INTEGER 03437 * On entry, IMB specifies the row size of the first block of 03438 * the global matrix distribution. IMB must be at least one. 03439 * 03440 * INB (global input) INTEGER 03441 * On entry, INB specifies the column size of the first block 03442 * of the global matrix distribution. INB must be at least one. 03443 * 03444 * MB (global input) INTEGER 03445 * On entry, MB specifies the row size of the blocks used to 03446 * partition the matrix. MB must be at least one. 03447 * 03448 * NB (global input) INTEGER 03449 * On entry, NB specifies the column size of the blocks used to 03450 * partition the matrix. NB must be at least one. 03451 * 03452 * RSRC (global input) INTEGER 03453 * On entry, RSRC specifies the row coordinate of the process 03454 * that possesses the first row of the matrix. When RSRC = -1, 03455 * the data is not distributed but replicated, otherwise RSRC 03456 * must be at least zero and strictly less than NPROW. 03457 * 03458 * CSRC (global input) INTEGER 03459 * On entry, CSRC specifies the column coordinate of the pro- 03460 * cess that possesses the first column of the matrix. When 03461 * CSRC = -1, the data is not distributed but replicated, other- 03462 * wise CSRC must be at least zero and strictly less than NPCOL. 03463 * 03464 * CTXT (local input) INTEGER 03465 * On entry, CTXT specifies the BLACS context handle, indicating 03466 * the global communication context. The value of the context 03467 * itself is local. 03468 * 03469 * LLD (local input) INTEGER 03470 * On entry, LLD specifies the leading dimension of the local 03471 * array storing the local entries of the matrix. LLD must be at 03472 * least MAX( 1, Lr(1,M) ). 03473 * 03474 * INFO (local output) INTEGER 03475 * = 0: successful exit 03476 * < 0: if INFO = -i, the i-th argument had an illegal value. 03477 * 03478 * Notes 03479 * ===== 03480 * 03481 * If the routine can recover from an erroneous input argument, it will 03482 * return an acceptable descriptor vector. For example, if LLD = 0 on 03483 * input, DESC( LLD_ ) will contain the smallest leading dimension re- 03484 * quired to store the specified m by n matrix, INFO will however be set 03485 * to -11 on exit in that case. 03486 * 03487 * -- Written on April 1, 1998 by 03488 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03489 * 03490 * ===================================================================== 03491 * 03492 * .. Parameters .. 03493 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 03494 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 03495 $ RSRC_ 03496 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 03497 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 03498 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 03499 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 03500 * .. 03501 * .. Local Scalars .. 03502 INTEGER LLDMIN, MP, MYCOL, MYROW, NPCOL, NPROW 03503 * .. 03504 * .. External Subroutines .. 03505 EXTERNAL BLACS_GRIDINFO, PXERBLA 03506 * .. 03507 * .. External Functions .. 03508 INTEGER PB_NUMROC 03509 EXTERNAL PB_NUMROC 03510 * .. 03511 * .. Intrinsic Functions .. 03512 INTRINSIC MAX, MIN 03513 * .. 03514 * .. Executable Statements .. 03515 * 03516 * Get grid parameters 03517 * 03518 CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL ) 03519 * 03520 INFO = 0 03521 IF( M.LT.0 ) THEN 03522 INFO = -2 03523 ELSE IF( N.LT.0 ) THEN 03524 INFO = -3 03525 ELSE IF( IMB.LT.1 ) THEN 03526 INFO = -4 03527 ELSE IF( INB.LT.1 ) THEN 03528 INFO = -5 03529 ELSE IF( MB.LT.1 ) THEN 03530 INFO = -6 03531 ELSE IF( NB.LT.1 ) THEN 03532 INFO = -7 03533 ELSE IF( RSRC.LT.-1 .OR. RSRC.GE.NPROW ) THEN 03534 INFO = -8 03535 ELSE IF( CSRC.LT.-1 .OR. CSRC.GE.NPCOL ) THEN 03536 INFO = -9 03537 ELSE IF( NPROW.EQ.-1 ) THEN 03538 INFO = -10 03539 END IF 03540 * 03541 * Compute minimum LLD if safe (to avoid division by 0) 03542 * 03543 IF( INFO.EQ.0 ) THEN 03544 MP = PB_NUMROC( M, 1, IMB, MB, MYROW, RSRC, NPROW ) 03545 IF( PB_NUMROC( N, 1, INB, NB, MYCOL, CSRC, NPCOL ).GT.0 ) THEN 03546 LLDMIN = MAX( 1, MP ) 03547 ELSE 03548 LLDMIN = 1 03549 END IF 03550 IF( LLD.LT.LLDMIN ) 03551 $ INFO = -11 03552 END IF 03553 * 03554 IF( INFO.NE.0 ) 03555 $ CALL PXERBLA( CTXT, 'PB_DESCINIT2', -INFO ) 03556 * 03557 DESC( DTYPE_ ) = BLOCK_CYCLIC_2D_INB 03558 DESC( CTXT_ ) = CTXT 03559 DESC( M_ ) = MAX( 0, M ) 03560 DESC( N_ ) = MAX( 0, N ) 03561 DESC( IMB_ ) = MAX( 1, IMB ) 03562 DESC( INB_ ) = MAX( 1, INB ) 03563 DESC( MB_ ) = MAX( 1, MB ) 03564 DESC( NB_ ) = MAX( 1, NB ) 03565 DESC( RSRC_ ) = MAX( -1, MIN( RSRC, NPROW-1 ) ) 03566 DESC( CSRC_ ) = MAX( -1, MIN( CSRC, NPCOL-1 ) ) 03567 DESC( LLD_ ) = MAX( LLD, LLDMIN ) 03568 * 03569 RETURN 03570 * 03571 * End of PB_DESCINIT2 03572 * 03573 END 03574 SUBROUTINE PB_BINFO( OFFD, M, N, IMB1, INB1, MB, NB, MRROW, MRCOL, 03575 $ LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, 03576 $ LNBLOC, ILOW, LOW, IUPP, UPP ) 03577 * 03578 * -- PBLAS test routine (version 2.0) -- 03579 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03580 * and University of California, Berkeley. 03581 * April 1, 1998 03582 * 03583 * .. Scalar Arguments .. 03584 INTEGER ILOW, IMB1, IMBLOC, INB1, INBLOC, IUPP, LCMT00, 03585 $ LMBLOC, LNBLOC, LOW, M, MB, MBLKS, MRCOL, 03586 $ MRROW, N, NB, NBLKS, OFFD, UPP 03587 * .. 03588 * 03589 * Purpose 03590 * ======= 03591 * 03592 * PB_BINFO initializes the local information of an m by n local array 03593 * owned by the process of relative coordinates ( MRROW, MRCOL ). Note 03594 * that if m or n is less or equal than zero, there is no data, in which 03595 * case this process does not need the local information computed by 03596 * this routine to proceed. 03597 * 03598 * Arguments 03599 * ========= 03600 * 03601 * OFFD (global input) INTEGER 03602 * On entry, OFFD specifies the off-diagonal of the underlying 03603 * matrix of interest as follows: 03604 * OFFD = 0 specifies the main diagonal, 03605 * OFFD > 0 specifies lower subdiagonals, and 03606 * OFFD < 0 specifies upper superdiagonals. 03607 * 03608 * M (local input) INTEGER 03609 * On entry, M specifies the local number of rows of the under- 03610 * lying matrix owned by the process of relative coordinates 03611 * ( MRROW, MRCOL ). M must be at least zero. 03612 * 03613 * N (local input) INTEGER 03614 * On entry, N specifies the local number of columns of the un- 03615 * derlying matrix owned by the process of relative coordinates 03616 * ( MRROW, MRCOL ). N must be at least zero. 03617 * 03618 * IMB1 (global input) INTEGER 03619 * On input, IMB1 specifies the global true size of the first 03620 * block of rows of the underlying global submatrix. IMB1 must 03621 * be at least MIN( 1, M ). 03622 * 03623 * INB1 (global input) INTEGER 03624 * On input, INB1 specifies the global true size of the first 03625 * block of columns of the underlying global submatrix. INB1 03626 * must be at least MIN( 1, N ). 03627 * 03628 * MB (global input) INTEGER 03629 * On entry, MB specifies the blocking factor used to partition 03630 * the rows of the matrix. MB must be at least one. 03631 * 03632 * NB (global input) INTEGER 03633 * On entry, NB specifies the blocking factor used to partition 03634 * the the columns of the matrix. NB must be at least one. 03635 * 03636 * MRROW (local input) INTEGER 03637 * On entry, MRROW specifies the relative row coordinate of the 03638 * process that possesses these M rows. MRROW must be least zero 03639 * and strictly less than NPROW. 03640 * 03641 * MRCOL (local input) INTEGER 03642 * On entry, MRCOL specifies the relative column coordinate of 03643 * the process that possesses these N columns. MRCOL must be 03644 * least zero and strictly less than NPCOL. 03645 * 03646 * LCMT00 (local output) INTEGER 03647 * On exit, LCMT00 is the LCM value of the left upper block of 03648 * this m by n local block owned by the process of relative co- 03649 * ordinates ( MRROW, MRCOL ). 03650 * 03651 * MBLKS (local output) INTEGER 03652 * On exit, MBLKS specifies the local number of blocks of rows 03653 * corresponding to M. MBLKS must be at least zero. 03654 * 03655 * NBLKS (local output) INTEGER 03656 * On exit, NBLKS specifies the local number of blocks of co- 03657 * lumns corresponding to N. NBLKS must be at least zero. 03658 * 03659 * IMBLOC (local output) INTEGER 03660 * On exit, IMBLOC specifies the number of rows (size) of the 03661 * uppest blocks of this m by n local array owned by the process 03662 * of relative coordinates ( MRROW, MRCOL ). IMBLOC is at least 03663 * MIN( 1, M ). 03664 * 03665 * INBLOC (local output) INTEGER 03666 * On exit, INBLOC specifies the number of columns (size) of 03667 * the leftmost blocks of this m by n local array owned by the 03668 * process of relative coordinates ( MRROW, MRCOL ). INBLOC is 03669 * at least MIN( 1, N ). 03670 * 03671 * LMBLOC (local output) INTEGER 03672 * On exit, LMBLOC specifies the number of rows (size) of the 03673 * lowest blocks of this m by n local array owned by the process 03674 * of relative coordinates ( MRROW, MRCOL ). LMBLOC is at least 03675 * MIN( 1, M ). 03676 * 03677 * LNBLOC (local output) INTEGER 03678 * On exit, LNBLOC specifies the number of columns (size) of the 03679 * rightmost blocks of this m by n local array owned by the 03680 * process of relative coordinates ( MRROW, MRCOL ). LNBLOC is 03681 * at least MIN( 1, N ). 03682 * 03683 * ILOW (local output) INTEGER 03684 * On exit, ILOW is the lower bound characterizing the first co- 03685 * lumn block owning offdiagonals of this m by n array. ILOW 03686 * must be less or equal than zero. 03687 * 03688 * LOW (global output) INTEGER 03689 * On exit, LOW is the lower bound characterizing the column 03690 * blocks with te exception of the first one (see ILOW) owning 03691 * offdiagonals of this m by n array. LOW must be less or equal 03692 * than zero. 03693 * 03694 * IUPP (local output) INTEGER 03695 * On exit, IUPP is the upper bound characterizing the first row 03696 * block owning offdiagonals of this m by n array. IUPP must be 03697 * greater or equal than zero. 03698 * 03699 * UPP (global output) INTEGER 03700 * On exit, UPP is the upper bound characterizing the row 03701 * blocks with te exception of the first one (see IUPP) owning 03702 * offdiagonals of this m by n array. UPP must be greater or 03703 * equal than zero. 03704 * 03705 * -- Written on April 1, 1998 by 03706 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03707 * 03708 * ===================================================================== 03709 * 03710 * .. Local Scalars .. 03711 INTEGER TMP1 03712 * .. 03713 * .. Intrinsic Functions .. 03714 INTRINSIC MAX, MIN 03715 * .. 03716 * .. Executable Statements .. 03717 * 03718 * Initialize LOW, ILOW, UPP, IUPP, LMBLOC, LNBLOC, IMBLOC, INBLOC, 03719 * MBLKS, NBLKS and LCMT00. 03720 * 03721 LOW = 1 - NB 03722 UPP = MB - 1 03723 * 03724 LCMT00 = OFFD 03725 * 03726 IF( M.LE.0 .OR. N.LE.0 ) THEN 03727 * 03728 IF( MRROW.GT.0 ) THEN 03729 IUPP = MB - 1 03730 ELSE 03731 IUPP = MAX( 0, IMB1 - 1 ) 03732 END IF 03733 IMBLOC = 0 03734 MBLKS = 0 03735 LMBLOC = 0 03736 * 03737 IF( MRCOL.GT.0 ) THEN 03738 ILOW = 1 - NB 03739 ELSE 03740 ILOW = MIN( 0, 1 - INB1 ) 03741 END IF 03742 INBLOC = 0 03743 NBLKS = 0 03744 LNBLOC = 0 03745 * 03746 LCMT00 = LCMT00 + ( LOW - ILOW + MRCOL * NB ) - 03747 $ ( IUPP - UPP + MRROW * MB ) 03748 * 03749 RETURN 03750 * 03751 END IF 03752 * 03753 IF( MRROW.GT.0 ) THEN 03754 * 03755 IMBLOC = MIN( M, MB ) 03756 IUPP = MB - 1 03757 LCMT00 = LCMT00 - ( IMB1 - MB + MRROW * MB ) 03758 MBLKS = ( M - 1 ) / MB + 1 03759 LMBLOC = M - ( M / MB ) * MB 03760 IF( LMBLOC.EQ.0 ) 03761 $ LMBLOC = MB 03762 * 03763 IF( MRCOL.GT.0 ) THEN 03764 * 03765 INBLOC = MIN( N, NB ) 03766 ILOW = 1 - NB 03767 LCMT00 = LCMT00 + INB1 - NB + MRCOL * NB 03768 NBLKS = ( N - 1 ) / NB + 1 03769 LNBLOC = N - ( N / NB ) * NB 03770 IF( LNBLOC.EQ.0 ) 03771 $ LNBLOC = NB 03772 * 03773 ELSE 03774 * 03775 INBLOC = INB1 03776 ILOW = 1 - INB1 03777 TMP1 = N - INB1 03778 IF( TMP1.GT.0 ) THEN 03779 * 03780 * more than one block 03781 * 03782 NBLKS = ( TMP1 - 1 ) / NB + 2 03783 LNBLOC = TMP1 - ( TMP1 / NB ) * NB 03784 IF( LNBLOC.EQ.0 ) 03785 $ LNBLOC = NB 03786 * 03787 ELSE 03788 * 03789 NBLKS = 1 03790 LNBLOC = INB1 03791 * 03792 END IF 03793 * 03794 END IF 03795 * 03796 ELSE 03797 * 03798 IMBLOC = IMB1 03799 IUPP = IMB1 - 1 03800 TMP1 = M - IMB1 03801 IF( TMP1.GT.0 ) THEN 03802 * 03803 * more than one block 03804 * 03805 MBLKS = ( TMP1 - 1 ) / MB + 2 03806 LMBLOC = TMP1 - ( TMP1 / MB ) * MB 03807 IF( LMBLOC.EQ.0 ) 03808 $ LMBLOC = MB 03809 * 03810 ELSE 03811 * 03812 MBLKS = 1 03813 LMBLOC = IMB1 03814 * 03815 END IF 03816 * 03817 IF( MRCOL.GT.0 ) THEN 03818 * 03819 INBLOC = MIN( N, NB ) 03820 ILOW = 1 - NB 03821 LCMT00 = LCMT00 + INB1 - NB + MRCOL * NB 03822 NBLKS = ( N - 1 ) / NB + 1 03823 LNBLOC = N - ( N / NB ) * NB 03824 IF( LNBLOC.EQ.0 ) 03825 $ LNBLOC = NB 03826 * 03827 ELSE 03828 * 03829 INBLOC = INB1 03830 ILOW = 1 - INB1 03831 TMP1 = N - INB1 03832 IF( TMP1.GT.0 ) THEN 03833 * 03834 * more than one block 03835 * 03836 NBLKS = ( TMP1 - 1 ) / NB + 2 03837 LNBLOC = TMP1 - ( TMP1 / NB ) * NB 03838 IF( LNBLOC.EQ.0 ) 03839 $ LNBLOC = NB 03840 * 03841 ELSE 03842 * 03843 NBLKS = 1 03844 LNBLOC = INB1 03845 * 03846 END IF 03847 * 03848 END IF 03849 * 03850 END IF 03851 * 03852 RETURN 03853 * 03854 * End of PB_BINFO 03855 * 03856 END 03857 INTEGER FUNCTION PILAENV( ICTXT, PREC ) 03858 * 03859 * -- PBLAS test routine (version 2.0) -- 03860 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03861 * and University of California, Berkeley. 03862 * April 1, 1998 03863 * 03864 * .. Scalar Arguments .. 03865 INTEGER ICTXT 03866 CHARACTER*1 PREC 03867 * .. 03868 * 03869 * Purpose 03870 * ======= 03871 * 03872 * PILAENV returns the logical computational block size to be used by 03873 * the PBLAS routines during testing and timing. This is a special ver- 03874 * sion to be used only as part of the testing or timing PBLAS programs 03875 * for testing different values of logical computational block sizes for 03876 * the PBLAS routines. It is called by the PBLAS routines to retrieve a 03877 * logical computational block size value. 03878 * 03879 * Arguments 03880 * ========= 03881 * 03882 * ICTXT (local input) INTEGER 03883 * On entry, ICTXT specifies the BLACS context handle, indica- 03884 * ting the global context of the operation. The context itself 03885 * is global, but the value of ICTXT is local. 03886 * 03887 * PREC (dummy input) CHARACTER*1 03888 * On entry, PREC is a dummy argument. 03889 * 03890 * -- Written on April 1, 1998 by 03891 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03892 * 03893 * ===================================================================== 03894 * 03895 * .. Common Blocks .. 03896 INTEGER INFO, NBLOG 03897 COMMON /INFOC/INFO, NBLOG 03898 * .. 03899 * .. Executable Statements .. 03900 * 03901 PILAENV = NBLOG 03902 * 03903 RETURN 03904 * 03905 * End of PILAENV 03906 * 03907 END 03908 SUBROUTINE PB_LOCINFO( I, INB, NB, MYROC, SRCPROC, NPROCS, 03909 $ ILOCBLK, ILOCOFF, MYDIST ) 03910 * 03911 * -- PBLAS test routine (version 2.0) -- 03912 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03913 * and University of California, Berkeley. 03914 * April 1, 1998 03915 * 03916 * .. Scalar Arguments .. 03917 INTEGER I, ILOCBLK, ILOCOFF, INB, MYDIST, MYROC, NB, 03918 $ NPROCS, SRCPROC 03919 * .. 03920 * 03921 * Purpose 03922 * ======= 03923 * 03924 * PB_LOCINFO computes local information about the beginning of a sub- 03925 * matrix starting at the global index I. 03926 * 03927 * Arguments 03928 * ========= 03929 * 03930 * I (global input) INTEGER 03931 * On entry, I specifies the global starting index in the ma- 03932 * trix. I must be at least one. 03933 * 03934 * INB (global input) INTEGER 03935 * On entry, INB specifies the size of the first block of rows 03936 * or columns of the matrix. INB must be at least one. 03937 * 03938 * NB (global input) INTEGER 03939 * On entry, NB specifies the size of the blocks of rows or co- 03940 * lumns of the matrix is partitioned into. NB must be at least 03941 * one. 03942 * 03943 * MYROC (local input) INTEGER 03944 * On entry, MYROC is the coordinate of the process whose local 03945 * information is determined. MYROC is at least zero and 03946 * strictly less than NPROCS. 03947 * 03948 * SRCPROC (global input) INTEGER 03949 * On entry, SRCPROC specifies the coordinate of the process 03950 * that possesses the first row or column of the matrix. When 03951 * SRCPROC = -1, the data is not distributed but replicated, 03952 * otherwise SRCPROC must be at least zero and strictly less 03953 * than NPROCS. 03954 * 03955 * NPROCS (global input) INTEGER 03956 * On entry, NPROCS specifies the total number of process rows 03957 * or columns over which the submatrix is distributed. NPROCS 03958 * must be at least one. 03959 * 03960 * ILOCBLK (local output) INTEGER 03961 * On exit, ILOCBLK specifies the local row or column block 03962 * coordinate corresponding to the row or column I of the ma- 03963 * trix. ILOCBLK must be at least zero. 03964 * 03965 * ILOCOFF (local output) INTEGER 03966 * On exit, ILOCOFF specifies the local row offset in the block 03967 * of local coordinate ILOCBLK corresponding to the row or co- 03968 * lumn I of the matrix. ILOCOFF must at least zero. 03969 * 03970 * MYDIST (local output) INTEGER 03971 * On exit, MYDIST specifies the relative process coordinate of 03972 * the process specified by MYROC to the process owning the row 03973 * or column I. MYDIST is at least zero and strictly less than 03974 * NPROCS. 03975 * 03976 * -- Written on April 1, 1998 by 03977 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03978 * 03979 * ===================================================================== 03980 * 03981 * .. Local Scalars .. 03982 INTEGER ITMP, NBLOCKS, PROC 03983 * .. 03984 * .. Executable Statements .. 03985 * 03986 ILOCOFF = 0 03987 * 03988 IF( SRCPROC.LT.0 ) THEN 03989 * 03990 MYDIST = 0 03991 * 03992 IF( I.LE.INB ) THEN 03993 * 03994 ILOCBLK = 0 03995 ILOCOFF = I - 1 03996 * 03997 ELSE 03998 * 03999 ITMP = I - INB 04000 NBLOCKS = ( ITMP - 1 ) / NB + 1 04001 ILOCBLK = NBLOCKS 04002 ILOCOFF = ITMP - 1 - ( NBLOCKS - 1 ) * NB 04003 * 04004 END IF 04005 * 04006 ELSE 04007 * 04008 PROC = SRCPROC 04009 MYDIST = MYROC - PROC 04010 IF( MYDIST.LT.0 ) 04011 $ MYDIST = MYDIST + NPROCS 04012 * 04013 IF( I.LE.INB ) THEN 04014 * 04015 ILOCBLK = 0 04016 IF( MYROC.EQ.PROC ) 04017 $ ILOCOFF = I - 1 04018 * 04019 ELSE 04020 * 04021 ITMP = I - INB 04022 NBLOCKS = ( ITMP - 1 ) / NB + 1 04023 PROC = PROC + NBLOCKS 04024 PROC = PROC - ( PROC / NPROCS ) * NPROCS 04025 ILOCBLK = NBLOCKS / NPROCS 04026 * 04027 IF( ( ILOCBLK*NPROCS ).LT.( MYDIST-NBLOCKS ) ) 04028 $ ILOCBLK = ILOCBLK + 1 04029 * 04030 IF( MYROC.EQ.PROC ) 04031 $ ILOCOFF = ITMP - 1 - ( NBLOCKS - 1 ) * NB 04032 * 04033 END IF 04034 * 04035 END IF 04036 * 04037 RETURN 04038 * 04039 * End of PB_LOCINFO 04040 * 04041 END 04042 SUBROUTINE PB_INITJMP( COLMAJ, NVIR, IMBVIR, INBVIR, IMBLOC, 04043 $ INBLOC, MB, NB, RSRC, CSRC, NPROW, NPCOL, 04044 $ STRIDE, JMP ) 04045 * 04046 * -- PBLAS test routine (version 2.0) -- 04047 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04048 * and University of California, Berkeley. 04049 * April 1, 1998 04050 * 04051 * .. Scalar Arguments .. 04052 LOGICAL COLMAJ 04053 INTEGER CSRC, IMBLOC, IMBVIR, INBLOC, INBVIR, MB, NB, 04054 $ NPCOL, NPROW, NVIR, RSRC, STRIDE 04055 * .. 04056 * .. Array Arguments .. 04057 INTEGER JMP( * ) 04058 * .. 04059 * 04060 * Purpose 04061 * ======= 04062 * 04063 * PB_INITJMP initializes the jump values JMP used by the random matrix 04064 * generator. 04065 * 04066 * Arguments 04067 * ========= 04068 * 04069 * COLMAJ (global input) LOGICAL 04070 * On entry, COLMAJ specifies the ordering of the random sequen- 04071 * ce. When COLMAJ is .TRUE., the random sequence will be used 04072 * for a column major ordering, and otherwise a row-major orde- 04073 * ring. This impacts on the computation of the jump values. 04074 * 04075 * NVIR (global input) INTEGER 04076 * On entry, NVIR specifies the size of the underlying virtual 04077 * matrix. NVIR must be at least zero. 04078 * 04079 * IMBVIR (local input) INTEGER 04080 * On entry, IMBVIR specifies the number of virtual rows of the 04081 * upper left block of the underlying virtual submatrix. IMBVIR 04082 * must be at least IMBLOC. 04083 * 04084 * INBVIR (local input) INTEGER 04085 * On entry, INBVIR specifies the number of virtual columns of 04086 * the upper left block of the underlying virtual submatrix. 04087 * INBVIR must be at least INBLOC. 04088 * 04089 * IMBLOC (local input) INTEGER 04090 * On entry, IMBLOC specifies the number of rows (size) of the 04091 * local uppest blocks. IMBLOC is at least zero. 04092 * 04093 * INBLOC (local input) INTEGER 04094 * On entry, INBLOC specifies the number of columns (size) of 04095 * the local leftmost blocks. INBLOC is at least zero. 04096 * 04097 * MB (global input) INTEGER 04098 * On entry, MB specifies the size of the blocks used to parti- 04099 * tion the matrix rows. MB must be at least one. 04100 * 04101 * NB (global input) INTEGER 04102 * On entry, NB specifies the size of the blocks used to parti- 04103 * tion the matrix columns. NB must be at least one. 04104 * 04105 * RSRC (global input) INTEGER 04106 * On entry, RSRC specifies the row coordinate of the process 04107 * that possesses the first row of the matrix. When RSRC = -1, 04108 * the rows are not distributed but replicated, otherwise RSRC 04109 * must be at least zero and strictly less than NPROW. 04110 * 04111 * CSRC (global input) INTEGER 04112 * On entry, CSRC specifies the column coordinate of the pro- 04113 * cess that possesses the first column of the matrix. When CSRC 04114 * is equal to -1, the columns are not distributed but replica- 04115 * ted, otherwise CSRC must be at least zero and strictly less 04116 * than NPCOL. 04117 * 04118 * NPROW (global input) INTEGER 04119 * On entry, NPROW specifies the total number of process rows 04120 * over which the matrix is distributed. NPROW must be at least 04121 * one. 04122 * 04123 * NPCOL (global input) INTEGER 04124 * On entry, NPCOL specifies the total number of process co- 04125 * lumns over which the matrix is distributed. NPCOL must be at 04126 * least one. 04127 * 04128 * STRIDE (global input) INTEGER 04129 * On entry, STRIDE specifies the number of random numbers to be 04130 * generated to compute one matrix entry. In the real case, 04131 * STRIDE is usually 1, where as in the complex case STRIDE is 04132 * usually 2 in order to generate the real and imaginary parts. 04133 * 04134 * JMP (local output) INTEGER array 04135 * On entry, JMP is an array of dimension JMP_LEN. On exit, this 04136 * array contains the different jump values used by the random 04137 * matrix generator. 04138 * 04139 * -- Written on April 1, 1998 by 04140 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04141 * 04142 * ===================================================================== 04143 * 04144 * .. Parameters .. 04145 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN, 04146 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB, 04147 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW 04148 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3, 04149 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6, 04150 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9, 04151 $ JMP_NQNB = 10, JMP_NQINBLOC = 11, 04152 $ JMP_LEN = 11 ) 04153 * .. 04154 * .. Local Scalars .. 04155 INTEGER NPMB, NQNB 04156 * .. 04157 * .. Executable Statements .. 04158 * 04159 IF( RSRC.LT.0 ) THEN 04160 NPMB = MB 04161 ELSE 04162 NPMB = NPROW * MB 04163 END IF 04164 IF( CSRC.LT.0 ) THEN 04165 NQNB = NB 04166 ELSE 04167 NQNB = NPCOL * NB 04168 END IF 04169 * 04170 JMP( JMP_1 ) = 1 04171 * 04172 JMP( JMP_MB ) = MB 04173 JMP( JMP_IMBV ) = IMBVIR 04174 JMP( JMP_NPMB ) = NPMB 04175 JMP( JMP_NPIMBLOC ) = IMBLOC + NPMB - MB 04176 * 04177 JMP( JMP_NB ) = NB 04178 JMP( JMP_INBV ) = INBVIR 04179 JMP( JMP_NQNB ) = NQNB 04180 JMP( JMP_NQINBLOC ) = INBLOC + NQNB - NB 04181 * 04182 IF( COLMAJ ) THEN 04183 JMP( JMP_ROW ) = STRIDE 04184 JMP( JMP_COL ) = STRIDE * NVIR 04185 ELSE 04186 JMP( JMP_ROW ) = STRIDE * NVIR 04187 JMP( JMP_COL ) = STRIDE 04188 END IF 04189 * 04190 RETURN 04191 * 04192 * End of PB_INITJMP 04193 * 04194 END 04195 SUBROUTINE PB_INITMULADD( MULADD0, JMP, IMULADD ) 04196 * 04197 * -- PBLAS test routine (version 2.0) -- 04198 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04199 * and University of California, Berkeley. 04200 * April 1, 1998 04201 * 04202 * .. Array Arguments .. 04203 INTEGER IMULADD( 4, * ), JMP( * ), MULADD0( * ) 04204 * .. 04205 * 04206 * Purpose 04207 * ======= 04208 * 04209 * PB_INITMULADD initializes the constants a's and c's corresponding to 04210 * the jump values (JMP) used by the matrix generator. 04211 * 04212 * Arguments 04213 * ========= 04214 * 04215 * MULADD0 (local input) INTEGER array 04216 * On entry, MULADD0 is an array of dimension 4 containing the 04217 * encoded initial constants a and c to jump from X( n ) to 04218 * X( n+1 ) = a*X( n ) + c in the random sequence. MULADD0(1:2) 04219 * contains respectively the 16-lower and 16-higher bits of the 04220 * constant a, and MULADD0(3:4) contains the 16-lower and 04221 * 16-higher bits of the constant c. 04222 * 04223 * JMP (local input) INTEGER array 04224 * On entry, JMP is an array of dimension JMP_LEN containing the 04225 * different jump values used by the matrix generator. 04226 * 04227 * IMULADD (local output) INTEGER array 04228 * On entry, IMULADD is an array of dimension ( 4, JMP_LEN ). On 04229 * exit, the jth column of this array contains the encoded ini- 04230 * tial constants a_j and c_j to jump from X( n ) to X(n+JMP(j)) 04231 * (= a_j*X( n ) + c_j) in the random sequence. IMULADD(1:2,j) 04232 * contains respectively the 16-lower and 16-higher bits of the 04233 * constant a_j, and IMULADD(3:4,j) contains the 16-lower and 04234 * 16-higher bits of the constant c_j. 04235 * 04236 * -- Written on April 1, 1998 by 04237 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04238 * 04239 * ===================================================================== 04240 * 04241 * .. Parameters .. 04242 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN, 04243 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB, 04244 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW 04245 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3, 04246 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6, 04247 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9, 04248 $ JMP_NQNB = 10, JMP_NQINBLOC = 11, 04249 $ JMP_LEN = 11 ) 04250 * .. 04251 * 04252 * .. Local Arrays .. 04253 INTEGER ITMP1( 2 ), ITMP2( 2 ) 04254 * .. 04255 * .. External Subroutines .. 04256 EXTERNAL PB_JUMP 04257 * .. 04258 * .. Executable Statements .. 04259 * 04260 ITMP2( 1 ) = 100 04261 ITMP2( 2 ) = 0 04262 * 04263 * Compute IMULADD for all JMP values 04264 * 04265 CALL PB_JUMP( JMP( JMP_1 ), MULADD0, ITMP2, ITMP1, 04266 $ IMULADD( 1, JMP_1 ) ) 04267 * 04268 CALL PB_JUMP( JMP( JMP_ROW ), MULADD0, ITMP1, ITMP2, 04269 $ IMULADD( 1, JMP_ROW ) ) 04270 CALL PB_JUMP( JMP( JMP_COL ), MULADD0, ITMP1, ITMP2, 04271 $ IMULADD( 1, JMP_COL ) ) 04272 * 04273 * Compute constants a and c to jump JMP( * ) numbers in the 04274 * sequence for column- or row-major ordering of the sequence. 04275 * 04276 CALL PB_JUMP( JMP( JMP_IMBV ), IMULADD( 1, JMP_ROW ), ITMP1, 04277 $ ITMP2, IMULADD( 1, JMP_IMBV ) ) 04278 CALL PB_JUMP( JMP( JMP_MB ), IMULADD( 1, JMP_ROW ), ITMP1, 04279 $ ITMP2, IMULADD( 1, JMP_MB ) ) 04280 CALL PB_JUMP( JMP( JMP_NPMB ), IMULADD( 1, JMP_ROW ), ITMP1, 04281 $ ITMP2, IMULADD( 1, JMP_NPMB ) ) 04282 CALL PB_JUMP( JMP( JMP_NPIMBLOC ), IMULADD( 1, JMP_ROW ), ITMP1, 04283 $ ITMP2, IMULADD( 1, JMP_NPIMBLOC ) ) 04284 * 04285 CALL PB_JUMP( JMP( JMP_INBV ), IMULADD( 1, JMP_COL ), ITMP1, 04286 $ ITMP2, IMULADD( 1, JMP_INBV ) ) 04287 CALL PB_JUMP( JMP( JMP_NB ), IMULADD( 1, JMP_COL ), ITMP1, 04288 $ ITMP2, IMULADD( 1, JMP_NB ) ) 04289 CALL PB_JUMP( JMP( JMP_NQNB ), IMULADD( 1, JMP_COL ), ITMP1, 04290 $ ITMP2, IMULADD( 1, JMP_NQNB ) ) 04291 CALL PB_JUMP( JMP( JMP_NQINBLOC ), IMULADD( 1, JMP_COL ), ITMP1, 04292 $ ITMP2, IMULADD( 1, JMP_NQINBLOC ) ) 04293 * 04294 RETURN 04295 * 04296 * End of PB_INITMULADD 04297 * 04298 END 04299 SUBROUTINE PB_SETLOCRAN( SEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF, 04300 $ MYRDIST, MYCDIST, NPROW, NPCOL, JMP, 04301 $ IMULADD, IRAN ) 04302 * 04303 * -- PBLAS test routine (version 2.0) -- 04304 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04305 * and University of California, Berkeley. 04306 * April 1, 1998 04307 * 04308 * .. Scalar Arguments .. 04309 INTEGER ILOCBLK, ILOCOFF, JLOCBLK, JLOCOFF, MYCDIST, 04310 $ MYRDIST, NPCOL, NPROW, SEED 04311 * .. 04312 * .. Array Arguments .. 04313 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * ) 04314 * .. 04315 * 04316 * Purpose 04317 * ======= 04318 * 04319 * PB_SETLOCRAN locally initializes the random number generator. 04320 * 04321 * Arguments 04322 * ========= 04323 * 04324 * SEED (global input) INTEGER 04325 * On entry, SEED specifies a positive integer used to initiali- 04326 * ze the first number in the random sequence used by the matrix 04327 * generator. SEED must be at least zero. 04328 * 04329 * ILOCBLK (local input) INTEGER 04330 * On entry, ILOCBLK specifies the local row block coordinate 04331 * corresponding to the first row of the submatrix of interest. 04332 * ILOCBLK must be at least zero. 04333 * 04334 * ILOCOFF (local input) INTEGER 04335 * On entry, ILOCOFF specifies the local row offset in the block 04336 * of local coordinate ILOCBLK corresponding to the first row of 04337 * the submatrix of interest. ILOCOFF must at least zero. 04338 * 04339 * JLOCBLK (local input) INTEGER 04340 * On entry, JLOCBLK specifies the local column block coordinate 04341 * corresponding to the first column of the submatrix of inte- 04342 * rest. JLOCBLK must be at least zero. 04343 * 04344 * JLOCOFF (local input) INTEGER 04345 * On entry, JLOCOFF specifies the local column offset in the 04346 * block of local coordinate JLOCBLK corresponding to the first 04347 * column of the submatrix of interest. JLOCOFF must be at least 04348 * zero. 04349 * 04350 * MYRDIST (local input) INTEGER 04351 * On entry, MYRDIST specifies the relative row process coordi- 04352 * nate to the process owning the first row of the submatrix of 04353 * interest. MYRDIST must be at least zero and stricly less than 04354 * NPROW (see the subroutine PB_LOCINFO). 04355 * 04356 * MYCDIST (local input) INTEGER 04357 * On entry, MYCDIST specifies the relative column process coor- 04358 * dinate to the process owning the first column of the subma- 04359 * trix of interest. MYCDIST must be at least zero and stricly 04360 * less than NPCOL (see the subroutine PB_LOCINFO). 04361 * 04362 * NPROW (global input) INTEGER 04363 * On entry, NPROW specifies the total number of process rows 04364 * over which the matrix is distributed. NPROW must be at least 04365 * one. 04366 * 04367 * NPCOL (global input) INTEGER 04368 * On entry, NPCOL specifies the total number of process co- 04369 * lumns over which the matrix is distributed. NPCOL must be at 04370 * least one. 04371 * 04372 * JMP (local input) INTEGER array 04373 * On entry, JMP is an array of dimension JMP_LEN containing the 04374 * different jump values used by the matrix generator. 04375 * 04376 * IMULADD (local input) INTEGER array 04377 * On entry, IMULADD is an array of dimension (4, JMP_LEN). The 04378 * jth column of this array contains the encoded initial cons- 04379 * tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) ) 04380 * (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j) 04381 * contains respectively the 16-lower and 16-higher bits of the 04382 * constant a_j, and IMULADD(3:4,j) contains the 16-lower and 04383 * 16-higher bits of the constant c_j. 04384 * 04385 * IRAN (local output) INTEGER array 04386 * On entry, IRAN is an array of dimension 2. On exit, IRAN con- 04387 * tains respectively the 16-lower and 32-higher bits of the en- 04388 * coding of the entry of the random sequence corresponding lo- 04389 * cally to the first local array entry to generate. 04390 * 04391 * -- Written on April 1, 1998 by 04392 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04393 * 04394 * ===================================================================== 04395 * 04396 * .. Parameters .. 04397 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN, 04398 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB, 04399 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW 04400 PARAMETER ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3, 04401 $ JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6, 04402 $ JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9, 04403 $ JMP_NQNB = 10, JMP_NQINBLOC = 11, 04404 $ JMP_LEN = 11 ) 04405 * .. 04406 * .. Local Arrays .. 04407 INTEGER IMULADDTMP( 4 ), ITMP( 2 ) 04408 * .. 04409 * .. External Subroutines .. 04410 EXTERNAL PB_JUMP, PB_SETRAN 04411 * .. 04412 * .. Executable Statements .. 04413 * 04414 * Compute and set the value of IRAN corresponding to A( IA, JA ) 04415 * 04416 ITMP( 1 ) = SEED 04417 ITMP( 2 ) = 0 04418 * 04419 CALL PB_JUMP( JMP( JMP_1 ), IMULADD( 1, JMP_1 ), ITMP, IRAN, 04420 $ IMULADDTMP ) 04421 * 04422 * Jump ILOCBLK blocks of rows + ILOCOFF rows 04423 * 04424 CALL PB_JUMP( ILOCOFF, IMULADD( 1, JMP_ROW ), IRAN, ITMP, 04425 $ IMULADDTMP ) 04426 IF( MYRDIST.GT.0 ) THEN 04427 CALL PB_JUMP( JMP( JMP_IMBV ), IMULADD( 1, JMP_ROW ), ITMP, 04428 $ IRAN, IMULADDTMP ) 04429 CALL PB_JUMP( MYRDIST - 1, IMULADD( 1, JMP_MB ), IRAN, 04430 $ ITMP, IMULADDTMP ) 04431 CALL PB_JUMP( ILOCBLK, IMULADD( 1, JMP_NPMB ), ITMP, 04432 $ IRAN, IMULADDTMP ) 04433 ELSE 04434 IF( ILOCBLK.GT.0 ) THEN 04435 CALL PB_JUMP( JMP( JMP_IMBV ), IMULADD( 1, JMP_ROW ), ITMP, 04436 $ IRAN, IMULADDTMP ) 04437 CALL PB_JUMP( NPROW - 1, IMULADD( 1, JMP_MB ), IRAN, 04438 $ ITMP, IMULADDTMP ) 04439 CALL PB_JUMP( ILOCBLK - 1, IMULADD( 1, JMP_NPMB ), ITMP, 04440 $ IRAN, IMULADDTMP ) 04441 ELSE 04442 CALL PB_JUMP( 0, IMULADD( 1, JMP_1 ), ITMP, 04443 $ IRAN, IMULADDTMP ) 04444 END IF 04445 END IF 04446 * 04447 * Jump JLOCBLK blocks of columns + JLOCOFF columns 04448 * 04449 CALL PB_JUMP( JLOCOFF, IMULADD( 1, JMP_COL ), IRAN, ITMP, 04450 $ IMULADDTMP ) 04451 IF( MYCDIST.GT.0 ) THEN 04452 CALL PB_JUMP( JMP( JMP_INBV ), IMULADD( 1, JMP_COL ), ITMP, 04453 $ IRAN, IMULADDTMP ) 04454 CALL PB_JUMP( MYCDIST - 1, IMULADD( 1, JMP_NB ), IRAN, 04455 $ ITMP, IMULADDTMP ) 04456 CALL PB_JUMP( JLOCBLK, IMULADD( 1, JMP_NQNB ), ITMP, 04457 $ IRAN, IMULADDTMP ) 04458 ELSE 04459 IF( JLOCBLK.GT.0 ) THEN 04460 CALL PB_JUMP( JMP( JMP_INBV ), IMULADD( 1, JMP_COL ), ITMP, 04461 $ IRAN, IMULADDTMP ) 04462 CALL PB_JUMP( NPCOL - 1, IMULADD( 1, JMP_NB ), IRAN, 04463 $ ITMP, IMULADDTMP ) 04464 CALL PB_JUMP( JLOCBLK - 1, IMULADD( 1, JMP_NQNB ), ITMP, 04465 $ IRAN, IMULADDTMP ) 04466 ELSE 04467 CALL PB_JUMP( 0, IMULADD( 1, JMP_1 ), ITMP, 04468 $ IRAN, IMULADDTMP ) 04469 END IF 04470 END IF 04471 * 04472 CALL PB_SETRAN( IRAN, IMULADD( 1, JMP_1 ) ) 04473 * 04474 RETURN 04475 * 04476 * End of PB_SETLOCRAN 04477 * 04478 END 04479 SUBROUTINE PB_LADD( J, K, I ) 04480 * 04481 * -- PBLAS test routine (version 2.0) -- 04482 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04483 * and University of California, Berkeley. 04484 * April 1, 1998 04485 * 04486 * .. Array Arguments .. 04487 INTEGER I( 2 ), J( 2 ), K( 2 ) 04488 * .. 04489 * 04490 * Purpose 04491 * ======= 04492 * 04493 * PB_LADD adds without carry two long positive integers K and J and put 04494 * the result into I. The long integers I, J, K are encoded on 31 bits 04495 * using an array of 2 integers. The 16-lower bits are stored in the 04496 * first entry of each array, the 15-higher bits in the second entry. 04497 * For efficiency purposes, the intrisic modulo function is inlined. 04498 * 04499 * Arguments 04500 * ========= 04501 * 04502 * J (local input) INTEGER array 04503 * On entry, J is an array of dimension 2 containing the encoded 04504 * long integer J. 04505 * 04506 * K (local input) INTEGER array 04507 * On entry, K is an array of dimension 2 containing the encoded 04508 * long integer K. 04509 * 04510 * I (local output) INTEGER array 04511 * On entry, I is an array of dimension 2. On exit, this array 04512 * contains the encoded long integer I. 04513 * 04514 * Further Details 04515 * =============== 04516 * 04517 * K( 2 ) K( 1 ) 04518 * 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 ) 04519 * + carry = ( K( 1 ) + J( 1 ) ) / 2**16 04520 * J( 2 ) J( 1 ) 04521 * 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry 04522 * ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 ) 04523 * I( 2 ) I( 1 ) 04524 * 0XXXXXXX XXXXXXXX I 04525 * 04526 * -- Written on April 1, 1998 by 04527 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04528 * 04529 * ===================================================================== 04530 * 04531 * .. Parameters .. 04532 INTEGER IPOW15, IPOW16 04533 PARAMETER ( IPOW15 = 2**15, IPOW16 = 2**16 ) 04534 * .. 04535 * .. Local Scalars .. 04536 INTEGER ITMP1, ITMP2 04537 * .. 04538 * .. Executable Statements .. 04539 * 04540 * I( 1 ) = MOD( K( 1 ) + J( 1 ), IPOW16 ) 04541 * 04542 ITMP1 = K( 1 ) + J( 1 ) 04543 ITMP2 = ITMP1 / IPOW16 04544 I( 1 ) = ITMP1 - ITMP2 * IPOW16 04545 * 04546 * I( 2 ) = MOD( ( K( 1 ) + J( 1 ) ) / IPOW16 + K( 2 ) + J( 2 ), 04547 * IPOW15 ) 04548 * 04549 ITMP1 = ITMP2 + K( 2 ) + J( 2 ) 04550 ITMP2 = ITMP1 / IPOW15 04551 I( 2 ) = ITMP1 - ITMP2 * IPOW15 04552 * 04553 RETURN 04554 * 04555 * End of PB_LADD 04556 * 04557 END 04558 SUBROUTINE PB_LMUL( K, J, I ) 04559 * 04560 * -- PBLAS test routine (version 2.0) -- 04561 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04562 * and University of California, Berkeley. 04563 * April 1, 1998 04564 * 04565 * .. Array Arguments .. 04566 INTEGER I( 2 ), J( 2 ), K( 2 ) 04567 * .. 04568 * 04569 * Purpose 04570 * ======= 04571 * 04572 * PB_LMUL multiplies without carry two long positive integers K and J 04573 * and put the result into I. The long integers I, J, K are encoded on 04574 * 31 bits using an array of 2 integers. The 16-lower bits are stored in 04575 * the first entry of each array, the 15-higher bits in the second entry 04576 * of each array. For efficiency purposes, the intrisic modulo function 04577 * is inlined. 04578 * 04579 * Arguments 04580 * ========= 04581 * 04582 * K (local input) INTEGER array 04583 * On entry, K is an array of dimension 2 containing the encoded 04584 * long integer K. 04585 * 04586 * J (local input) INTEGER array 04587 * On entry, J is an array of dimension 2 containing the encoded 04588 * long integer J. 04589 * 04590 * I (local output) INTEGER array 04591 * On entry, I is an array of dimension 2. On exit, this array 04592 * contains the encoded long integer I. 04593 * 04594 * Further Details 04595 * =============== 04596 * 04597 * K( 2 ) K( 1 ) 04598 * 0XXXXXXX XXXXXXXX K I( 1 ) = MOD( K( 1 ) + J( 1 ), 2**16 ) 04599 * * carry = ( K( 1 ) + J( 1 ) ) / 2**16 04600 * J( 2 ) J( 1 ) 04601 * 0XXXXXXX XXXXXXXX J I( 2 ) = K( 2 ) + J( 2 ) + carry 04602 * ---------------------- I( 2 ) = MOD( I( 2 ), 2**15 ) 04603 * I( 2 ) I( 1 ) 04604 * 0XXXXXXX XXXXXXXX I 04605 * 04606 * -- Written on April 1, 1998 by 04607 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04608 * 04609 * ===================================================================== 04610 * 04611 * .. Parameters .. 04612 INTEGER IPOW15, IPOW16, IPOW30 04613 PARAMETER ( IPOW15 = 2**15, IPOW16 = 2**16, 04614 $ IPOW30 = 2**30 ) 04615 * .. 04616 * .. Local Scalars .. 04617 INTEGER ITMP1, ITMP2 04618 * .. 04619 * .. Executable Statements .. 04620 * 04621 ITMP1 = K( 1 ) * J( 1 ) 04622 IF( ITMP1.LT.0 ) 04623 $ ITMP1 = ( ITMP1 + IPOW30 ) + IPOW30 04624 * 04625 * I( 1 ) = MOD( ITMP1, IPOW16 ) 04626 * 04627 ITMP2 = ITMP1 / IPOW16 04628 I( 1 ) = ITMP1 - ITMP2 * IPOW16 04629 * 04630 ITMP1 = K( 1 ) * J( 2 ) + K( 2 ) * J( 1 ) 04631 IF( ITMP1.LT.0 ) 04632 $ ITMP1 = ( ITMP1 + IPOW30 ) + IPOW30 04633 * 04634 ITMP1 = ITMP2 + ITMP1 04635 IF( ITMP1.LT.0 ) 04636 $ ITMP1 = ( ITMP1 + IPOW30 ) + IPOW30 04637 * 04638 * I( 2 ) = MOD( ITMP1, IPOW15 ) 04639 * 04640 I( 2 ) = ITMP1 - ( ITMP1 / IPOW15 ) * IPOW15 04641 * 04642 RETURN 04643 * 04644 * End of PB_LMUL 04645 * 04646 END 04647 SUBROUTINE PB_JUMP( K, MULADD, IRANN, IRANM, IMA ) 04648 * 04649 * -- PBLAS test routine (version 2.0) -- 04650 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04651 * and University of California, Berkeley. 04652 * April 1, 1998 04653 * 04654 * .. Scalar Arguments .. 04655 INTEGER K 04656 * .. 04657 * .. Array Arguments .. 04658 INTEGER IMA( 4 ), IRANM( 2 ), IRANN( 2 ), MULADD( 4 ) 04659 * .. 04660 * 04661 * Purpose 04662 * ======= 04663 * 04664 * PB_JUMP computes the constants A and C to jump K numbers in the ran- 04665 * dom sequence: 04666 * 04667 * X( n+K ) = A * X( n ) + C. 04668 * 04669 * The constants encoded in MULADD specify how to jump from entry in the 04670 * sequence to the next. 04671 * 04672 * Arguments 04673 * ========= 04674 * 04675 * K (local input) INTEGER 04676 * On entry, K specifies the number of entries of the sequence 04677 * to jump over. When K is less or equal than zero, A and C are 04678 * not computed, and IRANM is set to IRANN corresponding to a 04679 * jump of size zero. 04680 * 04681 * MULADD (local input) INTEGER array 04682 * On entry, MULADD is an array of dimension 4 containing the 04683 * encoded constants a and c to jump from X( n ) to X( n+1 ) 04684 * ( = a*X( n )+c) in the random sequence. MULADD(1:2) contains 04685 * respectively the 16-lower and 16-higher bits of the constant 04686 * a, and MULADD(3:4) contains the 16-lower and 16-higher bits 04687 * of the constant c. 04688 * 04689 * IRANN (local input) INTEGER array 04690 * On entry, IRANN is an array of dimension 2. This array con- 04691 * tains respectively the 16-lower and 16-higher bits of the en- 04692 * coding of X( n ). 04693 * 04694 * IRANM (local output) INTEGER array 04695 * On entry, IRANM is an array of dimension 2. On exit, this 04696 * array contains respectively the 16-lower and 16-higher bits 04697 * of the encoding of X( n+K ). 04698 * 04699 * IMA (local output) INTEGER array 04700 * On entry, IMA is an array of dimension 4. On exit, when K is 04701 * greater than zero, this array contains the encoded constants 04702 * A and C to jump from X( n ) to X( n+K ) in the random se- 04703 * quence. IMA(1:2) contains respectively the 16-lower and 04704 * 16-higher bits of the constant A, and IMA(3:4) contains the 04705 * 16-lower and 16-higher bits of the constant C. When K is 04706 * less or equal than zero, this array is not referenced. 04707 * 04708 * -- Written on April 1, 1998 by 04709 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04710 * 04711 * ===================================================================== 04712 * 04713 * .. Local Scalars .. 04714 INTEGER I 04715 * .. 04716 * .. Local Arrays .. 04717 INTEGER J( 2 ) 04718 * .. 04719 * .. External Subroutines .. 04720 EXTERNAL PB_LADD, PB_LMUL 04721 * .. 04722 * .. Executable Statements .. 04723 * 04724 IF( K.GT.0 ) THEN 04725 * 04726 IMA( 1 ) = MULADD( 1 ) 04727 IMA( 2 ) = MULADD( 2 ) 04728 IMA( 3 ) = MULADD( 3 ) 04729 IMA( 4 ) = MULADD( 4 ) 04730 * 04731 DO 10 I = 1, K - 1 04732 * 04733 CALL PB_LMUL( IMA, MULADD, J ) 04734 * 04735 IMA( 1 ) = J( 1 ) 04736 IMA( 2 ) = J( 2 ) 04737 * 04738 CALL PB_LMUL( IMA( 3 ), MULADD, J ) 04739 CALL PB_LADD( MULADD( 3 ), J, IMA( 3 ) ) 04740 * 04741 10 CONTINUE 04742 * 04743 CALL PB_LMUL( IRANN, IMA, J ) 04744 CALL PB_LADD( J, IMA( 3 ), IRANM ) 04745 * 04746 ELSE 04747 * 04748 IRANM( 1 ) = IRANN( 1 ) 04749 IRANM( 2 ) = IRANN( 2 ) 04750 * 04751 END IF 04752 * 04753 RETURN 04754 * 04755 * End of PB_JUMP 04756 * 04757 END 04758 SUBROUTINE PB_SETRAN( IRAN, IAC ) 04759 * 04760 * -- PBLAS test routine (version 2.0) -- 04761 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04762 * and University of California, Berkeley. 04763 * April 1, 1998 04764 * 04765 * .. Array Arguments .. 04766 INTEGER IAC( 4 ), IRAN( 2 ) 04767 * .. 04768 * 04769 * Purpose 04770 * ======= 04771 * 04772 * PB_SETRAN initializes the random generator with the encoding of the 04773 * first number X( 1 ) in the sequence, and the constants a and c used 04774 * to compute the next element in the sequence: 04775 * 04776 * X( n+1 ) = a * X( n ) + c. 04777 * 04778 * X( 1 ), a and c are stored in the common block RANCOM for later use 04779 * (see the routines PB_SRAN or PB_DRAN). 04780 * 04781 * Arguments 04782 * ========= 04783 * 04784 * IRAN (local input) INTEGER array 04785 * On entry, IRAN is an array of dimension 2. This array con- 04786 * tains respectively the 16-lower and 16-higher bits of the en- 04787 * coding of X( 1 ). 04788 * 04789 * IAC (local input) INTEGER array 04790 * On entry, IAC is an array of dimension 4. IAC(1:2) contain 04791 * respectively the 16-lower and 16-higher bits of the constant 04792 * a, and IAC(3:4) contain the 16-lower and 16-higher bits of 04793 * the constant c. 04794 * 04795 * -- Written on April 1, 1998 by 04796 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04797 * 04798 * ===================================================================== 04799 * 04800 * .. Common Blocks .. 04801 INTEGER IACS( 4 ), IRAND( 2 ) 04802 COMMON /RANCOM/ IRAND, IACS 04803 * .. 04804 * .. Save Statements .. 04805 SAVE /RANCOM/ 04806 * .. 04807 * .. Executable Statements .. 04808 * 04809 IRAND( 1 ) = IRAN( 1 ) 04810 IRAND( 2 ) = IRAN( 2 ) 04811 IACS( 1 ) = IAC( 1 ) 04812 IACS( 2 ) = IAC( 2 ) 04813 IACS( 3 ) = IAC( 3 ) 04814 IACS( 4 ) = IAC( 4 ) 04815 * 04816 RETURN 04817 * 04818 * End of PB_SETRAN 04819 * 04820 END 04821 SUBROUTINE PB_JUMPIT( MULADD, IRANN, IRANM ) 04822 * 04823 * -- PBLAS test routine (version 2.0) -- 04824 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 04825 * and University of California, Berkeley. 04826 * April 1, 1998 04827 * 04828 * .. Array Arguments .. 04829 INTEGER IRANM( 2 ), IRANN( 2 ), MULADD( 4 ) 04830 * .. 04831 * 04832 * Purpose 04833 * ======= 04834 * 04835 * PB_JUMPIT jumps in the random sequence from the number X( n ) enco- 04836 * ded in IRANN to the number X( m ) encoded in IRANM using the cons- 04837 * tants A and C encoded in MULADD: 04838 * 04839 * X( m ) = A * X( n ) + C. 04840 * 04841 * The constants A and C obviously depend on m and n, see the subroutine 04842 * PB_JUMP in order to set them up. 04843 * 04844 * Arguments 04845 * ========= 04846 * 04847 * MULADD (local input) INTEGER array 04848 * On netry, MULADD is an array of dimension 4. MULADD(1:2) con- 04849 * tains respectively the 16-lower and 16-higher bits of the 04850 * constant A, and MULADD(3:4) contains the 16-lower and 04851 * 16-higher bits of the constant C. 04852 * 04853 * IRANN (local input) INTEGER array 04854 * On entry, IRANN is an array of dimension 2. This array con- 04855 * tains respectively the 16-lower and 16-higher bits of the en- 04856 * coding of X( n ). 04857 * 04858 * IRANM (local output) INTEGER array 04859 * On entry, IRANM is an array of dimension 2. On exit, this 04860 * array contains respectively the 16-lower and 16-higher bits 04861 * of the encoding of X( m ). 04862 * 04863 * -- Written on April 1, 1998 by 04864 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 04865 * 04866 * ===================================================================== 04867 * 04868 * .. Local Arrays .. 04869 INTEGER J( 2 ) 04870 * .. 04871 * .. External Subroutines .. 04872 EXTERNAL PB_LADD, PB_LMUL 04873 * .. 04874 * .. Common Blocks .. 04875 INTEGER IACS( 4 ), IRAND( 2 ) 04876 COMMON /RANCOM/ IRAND, IACS 04877 * .. 04878 * .. Save Statements .. 04879 SAVE /RANCOM/ 04880 * .. 04881 * .. Executable Statements .. 04882 * 04883 CALL PB_LMUL( IRANN, MULADD, J ) 04884 CALL PB_LADD( J, MULADD( 3 ), IRANM ) 04885 * 04886 IRAND( 1 ) = IRANM( 1 ) 04887 IRAND( 2 ) = IRANM( 2 ) 04888 * 04889 RETURN 04890 * 04891 * End of PB_JUMPIT 04892 * 04893 END
