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

◆ pb_dlagen()

subroutine pb_dlagen ( character*1  uplo,
character*1  aform,
double precision, 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 1476 of file pdblastim.f.

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