OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pdblas2tst.f File Reference

Go to the source code of this file.

Functions/Subroutines

program pdbla2tst
subroutine pdbla2tstinfo (summry, nout, nmat, diagval, tranval, uploval, mval, nval, maval, naval, imbaval, mbaval, inbaval, nbaval, rscaval, cscaval, iaval, javal, mxval, nxval, imbxval, mbxval, inbxval, nbxval, rscxval, cscxval, ixval, jxval, incxval, myval, nyval, imbyval, mbyval, inbyval, nbyval, rscyval, cscyval, iyval, jyval, incyval, ldval, ngrids, pval, ldpval, qval, ldqval, nblog, ltest, sof, tee, iam, igap, iverb, nprocs, thresh, alpha, beta, work)
subroutine pdblas2tstchke (ltest, inout, nprocs)
subroutine pdchkarg2 (ictxt, nout, sname, uplo, trans, diag, m, n, alpha, ia, ja, desca, ix, jx, descx, incx, beta, iy, jy, descy, incy, info)
subroutine pdblas2tstchk (ictxt, nout, nrout, uplo, trans, diag, m, n, alpha, a, pa, ia, ja, desca, x, px, ix, jx, descx, incx, beta, y, py, iy, jy, descy, incy, thresh, rogue, work, info)

Function/Subroutine Documentation

◆ pdbla2tst()

program pdbla2tst

Definition at line 11 of file pdblas2tst.f.

◆ pdbla2tstinfo()

subroutine pdbla2tstinfo ( character*( * ) summry,
integer nout,
integer nmat,
character*1, dimension( ldval ) diagval,
character*1, dimension( ldval ) tranval,
character*1, dimension( ldval ) uploval,
integer, dimension( ldval ) mval,
integer, dimension( ldval ) nval,
integer, dimension( ldval ) maval,
integer, dimension( ldval ) naval,
integer, dimension( ldval ) imbaval,
integer, dimension( ldval ) mbaval,
integer, dimension( ldval ) inbaval,
integer, dimension( ldval ) nbaval,
integer, dimension( ldval ) rscaval,
integer, dimension( ldval ) cscaval,
integer, dimension( ldval ) iaval,
integer, dimension( ldval ) javal,
integer, dimension( ldval ) mxval,
integer, dimension( ldval ) nxval,
integer, dimension( ldval ) imbxval,
integer, dimension( ldval ) mbxval,
integer, dimension( ldval ) inbxval,
integer, dimension( ldval ) nbxval,
integer, dimension( ldval ) rscxval,
integer, dimension( ldval ) cscxval,
integer, dimension( ldval ) ixval,
integer, dimension( ldval ) jxval,
integer, dimension( ldval ) incxval,
integer, dimension( ldval ) myval,
integer, dimension( ldval ) nyval,
integer, dimension( ldval ) imbyval,
integer, dimension( ldval ) mbyval,
integer, dimension( ldval ) inbyval,
integer, dimension( ldval ) nbyval,
integer, dimension( ldval ) rscyval,
integer, dimension( ldval ) cscyval,
integer, dimension( ldval ) iyval,
integer, dimension( ldval ) jyval,
integer, dimension( ldval ) incyval,
integer ldval,
integer ngrids,
integer, dimension( ldpval ) pval,
integer ldpval,
integer, dimension( ldqval ) qval,
integer ldqval,
integer nblog,
logical, dimension( * ) ltest,
logical sof,
logical tee,
integer iam,
integer igap,
integer iverb,
integer nprocs,
real thresh,
double precision alpha,
double precision beta,
integer, dimension( * ) work )

Definition at line 1108 of file pdblas2tst.f.

