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

Go to the source code of this file.

Functions/Subroutines

program pzbla2tst
subroutine pzbla2tstinfo (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 pzblas2tstchke (ltest, inout, nprocs)
subroutine pzchkarg2 (ictxt, nout, sname, uplo, trans, diag, m, n, alpha, ia, ja, desca, ix, jx, descx, incx, beta, iy, jy, descy, incy, info)
subroutine pzblas2tstchk (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

◆ pzbla2tst()

program pzbla2tst

Definition at line 11 of file pzblas2tst.f.

◆ pzbla2tstinfo()

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

Definition at line 1138 of file pzblas2tst.f.

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

◆ pzblas2tstchk()

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

Definition at line 2562 of file pzblas2tst.f.

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

◆ pzblas2tstchke()

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

Definition at line 2022 of file pzblas2tst.f.

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

◆ pzchkarg2()

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

Definition at line 2237 of file pzblas2tst.f.

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