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

Go to the source code of this file.

Functions/Subroutines

program psbla3tst
subroutine psbla3tstinfo (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 psblas3tstchke (ltest, inout, nprocs)
subroutine pschkarg3 (ictxt, nout, sname, side, uplo, transa, transb, diag, m, n, k, alpha, ia, ja, desca, ib, jb, descb, beta, ic, jc, descc, info)
subroutine psblas3tstchk (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

◆ psbla3tst()

program psbla3tst

Definition at line 11 of file psblas3tst.f.

◆ psbla3tstinfo()

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

Definition at line 1304 of file psblas3tst.f.

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

◆ psblas3tstchk()

subroutine psblas3tstchk ( 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,
real alpha,
real, dimension( * ) a,
real, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
real, dimension( * ) b,
real, dimension( * ) pb,
integer ib,
integer jb,
integer, dimension( * ) descb,
real beta,
real, dimension( * ) c,
real, dimension( * ) pc,
integer ic,
integer jc,
integer, dimension( * ) descc,
real thresh,
real rogue,
real, dimension( * ) work,
integer info )

Definition at line 2730 of file psblas3tst.f.

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

◆ psblas3tstchke()

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

Definition at line 2191 of file psblas3tst.f.

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

◆ pschkarg3()

subroutine pschkarg3 ( 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,
real alpha,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer ib,
integer jb,
integer, dimension( * ) descb,
real beta,
integer ic,
integer jc,
integer, dimension( * ) descc,
integer info )

Definition at line 2400 of file psblas3tst.f.

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