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

◆ pdbla3tstinfo()

subroutine pdbla3tstinfo ( character*( * )  summry,
integer  nout,
integer  nmat,
character*1, dimension( ldval )  diagval,
character*1, dimension( ldval )  sideval,
character*1, dimension( ldval )  trnaval,
character*1, dimension( ldval )  trnbval,
character*1, dimension( ldval )  uploval,
integer, dimension( ldval )  mval,
integer, dimension( ldval )  nval,
integer, dimension( ldval )  kval,
integer, dimension( ldval )  maval,
integer, dimension( ldval )  naval,
integer, dimension( ldval )  imbaval,
integer, dimension( ldval )  mbaval,
integer, dimension( ldval )  inbaval,
integer, dimension( ldval )  nbaval,
integer, dimension( ldval )  rscaval,
integer, dimension( ldval )  cscaval,
integer, dimension( ldval )  iaval,
integer, dimension( ldval )  javal,
integer, dimension( ldval )  mbval,
integer, dimension( ldval )  nbval,
integer, dimension( ldval )  imbbval,
integer, dimension( ldval )  mbbval,
integer, dimension( ldval )  inbbval,
integer, dimension( ldval )  nbbval,
integer, dimension( ldval )  rscbval,
integer, dimension( ldval )  cscbval,
integer, dimension( ldval )  ibval,
integer, dimension( ldval )  jbval,
integer, dimension( ldval )  mcval,
integer, dimension( ldval )  ncval,
integer, dimension( ldval )  imbcval,
integer, dimension( ldval )  mbcval,
integer, dimension( ldval )  inbcval,
integer, dimension( ldval )  nbcval,
integer, dimension( ldval )  rsccval,
integer, dimension( ldval )  csccval,
integer, dimension( ldval )  icval,
integer, dimension( ldval )  jcval,
integer  ldval,
integer  ngrids,
integer, dimension( ldpval )  pval,
integer  ldpval,
integer, dimension( ldqval )  qval,
integer  ldqval,
integer  nblog,
logical, dimension( * )  ltest,
logical  sof,
logical  tee,
integer  iam,
integer  igap,
integer  iverb,
integer  nprocs,
real  thresh,
double precision  alpha,
double precision  beta,
integer, dimension( * )  work 
)

Definition at line 1305 of file pdblas3tst.f.

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