|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
|
ScaLAPACK
2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
|
00001 BLOCK DATA 00002 INTEGER NSUBS 00003 PARAMETER (NSUBS = 8) 00004 CHARACTER*7 SNAMES( NSUBS ) 00005 COMMON /SNAMEC/SNAMES 00006 DATA SNAMES/'PSSWAP ', 'PSSCAL ', 'PSCOPY ', 00007 $ 'PSAXPY ', 'PSDOT ', 'PSNRM2 ', 00008 $ 'PSASUM ', 'PSAMAX '/ 00009 END BLOCK DATA 00010 00011 PROGRAM PSBLA1TST 00012 * 00013 * -- PBLAS testing driver (version 2.0.2) -- 00014 * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver 00015 * May 1 2012 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * PSBLA1TST is the main testing program for the PBLAS Level 1 routines. 00021 * 00022 * The program must be driven by a short data file. An annotated exam- 00023 * ple of a data file can be obtained by deleting the first 3 characters 00024 * from the following 44 lines: 00025 * 'Level 1 PBLAS, Testing input file' 00026 * 'Intel iPSC/860 hypercube, gamma model.' 00027 * 'PSBLAS1TST.SUMM' output file name (if any) 00028 * 6 device out 00029 * F logical flag, T to stop on failures 00030 * F logical flag, T to test error exits 00031 * 0 verbosity, 0 for pass/fail, 1-3 for matrix dump on errors 00032 * 10 the leading dimension gap 00033 * 1 number of process grids (ordered pairs of P & Q) 00034 * 2 2 1 4 2 3 8 values of P 00035 * 2 2 4 1 3 2 1 values of Q 00036 * 1.0E0 value of ALPHA 00037 * 2 number of tests problems 00038 * 3 4 values of N 00039 * 6 10 values of M_X 00040 * 6 10 values of N_X 00041 * 2 5 values of IMB_X 00042 * 2 5 values of INB_X 00043 * 2 5 values of MB_X 00044 * 2 5 values of NB_X 00045 * 0 1 values of RSRC_X 00046 * 0 0 values of CSRC_X 00047 * 1 1 values of IX 00048 * 1 1 values of JX 00049 * 1 1 values of INCX 00050 * 6 10 values of M_Y 00051 * 6 10 values of N_Y 00052 * 2 5 values of IMB_Y 00053 * 2 5 values of INB_Y 00054 * 2 5 values of MB_Y 00055 * 2 5 values of NB_Y 00056 * 0 1 values of RSRC_Y 00057 * 0 0 values of CSRC_Y 00058 * 1 1 values of IY 00059 * 1 1 values of JY 00060 * 6 1 values of INCY 00061 * PSSWAP T put F for no test in the same column 00062 * PSSCAL T put F for no test in the same column 00063 * PSCOPY T put F for no test in the same column 00064 * PSAXPY T put F for no test in the same column 00065 * PSDOT T put F for no test in the same column 00066 * PSNRM2 T put F for no test in the same column 00067 * PSASUM T put F for no test in the same column 00068 * PSAMAX T put F for no test in the same column 00069 * 00070 * Internal Parameters 00071 * =================== 00072 * 00073 * TOTMEM INTEGER 00074 * TOTMEM is a machine-specific parameter indicating the maxi- 00075 * mum amount of available memory per process in bytes. The 00076 * user should customize TOTMEM to his platform. Remember to 00077 * leave room in memory for the operating system, the BLACS 00078 * buffer, etc. For example, on a system with 8 MB of memory 00079 * per process (e.g., one processor on an Intel iPSC/860), the 00080 * parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS, 00081 * code, BLACS buffer, etc). However, for PVM, we usually set 00082 * TOTMEM = 2000000. Some experimenting with the maximum value 00083 * of TOTMEM may be required. By default, TOTMEM is 2000000. 00084 * 00085 * REALSZ INTEGER 00086 * REALSZ indicates the length in bytes on the given platform 00087 * for a single precision real. By default, REALSZ is set to 00088 * four. 00089 * 00090 * MEM REAL array 00091 * MEM is an array of dimension TOTMEM / REALSZ. 00092 * All arrays used by SCALAPACK routines are allocated from this 00093 * array MEM and referenced by pointers. The integer IPA, for 00094 * example, is a pointer to the starting element of MEM for the 00095 * matrix A. 00096 * 00097 * -- Written on April 1, 1998 by 00098 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 00099 * 00100 * ===================================================================== 00101 * 00102 * .. Parameters .. 00103 INTEGER MAXTESTS, MAXGRIDS, GAPMUL, REALSZ, TOTMEM, 00104 $ MEMSIZ, NSUBS 00105 REAL PADVAL, ZERO 00106 PARAMETER ( MAXTESTS = 20, MAXGRIDS = 20, GAPMUL = 10, 00107 $ REALSZ = 4, TOTMEM = 2000000, 00108 $ MEMSIZ = TOTMEM / REALSZ, ZERO = 0.0E+0, 00109 $ PADVAL = -9923.0E+0, NSUBS = 8 ) 00110 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 00111 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 00112 $ RSRC_ 00113 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 00114 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 00115 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 00116 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 00117 * .. 00118 * .. Local Scalars .. 00119 LOGICAL ERRFLG, SOF, TEE 00120 INTEGER CSRCX, CSRCY, I, IAM, ICTXT, IGAP, IMBX, IMBY, 00121 $ IMIDX, IMIDY, INBX, INBY, INCX, INCY, IPMATX, 00122 $ IPMATY, IPOSTX, IPOSTY, IPREX, IPREY, IPW, IPX, 00123 $ IPY, IVERB, IX, IXSEED, IY, IYSEED, J, JX, JY, 00124 $ K, LDX, LDY, MBX, MBY, MEMREQD, MPX, MPY, MX, 00125 $ MY, MYCOL, MYROW, N, NBX, NBY, NGRIDS, NOUT, 00126 $ NPCOL, NPROCS, NPROW, NQX, NQY, NTESTS, NX, NY, 00127 $ PISCLR, RSRCX, RSRCY, TSKIP, TSTCNT 00128 REAL ALPHA, PSCLR, PUSCLR 00129 * .. 00130 * .. Local Arrays .. 00131 CHARACTER*80 OUTFILE 00132 LOGICAL LTEST( NSUBS ), YCHECK( NSUBS ) 00133 INTEGER CSCXVAL( MAXTESTS ), CSCYVAL( MAXTESTS ), 00134 $ DESCX( DLEN_ ), DESCXR( DLEN_ ), 00135 $ DESCY( DLEN_ ), DESCYR( DLEN_ ), IERR( 4 ), 00136 $ IMBXVAL( MAXTESTS ), IMBYVAL( MAXTESTS ), 00137 $ INBXVAL( MAXTESTS ), INBYVAL( MAXTESTS ), 00138 $ INCXVAL( MAXTESTS ), INCYVAL( MAXTESTS ), 00139 $ IXVAL( MAXTESTS ), IYVAL( MAXTESTS ), 00140 $ JXVAL( MAXTESTS ), JYVAL( MAXTESTS ), 00141 $ KFAIL( NSUBS ), KPASS( NSUBS ), KSKIP( NSUBS ), 00142 $ KTESTS( NSUBS ), MBXVAL( MAXTESTS ), 00143 $ MBYVAL( MAXTESTS ), MXVAL( MAXTESTS ), 00144 $ MYVAL( MAXTESTS ), NBXVAL( MAXTESTS ), 00145 $ NBYVAL( MAXTESTS ), NVAL( MAXTESTS ), 00146 $ NXVAL( MAXTESTS ), NYVAL( MAXTESTS ), 00147 $ PVAL( MAXTESTS ), QVAL( MAXTESTS ), 00148 $ RSCXVAL( MAXTESTS ), RSCYVAL( MAXTESTS ) 00149 REAL MEM( MEMSIZ ) 00150 * .. 00151 * .. External Subroutines .. 00152 EXTERNAL BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT, 00153 $ BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO, 00154 $ IGSUM2D, PB_DESCSET2, PB_PSLAPRNT, PB_SCHEKPAD, 00155 $ PB_SFILLPAD, PSAMAX, PSASUM, PSAXPY, 00156 $ PSBLA1TSTINFO, PSBLAS1TSTCHK, PSBLAS1TSTCHKE, 00157 $ PSCHKARG1, PSCHKVOUT, PSCOPY, PSDOT, PSLAGEN, 00158 $ PSMPRNT, PSNRM2, PSSCAL, PSSWAP, PSVPRNT, 00159 $ PVDESCCHK, PVDIMCHK 00160 * .. 00161 * .. Intrinsic Functions .. 00162 INTRINSIC ABS, MAX, MOD 00163 * .. 00164 * .. Common Blocks .. 00165 CHARACTER*7 SNAMES( NSUBS ) 00166 LOGICAL ABRTFLG 00167 INTEGER INFO, NBLOG 00168 COMMON /SNAMEC/SNAMES 00169 COMMON /INFOC/INFO, NBLOG 00170 COMMON /PBERRORC/NOUT, ABRTFLG 00171 * .. 00172 * .. Data Statements .. 00173 DATA YCHECK/.TRUE., .FALSE., .TRUE., .TRUE., .TRUE., 00174 $ .FALSE., .FALSE., .FALSE./ 00175 * .. 00176 * .. Executable Statements .. 00177 * 00178 * Initialization 00179 * 00180 * Set flag so that the PBLAS error handler will abort on errors. 00181 * 00182 ABRTFLG = .FALSE. 00183 * 00184 * So far no error, will become true as soon as one error is found. 00185 * 00186 ERRFLG = .FALSE. 00187 * 00188 * Test counters 00189 * 00190 TSKIP = 0 00191 TSTCNT = 0 00192 * 00193 * Seeds for random matrix generations. 00194 * 00195 IXSEED = 100 00196 IYSEED = 200 00197 * 00198 * So far no tests have been performed. 00199 * 00200 DO 10 I = 1, NSUBS 00201 KPASS( I ) = 0 00202 KSKIP( I ) = 0 00203 KFAIL( I ) = 0 00204 KTESTS( I ) = 0 00205 10 CONTINUE 00206 * 00207 * Get starting information 00208 * 00209 CALL BLACS_PINFO( IAM, NPROCS ) 00210 CALL PSBLA1TSTINFO( OUTFILE, NOUT, NTESTS, NVAL, MXVAL, NXVAL, 00211 $ IMBXVAL, MBXVAL, INBXVAL, NBXVAL, RSCXVAL, 00212 $ CSCXVAL, IXVAL, JXVAL, INCXVAL, MYVAL, 00213 $ NYVAL, IMBYVAL, MBYVAL, INBYVAL, NBYVAL, 00214 $ RSCYVAL, CSCYVAL, IYVAL, JYVAL, INCYVAL, 00215 $ MAXTESTS, NGRIDS, PVAL, MAXGRIDS, QVAL, 00216 $ MAXGRIDS, LTEST, SOF, TEE, IAM, IGAP, IVERB, 00217 $ NPROCS, ALPHA, MEM ) 00218 * 00219 IF( IAM.EQ.0 ) THEN 00220 WRITE( NOUT, FMT = 9979 ) 00221 WRITE( NOUT, FMT = * ) 00222 END IF 00223 * 00224 * If TEE is set then Test Error Exits of routines. 00225 * 00226 IF( TEE ) 00227 $ CALL PSBLAS1TSTCHKE( LTEST, NOUT, NPROCS ) 00228 * 00229 * Loop over different process grids 00230 * 00231 DO 60 I = 1, NGRIDS 00232 * 00233 NPROW = PVAL( I ) 00234 NPCOL = QVAL( I ) 00235 * 00236 * Make sure grid information is correct 00237 * 00238 IERR( 1 ) = 0 00239 IF( NPROW.LT.1 ) THEN 00240 IF( IAM.EQ.0 ) 00241 $ WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPROW', NPROW 00242 IERR( 1 ) = 1 00243 ELSE IF( NPCOL.LT.1 ) THEN 00244 IF( IAM.EQ.0 ) 00245 $ WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPCOL', NPCOL 00246 IERR( 1 ) = 1 00247 ELSE IF( NPROW*NPCOL.GT.NPROCS ) THEN 00248 IF( IAM.EQ.0 ) 00249 $ WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS 00250 IERR( 1 ) = 1 00251 END IF 00252 * 00253 IF( IERR( 1 ).GT.0 ) THEN 00254 IF( IAM.EQ.0 ) 00255 $ WRITE( NOUT, FMT = 9997 ) 'GRID' 00256 TSKIP = TSKIP + 1 00257 GO TO 60 00258 END IF 00259 * 00260 * Define process grid 00261 * 00262 CALL BLACS_GET( -1, 0, ICTXT ) 00263 CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL ) 00264 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 00265 * 00266 * Go to bottom of process grid loop if this case doesn't use my 00267 * process 00268 * 00269 IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL ) 00270 $ GO TO 60 00271 * 00272 * Loop over number of tests 00273 * 00274 DO 50 J = 1, NTESTS 00275 * 00276 * Get the test parameters 00277 * 00278 N = NVAL( J ) 00279 MX = MXVAL( J ) 00280 NX = NXVAL( J ) 00281 IMBX = IMBXVAL( J ) 00282 MBX = MBXVAL( J ) 00283 INBX = INBXVAL( J ) 00284 NBX = NBXVAL( J ) 00285 RSRCX = RSCXVAL( J ) 00286 CSRCX = CSCXVAL( J ) 00287 IX = IXVAL( J ) 00288 JX = JXVAL( J ) 00289 INCX = INCXVAL( J ) 00290 MY = MYVAL( J ) 00291 NY = NYVAL( J ) 00292 IMBY = IMBYVAL( J ) 00293 MBY = MBYVAL( J ) 00294 INBY = INBYVAL( J ) 00295 NBY = NBYVAL( J ) 00296 RSRCY = RSCYVAL( J ) 00297 CSRCY = CSCYVAL( J ) 00298 IY = IYVAL( J ) 00299 JY = JYVAL( J ) 00300 INCY = INCYVAL( J ) 00301 * 00302 IF( IAM.EQ.0 ) THEN 00303 TSTCNT = TSTCNT + 1 00304 WRITE( NOUT, FMT = * ) 00305 WRITE( NOUT, FMT = 9996 ) TSTCNT, NPROW, NPCOL 00306 WRITE( NOUT, FMT = * ) 00307 * 00308 WRITE( NOUT, FMT = 9995 ) 00309 WRITE( NOUT, FMT = 9994 ) 00310 WRITE( NOUT, FMT = 9995 ) 00311 WRITE( NOUT, FMT = 9993 ) N, IX, JX, MX, NX, IMBX, INBX, 00312 $ MBX, NBX, RSRCX, CSRCX, INCX 00313 * 00314 WRITE( NOUT, FMT = 9995 ) 00315 WRITE( NOUT, FMT = 9992 ) 00316 WRITE( NOUT, FMT = 9995 ) 00317 WRITE( NOUT, FMT = 9993 ) N, IY, JY, MY, NY, IMBY, INBY, 00318 $ MBY, NBY, RSRCY, CSRCY, INCY 00319 WRITE( NOUT, FMT = 9995 ) 00320 END IF 00321 * 00322 * Check the validity of the input and initialize DESC_ 00323 * 00324 CALL PVDESCCHK( ICTXT, NOUT, 'X', DESCX, 00325 $ BLOCK_CYCLIC_2D_INB, MX, NX, IMBX, INBX, 00326 $ MBX, NBX, RSRCX, CSRCX, INCX, MPX, NQX, 00327 $ IPREX, IMIDX, IPOSTX, IGAP, GAPMUL, 00328 $ IERR( 1 ) ) 00329 CALL PVDESCCHK( ICTXT, NOUT, 'Y', DESCY, 00330 $ BLOCK_CYCLIC_2D_INB, MY, NY, IMBY, INBY, 00331 $ MBY, NBY, RSRCY, CSRCY, INCY, MPY, NQY, 00332 $ IPREY, IMIDY, IPOSTY, IGAP, GAPMUL, 00333 $ IERR( 2 ) ) 00334 * 00335 IF( IERR( 1 ).GT.0 .OR. IERR( 2 ).GT.0 ) THEN 00336 TSKIP = TSKIP + 1 00337 GO TO 40 00338 END IF 00339 * 00340 LDX = MAX( 1, MX ) 00341 LDY = MAX( 1, MY ) 00342 * 00343 * Assign pointers into MEM for matrices corresponding to 00344 * vectors X and Y. Ex: IPX starts at position MEM( IPREX+1 ). 00345 * 00346 IPX = IPREX + 1 00347 IPY = IPX + DESCX( LLD_ ) * NQX + IPOSTX + IPREY 00348 IPMATX = IPY + DESCY( LLD_ ) * NQY + IPOSTY 00349 IPMATY = IPMATX + MX * NX 00350 IPW = IPMATY + MY * NY 00351 * 00352 * Check if sufficient memory. 00353 * Requirement = mem for local part of parallel matrices + 00354 * mem for whole matrices for comp. check + 00355 * mem for recving comp. check error vals. 00356 * 00357 MEMREQD = IPW - 1 + 00358 $ MAX( MAX( IMBX, MBX ), MAX( IMBY, MBY ) ) 00359 IERR( 1 ) = 0 00360 IF( MEMREQD.GT.MEMSIZ ) THEN 00361 IF( IAM.EQ.0 ) 00362 $ WRITE( NOUT, FMT = 9990 ) MEMREQD*REALSZ 00363 IERR( 1 ) = 1 00364 END IF 00365 * 00366 * Check all processes for an error 00367 * 00368 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) 00369 * 00370 IF( IERR( 1 ).GT.0 ) THEN 00371 IF( IAM.EQ.0 ) 00372 $ WRITE( NOUT, FMT = 9991 ) 00373 TSKIP = TSKIP + 1 00374 GO TO 40 00375 END IF 00376 * 00377 * Loop over all PBLAS 1 routines 00378 * 00379 DO 30 K = 1, NSUBS 00380 * 00381 * Continue only if this sub has to be tested. 00382 * 00383 IF( .NOT.LTEST( K ) ) 00384 $ GO TO 30 00385 * 00386 IF( IAM.EQ.0 ) THEN 00387 WRITE( NOUT, FMT = * ) 00388 WRITE( NOUT, FMT = 9989 ) SNAMES( K ) 00389 END IF 00390 * 00391 * Check the validity of the operand sizes 00392 * 00393 CALL PVDIMCHK( ICTXT, NOUT, N, 'X', IX, JX, DESCX, INCX, 00394 $ IERR( 1 ) ) 00395 CALL PVDIMCHK( ICTXT, NOUT, N, 'Y', IY, JY, DESCY, INCY, 00396 $ IERR( 2 ) ) 00397 * 00398 IF( IERR( 1 ).NE.0 .OR. IERR( 2 ).NE.0 ) THEN 00399 KSKIP( K ) = KSKIP( K ) + 1 00400 GO TO 30 00401 END IF 00402 * 00403 * Generate distributed matrices X and Y 00404 * 00405 CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX, 1, 00406 $ 1, DESCX, IXSEED, MEM( IPX ), 00407 $ DESCX( LLD_ ) ) 00408 IF( YCHECK( K ) ) 00409 $ CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MY, NY, 00410 $ 1, 1, DESCY, IYSEED, MEM( IPY ), 00411 $ DESCY( LLD_ ) ) 00412 * 00413 * Generate entire matrices on each process. 00414 * 00415 CALL PB_DESCSET2( DESCXR, MX, NX, IMBX, INBX, MBX, NBX, 00416 $ -1, -1, ICTXT, MAX( 1, MX ) ) 00417 CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX, 1, 00418 $ 1, DESCXR, IXSEED, MEM( IPMATX ), 00419 $ DESCXR( LLD_ ) ) 00420 IF( YCHECK( K ) ) THEN 00421 CALL PB_DESCSET2( DESCYR, MY, NY, IMBY, INBY, MBY, 00422 $ NBY, -1, -1, ICTXT, MAX( 1, MY ) ) 00423 CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MY, NY, 00424 $ 1, 1, DESCYR, IYSEED, MEM( IPMATY ), 00425 $ DESCYR( LLD_ ) ) 00426 END IF 00427 * 00428 * Pad the guard zones of X, and Y 00429 * 00430 CALL PB_SFILLPAD( ICTXT, MPX, NQX, MEM( IPX-IPREX ), 00431 $ DESCX( LLD_ ), IPREX, IPOSTX, PADVAL ) 00432 * 00433 IF( YCHECK( K ) ) THEN 00434 CALL PB_SFILLPAD( ICTXT, MPY, NQY, MEM( IPY-IPREY ), 00435 $ DESCY( LLD_ ), IPREY, IPOSTY, 00436 $ PADVAL ) 00437 END IF 00438 * 00439 * Initialize the check for INPUT only args. 00440 * 00441 INFO = 0 00442 CALL PSCHKARG1( ICTXT, NOUT, SNAMES( K ), N, ALPHA, IX, 00443 $ JX, DESCX, INCX, IY, JY, DESCY, INCY, 00444 $ INFO ) 00445 * 00446 INFO = 0 00447 PSCLR = ZERO 00448 PUSCLR = ZERO 00449 PISCLR = 0 00450 * 00451 * Print initial parallel data if IVERB >= 2. 00452 * 00453 IF( IVERB.EQ.2 ) THEN 00454 IF( INCX.EQ.DESCX( M_ ) ) THEN 00455 CALL PB_PSLAPRNT( 1, N, MEM( IPX ), IX, JX, DESCX, 00456 $ 0, 0, 'PARALLEL_INITIAL_X', NOUT, 00457 $ MEM( IPW ) ) 00458 ELSE 00459 CALL PB_PSLAPRNT( N, 1, MEM( IPX ), IX, JX, DESCX, 00460 $ 0, 0, 'PARALLEL_INITIAL_X', NOUT, 00461 $ MEM( IPW ) ) 00462 END IF 00463 IF( YCHECK( K ) ) THEN 00464 IF( INCY.EQ.DESCY( M_ ) ) THEN 00465 CALL PB_PSLAPRNT( 1, N, MEM( IPY ), IY, JY, 00466 $ DESCY, 0, 0, 00467 $ 'PARALLEL_INITIAL_Y', NOUT, 00468 $ MEM( IPW ) ) 00469 ELSE 00470 CALL PB_PSLAPRNT( N, 1, MEM( IPY ), IY, JY, 00471 $ DESCY, 0, 0, 00472 $ 'PARALLEL_INITIAL_Y', NOUT, 00473 $ MEM( IPW ) ) 00474 END IF 00475 END IF 00476 ELSE IF( IVERB.GE.3 ) THEN 00477 CALL PB_PSLAPRNT( MX, NX, MEM( IPX ), 1, 1, DESCX, 0, 00478 $ 0, 'PARALLEL_INITIAL_X', NOUT, 00479 $ MEM( IPW ) ) 00480 IF( YCHECK( K ) ) 00481 $ CALL PB_PSLAPRNT( MY, NY, MEM( IPY ), 1, 1, DESCY, 00482 $ 0, 0, 'PARALLEL_INITIAL_Y', NOUT, 00483 $ MEM( IPW ) ) 00484 END IF 00485 * 00486 * Call the PBLAS routine 00487 * 00488 IF( K.EQ.1 ) THEN 00489 * 00490 * Test PSSWAP 00491 * 00492 CALL PSSWAP( N, MEM( IPX ), IX, JX, DESCX, INCX, 00493 $ MEM( IPY ), IY, JY, DESCY, INCY ) 00494 * 00495 ELSE IF( K.EQ.2 ) THEN 00496 * 00497 * Test PSSCAL 00498 * 00499 PSCLR = ALPHA 00500 CALL PSSCAL( N, ALPHA, MEM( IPX ), IX, JX, DESCX, 00501 $ INCX ) 00502 * 00503 ELSE IF( K.EQ.3 ) THEN 00504 * 00505 * Test PSCOPY 00506 * 00507 CALL PSCOPY( N, MEM( IPX ), IX, JX, DESCX, INCX, 00508 $ MEM( IPY ), IY, JY, DESCY, INCY ) 00509 * 00510 ELSE IF( K.EQ.4 ) THEN 00511 * 00512 * Test PSAXPY 00513 * 00514 PSCLR = ALPHA 00515 CALL PSAXPY( N, ALPHA, MEM( IPX ), IX, JX, DESCX, 00516 $ INCX, MEM( IPY ), IY, JY, DESCY, INCY ) 00517 * 00518 ELSE IF( K.EQ.5 ) THEN 00519 * 00520 * Test PSDOT 00521 * 00522 CALL PSDOT( N, PSCLR, MEM( IPX ), IX, JX, DESCX, INCX, 00523 $ MEM( IPY ), IY, JY, DESCY, INCY ) 00524 * 00525 ELSE IF( K.EQ.6 ) THEN 00526 * 00527 * Test PSNRM2 00528 * 00529 CALL PSNRM2( N, PUSCLR, MEM( IPX ), IX, JX, DESCX, 00530 $ INCX ) 00531 * 00532 ELSE IF( K.EQ.7 ) THEN 00533 * 00534 * Test PSASUM 00535 * 00536 CALL PSASUM( N, PUSCLR, MEM( IPX ), IX, JX, DESCX, 00537 $ INCX ) 00538 * 00539 ELSE IF( K.EQ.8 ) THEN 00540 * 00541 CALL PSAMAX( N, PSCLR, PISCLR, MEM( IPX ), IX, JX, 00542 $ DESCX, INCX ) 00543 * 00544 END IF 00545 * 00546 * Check if the operation has been performed. 00547 * 00548 IF( INFO.NE.0 ) THEN 00549 KSKIP( K ) = KSKIP( K ) + 1 00550 IF( IAM.EQ.0 ) 00551 $ WRITE( NOUT, FMT = 9978 ) INFO 00552 GO TO 30 00553 END IF 00554 * 00555 * Check the computations 00556 * 00557 CALL PSBLAS1TSTCHK( ICTXT, NOUT, K, N, PSCLR, PUSCLR, 00558 $ PISCLR, MEM( IPMATX ), MEM( IPX ), 00559 $ IX, JX, DESCX, INCX, MEM( IPMATY ), 00560 $ MEM( IPY ), IY, JY, DESCY, INCY, 00561 $ INFO ) 00562 IF( MOD( INFO, 2 ).EQ.1 ) THEN 00563 IERR( 1 ) = 1 00564 ELSE IF( MOD( INFO / 2, 2 ).EQ.1 ) THEN 00565 IERR( 2 ) = 1 00566 ELSE IF( INFO.NE.0 ) THEN 00567 IERR( 1 ) = 1 00568 IERR( 2 ) = 1 00569 END IF 00570 * 00571 * Check padding 00572 * 00573 CALL PB_SCHEKPAD( ICTXT, SNAMES( K ), MPX, NQX, 00574 $ MEM( IPX-IPREX ), DESCX( LLD_ ), 00575 $ IPREX, IPOSTX, PADVAL ) 00576 IF( YCHECK( K ) ) THEN 00577 CALL PB_SCHEKPAD( ICTXT, SNAMES( K ), MPY, NQY, 00578 $ MEM( IPY-IPREY ), DESCY( LLD_ ), 00579 $ IPREY, IPOSTY, PADVAL ) 00580 END IF 00581 * 00582 * Check input-only scalar arguments 00583 * 00584 INFO = 1 00585 CALL PSCHKARG1( ICTXT, NOUT, SNAMES( K ), N, ALPHA, IX, 00586 $ JX, DESCX, INCX, IY, JY, DESCY, INCY, 00587 $ INFO ) 00588 * 00589 * Check input-only array arguments 00590 * 00591 CALL PSCHKVOUT( N, MEM( IPMATX ), MEM( IPX ), IX, JX, 00592 $ DESCX, INCX, IERR( 3 ) ) 00593 * 00594 IF( IERR( 3 ).NE.0 ) THEN 00595 IF( IAM.EQ.0 ) 00596 $ WRITE( NOUT, FMT = 9986 ) 'PARALLEL_X', SNAMES( K ) 00597 END IF 00598 * 00599 IF( YCHECK( K ) ) THEN 00600 CALL PSCHKVOUT( N, MEM( IPMATY ), MEM( IPY ), IY, JY, 00601 $ DESCY, INCY, IERR( 4 ) ) 00602 IF( IERR( 4 ).NE.0 ) THEN 00603 IF( IAM.EQ.0 ) 00604 $ WRITE( NOUT, FMT = 9986 ) 'PARALLEL_Y', 00605 $ SNAMES( K ) 00606 END IF 00607 END IF 00608 * 00609 * Only node 0 prints computational test result 00610 * 00611 IF( INFO.NE.0 .OR. IERR( 1 ).NE.0 .OR. 00612 $ IERR( 2 ).NE.0 .OR. IERR( 3 ).NE.0 .OR. 00613 $ IERR( 4 ).NE. 0 ) THEN 00614 IF( IAM.EQ.0 ) 00615 $ WRITE( NOUT, FMT = 9988 ) SNAMES( K ) 00616 KFAIL( K ) = KFAIL( K ) + 1 00617 ERRFLG = .TRUE. 00618 ELSE 00619 IF( IAM.EQ.0 ) 00620 $ WRITE( NOUT, FMT = 9987 ) SNAMES( K ) 00621 KPASS( K ) = KPASS( K ) + 1 00622 END IF 00623 * 00624 * Dump matrix if IVERB >= 1 and error. 00625 * 00626 IF( IVERB.GE.1 .AND. ERRFLG ) THEN 00627 IF( IERR( 3 ).NE.0 .OR. IVERB.GE.3 ) THEN 00628 CALL PSMPRNT( ICTXT, NOUT, MX, NX, MEM( IPMATX ), 00629 $ LDX, 0, 0, 'SERIAL_X' ) 00630 CALL PB_PSLAPRNT( MX, NX, MEM( IPX ), 1, 1, DESCX, 00631 $ 0, 0, 'PARALLEL_X', NOUT, 00632 $ MEM( IPMATX ) ) 00633 ELSE IF( IERR( 1 ).NE.0 ) THEN 00634 IF( N.GT.0 ) 00635 $ CALL PSVPRNT( ICTXT, NOUT, N, 00636 $ MEM( IPMATX+IX-1+(JX-1)*LDX ), 00637 $ INCX, 0, 0, 'SERIAL_X' ) 00638 IF( INCX.EQ.DESCX( M_ ) ) THEN 00639 CALL PB_PSLAPRNT( 1, N, MEM( IPX ), IX, JX, 00640 $ DESCX, 0, 0, 'PARALLEL_X', 00641 $ NOUT, MEM( IPMATX ) ) 00642 ELSE 00643 CALL PB_PSLAPRNT( N, 1, MEM( IPX ), IX, JX, 00644 $ DESCX, 0, 0, 'PARALLEL_X', 00645 $ NOUT, MEM( IPMATX ) ) 00646 END IF 00647 END IF 00648 IF( YCHECK( K ) ) THEN 00649 IF( IERR( 4 ).NE.0 .OR. IVERB.GE.3 ) THEN 00650 CALL PSMPRNT( ICTXT, NOUT, MY, NY, 00651 $ MEM( IPMATY ), LDY, 0, 0, 00652 $ 'SERIAL_Y' ) 00653 CALL PB_PSLAPRNT( MY, NY, MEM( IPY ), 1, 1, 00654 $ DESCY, 0, 0, 'PARALLEL_Y', 00655 $ NOUT, MEM( IPMATX ) ) 00656 ELSE IF( IERR( 2 ).NE.0 ) THEN 00657 IF( N.GT.0 ) 00658 $ CALL PSVPRNT( ICTXT, NOUT, N, 00659 $ MEM( IPMATY+IY-1+(JY-1)*LDY ), 00660 $ INCY, 0, 0, 'SERIAL_Y' ) 00661 IF( INCY.EQ.DESCY( M_ ) ) THEN 00662 CALL PB_PSLAPRNT( 1, N, MEM( IPY ), IY, JY, 00663 $ DESCY, 0, 0, 'PARALLEL_Y', 00664 $ NOUT, MEM( IPMATX ) ) 00665 ELSE 00666 CALL PB_PSLAPRNT( N, 1, MEM( IPY ), IY, JY, 00667 $ DESCY, 0, 0, 'PARALLEL_Y', 00668 $ NOUT, MEM( IPMATX ) ) 00669 END IF 00670 END IF 00671 END IF 00672 END IF 00673 * 00674 * Leave if error and "Stop On Failure" 00675 * 00676 IF( SOF.AND.ERRFLG ) 00677 $ GO TO 70 00678 * 00679 30 CONTINUE 00680 * 00681 40 IF( IAM.EQ.0 ) THEN 00682 WRITE( NOUT, FMT = * ) 00683 WRITE( NOUT, FMT = 9985 ) J 00684 END IF 00685 * 00686 50 CONTINUE 00687 * 00688 CALL BLACS_GRIDEXIT( ICTXT ) 00689 * 00690 60 CONTINUE 00691 * 00692 * Come here, if error and "Stop On Failure" 00693 * 00694 70 CONTINUE 00695 * 00696 * Before printing out final stats, add TSKIP to all skips 00697 * 00698 DO 80 I = 1, NSUBS 00699 IF( LTEST( I ) ) THEN 00700 KSKIP( I ) = KSKIP( I ) + TSKIP 00701 KTESTS( I ) = KSKIP( I ) + KFAIL( I ) + KPASS( I ) 00702 END IF 00703 80 CONTINUE 00704 * 00705 * Print results 00706 * 00707 IF( IAM.EQ.0 ) THEN 00708 WRITE( NOUT, FMT = * ) 00709 WRITE( NOUT, FMT = 9981 ) 00710 WRITE( NOUT, FMT = * ) 00711 WRITE( NOUT, FMT = 9983 ) 00712 WRITE( NOUT, FMT = 9982 ) 00713 * 00714 DO 90 I = 1, NSUBS 00715 WRITE( NOUT, FMT = 9984 ) '|', SNAMES( I ), KTESTS( I ), 00716 $ KPASS( I ), KFAIL( I ), KSKIP( I ) 00717 90 CONTINUE 00718 WRITE( NOUT, FMT = * ) 00719 WRITE( NOUT, FMT = 9980 ) 00720 WRITE( NOUT, FMT = * ) 00721 * 00722 END IF 00723 * 00724 CALL BLACS_EXIT( 0 ) 00725 * 00726 9999 FORMAT( 'ILLEGAL ', A, ': ', A, ' = ', I10, 00727 $ ' should be at least 1' ) 00728 9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', I4, 00729 $ '. It can be at most', I4 ) 00730 9997 FORMAT( 'Bad ', A, ' parameters: going on to next test case.' ) 00731 9996 FORMAT( 2X, 'Test number ', I4 , ' started on a ', I6, ' x ', 00732 $ I6, ' process grid.' ) 00733 9995 FORMAT( 2X, '---------------------------------------------------', 00734 $ '--------------------------' ) 00735 9994 FORMAT( 2X, ' N IX JX MX NX IMBX INBX', 00736 $ ' MBX NBX RSRCX CSRCX INCX' ) 00737 9993 FORMAT( 2X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I5,1X,I5,1X,I5,1X,I5,1X, 00738 $ I5,1X,I5,1X,I6 ) 00739 9992 FORMAT( 2X, ' N IY JY MY NY IMBY INBY', 00740 $ ' MBY NBY RSRCY CSRCY INCY' ) 00741 9991 FORMAT( 'Not enough memory for this test: going on to', 00742 $ ' next test case.' ) 00743 9990 FORMAT( 'Not enough memory. Need: ', I12 ) 00744 9989 FORMAT( 2X, ' Tested Subroutine: ', A ) 00745 9988 FORMAT( 2X, ' ***** Computational check: ', A, ' ', 00746 $ ' FAILED ',' *****' ) 00747 9987 FORMAT( 2X, ' ***** Computational check: ', A, ' ', 00748 $ ' PASSED ',' *****' ) 00749 9986 FORMAT( 2X, ' ***** ERROR ***** Matrix operand ', A, 00750 $ ' modified by ', A, ' *****' ) 00751 9985 FORMAT( 2X, 'Test number ', I4, ' completed.' ) 00752 9984 FORMAT( 2X,A1,2X,A7,8X,I4,6X,I4,5X,I4,4X,I4 ) 00753 9983 FORMAT( 2X, ' SUBROUTINE TOTAL TESTS PASSED FAILED ', 00754 $ 'SKIPPED' ) 00755 9982 FORMAT( 2X, ' ---------- ----------- ------ ------ ', 00756 $ '-------' ) 00757 9981 FORMAT( 2X, 'Testing Summary') 00758 9980 FORMAT( 2X, 'End of Tests.' ) 00759 9979 FORMAT( 2X, 'Tests started.' ) 00760 9978 FORMAT( 2X, ' ***** Operation not supported, error code: ', 00761 $ I5, ' *****' ) 00762 * 00763 STOP 00764 * 00765 * End of PSBLA1TST 00766 * 00767 END 00768 SUBROUTINE PSBLA1TSTINFO( SUMMRY, NOUT, NMAT, NVAL, MXVAL, 00769 $ NXVAL, IMBXVAL, MBXVAL, INBXVAL, 00770 $ NBXVAL, RSCXVAL, CSCXVAL, IXVAL, 00771 $ JXVAL, INCXVAL, MYVAL, NYVAL, IMBYVAL, 00772 $ MBYVAL, INBYVAL, NBYVAL, RSCYVAL, 00773 $ CSCYVAL, IYVAL, JYVAL, INCYVAL, 00774 $ LDVAL, NGRIDS, PVAL, LDPVAL, QVAL, 00775 $ LDQVAL, LTEST, SOF, TEE, IAM, IGAP, 00776 $ IVERB, NPROCS, ALPHA, WORK ) 00777 * 00778 * -- PBLAS test routine (version 2.0) -- 00779 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 00780 * and University of California, Berkeley. 00781 * April 1, 1998 00782 * 00783 * .. Scalar Arguments .. 00784 LOGICAL SOF, TEE 00785 INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL, 00786 $ NGRIDS, NMAT, NOUT, NPROCS 00787 REAL ALPHA 00788 * .. 00789 * .. Array Arguments .. 00790 CHARACTER*( * ) SUMMRY 00791 LOGICAL LTEST( * ) 00792 INTEGER CSCXVAL( LDVAL ), CSCYVAL( LDVAL ), 00793 $ IMBXVAL( LDVAL ), IMBYVAL( LDVAL ), 00794 $ INBXVAL( LDVAL ), INBYVAL( LDVAL ), 00795 $ INCXVAL( LDVAL ), INCYVAL( LDVAL ), 00796 $ IXVAL( LDVAL ), IYVAL( LDVAL ), JXVAL( LDVAL ), 00797 $ JYVAL( LDVAL ), MBXVAL( LDVAL ), 00798 $ MBYVAL( LDVAL ), MXVAL( LDVAL ), 00799 $ MYVAL( LDVAL ), NBXVAL( LDVAL ), 00800 $ NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ), 00801 $ NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ), 00802 $ RSCXVAL( LDVAL ), RSCYVAL( LDVAL ), WORK( * ) 00803 * .. 00804 * 00805 * Purpose 00806 * ======= 00807 * 00808 * PSBLA1TSTINFO get the needed startup information for testing various 00809 * Level 1 PBLAS routines, and transmits it to all processes. 00810 * 00811 * Notes 00812 * ===== 00813 * 00814 * For packing the information we assumed that the length in bytes of an 00815 * integer is equal to the length in bytes of a real single precision. 00816 * 00817 * Arguments 00818 * ========= 00819 * 00820 * SUMMRY (global output) CHARACTER*(*) 00821 * On exit, SUMMRY is the name of output (summary) file (if 00822 * any). SUMMRY is only defined for process 0. 00823 * 00824 * NOUT (global output) INTEGER 00825 * On exit, NOUT specifies the unit number for the output file. 00826 * When NOUT is 6, output to screen, when NOUT is 0, output to 00827 * stderr. NOUT is only defined for process 0. 00828 * 00829 * NMAT (global output) INTEGER 00830 * On exit, NMAT specifies the number of different test cases. 00831 * 00832 * NVAL (global output) INTEGER array 00833 * On entry, NVAL is an array of dimension LDVAL. On exit, this 00834 * array contains the values of N to run the code with. 00835 * 00836 * MXVAL (global output) INTEGER array 00837 * On entry, MXVAL is an array of dimension LDVAL. On exit, this 00838 * array contains the values of DESCX( M_ ) to run the code 00839 * with. 00840 * 00841 * NXVAL (global output) INTEGER array 00842 * On entry, NXVAL is an array of dimension LDVAL. On exit, this 00843 * array contains the values of DESCX( N_ ) to run the code 00844 * with. 00845 * 00846 * IMBXVAL (global output) INTEGER array 00847 * On entry, IMBXVAL is an array of dimension LDVAL. On exit, 00848 * this array contains the values of DESCX( IMB_ ) to run the 00849 * code with. 00850 * 00851 * MBXVAL (global output) INTEGER array 00852 * On entry, MBXVAL is an array of dimension LDVAL. On exit, 00853 * this array contains the values of DESCX( MB_ ) to run the 00854 * code with. 00855 * 00856 * INBXVAL (global output) INTEGER array 00857 * On entry, INBXVAL is an array of dimension LDVAL. On exit, 00858 * this array contains the values of DESCX( INB_ ) to run the 00859 * code with. 00860 * 00861 * NBXVAL (global output) INTEGER array 00862 * On entry, NBXVAL is an array of dimension LDVAL. On exit, 00863 * this array contains the values of DESCX( NB_ ) to run the 00864 * code with. 00865 * 00866 * RSCXVAL (global output) INTEGER array 00867 * On entry, RSCXVAL is an array of dimension LDVAL. On exit, 00868 * this array contains the values of DESCX( RSRC_ ) to run the 00869 * code with. 00870 * 00871 * CSCXVAL (global output) INTEGER array 00872 * On entry, CSCXVAL is an array of dimension LDVAL. On exit, 00873 * this array contains the values of DESCX( CSRC_ ) to run the 00874 * code with. 00875 * 00876 * IXVAL (global output) INTEGER array 00877 * On entry, IXVAL is an array of dimension LDVAL. On exit, this 00878 * array contains the values of IX to run the code with. 00879 * 00880 * JXVAL (global output) INTEGER array 00881 * On entry, JXVAL is an array of dimension LDVAL. On exit, this 00882 * array contains the values of JX to run the code with. 00883 * 00884 * INCXVAL (global output) INTEGER array 00885 * On entry, INCXVAL is an array of dimension LDVAL. On exit, 00886 * this array contains the values of INCX to run the code with. 00887 * 00888 * MYVAL (global output) INTEGER array 00889 * On entry, MYVAL is an array of dimension LDVAL. On exit, this 00890 * array contains the values of DESCY( M_ ) to run the code 00891 * with. 00892 * 00893 * NYVAL (global output) INTEGER array 00894 * On entry, NYVAL is an array of dimension LDVAL. On exit, this 00895 * array contains the values of DESCY( N_ ) to run the code 00896 * with. 00897 * 00898 * IMBYVAL (global output) INTEGER array 00899 * On entry, IMBYVAL is an array of dimension LDVAL. On exit, 00900 * this array contains the values of DESCY( IMB_ ) to run the 00901 * code with. 00902 * 00903 * MBYVAL (global output) INTEGER array 00904 * On entry, MBYVAL is an array of dimension LDVAL. On exit, 00905 * this array contains the values of DESCY( MB_ ) to run the 00906 * code with. 00907 * 00908 * INBYVAL (global output) INTEGER array 00909 * On entry, INBYVAL is an array of dimension LDVAL. On exit, 00910 * this array contains the values of DESCY( INB_ ) to run the 00911 * code with. 00912 * 00913 * NBYVAL (global output) INTEGER array 00914 * On entry, NBYVAL is an array of dimension LDVAL. On exit, 00915 * this array contains the values of DESCY( NB_ ) to run the 00916 * code with. 00917 * 00918 * RSCYVAL (global output) INTEGER array 00919 * On entry, RSCYVAL is an array of dimension LDVAL. On exit, 00920 * this array contains the values of DESCY( RSRC_ ) to run the 00921 * code with. 00922 * 00923 * CSCYVAL (global output) INTEGER array 00924 * On entry, CSCYVAL is an array of dimension LDVAL. On exit, 00925 * this array contains the values of DESCY( CSRC_ ) to run the 00926 * code with. 00927 * 00928 * IYVAL (global output) INTEGER array 00929 * On entry, IYVAL is an array of dimension LDVAL. On exit, this 00930 * array contains the values of IY to run the code with. 00931 * 00932 * JYVAL (global output) INTEGER array 00933 * On entry, JYVAL is an array of dimension LDVAL. On exit, this 00934 * array contains the values of JY to run the code with. 00935 * 00936 * INCYVAL (global output) INTEGER array 00937 * On entry, INCYVAL is an array of dimension LDVAL. On exit, 00938 * this array contains the values of INCY to run the code with. 00939 * 00940 * LDVAL (global input) INTEGER 00941 * On entry, LDVAL specifies the maximum number of different va- 00942 * lues that can be used for DESCX(:), IX, JX, INCX, DESCY(:), 00943 * IY, JY and INCY. This is also the maximum number of test 00944 * cases. 00945 * 00946 * NGRIDS (global output) INTEGER 00947 * On exit, NGRIDS specifies the number of different values that 00948 * can be used for P and Q. 00949 * 00950 * PVAL (global output) INTEGER array 00951 * On entry, PVAL is an array of dimension LDPVAL. On exit, this 00952 * array contains the values of P to run the code with. 00953 * 00954 * LDPVAL (global input) INTEGER 00955 * On entry, LDPVAL specifies the maximum number of different 00956 * values that can be used for P. 00957 * 00958 * QVAL (global output) INTEGER array 00959 * On entry, QVAL is an array of dimension LDQVAL. On exit, this 00960 * array contains the values of Q to run the code with. 00961 * 00962 * LDQVAL (global input) INTEGER 00963 * On entry, LDQVAL specifies the maximum number of different 00964 * values that can be used for Q. 00965 * 00966 * LTEST (global output) LOGICAL array 00967 * On entry, LTEST is an array of dimension at least eight. On 00968 * exit, if LTEST( i ) is .TRUE., the i-th Level 1 PBLAS routine 00969 * will be tested. See the input file for the ordering of the 00970 * routines. 00971 * 00972 * SOF (global output) LOGICAL 00973 * On exit, if SOF is .TRUE., the tester will stop on the first 00974 * detected failure. Otherwise, it won't. 00975 * 00976 * TEE (global output) LOGICAL 00977 * On exit, if TEE is .TRUE., the tester will perform the error 00978 * exit tests. These tests won't be performed otherwise. 00979 * 00980 * IAM (local input) INTEGER 00981 * On entry, IAM specifies the number of the process executing 00982 * this routine. 00983 * 00984 * IGAP (global output) INTEGER 00985 * On exit, IGAP specifies the user-specified gap used for pad- 00986 * ding. IGAP must be at least zero. 00987 * 00988 * IVERB (global output) INTEGER 00989 * On exit, IVERB specifies the output verbosity level: 0 for 00990 * pass/fail, 1, 2 or 3 for matrix dump on errors. 00991 * 00992 * NPROCS (global input) INTEGER 00993 * On entry, NPROCS specifies the total number of processes. 00994 * 00995 * ALPHA (global output) REAL 00996 * On exit, ALPHA specifies the value of alpha to be used in all 00997 * the test cases. 00998 * 00999 * WORK (local workspace) INTEGER array 01000 * On entry, WORK is an array of dimension at least 01001 * MAX( 2, 2*NGRIDS+23*NMAT+NSUBS+4 ) with NSUBS equal to 8. 01002 * This array is used to pack all output arrays in order to send 01003 * the information in one message. 01004 * 01005 * -- Written on April 1, 1998 by 01006 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01007 * 01008 * ===================================================================== 01009 * 01010 * .. Parameters .. 01011 INTEGER NIN, NSUBS 01012 PARAMETER ( NIN = 11, NSUBS = 8 ) 01013 * .. 01014 * .. Local Scalars .. 01015 LOGICAL LTESTT 01016 INTEGER I, ICTXT, J 01017 REAL EPS 01018 * .. 01019 * .. Local Arrays .. 01020 CHARACTER*7 SNAMET 01021 CHARACTER*79 USRINFO 01022 * .. 01023 * .. External Subroutines .. 01024 EXTERNAL BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT, 01025 $ BLACS_GRIDINIT, BLACS_SETUP, ICOPY, IGEBR2D, 01026 $ IGEBS2D, SGEBR2D, SGEBS2D 01027 * .. 01028 * .. External Functions .. 01029 REAL PSLAMCH 01030 EXTERNAL PSLAMCH 01031 * .. 01032 * .. Intrinsic Functions .. 01033 INTRINSIC MAX, MIN 01034 * .. 01035 * .. Common Blocks .. 01036 CHARACTER*7 SNAMES( NSUBS ) 01037 COMMON /SNAMEC/SNAMES 01038 * .. 01039 * .. Executable Statements .. 01040 * 01041 * Process 0 reads the input data, broadcasts to other processes and 01042 * writes needed information to NOUT 01043 * 01044 IF( IAM.EQ.0 ) THEN 01045 * 01046 * Open file and skip data file header 01047 * 01048 OPEN( NIN, FILE='PSBLAS1TST.dat', STATUS='OLD' ) 01049 READ( NIN, FMT = * ) SUMMRY 01050 SUMMRY = ' ' 01051 * 01052 * Read in user-supplied info about machine type, compiler, etc. 01053 * 01054 READ( NIN, FMT = 9999 ) USRINFO 01055 * 01056 * Read name and unit number for summary output file 01057 * 01058 READ( NIN, FMT = * ) SUMMRY 01059 READ( NIN, FMT = * ) NOUT 01060 IF( NOUT.NE.0 .AND. NOUT.NE.6 ) 01061 $ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) 01062 * 01063 * Read and check the parameter values for the tests. 01064 * 01065 * Read the flag that indicates if Stop on Failure 01066 * 01067 READ( NIN, FMT = * ) SOF 01068 * 01069 * Read the flag that indicates if Test Error Exits 01070 * 01071 READ( NIN, FMT = * ) TEE 01072 * 01073 * Read the verbosity level 01074 * 01075 READ( NIN, FMT = * ) IVERB 01076 IF( IVERB.LT.0 .OR. IVERB.GT.3 ) 01077 $ IVERB = 0 01078 * 01079 * Read the leading dimension gap 01080 * 01081 READ( NIN, FMT = * ) IGAP 01082 IF( IGAP.LT.0 ) 01083 $ IGAP = 0 01084 * 01085 * Get number of grids 01086 * 01087 READ( NIN, FMT = * ) NGRIDS 01088 IF( NGRIDS.LT.1 .OR. NGRIDS.GT.LDPVAL ) THEN 01089 WRITE( NOUT, FMT = 9998 ) 'Grids', LDPVAL 01090 GO TO 100 01091 ELSE IF( NGRIDS.GT.LDQVAL ) THEN 01092 WRITE( NOUT, FMT = 9998 ) 'Grids', LDQVAL 01093 GO TO 100 01094 END IF 01095 * 01096 * Get values of P and Q 01097 * 01098 READ( NIN, FMT = * ) ( PVAL( I ), I = 1, NGRIDS ) 01099 READ( NIN, FMT = * ) ( QVAL( I ), I = 1, NGRIDS ) 01100 * 01101 * Read ALPHA 01102 * 01103 READ( NIN, FMT = * ) ALPHA 01104 * 01105 * Read number of tests. 01106 * 01107 READ( NIN, FMT = * ) NMAT 01108 IF( NMAT.LT.1 .OR. NMAT.GT.LDVAL ) THEN 01109 WRITE( NOUT, FMT = 9998 ) 'Tests', LDVAL 01110 GO TO 100 01111 END IF 01112 * 01113 * Read in input data into arrays. 01114 * 01115 READ( NIN, FMT = * ) ( NVAL( I ), I = 1, NMAT ) 01116 READ( NIN, FMT = * ) ( MXVAL( I ), I = 1, NMAT ) 01117 READ( NIN, FMT = * ) ( NXVAL( I ), I = 1, NMAT ) 01118 READ( NIN, FMT = * ) ( IMBXVAL( I ), I = 1, NMAT ) 01119 READ( NIN, FMT = * ) ( INBXVAL( I ), I = 1, NMAT ) 01120 READ( NIN, FMT = * ) ( MBXVAL( I ), I = 1, NMAT ) 01121 READ( NIN, FMT = * ) ( NBXVAL( I ), I = 1, NMAT ) 01122 READ( NIN, FMT = * ) ( RSCXVAL( I ), I = 1, NMAT ) 01123 READ( NIN, FMT = * ) ( CSCXVAL( I ), I = 1, NMAT ) 01124 READ( NIN, FMT = * ) ( IXVAL( I ), I = 1, NMAT ) 01125 READ( NIN, FMT = * ) ( JXVAL( I ), I = 1, NMAT ) 01126 READ( NIN, FMT = * ) ( INCXVAL( I ), I = 1, NMAT ) 01127 READ( NIN, FMT = * ) ( MYVAL( I ), I = 1, NMAT ) 01128 READ( NIN, FMT = * ) ( NYVAL( I ), I = 1, NMAT ) 01129 READ( NIN, FMT = * ) ( IMBYVAL( I ), I = 1, NMAT ) 01130 READ( NIN, FMT = * ) ( INBYVAL( I ), I = 1, NMAT ) 01131 READ( NIN, FMT = * ) ( MBYVAL( I ), I = 1, NMAT ) 01132 READ( NIN, FMT = * ) ( NBYVAL( I ), I = 1, NMAT ) 01133 READ( NIN, FMT = * ) ( RSCYVAL( I ), I = 1, NMAT ) 01134 READ( NIN, FMT = * ) ( CSCYVAL( I ), I = 1, NMAT ) 01135 READ( NIN, FMT = * ) ( IYVAL( I ), I = 1, NMAT ) 01136 READ( NIN, FMT = * ) ( JYVAL( I ), I = 1, NMAT ) 01137 READ( NIN, FMT = * ) ( INCYVAL( I ), I = 1, NMAT ) 01138 * 01139 * Read names of subroutines and flags which indicate 01140 * whether they are to be tested. 01141 * 01142 DO 10 I = 1, NSUBS 01143 LTEST( I ) = .FALSE. 01144 10 CONTINUE 01145 20 CONTINUE 01146 READ( NIN, FMT = 9996, END = 50 ) SNAMET, LTESTT 01147 DO 30 I = 1, NSUBS 01148 IF( SNAMET.EQ.SNAMES( I ) ) 01149 $ GO TO 40 01150 30 CONTINUE 01151 * 01152 WRITE( NOUT, FMT = 9995 )SNAMET 01153 GO TO 100 01154 * 01155 40 CONTINUE 01156 LTEST( I ) = LTESTT 01157 GO TO 20 01158 * 01159 50 CONTINUE 01160 * 01161 * Close input file 01162 * 01163 CLOSE ( NIN ) 01164 * 01165 * For pvm only: if virtual machine not set up, allocate it and 01166 * spawn the correct number of processes. 01167 * 01168 IF( NPROCS.LT.1 ) THEN 01169 NPROCS = 0 01170 DO 60 I = 1, NGRIDS 01171 NPROCS = MAX( NPROCS, PVAL( I )*QVAL( I ) ) 01172 60 CONTINUE 01173 CALL BLACS_SETUP( IAM, NPROCS ) 01174 END IF 01175 * 01176 * Temporarily define blacs grid to include all processes so 01177 * information can be broadcast to all processes 01178 * 01179 CALL BLACS_GET( -1, 0, ICTXT ) 01180 CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS ) 01181 * 01182 * Compute machine epsilon 01183 * 01184 EPS = PSLAMCH( ICTXT, 'eps' ) 01185 * 01186 * Pack information arrays and broadcast 01187 * 01188 CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1 ) 01189 * 01190 WORK( 1 ) = NGRIDS 01191 WORK( 2 ) = NMAT 01192 CALL IGEBS2D( ICTXT, 'All', ' ', 2, 1, WORK, 2 ) 01193 * 01194 I = 1 01195 IF( SOF ) THEN 01196 WORK( I ) = 1 01197 ELSE 01198 WORK( I ) = 0 01199 END IF 01200 I = I + 1 01201 IF( TEE ) THEN 01202 WORK( I ) = 1 01203 ELSE 01204 WORK( I ) = 0 01205 END IF 01206 I = I + 1 01207 WORK( I ) = IVERB 01208 I = I + 1 01209 WORK( I ) = IGAP 01210 I = I + 1 01211 CALL ICOPY( NGRIDS, PVAL, 1, WORK( I ), 1 ) 01212 I = I + NGRIDS 01213 CALL ICOPY( NGRIDS, QVAL, 1, WORK( I ), 1 ) 01214 I = I + NGRIDS 01215 CALL ICOPY( NMAT, NVAL, 1, WORK( I ), 1 ) 01216 I = I + NMAT 01217 CALL ICOPY( NMAT, MXVAL, 1, WORK( I ), 1 ) 01218 I = I + NMAT 01219 CALL ICOPY( NMAT, NXVAL, 1, WORK( I ), 1 ) 01220 I = I + NMAT 01221 CALL ICOPY( NMAT, IMBXVAL, 1, WORK( I ), 1 ) 01222 I = I + NMAT 01223 CALL ICOPY( NMAT, INBXVAL, 1, WORK( I ), 1 ) 01224 I = I + NMAT 01225 CALL ICOPY( NMAT, MBXVAL, 1, WORK( I ), 1 ) 01226 I = I + NMAT 01227 CALL ICOPY( NMAT, NBXVAL, 1, WORK( I ), 1 ) 01228 I = I + NMAT 01229 CALL ICOPY( NMAT, RSCXVAL, 1, WORK( I ), 1 ) 01230 I = I + NMAT 01231 CALL ICOPY( NMAT, CSCXVAL, 1, WORK( I ), 1 ) 01232 I = I + NMAT 01233 CALL ICOPY( NMAT, IXVAL, 1, WORK( I ), 1 ) 01234 I = I + NMAT 01235 CALL ICOPY( NMAT, JXVAL, 1, WORK( I ), 1 ) 01236 I = I + NMAT 01237 CALL ICOPY( NMAT, INCXVAL, 1, WORK( I ), 1 ) 01238 I = I + NMAT 01239 CALL ICOPY( NMAT, MYVAL, 1, WORK( I ), 1 ) 01240 I = I + NMAT 01241 CALL ICOPY( NMAT, NYVAL, 1, WORK( I ), 1 ) 01242 I = I + NMAT 01243 CALL ICOPY( NMAT, IMBYVAL, 1, WORK( I ), 1 ) 01244 I = I + NMAT 01245 CALL ICOPY( NMAT, INBYVAL, 1, WORK( I ), 1 ) 01246 I = I + NMAT 01247 CALL ICOPY( NMAT, MBYVAL, 1, WORK( I ), 1 ) 01248 I = I + NMAT 01249 CALL ICOPY( NMAT, NBYVAL, 1, WORK( I ), 1 ) 01250 I = I + NMAT 01251 CALL ICOPY( NMAT, RSCYVAL, 1, WORK( I ), 1 ) 01252 I = I + NMAT 01253 CALL ICOPY( NMAT, CSCYVAL, 1, WORK( I ), 1 ) 01254 I = I + NMAT 01255 CALL ICOPY( NMAT, IYVAL, 1, WORK( I ), 1 ) 01256 I = I + NMAT 01257 CALL ICOPY( NMAT, JYVAL, 1, WORK( I ), 1 ) 01258 I = I + NMAT 01259 CALL ICOPY( NMAT, INCYVAL, 1, WORK( I ), 1 ) 01260 I = I + NMAT 01261 * 01262 DO 70 J = 1, NSUBS 01263 IF( LTEST( J ) ) THEN 01264 WORK( I ) = 1 01265 ELSE 01266 WORK( I ) = 0 01267 END IF 01268 I = I + 1 01269 70 CONTINUE 01270 I = I - 1 01271 CALL IGEBS2D( ICTXT, 'All', ' ', I, 1, WORK, I ) 01272 * 01273 * regurgitate input 01274 * 01275 WRITE( NOUT, FMT = 9999 ) 'Level 1 PBLAS testing program.' 01276 WRITE( NOUT, FMT = 9999 ) USRINFO 01277 WRITE( NOUT, FMT = * ) 01278 WRITE( NOUT, FMT = 9999 ) 01279 $ 'Tests of the real single precision '// 01280 $ 'Level 1 PBLAS' 01281 WRITE( NOUT, FMT = * ) 01282 WRITE( NOUT, FMT = 9999 ) 01283 $ 'The following parameter values will be used:' 01284 WRITE( NOUT, FMT = * ) 01285 WRITE( NOUT, FMT = 9993 ) NMAT 01286 WRITE( NOUT, FMT = 9992 ) NGRIDS 01287 WRITE( NOUT, FMT = 9990 ) 01288 $ 'P', ( PVAL(I), I = 1, MIN(NGRIDS, 5) ) 01289 IF( NGRIDS.GT.5 ) 01290 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 6, 01291 $ MIN( 10, NGRIDS ) ) 01292 IF( NGRIDS.GT.10 ) 01293 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 11, 01294 $ MIN( 15, NGRIDS ) ) 01295 IF( NGRIDS.GT.15 ) 01296 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 16, NGRIDS ) 01297 WRITE( NOUT, FMT = 9990 ) 01298 $ 'Q', ( QVAL(I), I = 1, MIN(NGRIDS, 5) ) 01299 IF( NGRIDS.GT.5 ) 01300 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 6, 01301 $ MIN( 10, NGRIDS ) ) 01302 IF( NGRIDS.GT.10 ) 01303 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 11, 01304 $ MIN( 15, NGRIDS ) ) 01305 IF( NGRIDS.GT.15 ) 01306 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 16, NGRIDS ) 01307 WRITE( NOUT, FMT = 9988 ) SOF 01308 WRITE( NOUT, FMT = 9987 ) TEE 01309 WRITE( NOUT, FMT = 9983 ) IGAP 01310 WRITE( NOUT, FMT = 9986 ) IVERB 01311 WRITE( NOUT, FMT = 9982 ) ALPHA 01312 IF( LTEST( 1 ) ) THEN 01313 WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... Yes' 01314 ELSE 01315 WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... No ' 01316 END IF 01317 DO 80 I = 2, NSUBS 01318 IF( LTEST( I ) ) THEN 01319 WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... Yes' 01320 ELSE 01321 WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... No ' 01322 END IF 01323 80 CONTINUE 01324 WRITE( NOUT, FMT = 9994 ) EPS 01325 WRITE( NOUT, FMT = * ) 01326 * 01327 ELSE 01328 * 01329 * If in pvm, must participate setting up virtual machine 01330 * 01331 IF( NPROCS.LT.1 ) 01332 $ CALL BLACS_SETUP( IAM, NPROCS ) 01333 * 01334 * Temporarily define blacs grid to include all processes so 01335 * information can be broadcast to all processes 01336 * 01337 CALL BLACS_GET( -1, 0, ICTXT ) 01338 CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS ) 01339 * 01340 * Compute machine epsilon 01341 * 01342 EPS = PSLAMCH( ICTXT, 'eps' ) 01343 * 01344 CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1, 0, 0 ) 01345 * 01346 CALL IGEBR2D( ICTXT, 'All', ' ', 2, 1, WORK, 2, 0, 0 ) 01347 NGRIDS = WORK( 1 ) 01348 NMAT = WORK( 2 ) 01349 * 01350 I = 2*NGRIDS + 23*NMAT + NSUBS + 4 01351 CALL IGEBR2D( ICTXT, 'All', ' ', I, 1, WORK, I, 0, 0 ) 01352 * 01353 I = 1 01354 IF( WORK( I ).EQ.1 ) THEN 01355 SOF = .TRUE. 01356 ELSE 01357 SOF = .FALSE. 01358 END IF 01359 I = I + 1 01360 IF( WORK( I ).EQ.1 ) THEN 01361 TEE = .TRUE. 01362 ELSE 01363 TEE = .FALSE. 01364 END IF 01365 I = I + 1 01366 IVERB = WORK( I ) 01367 I = I + 1 01368 IGAP = WORK( I ) 01369 I = I + 1 01370 CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL, 1 ) 01371 I = I + NGRIDS 01372 CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL, 1 ) 01373 I = I + NGRIDS 01374 CALL ICOPY( NMAT, WORK( I ), 1, NVAL, 1 ) 01375 I = I + NMAT 01376 CALL ICOPY( NMAT, WORK( I ), 1, MXVAL, 1 ) 01377 I = I + NMAT 01378 CALL ICOPY( NMAT, WORK( I ), 1, NXVAL, 1 ) 01379 I = I + NMAT 01380 CALL ICOPY( NMAT, WORK( I ), 1, IMBXVAL, 1 ) 01381 I = I + NMAT 01382 CALL ICOPY( NMAT, WORK( I ), 1, INBXVAL, 1 ) 01383 I = I + NMAT 01384 CALL ICOPY( NMAT, WORK( I ), 1, MBXVAL, 1 ) 01385 I = I + NMAT 01386 CALL ICOPY( NMAT, WORK( I ), 1, NBXVAL, 1 ) 01387 I = I + NMAT 01388 CALL ICOPY( NMAT, WORK( I ), 1, RSCXVAL, 1 ) 01389 I = I + NMAT 01390 CALL ICOPY( NMAT, WORK( I ), 1, CSCXVAL, 1 ) 01391 I = I + NMAT 01392 CALL ICOPY( NMAT, WORK( I ), 1, IXVAL, 1 ) 01393 I = I + NMAT 01394 CALL ICOPY( NMAT, WORK( I ), 1, JXVAL, 1 ) 01395 I = I + NMAT 01396 CALL ICOPY( NMAT, WORK( I ), 1, INCXVAL, 1 ) 01397 I = I + NMAT 01398 CALL ICOPY( NMAT, WORK( I ), 1, MYVAL, 1 ) 01399 I = I + NMAT 01400 CALL ICOPY( NMAT, WORK( I ), 1, NYVAL, 1 ) 01401 I = I + NMAT 01402 CALL ICOPY( NMAT, WORK( I ), 1, IMBYVAL, 1 ) 01403 I = I + NMAT 01404 CALL ICOPY( NMAT, WORK( I ), 1, INBYVAL, 1 ) 01405 I = I + NMAT 01406 CALL ICOPY( NMAT, WORK( I ), 1, MBYVAL, 1 ) 01407 I = I + NMAT 01408 CALL ICOPY( NMAT, WORK( I ), 1, NBYVAL, 1 ) 01409 I = I + NMAT 01410 CALL ICOPY( NMAT, WORK( I ), 1, RSCYVAL, 1 ) 01411 I = I + NMAT 01412 CALL ICOPY( NMAT, WORK( I ), 1, CSCYVAL, 1 ) 01413 I = I + NMAT 01414 CALL ICOPY( NMAT, WORK( I ), 1, IYVAL, 1 ) 01415 I = I + NMAT 01416 CALL ICOPY( NMAT, WORK( I ), 1, JYVAL, 1 ) 01417 I = I + NMAT 01418 CALL ICOPY( NMAT, WORK( I ), 1, INCYVAL, 1 ) 01419 I = I + NMAT 01420 * 01421 DO 90 J = 1, NSUBS 01422 IF( WORK( I ).EQ.1 ) THEN 01423 LTEST( J ) = .TRUE. 01424 ELSE 01425 LTEST( J ) = .FALSE. 01426 END IF 01427 I = I + 1 01428 90 CONTINUE 01429 * 01430 END IF 01431 * 01432 CALL BLACS_GRIDEXIT( ICTXT ) 01433 * 01434 RETURN 01435 * 01436 100 WRITE( NOUT, FMT = 9997 ) 01437 CLOSE( NIN ) 01438 IF( NOUT.NE.6 .AND. NOUT.NE.0 ) 01439 $ CLOSE( NOUT ) 01440 CALL BLACS_ABORT( ICTXT, 1 ) 01441 * 01442 STOP 01443 * 01444 9999 FORMAT( A ) 01445 9998 FORMAT( ' Number of values of ',5A, ' is less than 1 or greater ', 01446 $ 'than ', I2 ) 01447 9997 FORMAT( ' Illegal input in file ',40A,'. Aborting run.' ) 01448 9996 FORMAT( A7, L2 ) 01449 9995 FORMAT( ' Subprogram name ', A7, ' not recognized', 01450 $ /' ******* TESTS ABANDONED *******' ) 01451 9994 FORMAT( 2X, 'Relative machine precision (eps) is taken to be ', 01452 $ E18.6 ) 01453 9993 FORMAT( 2X, 'Number of Tests : ', I6 ) 01454 9992 FORMAT( 2X, 'Number of process grids : ', I6 ) 01455 9991 FORMAT( 2X, ' : ', 5I6 ) 01456 9990 FORMAT( 2X, A1, ' : ', 5I6 ) 01457 9988 FORMAT( 2X, 'Stop on failure flag : ', L6 ) 01458 9987 FORMAT( 2X, 'Test for error exits flag : ', L6 ) 01459 9986 FORMAT( 2X, 'Verbosity level : ', I6 ) 01460 9985 FORMAT( 2X, 'Routines to be tested : ', A, A8 ) 01461 9984 FORMAT( 2X, ' ', A, A8 ) 01462 9983 FORMAT( 2X, 'Leading dimension gap : ', I6 ) 01463 9982 FORMAT( 2X, 'Alpha : ', G16.6 ) 01464 * 01465 * End of PSBLA1TSTINFO 01466 * 01467 END 01468 SUBROUTINE PSBLAS1TSTCHKE( LTEST, INOUT, NPROCS ) 01469 * 01470 * -- PBLAS test routine (version 2.0) -- 01471 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01472 * and University of California, Berkeley. 01473 * April 1, 1998 01474 * 01475 * .. Scalar Arguments .. 01476 INTEGER INOUT, NPROCS 01477 * .. 01478 * .. Array Arguments .. 01479 LOGICAL LTEST( * ) 01480 * .. 01481 * 01482 * Purpose 01483 * ======= 01484 * 01485 * PSBLAS1TSTCHKE tests the error exits of the Level 1 PBLAS. 01486 * 01487 * Notes 01488 * ===== 01489 * 01490 * A description vector is associated with each 2D block-cyclicly dis- 01491 * tributed matrix. This vector stores the information required to 01492 * establish the mapping between a matrix entry and its corresponding 01493 * process and memory location. 01494 * 01495 * In the following comments, the character _ should be read as 01496 * "of the distributed matrix". Let A be a generic term for any 2D 01497 * block cyclicly distributed matrix. Its description vector is DESCA: 01498 * 01499 * NOTATION STORED IN EXPLANATION 01500 * ---------------- --------------- ------------------------------------ 01501 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 01502 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 01503 * the NPROW x NPCOL BLACS process grid 01504 * A is distributed over. The context 01505 * itself is global, but the handle 01506 * (the integer value) may vary. 01507 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 01508 * ted matrix A, M_A >= 0. 01509 * N_A (global) DESCA( N_ ) The number of columns in the distri- 01510 * buted matrix A, N_A >= 0. 01511 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 01512 * block of the matrix A, IMB_A > 0. 01513 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 01514 * left block of the matrix A, 01515 * INB_A > 0. 01516 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 01517 * bute the last M_A-IMB_A rows of A, 01518 * MB_A > 0. 01519 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 01520 * bute the last N_A-INB_A columns of 01521 * A, NB_A > 0. 01522 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 01523 * row of the matrix A is distributed, 01524 * NPROW > RSRC_A >= 0. 01525 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 01526 * first column of A is distributed. 01527 * NPCOL > CSRC_A >= 0. 01528 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01529 * array storing the local blocks of 01530 * the distributed matrix A, 01531 * IF( Lc( 1, N_A ) > 0 ) 01532 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01533 * ELSE 01534 * LLD_A >= 1. 01535 * 01536 * Let K be the number of rows of a matrix A starting at the global in- 01537 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01538 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01539 * receive if these K rows were distributed over NPROW processes. If K 01540 * is the number of columns of a matrix A starting at the global index 01541 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01542 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01543 * these K columns were distributed over NPCOL processes. 01544 * 01545 * The values of Lr() and Lc() may be determined via a call to the func- 01546 * tion PB_NUMROC: 01547 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01548 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01549 * 01550 * Arguments 01551 * ========= 01552 * 01553 * LTEST (global input) LOGICAL array 01554 * On entry, LTEST is an array of dimension at least 8 (NSUBS). 01555 * If LTEST( 1 ) is .TRUE., PSSWAP will be tested; 01556 * If LTEST( 2 ) is .TRUE., PSSCAL will be tested; 01557 * If LTEST( 3 ) is .TRUE., PSCOPY will be tested; 01558 * If LTEST( 4 ) is .TRUE., PSAXPY will be tested; 01559 * If LTEST( 5 ) is .TRUE., PSDOT will be tested; 01560 * If LTEST( 6 ) is .TRUE., PSNRM2 will be tested; 01561 * If LTEST( 7 ) is .TRUE., PSASUM will be tested; 01562 * If LTEST( 8 ) is .TRUE., PSAMAX will be tested. 01563 * 01564 * INOUT (global input) INTEGER 01565 * On entry, INOUT specifies the unit number for output file. 01566 * When INOUT is 6, output to screen, when INOUT = 0, output to 01567 * stderr. INOUT is only defined in process 0. 01568 * 01569 * NPROCS (global input) INTEGER 01570 * On entry, NPROCS specifies the total number of processes cal- 01571 * ling this routine. 01572 * 01573 * Calling sequence encodings 01574 * ========================== 01575 * 01576 * code Formal argument list Examples 01577 * 01578 * 11 (n, v1,v2) _SWAP, _COPY 01579 * 12 (n,s1, v1 ) _SCAL, _SCAL 01580 * 13 (n,s1, v1,v2) _AXPY, _DOT_ 01581 * 14 (n,s1,i1,v1 ) _AMAX 01582 * 15 (n,u1, v1 ) _ASUM, _NRM2 01583 * 01584 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV 01585 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV 01586 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV 01587 * 24 ( m,n,s1,v1,v2,m1) _GER_ 01588 * 25 (uplo, n,s1,v1, m1) _SYR 01589 * 26 (uplo, n,u1,v1, m1) _HER 01590 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2 01591 * 01592 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM 01593 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM 01594 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK 01595 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK 01596 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K 01597 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K 01598 * 37 ( m,n, s1,m1, s2,m3) _TRAN_ 01599 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM 01600 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD 01601 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD 01602 * 01603 * -- Written on April 1, 1998 by 01604 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01605 * 01606 * ===================================================================== 01607 * 01608 * .. Parameters .. 01609 INTEGER NSUBS 01610 PARAMETER ( NSUBS = 8 ) 01611 * .. 01612 * .. Local Scalars .. 01613 LOGICAL ABRTSAV 01614 INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW 01615 * .. 01616 * .. Local Arrays .. 01617 INTEGER SCODE( NSUBS ) 01618 * .. 01619 * .. External Subroutines .. 01620 EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO, 01621 $ BLACS_GRIDINIT, PSAMAX, PSASUM, PSAXPY, PSCOPY, 01622 $ PSDIMEE, PSDOT, PSNRM2, PSSCAL, PSSWAP, 01623 $ PSVECEE 01624 * .. 01625 * .. Common Blocks .. 01626 LOGICAL ABRTFLG 01627 INTEGER NOUT 01628 CHARACTER*7 SNAMES( NSUBS ) 01629 COMMON /SNAMEC/SNAMES 01630 COMMON /PBERRORC/NOUT, ABRTFLG 01631 * .. 01632 * .. Data Statements .. 01633 DATA SCODE/11, 12, 11, 13, 13, 15, 15, 14/ 01634 * .. 01635 * .. Executable Statements .. 01636 * 01637 * Temporarily define blacs grid to include all processes so 01638 * information can be broadcast to all processes. 01639 * 01640 CALL BLACS_GET( -1, 0, ICTXT ) 01641 CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS ) 01642 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 01643 * 01644 * Set ABRTFLG to FALSE so that the PBLAS error handler won't abort 01645 * on errors during these tests and set the output device unit for 01646 * it. 01647 * 01648 ABRTSAV = ABRTFLG 01649 ABRTFLG = .FALSE. 01650 NOUT = INOUT 01651 * 01652 * Test PSSWAP 01653 * 01654 I = 1 01655 IF( LTEST( I ) ) THEN 01656 CALL PSDIMEE( ICTXT, NOUT, PSSWAP, SCODE( I ), SNAMES( I ) ) 01657 CALL PSVECEE( ICTXT, NOUT, PSSWAP, SCODE( I ), SNAMES( I ) ) 01658 END IF 01659 * 01660 * Test PSSCAL 01661 * 01662 I = I + 1 01663 IF( LTEST( I ) ) THEN 01664 CALL PSDIMEE( ICTXT, NOUT, PSSCAL, SCODE( I ), SNAMES( I ) ) 01665 CALL PSVECEE( ICTXT, NOUT, PSSCAL, SCODE( I ), SNAMES( I ) ) 01666 END IF 01667 * 01668 * Test PSCOPY 01669 * 01670 I = I + 1 01671 IF( LTEST( I ) ) THEN 01672 CALL PSDIMEE( ICTXT, NOUT, PSCOPY, SCODE( I ), SNAMES( I ) ) 01673 CALL PSVECEE( ICTXT, NOUT, PSCOPY, SCODE( I ), SNAMES( I ) ) 01674 END IF 01675 * 01676 * Test PSAXPY 01677 * 01678 I = I + 1 01679 IF( LTEST( I ) ) THEN 01680 CALL PSDIMEE( ICTXT, NOUT, PSAXPY, SCODE( I ), SNAMES( I ) ) 01681 CALL PSVECEE( ICTXT, NOUT, PSAXPY, SCODE( I ), SNAMES( I ) ) 01682 END IF 01683 * 01684 * Test PSDOT 01685 * 01686 I = I + 1 01687 IF( LTEST( I ) ) THEN 01688 CALL PSDIMEE( ICTXT, NOUT, PSDOT, SCODE( I ), SNAMES( I ) ) 01689 CALL PSVECEE( ICTXT, NOUT, PSDOT, SCODE( I ), SNAMES( I ) ) 01690 END IF 01691 * 01692 * Test PSNRM2 01693 * 01694 I = I + 1 01695 IF( LTEST( I ) ) THEN 01696 CALL PSDIMEE( ICTXT, NOUT, PSNRM2, SCODE( I ), SNAMES( I ) ) 01697 CALL PSVECEE( ICTXT, NOUT, PSNRM2, SCODE( I ), SNAMES( I ) ) 01698 END IF 01699 * 01700 * Test PSASUM 01701 * 01702 I = I + 1 01703 IF( LTEST( I ) ) THEN 01704 CALL PSDIMEE( ICTXT, NOUT, PSASUM, SCODE( I ), SNAMES( I ) ) 01705 CALL PSVECEE( ICTXT, NOUT, PSASUM, SCODE( I ), SNAMES( I ) ) 01706 END IF 01707 * 01708 * Test PSAMAX 01709 * 01710 I = I + 1 01711 IF( LTEST( I ) ) THEN 01712 CALL PSDIMEE( ICTXT, NOUT, PSAMAX, SCODE( I ), SNAMES( I ) ) 01713 CALL PSVECEE( ICTXT, NOUT, PSAMAX, SCODE( I ), SNAMES( I ) ) 01714 END IF 01715 * 01716 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 01717 $ WRITE( NOUT, FMT = 9999 ) 01718 * 01719 CALL BLACS_GRIDEXIT( ICTXT ) 01720 * 01721 * Reset ABRTFLG to the value it had before calling this routine 01722 * 01723 ABRTFLG = ABRTSAV 01724 * 01725 9999 FORMAT( 2X, 'Error-exit tests completed.' ) 01726 * 01727 RETURN 01728 * 01729 * End of PSBLAS1TSTCHKE 01730 * 01731 END 01732 SUBROUTINE PSCHKARG1( ICTXT, NOUT, SNAME, N, ALPHA, IX, JX, 01733 $ DESCX, INCX, IY, JY, DESCY, INCY, INFO ) 01734 * 01735 * -- PBLAS test routine (version 2.0) -- 01736 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 01737 * and University of California, Berkeley. 01738 * April 1, 1998 01739 * 01740 * .. Scalar Arguments .. 01741 INTEGER ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N, 01742 $ NOUT 01743 REAL ALPHA 01744 * .. 01745 * .. Array Arguments .. 01746 CHARACTER*(*) SNAME 01747 INTEGER DESCX( * ), DESCY( * ) 01748 * .. 01749 * 01750 * Purpose 01751 * ======= 01752 * 01753 * PSCHKARG1 checks the input-only arguments of the Level 1 PBLAS. When 01754 * INFO = 0, this routine makes a copy of its arguments (which are INPUT 01755 * only arguments to PBLAS routines). Otherwise, it verifies the values 01756 * of these arguments against the saved copies. 01757 * 01758 * Notes 01759 * ===== 01760 * 01761 * A description vector is associated with each 2D block-cyclicly dis- 01762 * tributed matrix. This vector stores the information required to 01763 * establish the mapping between a matrix entry and its corresponding 01764 * process and memory location. 01765 * 01766 * In the following comments, the character _ should be read as 01767 * "of the distributed matrix". Let A be a generic term for any 2D 01768 * block cyclicly distributed matrix. Its description vector is DESCA: 01769 * 01770 * NOTATION STORED IN EXPLANATION 01771 * ---------------- --------------- ------------------------------------ 01772 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 01773 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 01774 * the NPROW x NPCOL BLACS process grid 01775 * A is distributed over. The context 01776 * itself is global, but the handle 01777 * (the integer value) may vary. 01778 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 01779 * ted matrix A, M_A >= 0. 01780 * N_A (global) DESCA( N_ ) The number of columns in the distri- 01781 * buted matrix A, N_A >= 0. 01782 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 01783 * block of the matrix A, IMB_A > 0. 01784 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 01785 * left block of the matrix A, 01786 * INB_A > 0. 01787 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 01788 * bute the last M_A-IMB_A rows of A, 01789 * MB_A > 0. 01790 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 01791 * bute the last N_A-INB_A columns of 01792 * A, NB_A > 0. 01793 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 01794 * row of the matrix A is distributed, 01795 * NPROW > RSRC_A >= 0. 01796 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 01797 * first column of A is distributed. 01798 * NPCOL > CSRC_A >= 0. 01799 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 01800 * array storing the local blocks of 01801 * the distributed matrix A, 01802 * IF( Lc( 1, N_A ) > 0 ) 01803 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 01804 * ELSE 01805 * LLD_A >= 1. 01806 * 01807 * Let K be the number of rows of a matrix A starting at the global in- 01808 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 01809 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 01810 * receive if these K rows were distributed over NPROW processes. If K 01811 * is the number of columns of a matrix A starting at the global index 01812 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 01813 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 01814 * these K columns were distributed over NPCOL processes. 01815 * 01816 * The values of Lr() and Lc() may be determined via a call to the func- 01817 * tion PB_NUMROC: 01818 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 01819 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 01820 * 01821 * Arguments 01822 * ========= 01823 * 01824 * ICTXT (local input) INTEGER 01825 * On entry, ICTXT specifies the BLACS context handle, indica- 01826 * ting the global context of the operation. The context itself 01827 * is global, but the value of ICTXT is local. 01828 * 01829 * NOUT (global input) INTEGER 01830 * On entry, NOUT specifies the unit number for the output file. 01831 * When NOUT is 6, output to screen, when NOUT is 0, output to 01832 * stderr. NOUT is only defined for process 0. 01833 * 01834 * SNAME (global input) CHARACTER*(*) 01835 * On entry, SNAME specifies the subroutine name calling this 01836 * subprogram. 01837 * 01838 * N (global input) INTEGER 01839 * On entry, N specifies the length of the subvector operands. 01840 * 01841 * ALPHA (global input) REAL 01842 * On entry, ALPHA specifies the scalar alpha. 01843 * 01844 * IX (global input) INTEGER 01845 * On entry, IX specifies X's global row index, which points to 01846 * the beginning of the submatrix sub( X ). 01847 * 01848 * JX (global input) INTEGER 01849 * On entry, JX specifies X's global column index, which points 01850 * to the beginning of the submatrix sub( X ). 01851 * 01852 * DESCX (global and local input) INTEGER array 01853 * On entry, DESCX is an integer array of dimension DLEN_. This 01854 * is the array descriptor for the matrix X. 01855 * 01856 * INCX (global input) INTEGER 01857 * On entry, INCX specifies the global increment for the 01858 * elements of X. Only two values of INCX are supported in 01859 * this version, namely 1 and M_X. INCX must not be zero. 01860 * 01861 * IY (global input) INTEGER 01862 * On entry, IY specifies Y's global row index, which points to 01863 * the beginning of the submatrix sub( Y ). 01864 * 01865 * JY (global input) INTEGER 01866 * On entry, JY specifies Y's global column index, which points 01867 * to the beginning of the submatrix sub( Y ). 01868 * 01869 * DESCY (global and local input) INTEGER array 01870 * On entry, DESCY is an integer array of dimension DLEN_. This 01871 * is the array descriptor for the matrix Y. 01872 * 01873 * INCY (global input) INTEGER 01874 * On entry, INCY specifies the global increment for the 01875 * elements of Y. Only two values of INCY are supported in 01876 * this version, namely 1 and M_Y. INCY must not be zero. 01877 * 01878 * INFO (global input/global output) INTEGER 01879 * When INFO = 0 on entry, the values of the arguments which are 01880 * INPUT only arguments to a PBLAS routine are copied into sta- 01881 * tic variables and INFO is unchanged on exit. Otherwise, the 01882 * values of the arguments are compared against the saved co- 01883 * pies. In case no error has been found INFO is zero on return, 01884 * otherwise it is non zero. 01885 * 01886 * -- Written on April 1, 1998 by 01887 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 01888 * 01889 * ===================================================================== 01890 * 01891 * .. Parameters .. 01892 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 01893 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 01894 $ RSRC_ 01895 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 01896 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 01897 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 01898 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 01899 * .. 01900 * .. Local Scalars .. 01901 INTEGER I, INCXREF, INCYREF, IXREF, IYREF, JXREF, 01902 $ JYREF, MYCOL, MYROW, NPCOL, NPROW, NREF 01903 REAL ALPHAREF 01904 * .. 01905 * .. Local Arrays .. 01906 CHARACTER*15 ARGNAME 01907 INTEGER DESCXREF( DLEN_ ), DESCYREF( DLEN_ ) 01908 * .. 01909 * .. External Subroutines .. 01910 EXTERNAL BLACS_GRIDINFO, IGSUM2D 01911 * .. 01912 * .. Save Statements .. 01913 SAVE 01914 * .. 01915 * .. Executable Statements .. 01916 * 01917 * Get grid parameters 01918 * 01919 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 01920 * 01921 * Check if first call. If yes, then save. 01922 * 01923 IF( INFO.EQ.0 ) THEN 01924 * 01925 NREF = N 01926 IXREF = IX 01927 JXREF = JX 01928 DO 10 I = 1, DLEN_ 01929 DESCXREF( I ) = DESCX( I ) 01930 10 CONTINUE 01931 INCXREF = INCX 01932 IYREF = IY 01933 JYREF = JY 01934 DO 20 I = 1, DLEN_ 01935 DESCYREF( I ) = DESCY( I ) 01936 20 CONTINUE 01937 INCYREF = INCY 01938 ALPHAREF = ALPHA 01939 * 01940 ELSE 01941 * 01942 * Test saved args. Return with first mismatch. 01943 * 01944 ARGNAME = ' ' 01945 IF( N.NE.NREF ) THEN 01946 WRITE( ARGNAME, FMT = '(A)' ) 'N' 01947 ELSE IF( IX.NE.IXREF ) THEN 01948 WRITE( ARGNAME, FMT = '(A)' ) 'IX' 01949 ELSE IF( JX.NE.JXREF ) THEN 01950 WRITE( ARGNAME, FMT = '(A)' ) 'JX' 01951 ELSE IF( DESCX( DTYPE_ ).NE.DESCXREF( DTYPE_ ) ) THEN 01952 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( DTYPE_ )' 01953 ELSE IF( DESCX( M_ ).NE.DESCXREF( M_ ) ) THEN 01954 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( M_ )' 01955 ELSE IF( DESCX( N_ ).NE.DESCXREF( N_ ) ) THEN 01956 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( N_ )' 01957 ELSE IF( DESCX( IMB_ ).NE.DESCXREF( IMB_ ) ) THEN 01958 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( IMB_ )' 01959 ELSE IF( DESCX( INB_ ).NE.DESCXREF( INB_ ) ) THEN 01960 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( INB_ )' 01961 ELSE IF( DESCX( MB_ ).NE.DESCXREF( MB_ ) ) THEN 01962 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( MB_ )' 01963 ELSE IF( DESCX( NB_ ).NE.DESCXREF( NB_ ) ) THEN 01964 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( NB_ )' 01965 ELSE IF( DESCX( RSRC_ ).NE.DESCXREF( RSRC_ ) ) THEN 01966 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( RSRC_ )' 01967 ELSE IF( DESCX( CSRC_ ).NE.DESCXREF( CSRC_ ) ) THEN 01968 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( CSRC_ )' 01969 ELSE IF( DESCX( CTXT_ ).NE.DESCXREF( CTXT_ ) ) THEN 01970 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( CTXT_ )' 01971 ELSE IF( DESCX( LLD_ ).NE.DESCXREF( LLD_ ) ) THEN 01972 WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( LLD_ )' 01973 ELSE IF( INCX.NE.INCXREF ) THEN 01974 WRITE( ARGNAME, FMT = '(A)' ) 'INCX' 01975 ELSE IF( IY.NE.IYREF ) THEN 01976 WRITE( ARGNAME, FMT = '(A)' ) 'IY' 01977 ELSE IF( JY.NE.JYREF ) THEN 01978 WRITE( ARGNAME, FMT = '(A)' ) 'JY' 01979 ELSE IF( DESCY( DTYPE_ ).NE.DESCYREF( DTYPE_ ) ) THEN 01980 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( DTYPE_ )' 01981 ELSE IF( DESCY( M_ ).NE.DESCYREF( M_ ) ) THEN 01982 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( M_ )' 01983 ELSE IF( DESCY( N_ ).NE.DESCYREF( N_ ) ) THEN 01984 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( N_ )' 01985 ELSE IF( DESCY( IMB_ ).NE.DESCYREF( IMB_ ) ) THEN 01986 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( IMB_ )' 01987 ELSE IF( DESCY( INB_ ).NE.DESCYREF( INB_ ) ) THEN 01988 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( INB_ )' 01989 ELSE IF( DESCY( MB_ ).NE.DESCYREF( MB_ ) ) THEN 01990 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( MB_ )' 01991 ELSE IF( DESCY( NB_ ).NE.DESCYREF( NB_ ) ) THEN 01992 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( NB_ )' 01993 ELSE IF( DESCY( RSRC_ ).NE.DESCYREF( RSRC_ ) ) THEN 01994 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( RSRC_ )' 01995 ELSE IF( DESCY( CSRC_ ).NE.DESCYREF( CSRC_ ) ) THEN 01996 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( CSRC_ )' 01997 ELSE IF( DESCY( CTXT_ ).NE.DESCYREF( CTXT_ ) ) THEN 01998 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( CTXT_ )' 01999 ELSE IF( DESCY( LLD_ ).NE.DESCYREF( LLD_ ) ) THEN 02000 WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( LLD_ )' 02001 ELSE IF( INCY.NE.INCYREF ) THEN 02002 WRITE( ARGNAME, FMT = '(A)' ) 'INCY' 02003 ELSE IF( ALPHA.NE.ALPHAREF ) THEN 02004 WRITE( ARGNAME, FMT = '(A)' ) 'ALPHA' 02005 ELSE 02006 INFO = 0 02007 END IF 02008 * 02009 CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 ) 02010 * 02011 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02012 * 02013 IF( INFO.GT.0 ) THEN 02014 WRITE( NOUT, FMT = 9999 ) ARGNAME, SNAME 02015 ELSE 02016 WRITE( NOUT, FMT = 9998 ) SNAME 02017 END IF 02018 * 02019 END IF 02020 * 02021 END IF 02022 * 02023 9999 FORMAT( 2X, ' ***** Input-only parameter check: ', A, 02024 $ ' FAILED changed ', A, ' *****' ) 02025 9998 FORMAT( 2X, ' ***** Input-only parameter check: ', A, 02026 $ ' PASSED *****' ) 02027 * 02028 RETURN 02029 * 02030 * End of PSCHKARG1 02031 * 02032 END 02033 LOGICAL FUNCTION PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) 02034 * 02035 * -- PBLAS test routine (version 2.0) -- 02036 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02037 * and University of California, Berkeley. 02038 * April 1, 1998 02039 * 02040 * .. Scalar Arguments .. 02041 INTEGER ICTXT, INCX, IX, JX, N 02042 * .. 02043 * .. Array Arguments .. 02044 INTEGER DESCX( * ) 02045 * .. 02046 * 02047 * Purpose 02048 * ======= 02049 * 02050 * PISINSCOPE returns .TRUE. if the calling process is in the scope of 02051 * sub( X ) = X( IX+(JX-1)*DESCX(M_)+(i-1)*INCX ) and .FALSE. if it is 02052 * not. This routine is used to determine which processes should check 02053 * the answer returned by some Level 1 PBLAS routines. 02054 * 02055 * Notes 02056 * ===== 02057 * 02058 * A description vector is associated with each 2D block-cyclicly dis- 02059 * tributed matrix. This vector stores the information required to 02060 * establish the mapping between a matrix entry and its corresponding 02061 * process and memory location. 02062 * 02063 * In the following comments, the character _ should be read as 02064 * "of the distributed matrix". Let A be a generic term for any 2D 02065 * block cyclicly distributed matrix. Its description vector is DESCA: 02066 * 02067 * NOTATION STORED IN EXPLANATION 02068 * ---------------- --------------- ------------------------------------ 02069 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 02070 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 02071 * the NPROW x NPCOL BLACS process grid 02072 * A is distributed over. The context 02073 * itself is global, but the handle 02074 * (the integer value) may vary. 02075 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 02076 * ted matrix A, M_A >= 0. 02077 * N_A (global) DESCA( N_ ) The number of columns in the distri- 02078 * buted matrix A, N_A >= 0. 02079 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 02080 * block of the matrix A, IMB_A > 0. 02081 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 02082 * left block of the matrix A, 02083 * INB_A > 0. 02084 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 02085 * bute the last M_A-IMB_A rows of A, 02086 * MB_A > 0. 02087 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 02088 * bute the last N_A-INB_A columns of 02089 * A, NB_A > 0. 02090 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 02091 * row of the matrix A is distributed, 02092 * NPROW > RSRC_A >= 0. 02093 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 02094 * first column of A is distributed. 02095 * NPCOL > CSRC_A >= 0. 02096 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 02097 * array storing the local blocks of 02098 * the distributed matrix A, 02099 * IF( Lc( 1, N_A ) > 0 ) 02100 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 02101 * ELSE 02102 * LLD_A >= 1. 02103 * 02104 * Let K be the number of rows of a matrix A starting at the global in- 02105 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 02106 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 02107 * receive if these K rows were distributed over NPROW processes. If K 02108 * is the number of columns of a matrix A starting at the global index 02109 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 02110 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 02111 * these K columns were distributed over NPCOL processes. 02112 * 02113 * The values of Lr() and Lc() may be determined via a call to the func- 02114 * tion PB_NUMROC: 02115 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 02116 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 02117 * 02118 * Arguments 02119 * ========= 02120 * 02121 * ICTXT (local input) INTEGER 02122 * On entry, ICTXT specifies the BLACS context handle, indica- 02123 * ting the global context of the operation. The context itself 02124 * is global, but the value of ICTXT is local. 02125 * 02126 * N (global input) INTEGER 02127 * The length of the subvector sub( X ). 02128 * 02129 * IX (global input) INTEGER 02130 * On entry, IX specifies X's global row index, which points to 02131 * the beginning of the submatrix sub( X ). 02132 * 02133 * JX (global input) INTEGER 02134 * On entry, JX specifies X's global column index, which points 02135 * to the beginning of the submatrix sub( X ). 02136 * 02137 * DESCX (global and local input) INTEGER array 02138 * On entry, DESCX is an integer array of dimension DLEN_. This 02139 * is the array descriptor for the matrix X. 02140 * 02141 * INCX (global input) INTEGER 02142 * On entry, INCX specifies the global increment for the 02143 * elements of X. Only two values of INCX are supported in 02144 * this version, namely 1 and M_X. INCX must not be zero. 02145 * 02146 * -- Written on April 1, 1998 by 02147 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02148 * 02149 * ===================================================================== 02150 * 02151 * .. Parameters .. 02152 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 02153 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 02154 $ RSRC_ 02155 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 02156 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 02157 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 02158 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 02159 * .. 02160 * .. Local Scalars .. 02161 LOGICAL COLREP, ROWREP 02162 INTEGER IIX, IXCOL, IXROW, JJX, MYCOL, MYROW, NPCOL, 02163 $ NPROW 02164 * .. 02165 * .. External Subroutines .. 02166 EXTERNAL BLACS_GRIDINFO, PB_INFOG2L 02167 * .. 02168 * .. Executable Statements .. 02169 * 02170 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 02171 * 02172 CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, 02173 $ IIX, JJX, IXROW, IXCOL ) 02174 ROWREP = ( IXROW.EQ.-1 ) 02175 COLREP = ( IXCOL.EQ.-1 ) 02176 * 02177 IF( DESCX( M_ ).EQ.1 .AND. N.EQ.1 ) THEN 02178 * 02179 * This is the special case, find process owner of IX, JX, and 02180 * only this process is the scope. 02181 * 02182 PISINSCOPE = ( ( IXROW.EQ.MYROW .OR. ROWREP ) .AND. 02183 $ ( IXCOL.EQ.MYCOL .OR. COLREP ) ) 02184 * 02185 ELSE 02186 * 02187 IF( INCX.EQ.DESCX( M_ ) ) THEN 02188 * 02189 * row vector 02190 * 02191 PISINSCOPE = ( MYROW.EQ.IXROW .OR. ROWREP ) 02192 * 02193 ELSE 02194 * 02195 * column vector 02196 * 02197 PISINSCOPE = ( MYCOL.EQ.IXCOL .OR. COLREP ) 02198 * 02199 END IF 02200 * 02201 END IF 02202 * 02203 RETURN 02204 * 02205 * End of PISINSCOPE 02206 * 02207 END 02208 SUBROUTINE PSBLAS1TSTCHK( ICTXT, NOUT, NROUT, N, PSCLR, PUSCLR, 02209 $ PISCLR, X, PX, IX, JX, DESCX, INCX, Y, 02210 $ PY, IY, JY, DESCY, INCY, INFO ) 02211 * 02212 * -- PBLAS test routine (version 2.0) -- 02213 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02214 * and University of California, Berkeley. 02215 * April 1, 1998 02216 * 02217 * .. Scalar Arguments .. 02218 INTEGER ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N, 02219 $ NOUT, NROUT, PISCLR 02220 REAL PSCLR, PUSCLR 02221 * .. 02222 * .. Array Arguments .. 02223 INTEGER DESCX( * ), DESCY( * ) 02224 REAL PX( * ), PY( * ), X( * ), Y( * ) 02225 * .. 02226 * 02227 * Purpose 02228 * ======= 02229 * 02230 * PSBLAS1TSTCHK performs the computational tests of the Level 1 PBLAS. 02231 * 02232 * Notes 02233 * ===== 02234 * 02235 * A description vector is associated with each 2D block-cyclicly dis- 02236 * tributed matrix. This vector stores the information required to 02237 * establish the mapping between a matrix entry and its corresponding 02238 * process and memory location. 02239 * 02240 * In the following comments, the character _ should be read as 02241 * "of the distributed matrix". Let A be a generic term for any 2D 02242 * block cyclicly distributed matrix. Its description vector is DESCA: 02243 * 02244 * NOTATION STORED IN EXPLANATION 02245 * ---------------- --------------- ------------------------------------ 02246 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type. 02247 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 02248 * the NPROW x NPCOL BLACS process grid 02249 * A is distributed over. The context 02250 * itself is global, but the handle 02251 * (the integer value) may vary. 02252 * M_A (global) DESCA( M_ ) The number of rows in the distribu- 02253 * ted matrix A, M_A >= 0. 02254 * N_A (global) DESCA( N_ ) The number of columns in the distri- 02255 * buted matrix A, N_A >= 0. 02256 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left 02257 * block of the matrix A, IMB_A > 0. 02258 * INB_A (global) DESCA( INB_ ) The number of columns of the upper 02259 * left block of the matrix A, 02260 * INB_A > 0. 02261 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri- 02262 * bute the last M_A-IMB_A rows of A, 02263 * MB_A > 0. 02264 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri- 02265 * bute the last N_A-INB_A columns of 02266 * A, NB_A > 0. 02267 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 02268 * row of the matrix A is distributed, 02269 * NPROW > RSRC_A >= 0. 02270 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the 02271 * first column of A is distributed. 02272 * NPCOL > CSRC_A >= 0. 02273 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 02274 * array storing the local blocks of 02275 * the distributed matrix A, 02276 * IF( Lc( 1, N_A ) > 0 ) 02277 * LLD_A >= MAX( 1, Lr( 1, M_A ) ) 02278 * ELSE 02279 * LLD_A >= 1. 02280 * 02281 * Let K be the number of rows of a matrix A starting at the global in- 02282 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows 02283 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would 02284 * receive if these K rows were distributed over NPROW processes. If K 02285 * is the number of columns of a matrix A starting at the global index 02286 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co- 02287 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if 02288 * these K columns were distributed over NPCOL processes. 02289 * 02290 * The values of Lr() and Lc() may be determined via a call to the func- 02291 * tion PB_NUMROC: 02292 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ) 02293 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL ) 02294 * 02295 * Arguments 02296 * ========= 02297 * 02298 * ICTXT (local input) INTEGER 02299 * On entry, ICTXT specifies the BLACS context handle, indica- 02300 * ting the global context of the operation. The context itself 02301 * is global, but the value of ICTXT is local. 02302 * 02303 * NOUT (global input) INTEGER 02304 * On entry, NOUT specifies the unit number for the output file. 02305 * When NOUT is 6, output to screen, when NOUT is 0, output to 02306 * stderr. NOUT is only defined for process 0. 02307 * 02308 * NROUT (global input) INTEGER 02309 * On entry, NROUT specifies which routine will be tested as 02310 * follows: 02311 * If NROUT = 1, PSSWAP will be tested; 02312 * else if NROUT = 2, PSSCAL will be tested; 02313 * else if NROUT = 3, PSCOPY will be tested; 02314 * else if NROUT = 4, PSAXPY will be tested; 02315 * else if NROUT = 5, PSDOT will be tested; 02316 * else if NROUT = 6, PSNRM2 will be tested; 02317 * else if NROUT = 7, PSASUM will be tested; 02318 * else if NROUT = 8, PSAMAX will be tested. 02319 * 02320 * N (global input) INTEGER 02321 * On entry, N specifies the length of the subvector operands. 02322 * 02323 * PSCLR (global input) REAL 02324 * On entry, depending on the value of NROUT, PSCLR specifies 02325 * the scalar ALPHA, or the output scalar returned by the PBLAS, 02326 * i.e., the dot product, the 2-norm, the absolute sum or the 02327 * value of AMAX. 02328 * 02329 * PUSCLR (global input) REAL 02330 * On entry, PUSCLR specifies the real part of the scalar ALPHA 02331 * used by the real scaling, the 2-norm, or the absolute sum 02332 * routines. PUSCLR is not used in the real versions of this 02333 * routine. 02334 * 02335 * PISCLR (global input) REAL 02336 * On entry, PISCLR specifies the value of the global index re- 02337 * turned by PSAMAX, otherwise PISCLR is not used. 02338 * 02339 * X (local input/local output) REAL array 02340 * On entry, X is an array of dimension (DESCX( M_ ),*). This 02341 * array contains a local copy of the initial entire matrix PX. 02342 * 02343 * PX (local input) REAL array 02344 * On entry, PX is an array of dimension (DESCX( LLD_ ),*). This 02345 * array contains the local entries of the matrix PX. 02346 * 02347 * IX (global input) INTEGER 02348 * On entry, IX specifies X's global row index, which points to 02349 * the beginning of the submatrix sub( X ). 02350 * 02351 * JX (global input) INTEGER 02352 * On entry, JX specifies X's global column index, which points 02353 * to the beginning of the submatrix sub( X ). 02354 * 02355 * DESCX (global and local input) INTEGER array 02356 * On entry, DESCX is an integer array of dimension DLEN_. This 02357 * is the array descriptor for the matrix X. 02358 * 02359 * INCX (global input) INTEGER 02360 * On entry, INCX specifies the global increment for the 02361 * elements of X. Only two values of INCX are supported in 02362 * this version, namely 1 and M_X. INCX must not be zero. 02363 * 02364 * Y (local input/local output) REAL array 02365 * On entry, Y is an array of dimension (DESCY( M_ ),*). This 02366 * array contains a local copy of the initial entire matrix PY. 02367 * 02368 * PY (local input) REAL array 02369 * On entry, PY is an array of dimension (DESCY( LLD_ ),*). This 02370 * array contains the local entries of the matrix PY. 02371 * 02372 * IY (global input) INTEGER 02373 * On entry, IY specifies Y's global row index, which points to 02374 * the beginning of the submatrix sub( Y ). 02375 * 02376 * JY (global input) INTEGER 02377 * On entry, JY specifies Y's global column index, which points 02378 * to the beginning of the submatrix sub( Y ). 02379 * 02380 * DESCY (global and local input) INTEGER array 02381 * On entry, DESCY is an integer array of dimension DLEN_. This 02382 * is the array descriptor for the matrix Y. 02383 * 02384 * INCY (global input) INTEGER 02385 * On entry, INCY specifies the global increment for the 02386 * elements of Y. Only two values of INCY are supported in 02387 * this version, namely 1 and M_Y. INCY must not be zero. 02388 * 02389 * INFO (global output) INTEGER 02390 * On exit, if INFO = 0, no error has been found, otherwise 02391 * if( MOD( INFO, 2 ) = 1 ) then an error on X has been found, 02392 * if( MOD( INFO/2, 2 ) = 1 ) then an error on Y has been found. 02393 * 02394 * -- Written on April 1, 1998 by 02395 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 02396 * 02397 * ===================================================================== 02398 * 02399 * .. Parameters .. 02400 REAL ZERO 02401 PARAMETER ( ZERO = 0.0E+0 ) 02402 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_, 02403 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_, 02404 $ RSRC_ 02405 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11, 02406 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4, 02407 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8, 02408 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 ) 02409 * .. 02410 * .. Local Scalars .. 02411 LOGICAL COLREP, INXSCOPE, INYSCOPE, ROWREP 02412 INTEGER I, IB, ICURCOL, ICURROW, IDUMM, IIX, IIY, IN, 02413 $ IOFFX, IOFFY, ISCLR, IXCOL, IXROW, IYCOL, 02414 $ IYROW, J, JB, JJX, JJY, JN, KK, LDX, LDY, 02415 $ MYCOL, MYROW, NPCOL, NPROW 02416 REAL ERR, ERRMAX, PREC, SCLR, USCLR 02417 * .. 02418 * .. Local Arrays .. 02419 INTEGER IERR( 6 ) 02420 CHARACTER*5 ARGIN1, ARGIN2, ARGOUT1, ARGOUT2 02421 * .. 02422 * .. External Subroutines .. 02423 EXTERNAL BLACS_GRIDINFO, IGAMX2D, PB_INFOG2L, PSCHKVIN, 02424 $ PSERRASUM, PSERRAXPY, PSERRDOT, PSERRNRM2, 02425 $ PSERRSCAL, SCOPY, SSWAP 02426 * .. 02427 * .. External Functions .. 02428 LOGICAL PISINSCOPE 02429 INTEGER ISAMAX 02430 REAL PSLAMCH 02431 EXTERNAL ISAMAX, PISINSCOPE, PSLAMCH 02432 * .. 02433 * .. Intrinsic Functions .. 02434 INTRINSIC MIN 02435 * .. 02436 * .. Executable Statements .. 02437 * 02438 INFO = 0 02439 * 02440 * Quick return if possible 02441 * 02442 IF( N.LE.0 ) 02443 $ RETURN 02444 * 02445 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 02446 * 02447 ARGIN1 = ' ' 02448 ARGIN2 = ' ' 02449 ARGOUT1 = ' ' 02450 ARGOUT2 = ' ' 02451 DO 10 I = 1, 6 02452 IERR( I ) = 0 02453 10 CONTINUE 02454 * 02455 PREC = PSLAMCH( ICTXT, 'precision' ) 02456 * 02457 IF( NROUT.EQ.1 ) THEN 02458 * 02459 * Test PSSWAP 02460 * 02461 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02462 IOFFY = IY + ( JY - 1 ) * DESCY( M_ ) 02463 CALL SSWAP( N, X( IOFFX ), INCX, Y( IOFFY ), INCY ) 02464 CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02465 $ IERR( 1 ) ) 02466 CALL PSCHKVIN( ERRMAX, N, Y, PY, IY, JY, DESCY, INCY, 02467 $ IERR( 2 ) ) 02468 * 02469 ELSE IF( NROUT.EQ.2 ) THEN 02470 * 02471 * Test PSSCAL 02472 * 02473 LDX = DESCX( LLD_ ) 02474 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02475 CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, 02476 $ IIX, JJX, IXROW, IXCOL ) 02477 ICURROW = IXROW 02478 ICURCOL = IXCOL 02479 ROWREP = ( IXROW.EQ.-1 ) 02480 COLREP = ( IXCOL.EQ.-1 ) 02481 * 02482 IF( INCX.EQ.DESCX( M_ ) ) THEN 02483 * 02484 * sub( X ) is a row vector 02485 * 02486 JB = DESCX( INB_ ) - JX + 1 02487 IF( JB.LE.0 ) 02488 $ JB = ( (-JB ) / DESCX( NB_ ) + 1 ) * DESCX( NB_ ) + JB 02489 JB = MIN( JB, N ) 02490 JN = JX + JB - 1 02491 * 02492 DO 20 J = JX, JN 02493 * 02494 CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC ) 02495 * 02496 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02497 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02498 IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT. 02499 $ ERR ) 02500 $ IERR( 1 ) = 1 02501 JJX = JJX + 1 02502 END IF 02503 * 02504 IOFFX = IOFFX + INCX 02505 * 02506 20 CONTINUE 02507 * 02508 ICURCOL = MOD( ICURCOL+1, NPCOL ) 02509 * 02510 DO 40 J = JN+1, JX+N-1, DESCX( NB_ ) 02511 JB = MIN( JX+N-J, DESCX( NB_ ) ) 02512 * 02513 DO 30 KK = 0, JB-1 02514 * 02515 CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC ) 02516 * 02517 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02518 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02519 IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT. 02520 $ ERR ) 02521 $ IERR( 1 ) = 1 02522 JJX = JJX + 1 02523 END IF 02524 * 02525 IOFFX = IOFFX + INCX 02526 * 02527 30 CONTINUE 02528 * 02529 ICURCOL = MOD( ICURCOL+1, NPCOL ) 02530 * 02531 40 CONTINUE 02532 * 02533 ELSE 02534 * 02535 * sub( X ) is a column vector 02536 * 02537 IB = DESCX( IMB_ ) - IX + 1 02538 IF( IB.LE.0 ) 02539 $ IB = ( (-IB ) / DESCX( MB_ ) + 1 ) * DESCX( MB_ ) + IB 02540 IB = MIN( IB, N ) 02541 IN = IX + IB - 1 02542 * 02543 DO 50 I = IX, IN 02544 * 02545 CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC ) 02546 * 02547 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02548 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02549 IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT. 02550 $ ERR ) 02551 $ IERR( 1 ) = 1 02552 IIX = IIX + 1 02553 END IF 02554 * 02555 IOFFX = IOFFX + INCX 02556 * 02557 50 CONTINUE 02558 * 02559 ICURROW = MOD( ICURROW+1, NPROW ) 02560 * 02561 DO 70 I = IN+1, IX+N-1, DESCX( MB_ ) 02562 IB = MIN( IX+N-I, DESCX( MB_ ) ) 02563 * 02564 DO 60 KK = 0, IB-1 02565 * 02566 CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC ) 02567 * 02568 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02569 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02570 IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT. 02571 $ ERR ) 02572 $ IERR( 1 ) = 1 02573 IIX = IIX + 1 02574 END IF 02575 * 02576 IOFFX = IOFFX + INCX 02577 60 CONTINUE 02578 * 02579 ICURROW = MOD( ICURROW+1, NPROW ) 02580 * 02581 70 CONTINUE 02582 * 02583 END IF 02584 * 02585 ELSE IF( NROUT.EQ.3 ) THEN 02586 * 02587 * Test PSCOPY 02588 * 02589 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02590 IOFFY = IY + ( JY - 1 ) * DESCY( M_ ) 02591 CALL SCOPY( N, X( IOFFX ), INCX, Y( IOFFY ), INCY ) 02592 CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02593 $ IERR( 1 ) ) 02594 CALL PSCHKVIN( ERRMAX, N, Y, PY, IY, JY, DESCY, INCY, 02595 $ IERR( 2 ) ) 02596 * 02597 ELSE IF( NROUT.EQ.4 ) THEN 02598 * 02599 * Test PSAXPY 02600 * 02601 CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02602 $ IERR( 1 ) ) 02603 LDY = DESCY( LLD_ ) 02604 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02605 IOFFY = IY + ( JY - 1 ) * DESCY( M_ ) 02606 CALL PB_INFOG2L( IY, JY, DESCY, NPROW, NPCOL, MYROW, MYCOL, 02607 $ IIY, JJY, IYROW, IYCOL ) 02608 ICURROW = IYROW 02609 ICURCOL = IYCOL 02610 ROWREP = ( IYROW.EQ.-1 ) 02611 COLREP = ( IYCOL.EQ.-1 ) 02612 * 02613 IF( INCY.EQ.DESCY( M_ ) ) THEN 02614 * 02615 * sub( Y ) is a row vector 02616 * 02617 JB = DESCY( INB_ ) - JY + 1 02618 IF( JB.LE.0 ) 02619 $ JB = ( (-JB ) / DESCY( NB_ ) + 1 ) * DESCY( NB_ ) + JB 02620 JB = MIN( JB, N ) 02621 JN = JY + JB - 1 02622 * 02623 DO 140 J = JY, JN 02624 * 02625 CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ), 02626 $ PREC ) 02627 * 02628 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02629 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02630 IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT. 02631 $ ERR ) THEN 02632 IERR( 2 ) = 1 02633 END IF 02634 JJY = JJY + 1 02635 END IF 02636 * 02637 IOFFX = IOFFX + INCX 02638 IOFFY = IOFFY + INCY 02639 * 02640 140 CONTINUE 02641 * 02642 ICURCOL = MOD( ICURCOL+1, NPCOL ) 02643 * 02644 DO 160 J = JN+1, JY+N-1, DESCY( NB_ ) 02645 JB = MIN( JY+N-J, DESCY( NB_ ) ) 02646 * 02647 DO 150 KK = 0, JB-1 02648 * 02649 CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ), 02650 $ PREC ) 02651 * 02652 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02653 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02654 IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT. 02655 $ ERR ) THEN 02656 IERR( 2 ) = 1 02657 END IF 02658 JJY = JJY + 1 02659 END IF 02660 * 02661 IOFFX = IOFFX + INCX 02662 IOFFY = IOFFY + INCY 02663 * 02664 150 CONTINUE 02665 * 02666 ICURCOL = MOD( ICURCOL+1, NPCOL ) 02667 * 02668 160 CONTINUE 02669 * 02670 ELSE 02671 * 02672 * sub( Y ) is a column vector 02673 * 02674 IB = DESCY( IMB_ ) - IY + 1 02675 IF( IB.LE.0 ) 02676 $ IB = ( (-IB ) / DESCY( MB_ ) + 1 ) * DESCY( MB_ ) + IB 02677 IB = MIN( IB, N ) 02678 IN = IY + IB - 1 02679 * 02680 DO 170 I = IY, IN 02681 * 02682 CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ), 02683 $ PREC ) 02684 * 02685 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02686 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02687 IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT. 02688 $ ERR ) THEN 02689 IERR( 2 ) = 1 02690 END IF 02691 IIY = IIY + 1 02692 END IF 02693 * 02694 IOFFX = IOFFX + INCX 02695 IOFFY = IOFFY + INCY 02696 * 02697 170 CONTINUE 02698 * 02699 ICURROW = MOD( ICURROW+1, NPROW ) 02700 * 02701 DO 190 I = IN+1, IY+N-1, DESCY( MB_ ) 02702 IB = MIN( IY+N-I, DESCY( MB_ ) ) 02703 * 02704 DO 180 KK = 0, IB-1 02705 * 02706 CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ), 02707 $ PREC ) 02708 * 02709 IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND. 02710 $ ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN 02711 IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT. 02712 $ ERR ) THEN 02713 IERR( 2 ) = 1 02714 END IF 02715 IIY = IIY + 1 02716 END IF 02717 * 02718 IOFFX = IOFFX + INCX 02719 IOFFY = IOFFY + INCY 02720 * 02721 180 CONTINUE 02722 * 02723 ICURROW = MOD( ICURROW+1, NPROW ) 02724 * 02725 190 CONTINUE 02726 * 02727 END IF 02728 * 02729 ELSE IF( NROUT.EQ.5 ) THEN 02730 * 02731 * Test PSDOT 02732 * 02733 CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02734 $ IERR( 1 ) ) 02735 CALL PSCHKVIN( ERRMAX, N, Y, PY, IY, JY, DESCY, INCY, 02736 $ IERR( 2 ) ) 02737 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02738 IOFFY = IY + ( JY - 1 ) * DESCY( M_ ) 02739 CALL PSERRDOT( ERR, N, SCLR, X( IOFFX ), INCX, Y( IOFFY ), 02740 $ INCY, PREC ) 02741 INXSCOPE = PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) 02742 INYSCOPE = PISINSCOPE( ICTXT, N, IY, JY, DESCY, INCY ) 02743 IF( INXSCOPE.OR.INYSCOPE ) THEN 02744 IF( ABS( PSCLR - SCLR ).GT.ERR ) THEN 02745 IERR( 3 ) = 1 02746 WRITE( ARGIN1, FMT = '(A)' ) 'DOT' 02747 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02748 WRITE( NOUT, FMT = 9998 ) ARGIN1 02749 WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR 02750 END IF 02751 END IF 02752 ELSE 02753 SCLR = ZERO 02754 IF( PSCLR.NE.SCLR ) THEN 02755 IERR( 4 ) = 1 02756 WRITE( ARGOUT1, FMT = '(A)' ) 'DOT' 02757 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02758 WRITE( NOUT, FMT = 9997 ) ARGOUT1 02759 WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR 02760 END IF 02761 END IF 02762 END IF 02763 * 02764 ELSE IF( NROUT.EQ.6 ) THEN 02765 * 02766 * Test PSNRM2 02767 * 02768 CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02769 $ IERR( 1 ) ) 02770 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02771 CALL PSERRNRM2( ERR, N, USCLR, X( IOFFX ), INCX, PREC ) 02772 IF( PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) ) THEN 02773 IF( ABS( PUSCLR - USCLR ).GT.ERR ) THEN 02774 IERR( 3 ) = 1 02775 WRITE( ARGIN1, FMT = '(A)' ) 'NRM2' 02776 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02777 WRITE( NOUT, FMT = 9998 ) ARGIN1 02778 WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR 02779 END IF 02780 END IF 02781 ELSE 02782 USCLR = ZERO 02783 IF( PUSCLR.NE.USCLR ) THEN 02784 IERR( 4 ) = 1 02785 WRITE( ARGOUT1, FMT = '(A)' ) 'NRM2' 02786 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02787 WRITE( NOUT, FMT = 9997 ) ARGOUT1 02788 WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR 02789 END IF 02790 END IF 02791 END IF 02792 * 02793 ELSE IF( NROUT.EQ.7 ) THEN 02794 * 02795 * Test PSASUM 02796 * 02797 CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02798 $ IERR( 1 ) ) 02799 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02800 CALL PSERRASUM( ERR, N, USCLR, X( IOFFX ), INCX, PREC ) 02801 IF( PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) ) THEN 02802 IF( ABS( PUSCLR - USCLR ) .GT. ERR ) THEN 02803 IERR( 3 ) = 1 02804 WRITE( ARGIN1, FMT = '(A)' ) 'ASUM' 02805 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02806 WRITE( NOUT, FMT = 9998 ) ARGIN1 02807 WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR 02808 END IF 02809 END IF 02810 ELSE 02811 USCLR = ZERO 02812 IF( PUSCLR.NE.USCLR ) THEN 02813 IERR( 4 ) = 1 02814 WRITE( ARGOUT1, FMT = '(A)' ) 'ASUM' 02815 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02816 WRITE( NOUT, FMT = 9997 ) ARGOUT1 02817 WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR 02818 END IF 02819 END IF 02820 END IF 02821 * 02822 ELSE IF( NROUT.EQ.8 ) THEN 02823 * 02824 * Test PSAMAX 02825 * 02826 CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX, 02827 $ IERR( 1 ) ) 02828 IOFFX = IX + ( JX - 1 ) * DESCX( M_ ) 02829 IF( PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) ) THEN 02830 ISCLR = ISAMAX( N, X( IOFFX ), INCX ) 02831 IF( N.LT.1 ) THEN 02832 SCLR = ZERO 02833 ELSE IF( ( INCX.EQ.1 ).AND.( DESCX( M_ ).EQ.1 ).AND. 02834 $ ( N.EQ.1 ) ) THEN 02835 ISCLR = JX 02836 SCLR = X( IOFFX ) 02837 ELSE IF( INCX.EQ.DESCX( M_ ) ) THEN 02838 ISCLR = JX + ISCLR - 1 02839 SCLR = X( IX + ( ISCLR - 1 ) * DESCX( M_ ) ) 02840 ELSE 02841 ISCLR = IX + ISCLR - 1 02842 SCLR = X( ISCLR + ( JX - 1 ) * DESCX( M_ ) ) 02843 END IF 02844 * 02845 IF( PSCLR.NE.SCLR ) THEN 02846 IERR( 3 ) = 1 02847 WRITE( ARGIN1, FMT = '(A)' ) 'AMAX' 02848 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02849 WRITE( NOUT, FMT = 9998 ) ARGIN1 02850 WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR 02851 END IF 02852 END IF 02853 * 02854 IF( PISCLR.NE.ISCLR ) THEN 02855 IERR( 5 ) = 1 02856 WRITE( ARGIN2, FMT = '(A)' ) 'INDX' 02857 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02858 WRITE( NOUT, FMT = 9998 ) ARGIN2 02859 WRITE( NOUT, FMT = 9995 ) ISCLR, PISCLR 02860 END IF 02861 END IF 02862 ELSE 02863 ISCLR = 0 02864 SCLR = ZERO 02865 IF( PSCLR.NE.SCLR ) THEN 02866 IERR( 4 ) = 1 02867 WRITE( ARGOUT1, FMT = '(A)' ) 'AMAX' 02868 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02869 WRITE( NOUT, FMT = 9997 ) ARGOUT1 02870 WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR 02871 END IF 02872 END IF 02873 IF( PISCLR.NE.ISCLR ) THEN 02874 IERR( 6 ) = 1 02875 WRITE( ARGOUT2, FMT = '(A)' ) 'INDX' 02876 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 02877 WRITE( NOUT, FMT = 9997 ) ARGOUT2 02878 WRITE( NOUT, FMT = 9995 ) ISCLR, PISCLR 02879 END IF 02880 END IF 02881 END IF 02882 * 02883 END IF 02884 * 02885 * Find IERR across all processes 02886 * 02887 CALL IGAMX2D( ICTXT, 'All', ' ', 6, 1, IERR, 6, IDUMM, IDUMM, -1, 02888 $ -1, 0 ) 02889 * 02890 * Encode the errors found in INFO 02891 * 02892 IF( IERR( 1 ).NE.0 ) THEN 02893 INFO = INFO + 1 02894 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 02895 $ WRITE( NOUT, FMT = 9999 ) 'X' 02896 END IF 02897 * 02898 IF( IERR( 2 ).NE.0 ) THEN 02899 INFO = INFO + 2 02900 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) 02901 $ WRITE( NOUT, FMT = 9999 ) 'Y' 02902 END IF 02903 * 02904 IF( IERR( 3 ).NE.0 ) 02905 $ INFO = INFO + 4 02906 * 02907 IF( IERR( 4 ).NE.0 ) 02908 $ INFO = INFO + 8 02909 * 02910 IF( IERR( 5 ).NE.0 ) 02911 $ INFO = INFO + 16 02912 * 02913 IF( IERR( 6 ).NE.0 ) 02914 $ INFO = INFO + 32 02915 * 02916 9999 FORMAT( 2X, ' ***** ERROR: Vector operand ', A, 02917 $ ' is incorrect.' ) 02918 9998 FORMAT( 2X, ' ***** ERROR: Output scalar result ', A, 02919 $ ' in scope is incorrect.' ) 02920 9997 FORMAT( 2X, ' ***** ERROR: Output scalar result ', A, 02921 $ ' out of scope is incorrect.' ) 02922 9996 FORMAT( 2X, ' ***** Expected value is: ', E16.8, /2X, 02923 $ ' Obtained value is: ', E16.8 ) 02924 9995 FORMAT( 2X, ' ***** Expected value is: ', I6, /2X, 02925 $ ' Obtained value is: ', I6 ) 02926 * 02927 RETURN 02928 * 02929 * End of PSBLAS1TSTCHK 02930 * 02931 END 02932 SUBROUTINE PSERRDOT( ERRBND, N, SCLR, X, INCX, Y, INCY, PREC ) 02933 * 02934 * -- PBLAS test routine (version 2.0) -- 02935 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 02936 * and University of California, Berkeley. 02937 * April 1, 1998 02938 * 02939 * .. Scalar Arguments .. 02940 INTEGER INCX, INCY, N 02941 REAL ERRBND, PREC, SCLR 02942 * .. 02943 * .. Array Arguments .. 02944 REAL X( * ), Y( * ) 02945 * .. 02946 * 02947 * Purpose 02948 * ======= 02949 * 02950 * PSERRDOT serially computes the dot product X**T * Y and returns a 02951 * scaled relative acceptable error bound on the result. 02952 * 02953 * Notes 02954 * ===== 02955 * 02956 * If dot1 = SCLR and dot2 are two different computed results, and dot1 02957 * is being assumed to be correct, we require 02958 * 02959 * abs( dot1 - dot2 ) <= ERRBND = ERRFACT * abs( dot1 ), 02960 * 02961 * where ERRFACT is computed as the maximum of the positive and negative 02962 * partial sums multiplied by a constant proportional to the machine 02963 * precision. 02964 * 02965 * Arguments 02966 * ========= 02967 * 02968 * ERRBND (global output) REAL 02969 * On exit, ERRBND specifies the scaled relative acceptable er- 02970 * ror bound. 02971 * 02972 * N (global input) INTEGER 02973 * On entry, N specifies the length of the vector operands. 02974 * 02975 * SCLR (global output) REAL 02976 * On exit, SCLR specifies the dot product of the two vectors 02977 * X and Y. 02978 * 02979 * X (global input) REAL array 02980 * On entry, X is an array of dimension at least 02981 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen- 02982 * ted array X must contain the vector x. 02983 * 02984 * INCX (global input) INTEGER. 02985 * On entry, INCX specifies the increment for the elements of X. 02986 * INCX must not be zero. 02987 * 02988 * Y (global input) REAL array 02989 * On entry, Y is an array of dimension at least 02990 * ( 1 + ( n - 1 )*abs( INCY ) ). Before entry, the incremen- 02991 * ted array Y must contain the vector y. 02992 * 02993 * INCY (global input) INTEGER. 02994 * On entry, INCY specifies the increment for the elements of Y. 02995 * INCY must not be zero. 02996 * 02997 * PREC (global input) REAL 02998 * On entry, PREC specifies the machine precision. 02999 * 03000 * -- Written on April 1, 1998 by 03001 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03002 * 03003 * ===================================================================== 03004 * 03005 * .. Parameters .. 03006 REAL ONE, TWO, ZERO 03007 PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, 03008 $ ZERO = 0.0E+0 ) 03009 * .. 03010 * .. Local Scalars .. 03011 INTEGER I, IX, IY 03012 REAL ADDBND, FACT, SUMNEG, SUMPOS, TMP 03013 * .. 03014 * .. Intrinsic Functions .. 03015 INTRINSIC ABS, MAX 03016 * .. 03017 * .. Executable Statements .. 03018 * 03019 IX = 1 03020 IY = 1 03021 SCLR = ZERO 03022 SUMPOS = ZERO 03023 SUMNEG = ZERO 03024 FACT = TWO * ( ONE + PREC ) 03025 ADDBND = TWO * TWO * TWO * PREC 03026 * 03027 DO 10 I = 1, N 03028 TMP = X( IX ) * Y( IY ) 03029 SCLR = SCLR + TMP 03030 IF( TMP.GE.ZERO ) THEN 03031 SUMPOS = SUMPOS + TMP * FACT 03032 ELSE 03033 SUMNEG = SUMNEG - TMP * FACT 03034 END IF 03035 IX = IX + INCX 03036 IY = IY + INCY 03037 10 CONTINUE 03038 * 03039 ERRBND = ADDBND * MAX( SUMPOS, SUMNEG ) 03040 * 03041 RETURN 03042 * 03043 * End of PSERRDOT 03044 * 03045 END 03046 SUBROUTINE PSERRNRM2( ERRBND, N, USCLR, X, INCX, PREC ) 03047 * 03048 * -- PBLAS test routine (version 2.0) -- 03049 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03050 * and University of California, Berkeley. 03051 * April 1, 1998 03052 * 03053 * .. Scalar Arguments .. 03054 INTEGER INCX, N 03055 REAL ERRBND, PREC, USCLR 03056 * .. 03057 * .. Array Arguments .. 03058 REAL X( * ) 03059 * .. 03060 * 03061 * Purpose 03062 * ======= 03063 * 03064 * PSERRNRM2 serially computes the 2-norm the vector X and returns a 03065 * scaled relative acceptable error bound on the result. 03066 * 03067 * Notes 03068 * ===== 03069 * 03070 * If norm1 = SCLR and norm2 are two different computed results, and 03071 * norm1 being assumed to be correct, we require 03072 * 03073 * abs( norm1 - norm2 ) <= ERRBND = ERRFACT * abs( norm1 ), 03074 * 03075 * where ERRFACT is computed as the maximum of the positive and negative 03076 * partial sums multiplied by a constant proportional to the machine 03077 * precision. 03078 * 03079 * Arguments 03080 * ========= 03081 * 03082 * ERRBND (global output) REAL 03083 * On exit, ERRBND specifies the scaled relative acceptable er- 03084 * ror bound. 03085 * 03086 * N (global input) INTEGER 03087 * On entry, N specifies the length of the vector operand. 03088 * 03089 * USCLR (global output) REAL 03090 * On exit, USCLR specifies the 2-norm of the vector X. 03091 * 03092 * X (global input) REAL array 03093 * On entry, X is an array of dimension at least 03094 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen- 03095 * ted array X must contain the vector x. 03096 * 03097 * INCX (global input) INTEGER. 03098 * On entry, INCX specifies the increment for the elements of X. 03099 * INCX must not be zero. 03100 * 03101 * PREC (global input) REAL 03102 * On entry, PREC specifies the machine precision. 03103 * 03104 * -- Written on April 1, 1998 by 03105 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03106 * 03107 * ===================================================================== 03108 * 03109 * .. Parameters .. 03110 REAL ONE, TWO, ZERO 03111 PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, 03112 $ ZERO = 0.0E+0 ) 03113 * .. 03114 * .. Local Scalars .. 03115 INTEGER IX 03116 REAL ABSXI, ADDBND, FACT, SCALE, SSQ, SUMSCA, SUMSSQ 03117 * .. 03118 * .. Intrinsic Functions .. 03119 INTRINSIC ABS 03120 * .. 03121 * .. Executable Statements .. 03122 * 03123 USCLR = ZERO 03124 SUMSSQ = ONE 03125 SUMSCA = ZERO 03126 ADDBND = TWO * TWO * TWO * PREC 03127 FACT = ONE + TWO * ( ( ONE + PREC )**3 - ONE ) 03128 * 03129 SCALE = ZERO 03130 SSQ = ONE 03131 DO 10 IX = 1, 1 + ( N - 1 )*INCX, INCX 03132 IF( X( IX ).NE.ZERO ) THEN 03133 ABSXI = ABS( X( IX ) ) 03134 IF( SCALE.LT.ABSXI )THEN 03135 SUMSSQ = ONE + ( SSQ*( SCALE/ABSXI )**2 ) * FACT 03136 ERRBND = ADDBND * SUMSSQ 03137 SUMSSQ = SUMSSQ + ERRBND 03138 SSQ = ONE + SSQ*( SCALE/ABSXI )**2 03139 SUMSCA = ABSXI 03140 SCALE = ABSXI 03141 ELSE 03142 SUMSSQ = SSQ + ( ( ABSXI/SCALE )**2 ) * FACT 03143 ERRBND = ADDBND * SUMSSQ 03144 SUMSSQ = SUMSSQ + ERRBND 03145 SSQ = SSQ + ( ABSXI/SCALE )**2 03146 END IF 03147 END IF 03148 10 CONTINUE 03149 * 03150 USCLR = SCALE * SQRT( SSQ ) 03151 * 03152 * Error on square root 03153 * 03154 ERRBND = SQRT( SUMSSQ ) * ( ONE + TWO * ( 1.00001E+0 * PREC ) ) 03155 * 03156 ERRBND = ( SUMSCA * ERRBND ) - USCLR 03157 * 03158 RETURN 03159 * 03160 * End of PSERRNRM2 03161 * 03162 END 03163 SUBROUTINE PSERRASUM( ERRBND, N, USCLR, X, INCX, PREC ) 03164 * 03165 * -- PBLAS test routine (version 2.0) -- 03166 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03167 * and University of California, Berkeley. 03168 * April 1, 1998 03169 * 03170 * .. Scalar Arguments .. 03171 INTEGER INCX, N 03172 REAL ERRBND, PREC, USCLR 03173 * .. 03174 * .. Array Arguments .. 03175 REAL X( * ) 03176 * .. 03177 * 03178 * Purpose 03179 * ======= 03180 * 03181 * PSERRASUM serially computes the sum of absolute values of the vector 03182 * X and returns a scaled relative acceptable error bound on the result. 03183 * 03184 * Arguments 03185 * ========= 03186 * 03187 * ERRBND (global output) REAL 03188 * On exit, ERRBND specifies a scaled relative acceptable error 03189 * bound. In this case the error bound is just the absolute sum 03190 * multiplied by a constant proportional to the machine preci- 03191 * sion. 03192 * 03193 * N (global input) INTEGER 03194 * On entry, N specifies the length of the vector operand. 03195 * 03196 * USCLR (global output) REAL 03197 * On exit, USCLR specifies the sum of absolute values of the 03198 * vector X. 03199 * 03200 * X (global input) REAL array 03201 * On entry, X is an array of dimension at least 03202 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen- 03203 * ted array X must contain the vector x. 03204 * 03205 * INCX (global input) INTEGER. 03206 * On entry, INCX specifies the increment for the elements of X. 03207 * INCX must not be zero. 03208 * 03209 * PREC (global input) REAL 03210 * On entry, PREC specifies the machine precision. 03211 * 03212 * -- Written on April 1, 1998 by 03213 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03214 * 03215 * ===================================================================== 03216 * 03217 * .. Parameters .. 03218 REAL TWO, ZERO 03219 PARAMETER ( TWO = 2.0E+0, ZERO = 0.0E+0 ) 03220 * .. 03221 * .. Local Scalars .. 03222 INTEGER IX 03223 REAL ADDBND 03224 * .. 03225 * .. Intrinsic Functions .. 03226 INTRINSIC ABS 03227 * .. 03228 * .. Executable Statements .. 03229 * 03230 IX = 1 03231 USCLR = ZERO 03232 ADDBND = TWO * TWO * TWO * PREC 03233 * 03234 DO 10 IX = 1, 1 + ( N - 1 )*INCX, INCX 03235 USCLR = USCLR + ABS( X( IX ) ) 03236 10 CONTINUE 03237 * 03238 ERRBND = ADDBND * USCLR 03239 * 03240 RETURN 03241 * 03242 * End of PSERRASUM 03243 * 03244 END 03245 SUBROUTINE PSERRSCAL( ERRBND, PSCLR, X, PREC ) 03246 * 03247 * -- PBLAS test routine (version 2.0) -- 03248 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03249 * and University of California, Berkeley. 03250 * April 1, 1998 03251 * 03252 * .. Scalar Arguments .. 03253 REAL ERRBND, PREC, PSCLR, X 03254 * .. 03255 * 03256 * Purpose 03257 * ======= 03258 * 03259 * PSERRSCAL serially computes the product PSCLR * X and returns a sca- 03260 * led relative acceptable error bound on the result. 03261 * 03262 * Notes 03263 * ===== 03264 * 03265 * If s1 = PSCLR*X and s2 are two different computed results, and s1 is 03266 * being assumed to be correct, we require 03267 * 03268 * abs( s1 - s2 ) <= ERRBND = ERRFACT * abs( s1 ), 03269 * 03270 * where ERRFACT is computed as two times the machine precision. 03271 * 03272 * Arguments 03273 * ========= 03274 * 03275 * ERRBND (global output) REAL 03276 * On exit, ERRBND specifies the scaled relative acceptable er- 03277 * ror bound. 03278 * 03279 * PSCLR (global input) REAL 03280 * On entry, PSCLR specifies the scale factor. 03281 * 03282 * X (global input/global output) REAL 03283 * On entry, X specifies the scalar to be scaled. On exit, X is 03284 * the scaled entry. 03285 * 03286 * PREC (global input) REAL 03287 * On entry, PREC specifies the machine precision. 03288 * 03289 * -- Written on April 1, 1998 by 03290 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03291 * 03292 * ===================================================================== 03293 * 03294 * .. Parameters .. 03295 REAL TWO 03296 PARAMETER ( TWO = 2.0E+0 ) 03297 * .. 03298 * .. Intrinsic Functions .. 03299 INTRINSIC ABS 03300 * .. 03301 * .. Executable Statements .. 03302 * 03303 X = PSCLR * X 03304 * 03305 ERRBND = ( TWO * PREC ) * ABS( X ) 03306 * 03307 RETURN 03308 * 03309 * End of PSERRSCAL 03310 * 03311 END 03312 SUBROUTINE PSERRAXPY( ERRBND, PSCLR, X, Y, PREC ) 03313 * 03314 * -- PBLAS test routine (version 2.0) -- 03315 * University of Tennessee, Knoxville, Oak Ridge National Laboratory, 03316 * and University of California, Berkeley. 03317 * April 1, 1998 03318 * 03319 * .. Scalar Arguments .. 03320 REAL ERRBND, PREC, PSCLR, X, Y 03321 * .. 03322 * 03323 * Purpose 03324 * ======= 03325 * 03326 * PSERRAXPY serially computes Y := Y + PSCLR * X and returns a scaled 03327 * relative acceptable error bound on the result. 03328 * 03329 * Arguments 03330 * ========= 03331 * 03332 * ERRBND (global output) REAL 03333 * On exit, ERRBND specifies the scaled relative acceptable er- 03334 * ror bound. 03335 * 03336 * PSCLR (global input) REAL 03337 * On entry, PSCLR specifies the scale factor. 03338 * 03339 * X (global input) REAL 03340 * On entry, X specifies the scalar to be scaled. 03341 * 03342 * Y (global input/global output) REAL 03343 * On entry, Y specifies the scalar to be added. On exit, Y con- 03344 * tains the resulting scalar. 03345 * 03346 * PREC (global input) REAL 03347 * On entry, PREC specifies the machine precision. 03348 * 03349 * -- Written on April 1, 1998 by 03350 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA. 03351 * 03352 * ===================================================================== 03353 * 03354 * .. Parameters .. 03355 REAL ONE, TWO, ZERO 03356 PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, 03357 $ ZERO = 0.0E+0 ) 03358 * .. 03359 * .. Local Scalars .. 03360 REAL ADDBND, FACT, SUMPOS, SUMNEG, TMP 03361 * .. 03362 * .. Intrinsic Functions .. 03363 INTRINSIC MAX 03364 * .. 03365 * .. Executable Statements .. 03366 * 03367 SUMPOS = ZERO 03368 SUMNEG = ZERO 03369 FACT = ONE + TWO * PREC 03370 ADDBND = TWO * TWO * TWO * PREC 03371 * 03372 TMP = PSCLR * X 03373 IF( TMP.GE.ZERO ) THEN 03374 SUMPOS = SUMPOS + TMP * FACT 03375 ELSE 03376 SUMNEG = SUMNEG - TMP * FACT 03377 END IF 03378 * 03379 TMP = Y 03380 IF( TMP.GE.ZERO ) THEN 03381 SUMPOS = SUMPOS + TMP 03382 ELSE 03383 SUMNEG = SUMNEG - TMP 03384 END IF 03385 * 03386 Y = Y + ( PSCLR * X ) 03387 * 03388 ERRBND = ADDBND * MAX( SUMPOS, SUMNEG ) 03389 * 03390 RETURN 03391 * 03392 * End of PSERRAXPY 03393 * 03394 END
