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

◆ pb_zlagen()

subroutine pb_zlagen ( character*1  uplo,
character*1  aform,
complex*16, 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 1499 of file pzblastim.f.

1502*
1503* -- PBLAS test routine (version 2.0) --
1504* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1505* and University of California, Berkeley.
1506* April 1, 1998
1507*
1508* .. Scalar Arguments ..
1509 CHARACTER*1 UPLO, AFORM
1510 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
1511 $ MB, MBLKS, NB, NBLKS
1512* ..
1513* .. Array Arguments ..
1514 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
1515 COMPLEX*16 A( LDA, * )
1516* ..
1517*
1518* Purpose
1519* =======
1520*
1521* PB_ZLAGEN locally initializes an array A.
1522*
1523* Arguments
1524* =========
1525*
1526* UPLO (global input) CHARACTER*1
1527* On entry, UPLO specifies whether the lower (UPLO='L') trape-
1528* zoidal part or the upper (UPLO='U') trapezoidal part is to be
1529* generated when the matrix to be generated is symmetric or
1530* Hermitian. For all the other values of AFORM, the value of
1531* this input argument is ignored.
1532*
1533* AFORM (global input) CHARACTER*1
1534* On entry, AFORM specifies the type of submatrix to be genera-
1535* ted as follows:
1536* AFORM = 'S', sub( A ) is a symmetric matrix,
1537* AFORM = 'H', sub( A ) is a Hermitian matrix,
1538* AFORM = 'T', sub( A ) is overrwritten with the transpose
1539* of what would normally be generated,
1540* AFORM = 'C', sub( A ) is overwritten with the conjugate
1541* transpose of what would normally be genera-
1542* ted.
1543* AFORM = 'N', a random submatrix is generated.
1544*
1545* A (local output) COMPLEX*16 array
1546* On entry, A is an array of dimension (LLD_A, *). On exit,
1547* this array contains the local entries of the randomly genera-
1548* ted submatrix sub( A ).
1549*
1550* LDA (local input) INTEGER
1551* On entry, LDA specifies the local leading dimension of the
1552* array A. LDA must be at least one.
1553*
1554* LCMT00 (global input) INTEGER
1555* On entry, LCMT00 is the LCM value specifying the off-diagonal
1556* of the underlying matrix of interest. LCMT00=0 specifies the
1557* main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
1558* specifies superdiagonals.
1559*
1560* IRAN (local input) INTEGER array
1561* On entry, IRAN is an array of dimension 2 containing respec-
1562* tively the 16-lower and 16-higher bits of the encoding of the
1563* entry of the random sequence corresponding locally to the
1564* first local array entry to generate. Usually, this array is
1565* computed by PB_SETLOCRAN.
1566*
1567* MBLKS (local input) INTEGER
1568* On entry, MBLKS specifies the local number of blocks of rows.
1569* MBLKS is at least zero.
1570*
1571* IMBLOC (local input) INTEGER
1572* On entry, IMBLOC specifies the number of rows (size) of the
1573* local uppest blocks. IMBLOC is at least zero.
1574*
1575* MB (global input) INTEGER
1576* On entry, MB specifies the blocking factor used to partition
1577* the rows of the matrix. MB must be at least one.
1578*
1579* LMBLOC (local input) INTEGER
1580* On entry, LMBLOC specifies the number of rows (size) of the
1581* local lowest blocks. LMBLOC is at least zero.
1582*
1583* NBLKS (local input) INTEGER
1584* On entry, NBLKS specifies the local number of blocks of co-
1585* lumns. NBLKS is at least zero.
1586*
1587* INBLOC (local input) INTEGER
1588* On entry, INBLOC specifies the number of columns (size) of
1589* the local leftmost blocks. INBLOC is at least zero.
1590*
1591* NB (global input) INTEGER
1592* On entry, NB specifies the blocking factor used to partition
1593* the the columns of the matrix. NB must be at least one.
1594*
1595* LNBLOC (local input) INTEGER
1596* On entry, LNBLOC specifies the number of columns (size) of
1597* the local rightmost blocks. LNBLOC is at least zero.
1598*
1599* JMP (local input) INTEGER array
1600* On entry, JMP is an array of dimension JMP_LEN containing the
1601* different jump values used by the random matrix generator.
1602*
1603* IMULADD (local input) INTEGER array
1604* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
1605* jth column of this array contains the encoded initial cons-
1606* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
1607* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
1608* contains respectively the 16-lower and 16-higher bits of the
1609* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
1610* 16-higher bits of the constant c_j.
1611*
1612* -- Written on April 1, 1998 by
1613* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1614*
1615* =====================================================================
1616*
1617* .. Parameters ..
1618 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
1619 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
1620 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
1621 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
1622 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
1623 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
1624 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
1625 $ jmp_len = 11 )
1626 DOUBLE PRECISION ZERO
1627 parameter( zero = 0.0d+0 )
1628* ..
1629* .. Local Scalars ..
1630 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
1631 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
1632 COMPLEX*16 DUMMY
1633* ..
1634* .. Local Arrays ..
1635 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
1636* ..
1637* .. External Subroutines ..
1638 EXTERNAL pb_jumpit
1639* ..
1640* .. External Functions ..
1641 LOGICAL LSAME
1642 DOUBLE PRECISION PB_DRAND
1643 EXTERNAL lsame, pb_drand
1644* ..
1645* .. Intrinsic Functions ..
1646 INTRINSIC dble, dcmplx, max, min
1647* ..
1648* .. Executable Statements ..
1649*
1650 DO 10 i = 1, 2
1651 ib1( i ) = iran( i )
1652 ib2( i ) = iran( i )
1653 ib3( i ) = iran( i )
1654 10 CONTINUE
1655*
1656 IF( lsame( aform, 'N' ) ) THEN
1657*
1658* Generate random matrix
1659*
1660 jj = 1
1661*
1662 DO 50 jblk = 1, nblks
1663*
1664 IF( jblk.EQ.1 ) THEN
1665 jb = inbloc
1666 ELSE IF( jblk.EQ.nblks ) THEN
1667 jb = lnbloc
1668 ELSE
1669 jb = nb
1670 END IF
1671*
1672 DO 40 jk = jj, jj + jb - 1
1673*
1674 ii = 1
1675*
1676 DO 30 iblk = 1, mblks
1677*
1678 IF( iblk.EQ.1 ) THEN
1679 ib = imbloc
1680 ELSE IF( iblk.EQ.mblks ) THEN
1681 ib = lmbloc
1682 ELSE
1683 ib = mb
1684 END IF
1685*
1686* Blocks are IB by JB
1687*
1688 DO 20 ik = ii, ii + ib - 1
1689 a( ik, jk ) = dcmplx( pb_drand( 0 ),
1690 $ pb_drand( 0 ) )
1691 20 CONTINUE
1692*
1693 ii = ii + ib
1694*
1695 IF( iblk.EQ.1 ) THEN
1696*
1697* Jump IMBLOC + ( NPROW - 1 ) * MB rows
1698*
1699 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1700 $ ib0 )
1701*
1702 ELSE
1703*
1704* Jump NPROW * MB rows
1705*
1706 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1, ib0 )
1707*
1708 END IF
1709*
1710 ib1( 1 ) = ib0( 1 )
1711 ib1( 2 ) = ib0( 2 )
1712*
1713 30 CONTINUE
1714*
1715* Jump one column
1716*
1717 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1718*
1719 ib1( 1 ) = ib0( 1 )
1720 ib1( 2 ) = ib0( 2 )
1721 ib2( 1 ) = ib0( 1 )
1722 ib2( 2 ) = ib0( 2 )
1723*
1724 40 CONTINUE
1725*
1726 jj = jj + jb
1727*
1728 IF( jblk.EQ.1 ) THEN
1729*
1730* Jump INBLOC + ( NPCOL - 1 ) * NB columns
1731*
1732 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1733*
1734 ELSE
1735*
1736* Jump NPCOL * NB columns
1737*
1738 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1739*
1740 END IF
1741*
1742 ib1( 1 ) = ib0( 1 )
1743 ib1( 2 ) = ib0( 2 )
1744 ib2( 1 ) = ib0( 1 )
1745 ib2( 2 ) = ib0( 2 )
1746 ib3( 1 ) = ib0( 1 )
1747 ib3( 2 ) = ib0( 2 )
1748*
1749 50 CONTINUE
1750*
1751 ELSE IF( lsame( aform, 'T' ) ) THEN
1752*
1753* Generate the transpose of the matrix that would be normally
1754* generated.
1755*
1756 ii = 1
1757*
1758 DO 90 iblk = 1, mblks
1759*
1760 IF( iblk.EQ.1 ) THEN
1761 ib = imbloc
1762 ELSE IF( iblk.EQ.mblks ) THEN
1763 ib = lmbloc
1764 ELSE
1765 ib = mb
1766 END IF
1767*
1768 DO 80 ik = ii, ii + ib - 1
1769*
1770 jj = 1
1771*
1772 DO 70 jblk = 1, nblks
1773*
1774 IF( jblk.EQ.1 ) THEN
1775 jb = inbloc
1776 ELSE IF( jblk.EQ.nblks ) THEN
1777 jb = lnbloc
1778 ELSE
1779 jb = nb
1780 END IF
1781*
1782* Blocks are IB by JB
1783*
1784 DO 60 jk = jj, jj + jb - 1
1785 a( ik, jk ) = dcmplx( pb_drand( 0 ),
1786 $ pb_drand( 0 ) )
1787 60 CONTINUE
1788*
1789 jj = jj + jb
1790*
1791 IF( jblk.EQ.1 ) THEN
1792*
1793* Jump INBLOC + ( NPCOL - 1 ) * NB columns
1794*
1795 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
1796 $ ib0 )
1797*
1798 ELSE
1799*
1800* Jump NPCOL * NB columns
1801*
1802 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1, ib0 )
1803*
1804 END IF
1805*
1806 ib1( 1 ) = ib0( 1 )
1807 ib1( 2 ) = ib0( 2 )
1808*
1809 70 CONTINUE
1810*
1811* Jump one row
1812*
1813 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
1814*
1815 ib1( 1 ) = ib0( 1 )
1816 ib1( 2 ) = ib0( 2 )
1817 ib2( 1 ) = ib0( 1 )
1818 ib2( 2 ) = ib0( 2 )
1819*
1820 80 CONTINUE
1821*
1822 ii = ii + ib
1823*
1824 IF( iblk.EQ.1 ) THEN
1825*
1826* Jump IMBLOC + ( NPROW - 1 ) * MB rows
1827*
1828 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
1829*
1830 ELSE
1831*
1832* Jump NPROW * MB rows
1833*
1834 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
1835*
1836 END IF
1837*
1838 ib1( 1 ) = ib0( 1 )
1839 ib1( 2 ) = ib0( 2 )
1840 ib2( 1 ) = ib0( 1 )
1841 ib2( 2 ) = ib0( 2 )
1842 ib3( 1 ) = ib0( 1 )
1843 ib3( 2 ) = ib0( 2 )
1844*
1845 90 CONTINUE
1846*
1847 ELSE IF( lsame( aform, 'S' ) ) THEN
1848*
1849* Generate a symmetric matrix
1850*
1851 IF( lsame( uplo, 'L' ) ) THEN
1852*
1853* generate lower trapezoidal part
1854*
1855 jj = 1
1856 lcmtc = lcmt00
1857*
1858 DO 170 jblk = 1, nblks
1859*
1860 IF( jblk.EQ.1 ) THEN
1861 jb = inbloc
1862 low = 1 - inbloc
1863 ELSE IF( jblk.EQ.nblks ) THEN
1864 jb = lnbloc
1865 low = 1 - nb
1866 ELSE
1867 jb = nb
1868 low = 1 - nb
1869 END IF
1870*
1871 DO 160 jk = jj, jj + jb - 1
1872*
1873 ii = 1
1874 lcmtr = lcmtc
1875*
1876 DO 150 iblk = 1, mblks
1877*
1878 IF( iblk.EQ.1 ) THEN
1879 ib = imbloc
1880 upp = imbloc - 1
1881 ELSE IF( iblk.EQ.mblks ) THEN
1882 ib = lmbloc
1883 upp = mb - 1
1884 ELSE
1885 ib = mb
1886 upp = mb - 1
1887 END IF
1888*
1889* Blocks are IB by JB
1890*
1891 IF( lcmtr.GT.upp ) THEN
1892*
1893 DO 100 ik = ii, ii + ib - 1
1894 dummy = dcmplx( pb_drand( 0 ),
1895 $ pb_drand( 0 ) )
1896 100 CONTINUE
1897*
1898 ELSE IF( lcmtr.GE.low ) THEN
1899*
1900 jtmp = jk - jj + 1
1901 mnb = max( 0, -lcmtr )
1902*
1903 IF( jtmp.LE.min( mnb, jb ) ) THEN
1904*
1905 DO 110 ik = ii, ii + ib - 1
1906 a( ik, jk ) = dcmplx( pb_drand( 0 ),
1907 $ pb_drand( 0 ) )
1908 110 CONTINUE
1909*
1910 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
1911 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
1912*
1913 itmp = ii + jtmp + lcmtr - 1
1914*
1915 DO 120 ik = ii, itmp - 1
1916 dummy = dcmplx( pb_drand( 0 ),
1917 $ pb_drand( 0 ) )
1918 120 CONTINUE
1919*
1920 DO 130 ik = itmp, ii + ib - 1
1921 a( ik, jk ) = dcmplx( pb_drand( 0 ),
1922 $ pb_drand( 0 ) )
1923 130 CONTINUE
1924*
1925 END IF
1926*
1927 ELSE
1928*
1929 DO 140 ik = ii, ii + ib - 1
1930 a( ik, jk ) = dcmplx( pb_drand( 0 ),
1931 $ pb_drand( 0 ) )
1932 140 CONTINUE
1933*
1934 END IF
1935*
1936 ii = ii + ib
1937*
1938 IF( iblk.EQ.1 ) THEN
1939*
1940* Jump IMBLOC + ( NPROW - 1 ) * MB rows
1941*
1942 lcmtr = lcmtr - jmp( jmp_npimbloc )
1943 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
1944 $ ib0 )
1945*
1946 ELSE
1947*
1948* Jump NPROW * MB rows
1949*
1950 lcmtr = lcmtr - jmp( jmp_npmb )
1951 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
1952 $ ib0 )
1953*
1954 END IF
1955*
1956 ib1( 1 ) = ib0( 1 )
1957 ib1( 2 ) = ib0( 2 )
1958*
1959 150 CONTINUE
1960*
1961* Jump one column
1962*
1963 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
1964*
1965 ib1( 1 ) = ib0( 1 )
1966 ib1( 2 ) = ib0( 2 )
1967 ib2( 1 ) = ib0( 1 )
1968 ib2( 2 ) = ib0( 2 )
1969*
1970 160 CONTINUE
1971*
1972 jj = jj + jb
1973*
1974 IF( jblk.EQ.1 ) THEN
1975*
1976* Jump INBLOC + ( NPCOL - 1 ) * NB columns
1977*
1978 lcmtc = lcmtc + jmp( jmp_nqinbloc )
1979 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
1980*
1981 ELSE
1982*
1983* Jump NPCOL * NB columns
1984*
1985 lcmtc = lcmtc + jmp( jmp_nqnb )
1986 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
1987*
1988 END IF
1989*
1990 ib1( 1 ) = ib0( 1 )
1991 ib1( 2 ) = ib0( 2 )
1992 ib2( 1 ) = ib0( 1 )
1993 ib2( 2 ) = ib0( 2 )
1994 ib3( 1 ) = ib0( 1 )
1995 ib3( 2 ) = ib0( 2 )
1996*
1997 170 CONTINUE
1998*
1999 ELSE
2000*
2001* generate upper trapezoidal part
2002*
2003 ii = 1
2004 lcmtr = lcmt00
2005*
2006 DO 250 iblk = 1, mblks
2007*
2008 IF( iblk.EQ.1 ) THEN
2009 ib = imbloc
2010 upp = imbloc - 1
2011 ELSE IF( iblk.EQ.mblks ) THEN
2012 ib = lmbloc
2013 upp = mb - 1
2014 ELSE
2015 ib = mb
2016 upp = mb - 1
2017 END IF
2018*
2019 DO 240 ik = ii, ii + ib - 1
2020*
2021 jj = 1
2022 lcmtc = lcmtr
2023*
2024 DO 230 jblk = 1, nblks
2025*
2026 IF( jblk.EQ.1 ) THEN
2027 jb = inbloc
2028 low = 1 - inbloc
2029 ELSE IF( jblk.EQ.nblks ) THEN
2030 jb = lnbloc
2031 low = 1 - nb
2032 ELSE
2033 jb = nb
2034 low = 1 - nb
2035 END IF
2036*
2037* Blocks are IB by JB
2038*
2039 IF( lcmtc.LT.low ) THEN
2040*
2041 DO 180 jk = jj, jj + jb - 1
2042 dummy = dcmplx( pb_drand( 0 ),
2043 $ pb_drand( 0 ) )
2044 180 CONTINUE
2045*
2046 ELSE IF( lcmtc.LE.upp ) THEN
2047*
2048 itmp = ik - ii + 1
2049 mnb = max( 0, lcmtc )
2050*
2051 IF( itmp.LE.min( mnb, ib ) ) THEN
2052*
2053 DO 190 jk = jj, jj + jb - 1
2054 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2055 $ pb_drand( 0 ) )
2056 190 CONTINUE
2057*
2058 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
2059 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
2060*
2061 jtmp = jj + itmp - lcmtc - 1
2062*
2063 DO 200 jk = jj, jtmp - 1
2064 dummy = dcmplx( pb_drand( 0 ),
2065 $ pb_drand( 0 ) )
2066 200 CONTINUE
2067*
2068 DO 210 jk = jtmp, jj + jb - 1
2069 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2070 $ pb_drand( 0 ) )
2071 210 CONTINUE
2072*
2073 END IF
2074*
2075 ELSE
2076*
2077 DO 220 jk = jj, jj + jb - 1
2078 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2079 $ pb_drand( 0 ) )
2080 220 CONTINUE
2081*
2082 END IF
2083*
2084 jj = jj + jb
2085*
2086 IF( jblk.EQ.1 ) THEN
2087*
2088* Jump INBLOC + ( NPCOL - 1 ) * NB columns
2089*
2090 lcmtc = lcmtc + jmp( jmp_nqinbloc )
2091 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2092 $ ib0 )
2093*
2094 ELSE
2095*
2096* Jump NPCOL * NB columns
2097*
2098 lcmtc = lcmtc + jmp( jmp_nqnb )
2099 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2100 $ ib0 )
2101*
2102 END IF
2103*
2104 ib1( 1 ) = ib0( 1 )
2105 ib1( 2 ) = ib0( 2 )
2106*
2107 230 CONTINUE
2108*
2109* Jump one row
2110*
2111 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2112*
2113 ib1( 1 ) = ib0( 1 )
2114 ib1( 2 ) = ib0( 2 )
2115 ib2( 1 ) = ib0( 1 )
2116 ib2( 2 ) = ib0( 2 )
2117*
2118 240 CONTINUE
2119*
2120 ii = ii + ib
2121*
2122 IF( iblk.EQ.1 ) THEN
2123*
2124* Jump IMBLOC + ( NPROW - 1 ) * MB rows
2125*
2126 lcmtr = lcmtr - jmp( jmp_npimbloc )
2127 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2128*
2129 ELSE
2130*
2131* Jump NPROW * MB rows
2132*
2133 lcmtr = lcmtr - jmp( jmp_npmb )
2134 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2135*
2136 END IF
2137*
2138 ib1( 1 ) = ib0( 1 )
2139 ib1( 2 ) = ib0( 2 )
2140 ib2( 1 ) = ib0( 1 )
2141 ib2( 2 ) = ib0( 2 )
2142 ib3( 1 ) = ib0( 1 )
2143 ib3( 2 ) = ib0( 2 )
2144*
2145 250 CONTINUE
2146*
2147 END IF
2148*
2149 ELSE IF( lsame( aform, 'C' ) ) THEN
2150*
2151* Generate the conjugate transpose of the matrix that would be
2152* normally generated.
2153*
2154 ii = 1
2155*
2156 DO 290 iblk = 1, mblks
2157*
2158 IF( iblk.EQ.1 ) THEN
2159 ib = imbloc
2160 ELSE IF( iblk.EQ.mblks ) THEN
2161 ib = lmbloc
2162 ELSE
2163 ib = mb
2164 END IF
2165*
2166 DO 280 ik = ii, ii + ib - 1
2167*
2168 jj = 1
2169*
2170 DO 270 jblk = 1, nblks
2171*
2172 IF( jblk.EQ.1 ) THEN
2173 jb = inbloc
2174 ELSE IF( jblk.EQ.nblks ) THEN
2175 jb = lnbloc
2176 ELSE
2177 jb = nb
2178 END IF
2179*
2180* Blocks are IB by JB
2181*
2182 DO 260 jk = jj, jj + jb - 1
2183 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2184 $ -pb_drand( 0 ) )
2185 260 CONTINUE
2186*
2187 jj = jj + jb
2188*
2189 IF( jblk.EQ.1 ) THEN
2190*
2191* Jump INBLOC + ( NPCOL - 1 ) * NB columns
2192*
2193 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2194 $ ib0 )
2195*
2196 ELSE
2197*
2198* Jump NPCOL * NB columns
2199*
2200 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2201 $ ib0 )
2202*
2203 END IF
2204*
2205 ib1( 1 ) = ib0( 1 )
2206 ib1( 2 ) = ib0( 2 )
2207*
2208 270 CONTINUE
2209*
2210* Jump one row
2211*
2212 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2213*
2214 ib1( 1 ) = ib0( 1 )
2215 ib1( 2 ) = ib0( 2 )
2216 ib2( 1 ) = ib0( 1 )
2217 ib2( 2 ) = ib0( 2 )
2218*
2219 280 CONTINUE
2220*
2221 ii = ii + ib
2222*
2223 IF( iblk.EQ.1 ) THEN
2224*
2225* Jump IMBLOC + ( NPROW - 1 ) * MB rows
2226*
2227 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2228*
2229 ELSE
2230*
2231* Jump NPROW * MB rows
2232*
2233 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2234*
2235 END IF
2236*
2237 ib1( 1 ) = ib0( 1 )
2238 ib1( 2 ) = ib0( 2 )
2239 ib2( 1 ) = ib0( 1 )
2240 ib2( 2 ) = ib0( 2 )
2241 ib3( 1 ) = ib0( 1 )
2242 ib3( 2 ) = ib0( 2 )
2243*
2244 290 CONTINUE
2245*
2246 ELSE IF( lsame( aform, 'H' ) ) THEN
2247*
2248* Generate a Hermitian matrix
2249*
2250 IF( lsame( uplo, 'L' ) ) THEN
2251*
2252* generate lower trapezoidal part
2253*
2254 jj = 1
2255 lcmtc = lcmt00
2256*
2257 DO 370 jblk = 1, nblks
2258*
2259 IF( jblk.EQ.1 ) THEN
2260 jb = inbloc
2261 low = 1 - inbloc
2262 ELSE IF( jblk.EQ.nblks ) THEN
2263 jb = lnbloc
2264 low = 1 - nb
2265 ELSE
2266 jb = nb
2267 low = 1 - nb
2268 END IF
2269*
2270 DO 360 jk = jj, jj + jb - 1
2271*
2272 ii = 1
2273 lcmtr = lcmtc
2274*
2275 DO 350 iblk = 1, mblks
2276*
2277 IF( iblk.EQ.1 ) THEN
2278 ib = imbloc
2279 upp = imbloc - 1
2280 ELSE IF( iblk.EQ.mblks ) THEN
2281 ib = lmbloc
2282 upp = mb - 1
2283 ELSE
2284 ib = mb
2285 upp = mb - 1
2286 END IF
2287*
2288* Blocks are IB by JB
2289*
2290 IF( lcmtr.GT.upp ) THEN
2291*
2292 DO 300 ik = ii, ii + ib - 1
2293 dummy = dcmplx( pb_drand( 0 ),
2294 $ pb_drand( 0 ) )
2295 300 CONTINUE
2296*
2297 ELSE IF( lcmtr.GE.low ) THEN
2298*
2299 jtmp = jk - jj + 1
2300 mnb = max( 0, -lcmtr )
2301*
2302 IF( jtmp.LE.min( mnb, jb ) ) THEN
2303*
2304 DO 310 ik = ii, ii + ib - 1
2305 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2306 $ pb_drand( 0 ) )
2307 310 CONTINUE
2308*
2309 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
2310 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
2311*
2312 itmp = ii + jtmp + lcmtr - 1
2313*
2314 DO 320 ik = ii, itmp - 1
2315 dummy = dcmplx( pb_drand( 0 ),
2316 $ pb_drand( 0 ) )
2317 320 CONTINUE
2318*
2319 IF( itmp.LE.( ii + ib - 1 ) ) THEN
2320 dummy = dcmplx( pb_drand( 0 ),
2321 $ -pb_drand( 0 ) )
2322 a( itmp, jk ) = dcmplx( dble( dummy ),
2323 $ zero )
2324 END IF
2325*
2326 DO 330 ik = itmp + 1, ii + ib - 1
2327 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2328 $ pb_drand( 0 ) )
2329 330 CONTINUE
2330*
2331 END IF
2332*
2333 ELSE
2334*
2335 DO 340 ik = ii, ii + ib - 1
2336 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2337 $ pb_drand( 0 ) )
2338 340 CONTINUE
2339*
2340 END IF
2341*
2342 ii = ii + ib
2343*
2344 IF( iblk.EQ.1 ) THEN
2345*
2346* Jump IMBLOC + ( NPROW - 1 ) * MB rows
2347*
2348 lcmtr = lcmtr - jmp( jmp_npimbloc )
2349 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
2350 $ ib0 )
2351*
2352 ELSE
2353*
2354* Jump NPROW * MB rows
2355*
2356 lcmtr = lcmtr - jmp( jmp_npmb )
2357 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
2358 $ ib0 )
2359*
2360 END IF
2361*
2362 ib1( 1 ) = ib0( 1 )
2363 ib1( 2 ) = ib0( 2 )
2364*
2365 350 CONTINUE
2366*
2367* Jump one column
2368*
2369 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
2370*
2371 ib1( 1 ) = ib0( 1 )
2372 ib1( 2 ) = ib0( 2 )
2373 ib2( 1 ) = ib0( 1 )
2374 ib2( 2 ) = ib0( 2 )
2375*
2376 360 CONTINUE
2377*
2378 jj = jj + jb
2379*
2380 IF( jblk.EQ.1 ) THEN
2381*
2382* Jump INBLOC + ( NPCOL - 1 ) * NB columns
2383*
2384 lcmtc = lcmtc + jmp( jmp_nqinbloc )
2385 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
2386*
2387 ELSE
2388*
2389* Jump NPCOL * NB columns
2390*
2391 lcmtc = lcmtc + jmp( jmp_nqnb )
2392 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
2393*
2394 END IF
2395*
2396 ib1( 1 ) = ib0( 1 )
2397 ib1( 2 ) = ib0( 2 )
2398 ib2( 1 ) = ib0( 1 )
2399 ib2( 2 ) = ib0( 2 )
2400 ib3( 1 ) = ib0( 1 )
2401 ib3( 2 ) = ib0( 2 )
2402*
2403 370 CONTINUE
2404*
2405 ELSE
2406*
2407* generate upper trapezoidal part
2408*
2409 ii = 1
2410 lcmtr = lcmt00
2411*
2412 DO 450 iblk = 1, mblks
2413*
2414 IF( iblk.EQ.1 ) THEN
2415 ib = imbloc
2416 upp = imbloc - 1
2417 ELSE IF( iblk.EQ.mblks ) THEN
2418 ib = lmbloc
2419 upp = mb - 1
2420 ELSE
2421 ib = mb
2422 upp = mb - 1
2423 END IF
2424*
2425 DO 440 ik = ii, ii + ib - 1
2426*
2427 jj = 1
2428 lcmtc = lcmtr
2429*
2430 DO 430 jblk = 1, nblks
2431*
2432 IF( jblk.EQ.1 ) THEN
2433 jb = inbloc
2434 low = 1 - inbloc
2435 ELSE IF( jblk.EQ.nblks ) THEN
2436 jb = lnbloc
2437 low = 1 - nb
2438 ELSE
2439 jb = nb
2440 low = 1 - nb
2441 END IF
2442*
2443* Blocks are IB by JB
2444*
2445 IF( lcmtc.LT.low ) THEN
2446*
2447 DO 380 jk = jj, jj + jb - 1
2448 dummy = dcmplx( pb_drand( 0 ),
2449 $ -pb_drand( 0 ) )
2450 380 CONTINUE
2451*
2452 ELSE IF( lcmtc.LE.upp ) THEN
2453*
2454 itmp = ik - ii + 1
2455 mnb = max( 0, lcmtc )
2456*
2457 IF( itmp.LE.min( mnb, ib ) ) THEN
2458*
2459 DO 390 jk = jj, jj + jb - 1
2460 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2461 $ -pb_drand( 0 ) )
2462 390 CONTINUE
2463*
2464 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
2465 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
2466*
2467 jtmp = jj + itmp - lcmtc - 1
2468*
2469 DO 400 jk = jj, jtmp - 1
2470 dummy = dcmplx( pb_drand( 0 ),
2471 $ -pb_drand( 0 ) )
2472 400 CONTINUE
2473*
2474 IF( jtmp.LE.( jj + jb - 1 ) ) THEN
2475 dummy = dcmplx( pb_drand( 0 ),
2476 $ -pb_drand( 0 ) )
2477 a( ik, jtmp ) = dcmplx( dble( dummy ),
2478 $ zero )
2479 END IF
2480*
2481 DO 410 jk = jtmp + 1, jj + jb - 1
2482 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2483 $ -pb_drand( 0 ) )
2484 410 CONTINUE
2485*
2486 END IF
2487*
2488 ELSE
2489*
2490 DO 420 jk = jj, jj + jb - 1
2491 a( ik, jk ) = dcmplx( pb_drand( 0 ),
2492 $ -pb_drand( 0 ) )
2493 420 CONTINUE
2494*
2495 END IF
2496*
2497 jj = jj + jb
2498*
2499 IF( jblk.EQ.1 ) THEN
2500*
2501* Jump INBLOC + ( NPCOL - 1 ) * NB columns
2502*
2503 lcmtc = lcmtc + jmp( jmp_nqinbloc )
2504 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
2505 $ ib0 )
2506*
2507 ELSE
2508*
2509* Jump NPCOL * NB columns
2510*
2511 lcmtc = lcmtc + jmp( jmp_nqnb )
2512 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
2513 $ ib0 )
2514*
2515 END IF
2516*
2517 ib1( 1 ) = ib0( 1 )
2518 ib1( 2 ) = ib0( 2 )
2519*
2520 430 CONTINUE
2521*
2522* Jump one row
2523*
2524 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
2525*
2526 ib1( 1 ) = ib0( 1 )
2527 ib1( 2 ) = ib0( 2 )
2528 ib2( 1 ) = ib0( 1 )
2529 ib2( 2 ) = ib0( 2 )
2530*
2531 440 CONTINUE
2532*
2533 ii = ii + ib
2534*
2535 IF( iblk.EQ.1 ) THEN
2536*
2537* Jump IMBLOC + ( NPROW - 1 ) * MB rows
2538*
2539 lcmtr = lcmtr - jmp( jmp_npimbloc )
2540 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
2541*
2542 ELSE
2543*
2544* Jump NPROW * MB rows
2545*
2546 lcmtr = lcmtr - jmp( jmp_npmb )
2547 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
2548*
2549 END IF
2550*
2551 ib1( 1 ) = ib0( 1 )
2552 ib1( 2 ) = ib0( 2 )
2553 ib2( 1 ) = ib0( 1 )
2554 ib2( 2 ) = ib0( 2 )
2555 ib3( 1 ) = ib0( 1 )
2556 ib3( 2 ) = ib0( 2 )
2557*
2558 450 CONTINUE
2559*
2560 END IF
2561*
2562 END IF
2563*
2564 RETURN
2565*
2566* End of PB_ZLAGEN
2567*
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: