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

Go to the source code of this file.

Functions/Subroutines

program pdba3tst
subroutine pdbla3tstinfo (summry, nout, nmat, diagval, sideval, trnaval, trnbval, uploval, mval, nval, kval, maval, naval, imbaval, mbaval, inbaval, nbaval, rscaval, cscaval, iaval, javal, mbval, nbval, imbbval, mbbval, inbbval, nbbval, rscbval, cscbval, ibval, jbval, mcval, ncval, imbcval, mbcval, inbcval, nbcval, rsccval, csccval, icval, jcval, ldval, ngrids, pval, ldpval, qval, ldqval, nblog, ltest, sof, tee, iam, igap, iverb, nprocs, thresh, alpha, beta, work)
subroutine pdblas3tstchke (ltest, inout, nprocs)
subroutine pdchkarg3 (ictxt, nout, sname, side, uplo, transa, transb, diag, m, n, k, alpha, ia, ja, desca, ib, jb, descb, beta, ic, jc, descc, info)
subroutine pdblas3tstchk (ictxt, nout, nrout, side, uplo, transa, transb, diag, m, n, k, alpha, a, pa, ia, ja, desca, b, pb, ib, jb, descb, beta, c, pc, ic, jc, descc, thresh, rogue, work, info)

Function/Subroutine Documentation

◆ pdba3tst()

program pdba3tst

Definition at line 11 of file pdblas3tst.f.

◆ pdbla3tstinfo()

subroutine pdbla3tstinfo ( character*( * ) summry,
integer nout,
integer nmat,
character*1, dimension( ldval ) diagval,
character*1, dimension( ldval ) sideval,
character*1, dimension( ldval ) trnaval,
character*1, dimension( ldval ) trnbval,
character*1, dimension( ldval ) uploval,
integer, dimension( ldval ) mval,
integer, dimension( ldval ) nval,
integer, dimension( ldval ) kval,
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 ) mbval,
integer, dimension( ldval ) nbval,
integer, dimension( ldval ) imbbval,
integer, dimension( ldval ) mbbval,
integer, dimension( ldval ) inbbval,
integer, dimension( ldval ) nbbval,
integer, dimension( ldval ) rscbval,
integer, dimension( ldval ) cscbval,
integer, dimension( ldval ) ibval,
integer, dimension( ldval ) jbval,
integer, dimension( ldval ) mcval,
integer, dimension( ldval ) ncval,
integer, dimension( ldval ) imbcval,
integer, dimension( ldval ) mbcval,
integer, dimension( ldval ) inbcval,
integer, dimension( ldval ) nbcval,
integer, dimension( ldval ) rsccval,
integer, dimension( ldval ) csccval,
integer, dimension( ldval ) icval,
integer, dimension( ldval ) jcval,
integer ldval,
integer ngrids,
integer, dimension( ldpval ) pval,
integer ldpval,
integer, dimension( ldqval ) qval,
integer ldqval,
integer nblog,
logical, dimension( * ) ltest,
logical sof,
logical tee,
integer iam,
integer igap,
integer iverb,
integer nprocs,
real thresh,
double precision alpha,
double precision beta,
integer, dimension( * ) work )

Definition at line 1305 of file pdblas3tst.f.

1318*
1319* -- PBLAS test routine (version 2.0) --
1320* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1321* and University of California, Berkeley.
1322* April 1, 1998
1323*
1324* .. Scalar Arguments ..
1325 LOGICAL SOF, TEE
1326 INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL, NBLOG,
1327 $ NGRIDS, NMAT, NOUT, NPROCS
1328 REAL THRESH
1329 DOUBLE PRECISION ALPHA, BETA
1330* ..
1331* .. Array Arguments ..
1332 CHARACTER*( * ) SUMMRY
1333 CHARACTER*1 DIAGVAL( LDVAL ), SIDEVAL( LDVAL ),
1334 $ TRNAVAL( LDVAL ), TRNBVAL( LDVAL ),
1335 $ UPLOVAL( LDVAL )
1336 LOGICAL LTEST( * )
1337 INTEGER CSCAVAL( LDVAL ), CSCBVAL( LDVAL ),
1338 $ CSCCVAL( LDVAL ), IAVAL( LDVAL ),
1339 $ IBVAL( LDVAL ), ICVAL( LDVAL ),
1340 $ IMBAVAL( LDVAL ), IMBBVAL( LDVAL ),
1341 $ IMBCVAL( LDVAL ), INBAVAL( LDVAL ),
1342 $ INBBVAL( LDVAL ), INBCVAL( LDVAL ),
1343 $ JAVAL( LDVAL ), JBVAL( LDVAL ), JCVAL( LDVAL ),
1344 $ KVAL( LDVAL ), MAVAL( LDVAL ), MBAVAL( LDVAL ),
1345 $ MBBVAL( LDVAL ), MBCVAL( LDVAL ),
1346 $ MBVAL( LDVAL ), MCVAL( LDVAL ), MVAL( LDVAL ),
1347 $ NAVAL( LDVAL ), NBAVAL( LDVAL ),
1348 $ NBBVAL( LDVAL ), NBCVAL( LDVAL ),
1349 $ NBVAL( LDVAL ), NCVAL( LDVAL ), NVAL( LDVAL ),
1350 $ PVAL( LDPVAL ), QVAL( LDQVAL ),
1351 $ RSCAVAL( LDVAL ), RSCBVAL( LDVAL ),
1352 $ RSCCVAL( LDVAL ), WORK( * )
1353* ..
1354*
1355* Purpose
1356* =======
1357*
1358* PDBLA3TSTINFO get the needed startup information for testing various
1359* Level 3 PBLAS routines, and transmits it to all processes.
1360*
1361* Notes
1362* =====
1363*
1364* For packing the information we assumed that the length in bytes of an
1365* integer is equal to the length in bytes of a real single precision.
1366*
1367* Arguments
1368* =========
1369*
1370* SUMMRY (global output) CHARACTER*(*)
1371* On exit, SUMMRY is the name of output (summary) file (if
1372* any). SUMMRY is only defined for process 0.
1373*
1374* NOUT (global output) INTEGER
1375* On exit, NOUT specifies the unit number for the output file.
1376* When NOUT is 6, output to screen, when NOUT is 0, output to
1377* stderr. NOUT is only defined for process 0.
1378*
1379* NMAT (global output) INTEGER
1380* On exit, NMAT specifies the number of different test cases.
1381*
1382* DIAGVAL (global output) CHARACTER array
1383* On entry, DIAGVAL is an array of dimension LDVAL. On exit,
1384* this array contains the values of DIAG to run the code with.
1385*
1386* SIDEVAL (global output) CHARACTER array
1387* On entry, SIDEVAL is an array of dimension LDVAL. On exit,
1388* this array contains the values of SIDE to run the code with.
1389*
1390* TRNAVAL (global output) CHARACTER array
1391* On entry, TRNAVAL is an array of dimension LDVAL. On exit,
1392* this array contains the values of TRANSA to run the code
1393* with.
1394*
1395* TRNBVAL (global output) CHARACTER array
1396* On entry, TRNBVAL is an array of dimension LDVAL. On exit,
1397* this array contains the values of TRANSB to run the code
1398* with.
1399*
1400* UPLOVAL (global output) CHARACTER array
1401* On entry, UPLOVAL is an array of dimension LDVAL. On exit,
1402* this array contains the values of UPLO to run the code with.
1403*
1404* MVAL (global output) INTEGER array
1405* On entry, MVAL is an array of dimension LDVAL. On exit, this
1406* array contains the values of M to run the code with.
1407*
1408* NVAL (global output) INTEGER array
1409* On entry, NVAL is an array of dimension LDVAL. On exit, this
1410* array contains the values of N to run the code with.
1411*
1412* KVAL (global output) INTEGER array
1413* On entry, KVAL is an array of dimension LDVAL. On exit, this
1414* array contains the values of K to run the code with.
1415*
1416* MAVAL (global output) INTEGER array
1417* On entry, MAVAL is an array of dimension LDVAL. On exit, this
1418* array contains the values of DESCA( M_ ) to run the code
1419* with.
1420*
1421* NAVAL (global output) INTEGER array
1422* On entry, NAVAL is an array of dimension LDVAL. On exit, this
1423* array contains the values of DESCA( N_ ) to run the code
1424* with.
1425*
1426* IMBAVAL (global output) INTEGER array
1427* On entry, IMBAVAL is an array of dimension LDVAL. On exit,
1428* this array contains the values of DESCA( IMB_ ) to run the
1429* code with.
1430*
1431* MBAVAL (global output) INTEGER array
1432* On entry, MBAVAL is an array of dimension LDVAL. On exit,
1433* this array contains the values of DESCA( MB_ ) to run the
1434* code with.
1435*
1436* INBAVAL (global output) INTEGER array
1437* On entry, INBAVAL is an array of dimension LDVAL. On exit,
1438* this array contains the values of DESCA( INB_ ) to run the
1439* code with.
1440*
1441* NBAVAL (global output) INTEGER array
1442* On entry, NBAVAL is an array of dimension LDVAL. On exit,
1443* this array contains the values of DESCA( NB_ ) to run the
1444* code with.
1445*
1446* RSCAVAL (global output) INTEGER array
1447* On entry, RSCAVAL is an array of dimension LDVAL. On exit,
1448* this array contains the values of DESCA( RSRC_ ) to run the
1449* code with.
1450*
1451* CSCAVAL (global output) INTEGER array
1452* On entry, CSCAVAL is an array of dimension LDVAL. On exit,
1453* this array contains the values of DESCA( CSRC_ ) to run the
1454* code with.
1455*
1456* IAVAL (global output) INTEGER array
1457* On entry, IAVAL is an array of dimension LDVAL. On exit, this
1458* array contains the values of IA to run the code with.
1459*
1460* JAVAL (global output) INTEGER array
1461* On entry, JAVAL is an array of dimension LDVAL. On exit, this
1462* array contains the values of JA to run the code with.
1463*
1464* MBVAL (global output) INTEGER array
1465* On entry, MBVAL is an array of dimension LDVAL. On exit, this
1466* array contains the values of DESCB( M_ ) to run the code
1467* with.
1468*
1469* NBVAL (global output) INTEGER array
1470* On entry, NBVAL is an array of dimension LDVAL. On exit, this
1471* array contains the values of DESCB( N_ ) to run the code
1472* with.
1473*
1474* IMBBVAL (global output) INTEGER array
1475* On entry, IMBBVAL is an array of dimension LDVAL. On exit,
1476* this array contains the values of DESCB( IMB_ ) to run the
1477* code with.
1478*
1479* MBBVAL (global output) INTEGER array
1480* On entry, MBBVAL is an array of dimension LDVAL. On exit,
1481* this array contains the values of DESCB( MB_ ) to run the
1482* code with.
1483*
1484* INBBVAL (global output) INTEGER array
1485* On entry, INBBVAL is an array of dimension LDVAL. On exit,
1486* this array contains the values of DESCB( INB_ ) to run the
1487* code with.
1488*
1489* NBBVAL (global output) INTEGER array
1490* On entry, NBBVAL is an array of dimension LDVAL. On exit,
1491* this array contains the values of DESCB( NB_ ) to run the
1492* code with.
1493*
1494* RSCBVAL (global output) INTEGER array
1495* On entry, RSCBVAL is an array of dimension LDVAL. On exit,
1496* this array contains the values of DESCB( RSRC_ ) to run the
1497* code with.
1498*
1499* CSCBVAL (global output) INTEGER array
1500* On entry, CSCBVAL is an array of dimension LDVAL. On exit,
1501* this array contains the values of DESCB( CSRC_ ) to run the
1502* code with.
1503*
1504* IBVAL (global output) INTEGER array
1505* On entry, IBVAL is an array of dimension LDVAL. On exit, this
1506* array contains the values of IB to run the code with.
1507*
1508* JBVAL (global output) INTEGER array
1509* On entry, JBVAL is an array of dimension LDVAL. On exit, this
1510* array contains the values of JB to run the code with.
1511*
1512* MCVAL (global output) INTEGER array
1513* On entry, MCVAL is an array of dimension LDVAL. On exit, this
1514* array contains the values of DESCC( M_ ) to run the code
1515* with.
1516*
1517* NCVAL (global output) INTEGER array
1518* On entry, NCVAL is an array of dimension LDVAL. On exit, this
1519* array contains the values of DESCC( N_ ) to run the code
1520* with.
1521*
1522* IMBCVAL (global output) INTEGER array
1523* On entry, IMBCVAL is an array of dimension LDVAL. On exit,
1524* this array contains the values of DESCC( IMB_ ) to run the
1525* code with.
1526*
1527* MBCVAL (global output) INTEGER array
1528* On entry, MBCVAL is an array of dimension LDVAL. On exit,
1529* this array contains the values of DESCC( MB_ ) to run the
1530* code with.
1531*
1532* INBCVAL (global output) INTEGER array
1533* On entry, INBCVAL is an array of dimension LDVAL. On exit,
1534* this array contains the values of DESCC( INB_ ) to run the
1535* code with.
1536*
1537* NBCVAL (global output) INTEGER array
1538* On entry, NBCVAL is an array of dimension LDVAL. On exit,
1539* this array contains the values of DESCC( NB_ ) to run the
1540* code with.
1541*
1542* RSCCVAL (global output) INTEGER array
1543* On entry, RSCCVAL is an array of dimension LDVAL. On exit,
1544* this array contains the values of DESCC( RSRC_ ) to run the
1545* code with.
1546*
1547* CSCCVAL (global output) INTEGER array
1548* On entry, CSCCVAL is an array of dimension LDVAL. On exit,
1549* this array contains the values of DESCC( CSRC_ ) to run the
1550* code with.
1551*
1552* ICVAL (global output) INTEGER array
1553* On entry, ICVAL is an array of dimension LDVAL. On exit, this
1554* array contains the values of IC to run the code with.
1555*
1556* JCVAL (global output) INTEGER array
1557* On entry, JCVAL is an array of dimension LDVAL. On exit, this
1558* array contains the values of JC to run the code with.
1559*
1560* LDVAL (global input) INTEGER
1561* On entry, LDVAL specifies the maximum number of different va-
1562* lues that can be used for DIAG, SIDE, TRANSA, TRANSB, UPLO,
1563* M, N, K, DESCA(:), IA, JA, DESCB(:), IB, JB, DESCC(:), IC,
1564* JC. This is also the maximum number of test cases.
1565*
1566* NGRIDS (global output) INTEGER
1567* On exit, NGRIDS specifies the number of different values that
1568* can be used for P and Q.
1569*
1570* PVAL (global output) INTEGER array
1571* On entry, PVAL is an array of dimension LDPVAL. On exit, this
1572* array contains the values of P to run the code with.
1573*
1574* LDPVAL (global input) INTEGER
1575* On entry, LDPVAL specifies the maximum number of different
1576* values that can be used for P.
1577*
1578* QVAL (global output) INTEGER array
1579* On entry, QVAL is an array of dimension LDQVAL. On exit, this
1580* array contains the values of Q to run the code with.
1581*
1582* LDQVAL (global input) INTEGER
1583* On entry, LDQVAL specifies the maximum number of different
1584* values that can be used for Q.
1585*
1586* NBLOG (global output) INTEGER
1587* On exit, NBLOG specifies the logical computational block size
1588* to run the tests with. NBLOG must be at least one.
1589*
1590* LTEST (global output) LOGICAL array
1591* On entry, LTEST is an array of dimension at least eight. On
1592* exit, if LTEST( i ) is .TRUE., the i-th Level 3 PBLAS routine
1593* will be tested. See the input file for the ordering of the
1594* routines.
1595*
1596* SOF (global output) LOGICAL
1597* On exit, if SOF is .TRUE., the tester will stop on the first
1598* detected failure. Otherwise, it won't.
1599*
1600* TEE (global output) LOGICAL
1601* On exit, if TEE is .TRUE., the tester will perform the error
1602* exit tests. These tests won't be performed otherwise.
1603*
1604* IAM (local input) INTEGER
1605* On entry, IAM specifies the number of the process executing
1606* this routine.
1607*
1608* IGAP (global output) INTEGER
1609* On exit, IGAP specifies the user-specified gap used for pad-
1610* ding. IGAP must be at least zero.
1611*
1612* IVERB (global output) INTEGER
1613* On exit, IVERB specifies the output verbosity level: 0 for
1614* pass/fail, 1, 2 or 3 for matrix dump on errors.
1615*
1616* NPROCS (global input) INTEGER
1617* On entry, NPROCS specifies the total number of processes.
1618*
1619* THRESH (global output) REAL
1620* On exit, THRESH specifies the threshhold value for the test
1621* ratio.
1622*
1623* ALPHA (global output) DOUBLE PRECISION
1624* On exit, ALPHA specifies the value of alpha to be used in all
1625* the test cases.
1626*
1627* BETA (global output) DOUBLE PRECISION
1628* On exit, BETA specifies the value of beta to be used in all
1629* the test cases.
1630*
1631* WORK (local workspace) INTEGER array
1632* On entry, WORK is an array of dimension at least
1633* MAX( 3, 2*NGRIDS+38*NMAT+NSUBS+4 ) with NSUBS equal to 8.
1634* This array is used to pack all output arrays in order to send
1635* the information in one message.
1636*
1637* -- Written on April 1, 1998 by
1638* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1639*
1640* =====================================================================
1641*
1642* .. Parameters ..
1643 INTEGER NIN, NSUBS
1644 parameter( nin = 11, nsubs = 8 )
1645* ..
1646* .. Local Scalars ..
1647 LOGICAL LTESTT
1648 INTEGER I, ICTXT, J
1649 DOUBLE PRECISION EPS
1650* ..
1651* .. Local Arrays ..
1652 CHARACTER*7 SNAMET
1653 CHARACTER*79 USRINFO
1654* ..
1655* .. External Subroutines ..
1656 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1657 $ blacs_gridinit, blacs_setup, dgebr2d, dgebs2d,
1658 $ icopy, igebr2d, igebs2d, sgebr2d, sgebs2d
1659* ..
1660* .. External Functions ..
1661 DOUBLE PRECISION PDLAMCH
1662 EXTERNAL pdlamch
1663* ..
1664* .. Intrinsic Functions ..
1665 INTRINSIC char, ichar, max, min
1666* ..
1667* .. Common Blocks ..
1668 CHARACTER*7 SNAMES( NSUBS )
1669 COMMON /snamec/snames
1670* ..
1671* .. Executable Statements ..
1672*
1673* Process 0 reads the input data, broadcasts to other processes and
1674* writes needed information to NOUT
1675*
1676 IF( iam.EQ.0 ) THEN
1677*
1678* Open file and skip data file header
1679*
1680 OPEN( nin, file='PDBLAS3TST.dat', status='OLD' )
1681 READ( nin, fmt = * ) summry
1682 summry = ' '
1683*
1684* Read in user-supplied info about machine type, compiler, etc.
1685*
1686 READ( nin, fmt = 9999 ) usrinfo
1687*
1688* Read name and unit number for summary output file
1689*
1690 READ( nin, fmt = * ) summry
1691 READ( nin, fmt = * ) nout
1692 IF( nout.NE.0 .AND. nout.NE.6 )
1693 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1694*
1695* Read and check the parameter values for the tests.
1696*
1697* Read the flag that indicates if Stop on Failure
1698*
1699 READ( nin, fmt = * ) sof
1700*
1701* Read the flag that indicates if Test Error Exits
1702*
1703 READ( nin, fmt = * ) tee
1704*
1705* Read the verbosity level
1706*
1707 READ( nin, fmt = * ) iverb
1708 IF( iverb.LT.0 .OR. iverb.GT.3 )
1709 $ iverb = 0
1710*
1711* Read the leading dimension gap
1712*
1713 READ( nin, fmt = * ) igap
1714 IF( igap.LT.0 )
1715 $ igap = 0
1716*
1717* Read the threshold value for test ratio
1718*
1719 READ( nin, fmt = * ) thresh
1720 IF( thresh.LT.0.0 )
1721 $ thresh = 16.0
1722*
1723* Get logical computational block size
1724*
1725 READ( nin, fmt = * ) nblog
1726 IF( nblog.LT.1 )
1727 $ nblog = 32
1728*
1729* Get number of grids
1730*
1731 READ( nin, fmt = * ) ngrids
1732 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1733 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1734 GO TO 120
1735 ELSE IF( ngrids.GT.ldqval ) THEN
1736 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1737 GO TO 120
1738 END IF
1739*
1740* Get values of P and Q
1741*
1742 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1743 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1744*
1745* Read ALPHA, BETA
1746*
1747 READ( nin, fmt = * ) alpha
1748 READ( nin, fmt = * ) beta
1749*
1750* Read number of tests.
1751*
1752 READ( nin, fmt = * ) nmat
1753 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1754 WRITE( nout, fmt = 9998 ) 'Tests', ldval
1755 GO TO 120
1756 ENDIF
1757*
1758* Read in input data into arrays.
1759*
1760 READ( nin, fmt = * ) ( diagval( i ), i = 1, nmat )
1761 READ( nin, fmt = * ) ( sideval( i ), i = 1, nmat )
1762 READ( nin, fmt = * ) ( trnaval( i ), i = 1, nmat )
1763 READ( nin, fmt = * ) ( trnbval( i ), i = 1, nmat )
1764 READ( nin, fmt = * ) ( uploval( i ), i = 1, nmat )
1765 READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
1766 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1767 READ( nin, fmt = * ) ( kval( i ), i = 1, nmat )
1768 READ( nin, fmt = * ) ( maval( i ), i = 1, nmat )
1769 READ( nin, fmt = * ) ( naval( i ), i = 1, nmat )
1770 READ( nin, fmt = * ) ( imbaval( i ), i = 1, nmat )
1771 READ( nin, fmt = * ) ( inbaval( i ), i = 1, nmat )
1772 READ( nin, fmt = * ) ( mbaval( i ), i = 1, nmat )
1773 READ( nin, fmt = * ) ( nbaval( i ), i = 1, nmat )
1774 READ( nin, fmt = * ) ( rscaval( i ), i = 1, nmat )
1775 READ( nin, fmt = * ) ( cscaval( i ), i = 1, nmat )
1776 READ( nin, fmt = * ) ( iaval( i ), i = 1, nmat )
1777 READ( nin, fmt = * ) ( javal( i ), i = 1, nmat )
1778 READ( nin, fmt = * ) ( mbval( i ), i = 1, nmat )
1779 READ( nin, fmt = * ) ( nbval( i ), i = 1, nmat )
1780 READ( nin, fmt = * ) ( imbbval( i ), i = 1, nmat )
1781 READ( nin, fmt = * ) ( inbbval( i ), i = 1, nmat )
1782 READ( nin, fmt = * ) ( mbbval( i ), i = 1, nmat )
1783 READ( nin, fmt = * ) ( nbbval( i ), i = 1, nmat )
1784 READ( nin, fmt = * ) ( rscbval( i ), i = 1, nmat )
1785 READ( nin, fmt = * ) ( cscbval( i ), i = 1, nmat )
1786 READ( nin, fmt = * ) ( ibval( i ), i = 1, nmat )
1787 READ( nin, fmt = * ) ( jbval( i ), i = 1, nmat )
1788 READ( nin, fmt = * ) ( mcval( i ), i = 1, nmat )
1789 READ( nin, fmt = * ) ( ncval( i ), i = 1, nmat )
1790 READ( nin, fmt = * ) ( imbcval( i ), i = 1, nmat )
1791 READ( nin, fmt = * ) ( inbcval( i ), i = 1, nmat )
1792 READ( nin, fmt = * ) ( mbcval( i ), i = 1, nmat )
1793 READ( nin, fmt = * ) ( nbcval( i ), i = 1, nmat )
1794 READ( nin, fmt = * ) ( rsccval( i ), i = 1, nmat )
1795 READ( nin, fmt = * ) ( csccval( i ), i = 1, nmat )
1796 READ( nin, fmt = * ) ( icval( i ), i = 1, nmat )
1797 READ( nin, fmt = * ) ( jcval( i ), i = 1, nmat )
1798*
1799* Read names of subroutines and flags which indicate
1800* whether they are to be tested.
1801*
1802 DO 10 i = 1, nsubs
1803 ltest( i ) = .false.
1804 10 CONTINUE
1805 20 CONTINUE
1806 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1807 DO 30 i = 1, nsubs
1808 IF( snamet.EQ.snames( i ) )
1809 $ GO TO 40
1810 30 CONTINUE
1811*
1812 WRITE( nout, fmt = 9995 )snamet
1813 GO TO 120
1814*
1815 40 CONTINUE
1816 ltest( i ) = ltestt
1817 GO TO 20
1818*
1819 50 CONTINUE
1820*
1821* Close input file
1822*
1823 CLOSE ( nin )
1824*
1825* For pvm only: if virtual machine not set up, allocate it and
1826* spawn the correct number of processes.
1827*
1828 IF( nprocs.LT.1 ) THEN
1829 nprocs = 0
1830 DO 60 i = 1, ngrids
1831 nprocs = max( nprocs, pval( i )*qval( i ) )
1832 60 CONTINUE
1833 CALL blacs_setup( iam, nprocs )
1834 END IF
1835*
1836* Temporarily define blacs grid to include all processes so
1837* information can be broadcast to all processes
1838*
1839 CALL blacs_get( -1, 0, ictxt )
1840 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1841*
1842* Compute machine epsilon
1843*
1844 eps = pdlamch( ictxt, 'eps' )
1845*
1846* Pack information arrays and broadcast
1847*
1848 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
1849 CALL dgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
1850 CALL dgebs2d( ictxt, 'All', ' ', 1, 1, beta, 1 )
1851*
1852 work( 1 ) = ngrids
1853 work( 2 ) = nmat
1854 work( 3 ) = nblog
1855 CALL igebs2d( ictxt, 'All', ' ', 3, 1, work, 3 )
1856*
1857 i = 1
1858 IF( sof ) THEN
1859 work( i ) = 1
1860 ELSE
1861 work( i ) = 0
1862 END IF
1863 i = i + 1
1864 IF( tee ) THEN
1865 work( i ) = 1
1866 ELSE
1867 work( i ) = 0
1868 END IF
1869 i = i + 1
1870 work( i ) = iverb
1871 i = i + 1
1872 work( i ) = igap
1873 i = i + 1
1874 DO 70 j = 1, nmat
1875 work( i ) = ichar( diagval( j ) )
1876 work( i+1 ) = ichar( sideval( j ) )
1877 work( i+2 ) = ichar( trnaval( j ) )
1878 work( i+3 ) = ichar( trnbval( j ) )
1879 work( i+4 ) = ichar( uploval( j ) )
1880 i = i + 5
1881 70 CONTINUE
1882 CALL icopy( ngrids, pval, 1, work( i ), 1 )
1883 i = i + ngrids
1884 CALL icopy( ngrids, qval, 1, work( i ), 1 )
1885 i = i + ngrids
1886 CALL icopy( nmat, mval, 1, work( i ), 1 )
1887 i = i + nmat
1888 CALL icopy( nmat, nval, 1, work( i ), 1 )
1889 i = i + nmat
1890 CALL icopy( nmat, kval, 1, work( i ), 1 )
1891 i = i + nmat
1892 CALL icopy( nmat, maval, 1, work( i ), 1 )
1893 i = i + nmat
1894 CALL icopy( nmat, naval, 1, work( i ), 1 )
1895 i = i + nmat
1896 CALL icopy( nmat, imbaval, 1, work( i ), 1 )
1897 i = i + nmat
1898 CALL icopy( nmat, inbaval, 1, work( i ), 1 )
1899 i = i + nmat
1900 CALL icopy( nmat, mbaval, 1, work( i ), 1 )
1901 i = i + nmat
1902 CALL icopy( nmat, nbaval, 1, work( i ), 1 )
1903 i = i + nmat
1904 CALL icopy( nmat, rscaval, 1, work( i ), 1 )
1905 i = i + nmat
1906 CALL icopy( nmat, cscaval, 1, work( i ), 1 )
1907 i = i + nmat
1908 CALL icopy( nmat, iaval, 1, work( i ), 1 )
1909 i = i + nmat
1910 CALL icopy( nmat, javal, 1, work( i ), 1 )
1911 i = i + nmat
1912 CALL icopy( nmat, mbval, 1, work( i ), 1 )
1913 i = i + nmat
1914 CALL icopy( nmat, nbval, 1, work( i ), 1 )
1915 i = i + nmat
1916 CALL icopy( nmat, imbbval, 1, work( i ), 1 )
1917 i = i + nmat
1918 CALL icopy( nmat, inbbval, 1, work( i ), 1 )
1919 i = i + nmat
1920 CALL icopy( nmat, mbbval, 1, work( i ), 1 )
1921 i = i + nmat
1922 CALL icopy( nmat, nbbval, 1, work( i ), 1 )
1923 i = i + nmat
1924 CALL icopy( nmat, rscbval, 1, work( i ), 1 )
1925 i = i + nmat
1926 CALL icopy( nmat, cscbval, 1, work( i ), 1 )
1927 i = i + nmat
1928 CALL icopy( nmat, ibval, 1, work( i ), 1 )
1929 i = i + nmat
1930 CALL icopy( nmat, jbval, 1, work( i ), 1 )
1931 i = i + nmat
1932 CALL icopy( nmat, mcval, 1, work( i ), 1 )
1933 i = i + nmat
1934 CALL icopy( nmat, ncval, 1, work( i ), 1 )
1935 i = i + nmat
1936 CALL icopy( nmat, imbcval, 1, work( i ), 1 )
1937 i = i + nmat
1938 CALL icopy( nmat, inbcval, 1, work( i ), 1 )
1939 i = i + nmat
1940 CALL icopy( nmat, mbcval, 1, work( i ), 1 )
1941 i = i + nmat
1942 CALL icopy( nmat, nbcval, 1, work( i ), 1 )
1943 i = i + nmat
1944 CALL icopy( nmat, rsccval, 1, work( i ), 1 )
1945 i = i + nmat
1946 CALL icopy( nmat, csccval, 1, work( i ), 1 )
1947 i = i + nmat
1948 CALL icopy( nmat, icval, 1, work( i ), 1 )
1949 i = i + nmat
1950 CALL icopy( nmat, jcval, 1, work( i ), 1 )
1951 i = i + nmat
1952*
1953 DO 80 j = 1, nsubs
1954 IF( ltest( j ) ) THEN
1955 work( i ) = 1
1956 ELSE
1957 work( i ) = 0
1958 END IF
1959 i = i + 1
1960 80 CONTINUE
1961 i = i - 1
1962 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
1963*
1964* regurgitate input
1965*
1966 WRITE( nout, fmt = 9999 ) 'Level 3 PBLAS testing program.'
1967 WRITE( nout, fmt = 9999 ) usrinfo
1968 WRITE( nout, fmt = * )
1969 WRITE( nout, fmt = 9999 )
1970 $ 'Tests of the real double precision '//
1971 $ 'Level 3 PBLAS'
1972 WRITE( nout, fmt = * )
1973 WRITE( nout, fmt = 9993 ) nmat
1974 WRITE( nout, fmt = 9979 ) nblog
1975 WRITE( nout, fmt = 9992 ) ngrids
1976 WRITE( nout, fmt = 9990 )
1977 $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
1978 IF( ngrids.GT.5 )
1979 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 6,
1980 $ min( 10, ngrids ) )
1981 IF( ngrids.GT.10 )
1982 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 11,
1983 $ min( 15, ngrids ) )
1984 IF( ngrids.GT.15 )
1985 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 16, ngrids )
1986 WRITE( nout, fmt = 9990 )
1987 $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
1988 IF( ngrids.GT.5 )
1989 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 6,
1990 $ min( 10, ngrids ) )
1991 IF( ngrids.GT.10 )
1992 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 11,
1993 $ min( 15, ngrids ) )
1994 IF( ngrids.GT.15 )
1995 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 16, ngrids )
1996 WRITE( nout, fmt = 9988 ) sof
1997 WRITE( nout, fmt = 9987 ) tee
1998 WRITE( nout, fmt = 9983 ) igap
1999 WRITE( nout, fmt = 9986 ) iverb
2000 WRITE( nout, fmt = 9980 ) thresh
2001 WRITE( nout, fmt = 9982 ) alpha
2002 WRITE( nout, fmt = 9981 ) beta
2003 IF( ltest( 1 ) ) THEN
2004 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... Yes'
2005 ELSE
2006 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... No '
2007 END IF
2008 DO 90 i = 2, nsubs
2009 IF( ltest( i ) ) THEN
2010 WRITE( nout, fmt = 9984 ) snames( i ), ' ... Yes'
2011 ELSE
2012 WRITE( nout, fmt = 9984 ) snames( i ), ' ... No '
2013 END IF
2014 90 CONTINUE
2015 WRITE( nout, fmt = 9994 ) eps
2016 WRITE( nout, fmt = * )
2017*
2018 ELSE
2019*
2020* If in pvm, must participate setting up virtual machine
2021*
2022 IF( nprocs.LT.1 )
2023 $ CALL blacs_setup( iam, nprocs )
2024*
2025* Temporarily define blacs grid to include all processes so
2026* information can be broadcast to all processes
2027*
2028 CALL blacs_get( -1, 0, ictxt )
2029 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
2030*
2031* Compute machine epsilon
2032*
2033 eps = pdlamch( ictxt, 'eps' )
2034*
2035 CALL sgebr2d( ictxt, 'All', ' ', 1, 1, thresh, 1, 0, 0 )
2036 CALL dgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
2037 CALL dgebr2d( ictxt, 'All', ' ', 1, 1, beta, 1, 0, 0 )
2038*
2039 CALL igebr2d( ictxt, 'All', ' ', 3, 1, work, 3, 0, 0 )
2040 ngrids = work( 1 )
2041 nmat = work( 2 )
2042 nblog = work( 3 )
2043*
2044 i = 2*ngrids + 38*nmat + nsubs + 4
2045 CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
2046*
2047 i = 1
2048 IF( work( i ).EQ.1 ) THEN
2049 sof = .true.
2050 ELSE
2051 sof = .false.
2052 END IF
2053 i = i + 1
2054 IF( work( i ).EQ.1 ) THEN
2055 tee = .true.
2056 ELSE
2057 tee = .false.
2058 END IF
2059 i = i + 1
2060 iverb = work( i )
2061 i = i + 1
2062 igap = work( i )
2063 i = i + 1
2064 DO 100 j = 1, nmat
2065 diagval( j ) = char( work( i ) )
2066 sideval( j ) = char( work( i+1 ) )
2067 trnaval( j ) = char( work( i+2 ) )
2068 trnbval( j ) = char( work( i+3 ) )
2069 uploval( j ) = char( work( i+4 ) )
2070 i = i + 5
2071 100 CONTINUE
2072 CALL icopy( ngrids, work( i ), 1, pval, 1 )
2073 i = i + ngrids
2074 CALL icopy( ngrids, work( i ), 1, qval, 1 )
2075 i = i + ngrids
2076 CALL icopy( nmat, work( i ), 1, mval, 1 )
2077 i = i + nmat
2078 CALL icopy( nmat, work( i ), 1, nval, 1 )
2079 i = i + nmat
2080 CALL icopy( nmat, work( i ), 1, kval, 1 )
2081 i = i + nmat
2082 CALL icopy( nmat, work( i ), 1, maval, 1 )
2083 i = i + nmat
2084 CALL icopy( nmat, work( i ), 1, naval, 1 )
2085 i = i + nmat
2086 CALL icopy( nmat, work( i ), 1, imbaval, 1 )
2087 i = i + nmat
2088 CALL icopy( nmat, work( i ), 1, inbaval, 1 )
2089 i = i + nmat
2090 CALL icopy( nmat, work( i ), 1, mbaval, 1 )
2091 i = i + nmat
2092 CALL icopy( nmat, work( i ), 1, nbaval, 1 )
2093 i = i + nmat
2094 CALL icopy( nmat, work( i ), 1, rscaval, 1 )
2095 i = i + nmat
2096 CALL icopy( nmat, work( i ), 1, cscaval, 1 )
2097 i = i + nmat
2098 CALL icopy( nmat, work( i ), 1, iaval, 1 )
2099 i = i + nmat
2100 CALL icopy( nmat, work( i ), 1, javal, 1 )
2101 i = i + nmat
2102 CALL icopy( nmat, work( i ), 1, mbval, 1 )
2103 i = i + nmat
2104 CALL icopy( nmat, work( i ), 1, nbval, 1 )
2105 i = i + nmat
2106 CALL icopy( nmat, work( i ), 1, imbbval, 1 )
2107 i = i + nmat
2108 CALL icopy( nmat, work( i ), 1, inbbval, 1 )
2109 i = i + nmat
2110 CALL icopy( nmat, work( i ), 1, mbbval, 1 )
2111 i = i + nmat
2112 CALL icopy( nmat, work( i ), 1, nbbval, 1 )
2113 i = i + nmat
2114 CALL icopy( nmat, work( i ), 1, rscbval, 1 )
2115 i = i + nmat
2116 CALL icopy( nmat, work( i ), 1, cscbval, 1 )
2117 i = i + nmat
2118 CALL icopy( nmat, work( i ), 1, ibval, 1 )
2119 i = i + nmat
2120 CALL icopy( nmat, work( i ), 1, jbval, 1 )
2121 i = i + nmat
2122 CALL icopy( nmat, work( i ), 1, mcval, 1 )
2123 i = i + nmat
2124 CALL icopy( nmat, work( i ), 1, ncval, 1 )
2125 i = i + nmat
2126 CALL icopy( nmat, work( i ), 1, imbcval, 1 )
2127 i = i + nmat
2128 CALL icopy( nmat, work( i ), 1, inbcval, 1 )
2129 i = i + nmat
2130 CALL icopy( nmat, work( i ), 1, mbcval, 1 )
2131 i = i + nmat
2132 CALL icopy( nmat, work( i ), 1, nbcval, 1 )
2133 i = i + nmat
2134 CALL icopy( nmat, work( i ), 1, rsccval, 1 )
2135 i = i + nmat
2136 CALL icopy( nmat, work( i ), 1, csccval, 1 )
2137 i = i + nmat
2138 CALL icopy( nmat, work( i ), 1, icval, 1 )
2139 i = i + nmat
2140 CALL icopy( nmat, work( i ), 1, jcval, 1 )
2141 i = i + nmat
2142*
2143 DO 110 j = 1, nsubs
2144 IF( work( i ).EQ.1 ) THEN
2145 ltest( j ) = .true.
2146 ELSE
2147 ltest( j ) = .false.
2148 END IF
2149 i = i + 1
2150 110 CONTINUE
2151*
2152 END IF
2153*
2154 CALL blacs_gridexit( ictxt )
2155*
2156 RETURN
2157*
2158 120 WRITE( nout, fmt = 9997 )
2159 CLOSE( nin )
2160 IF( nout.NE.6 .AND. nout.NE.0 )
2161 $ CLOSE( nout )
2162 CALL blacs_abort( ictxt, 1 )
2163*
2164 stop
2165*
2166 9999 FORMAT( a )
2167 9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
2168 $ 'than ', i2 )
2169 9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
2170 9996 FORMAT( a7, l2 )
2171 9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
2172 $ /' ******* TESTS ABANDONED *******' )
2173 9994 FORMAT( 2x, 'Relative machine precision (eps) is taken to be ',
2174 $ e18.6 )
2175 9993 FORMAT( 2x, 'Number of Tests : ', i6 )
2176 9992 FORMAT( 2x, 'Number of process grids : ', i6 )
2177 9991 FORMAT( 2x, ' : ', 5i6 )
2178 9990 FORMAT( 2x, a1, ' : ', 5i6 )
2179 9988 FORMAT( 2x, 'Stop on failure flag : ', l6 )
2180 9987 FORMAT( 2x, 'Test for error exits flag : ', l6 )
2181 9986 FORMAT( 2x, 'Verbosity level : ', i6 )
2182 9985 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
2183 9984 FORMAT( 2x, ' ', a, a8 )
2184 9983 FORMAT( 2x, 'Leading dimension gap : ', i6 )
2185 9982 FORMAT( 2x, 'Alpha : ', g16.6 )
2186 9981 FORMAT( 2x, 'Beta : ', g16.6 )
2187 9980 FORMAT( 2x, 'Threshold value : ', g16.6 )
2188 9979 FORMAT( 2x, 'Logical block size : ', i6 )
2189*
2190* End of PDBLA3TSTINFO
2191*
alpha
#define alpha
Definition eval.h:35
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
sgebs2d
subroutine sgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1072
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
dgebs2d
subroutine dgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1082
dgebr2d
subroutine dgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1123
sgebr2d
subroutine sgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1113
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769

