SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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 IF( work( i ).EQ.1 ) THEN
2047 sof = .true.
2048 ELSE
2049 sof = .false.
2050 END IF
2051 i = i + 1
2052 IF( work( i ).EQ.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 IF( work( i ).EQ.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 IF( nout.NE.6 .AND. nout.NE.0 )
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*
icopy
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
pslamch
real function pslamch(ictxt, cmach)
Definition pcblastst.f:7455
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
Here is the call graph for this function:
Here is the caller graph for this function: