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