◆ pdblas3tstchk()

subroutine pdblas3tstchk ( integer ictxt,
integer nout,
integer nrout,
character*1 side,
character*1 uplo,
character*1 transa,
character*1 transb,
character*1 diag,
integer m,
integer n,
integer k,
double precision alpha,
double precision, dimension( * ) a,
double precision, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
double precision, dimension( * ) b,
double precision, dimension( * ) pb,
integer ib,
integer jb,
integer, dimension( * ) descb,
double precision beta,
double precision, dimension( * ) c,
double precision, dimension( * ) pc,
integer ic,
integer jc,
integer, dimension( * ) descc,
real thresh,
double precision rogue,
double precision, dimension( * ) work,
integer info )

Definition at line 2732 of file pdblas3tst.f.

2737*
2738* -- PBLAS test routine (version 2.0) --
2739* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2740* and University of California, Berkeley.
2741* April 1, 1998
2742*
2743* .. Scalar Arguments ..
2744 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2745 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2746 $ NOUT, NROUT
2747 REAL THRESH
2748 DOUBLE PRECISION ALPHA, BETA, ROGUE
2749* ..
2750* .. Array Arguments ..
2751 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2752 DOUBLE PRECISION A( * ), B( * ), C( * ), PA( * ), PB( * ),
2753 $ PC( * ), WORK( * )
2754* ..
2755*
2756* Purpose
2757* =======
2758*
2759* PDBLAS3TSTCHK performs the computational tests of the Level 3 PBLAS.
2760*
2761* Notes
2762* =====
2763*
2764* A description vector is associated with each 2D block-cyclicly dis-
2765* tributed matrix. This vector stores the information required to
2766* establish the mapping between a matrix entry and its corresponding
2767* process and memory location.
2768*
2769* In the following comments, the character _ should be read as
2770* "of the distributed matrix". Let A be a generic term for any 2D
2771* block cyclicly distributed matrix. Its description vector is DESCA:
2772*
2773* NOTATION STORED IN EXPLANATION
2774* ---------------- --------------- ------------------------------------
2775* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2776* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2777* the NPROW x NPCOL BLACS process grid
2778* A is distributed over. The context
2779* itself is global, but the handle
2780* (the integer value) may vary.
2781* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2782* ted matrix A, M_A >= 0.
2783* N_A (global) DESCA( N_ ) The number of columns in the distri-
2784* buted matrix A, N_A >= 0.
2785* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2786* block of the matrix A, IMB_A > 0.
2787* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2788* left block of the matrix A,
2789* INB_A > 0.
2790* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2791* bute the last M_A-IMB_A rows of A,
2792* MB_A > 0.
2793* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2794* bute the last N_A-INB_A columns of
2795* A, NB_A > 0.
2796* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2797* row of the matrix A is distributed,
2798* NPROW > RSRC_A >= 0.
2799* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2800* first column of A is distributed.
2801* NPCOL > CSRC_A >= 0.
2802* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2803* array storing the local blocks of
2804* the distributed matrix A,
2805* IF( Lc( 1, N_A ) > 0 )
2806* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2807* ELSE
2808* LLD_A >= 1.
2809*
2810* Let K be the number of rows of a matrix A starting at the global in-
2811* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2812* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2813* receive if these K rows were distributed over NPROW processes. If K
2814* is the number of columns of a matrix A starting at the global index
2815* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2816* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2817* these K columns were distributed over NPCOL processes.
2818*
2819* The values of Lr() and Lc() may be determined via a call to the func-
2820* tion PB_NUMROC:
2821* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2822* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2823*
2824* Arguments
2825* =========
2826*
2827* ICTXT (local input) INTEGER
2828* On entry, ICTXT specifies the BLACS context handle, indica-
2829* ting the global context of the operation. The context itself
2830* is global, but the value of ICTXT is local.
2831*
2832* NOUT (global input) INTEGER
2833* On entry, NOUT specifies the unit number for the output file.
2834* When NOUT is 6, output to screen, when NOUT is 0, output to
2835* stderr. NOUT is only defined for process 0.
2836*
2837* NROUT (global input) INTEGER
2838* On entry, NROUT specifies which routine will be tested as
2839* follows:
2840* If NROUT = 1, PDGEMM will be tested;
2841* else if NROUT = 2, PDSYMM will be tested;
2842* else if NROUT = 3, PDSYRK will be tested;
2843* else if NROUT = 4, PDSYR2K will be tested;
2844* else if NROUT = 5, PDTRMM will be tested;
2845* else if NROUT = 6, PDTRSM will be tested;
2846* else if NROUT = 7, PDGEADD will be tested;
2847* else if NROUT = 8, PDTRADD will be tested;
2848*
2849* SIDE (global input) CHARACTER*1
2850* On entry, SIDE specifies if the multiplication should be per-
2851* formed from the left or the right.
2852*
2853* UPLO (global input) CHARACTER*1
2854* On entry, UPLO specifies if the upper or lower part of the
2855* matrix operand is to be referenced.
2856*
2857* TRANSA (global input) CHARACTER*1
2858* On entry, TRANSA specifies if the matrix operand A is to be
2859* transposed.
2860*
2861* TRANSB (global input) CHARACTER*1
2862* On entry, TRANSB specifies if the matrix operand B is to be
2863* transposed.
2864*
2865* DIAG (global input) CHARACTER*1
2866* On entry, DIAG specifies if the triangular matrix operand is
2867* unit or non-unit.
2868*
2869* M (global input) INTEGER
2870* On entry, M specifies the number of rows of C.
2871*
2872* N (global input) INTEGER
2873* On entry, N specifies the number of columns of C.
2874*
2875* K (global input) INTEGER
2876* On entry, K specifies the number of columns (resp. rows) of A
2877* when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
2878* PxSYR2K, PxHERK and PxHER2K.
2879*
2880* ALPHA (global input) DOUBLE PRECISION
2881* On entry, ALPHA specifies the scalar alpha.
2882*
2883* A (local input/local output) DOUBLE PRECISION array
2884* On entry, A is an array of dimension (DESCA( M_ ),*). This
2885* array contains a local copy of the initial entire matrix PA.
2886*
2887* PA (local input) DOUBLE PRECISION array
2888* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
2889* array contains the local entries of the matrix PA.
2890*
2891* IA (global input) INTEGER
2892* On entry, IA specifies A's global row index, which points to
2893* the beginning of the submatrix sub( A ).
2894*
2895* JA (global input) INTEGER
2896* On entry, JA specifies A's global column index, which points
2897* to the beginning of the submatrix sub( A ).
2898*
2899* DESCA (global and local input) INTEGER array
2900* On entry, DESCA is an integer array of dimension DLEN_. This
2901* is the array descriptor for the matrix A.
2902*
2903* B (local input/local output) DOUBLE PRECISION array
2904* On entry, B is an array of dimension (DESCB( M_ ),*). This
2905* array contains a local copy of the initial entire matrix PB.
2906*
2907* PB (local input) DOUBLE PRECISION array
2908* On entry, PB is an array of dimension (DESCB( LLD_ ),*). This
2909* array contains the local entries of the matrix PB.
2910*
2911* IB (global input) INTEGER
2912* On entry, IB specifies B's global row index, which points to
2913* the beginning of the submatrix sub( B ).
2914*
2915* JB (global input) INTEGER
2916* On entry, JB specifies B's global column index, which points
2917* to the beginning of the submatrix sub( B ).
2918*
2919* DESCB (global and local input) INTEGER array
2920* On entry, DESCB is an integer array of dimension DLEN_. This
2921* is the array descriptor for the matrix B.
2922*
2923* BETA (global input) DOUBLE PRECISION
2924* On entry, BETA specifies the scalar beta.
2925*
2926* C (local input/local output) DOUBLE PRECISION array
2927* On entry, C is an array of dimension (DESCC( M_ ),*). This
2928* array contains a local copy of the initial entire matrix PC.
2929*
2930* PC (local input) DOUBLE PRECISION array
2931* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
2932* array contains the local pieces of the matrix PC.
2933*
2934* IC (global input) INTEGER
2935* On entry, IC specifies C's global row index, which points to
2936* the beginning of the submatrix sub( C ).
2937*
2938* JC (global input) INTEGER
2939* On entry, JC specifies C's global column index, which points
2940* to the beginning of the submatrix sub( C ).
2941*
2942* DESCC (global and local input) INTEGER array
2943* On entry, DESCC is an integer array of dimension DLEN_. This
2944* is the array descriptor for the matrix C.
2945*
2946* THRESH (global input) REAL
2947* On entry, THRESH is the threshold value for the test ratio.
2948*
2949* ROGUE (global input) DOUBLE PRECISION
2950* On entry, ROGUE specifies the constant used to pad the
2951* non-referenced part of triangular or symmetric matrices.
2952*
2953* WORK (workspace) DOUBLE PRECISION array
2954* On entry, WORK is an array of dimension LWORK where LWORK is
2955* at least 2*MAX( M, MAX( N, K ) ). This array is used to store
2956* a copy of a column of C and the computed gauges (see PDMMCH).
2957*
2958* INFO (global output) INTEGER
2959* On exit, if INFO = 0, no error has been found, otherwise
2960* if( MOD( INFO, 2 ) = 1 ) then an error on A has been found,
2961* if( MOD( INFO/2, 2 ) = 1 ) then an error on B has been found,
2962* if( MOD( INFO/4, 2 ) = 1 ) then an error on C has been found.
2963*
2964* -- Written on April 1, 1998 by
2965* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2966*
2967* =====================================================================
2968*
2969* .. Parameters ..
2970 DOUBLE PRECISION ONE, ZERO
2971 parameter( one = 1.0d+0, zero = 0.0d+0 )
2972 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2973 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2974 $ RSRC_
2975 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2976 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2977 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2978 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2979* ..
2980* .. Local Scalars ..
2981 INTEGER I, IPG, MYCOL, MYROW, NPCOL, NPROW
2982 DOUBLE PRECISION ERR
2983* ..
2984* .. Local Arrays ..
2985 INTEGER IERR( 3 )
2986* ..
2987* .. External Subroutines ..
2988 EXTERNAL blacs_gridinfo, dtrsm, pb_dlaset, pdchkmin,
2989 $ pdmmch, pdmmch1, pdmmch2, pdmmch3, pdtrmm
2990* ..
2991* .. External Functions ..
2992 LOGICAL LSAME
2993 EXTERNAL lsame
2994* ..
2995* .. Intrinsic Functions ..
2996 INTRINSIC dble
2997* ..
2998* .. Executable Statements ..
2999*
3000 info = 0
3001*
3002* Quick return if possible
3003*
3004 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
3005 $ RETURN
3006*
3007* Start the operations
3008*
3009 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3010*
3011 DO 10 i = 1, 3
3012 ierr( i ) = 0
3013 10 CONTINUE
3014 ipg = max( m, max( n, k ) ) + 1
3015*
3016 IF( nrout.EQ.1 ) THEN
3017*
3018* Test PDGEMM
3019*
3020* Check the resulting matrix C
3021*
3022 CALL pdmmch( ictxt, transa, transb, m, n, k, alpha, a, ia, ja,
3023 $ desca, b, ib, jb, descb, beta, c, pc, ic, jc,
3024 $ descc, work, work( ipg ), err, ierr( 3 ) )
3025*
3026 IF( ierr( 3 ).NE.0 ) THEN
3027 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3028 $ WRITE( nout, fmt = 9998 )
3029 ELSE IF( err.GT.dble( thresh ) ) THEN
3030 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3031 $ WRITE( nout, fmt = 9997 ) err
3032 END IF
3033*
3034* Check the input-only arguments
3035*
3036 IF( lsame( transa, 'N' ) ) THEN
3037 CALL pdchkmin( err, m, k, a, pa, ia, ja, desca, ierr( 1 ) )
3038 ELSE
3039 CALL pdchkmin( err, k, m, a, pa, ia, ja, desca, ierr( 1 ) )
3040 END IF
3041 IF( lsame( transb, 'N' ) ) THEN
3042 CALL pdchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3043 ELSE
3044 CALL pdchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3045 END IF
3046*
3047 ELSE IF( nrout.EQ.2 ) THEN
3048*
3049* Test PDSYMM
3050*
3051* Check the resulting matrix C
3052*
3053 IF( lsame( side, 'L' ) ) THEN
3054 CALL pdmmch( ictxt, 'No transpose', 'No transpose', m, n, m,
3055 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3056 $ beta, c, pc, ic, jc, descc, work, work( ipg ),
3057 $ err, ierr( 3 ) )
3058 ELSE
3059 CALL pdmmch( ictxt, 'No transpose', 'No transpose', m, n, n,
3060 $ alpha, b, ib, jb, descb, a, ia, ja, desca,
3061 $ beta, c, pc, ic, jc, descc, work, work( ipg ),
3062 $ err, ierr( 3 ) )
3063 END IF
3064*
3065 IF( ierr( 3 ).NE.0 ) THEN
3066 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3067 $ WRITE( nout, fmt = 9998 )
3068 ELSE IF( err.GT.dble( thresh ) ) THEN
3069 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3070 $ WRITE( nout, fmt = 9997 ) err
3071 END IF
3072*
3073* Check the input-only arguments
3074*
3075 IF( lsame( uplo, 'L' ) ) THEN
3076 IF( lsame( side, 'L' ) ) THEN
3077 CALL pb_dlaset( 'upper', M-1, M-1, 0, ROGUE, ROGUE,
3078 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3079 ELSE
3080 CALL PB_DLASET( 'upper', N-1, N-1, 0, ROGUE, ROGUE,
3081 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3082 END IF
3083 ELSE
3084 IF( LSAME( SIDE, 'l' ) ) THEN
3085 CALL PB_DLASET( 'lower', M-1, M-1, 0, ROGUE, ROGUE,
3086 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3087 $ DESCA( M_ ) )
3088 ELSE
3089 CALL PB_DLASET( 'lower', N-1, N-1, 0, ROGUE, ROGUE,
3090 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3091 $ DESCA( M_ ) )
3092 END IF
3093 END IF
3094*
3095 IF( LSAME( SIDE, 'l' ) ) THEN
3096 CALL PDCHKMIN( ERR, M, M, A, PA, IA, JA, DESCA, IERR( 1 ) )
3097 ELSE
3098 CALL PDCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
3099 END IF
3100 CALL PDCHKMIN( ERR, M, N, B, PB, IB, JB, DESCB, IERR( 2 ) )
3101*
3102.EQ. ELSE IF( NROUT3 ) THEN
3103*
3104* Test PDSYRK
3105*
3106* Check the resulting matrix C
3107*
3108 IF( LSAME( TRANSA, 'n' ) ) THEN
3109 CALL PDMMCH1( ICTXT, UPLO, 'no transpose', N, K, ALPHA, A,
3110 $ IA, JA, DESCA, BETA, C, PC, IC, JC, DESCC,
3111 $ WORK, WORK( IPG ), ERR, IERR( 3 ) )
3112 ELSE
3113 CALL PDMMCH1( ICTXT, UPLO, 'transpose', N, K, ALPHA, A, IA,
3114 $ JA, DESCA, BETA, C, PC, IC, JC, DESCC, WORK,
3115 $ WORK( IPG ), ERR, IERR( 3 ) )
3116 END IF
3117*
3118.NE. IF( IERR( 3 )0 ) THEN
3119.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3120 $ WRITE( NOUT, FMT = 9998 )
3121.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3122.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3123 $ WRITE( NOUT, FMT = 9997 ) ERR
3124 END IF
3125*
3126* Check the input-only arguments
3127*
3128 IF( LSAME( TRANSA, 'n' ) ) THEN
3129 CALL PDCHKMIN( ERR, N, K, A, PA, IA, JA, DESCA, IERR( 1 ) )
3130 ELSE
3131 CALL PDCHKMIN( ERR, K, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
3132 END IF
3133*
3134.EQ. ELSE IF( NROUT4 ) THEN
3135*
3136* Test PDSYR2K
3137*
3138* Check the resulting matrix C
3139*
3140 IF( LSAME( TRANSA, 'n' ) ) THEN
3141 CALL PDMMCH2( ICTXT, UPLO, 'no transpose', N, K, ALPHA, A,
3142 $ IA, JA, DESCA, B, IB, JB, DESCB, BETA, C, PC,
3143 $ IC, JC, DESCC, WORK, WORK( IPG ), ERR,
3144 $ IERR( 3 ) )
3145 ELSE
3146 CALL PDMMCH2( ICTXT, UPLO, 'transpose', N, K, ALPHA, A,
3147 $ IA, JA, DESCA, B, IB, JB, DESCB, BETA, C, PC,
3148 $ IC, JC, DESCC, WORK, WORK( IPG ), ERR,
3149 $ IERR( 3 ) )
3150 END IF
3151*
3152.NE. IF( IERR( 3 )0 ) THEN
3153.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3154 $ WRITE( NOUT, FMT = 9998 )
3155.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3156.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3157 $ WRITE( NOUT, FMT = 9997 ) ERR
3158 END IF
3159*
3160* Check the input-only arguments
3161*
3162 IF( LSAME( TRANSA, 'n' ) ) THEN
3163 CALL PDCHKMIN( ERR, N, K, A, PA, IA, JA, DESCA, IERR( 1 ) )
3164 CALL PDCHKMIN( ERR, N, K, B, PB, IB, JB, DESCB, IERR( 2 ) )
3165 ELSE
3166 CALL PDCHKMIN( ERR, K, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
3167 CALL PDCHKMIN( ERR, K, N, B, PB, IB, JB, DESCB, IERR( 2 ) )
3168 END IF
3169*
3170.EQ. ELSE IF( NROUT5 ) THEN
3171*
3172* Test PDTRMM
3173*
3174* Check the resulting matrix B
3175*
3176 IF( LSAME( SIDE, 'l' ) ) THEN
3177 CALL PDMMCH( ICTXT, TRANSA, 'no transpose', M, N, M,
3178 $ ALPHA, A, IA, JA, DESCA, C, IB, JB, DESCB,
3179 $ ZERO, B, PB, IB, JB, DESCB, WORK,
3180 $ WORK( IPG ), ERR, IERR( 2 ) )
3181 ELSE
3182 CALL PDMMCH( ICTXT, 'no transpose', TRANSA, M, N, N,
3183 $ ALPHA, C, IB, JB, DESCB, A, IA, JA, DESCA,
3184 $ ZERO, B, PB, IB, JB, DESCB, WORK,
3185 $ WORK( IPG ), ERR, IERR( 2 ) )
3186 END IF
3187*
3188.NE. IF( IERR( 2 )0 ) THEN
3189.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3190 $ WRITE( NOUT, FMT = 9998 )
3191.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3192.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3193 $ WRITE( NOUT, FMT = 9997 ) ERR
3194 END IF
3195*
3196* Check the input-only arguments
3197*
3198 IF( LSAME( SIDE, 'l' ) ) THEN
3199 IF( LSAME( UPLO, 'l' ) ) THEN
3200 IF( LSAME( DIAG, 'n' ) ) THEN
3201 CALL PB_DLASET( 'upper', M-1, M-1, 0, ROGUE, ROGUE,
3202 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3203 ELSE
3204 CALL PB_DLASET( 'upper', M, M, 0, ROGUE, ONE,
3205 $ A( IA+(JA-1)*DESCA( M_ ) ),
3206 $ DESCA( M_ ) )
3207 END IF
3208 ELSE
3209 IF( LSAME( DIAG, 'n' ) ) THEN
3210 CALL PB_DLASET( 'lower', M-1, M-1, 0, ROGUE, ROGUE,
3211 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3212 $ DESCA( M_ ) )
3213 ELSE
3214 CALL PB_DLASET( 'lower', M, M, 0, ROGUE, ONE,
3215 $ A( IA+(JA-1)*DESCA( M_ ) ),
3216 $ DESCA( M_ ) )
3217 END IF
3218 END IF
3219 CALL PDCHKMIN( ERR, M, M, A, PA, IA, JA, DESCA, IERR( 1 ) )
3220 ELSE
3221 IF( LSAME( UPLO, 'l' ) ) THEN
3222 IF( LSAME( DIAG, 'n' ) ) THEN
3223 CALL PB_DLASET( 'upper', N-1, N-1, 0, ROGUE, ROGUE,
3224 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3225 ELSE
3226 CALL PB_DLASET( 'upper', N, N, 0, ROGUE, ONE,
3227 $ A( IA+(JA-1)*DESCA( M_ ) ),
3228 $ DESCA( M_ ) )
3229 END IF
3230 ELSE
3231 IF( LSAME( DIAG, 'n' ) ) THEN
3232 CALL PB_DLASET( 'lower', N-1, N-1, 0, ROGUE, ROGUE,
3233 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3234 $ DESCA( M_ ) )
3235 ELSE
3236 CALL PB_DLASET( 'lower', N, N, 0, ROGUE, ONE,
3237 $ A( IA+(JA-1)*DESCA( M_ ) ),
3238 $ DESCA( M_ ) )
3239 END IF
3240 END IF
3241 CALL PDCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
3242 END IF
3243*
3244.EQ. ELSE IF( NROUT6 ) THEN
3245*
3246* Test PDTRSM
3247*
3248* Check the resulting matrix B
3249*
3250 CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
3251 $ A( IA+(JA-1)*DESCA( M_ ) ), DESCA( M_ ),
3252 $ B( IB+(JB-1)*DESCB( M_ ) ), DESCB( M_ ) )
3253 CALL PDTRMM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, PA, IA, JA,
3254 $ DESCA, PB, IB, JB, DESCB )
3255 IF( LSAME( SIDE, 'l' ) ) THEN
3256 CALL PDMMCH( ICTXT, TRANSA, 'no transpose', M, N, M, ALPHA,
3257 $ A, IA, JA, DESCA, B, IB, JB, DESCB, ZERO, C,
3258 $ PB, IB, JB, DESCB, WORK, WORK( IPG ), ERR,
3259 $ IERR( 2 ) )
3260 ELSE
3261 CALL PDMMCH( ICTXT, 'no transpose', TRANSA, M, N, N, ALPHA,
3262 $ B, IB, JB, DESCB, A, IA, JA, DESCA, ZERO, C,
3263 $ PB, IB, JB, DESCB, WORK, WORK( IPG ), ERR,
3264 $ IERR( 2 ) )
3265 END IF
3266*
3267.NE. IF( IERR( 2 )0 ) THEN
3268.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3269 $ WRITE( NOUT, FMT = 9998 )
3270.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3271.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3272 $ WRITE( NOUT, FMT = 9997 ) ERR
3273 END IF
3274*
3275* Check the input-only arguments
3276*
3277 IF( LSAME( SIDE, 'l' ) ) THEN
3278 IF( LSAME( UPLO, 'l' ) ) THEN
3279 IF( LSAME( DIAG, 'n' ) ) THEN
3280 CALL PB_DLASET( 'upper', M-1, M-1, 0, ROGUE, ROGUE,
3281 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3282 ELSE
3283 CALL PB_DLASET( 'upper', M, M, 0, ROGUE, ONE,
3284 $ A( IA+(JA-1)*DESCA( M_ ) ),
3285 $ DESCA( M_ ) )
3286 END IF
3287 ELSE
3288 IF( LSAME( DIAG, 'n' ) ) THEN
3289 CALL PB_DLASET( 'lower', M-1, M-1, 0, ROGUE, ROGUE,
3290 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3291 $ DESCA( M_ ) )
3292 ELSE
3293 CALL PB_DLASET( 'lower', M, M, 0, ROGUE, ONE,
3294 $ A( IA+(JA-1)*DESCA( M_ ) ),
3295 $ DESCA( M_ ) )
3296 END IF
3297 END IF
3298 CALL PDCHKMIN( ERR, M, M, A, PA, IA, JA, DESCA, IERR( 1 ) )
3299 ELSE
3300 IF( LSAME( UPLO, 'l' ) ) THEN
3301 IF( LSAME( DIAG, 'n' ) ) THEN
3302 CALL pb_dlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3303 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3304 ELSE
3305 CALL pb_dlaset( 'Upper', n, n, 0, rogue, one,
3306 $ a( ia+(ja-1)*desca( m_ ) ),
3307 $ desca( m_ ) )
3308 END IF
3309 ELSE
3310 IF( lsame( diag, 'N' ) ) THEN
3311 CALL pb_dlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3312 $ a( ia+1+(ja-1)*desca( m_ ) ),
3313 $ desca( m_ ) )
3314 ELSE
3315 CALL pb_dlaset( 'Lower', n, n, 0, rogue, one,
3316 $ a( ia+(ja-1)*desca( m_ ) ),
3317 $ desca( m_ ) )
3318 END IF
3319 END IF
3320 CALL pdchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3321 END IF
3322 ELSE IF( nrout.EQ.7 ) THEN
3323*
3324* Test PDGEADD
3325*
3326* Check the resulting matrix C
3327*
3328 CALL pdmmch3( 'All', transa, m, n, alpha, a, ia, ja, desca,
3329 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3330*
3331* Check the input-only arguments
3332*
3333 IF( lsame( transa, 'N' ) ) THEN
3334 CALL pdchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3335 ELSE
3336 CALL pdchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3337 END IF
3338*
3339 ELSE IF( nrout.EQ.8 ) THEN
3340*
3341* Test PDTRADD
3342*
3343* Check the resulting matrix C
3344*
3345 CALL pdmmch3( uplo, transa, m, n, alpha, a, ia, ja, desca,
3346 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3347*
3348* Check the input-only arguments
3349*
3350 IF( lsame( transa, 'N' ) ) THEN
3351 CALL pdchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3352 ELSE
3353 CALL pdchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3354 END IF
3355*
3356 END IF
3357*
3358 IF( ierr( 1 ).NE.0 ) THEN
3359 info = info + 1
3360 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3361 $ WRITE( nout, fmt = 9999 ) 'A'
3362 END IF
3363*
3364 IF( ierr( 2 ).NE.0 ) THEN
3365 info = info + 2
3366 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3367 $ WRITE( nout, fmt = 9999 ) 'B'
3368 END IF
3369*
3370 IF( ierr( 3 ).NE.0 ) THEN
3371 info = info + 4
3372 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3373 $ WRITE( nout, fmt = 9999 ) 'C'
3374 END IF
3375*
3376 9999 FORMAT( 2x, ' ***** ERROR: Matrix operand ', a,
3377 $ ' is incorrect.' )
3378 9998 FORMAT( 2x, ' ***** FATAL ERROR - Computed result is less ',
3379 $ 'than half accurate *****' )
3380 9997 FORMAT( 2x, ' ***** Test completed with maximum test ratio: ',
3381 $ f11.5, ' SUSPECT *****' )
3382*
3383 RETURN
3384*
3385* End of PDBLAS3TSTCHK
3386*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
dtrsm
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pdmmch2
subroutine pdmmch2(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pdblastst.f:5996
pdmmch
subroutine pdmmch(ictxt, transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pdblastst.f:5272
pb_dlaset
subroutine pb_dlaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pdblastst.f:9359
pdmmch3
subroutine pdmmch3(uplo, trans, m, n, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, err, info)
Definition pdblastst.f:6372
pdmmch1
subroutine pdmmch1(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pdblastst.f:5649
pdchkmin
subroutine pdchkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition pdblastst.f:3326
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ pdblas3tstchke()

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

Definition at line 2193 of file pdblas3tst.f.

2194*
2195* -- PBLAS test routine (version 2.0) --
2196* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2197* and University of California, Berkeley.
2198* April 1, 1998
2199*
2200* .. Scalar Arguments ..
2201 INTEGER INOUT, NPROCS
2202* ..
2203* .. Array Arguments ..
2204 LOGICAL LTEST( * )
2205* ..
2206*
2207* Purpose
2208* =======
2209*
2210* PDBLAS3TSTCHKE tests the error exits of the Level 3 PBLAS.
2211*
2212* Arguments
2213* =========
2214*
2215* LTEST (global input) LOGICAL array
2216* On entry, LTEST is an array of dimension at least 7 (NSUBS).
2217* If LTEST( 1 ) is .TRUE., PDGEMM will be tested;
2218* If LTEST( 2 ) is .TRUE., PDSYMM will be tested;
2219* If LTEST( 3 ) is .TRUE., PDSYRK will be tested;
2220* If LTEST( 4 ) is .TRUE., PDSYR2K will be tested;
2221* If LTEST( 5 ) is .TRUE., PDTRMM will be tested;
2222* If LTEST( 6 ) is .TRUE., PDTRSM will be tested;
2223* If LTEST( 7 ) is .TRUE., PDGEADD will be tested;
2224* If LTEST( 8 ) is .TRUE., PDTRADD will be tested;
2225*
2226* INOUT (global input) INTEGER
2227* On entry, INOUT specifies the unit number for output file.
2228* When INOUT is 6, output to screen, when INOUT = 0, output to
2229* stderr. INOUT is only defined in process 0.
2230*
2231* NPROCS (global input) INTEGER
2232* On entry, NPROCS specifies the total number of processes cal-
2233* ling this routine.
2234*
2235* Calling sequence encodings
2236* ==========================
2237*
2238* code Formal argument list Examples
2239*
2240* 11 (n, v1,v2) _SWAP, _COPY
2241* 12 (n,s1, v1 ) _SCAL, _SCAL
2242* 13 (n,s1, v1,v2) _AXPY, _DOT_
2243* 14 (n,s1,i1,v1 ) _AMAX
2244* 15 (n,u1, v1 ) _ASUM, _NRM2
2245*
2246* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2247* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2248* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2249* 24 ( m,n,s1,v1,v2,m1) _GER_
2250* 25 (uplo, n,s1,v1, m1) _SYR
2251* 26 (uplo, n,u1,v1, m1) _HER
2252* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2253*
2254* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2255* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2256* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2257* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2258* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2259* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2260* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2261* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2262* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2263* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2264*
2265* -- Written on April 1, 1998 by
2266* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2267*
2268* =====================================================================
2269*
2270* .. Parameters ..
2271 INTEGER NSUBS
2272 parameter( nsubs = 8 )
2273* ..
2274* .. Local Scalars ..
2275 LOGICAL ABRTSAV
2276 INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
2277* ..
2278* .. Local Arrays ..
2279 INTEGER SCODE( NSUBS )
2280* ..
2281* .. External Subroutines ..
2282 EXTERNAL blacs_get, blacs_gridexit, blacs_gridinfo,
2283 $ blacs_gridinit, pddimee, pdgeadd, pdgemm,
2284 $ pdmatee, pdoptee, pdsymm, pdsyr2k, pdsyrk,
2285 $ pdtradd, pdtrmm, pdtrsm
2286* ..
2287* .. Common Blocks ..
2288 LOGICAL ABRTFLG
2289 INTEGER NOUT
2290 CHARACTER*7 SNAMES( NSUBS )
2291 COMMON /snamec/snames
2292 COMMON /pberrorc/nout, abrtflg
2293* ..
2294* .. Data Statements ..
2295 DATA scode/31, 32, 33, 35, 38, 38, 39, 40/
2296* ..
2297* .. Executable Statements ..
2298*
2299* Temporarily define blacs grid to include all processes so
2300* information can be broadcast to all processes.
2301*
2302 CALL blacs_get( -1, 0, ictxt )
2303 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
2304 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2305*
2306* Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
2307* on errors during these tests and set the output device unit for
2308* it.
2309*
2310 abrtsav = abrtflg
2311 abrtflg = .false.
2312 nout = inout
2313*
2314* Test PDGEMM
2315*
2316 i = 1
2317 IF( ltest( i ) ) THEN
2318 CALL pdoptee( ictxt, nout, pdgemm, scode( i ), snames( i ) )
2319 CALL pddimee( ictxt, nout, pdgemm, scode( i ), snames( i ) )
2320 CALL pdmatee( ictxt, nout, pdgemm, scode( i ), snames( i ) )
2321 END IF
2322*
2323* Test PDSYMM
2324*
2325 i = i + 1
2326 IF( ltest( i ) ) THEN
2327 CALL pdoptee( ictxt, nout, pdsymm, scode( i ), snames( i ) )
2328 CALL pddimee( ictxt, nout, pdsymm, scode( i ), snames( i ) )
2329 CALL pdmatee( ictxt, nout, pdsymm, scode( i ), snames( i ) )
2330 END IF
2331*
2332* Test PDSYRK
2333*
2334 i = i + 1
2335 IF( ltest( i ) ) THEN
2336 CALL pdoptee( ictxt, nout, pdsyrk, scode( i ), snames( i ) )
2337 CALL pddimee( ictxt, nout, pdsyrk, scode( i ), snames( i ) )
2338 CALL pdmatee( ictxt, nout, pdsyrk, scode( i ), snames( i ) )
2339 END IF
2340*
2341* Test PDSYR2K
2342*
2343 i = i + 1
2344 IF( ltest( i ) ) THEN
2345 CALL pdoptee( ictxt, nout, pdsyr2k, scode( i ), snames( i ) )
2346 CALL pddimee( ictxt, nout, pdsyr2k, scode( i ), snames( i ) )
2347 CALL pdmatee( ictxt, nout, pdsyr2k, scode( i ), snames( i ) )
2348 END IF
2349*
2350* Test PDTRMM
2351*
2352 i = i + 1
2353 IF( ltest( i ) ) THEN
2354 CALL pdoptee( ictxt, nout, pdtrmm, scode( i ), snames( i ) )
2355 CALL pddimee( ictxt, nout, pdtrmm, scode( i ), snames( i ) )
2356 CALL pdmatee( ictxt, nout, pdtrmm, scode( i ), snames( i ) )
2357 END IF
2358*
2359* Test PDTRSM
2360*
2361 i = i + 1
2362 IF( ltest( i ) ) THEN
2363 CALL pdoptee( ictxt, nout, pdtrsm, scode( i ), snames( i ) )
2364 CALL pddimee( ictxt, nout, pdtrsm, scode( i ), snames( i ) )
2365 CALL pdmatee( ictxt, nout, pdtrsm, scode( i ), snames( i ) )
2366 END IF
2367*
2368* Test PDGEADD
2369*
2370 i = i + 1
2371 IF( ltest( i ) ) THEN
2372 CALL pdoptee( ictxt, nout, pdgeadd, scode( i ), snames( i ) )
2373 CALL pddimee( ictxt, nout, pdgeadd, scode( i ), snames( i ) )
2374 CALL pdmatee( ictxt, nout, pdgeadd, scode( i ), snames( i ) )
2375 END IF
2376*
2377* Test PDTRADD
2378*
2379 i = i + 1
2380 IF( ltest( i ) ) THEN
2381 CALL pdoptee( ictxt, nout, pdtradd, scode( i ), snames( i ) )
2382 CALL pddimee( ictxt, nout, pdtradd, scode( i ), snames( i ) )
2383 CALL pdmatee( ictxt, nout, pdtradd, scode( i ), snames( i ) )
2384 END IF
2385*
2386 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2387 $ WRITE( nout, fmt = 9999 )
2388*
2389 CALL blacs_gridexit( ictxt )
2390*
2391* Reset ABRTFLG to the value it had before calling this routine
2392*
2393 abrtflg = abrtsav
2394*
2395 9999 FORMAT( 2x, 'Error-exit tests completed.' )
2396*
2397 RETURN
2398*
2399* End of PDBLAS3TSTCHKE
2400*
pdtrsm
subroutine pdtrsm(side, uplo, transa, diag, m, n, alpha, a, ia, ja, desca, b, ib, jb, descb)
Definition mpi.f:1511
pdoptee
subroutine pdoptee(ictxt, nout, subptr, scode, sname)
Definition pdblastst.f:2
pdmatee
subroutine pdmatee(ictxt, nout, subptr, scode, sname)
Definition pdblastst.f:1190
pddimee
subroutine pddimee(ictxt, nout, subptr, scode, sname)
Definition pdblastst.f:455

◆ pdchkarg3()

subroutine pdchkarg3 ( integer ictxt,
integer nout,
character*7 sname,
character*1 side,
character*1 uplo,
character*1 transa,
character*1 transb,
character*1 diag,
integer m,
integer n,
integer k,
double precision alpha,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer ib,
integer jb,
integer, dimension( * ) descb,
double precision beta,
integer ic,
integer jc,
integer, dimension( * ) descc,
integer info )

Definition at line 2402 of file pdblas3tst.f.

2406*
2407* -- PBLAS test routine (version 2.0) --
2408* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2409* and University of California, Berkeley.
2410* April 1, 1998
2411*
2412* .. Scalar Arguments ..
2413 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2414 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2415 $ NOUT
2416 DOUBLE PRECISION ALPHA, BETA
2417* ..
2418* .. Array Arguments ..
2419 CHARACTER*7 SNAME
2420 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2421* ..
2422*
2423* Purpose
2424* =======
2425*
2426* PDCHKARG3 checks the input-only arguments of the Level 3 PBLAS. When
2427* INFO = 0, this routine makes a copy of its arguments (which are INPUT
2428* only arguments to PBLAS routines). Otherwise, it verifies the values
2429* of these arguments against the saved copies.
2430*
2431* Arguments
2432* =========
2433*
2434* ICTXT (local input) INTEGER
2435* On entry, ICTXT specifies the BLACS context handle, indica-
2436* ting the global context of the operation. The context itself
2437* is global, but the value of ICTXT is local.
2438*
2439* NOUT (global input) INTEGER
2440* On entry, NOUT specifies the unit number for the output file.
2441* When NOUT is 6, output to screen, when NOUT is 0, output to
2442* stderr. NOUT is only defined for process 0.
2443*
2444* SNAME (global input) CHARACTER*(*)
2445* On entry, SNAME specifies the subroutine name calling this
2446* subprogram.
2447*
2448* SIDE (global input) CHARACTER*1
2449* On entry, SIDE specifies the SIDE option in the Level 3 PBLAS
2450* operation.
2451*
2452* UPLO (global input) CHARACTER*1
2453* On entry, UPLO specifies the UPLO option in the Level 3 PBLAS
2454* operation.
2455*
2456* TRANSA (global input) CHARACTER*1
2457* On entry, TRANSA specifies the TRANSA option in the Level 3
2458* PBLAS operation.
2459*
2460* TRANSB (global input) CHARACTER*1
2461* On entry, TRANSB specifies the TRANSB option in the Level 3
2462* PBLAS operation.
2463*
2464* DIAG (global input) CHARACTER*1
2465* On entry, DIAG specifies the DIAG option in the Level 3 PBLAS
2466* operation.
2467*
2468* M (global input) INTEGER
2469* On entry, M specifies the dimension of the submatrix ope-
2470* rands.
2471*
2472* N (global input) INTEGER
2473* On entry, N specifies the dimension of the submatrix ope-
2474* rands.
2475*
2476* K (global input) INTEGER
2477* On entry, K specifies the dimension of the submatrix ope-
2478* rands.
2479*
2480* ALPHA (global input) DOUBLE PRECISION
2481* On entry, ALPHA specifies the scalar alpha.
2482*
2483* IA (global input) INTEGER
2484* On entry, IA specifies A's global row index, which points to
2485* the beginning of the submatrix sub( A ).
2486*
2487* JA (global input) INTEGER
2488* On entry, JA specifies A's global column index, which points
2489* to the beginning of the submatrix sub( A ).
2490*
2491* DESCA (global and local input) INTEGER array
2492* On entry, DESCA is an integer array of dimension DLEN_. This
2493* is the array descriptor for the matrix A.
2494*
2495* IB (global input) INTEGER
2496* On entry, IB specifies B's global row index, which points to
2497* the beginning of the submatrix sub( B ).
2498*
2499* JB (global input) INTEGER
2500* On entry, JB specifies B's global column index, which points
2501* to the beginning of the submatrix sub( B ).
2502*
2503* DESCB (global and local input) INTEGER array
2504* On entry, DESCB is an integer array of dimension DLEN_. This
2505* is the array descriptor for the matrix B.
2506*
2507* BETA (global input) DOUBLE PRECISION
2508* On entry, BETA specifies the scalar beta.
2509*
2510* IC (global input) INTEGER
2511* On entry, IC specifies C's global row index, which points to
2512* the beginning of the submatrix sub( C ).
2513*
2514* JC (global input) INTEGER
2515* On entry, JC specifies C's global column index, which points
2516* to the beginning of the submatrix sub( C ).
2517*
2518* DESCC (global and local input) INTEGER array
2519* On entry, DESCC is an integer array of dimension DLEN_. This
2520* is the array descriptor for the matrix C.
2521*
2522* INFO (global input/global output) INTEGER
2523* When INFO = 0 on entry, the values of the arguments which are
2524* INPUT only arguments to a PBLAS routine are copied into sta-
2525* tic variables and INFO is unchanged on exit. Otherwise, the
2526* values of the arguments are compared against the saved co-
2527* pies. In case no error has been found INFO is zero on return,
2528* otherwise it is non zero.
2529*
2530* -- Written on April 1, 1998 by
2531* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2532*
2533* =====================================================================
2534*
2535* .. Parameters ..
2536 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2537 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2538 $ RSRC_
2539 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2540 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2541 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2542 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2543* ..
2544* .. Local Scalars ..
2545 CHARACTER*1 DIAGREF, SIDEREF, TRANSAREF, TRANSBREF, UPLOREF
2546 INTEGER I, IAREF, IBREF, ICREF, JAREF, JBREF, JCREF,
2547 $ KREF, MREF, MYCOL, MYROW, NPCOL, NPROW, NREF
2548 DOUBLE PRECISION ALPHAREF, BETAREF
2549* ..
2550* .. Local Arrays ..
2551 CHARACTER*15 ARGNAME
2552 INTEGER DESCAREF( DLEN_ ), DESCBREF( DLEN_ ),
2553 $ DESCCREF( DLEN_ )
2554* ..
2555* .. External Subroutines ..
2556 EXTERNAL blacs_gridinfo, igsum2d
2557* ..
2558* .. External Functions ..
2559 LOGICAL LSAME
2560 EXTERNAL lsame
2561* ..
2562* .. Save Statements ..
2563 SAVE
2564* ..
2565* .. Executable Statements ..
2566*
2567* Get grid parameters
2568*
2569 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2570*
2571* Check if first call. If yes, then save.
2572*
2573 IF( info.EQ.0 ) THEN
2574*
2575 diagref = diag
2576 sideref = side
2577 transaref = transa
2578 transbref = transb
2579 uploref = uplo
2580 mref = m
2581 nref = n
2582 kref = k
2583 alpharef = alpha
2584 iaref = ia
2585 jaref = ja
2586 DO 10 i = 1, dlen_
2587 descaref( i ) = desca( i )
2588 10 CONTINUE
2589 ibref = ib
2590 jbref = jb
2591 DO 20 i = 1, dlen_
2592 descbref( i ) = descb( i )
2593 20 CONTINUE
2594 betaref = beta
2595 icref = ic
2596 jcref = jc
2597 DO 30 i = 1, dlen_
2598 desccref( i ) = descc( i )
2599 30 CONTINUE
2600*
2601 ELSE
2602*
2603* Test saved args. Return with first mismatch.
2604*
2605 argname = ' '
2606 IF( .NOT. lsame( diag, diagref ) ) THEN
2607 WRITE( argname, fmt = '(A)' ) 'DIAG'
2608 ELSE IF( .NOT. lsame( side, sideref ) ) THEN
2609 WRITE( argname, fmt = '(A)' ) 'SIDE'
2610 ELSE IF( .NOT. lsame( transa, transaref ) ) THEN
2611 WRITE( argname, fmt = '(A)' ) 'TRANSA'
2612 ELSE IF( .NOT. lsame( transb, transbref ) ) THEN
2613 WRITE( argname, fmt = '(A)' ) 'TRANSB'
2614 ELSE IF( .NOT. lsame( uplo, uploref ) ) THEN
2615 WRITE( argname, fmt = '(A)' ) 'UPLO'
2616 ELSE IF( m.NE.mref ) THEN
2617 WRITE( argname, fmt = '(A)' ) 'M'
2618 ELSE IF( n.NE.nref ) THEN
2619 WRITE( argname, fmt = '(A)' ) 'N'
2620 ELSE IF( k.NE.kref ) THEN
2621 WRITE( argname, fmt = '(A)' ) 'K'
2622 ELSE IF( alpha.NE.alpharef ) THEN
2623 WRITE( argname, fmt = '(A)' ) 'ALPHA'
2624 ELSE IF( ia.NE.iaref ) THEN
2625 WRITE( argname, fmt = '(A)' ) 'IA'
2626 ELSE IF( ja.NE.jaref ) THEN
2627 WRITE( argname, fmt = '(A)' ) 'JA'
2628 ELSE IF( desca( dtype_ ).NE.descaref( dtype_ ) ) THEN
2629 WRITE( argname, fmt = '(A)' ) 'DESCA( DTYPE_ )'
2630 ELSE IF( desca( m_ ).NE.descaref( m_ ) ) THEN
2631 WRITE( argname, fmt = '(A)' ) 'desca( m_ )'
2632 ELSE IF( desca( n_ ).NE.descaref( n_ ) ) THEN
2633 WRITE( argname, fmt = '(A)' ) 'DESCA( N_ )'
2634 ELSE IF( desca( imb_ ).NE.descaref( imb_ ) ) THEN
2635 WRITE( argname, fmt = '(A)' ) 'DESCA( IMB_ )'
2636 ELSE IF( desca( inb_ ).NE.descaref( inb_ ) ) THEN
2637 WRITE( argname, fmt = '(A)' ) 'DESCA( INB_ )'
2638 ELSE IF( desca( mb_ ).NE.descaref( mb_ ) ) THEN
2639 WRITE( argname, fmt = '(A)' ) 'DESCA( MB_ )'
2640 ELSE IF( desca( nb_ ).NE.descaref( nb_ ) ) THEN
2641 WRITE( argname, fmt = '(A)' ) 'DESCA( NB_ )'
2642 ELSE IF( desca( rsrc_ ).NE.descaref( rsrc_ ) ) THEN
2643 WRITE( argname, fmt = '(A)' ) 'DESCA( RSRC_ )'
2644 ELSE IF( desca( csrc_ ).NE.descaref( csrc_ ) ) THEN
2645 WRITE( argname, fmt = '(A)' ) 'DESCA( CSRC_ )'
2646 ELSE IF( desca( ctxt_ ).NE.descaref( ctxt_ ) ) THEN
2647 WRITE( argname, fmt = '(A)' ) 'DESCA( CTXT_ )'
2648 ELSE IF( desca( lld_ ).NE.descaref( lld_ ) ) THEN
2649 WRITE( argname, fmt = '(A)' ) 'DESCA( LLD_ )'
2650 ELSE IF( ib.NE.ibref ) THEN
2651 WRITE( argname, fmt = '(A)' ) 'IB'
2652 ELSE IF( jb.NE.jbref ) THEN
2653 WRITE( argname, fmt = '(A)' ) 'JB'
2654 ELSE IF( descb( dtype_ ).NE.descbref( dtype_ ) ) THEN
2655 WRITE( argname, fmt = '(A)' ) 'DESCB( DTYPE_ )'
2656 ELSE IF( descb( m_ ).NE.descbref( m_ ) ) THEN
2657 WRITE( argname, fmt = '(A)' ) 'DESCB( M_ )'
2658 ELSE IF( descb( n_ ).NE.descbref( n_ ) ) THEN
2659 WRITE( argname, fmt = '(A)' ) 'DESCB( N_ )'
2660 ELSE IF( descb( imb_ ).NE.descbref( imb_ ) ) THEN
2661 WRITE( argname, fmt = '(A)' ) 'DESCB( IMB_ )'
2662 ELSE IF( descb( inb_ ).NE.descbref( inb_ ) ) THEN
2663 WRITE( argname, fmt = '(A)' ) 'DESCB( INB_ )'
2664 ELSE IF( descb( mb_ ).NE.descbref( mb_ ) ) THEN
2665 WRITE( argname, fmt = '(A)' ) 'DESCB( MB_ )'
2666 ELSE IF( descb( nb_ ).NE.descbref( nb_ ) ) THEN
2667 WRITE( argname, fmt = '(A)' ) 'DESCB( NB_ )'
2668 ELSE IF( descb( rsrc_ ).NE.descbref( rsrc_ ) ) THEN
2669 WRITE( argname, fmt = '(A)' ) 'DESCB( RSRC_ )'
2670 ELSE IF( descb( csrc_ ).NE.descbref( csrc_ ) ) THEN
2671 WRITE( argname, fmt = '(A)' ) 'descb( csrc_ )'
2672.NE. ELSE IF( DESCB( CTXT_ )DESCBREF( CTXT_ ) ) THEN
2673 WRITE( ARGNAME, FMT = '(a)' ) 'descb( ctxt_ )'
2674.NE. ELSE IF( DESCB( LLD_ )DESCBREF( LLD_ ) ) THEN
2675 WRITE( ARGNAME, FMT = '(a)' ) 'descb( lld_ )'
2676.NE. ELSE IF( BETABETAREF ) THEN
2677 WRITE( ARGNAME, FMT = '(a)' ) 'beta'
2678.NE. ELSE IF( ICICREF ) THEN
2679 WRITE( ARGNAME, FMT = '(a)' ) 'ic'
2680.NE. ELSE IF( JCJCREF ) THEN
2681 WRITE( ARGNAME, FMT = '(a)' ) 'jc'
2682.NE. ELSE IF( DESCC( DTYPE_ )DESCCREF( DTYPE_ ) ) THEN
2683 WRITE( ARGNAME, FMT = '(a)' ) 'descc( dtype_ )'
2684.NE. ELSE IF( DESCC( M_ )DESCCREF( M_ ) ) THEN
2685 WRITE( ARGNAME, FMT = '(a)' ) 'descc( m_ )'
2686.NE. ELSE IF( DESCC( N_ )DESCCREF( N_ ) ) THEN
2687 WRITE( ARGNAME, FMT = '(a)' ) 'descc( n_ )'
2688.NE. ELSE IF( DESCC( IMB_ )DESCCREF( IMB_ ) ) THEN
2689 WRITE( ARGNAME, FMT = '(a)' ) 'descc( imb_ )'
2690.NE. ELSE IF( DESCC( INB_ )DESCCREF( INB_ ) ) THEN
2691 WRITE( ARGNAME, FMT = '(a)' ) 'descc( inb_ )'
2692.NE. ELSE IF( DESCC( MB_ )DESCCREF( MB_ ) ) THEN
2693 WRITE( ARGNAME, FMT = '(a)' ) 'descc( mb_ )'
2694.NE. ELSE IF( DESCC( NB_ )DESCCREF( NB_ ) ) THEN
2695 WRITE( ARGNAME, FMT = '(a)' ) 'descc( nb_ )'
2696.NE. ELSE IF( DESCC( RSRC_ )DESCCREF( RSRC_ ) ) THEN
2697 WRITE( ARGNAME, FMT = '(a)' ) 'descc( rsrc_ )'
2698.NE. ELSE IF( DESCC( CSRC_ )DESCCREF( CSRC_ ) ) THEN
2699 WRITE( ARGNAME, FMT = '(a)' ) 'descc( csrc_ )'
2700.NE. ELSE IF( DESCC( CTXT_ )DESCCREF( CTXT_ ) ) THEN
2701 WRITE( ARGNAME, FMT = '(a)' ) 'descc( ctxt_ )'
2702.NE. ELSE IF( DESCC( LLD_ )DESCCREF( LLD_ ) ) THEN
2703 WRITE( ARGNAME, FMT = '(a)' ) 'descc( lld_ )'
2704 ELSE
2705 INFO = 0
2706 END IF
2707*
2708 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, 0 )
2709*
2710.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
2711*
2712.NE. IF( INFO0 ) THEN
2713 WRITE( NOUT, FMT = 9999 ) ARGNAME, SNAME
2714 ELSE
2715 WRITE( NOUT, FMT = 9998 ) SNAME
2716 END IF
2717*
2718 END IF
2719*
2720 END IF
2721*
2722 9999 FORMAT( 2X, ' ***** input-only parameter check: ', A,
2723 $ ' failed changed ', A, ' *****' )
2724 9998 FORMAT( 2X, ' ***** input-only parameter check: ', A,
2725 $ ' passed *****' )
2726*
2727 RETURN
2728*
2729* End of PDCHKARG3
2730*