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

◆ pb_slagen()

subroutine pb_slagen ( character*1  uplo,
character*1  aform,
real, dimension( lda, * )  a,
integer  lda,
integer  lcmt00,
integer, dimension( * )  iran,
integer  mblks,
integer  imbloc,
integer  mb,
integer  lmbloc,
integer  nblks,
integer  inbloc,
integer  nb,
integer  lnbloc,
integer, dimension( * )  jmp,
integer, dimension( 4, * )  imuladd 
)

Definition at line 1477 of file psblastim.f.

1480*
1481* -- PBLAS test routine (version 2.0) --
1482* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1483* and University of California, Berkeley.
1484* April 1, 1998
1485*
1486* .. Scalar Arguments ..
1487 CHARACTER*1 UPLO, AFORM
1488 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
1489 $ MB, MBLKS, NB, NBLKS
1490* ..
1491* .. Array Arguments ..
1492 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
1493 REAL A( LDA, * )
1494* ..
1495*
1496* Purpose
1497* =======
1498*
1499* PB_SLAGEN locally initializes an array A.
1500*
1501* Arguments
1502* =========
1503*
1504* UPLO (global input) CHARACTER*1
1505* On entry, UPLO specifies whether the lower (UPLO='L') trape-
1506* zoidal part or the upper (UPLO='U') trapezoidal part is to be
1507* generated when the matrix to be generated is symmetric or
1508* Hermitian. For all the other values of AFORM, the value of
1509* this input argument is ignored.
1510*
1511* AFORM (global input) CHARACTER*1
1512* On entry, AFORM specifies the type of submatrix to be genera-
1513* ted as follows:
1514* AFORM = 'S', sub( A ) is a symmetric matrix,
1515* AFORM = 'H', sub( A ) is a Hermitian matrix,
1516* AFORM = 'T', sub( A ) is overrwritten with the transpose
1517* of what would normally be generated,
1518* AFORM = 'C', sub( A ) is overwritten with the conjugate
1519* transpose of what would normally be genera-
1520* ted.
1521* AFORM = 'N', a random submatrix is generated.
1522*
1523* A (local output) REAL array
1524* On entry, A is an array of dimension (LLD_A, *). On exit,
1525* this array contains the local entries of the randomly genera-
1526* ted submatrix sub( A ).
1527*
1528* LDA (local input) INTEGER
1529* On entry, LDA specifies the local leading dimension of the
1530* array A. LDA must be at least one.
1531*
1532* LCMT00 (global input) INTEGER
1533* On entry, LCMT00 is the LCM value specifying the off-diagonal
1534* of the underlying matrix of interest. LCMT00=0 specifies the
1535* main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
1536* specifies superdiagonals.
1537*
1538* IRAN (local input) INTEGER array
1539* On entry, IRAN is an array of dimension 2 containing respec-
1540* tively the 16-lower and 16-higher bits of the encoding of the
1541* entry of the random sequence corresponding locally to the
1542* first local array entry to generate. Usually, this array is
1543* computed by PB_SETLOCRAN.
1544*
1545* MBLKS (local input) INTEGER
1546* On entry, MBLKS specifies the local number of blocks of rows.
1547* MBLKS is at least zero.
1548*
1549* IMBLOC (local input) INTEGER
1550* On entry, IMBLOC specifies the number of rows (size) of the
1551* local uppest blocks. IMBLOC is at least zero.
1552*
1553* MB (global input) INTEGER
1554* On entry, MB specifies the blocking factor used to partition
1555* the rows of the matrix. MB must be at least one.
1556*
1557* LMBLOC (local input) INTEGER
1558* On entry, LMBLOC specifies the number of rows (size) of the
1559* local lowest blocks. LMBLOC is at least zero.
1560*
1561* NBLKS (local input) INTEGER
1562* On entry, NBLKS specifies the local number of blocks of co-
1563* lumns. NBLKS is at least zero.
1564*
1565* INBLOC (local input) INTEGER
1566* On entry, INBLOC specifies the number of columns (size) of
1567* the local leftmost blocks. INBLOC is at least zero.
1568*
1569* NB (global input) INTEGER
1570* On entry, NB specifies the blocking factor used to partition
1571* the the columns of the matrix. NB must be at least one.
1572*
1573* LNBLOC (local input) INTEGER
1574* On entry, LNBLOC specifies the number of columns (size) of
1575* the local rightmost blocks. LNBLOC is at least zero.
1576*
1577* JMP (local input) INTEGER array
1578* On entry, JMP is an array of dimension JMP_LEN containing the
1579* different jump values used by the random matrix generator.
1580*
1581* IMULADD (local input) INTEGER array
1582* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
1583* jth column of this array contains the encoded initial cons-
1584* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
1585* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
1586* contains respectively the 16-lower and 16-higher bits of the
1587* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
1588* 16-higher bits of the constant c_j.
1589*
1590* -- Written on April 1, 1998 by
1591* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1592*
1593* =====================================================================
1594*
1595* .. Parameters ..
1596 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
1597 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
1598 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
1599 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
1600 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
1601 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
1602 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
1603 $ jmp_len = 11 )
1604* ..
1605* .. Local Scalars ..
1606 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
1607 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
1608 REAL DUMMY
1609* ..
1610* .. Local Arrays ..
1611 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
1612* ..
1613* .. External Subroutines ..
1614 EXTERNAL pb_jumpit
1615* ..
1616* .. External Functions ..
1617 LOGICAL LSAME
1618 REAL PB_SRAND
1619 EXTERNAL lsame, pb_srand
1620* ..
1621* .. Intrinsic Functions ..
1622 INTRINSIC max, min
1623* ..
1624* .. Executable Statements ..
1625*
1626 DO 10 i = 1, 2
1627 ib1( i ) = iran( i )
1628 ib2( i ) = iran( i )
1629 ib3( i ) = iran( i )
1630 10 CONTINUE
1631*
1632 IF( lsame( aform, 'N' ) ) THEN
1633*
1634* Generate random matrix
1635*
1636 jj = 1
1637*
1638 DO 50 jblk = 1, nblks
1639*
1640 IF( jblk.EQ.1 ) THEN
1641 jb = inbloc
1642 ELSE IF( jblk.EQ.nblks ) THEN
1643 jb = lnbloc
1644 ELSE
1645 jb = nb
1646 END IF
1647*
1648 DO 40 jk = jj, jj + jb - 1
1649*
1650 ii = 1
1651*
1652 DO 30 iblk = 1, mblks
1653*
1654 IF( iblk.EQ.1 ) THEN
1655 ib = imbloc
1656 ELSE IF( iblk.EQ.mblks ) THEN
1657 ib = lmbloc
1658 ELSE
1659 ib = mb
1660 END IF
1661*
1662* Blocks are IB by JB
1663*
1664 DO 20 ik = ii, ii + ib - 1
1665 a( ik, jk ) = pb_srand( 0 )
1666 20 CONTINUE
1667*
1668 ii = ii + ib
1669*
1670 IF( iblk.EQ.1 ) THEN
1671*
1672* Jump IMBLOC + ( NPROW - 1 ) * MB rows
1673*
1674 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1675 $ ib0 )
1676*
1677 ELSE
1678*
1679* Jump NPROW * MB rows
1680*
1681 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1, ib0 )
1682*
1683 END IF
1684*
1685 ib1( 1 ) = ib0( 1 )
1686 ib1( 2 ) = ib0( 2 )
1687*
1688 30 CONTINUE
1689*
1690* Jump one column
1691*
1692 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1693*
1694 ib1( 1 ) = ib0( 1 )
1695 ib1( 2 ) = ib0( 2 )
1696 ib2( 1 ) = ib0( 1 )
1697 ib2( 2 ) = ib0( 2 )
1698*
1699 40 CONTINUE
1700*
1701 jj = jj + jb
1702*
1703 IF( jblk.EQ.1 ) THEN
1704*
1705* Jump INBLOC + ( NPCOL - 1 ) * NB columns
1706*
1707 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1708*
1709 ELSE
1710*
1711* Jump NPCOL * NB columns
1712*
1713 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1714*
1715 END IF
1716*
1717 ib1( 1 ) = ib0( 1 )
1718 ib1( 2 ) = ib0( 2 )
1719 ib2( 1 ) = ib0( 1 )
1720 ib2( 2 ) = ib0( 2 )
1721 ib3( 1 ) = ib0( 1 )
1722 ib3( 2 ) = ib0( 2 )
1723*
1724 50 CONTINUE
1725*
1726 ELSE IF( lsame( aform, 'T' ) .OR. lsame( aform, 'C' ) ) THEN
1727*
1728* Generate the transpose of the matrix that would be normally
1729* generated.
1730*
1731 ii = 1
1732*
1733 DO 90 iblk = 1, mblks
1734*
1735 IF( iblk.EQ.1 ) THEN
1736 ib = imbloc
1737 ELSE IF( iblk.EQ.mblks ) THEN
1738 ib = lmbloc
1739 ELSE
1740 ib = mb
1741 END IF
1742*
1743 DO 80 ik = ii, ii + ib - 1
1744*
1745 jj = 1
1746*
1747 DO 70 jblk = 1, nblks
1748*
1749 IF( jblk.EQ.1 ) THEN
1750 jb = inbloc
1751 ELSE IF( jblk.EQ.nblks ) THEN
1752 jb = lnbloc
1753 ELSE
1754 jb = nb
1755 END IF
1756*
1757* Blocks are IB by JB
1758*
1759 DO 60 jk = jj, jj + jb - 1
1760 a( ik, jk ) = pb_srand( 0 )
1761 60 CONTINUE
1762*
1763 jj = jj + jb
1764*
1765 IF( jblk.EQ.1 ) THEN
1766*
1767* Jump INBLOC + ( NPCOL - 1 ) * NB columns
1768*
1769 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
1770 $ ib0 )
1771*
1772 ELSE
1773*
1774* Jump NPCOL * NB columns
1775*
1776 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1, ib0 )
1777*
1778 END IF
1779*
1780 ib1( 1 ) = ib0( 1 )
1781 ib1( 2 ) = ib0( 2 )
1782*
1783 70 CONTINUE
1784*
1785* Jump one row
1786*
1787 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
1788*
1789 ib1( 1 ) = ib0( 1 )
1790 ib1( 2 ) = ib0( 2 )
1791 ib2( 1 ) = ib0( 1 )
1792 ib2( 2 ) = ib0( 2 )
1793*
1794 80 CONTINUE
1795*
1796 ii = ii + ib
1797*
1798 IF( iblk.EQ.1 ) THEN
1799*
1800* Jump IMBLOC + ( NPROW - 1 ) * MB rows
1801*
1802 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
1803*
1804 ELSE
1805*
1806* Jump NPROW * MB rows
1807*
1808 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
1809*
1810 END IF
1811*
1812 ib1( 1 ) = ib0( 1 )
1813 ib1( 2 ) = ib0( 2 )
1814 ib2( 1 ) = ib0( 1 )
1815 ib2( 2 ) = ib0( 2 )
1816 ib3( 1 ) = ib0( 1 )
1817 ib3( 2 ) = ib0( 2 )
1818*
1819 90 CONTINUE
1820*
1821 ELSE IF( ( lsame( aform, 'S' ) ).OR.( lsame( aform, 'H' ) ) ) THEN
1822*
1823* Generate a symmetric matrix
1824*
1825 IF( lsame( uplo, 'L' ) ) THEN
1826*
1827* generate lower trapezoidal part
1828*
1829 jj = 1
1830 lcmtc = lcmt00
1831*
1832 DO 170 jblk = 1, nblks
1833*
1834 IF( jblk.EQ.1 ) THEN
1835 jb = inbloc
1836 low = 1 - inbloc
1837 ELSE IF( jblk.EQ.nblks ) THEN
1838 jb = lnbloc
1839 low = 1 - nb
1840 ELSE
1841 jb = nb
1842 low = 1 - nb
1843 END IF
1844*
1845 DO 160 jk = jj, jj + jb - 1
1846*
1847 ii = 1
1848 lcmtr = lcmtc
1849*
1850 DO 150 iblk = 1, mblks
1851*
1852 IF( iblk.EQ.1 ) THEN
1853 ib = imbloc
1854 upp = imbloc - 1
1855 ELSE IF( iblk.EQ.mblks ) THEN
1856 ib = lmbloc
1857 upp = mb - 1
1858 ELSE
1859 ib = mb
1860 upp = mb - 1
1861 END IF
1862*
1863* Blocks are IB by JB
1864*
1865 IF( lcmtr.GT.upp ) THEN
1866*
1867 DO 100 ik = ii, ii + ib - 1
1868 dummy = pb_srand( 0 )
1869 100 CONTINUE
1870*
1871 ELSE IF( lcmtr.GE.low ) THEN
1872*
1873 jtmp = jk - jj + 1
1874 mnb = max( 0, -lcmtr )
1875*
1876 IF( jtmp.LE.min( mnb, jb ) ) THEN
1877*
1878 DO 110 ik = ii, ii + ib - 1
1879 a( ik, jk ) = pb_srand( 0 )
1880 110 CONTINUE
1881*
1882 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
1883 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
1884*
1885 itmp = ii + jtmp + lcmtr - 1
1886*
1887 DO 120 ik = ii, itmp - 1
1888 dummy = pb_srand( 0 )
1889 120 CONTINUE
1890*
1891 DO 130 ik = itmp, ii + ib - 1
1892 a( ik, jk ) = pb_srand( 0 )
1893 130 CONTINUE
1894*
1895 END IF
1896*
1897 ELSE
1898*
1899 DO 140 ik = ii, ii + ib - 1
1900 a( ik, jk ) = pb_srand( 0 )
1901 140 CONTINUE
1902*
1903 END IF
1904*
1905 ii = ii + ib
1906*
1907 IF( iblk.EQ.1 ) THEN
1908*
1909* Jump IMBLOC + ( NPROW - 1 ) * MB rows
1910*
1911 lcmtr = lcmtr - jmp( jmp_npimbloc )
1912 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1913 $ ib0 )
1914*
1915 ELSE
1916*
1917* Jump NPROW * MB rows
1918*
1919 lcmtr = lcmtr - jmp( jmp_npmb )
1920 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
1921 $ ib0 )
1922*
1923 END IF
1924*
1925 ib1( 1 ) = ib0( 1 )
1926 ib1( 2 ) = ib0( 2 )
1927*
1928 150 CONTINUE
1929*
1930* Jump one column
1931*
1932 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1933*
1934 ib1( 1 ) = ib0( 1 )
1935 ib1( 2 ) = ib0( 2 )
1936 ib2( 1 ) = ib0( 1 )
1937 ib2( 2 ) = ib0( 2 )
1938*
1939 160 CONTINUE
1940*
1941 jj = jj + jb
1942*
1943 IF( jblk.EQ.1 ) THEN
1944*
1945* Jump INBLOC + ( NPCOL - 1 ) * NB columns
1946*
1947 lcmtc = lcmtc + jmp( jmp_nqinbloc )
1948 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1949*
1950 ELSE
1951*
1952* Jump NPCOL * NB columns
1953*
1954 lcmtc = lcmtc + jmp( jmp_nqnb )
1955 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1956*
1957 END IF
1958*
1959 ib1( 1 ) = ib0( 1 )
1960 ib1( 2 ) = ib0( 2 )
1961 ib2( 1 ) = ib0( 1 )
1962 ib2( 2 ) = ib0( 2 )
1963 ib3( 1 ) = ib0( 1 )
1964 ib3( 2 ) = ib0( 2 )
1965*
1966 170 CONTINUE
1967*
1968 ELSE
1969*
1970* generate upper trapezoidal part
1971*
1972 ii = 1
1973 lcmtr = lcmt00
1974*
1975 DO 250 iblk = 1, mblks
1976*
1977 IF( iblk.EQ.1 ) THEN
1978 ib = imbloc
1979 upp = imbloc - 1
1980 ELSE IF( iblk.EQ.mblks ) THEN
1981 ib = lmbloc
1982 upp = mb - 1
1983 ELSE
1984 ib = mb
1985 upp = mb - 1
1986 END IF
1987*
1988 DO 240 ik = ii, ii + ib - 1
1989*
1990 jj = 1
1991 lcmtc = lcmtr
1992*
1993 DO 230 jblk = 1, nblks
1994*
1995 IF( jblk.EQ.1 ) THEN
1996 jb = inbloc
1997 low = 1 - inbloc
1998 ELSE IF( jblk.EQ.nblks ) THEN
1999 jb = lnbloc
2000 low = 1 - nb
2001 ELSE
2002 jb = nb
2003 low = 1 - nb
2004 END IF
2005*
2006* Blocks are IB by JB
2007*
2008 IF( lcmtc.LT.low ) THEN
2009*
2010 DO 180 jk = jj, jj + jb - 1
2011 dummy = pb_srand( 0 )
2012 180 CONTINUE
2013*
2014 ELSE IF( lcmtc.LE.upp ) THEN
2015*
2016 itmp = ik - ii + 1
2017 mnb = max( 0, lcmtc )
2018*
2019 IF( itmp.LE.min( mnb, ib ) ) THEN
2020*
2021 DO 190 jk = jj, jj + jb - 1
2022 a( ik, jk ) = pb_srand( 0 )
2023 190 CONTINUE
2024*
2025 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
2026 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
2027*
2028 jtmp = jj + itmp - lcmtc - 1
2029*
2030 DO 200 jk = jj, jtmp - 1
2031 dummy = pb_srand( 0 )
2032 200 CONTINUE
2033*
2034 DO 210 jk = jtmp, jj + jb - 1
2035 a( ik, jk ) = pb_srand( 0 )
2036 210 CONTINUE
2037*
2038 END IF
2039*
2040 ELSE
2041*
2042 DO 220 jk = jj, jj + jb - 1
2043 a( ik, jk ) = pb_srand( 0 )
2044 220 CONTINUE
2045*
2046 END IF
2047*
2048 jj = jj + jb
2049*
2050 IF( jblk.EQ.1 ) THEN
2051*
2052* Jump INBLOC + ( NPCOL - 1 ) * NB columns
2053*
2054 lcmtc = lcmtc + jmp( jmp_nqinbloc )
2055 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2056 $ ib0 )
2057*
2058 ELSE
2059*
2060* Jump NPCOL * NB columns
2061*
2062 lcmtc = lcmtc + jmp( jmp_nqnb )
2063 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2064 $ ib0 )
2065*
2066 END IF
2067*
2068 ib1( 1 ) = ib0( 1 )
2069 ib1( 2 ) = ib0( 2 )
2070*
2071 230 CONTINUE
2072*
2073* Jump one row
2074*
2075 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2076*
2077 ib1( 1 ) = ib0( 1 )
2078 ib1( 2 ) = ib0( 2 )
2079 ib2( 1 ) = ib0( 1 )
2080 ib2( 2 ) = ib0( 2 )
2081*
2082 240 CONTINUE
2083*
2084 ii = ii + ib
2085*
2086 IF( iblk.EQ.1 ) THEN
2087*
2088* Jump IMBLOC + ( NPROW - 1 ) * MB rows
2089*
2090 lcmtr = lcmtr - jmp( jmp_npimbloc )
2091 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2092*
2093 ELSE
2094*
2095* Jump NPROW * MB rows
2096*
2097 lcmtr = lcmtr - jmp( jmp_npmb )
2098 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2099*
2100 END IF
2101*
2102 ib1( 1 ) = ib0( 1 )
2103 ib1( 2 ) = ib0( 2 )
2104 ib2( 1 ) = ib0( 1 )
2105 ib2( 2 ) = ib0( 2 )
2106 ib3( 1 ) = ib0( 1 )
2107 ib3( 2 ) = ib0( 2 )
2108*
2109 250 CONTINUE
2110*
2111 END IF
2112*
2113 END IF
2114*
2115 RETURN
2116*
2117* End of PB_SLAGEN
2118*
pb_jumpit
subroutine pb_jumpit(muladd, irann, iranm)
Definition pblastst.f:4822
pb_srand
real function pb_srand(idumm)
Definition pcblastst.f:11490
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
Here is the call graph for this function: