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