1121*
1122* -- PBLAS test routine (version 2.0) --
1123* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1124* and University of California, Berkeley.
1125* April 1, 1998
1126*
1127* .. Scalar Arguments ..
1128 LOGICAL SOF, TEE
1129 INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL, NBLOG,
1130 $ NGRIDS, NMAT, NOUT, NPROCS
1131 REAL THRESH
1132 DOUBLE PRECISION ALPHA, BETA
1133* ..
1134* .. Array Arguments ..
1135 CHARACTER*( * ) SUMMRY
1136 CHARACTER*1 DIAGVAL( LDVAL ), TRANVAL( LDVAL ),
1137 $ UPLOVAL( LDVAL )
1138 LOGICAL LTEST( * )
1139 INTEGER CSCAVAL( LDVAL ), CSCXVAL( LDVAL ),
1140 $ CSCYVAL( LDVAL ), IAVAL( LDVAL ),
1141 $ IMBAVAL( LDVAL ), IMBXVAL( LDVAL ),
1142 $ IMBYVAL( LDVAL ), INBAVAL( LDVAL ),
1143 $ INBXVAL( LDVAL ), INBYVAL( LDVAL ),
1144 $ INCXVAL( LDVAL ), INCYVAL( LDVAL ),
1145 $ IXVAL( LDVAL ), IYVAL( LDVAL ), JAVAL( LDVAL ),
1146 $ JXVAL( LDVAL ), JYVAL( LDVAL ), MAVAL( LDVAL ),
1147 $ MBAVAL( LDVAL ), MBXVAL( LDVAL ),
1148 $ MBYVAL( LDVAL ), MVAL( LDVAL ), MXVAL( LDVAL ),
1149 $ MYVAL( LDVAL ), NAVAL( LDVAL ),
1150 $ NBAVAL( LDVAL ), NBXVAL( LDVAL ),
1151 $ NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ),
1152 $ NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ),
1153 $ RSCAVAL( LDVAL ), RSCXVAL( LDVAL ),
1154 $ RSCYVAL( LDVAL ), WORK( * )
1155* ..
1156*
1157* Purpose
1158* =======
1159*
1160* PDBLA2TSTINFO get the needed startup information for testing various
1161* Level 2 PBLAS routines, and transmits it to all processes.
1162*
1163* Notes
1164* =====
1165*
1166* For packing the information we assumed that the length in bytes of an
1167* integer is equal to the length in bytes of a real single precision.
1168*
1169* Arguments
1170* =========
1171*
1172* SUMMRY (global output) CHARACTER*(*)
1173* On exit, SUMMRY is the name of output (summary) file (if
1174* any). SUMMRY is only defined for process 0.
1175*
1176* NOUT (global output) INTEGER
1177* On exit, NOUT specifies the unit number for the output file.
1178* When NOUT is 6, output to screen, when NOUT is 0, output to
1179* stderr. NOUT is only defined for process 0.
1180*
1181* NMAT (global output) INTEGER
1182* On exit, NMAT specifies the number of different test cases.
1183*
1184* DIAGVAL (global output) CHARACTER array
1185* On entry, DIAGVAL is an array of dimension LDVAL. On exit,
1186* this array contains the values of DIAG to run the code with.
1187*
1188* TRANVAL (global output) CHARACTER array
1189* On entry, TRANVAL is an array of dimension LDVAL. On exit,
1190* this array contains the values of TRANS to run the code
1191* with.
1192*
1193* UPLOVAL (global output) CHARACTER array
1194* On entry, UPLOVAL is an array of dimension LDVAL. On exit,
1195* this array contains the values of UPLO to run the code with.
1196*
1197* MVAL (global output) INTEGER array
1198* On entry, MVAL is an array of dimension LDVAL. On exit, this
1199* array contains the values of M to run the code with.
1200*
1201* NVAL (global output) INTEGER array
1202* On entry, NVAL is an array of dimension LDVAL. On exit, this
1203* array contains the values of N to run the code with.
1204*
1205* MAVAL (global output) INTEGER array
1206* On entry, MAVAL is an array of dimension LDVAL. On exit, this
1207* array contains the values of DESCA( M_ ) to run the code
1208* with.
1209*
1210* NAVAL (global output) INTEGER array
1211* On entry, NAVAL is an array of dimension LDVAL. On exit, this
1212* array contains the values of DESCA( N_ ) to run the code
1213* with.
1214*
1215* IMBAVAL (global output) INTEGER array
1216* On entry, IMBAVAL is an array of dimension LDVAL. On exit,
1217* this array contains the values of DESCA( IMB_ ) to run the
1218* code with.
1219*
1220* MBAVAL (global output) INTEGER array
1221* On entry, MBAVAL is an array of dimension LDVAL. On exit,
1222* this array contains the values of DESCA( MB_ ) to run the
1223* code with.
1224*
1225* INBAVAL (global output) INTEGER array
1226* On entry, INBAVAL is an array of dimension LDVAL. On exit,
1227* this array contains the values of DESCA( INB_ ) to run the
1228* code with.
1229*
1230* NBAVAL (global output) INTEGER array
1231* On entry, NBAVAL is an array of dimension LDVAL. On exit,
1232* this array contains the values of DESCA( NB_ ) to run the
1233* code with.
1234*
1235* RSCAVAL (global output) INTEGER array
1236* On entry, RSCAVAL is an array of dimension LDVAL. On exit,
1237* this array contains the values of DESCA( RSRC_ ) to run the
1238* code with.
1239*
1240* CSCAVAL (global output) INTEGER array
1241* On entry, CSCAVAL is an array of dimension LDVAL. On exit,
1242* this array contains the values of DESCA( CSRC_ ) to run the
1243* code with.
1244*
1245* IAVAL (global output) INTEGER array
1246* On entry, IAVAL is an array of dimension LDVAL. On exit, this
1247* array contains the values of IA to run the code with.
1248*
1249* JAVAL (global output) INTEGER array
1250* On entry, JAVAL is an array of dimension LDVAL. On exit, this
1251* array contains the values of JA to run the code with.
1252*
1253* MXVAL (global output) INTEGER array
1254* On entry, MXVAL is an array of dimension LDVAL. On exit, this
1255* array contains the values of DESCX( M_ ) to run the code
1256* with.
1257*
1258* NXVAL (global output) INTEGER array
1259* On entry, NXVAL is an array of dimension LDVAL. On exit, this
1260* array contains the values of DESCX( N_ ) to run the code
1261* with.
1262*
1263* IMBXVAL (global output) INTEGER array
1264* On entry, IMBXVAL is an array of dimension LDVAL. On exit,
1265* this array contains the values of DESCX( IMB_ ) to run the
1266* code with.
1267*
1268* MBXVAL (global output) INTEGER array
1269* On entry, MBXVAL is an array of dimension LDVAL. On exit,
1270* this array contains the values of DESCX( MB_ ) to run the
1271* code with.
1272*
1273* INBXVAL (global output) INTEGER array
1274* On entry, INBXVAL is an array of dimension LDVAL. On exit,
1275* this array contains the values of DESCX( INB_ ) to run the
1276* code with.
1277*
1278* NBXVAL (global output) INTEGER array
1279* On entry, NBXVAL is an array of dimension LDVAL. On exit,
1280* this array contains the values of DESCX( NB_ ) to run the
1281* code with.
1282*
1283* RSCXVAL (global output) INTEGER array
1284* On entry, RSCXVAL is an array of dimension LDVAL. On exit,
1285* this array contains the values of DESCX( RSRC_ ) to run the
1286* code with.
1287*
1288* CSCXVAL (global output) INTEGER array
1289* On entry, CSCXVAL is an array of dimension LDVAL. On exit,
1290* this array contains the values of DESCX( CSRC_ ) to run the
1291* code with.
1292*
1293* IXVAL (global output) INTEGER array
1294* On entry, IXVAL is an array of dimension LDVAL. On exit, this
1295* array contains the values of IX to run the code with.
1296*
1297* JXVAL (global output) INTEGER array
1298* On entry, JXVAL is an array of dimension LDVAL. On exit, this
1299* array contains the values of JX to run the code with.
1300*
1301* INCXVAL (global output) INTEGER array
1302* On entry, INCXVAL is an array of dimension LDVAL. On exit,
1303* this array contains the values of INCX to run the code with.
1304*
1305* MYVAL (global output) INTEGER array
1306* On entry, MYVAL is an array of dimension LDVAL. On exit, this
1307* array contains the values of DESCY( M_ ) to run the code
1308* with.
1309*
1310* NYVAL (global output) INTEGER array
1311* On entry, NYVAL is an array of dimension LDVAL. On exit, this
1312* array contains the values of DESCY( N_ ) to run the code
1313* with.
1314*
1315* IMBYVAL (global output) INTEGER array
1316* On entry, IMBYVAL is an array of dimension LDVAL. On exit,
1317* this array contains the values of DESCY( IMB_ ) to run the
1318* code with.
1319*
1320* MBYVAL (global output) INTEGER array
1321* On entry, MBYVAL is an array of dimension LDVAL. On exit,
1322* this array contains the values of DESCY( MB_ ) to run the
1323* code with.
1324*
1325* INBYVAL (global output) INTEGER array
1326* On entry, INBYVAL is an array of dimension LDVAL. On exit,
1327* this array contains the values of DESCY( INB_ ) to run the
1328* code with.
1329*
1330* NBYVAL (global output) INTEGER array
1331* On entry, NBYVAL is an array of dimension LDVAL. On exit,
1332* this array contains the values of DESCY( NB_ ) to run the
1333* code with.
1334*
1335* RSCYVAL (global output) INTEGER array
1336* On entry, RSCYVAL is an array of dimension LDVAL. On exit,
1337* this array contains the values of DESCY( RSRC_ ) to run the
1338* code with.
1339*
1340* CSCYVAL (global output) INTEGER array
1341* On entry, CSCYVAL is an array of dimension LDVAL. On exit,
1342* this array contains the values of DESCY( CSRC_ ) to run the
1343* code with.
1344*
1345* IYVAL (global output) INTEGER array
1346* On entry, IYVAL is an array of dimension LDVAL. On exit, this
1347* array contains the values of IY to run the code with.
1348*
1349* JYVAL (global output) INTEGER array
1350* On entry, JYVAL is an array of dimension LDVAL. On exit, this
1351* array contains the values of JY to run the code with.
1352*
1353* INCYVAL (global output) INTEGER array
1354* On entry, INCYVAL is an array of dimension LDVAL. On exit,
1355* this array contains the values of INCY to run the code with.
1356*
1357* LDVAL (global input) INTEGER
1358* On entry, LDVAL specifies the maximum number of different va-
1359* lues that can be used for DIAG, TRANS, UPLO, M, N, DESCA(:),
1360* IA, JA, DESCX(:), IX, JX, INCX, DESCY(:), IY, JY and INCY.
1361* This is also the maximum number of test cases.
1362*
1363* NGRIDS (global output) INTEGER
1364* On exit, NGRIDS specifies the number of different values that
1365* can be used for P and Q.
1366*
1367* PVAL (global output) INTEGER array
1368* On entry, PVAL is an array of dimension LDPVAL. On exit, this
1369* array contains the values of P to run the code with.
1370*
1371* LDPVAL (global input) INTEGER
1372* On entry, LDPVAL specifies the maximum number of different
1373* values that can be used for P.
1374*
1375* QVAL (global output) INTEGER array
1376* On entry, QVAL is an array of dimension LDQVAL. On exit, this
1377* array contains the values of Q to run the code with.
1378*
1379* LDQVAL (global input) INTEGER
1380* On entry, LDQVAL specifies the maximum number of different
1381* values that can be used for Q.
1382*
1383* NBLOG (global output) INTEGER
1384* On exit, NBLOG specifies the logical computational block size
1385* to run the tests with. NBLOG must be at least one.
1386*
1387* LTEST (global output) LOGICAL array
1388* On entry, LTEST is an array of dimension at least seven. On
1389* exit, if LTEST( i ) is .TRUE., the i-th Level 2 PBLAS routine
1390* will be tested. See the input file for the ordering of the
1391* routines.
1392*
1393* SOF (global output) LOGICAL
1394* On exit, if SOF is .TRUE., the tester will stop on the first
1395* detected failure. Otherwise, it won't.
1396*
1397* TEE (global output) LOGICAL
1398* On exit, if TEE is .TRUE., the tester will perform the error
1399* exit tests. These tests won't be performed otherwise.
1400*
1401* IAM (local input) INTEGER
1402* On entry, IAM specifies the number of the process executing
1403* this routine.
1404*
1405* IGAP (global output) INTEGER
1406* On exit, IGAP specifies the user-specified gap used for pad-
1407* ding. IGAP must be at least zero.
1408*
1409* IVERB (global output) INTEGER
1410* On exit, IVERB specifies the output verbosity level: 0 for
1411* pass/fail, 1, 2 or 3 for matrix dump on errors.
1412*
1413* NPROCS (global input) INTEGER
1414* On entry, NPROCS specifies the total number of processes.
1415*
1416* THRESH (global output) REAL
1417* On exit, THRESH specifies the threshhold value for the test
1418* ratio.
1419*
1420* ALPHA (global output) DOUBLE PRECISION
1421* On exit, ALPHA specifies the value of alpha to be used in all
1422* the test cases.
1423*
1424* BETA (global output) DOUBLE PRECISION
1425* On exit, BETA specifies the value of beta to be used in all
1426* the test cases.
1427*
1428* WORK (local workspace) INTEGER array
1429* On entry, WORK is an array of dimension at least
1430* MAX( 3, 2*NGRIDS+37*NMAT+NSUBS+4 ) with NSUBS equal to 7.
1431* This array is used to pack all output arrays in order to send
1432* the information in one message.
1433*
1434* -- Written on April 1, 1998 by
1435* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1436*
1437* =====================================================================
1438*
1439* .. Parameters ..
1440 INTEGER NIN, NSUBS
1441 parameter( nin = 11, nsubs = 7 )
1442* ..
1443* .. Local Scalars ..
1444 LOGICAL LTESTT
1445 INTEGER I, ICTXT, J
1446 DOUBLE PRECISION EPS
1447* ..
1448* .. Local Arrays ..
1449 CHARACTER*7 SNAMET
1450 CHARACTER*79 USRINFO
1451* ..
1452* .. External Subroutines ..
1453 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1454 $ blacs_gridinit, blacs_setup, dgebr2d, dgebs2d,
1455 $ icopy, igebr2d, igebs2d, sgebr2d, sgebs2d
1456*ype real dble cplx zplx
1457* ..
1458* .. External Functions ..
1459 DOUBLE PRECISION PDLAMCH
1460 EXTERNAL pdlamch
1461* ..
1462* .. Intrinsic Functions ..
1463 INTRINSIC char, ichar, max, min
1464* ..
1465* .. Common Blocks ..
1466 CHARACTER*7 SNAMES( NSUBS )
1467 COMMON /snamec/snames
1468* ..
1469* .. Executable Statements ..
1470*
1471* Process 0 reads the input data, broadcasts to other processes and
1472* writes needed information to NOUT
1473*
1474 IF( iam.EQ.0 ) THEN
1475*
1476* Open file and skip data file header
1477*
1478 OPEN( nin, file='PDBLAS2TST.dat', status='OLD' )
1479 READ( nin, fmt = * ) summry
1480 summry = ' '
1481*
1482* Read in user-supplied info about machine type, compiler, etc.
1483*
1484 READ( nin, fmt = 9999 ) usrinfo
1485*
1486* Read name and unit number for summary output file
1487*
1488 READ( nin, fmt = * ) summry
1489 READ( nin, fmt = * ) nout
1490 IF( nout.NE.0 .AND. nout.NE.6 )
1491 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1492*
1493* Read and check the parameter values for the tests.
1494*
1495* Read the flag that indicates if Stop on Failure
1496*
1497 READ( nin, fmt = * ) sof
1498*
1499* Read the flag that indicates if Test Error Exits
1500*
1501 READ( nin, fmt = * ) tee
1502*
1503* Read the verbosity level
1504*
1505 READ( nin, fmt = * ) iverb
1506 IF( iverb.LT.0 .OR. iverb.GT.3 )
1507 $ iverb = 0
1508*
1509* Read the leading dimension gap
1510*
1511 READ( nin, fmt = * ) igap
1512 IF( igap.LT.0 )
1513 $ igap = 0
1514*
1515* Read the threshold value for test ratio
1516*
1517 READ( nin, fmt = * ) thresh
1518 IF( thresh.LT.0.0 )
1519 $ thresh = 16.0
1520*
1521* Get logical computational block size
1522*
1523 READ( nin, fmt = * ) nblog
1524 IF( nblog.LT.1 )
1525 $ nblog = 32
1526*
1527* Get number of grids
1528*
1529 READ( nin, fmt = * ) ngrids
1530 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1531 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1532 GO TO 120
1533 ELSE IF( ngrids.GT.ldqval ) THEN
1534 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1535 GO TO 120
1536 END IF
1537*
1538* Get values of P and Q
1539*
1540 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1541 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1542*
1543* Read ALPHA, BETA
1544*
1545 READ( nin, fmt = * ) alpha
1546 READ( nin, fmt = * ) beta
1547*
1548* Read number of tests.
1549*
1550 READ( nin, fmt = * ) nmat
1551 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1552 WRITE( nout, fmt = 9998 ) 'Tests', ldval
1553 GO TO 120
1554 ENDIF
1555*
1556* Read in input data into arrays.
1557*
1558 READ( nin, fmt = * ) ( uploval( i ), i = 1, nmat )
1559 READ( nin, fmt = * ) ( tranval( i ), i = 1, nmat )
1560 READ( nin, fmt = * ) ( diagval( i ), i = 1, nmat )
1561 READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
1562 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1563 READ( nin, fmt = * ) ( maval( i ), i = 1, nmat )
1564 READ( nin, fmt = * ) ( naval( i ), i = 1, nmat )
1565 READ( nin, fmt = * ) ( imbaval( i ), i = 1, nmat )
1566 READ( nin, fmt = * ) ( inbaval( i ), i = 1, nmat )
1567 READ( nin, fmt = * ) ( mbaval( i ), i = 1, nmat )
1568 READ( nin, fmt = * ) ( nbaval( i ), i = 1, nmat )
1569 READ( nin, fmt = * ) ( rscaval( i ), i = 1, nmat )
1570 READ( nin, fmt = * ) ( cscaval( i ), i = 1, nmat )
1571 READ( nin, fmt = * ) ( iaval( i ), i = 1, nmat )
1572 READ( nin, fmt = * ) ( javal( i ), i = 1, nmat )
1573 READ( nin, fmt = * ) ( mxval( i ), i = 1, nmat )
1574 READ( nin, fmt = * ) ( nxval( i ), i = 1, nmat )
1575 READ( nin, fmt = * ) ( imbxval( i ), i = 1, nmat )
1576 READ( nin, fmt = * ) ( inbxval( i ), i = 1, nmat )
1577 READ( nin, fmt = * ) ( mbxval( i ), i = 1, nmat )
1578 READ( nin, fmt = * ) ( nbxval( i ), i = 1, nmat )
1579 READ( nin, fmt = * ) ( rscxval( i ), i = 1, nmat )
1580 READ( nin, fmt = * ) ( cscxval( i ), i = 1, nmat )
1581 READ( nin, fmt = * ) ( ixval( i ), i = 1, nmat )
1582 READ( nin, fmt = * ) ( jxval( i ), i = 1, nmat )
1583 READ( nin, fmt = * ) ( incxval( i ), i = 1, nmat )
1584 READ( nin, fmt = * ) ( myval( i ), i = 1, nmat )
1585 READ( nin, fmt = * ) ( nyval( i ), i = 1, nmat )
1586 READ( nin, fmt = * ) ( imbyval( i ), i = 1, nmat )
1587 READ( nin, fmt = * ) ( inbyval( i ), i = 1, nmat )
1588 READ( nin, fmt = * ) ( mbyval( i ), i = 1, nmat )
1589 READ( nin, fmt = * ) ( nbyval( i ), i = 1, nmat )
1590 READ( nin, fmt = * ) ( rscyval( i ), i = 1, nmat )
1591 READ( nin, fmt = * ) ( cscyval( i ), i = 1, nmat )
1592 READ( nin, fmt = * ) ( iyval( i ), i = 1, nmat )
1593 READ( nin, fmt = * ) ( jyval( i ), i = 1, nmat )
1594 READ( nin, fmt = * ) ( incyval( i ), i = 1, nmat )
1595*
1596* Read names of subroutines and flags which indicate
1597* whether they are to be tested.
1598*
1599 DO 10 i = 1, nsubs
1600 ltest( i ) = .false.
1601 10 CONTINUE
1602 20 CONTINUE
1603 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1604 DO 30 i = 1, nsubs
1605 IF( snamet.EQ.snames( i ) )
1606 $ GO TO 40
1607 30 CONTINUE
1608*
1609 WRITE( nout, fmt = 9995 )snamet
1610 GO TO 120
1611*
1612 40 CONTINUE
1613 ltest( i ) = ltestt
1614 GO TO 20
1615*
1616 50 CONTINUE
1617*
1618* Close input file
1619*
1620 CLOSE ( nin )
1621*
1622* For pvm only: if virtual machine not set up, allocate it and
1623* spawn the correct number of processes.
1624*
1625 IF( nprocs.LT.1 ) THEN
1626 nprocs = 0
1627 DO 60 i = 1, ngrids
1628 nprocs = max( nprocs, pval( i )*qval( i ) )
1629 60 CONTINUE
1630 CALL blacs_setup( iam, nprocs )
1631 END IF
1632*
1633* Temporarily define blacs grid to include all processes so
1634* information can be broadcast to all processes
1635*
1636 CALL blacs_get( -1, 0, ictxt )
1637 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1638*
1639* Compute machine epsilon
1640*
1641 eps = pdlamch( ictxt, 'eps' )
1642*
1643* Pack information arrays and broadcast
1644*
1645 CALL sgebs2d( ictxt, 'all', ' ', 1, 1, THRESH, 1 )
1646 CALL DGEBS2D( ICTXT, 'all', ' ', 1, 1, ALPHA, 1 )
1647 CALL DGEBS2D( ICTXT, 'all', ' ', 1, 1, BETA, 1 )
1648*
1649 WORK( 1 ) = NGRIDS
1650 WORK( 2 ) = NMAT
1651 WORK( 3 ) = NBLOG
1652 CALL IGEBS2D( ICTXT, 'all', ' ', 3, 1, WORK, 3 )
1653*
1654 I = 1
1655 IF( SOF ) THEN
1656 WORK( I ) = 1
1657 ELSE
1658 WORK( I ) = 0
1659 END IF
1660 I = I + 1
1661 IF( TEE ) THEN
1662 WORK( I ) = 1
1663 ELSE
1664 WORK( I ) = 0
1665 END IF
1666 I = I + 1
1667 WORK( I ) = IVERB
1668 I = I + 1
1669 WORK( I ) = IGAP
1670 I = I + 1
1671 DO 70 J = 1, NMAT
1672 WORK( I ) = ICHAR( DIAGVAL( J ) )
1673 WORK( I+1 ) = ICHAR( TRANVAL( J ) )
1674 WORK( I+2 ) = ICHAR( UPLOVAL( J ) )
1675 I = I + 3
1676 70 CONTINUE
1677 CALL ICOPY( NGRIDS, PVAL, 1, WORK( I ), 1 )
1678 I = I + NGRIDS
1679 CALL ICOPY( NGRIDS, QVAL, 1, WORK( I ), 1 )
1680 I = I + NGRIDS
1681 CALL ICOPY( NMAT, MVAL, 1, WORK( I ), 1 )
1682 I = I + NMAT
1683 CALL ICOPY( NMAT, NVAL, 1, WORK( I ), 1 )
1684 I = I + NMAT
1685 CALL ICOPY( NMAT, MAVAL, 1, WORK( I ), 1 )
1686 I = I + NMAT
1687 CALL ICOPY( NMAT, NAVAL, 1, WORK( I ), 1 )
1688 I = I + NMAT
1689 CALL ICOPY( NMAT, IMBAVAL, 1, WORK( I ), 1 )
1690 I = I + NMAT
1691 CALL ICOPY( NMAT, INBAVAL, 1, WORK( I ), 1 )
1692 I = I + NMAT
1693 CALL ICOPY( NMAT, MBAVAL, 1, WORK( I ), 1 )
1694 I = I + NMAT
1695 CALL ICOPY( NMAT, NBAVAL, 1, WORK( I ), 1 )
1696 I = I + NMAT
1697 CALL ICOPY( NMAT, RSCAVAL, 1, WORK( I ), 1 )
1698 I = I + NMAT
1699 CALL ICOPY( NMAT, CSCAVAL, 1, WORK( I ), 1 )
1700 I = I + NMAT
1701 CALL ICOPY( NMAT, IAVAL, 1, WORK( I ), 1 )
1702 I = I + NMAT
1703 CALL ICOPY( NMAT, JAVAL, 1, WORK( I ), 1 )
1704 I = I + NMAT
1705 CALL ICOPY( NMAT, MXVAL, 1, WORK( I ), 1 )
1706 I = I + NMAT
1707 CALL ICOPY( NMAT, NXVAL, 1, WORK( I ), 1 )
1708 I = I + NMAT
1709 CALL ICOPY( NMAT, IMBXVAL, 1, WORK( I ), 1 )
1710 I = I + NMAT
1711 CALL ICOPY( NMAT, INBXVAL, 1, WORK( I ), 1 )
1712 I = I + NMAT
1713 CALL ICOPY( NMAT, MBXVAL, 1, WORK( I ), 1 )
1714 I = I + NMAT
1715 CALL ICOPY( NMAT, NBXVAL, 1, WORK( I ), 1 )
1716 I = I + NMAT
1717 CALL ICOPY( NMAT, RSCXVAL, 1, WORK( I ), 1 )
1718 I = I + NMAT
1719 CALL ICOPY( NMAT, CSCXVAL, 1, WORK( I ), 1 )
1720 I = I + NMAT
1721 CALL ICOPY( NMAT, IXVAL, 1, WORK( I ), 1 )
1722 I = I + NMAT
1723 CALL ICOPY( NMAT, JXVAL, 1, WORK( I ), 1 )
1724 I = I + NMAT
1725 CALL ICOPY( NMAT, INCXVAL, 1, WORK( I ), 1 )
1726 I = I + NMAT
1727 CALL ICOPY( NMAT, MYVAL, 1, WORK( I ), 1 )
1728 I = I + NMAT
1729 CALL ICOPY( NMAT, NYVAL, 1, WORK( I ), 1 )
1730 I = I + NMAT
1731 CALL ICOPY( NMAT, IMBYVAL, 1, WORK( I ), 1 )
1732 I = I + NMAT
1733 CALL ICOPY( NMAT, INBYVAL, 1, WORK( I ), 1 )
1734 I = I + NMAT
1735 CALL ICOPY( NMAT, MBYVAL, 1, WORK( I ), 1 )
1736 I = I + NMAT
1737 CALL ICOPY( NMAT, NBYVAL, 1, WORK( I ), 1 )
1738 I = I + NMAT
1739 CALL ICOPY( NMAT, RSCYVAL, 1, WORK( I ), 1 )
1740 I = I + NMAT
1741 CALL ICOPY( NMAT, CSCYVAL, 1, WORK( I ), 1 )
1742 I = I + NMAT
1743 CALL ICOPY( NMAT, IYVAL, 1, WORK( I ), 1 )
1744 I = I + NMAT
1745 CALL ICOPY( NMAT, JYVAL, 1, WORK( I ), 1 )
1746 I = I + NMAT
1747 CALL ICOPY( NMAT, INCYVAL, 1, WORK( I ), 1 )
1748 I = I + NMAT
1749*
1750 DO 80 J = 1, NSUBS
1751 IF( LTEST( J ) ) THEN
1752 WORK( I ) = 1
1753 ELSE
1754 WORK( I ) = 0
1755 END IF
1756 I = I + 1
1757 80 CONTINUE
1758 I = I - 1
1759 CALL IGEBS2D( ICTXT, 'all', ' ', I, 1, WORK, I )
1760*
1761* regurgitate input
1762*
1763 WRITE( NOUT, FMT = 9999 ) 'level 2 pblas testing program.'
1764 WRITE( NOUT, FMT = 9999 ) USRINFO
1765 WRITE( NOUT, FMT = * )
1766 WRITE( NOUT, FMT = 9999 )
1767 $ 'tests of the real double precision '//
1768 $ 'Level 2 PBLAS'
1769 WRITE( NOUT, FMT = * )
1770 WRITE( NOUT, FMT = 9993 ) NMAT
1771 WRITE( NOUT, FMT = 9979 ) NBLOG
1772 WRITE( NOUT, FMT = 9992 ) NGRIDS
1773 WRITE( NOUT, FMT = 9990 )
1774 $ 'P', ( PVAL(I), I = 1, MIN(NGRIDS, 5) )
1775.GT. IF( NGRIDS5 )
1776 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 6,
1777 $ MIN( 10, NGRIDS ) )
1778.GT. IF( NGRIDS10 )
1779 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 11,
1780 $ MIN( 15, NGRIDS ) )
1781.GT. IF( NGRIDS15 )
1782 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 16, NGRIDS )
1783 WRITE( NOUT, FMT = 9990 )
1784 $ 'Q', ( QVAL(I), I = 1, MIN(NGRIDS, 5) )
1785.GT. IF( NGRIDS5 )
1786 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 6,
1787 $ MIN( 10, NGRIDS ) )
1788.GT. IF( NGRIDS10 )
1789 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 11,
1790 $ MIN( 15, NGRIDS ) )
1791.GT. IF( NGRIDS15 )
1792 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 16, NGRIDS )
1793 WRITE( NOUT, FMT = 9988 ) SOF
1794 WRITE( NOUT, FMT = 9987 ) TEE
1795 WRITE( NOUT, FMT = 9983 ) IGAP
1796 WRITE( NOUT, FMT = 9986 ) IVERB
1797 WRITE( NOUT, FMT = 9980 ) THRESH
1798 WRITE( NOUT, FMT = 9982 ) ALPHA
1799 WRITE( NOUT, FMT = 9981 ) BETA
1800 IF( LTEST( 1 ) ) THEN
1801 WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... Yes'
1802 ELSE
1803 WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... No '
1804 END IF
1805 DO 90 I = 2, NSUBS
1806 IF( LTEST( I ) ) THEN
1807 WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... Yes'
1808 ELSE
1809 WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... No '
1810 END IF
1811 90 CONTINUE
1812 WRITE( NOUT, FMT = 9994 ) EPS
1813 WRITE( NOUT, FMT = * )
1814*
1815 ELSE
1816*
1817* If in pvm, must participate setting up virtual machine
1818*
1819.LT. IF( NPROCS1 )
1820 $ CALL BLACS_SETUP( IAM, NPROCS )
1821*
1822* Temporarily define blacs grid to include all processes so
1823* information can be broadcast to all processes
1824*
1825 CALL BLACS_GET( -1, 0, ICTXT )
1826 CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
1827*
1828* Compute machine epsilon
1829*
1830 EPS = PDLAMCH( ICTXT, 'eps' )
1831*
1832 CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, THRESH, 1, 0, 0 )
1833 CALL DGEBR2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1, 0, 0 )
1834 CALL DGEBR2D( ICTXT, 'All', ' ', 1, 1, BETA, 1, 0, 0 )
1835*
1836 CALL IGEBR2D( ICTXT, 'All', ' ', 3, 1, WORK, 3, 0, 0 )
1837 NGRIDS = WORK( 1 )
1838 NMAT = WORK( 2 )
1839 NBLOG = WORK( 3 )
1840*
1841 I = 2*NGRIDS + 37*NMAT + NSUBS + 4
1842 CALL IGEBR2D( ICTXT, 'All', ' ', I, 1, WORK, I, 0, 0 )
1843*
1844 I = 1
1845.EQ. IF( WORK( I )1 ) THEN
1846 SOF = .TRUE.
1847 ELSE
1848 SOF = .FALSE.
1849 END IF
1850 I = I + 1
1851.EQ. IF( WORK( I )1 ) THEN
1852 TEE = .TRUE.
1853 ELSE
1854 TEE = .FALSE.
1855 END IF
1856 I = I + 1
1857 IVERB = WORK( I )
1858 I = I + 1
1859 IGAP = WORK( I )
1860 I = I + 1
1861 DO 100 J = 1, NMAT
1862 DIAGVAL( J ) = CHAR( WORK( I ) )
1863 TRANVAL( J ) = CHAR( WORK( I+1 ) )
1864 UPLOVAL( J ) = CHAR( WORK( I+2 ) )
1865 I = I + 3
1866 100 CONTINUE
1867 CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL, 1 )
1868 I = I + NGRIDS
1869 CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL, 1 )
1870 I = I + NGRIDS
1871 CALL ICOPY( NMAT, WORK( I ), 1, MVAL, 1 )
1872 I = I + NMAT
1873 CALL ICOPY( NMAT, WORK( I ), 1, NVAL, 1 )
1874 I = I + NMAT
1875 CALL ICOPY( NMAT, WORK( I ), 1, MAVAL, 1 )
1876 I = I + NMAT
1877 CALL ICOPY( NMAT, WORK( I ), 1, NAVAL, 1 )
1878 I = I + NMAT
1879 CALL ICOPY( NMAT, WORK( I ), 1, IMBAVAL, 1 )
1880 I = I + NMAT
1881 CALL ICOPY( NMAT, WORK( I ), 1, INBAVAL, 1 )
1882 I = I + NMAT
1883 CALL ICOPY( NMAT, WORK( I ), 1, MBAVAL, 1 )
1884 I = I + NMAT
1885 CALL ICOPY( NMAT, WORK( I ), 1, NBAVAL, 1 )
1886 I = I + NMAT
1887 CALL ICOPY( NMAT, WORK( I ), 1, RSCAVAL, 1 )
1888 I = I + NMAT
1889 CALL ICOPY( NMAT, WORK( I ), 1, CSCAVAL, 1 )
1890 I = I + NMAT
1891 CALL ICOPY( NMAT, WORK( I ), 1, IAVAL, 1 )
1892 I = I + NMAT
1893 CALL ICOPY( NMAT, WORK( I ), 1, JAVAL, 1 )
1894 I = I + NMAT
1895 CALL ICOPY( NMAT, WORK( I ), 1, MXVAL, 1 )
1896 I = I + NMAT
1897 CALL ICOPY( NMAT, WORK( I ), 1, NXVAL, 1 )
1898 I = I + NMAT
1899 CALL ICOPY( NMAT, WORK( I ), 1, IMBXVAL, 1 )
1900 I = I + NMAT
1901 CALL ICOPY( NMAT, WORK( I ), 1, INBXVAL, 1 )
1902 I = I + NMAT
1903 CALL ICOPY( NMAT, WORK( I ), 1, MBXVAL, 1 )
1904 I = I + NMAT
1905 CALL ICOPY( NMAT, WORK( I ), 1, NBXVAL, 1 )
1906 I = I + NMAT
1907 CALL ICOPY( NMAT, WORK( I ), 1, RSCXVAL, 1 )
1908 I = I + NMAT
1909 CALL ICOPY( NMAT, WORK( I ), 1, CSCXVAL, 1 )
1910 I = I + NMAT
1911 CALL ICOPY( NMAT, WORK( I ), 1, IXVAL, 1 )
1912 I = I + NMAT
1913 CALL ICOPY( NMAT, WORK( I ), 1, JXVAL, 1 )
1914 I = I + NMAT
1915 CALL ICOPY( NMAT, WORK( I ), 1, INCXVAL, 1 )
1916 I = I + NMAT
1917 CALL ICOPY( NMAT, WORK( I ), 1, MYVAL, 1 )
1918 I = I + NMAT
1919 CALL ICOPY( NMAT, WORK( I ), 1, NYVAL, 1 )
1920 I = I + NMAT
1921 CALL ICOPY( NMAT, WORK( I ), 1, IMBYVAL, 1 )
1922 I = I + NMAT
1923 CALL ICOPY( NMAT, WORK( I ), 1, INBYVAL, 1 )
1924 I = I + NMAT
1925 CALL ICOPY( NMAT, WORK( I ), 1, MBYVAL, 1 )
1926 I = I + NMAT
1927 CALL ICOPY( NMAT, WORK( I ), 1, NBYVAL, 1 )
1928 I = I + NMAT
1929 CALL ICOPY( NMAT, WORK( I ), 1, RSCYVAL, 1 )
1930 I = I + NMAT
1931 CALL ICOPY( NMAT, WORK( I ), 1, CSCYVAL, 1 )
1932 I = I + NMAT
1933 CALL ICOPY( NMAT, WORK( I ), 1, IYVAL, 1 )
1934 I = I + NMAT
1935 CALL ICOPY( NMAT, WORK( I ), 1, JYVAL, 1 )
1936 I = I + NMAT
1937 CALL ICOPY( NMAT, WORK( I ), 1, INCYVAL, 1 )
1938 I = I + NMAT
1939*
1940 DO 110 J = 1, NSUBS
1941.EQ. IF( WORK( I )1 ) THEN
1942 LTEST( J ) = .TRUE.
1943 ELSE
1944 LTEST( J ) = .FALSE.
1945 END IF
1946 I = I + 1
1947 110 CONTINUE
1948*
1949 END IF
1950*
1951 CALL BLACS_GRIDEXIT( ICTXT )
1952*
1953 RETURN
1954*
1955 120 WRITE( NOUT, FMT = 9997 )
1956 CLOSE( NIN )
1957.NE..AND..NE. IF( NOUT6 NOUT0 )
1958 $ CLOSE( NOUT )
1959 CALL BLACS_ABORT( ICTXT, 1 )
1960*
1961 STOP
1962*
1963 9999 FORMAT( A )
1964 9998 FORMAT( ' Number of values of ',5A, ' is less than 1 or greater ',
1965 $ 'than ', I2 )
1966 9997 FORMAT( ' Illegal input in file ',40A,'. Aborting run.' )
1967 9996 FORMAT( A7, L2 )
1968 9995 FORMAT( ' Subprogram name ', A7, ' not recognized',
1969 $ /' ******* TESTS ABANDONED *******' )
1970 9994 FORMAT( 2X, 'Relative machine precision (eps) is taken to be ',
1971 $ E18.6 )
1972 9993 FORMAT( 2X, 'Number of Tests : ', I6 )
1973 9992 FORMAT( 2X, 'Number of process grids : ', I6 )
1974 9991 FORMAT( 2X, ' : ', 5I6 )
1975 9990 FORMAT( 2X, A1, ' : ', 5I6 )
1976 9988 FORMAT( 2X, 'Stop on failure flag : ', L6 )
1977 9987 FORMAT( 2X, 'Test for error exits flag : ', L6 )
1978 9986 FORMAT( 2X, 'Verbosity level : ', I6 )
1979 9985 FORMAT( 2X, 'Routines to be tested : ', A, A8 )
1980 9984 FORMAT( 2X, ' ', A, A8 )
1981 9983 FORMAT( 2X, 'Leading dimension gap : ', I6 )
1982 9982 FORMAT( 2X, 'Alpha : ', G16.6 )
1983 9981 FORMAT( 2X, 'Beta : ', G16.6 )
1984 9980 FORMAT( 2X, 'Threshold value : ', G16.6 )
1985 9979 FORMAT( 2X, 'Logical block size : ', I6 )
1986*
1987* End of PDBLA2TSTINFO
1988*
the
end diagonal values have been computed in the(sparse) matrix id.SOL
alpha
#define alpha
Definition eval.h:35
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
sgebs2d
subroutine sgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1072
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
dgebs2d
subroutine dgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1082
dgebr2d
subroutine dgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1123
sgebr2d
subroutine sgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1113
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769

