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

Go to the source code of this file.

Functions/Subroutines

program pcbla2tst
subroutine pcbla2tstinfo (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 pcblas2tstchke (ltest, inout, nprocs)
subroutine pcchkarg2 (ictxt, nout, sname, uplo, trans, diag, m, n, alpha, ia, ja, desca, ix, jx, descx, incx, beta, iy, jy, descy, incy, info)
subroutine pcblas2tstchk (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

◆ pcbla2tst()

program pcbla2tst

Definition at line 11 of file pcblas2tst.f.

◆ pcbla2tstinfo()

subroutine pcbla2tstinfo ( 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,
complex alpha,
complex beta,
integer, dimension( * ) work )

Definition at line 1139 of file pcblas2tst.f.

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

◆ pcblas2tstchk()

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

Definition at line 2563 of file pcblas2tst.f.

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

◆ pcblas2tstchke()

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

Definition at line 2023 of file pcblas2tst.f.

2024*
2025* -- PBLAS test routine (version 2.0) --
2026* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2027* and University of California, Berkeley.
2028* April 1, 1998
2029*
2030* .. Scalar Arguments ..
2031 INTEGER INOUT, NPROCS
2032* ..
2033* .. Array Arguments ..
2034 LOGICAL LTEST( * )
2035* ..
2036*
2037* Purpose
2038* =======
2039*
2040* PCBLAS2TSTCHKE tests the error exits of the Level 2 PBLAS.
2041*
2042* Arguments
2043* =========
2044*
2045* LTEST (global input) LOGICAL array
2046* On entry, LTEST is an array of dimension at least 8 (NSUBS).
2047* If LTEST( 1 ) is .TRUE., PCGEMV will be tested;
2048* If LTEST( 2 ) is .TRUE., PCHEMV will be tested;
2049* If LTEST( 3 ) is .TRUE., PCTRMV will be tested;
2050* If LTEST( 4 ) is .TRUE., PCTRSV will be tested;
2051* If LTEST( 5 ) is .TRUE., PCGERU will be tested;
2052* If LTEST( 6 ) is .TRUE., PCGERC will be tested;
2053* If LTEST( 7 ) is .TRUE., PCHER will be tested;
2054* If LTEST( 8 ) is .TRUE., PCHER2 will be tested;
2055*
2056* INOUT (global input) INTEGER
2057* On entry, INOUT specifies the unit number for output file.
2058* When INOUT is 6, output to screen, when INOUT = 0, output to
2059* stderr. INOUT is only defined in process 0.
2060*
2061* NPROCS (global input) INTEGER
2062* On entry, NPROCS specifies the total number of processes cal-
2063* ling this routine.
2064*
2065* Calling sequence encodings
2066* ==========================
2067*
2068* code Formal argument list Examples
2069*
2070* 11 (n, v1,v2) _SWAP, _COPY
2071* 12 (n,s1, v1 ) _SCAL, _SCAL
2072* 13 (n,s1, v1,v2) _AXPY, _DOT_
2073* 14 (n,s1,i1,v1 ) _AMAX
2074* 15 (n,u1, v1 ) _ASUM, _NRM2
2075*
2076* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2077* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2078* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2079* 24 ( m,n,s1,v1,v2,m1) _GER_
2080* 25 (uplo, n,s1,v1, m1) _SYR
2081* 26 (uplo, n,u1,v1, m1) _HER
2082* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2083*
2084* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2085* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2086* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2087* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2088* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2089* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2090* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2091* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2092* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2093* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2094*
2095* -- Written on April 1, 1998 by
2096* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2097*
2098* =====================================================================
2099*
2100* .. Parameters ..
2101 INTEGER NSUBS
2102 parameter( nsubs = 8 )
2103* ..
2104* .. Local Scalars ..
2105 LOGICAL ABRTSAV
2106 INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
2107* ..
2108* .. Local Arrays ..
2109 INTEGER SCODE( NSUBS )
2110* ..
2111* .. External Subroutines ..
2112 EXTERNAL blacs_get, blacs_gridexit, blacs_gridinfo,
2113 $ blacs_gridinit, pcdimee, pcgemv, pcgerc,
2114 $ pcgeru, pchemv, pcher, pcher2, pcmatee,
2115 $ pcoptee, pctrmv, pctrsv, pcvecee
2116* ..
2117* .. Common Blocks ..
2118 LOGICAL ABRTFLG
2119 INTEGER NOUT
2120 CHARACTER*7 SNAMES( NSUBS )
2121 COMMON /snamec/snames
2122 COMMON /pberrorc/nout, abrtflg
2123* ..
2124* .. Data Statements ..
2125 DATA scode/21, 22, 23, 23, 24, 24, 26, 27/
2126* ..
2127* .. Executable Statements ..
2128*
2129* Temporarily define blacs grid to include all processes so
2130* information can be broadcast to all processes.
2131*
2132 CALL blacs_get( -1, 0, ictxt )
2133 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
2134 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2135*
2136* Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
2137* on errors during these tests and set the output device unit for
2138* it.
2139*
2140 abrtsav = abrtflg
2141 abrtflg = .false.
2142 nout = inout
2143*
2144* Test PCGEMV
2145*
2146 i = 1
2147 IF( ltest( i ) ) THEN
2148 CALL pcoptee( ictxt, nout, pcgemv, scode( i ), snames( i ) )
2149 CALL pcdimee( ictxt, nout, pcgemv, scode( i ), snames( i ) )
2150 CALL pcmatee( ictxt, nout, pcgemv, scode( i ), snames( i ) )
2151 CALL pcvecee( ictxt, nout, pcgemv, scode( i ), snames( i ) )
2152 END IF
2153*
2154* Test PCHEMV
2155*
2156 i = i + 1
2157 IF( ltest( i ) ) THEN
2158 CALL pcoptee( ictxt, nout, pchemv, scode( i ), snames( i ) )
2159 CALL pcdimee( ictxt, nout, pchemv, scode( i ), snames( i ) )
2160 CALL pcmatee( ictxt, nout, pchemv, scode( i ), snames( i ) )
2161 CALL pcvecee( ictxt, nout, pchemv, scode( i ), snames( i ) )
2162 END IF
2163*
2164* Test PCTRMV
2165*
2166 i = i + 1
2167 IF( ltest( i ) ) THEN
2168 CALL pcoptee( ictxt, nout, pctrmv, scode( i ), snames( i ) )
2169 CALL pcdimee( ictxt, nout, pctrmv, scode( i ), snames( i ) )
2170 CALL pcmatee( ictxt, nout, pctrmv, scode( i ), snames( i ) )
2171 CALL pcvecee( ictxt, nout, pctrmv, scode( i ), snames( i ) )
2172 END IF
2173*
2174* Test PCTRSV
2175*
2176 i = i + 1
2177 IF( ltest( i ) ) THEN
2178 CALL pcoptee( ictxt, nout, pctrsv, scode( i ), snames( i ) )
2179 CALL pcdimee( ictxt, nout, pctrsv, scode( i ), snames( i ) )
2180 CALL pcmatee( ictxt, nout, pctrsv, scode( i ), snames( i ) )
2181 CALL pcvecee( ictxt, nout, pctrsv, scode( i ), snames( i ) )
2182 END IF
2183*
2184* Test PCGERU
2185*
2186 i = i + 1
2187 IF( ltest( i ) ) THEN
2188 CALL pcdimee( ictxt, nout, pcgeru, scode( i ), snames( i ) )
2189 CALL pcvecee( ictxt, nout, pcgeru, scode( i ), snames( i ) )
2190 CALL pcmatee( ictxt, nout, pcgeru, scode( i ), snames( i ) )
2191 END IF
2192*
2193* Test PCGERC
2194*
2195 i = i + 1
2196 IF( ltest( i ) ) THEN
2197 CALL pcdimee( ictxt, nout, pcgerc, scode( i ), snames( i ) )
2198 CALL pcvecee( ictxt, nout, pcgerc, scode( i ), snames( i ) )
2199 CALL pcmatee( ictxt, nout, pcgerc, scode( i ), snames( i ) )
2200 END IF
2201*
2202* Test PCHER
2203*
2204 i = i + 1
2205 IF( ltest( i ) ) THEN
2206 CALL pcoptee( ictxt, nout, pcher, scode( i ), snames( i ) )
2207 CALL pcdimee( ictxt, nout, pcher, scode( i ), snames( i ) )
2208 CALL pcvecee( ictxt, nout, pcher, scode( i ), snames( i ) )
2209 CALL pcmatee( ictxt, nout, pcher, scode( i ), snames( i ) )
2210 END IF
2211*
2212* Test PCHER2
2213*
2214 i = i + 1
2215 IF( ltest( i ) ) THEN
2216 CALL pcoptee( ictxt, nout, pcher2, scode( i ), snames( i ) )
2217 CALL pcdimee( ictxt, nout, pcher2, scode( i ), snames( i ) )
2218 CALL pcvecee( ictxt, nout, pcher2, scode( i ), snames( i ) )
2219 CALL pcmatee( ictxt, nout, pcher2, scode( i ), snames( i ) )
2220 END IF
2221*
2222 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2223 $ WRITE( nout, fmt = 9999 )
2224*
2225 CALL blacs_gridexit( ictxt )
2226*
2227* Reset ABRTFLG to the value it had before calling this routine
2228*
2229 abrtflg = abrtsav
2230*
2231 9999 FORMAT( 2x, 'Error-exit tests completed.' )
2232*
2233 RETURN
2234*
2235* End of PCBLAS2TSTCHKE
2236*
pcvecee
subroutine pcvecee(ictxt, nout, subptr, scode, sname)
Definition pcblastst.f:936
pcmatee
subroutine pcmatee(ictxt, nout, subptr, scode, sname)
Definition pcblastst.f:1190
pcoptee
subroutine pcoptee(ictxt, nout, subptr, scode, sname)
Definition pcblastst.f:2
pcdimee
subroutine pcdimee(ictxt, nout, subptr, scode, sname)
Definition pcblastst.f:455

◆ pcchkarg2()

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

Definition at line 2238 of file pcblas2tst.f.

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