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

◆ pzbla3tstinfo()

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

Definition at line 1404 of file pzblas3tst.f.

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