◆ pdblas2tstchk()

subroutine pdblas2tstchk ( integer ictxt,
integer nout,
integer nrout,
character*1 uplo,
character*1 trans,
character*1 diag,
integer m,
integer n,
double precision alpha,
double precision, dimension( * ) a,
double precision, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
double precision, dimension( * ) x,
double precision, dimension( * ) px,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
double precision beta,
double precision, dimension( * ) y,
double precision, dimension( * ) py,
integer iy,
integer jy,
integer, dimension( * ) descy,
integer incy,
real thresh,
double precision rogue,
double precision, dimension( * ) work,
integer info )

Definition at line 2520 of file pdblas2tst.f.

2525*
2526* -- PBLAS test routine (version 2.0) --
2527* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2528* and University of California, Berkeley.
2529* April 1, 1998
2530*
2531* .. Scalar Arguments ..
2532 CHARACTER*1 DIAG, TRANS, UPLO
2533 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
2534 $ JY, M, N, NOUT, NROUT
2535 REAL THRESH
2536 DOUBLE PRECISION ALPHA, BETA, ROGUE
2537* ..
2538* .. Array Arguments ..
2539 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
2540 DOUBLE PRECISION A( * ), PA( * ), PX( * ), PY( * ), WORK( * ),
2541 $ X( * ), Y( * )
2542* ..
2543*
2544* Purpose
2545* =======
2546*
2547* PDBLAS2TSTCHK performs the computational tests of the Level 2 PBLAS.
2548*
2549* Notes
2550* =====
2551*
2552* A description vector is associated with each 2D block-cyclicly dis-
2553* tributed matrix. This vector stores the information required to
2554* establish the mapping between a matrix entry and its corresponding
2555* process and memory location.
2556*
2557* In the following comments, the character _ should be read as
2558* "of the distributed matrix". Let A be a generic term for any 2D
2559* block cyclicly distributed matrix. Its description vector is DESCA:
2560*
2561* NOTATION STORED IN EXPLANATION
2562* ---------------- --------------- ------------------------------------
2563* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2564* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2565* the NPROW x NPCOL BLACS process grid
2566* A is distributed over. The context
2567* itself is global, but the handle
2568* (the integer value) may vary.
2569* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2570* ted matrix A, M_A >= 0.
2571* N_A (global) DESCA( N_ ) The number of columns in the distri-
2572* buted matrix A, N_A >= 0.
2573* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2574* block of the matrix A, IMB_A > 0.
2575* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2576* left block of the matrix A,
2577* INB_A > 0.
2578* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2579* bute the last M_A-IMB_A rows of A,
2580* MB_A > 0.
2581* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2582* bute the last N_A-INB_A columns of
2583* A, NB_A > 0.
2584* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2585* row of the matrix A is distributed,
2586* NPROW > RSRC_A >= 0.
2587* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2588* first column of A is distributed.
2589* NPCOL > CSRC_A >= 0.
2590* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2591* array storing the local blocks of
2592* the distributed matrix A,
2593* IF( Lc( 1, N_A ) > 0 )
2594* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2595* ELSE
2596* LLD_A >= 1.
2597*
2598* Let K be the number of rows of a matrix A starting at the global in-
2599* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2600* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2601* receive if these K rows were distributed over NPROW processes. If K
2602* is the number of columns of a matrix A starting at the global index
2603* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2604* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2605* these K columns were distributed over NPCOL processes.
2606*
2607* The values of Lr() and Lc() may be determined via a call to the func-
2608* tion PB_NUMROC:
2609* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2610* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2611*
2612* Arguments
2613* =========
2614*
2615* ICTXT (local input) INTEGER
2616* On entry, ICTXT specifies the BLACS context handle, indica-
2617* ting the global context of the operation. The context itself
2618* is global, but the value of ICTXT is local.
2619*
2620* NOUT (global input) INTEGER
2621* On entry, NOUT specifies the unit number for the output file.
2622* When NOUT is 6, output to screen, when NOUT is 0, output to
2623* stderr. NOUT is only defined for process 0.
2624*
2625* NROUT (global input) INTEGER
2626* On entry, NROUT specifies which routine will be tested as
2627* follows:
2628* If NROUT = 1, PDGEMV will be tested;
2629* else if NROUT = 2, PDSYMV will be tested;
2630* else if NROUT = 3, PDTRMV will be tested;
2631* else if NROUT = 4, PDTRSV will be tested;
2632* else if NROUT = 5, PDGER will be tested;
2633* else if NROUT = 6, PDSYR will be tested;
2634* else if NROUT = 7, PDSYR2 will be tested;
2635*
2636* UPLO (global input) CHARACTER*1
2637* On entry, UPLO specifies if the upper or lower part of the
2638* matrix operand is to be referenced.
2639*
2640* TRANS (global input) CHARACTER*1
2641* On entry, TRANS specifies if the matrix operand A is to be
2642* transposed.
2643*
2644* DIAG (global input) CHARACTER*1
2645* On entry, DIAG specifies if the triangular matrix operand is
2646* unit or non-unit.
2647*
2648* M (global input) INTEGER
2649* On entry, M specifies the number of rows of A.
2650*
2651* N (global input) INTEGER
2652* On entry, N specifies the number of columns of A.
2653*
2654* ALPHA (global input) DOUBLE PRECISION
2655* On entry, ALPHA specifies the scalar alpha.
2656*
2657* A (local input/local output) DOUBLE PRECISION array
2658* On entry, A is an array of dimension (DESCA( M_ ),*). This
2659* array contains a local copy of the initial entire matrix PA.
2660*
2661* PA (local input) DOUBLE PRECISION array
2662* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
2663* array contains the local entries of the matrix PA.
2664*
2665* IA (global input) INTEGER
2666* On entry, IA specifies A's global row index, which points to
2667* the beginning of the submatrix sub( A ).
2668*
2669* JA (global input) INTEGER
2670* On entry, JA specifies A's global column index, which points
2671* to the beginning of the submatrix sub( A ).
2672*
2673* DESCA (global and local input) INTEGER array
2674* On entry, DESCA is an integer array of dimension DLEN_. This
2675* is the array descriptor for the matrix A.
2676*
2677* X (local input/local output) DOUBLE PRECISION array
2678* On entry, X is an array of dimension (DESCX( M_ ),*). This
2679* array contains a local copy of the initial entire matrix PX.
2680*
2681* PX (local input) DOUBLE PRECISION array
2682* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2683* array contains the local entries of the matrix PX.
2684*
2685* IX (global input) INTEGER
2686* On entry, IX specifies X's global row index, which points to
2687* the beginning of the submatrix sub( X ).
2688*
2689* JX (global input) INTEGER
2690* On entry, JX specifies X's global column index, which points
2691* to the beginning of the submatrix sub( X ).
2692*
2693* DESCX (global and local input) INTEGER array
2694* On entry, DESCX is an integer array of dimension DLEN_. This
2695* is the array descriptor for the matrix X.
2696*
2697* INCX (global input) INTEGER
2698* On entry, INCX specifies the global increment for the
2699* elements of X. Only two values of INCX are supported in
2700* this version, namely 1 and M_X. INCX must not be zero.
2701*
2702* BETA (global input) DOUBLE PRECISION
2703* On entry, BETA specifies the scalar beta.
2704*
2705* Y (local input/local output) DOUBLE PRECISION array
2706* On entry, Y is an array of dimension (DESCY( M_ ),*). This
2707* array contains a local copy of the initial entire matrix PY.
2708*
2709* PY (local input) DOUBLE PRECISION array
2710* On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
2711* array contains the local entries of the matrix PY.
2712*
2713* IY (global input) INTEGER
2714* On entry, IY specifies Y's global row index, which points to
2715* the beginning of the submatrix sub( Y ).
2716*
2717* JY (global input) INTEGER
2718* On entry, JY specifies Y's global column index, which points
2719* to the beginning of the submatrix sub( Y ).
2720*
2721* DESCY (global and local input) INTEGER array
2722* On entry, DESCY is an integer array of dimension DLEN_. This
2723* is the array descriptor for the matrix Y.
2724*
2725* INCY (global input) INTEGER
2726* On entry, INCY specifies the global increment for the
2727* elements of Y. Only two values of INCY are supported in
2728* this version, namely 1 and M_Y. INCY must not be zero.
2729*
2730* THRESH (global input) REAL
2731* On entry, THRESH is the threshold value for the test ratio.
2732*
2733* ROGUE (global input) DOUBLE PRECISION
2734* On entry, ROGUE specifies the constant used to pad the
2735* non-referenced part of triangular or symmetric matrices.
2736*
2737* WORK (workspace) DOUBLE PRECISION array
2738* On entry, WORK is an array of dimension LWORK where LWORK is
2739* at least MAX( M, N ). This array is used to store the compu-
2740* ted gauges (see PDMVCH).
2741*
2742* INFO (global output) INTEGER
2743* On exit, if INFO = 0, no error has been found, otherwise
2744* if( MOD( INFO, 2 ) = 1 ) then an error on A has been found,
2745* if( MOD( INFO/2, 2 ) = 1 ) then an error on X has been found,
2746* if( MOD( INFO/4, 2 ) = 1 ) then an error on Y has been found.
2747*
2748* -- Written on April 1, 1998 by
2749* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2750*
2751* =====================================================================
2752*
2753* .. Parameters ..
2754 DOUBLE PRECISION ONE, ZERO
2755 parameter( one = 1.0d+0, zero = 0.0d+0 )
2756 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2757 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2758 $ RSRC_
2759 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2760 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2761 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2762 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2763* ..
2764* .. Local Scalars ..
2765 INTEGER I, MYCOL, MYROW, NPCOL, NPROW
2766 DOUBLE PRECISION ERR
2767* ..
2768* .. Local Arrays ..
2769 INTEGER IERR( 3 )
2770* ..
2771* .. External Subroutines ..
2772 EXTERNAL blacs_gridinfo, dtrsv, pb_dlaset, pdchkmin,
2773 $ pdchkvin, pdmvch, pdtrmv, pdvmch, pdvmch2
2774* ..
2775* .. External Functions ..
2776 LOGICAL LSAME
2777 EXTERNAL lsame
2778* ..
2779* .. Intrinsic Functions ..
2780 INTRINSIC dble
2781* ..
2782* .. Executable Statements ..
2783*
2784 info = 0
2785*
2786* Quick return if possible
2787*
2788 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
2789 $ RETURN
2790*
2791* Start the operations
2792*
2793 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2794*
2795 DO 10 i = 1, 3
2796 ierr( i ) = 0
2797 10 CONTINUE
2798*
2799 IF( nrout.EQ.1 ) THEN
2800*
2801* Test PDGEMV
2802*
2803* Check the resulting vector Y
2804*
2805 CALL pdmvch( ictxt, trans, m, n, alpha, a, ia, ja, desca, x,
2806 $ ix, jx, descx, incx, beta, y, py, iy, jy, descy,
2807 $ incy, work, err, ierr( 3 ) )
2808*
2809 IF( ierr( 3 ).NE.0 ) THEN
2810 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2811 $ WRITE( nout, fmt = 9997 )
2812 ELSE IF( err.GT.dble( thresh ) ) THEN
2813 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2814 $ WRITE( nout, fmt = 9996 ) err
2815 END IF
2816*
2817* Check the input-only arguments
2818*
2819 CALL pdchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
2820 IF( lsame( trans, 'N' ) ) THEN
2821 CALL pdchkvin( err, n, x, px, ix, jx, descx, incx,
2822 $ ierr( 2 ) )
2823 ELSE
2824 CALL pdchkvin( err, m, x, px, ix, jx, descx, incx,
2825 $ ierr( 2 ) )
2826 END IF
2827*
2828 ELSE IF( nrout.EQ.2 ) THEN
2829*
2830* Test PDSYMV
2831*
2832* Check the resulting vector Y
2833*
2834 CALL pdmvch( ictxt, 'No transpose', n, n, alpha, a, ia, ja,
2835 $ desca, x, ix, jx, descx, incx, beta, y, py, iy,
2836 $ jy, descy, incy, work, err, ierr( 3 ) )
2837*
2838 IF( ierr( 3 ).NE.0 ) THEN
2839 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2840 $ WRITE( nout, fmt = 9997 )
2841 ELSE IF( err.GT.dble( thresh ) ) THEN
2842 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2843 $ WRITE( nout, fmt = 9996 ) err
2844 END IF
2845*
2846* Check the input-only arguments
2847*
2848 IF( lsame( uplo, 'L' ) ) THEN
2849 CALL pb_dlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
2850 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
2851 ELSE
2852 CALL pb_dlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
2853 $ a( ia+1+(ja-1)*desca( m_ ) ), desca( m_ ) )
2854 END IF
2855 CALL pdchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
2856 CALL pdchkvin( err, n, x, px, ix, jx, descx, incx, ierr( 2 ) )
2857*
2858 ELSE IF( nrout.EQ.3 ) THEN
2859*
2860* Test PDTRMV
2861*
2862* Check the resulting vector X
2863*
2864 CALL pdmvch( ictxt, trans, n, n, one, a, ia, ja, desca, y, ix,
2865 $ jx, descx, incx, zero, x, px, ix, jx, descx, incx,
2866 $ work, err, ierr( 2 ) )
2867*
2868 IF( ierr( 2 ).NE.0 ) THEN
2869 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2870 $ WRITE( nout, fmt = 9997 )
2871 ELSE IF( err.GT.dble( thresh ) ) THEN
2872 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2873 $ WRITE( nout, fmt = 9996 ) err
2874 END IF
2875*
2876* Check the input-only arguments
2877*
2878 IF( lsame( uplo, 'L' ) ) THEN
2879 IF( lsame( diag, 'N' ) ) THEN
2880 CALL pb_dlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
2881 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
2882 ELSE
2883 CALL pb_dlaset( 'Upper', n, n, 0, rogue, one,
2884 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ) )
2885 END IF
2886 ELSE
2887 IF( lsame( diag, 'N' ) ) THEN
2888 CALL pb_dlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
2889 $ a( ia+1+(ja-1)*desca( m_ ) ),
2890 $ desca( m_ ) )
2891 ELSE
2892 CALL pb_dlaset( 'Lower', n, n, 0, rogue, one,
2893 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ) )
2894 END IF
2895 END IF
2896 CALL pdchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
2897*
2898 ELSE IF( nrout.EQ.4 ) THEN
2899*
2900* Test PDTRSV
2901*
2902* Check the resulting vector X
2903*
2904 CALL dtrsv( uplo, trans, diag, n, a( ia+(ja-1)*desca( m_ ) ),
2905 $ desca( m_ ), x( ix+(jx-1)*descx( m_ ) ), incx )
2906 CALL pdtrmv( uplo, trans, diag, n, pa, ia, ja, desca, px, ix,
2907 $ jx, descx, incx )
2908 CALL pdmvch( ictxt, trans, n, n, one, a, ia, ja, desca, x, ix,
2909 $ jx, descx, incx, zero, y, px, ix, jx, descx, incx,
2910 $ work, err, ierr( 2 ) )
2911*
2912 IF( ierr( 2 ).NE.0 ) THEN
2913 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2914 $ WRITE( nout, fmt = 9997 )
2915 ELSE IF( err.GT.dble( thresh ) ) THEN
2916 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2917 $ WRITE( nout, fmt = 9996 ) err
2918 END IF
2919*
2920* Check the input-only arguments
2921*
2922 IF( lsame( uplo, 'L' ) ) THEN
2923 IF( lsame( diag, 'N' ) ) THEN
2924 CALL pb_dlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
2925 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
2926 ELSE
2927 CALL pb_dlaset( 'Upper', n, n, 0, rogue, one,
2928 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ) )
2929 END IF
2930 ELSE
2931 IF( lsame( diag, 'N' ) ) THEN
2932 CALL pb_dlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
2933 $ a( ia+1+(ja-1)*desca( m_ ) ),
2934 $ desca( m_ ) )
2935 ELSE
2936 CALL pb_dlaset( 'Lower', n, n, 0, rogue, one,
2937 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ) )
2938 END IF
2939 END IF
2940 CALL pdchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
2941*
2942 ELSE IF( nrout.EQ.5 ) THEN
2943*
2944* Test PDGER
2945*
2946* Check the resulting matrix A
2947*
2948 CALL pdvmch( ictxt, 'Ge', m, n, alpha, x, ix, jx, descx,
2949 $ incx, y, iy, jy, descy, incy, a, pa, ia, ja,
2950 $ desca, work, err, ierr( 1 ) )
2951 IF( ierr( 1 ).NE.0 ) THEN
2952 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2953 $ WRITE( nout, fmt = 9997 )
2954 ELSE IF( err.GT.dble( thresh ) ) THEN
2955 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2956 $ WRITE( nout, fmt = 9996 ) err
2957 END IF
2958*
2959* Check the input-only arguments
2960*
2961 CALL pdchkvin( err, m, x, px, ix, jx, descx, incx, ierr( 2 ) )
2962 CALL pdchkvin( err, n, y, py, iy, jy, descy, incy, ierr( 3 ) )
2963*
2964 ELSE IF( nrout.EQ.6 ) THEN
2965*
2966* Test PDSYR
2967*
2968* Check the resulting matrix A
2969*
2970 CALL pdvmch( ictxt, uplo, n, n, alpha, x, ix, jx, descx,
2971 $ incx, x, ix, jx, descx, incx, a, pa, ia, ja,
2972 $ desca, work, err, ierr( 1 ) )
2973 IF( ierr( 1 ).NE.0 ) THEN
2974 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2975 $ WRITE( nout, fmt = 9997 )
2976 ELSE IF( err.GT.dble( thresh ) ) THEN
2977 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2978 $ WRITE( nout, fmt = 9996 ) err
2979 END IF
2980*
2981* Check the input-only arguments
2982*
2983 CALL pdchkvin( err, n, x, px, ix, jx, descx, incx, ierr( 2 ) )
2984*
2985 ELSE IF( nrout.EQ.7 ) THEN
2986*
2987* Test PDSYR2
2988*
2989* Check the resulting matrix A
2990*
2991 CALL pdvmch2( ictxt, uplo, n, n, alpha, x, ix, jx, descx, incx,
2992 $ y, iy, jy, descy, incy, a, pa, ia, ja, desca,
2993 $ work, err, ierr( 1 ) )
2994 IF( ierr( 1 ).NE.0 ) THEN
2995 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2996 $ WRITE( nout, fmt = 9997 )
2997 ELSE IF( err.GT.dble( thresh ) ) THEN
2998 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2999 $ WRITE( nout, fmt = 9996 ) err
3000 END IF
3001*
3002* Check the input-only arguments
3003*
3004 CALL pdchkvin( err, n, x, px, ix, jx, descx, incx, ierr( 2 ) )
3005 CALL pdchkvin( err, n, y, py, iy, jy, descy, incy, ierr( 3 ) )
3006*
3007 END IF
3008*
3009 IF( ierr( 1 ).NE.0 ) THEN
3010 info = info + 1
3011 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3012 $ WRITE( nout, fmt = 9999 ) 'A'
3013 END IF
3014*
3015 IF( ierr( 2 ).NE.0 ) THEN
3016 info = info + 2
3017 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3018 $ WRITE( nout, fmt = 9998 ) 'X'
3019 END IF
3020*
3021 IF( ierr( 3 ).NE.0 ) THEN
3022 info = info + 4
3023 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3024 $ WRITE( nout, fmt = 9998 ) 'Y'
3025 END IF
3026*
3027 9999 FORMAT( 2x, ' ***** ERROR: Matrix operand ', a,
3028 $ ' is incorrect.' )
3029 9998 FORMAT( 2x, ' ***** ERROR: Vector operand ', a,
3030 $ ' is incorrect.' )
3031 9997 FORMAT( 2x, ' ***** FATAL ERROR - Computed result is less ',
3032 $ 'than half accurate *****' )
3033 9996 FORMAT( 2x, ' ***** Test completed with maximum test ratio: ',
3034 $ f11.5, ' SUSPECT *****' )
3035*
3036 RETURN
3037*
3038* End of PDBLAS2TSTCHK
3039*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
dtrsv
subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
DTRSV
Definition dtrsv.f:143
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pb_dlaset
subroutine pb_dlaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pdblastst.f:9359
pdvmch2
subroutine pdvmch2(ictxt, uplo, m, n, alpha, x, ix, jx, descx, incx, y, iy, jy, descy, incy, a, pa, ia, ja, desca, g, err, info)
Definition pdblastst.f:4919
pdvmch
subroutine pdvmch(ictxt, uplo, m, n, alpha, x, ix, jx, descx, incx, y, iy, jy, descy, incy, a, pa, ia, ja, desca, g, err, info)
Definition pdblastst.f:4570
pdmvch
subroutine pdmvch(ictxt, trans, m, n, alpha, a, ia, ja, desca, x, ix, jx, descx, incx, beta, y, py, iy, jy, descy, incy, g, err, info)
Definition pdblastst.f:4157
pdchkvin
subroutine pdchkvin(errmax, n, x, px, ix, jx, descx, incx, info)
Definition pdblastst.f:2576
pdchkmin
subroutine pdchkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition pdblastst.f:3326

◆ pdblas2tstchke()

subroutine pdblas2tstchke ( logical, dimension( * ) ltest,
integer inout,
integer nprocs )

Definition at line 1990 of file pdblas2tst.f.

1991*
1992* -- PBLAS test routine (version 2.0) --
1993* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1994* and University of California, Berkeley.
1995* April 1, 1998
1996*
1997* .. Scalar Arguments ..
1998 INTEGER INOUT, NPROCS
1999* ..
2000* .. Array Arguments ..
2001 LOGICAL LTEST( * )
2002* ..
2003*
2004* Purpose
2005* =======
2006*
2007* PDBLAS2TSTCHKE tests the error exits of the Level 2 PBLAS.
2008*
2009* Arguments
2010* =========
2011*
2012* LTEST (global input) LOGICAL array
2013* On entry, LTEST is an array of dimension at least 7 (NSUBS).
2014* If LTEST( 1 ) is .TRUE., PDGEMV will be tested;
2015* If LTEST( 2 ) is .TRUE., PDSYMV will be tested;
2016* If LTEST( 3 ) is .TRUE., PDTRMV will be tested;
2017* If LTEST( 4 ) is .TRUE., PDTRSV will be tested;
2018* If LTEST( 5 ) is .TRUE., PDGER will be tested;
2019* If LTEST( 6 ) is .TRUE., PDSYR will be tested;
2020* If LTEST( 7 ) is .TRUE., PDSYR2 will be tested;
2021*
2022* INOUT (global input) INTEGER
2023* On entry, INOUT specifies the unit number for output file.
2024* When INOUT is 6, output to screen, when INOUT = 0, output to
2025* stderr. INOUT is only defined in process 0.
2026*
2027* NPROCS (global input) INTEGER
2028* On entry, NPROCS specifies the total number of processes cal-
2029* ling this routine.
2030*
2031* Calling sequence encodings
2032* ==========================
2033*
2034* code Formal argument list Examples
2035*
2036* 11 (n, v1,v2) _SWAP, _COPY
2037* 12 (n,s1, v1 ) _SCAL, _SCAL
2038* 13 (n,s1, v1,v2) _AXPY, _DOT_
2039* 14 (n,s1,i1,v1 ) _AMAX
2040* 15 (n,u1, v1 ) _ASUM, _NRM2
2041*
2042* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2043* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2044* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2045* 24 ( m,n,s1,v1,v2,m1) _GER_
2046* 25 (uplo, n,s1,v1, m1) _SYR
2047* 26 (uplo, n,u1,v1, m1) _HER
2048* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2049*
2050* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2051* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2052* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2053* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2054* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2055* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2056* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2057* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2058* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2059* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2060*
2061* -- Written on April 1, 1998 by
2062* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2063*
2064* =====================================================================
2065*
2066* .. Parameters ..
2067 INTEGER NSUBS
2068 parameter( nsubs = 7 )
2069* ..
2070* .. Local Scalars ..
2071 LOGICAL ABRTSAV
2072 INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
2073* ..
2074* .. Local Arrays ..
2075 INTEGER SCODE( NSUBS )
2076* ..
2077* .. External Subroutines ..
2078 EXTERNAL blacs_get, blacs_gridexit, blacs_gridinfo,
2079 $ blacs_gridinit, pddimee, pdgemv, pdger,
2080 $ pdmatee, pdoptee, pdsymv, pdsyr, pdsyr2,
2081 $ pdtrmv, pdtrsv, pdvecee
2082* ..
2083* .. Common Blocks ..
2084 LOGICAL ABRTFLG
2085 INTEGER NOUT
2086 CHARACTER*7 SNAMES( NSUBS )
2087 COMMON /snamec/snames
2088 COMMON /pberrorc/nout, abrtflg
2089* ..
2090* .. Data Statements ..
2091 DATA scode/21, 22, 23, 23, 24, 25, 27/
2092* ..
2093* .. Executable Statements ..
2094*
2095* Temporarily define blacs grid to include all processes so
2096* information can be broadcast to all processes.
2097*
2098 CALL blacs_get( -1, 0, ictxt )
2099 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
2100 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2101*
2102* Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
2103* on errors during these tests and set the output device unit for
2104* it.
2105*
2106 abrtsav = abrtflg
2107 abrtflg = .false.
2108 nout = inout
2109*
2110* Test PDGEMV
2111*
2112 i = 1
2113 IF( ltest( i ) ) THEN
2114 CALL pdoptee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
2115 CALL pddimee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
2116 CALL pdmatee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
2117 CALL pdvecee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
2118 END IF
2119*
2120* Test PDSYMV
2121*
2122 i = i + 1
2123 IF( ltest( i ) ) THEN
2124 CALL pdoptee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
2125 CALL pddimee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
2126 CALL pdmatee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
2127 CALL pdvecee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
2128 END IF
2129*
2130* Test PDTRMV
2131*
2132 i = i + 1
2133 IF( ltest( i ) ) THEN
2134 CALL pdoptee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
2135 CALL pddimee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
2136 CALL pdmatee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
2137 CALL pdvecee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
2138 END IF
2139*
2140* Test PDTRSV
2141*
2142 i = i + 1
2143 IF( ltest( i ) ) THEN
2144 CALL pdoptee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
2145 CALL pddimee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
2146 CALL pdmatee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
2147 CALL pdvecee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
2148 END IF
2149*
2150* Test PDGER
2151*
2152 i = i + 1
2153 IF( ltest( i ) ) THEN
2154 CALL pddimee( ictxt, nout, pdger, scode( i ), snames( i ) )
2155 CALL pdvecee( ictxt, nout, pdger, scode( i ), snames( i ) )
2156 CALL pdmatee( ictxt, nout, pdger, scode( i ), snames( i ) )
2157 END IF
2158*
2159* Test PDSYR
2160*
2161 i = i + 1
2162 IF( ltest( i ) ) THEN
2163 CALL pdoptee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
2164 CALL pddimee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
2165 CALL pdvecee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
2166 CALL pdmatee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
2167 END IF
2168*
2169* Test PDSYR2
2170*
2171 i = i + 1
2172 IF( ltest( i ) ) THEN
2173 CALL pdoptee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
2174 CALL pddimee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
2175 CALL pdvecee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
2176 CALL pdmatee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
2177 END IF
2178*
2179 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2180 $ WRITE( nout, fmt = 9999 )
2181*
2182 CALL blacs_gridexit( ictxt )
2183*
2184* Reset ABRTFLG to the value it had before calling this routine
2185*
2186 abrtflg = abrtsav
2187*
2188 9999 FORMAT( 2x, 'Error-exit tests completed.' )
2189*
2190 RETURN
2191*
2192* End of PDBLAS2TSTCHKE
2193*
pdoptee
subroutine pdoptee(ictxt, nout, subptr, scode, sname)
Definition pdblastst.f:2
pdmatee
subroutine pdmatee(ictxt, nout, subptr, scode, sname)
Definition pdblastst.f:1190
pddimee
subroutine pddimee(ictxt, nout, subptr, scode, sname)
Definition pdblastst.f:455
pdvecee
subroutine pdvecee(ictxt, nout, subptr, scode, sname)
Definition pdblastst.f:936

◆ pdchkarg2()

subroutine pdchkarg2 ( integer ictxt,
integer nout,
character*(*) sname,
character*1 uplo,
character*1 trans,
character*1 diag,
integer m,
integer n,
double precision alpha,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
double precision beta,
integer iy,
integer jy,
integer, dimension( * ) descy,
integer incy,
integer info )

Definition at line 2195 of file pdblas2tst.f.

2198*
2199* -- PBLAS test routine (version 2.0) --
2200* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2201* and University of California, Berkeley.
2202* April 1, 1998
2203*
2204* .. Scalar Arguments ..
2205 CHARACTER*1 DIAG, TRANS, UPLO
2206 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
2207 $ JY, M, N, NOUT
2208 DOUBLE PRECISION ALPHA, BETA
2209* ..
2210* .. Array Arguments ..
2211 CHARACTER*(*) SNAME
2212 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
2213* ..
2214*
2215* Purpose
2216* =======
2217*
2218* PDCHKARG2 checks the input-only arguments of the Level 2 PBLAS. When
2219* INFO = 0, this routine makes a copy of its arguments (which are INPUT
2220* only arguments to PBLAS routines). Otherwise, it verifies the values
2221* of these arguments against the saved copies.
2222*
2223* Arguments
2224* =========
2225*
2226* ICTXT (local input) INTEGER
2227* On entry, ICTXT specifies the BLACS context handle, indica-
2228* ting the global context of the operation. The context itself
2229* is global, but the value of ICTXT is local.
2230*
2231* NOUT (global input) INTEGER
2232* On entry, NOUT specifies the unit number for the output file.
2233* When NOUT is 6, output to screen, when NOUT is 0, output to
2234* stderr. NOUT is only defined for process 0.
2235*
2236* SNAME (global input) CHARACTER*(*)
2237* On entry, SNAME specifies the subroutine name calling this
2238* subprogram.
2239*
2240* UPLO (global input) CHARACTER*1
2241* On entry, UPLO specifies the UPLO option in the Level 2 PBLAS
2242* operation.
2243*
2244* TRANS (global input) CHARACTER*1
2245* On entry, TRANS specifies the TRANS option in the Level 2
2246* PBLAS operation.
2247*
2248* DIAG (global input) CHARACTER*1
2249* On entry, DIAG specifies the DIAG option in the Level 2 PBLAS
2250* operation.
2251*
2252* M (global input) INTEGER
2253* On entry, M specifies the dimension of the submatrix ope-
2254* rands.
2255*
2256* N (global input) INTEGER
2257* On entry, N specifies the dimension of the submatrix ope-
2258* rands.
2259*
2260* ALPHA (global input) DOUBLE PRECISION
2261* On entry, ALPHA specifies the scalar alpha.
2262*
2263* IA (global input) INTEGER
2264* On entry, IA specifies A's global row index, which points to
2265* the beginning of the submatrix sub( A ).
2266*
2267* JA (global input) INTEGER
2268* On entry, JA specifies A's global column index, which points
2269* to the beginning of the submatrix sub( A ).
2270*
2271* DESCA (global and local input) INTEGER array
2272* On entry, DESCA is an integer array of dimension DLEN_. This
2273* is the array descriptor for the matrix A.
2274*
2275* IX (global input) INTEGER
2276* On entry, IX specifies X's global row index, which points to
2277* the beginning of the submatrix sub( X ).
2278*
2279* JX (global input) INTEGER
2280* On entry, JX specifies X's global column index, which points
2281* to the beginning of the submatrix sub( X ).
2282*
2283* DESCX (global and local input) INTEGER array
2284* On entry, DESCX is an integer array of dimension DLEN_. This
2285* is the array descriptor for the matrix X.
2286*
2287* INCX (global input) INTEGER
2288* On entry, INCX specifies the global increment for the
2289* elements of X. Only two values of INCX are supported in
2290* this version, namely 1 and M_X. INCX must not be zero.
2291*
2292* BETA (global input) DOUBLE PRECISION
2293* On entry, BETA specifies the scalar beta.
2294*
2295* IY (global input) INTEGER
2296* On entry, IY specifies Y's global row index, which points to
2297* the beginning of the submatrix sub( Y ).
2298*
2299* JY (global input) INTEGER
2300* On entry, JY specifies Y's global column index, which points
2301* to the beginning of the submatrix sub( Y ).
2302*
2303* DESCY (global and local input) INTEGER array
2304* On entry, DESCY is an integer array of dimension DLEN_. This
2305* is the array descriptor for the matrix Y.
2306*
2307* INCY (global input) INTEGER
2308* On entry, INCY specifies the global increment for the
2309* elements of Y. Only two values of INCY are supported in
2310* this version, namely 1 and M_Y. INCY must not be zero.
2311*
2312* INFO (global input/global output) INTEGER
2313* When INFO = 0 on entry, the values of the arguments which are
2314* INPUT only arguments to a PBLAS routine are copied into sta-
2315* tic variables and INFO is unchanged on exit. Otherwise, the
2316* values of the arguments are compared against the saved co-
2317* pies. In case no error has been found INFO is zero on return,
2318* otherwise it is non zero.
2319*
2320* -- Written on April 1, 1998 by
2321* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2322*
2323* =====================================================================
2324*
2325* .. Parameters ..
2326 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2327 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2328 $ RSRC_
2329 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2330 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2331 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2332 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2333* ..
2334* .. Local Scalars ..
2335 CHARACTER*1 DIAGREF, TRANSREF, UPLOREF
2336 INTEGER I, IAREF, INCXREF, INCYREF, IXREF, IYREF,
2337 $ JAREF, JXREF, JYREF, MREF, MYCOL, MYROW, NPCOL,
2338 $ NPROW, NREF
2339 DOUBLE PRECISION ALPHAREF, BETAREF
2340* ..
2341* .. Local Arrays ..
2342 CHARACTER*15 ARGNAME
2343 INTEGER DESCAREF( DLEN_ ), DESCXREF( DLEN_ ),
2344 $ DESCYREF( DLEN_ )
2345* ..
2346* .. External Subroutines ..
2347 EXTERNAL blacs_gridinfo, igsum2d
2348* ..
2349* .. External Functions ..
2350 LOGICAL LSAME
2351 EXTERNAL lsame
2352* ..
2353* .. Save Statements ..
2354 SAVE
2355* ..
2356* .. Executable Statements ..
2357*
2358* Get grid parameters
2359*
2360 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2361*
2362* Check if first call. If yes, then save.
2363*
2364 IF( info.EQ.0 ) THEN
2365*
2366 diagref = diag
2367 transref = trans
2368 uploref = uplo
2369 mref = m
2370 nref = n
2371 alpharef = alpha
2372 iaref = ia
2373 jaref = ja
2374 DO 10 i = 1, dlen_
2375 descaref( i ) = desca( i )
2376 10 CONTINUE
2377 ixref = ix
2378 jxref = jx
2379 DO 20 i = 1, dlen_
2380 descxref( i ) = descx( i )
2381 20 CONTINUE
2382 incxref = incx
2383 betaref = beta
2384 iyref = iy
2385 jyref = jy
2386 DO 30 i = 1, dlen_
2387 descyref( i ) = descy( i )
2388 30 CONTINUE
2389 incyref = incy
2390*
2391 ELSE
2392*
2393* Test saved args. Return with first mismatch.
2394*
2395 argname = ' '
2396 IF( .NOT. lsame( diag, diagref ) ) THEN
2397 WRITE( argname, fmt = '(A)' ) 'DIAG'
2398 ELSE IF( .NOT. lsame( trans, transref ) ) THEN
2399 WRITE( argname, fmt = '(A)' ) 'TRANS'
2400 ELSE IF( .NOT. lsame( uplo, uploref ) ) THEN
2401 WRITE( argname, fmt = '(A)' ) 'UPLO'
2402 ELSE IF( m.NE.mref ) THEN
2403 WRITE( argname, fmt = '(a)' ) 'm'
2404.NE. ELSE IF( NNREF ) THEN
2405 WRITE( ARGNAME, FMT = '(a)' ) 'n'
2406.NE. ELSE IF( ALPHAALPHAREF ) THEN
2407 WRITE( ARGNAME, FMT = '(a)' ) 'alpha'
2408 ELSE IF( ia.NE.iaref ) THEN
2409 WRITE( argname, fmt = '(A)' ) 'IA'
2410 ELSE IF( ja.NE.jaref ) THEN
2411 WRITE( argname, fmt = '(A)' ) 'JA'
2412 ELSE IF( desca( dtype_ ).NE.descaref( dtype_ ) ) THEN
2413 WRITE( argname, fmt = '(A)' ) 'DESCA( DTYPE_ )'
2414 ELSE IF( desca( m_ ).NE.descaref( m_ ) ) THEN
2415 WRITE( argname, fmt = '(A)' ) 'DESCA( M_ )'
2416 ELSE IF( desca( n_ ).NE.descaref( n_ ) ) THEN
2417 WRITE( argname, fmt = '(A)' ) 'DESCA( N_ )'
2418 ELSE IF( desca( imb_ ).NE.descaref( imb_ ) ) THEN
2419 WRITE( argname, fmt = '(A)' ) 'DESCA( IMB_ )'
2420 ELSE IF( desca( inb_ ).NE.descaref( inb_ ) ) THEN
2421 WRITE( argname, fmt = '(A)' ) 'DESCA( INB_ )'
2422 ELSE IF( desca( mb_ ).NE.descaref( mb_ ) ) THEN
2423 WRITE( argname, fmt = '(A)' ) 'DESCA( MB_ )'
2424 ELSE IF( desca( nb_ ).NE.descaref( nb_ ) ) THEN
2425 WRITE( argname, fmt = '(A)' ) 'DESCA( NB_ )'
2426 ELSE IF( desca( rsrc_ ).NE.descaref( rsrc_ ) ) THEN
2427 WRITE( argname, fmt = '(A)' ) 'DESCA( RSRC_ )'
2428 ELSE IF( desca( csrc_ ).NE.descaref( csrc_ ) ) THEN
2429 WRITE( argname, fmt = '(A)' ) 'DESCA( CSRC_ )'
2430 ELSE IF( desca( ctxt_ ).NE.descaref( ctxt_ ) ) THEN
2431 WRITE( argname, fmt = '(A)' ) 'DESCA( CTXT_ )'
2432 ELSE IF( desca( lld_ ).NE.descaref( lld_ ) ) THEN
2433 WRITE( argname, fmt = '(A)' ) 'DESCA( LLD_ )'
2434 ELSE IF( ix.NE.ixref ) THEN
2435 WRITE( argname, fmt = '(A)' ) 'IX'
2436 ELSE IF( jx.NE.jxref ) THEN
2437 WRITE( argname, fmt = '(A)' ) 'JX'
2438 ELSE IF( descx( dtype_ ).NE.descxref( dtype_ ) ) THEN
2439 WRITE( argname, fmt = '(A)' ) 'DESCX( DTYPE_ )'
2440 ELSE IF( descx( m_ ).NE.descxref( m_ ) ) THEN
2441 WRITE( argname, fmt = '(A)' ) 'DESCX( M_ )'
2442 ELSE IF( descx( n_ ).NE.descxref( n_ ) ) THEN
2443 WRITE( argname, fmt = '(A)' ) 'DESCX( N_ )'
2444 ELSE IF( descx( imb_ ).NE.descxref( imb_ ) ) THEN
2445 WRITE( argname, fmt = '(A)' ) 'DESCX( IMB_ )'
2446 ELSE IF( descx( inb_ ).NE.descxref( inb_ ) ) THEN
2447 WRITE( argname, fmt = '(A)' ) 'DESCX( INB_ )'
2448 ELSE IF( descx( mb_ ).NE.descxref( mb_ ) ) THEN
2449 WRITE( argname, fmt = '(A)' ) 'DESCX( MB_ )'
2450 ELSE IF( descx( nb_ ).NE.descxref( nb_ ) ) THEN
2451 WRITE( argname, fmt = '(A)' ) 'DESCX( NB_ )'
2452 ELSE IF( descx( rsrc_ ).NE.descxref( rsrc_ ) ) THEN
2453 WRITE( argname, fmt = '(A)' ) 'DESCX( RSRC_ )'
2454 ELSE IF( descx( csrc_ ).NE.descxref( csrc_ ) ) THEN
2455 WRITE( argname, fmt = '(A)' ) 'DESCX( CSRC_ )'
2456 ELSE IF( descx( ctxt_ ).NE.descxref( ctxt_ ) ) THEN
2457 WRITE( argname, fmt = '(A)' ) 'DESCX( CTXT_ )'
2458 ELSE IF( descx( lld_ ).NE.descxref( lld_ ) ) THEN
2459 WRITE( argname, fmt = '(A)' ) 'DESCX( LLD_ )'
2460 ELSE IF( incx.NE.incxref ) THEN
2461 WRITE( argname, fmt = '(A)' ) 'INCX'
2462 ELSE IF( beta.NE.betaref ) THEN
2463 WRITE( argname, fmt = '(A)' ) 'BETA'
2464 ELSE IF( iy.NE.iyref ) THEN
2465 WRITE( argname, fmt = '(A)' ) 'IY'
2466 ELSE IF( jy.NE.jyref ) THEN
2467 WRITE( argname, fmt = '(A)' ) 'JY'
2468 ELSE IF( descy( dtype_ ).NE.descyref( dtype_ ) ) THEN
2469 WRITE( argname, fmt = '(A)' ) 'DESCY( DTYPE_ )'
2470 ELSE IF( descy( m_ ).NE.descyref( m_ ) ) THEN
2471 WRITE( argname, fmt = '(A)' ) 'DESCY( M_ )'
2472 ELSE IF( descy( n_ ).NE.descyref( n_ ) ) THEN
2473 WRITE( argname, fmt = '(A)' ) 'DESCY( N_ )'
2474 ELSE IF( descy( imb_ ).NE.descyref( imb_ ) ) THEN
2475 WRITE( argname, fmt = '(A)' ) 'DESCY( IMB_ )'
2476 ELSE IF( descy( inb_ ).NE.descyref( inb_ ) ) THEN
2477 WRITE( argname, fmt = '(A)' ) 'DESCY( INB_ )'
2478 ELSE IF( descy( mb_ ).NE.descyref( mb_ ) ) THEN
2479 WRITE( argname, fmt = '(A)' ) 'DESCY( MB_ )'
2480 ELSE IF( descy( nb_ ).NE.descyref( nb_ ) ) THEN
2481 WRITE( argname, fmt = '(A)' ) 'DESCY( NB_ )'
2482 ELSE IF( descy( rsrc_ ).NE.descyref( rsrc_ ) ) THEN
2483 WRITE( argname, fmt = '(A)' ) 'DESCY( RSRC_ )'
2484 ELSE IF( descy( csrc_ ).NE.descyref( csrc_ ) ) THEN
2485 WRITE( argname, fmt = '(A)' ) 'DESCY( CSRC_ )'
2486 ELSE IF( descy( ctxt_ ).NE.descyref( ctxt_ ) ) THEN
2487 WRITE( argname, fmt = '(A)' ) 'DESCY( CTXT_ )'
2488 ELSE IF( descy( lld_ ).NE.descyref( lld_ ) ) THEN
2489 WRITE( argname, fmt = '(A)' ) 'DESCY( LLD_ )'
2490 ELSE IF( incy.NE.incyref ) THEN
2491 WRITE( argname, fmt = '(A)' ) 'INCY'
2492 ELSE
2493 info = 0
2494 END IF
2495*
2496 CALL igsum2d( ictxt, 'all', ' ', 1, 1, INFO, 1, -1, 0 )
2497*
2498.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
2499*
2500.NE. IF( INFO0 ) THEN
2501 WRITE( NOUT, FMT = 9999 ) ARGNAME, SNAME
2502 ELSE
2503 WRITE( NOUT, FMT = 9998 ) SNAME
2504 END IF
2505*
2506 END IF
2507*
2508 END IF
2509*
2510 9999 FORMAT( 2X, ' ***** input-only parameter check: ', A,
2511 $ ' failed changed ', A, ' *****' )
2512 9998 FORMAT( 2X, ' ***** input-only parameter check: ', A,
2513 $ ' passed *****' )
2514*
2515 RETURN
2516*
2517* End of PDCHKARG2
2518*