OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pcblastim.f File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine pclascal (type, m, n, alpha, a, ia, ja, desca)
subroutine pclagen (inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
subroutine pcladom (inplace, n, alpha, a, ia, ja, desca)
subroutine pb_clascal (uplo, m, n, ioffd, alpha, a, lda)
subroutine pb_clagen (uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
real function pb_srand (idumm)
real function pb_sran (idumm)

Function/Subroutine Documentation

◆ pb_clagen()

subroutine pb_clagen ( character*1 uplo,
character*1 aform,
complex, 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 1498 of file pcblastim.f.

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

◆ pb_clascal()

subroutine pb_clascal ( character*1 uplo,
integer m,
integer n,
integer ioffd,
complex alpha,
complex, dimension( lda, * ) a,
integer lda )

Definition at line 1319 of file pcblastim.f.

1320*
1321* -- PBLAS test routine (version 2.0) --
1322* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1323* and University of California, Berkeley.
1324* April 1, 1998
1325*
1326* .. Scalar Arguments ..
1327 CHARACTER*1 UPLO
1328 INTEGER IOFFD, LDA, M, N
1329 COMPLEX ALPHA
1330* ..
1331* .. Array Arguments ..
1332 COMPLEX A( LDA, * )
1333* ..
1334*
1335* Purpose
1336* =======
1337*
1338* PB_CLASCAL scales a two-dimensional array A by the scalar alpha.
1339*
1340* Arguments
1341* =========
1342*
1343* UPLO (input) CHARACTER*1
1344* On entry, UPLO specifies which trapezoidal part of the ar-
1345* ray A is to be scaled as follows:
1346* = 'L' or 'l': the lower trapezoid of A is scaled,
1347* = 'U' or 'u': the upper trapezoid of A is scaled,
1348* = 'D' or 'd': diagonal specified by IOFFD is scaled,
1349* Otherwise: all of the array A is scaled.
1350*
1351* M (input) INTEGER
1352* On entry, M specifies the number of rows of the array A. M
1353* must be at least zero.
1354*
1355* N (input) INTEGER
1356* On entry, N specifies the number of columns of the array A.
1357* N must be at least zero.
1358*
1359* IOFFD (input) INTEGER
1360* On entry, IOFFD specifies the position of the offdiagonal de-
1361* limiting the upper and lower trapezoidal part of A as follows
1362* (see the notes below):
1363*
1364* IOFFD = 0 specifies the main diagonal A( i, i ),
1365* with i = 1 ... MIN( M, N ),
1366* IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
1367* with i = 1 ... MIN( M-IOFFD, N ),
1368* IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
1369* with i = 1 ... MIN( M, N+IOFFD ).
1370*
1371* ALPHA (input) COMPLEX
1372* On entry, ALPHA specifies the scalar alpha.
1373*
1374* A (input/output) COMPLEX array
1375* On entry, A is an array of dimension (LDA,N). Before entry
1376* with UPLO = 'U' or 'u', the leading m by n part of the array
1377* A must contain the upper trapezoidal part of the matrix as
1378* specified by IOFFD to be scaled, and the strictly lower tra-
1379* pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
1380* the leading m by n part of the array A must contain the lower
1381* trapezoidal part of the matrix as specified by IOFFD to be
1382* scaled, and the strictly upper trapezoidal part of A is not
1383* referenced. On exit, the entries of the trapezoid part of A
1384* determined by UPLO and IOFFD are scaled.
1385*
1386* LDA (input) INTEGER
1387* On entry, LDA specifies the leading dimension of the array A.
1388* LDA must be at least max( 1, M ).
1389*
1390* Notes
1391* =====
1392* N N
1393* ---------------------------- -----------
1394* | d | | |
1395* M | d 'U' | | 'U' |
1396* | 'L' 'D' | |d |
1397* | d | M | d |
1398* ---------------------------- | 'D' |
1399* | d |
1400* IOFFD < 0 | 'L' d |
1401* | d|
1402* N | |
1403* ----------- -----------
1404* | d 'U'|
1405* | d | IOFFD > 0
1406* M | 'D' |
1407* | d| N
1408* | 'L' | ----------------------------
1409* | | | 'U' |
1410* | | |d |
1411* | | | 'D' |
1412* | | | d |
1413* | | |'L' d |
1414* ----------- ----------------------------
1415*
1416* -- Written on April 1, 1998 by
1417* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1418*
1419* =====================================================================
1420*
1421* .. Local Scalars ..
1422 INTEGER I, J, JTMP, MN
1423* ..
1424* .. External Functions ..
1425 LOGICAL LSAME
1426 EXTERNAL lsame
1427* ..
1428* .. Intrinsic Functions ..
1429 INTRINSIC max, min
1430* ..
1431* .. Executable Statements ..
1432*
1433* Quick return if possible
1434*
1435 IF( m.LE.0 .OR. n.LE.0 )
1436 $ RETURN
1437*
1438* Start the operations
1439*
1440 IF( lsame( uplo, 'L' ) ) THEN
1441*
1442* Scales the lower triangular part of the array by ALPHA.
1443*
1444 mn = max( 0, -ioffd )
1445 DO 20 j = 1, min( mn, n )
1446 DO 10 i = 1, m
1447 a( i, j ) = alpha * a( i, j )
1448 10 CONTINUE
1449 20 CONTINUE
1450 DO 40 j = mn + 1, min( m - ioffd, n )
1451 DO 30 i = j + ioffd, m
1452 a( i, j ) = alpha * a( i, j )
1453 30 CONTINUE
1454 40 CONTINUE
1455*
1456 ELSE IF( lsame( uplo, 'U' ) ) THEN
1457*
1458* Scales the upper triangular part of the array by ALPHA.
1459*
1460 mn = min( m - ioffd, n )
1461 DO 60 j = max( 0, -ioffd ) + 1, mn
1462 DO 50 i = 1, j + ioffd
1463 a( i, j ) = alpha * a( i, j )
1464 50 CONTINUE
1465 60 CONTINUE
1466 DO 80 j = max( 0, mn ) + 1, n
1467 DO 70 i = 1, m
1468 a( i, j ) = alpha * a( i, j )
1469 70 CONTINUE
1470 80 CONTINUE
1471*
1472 ELSE IF( lsame( uplo, 'D' ) ) THEN
1473*
1474* Scales the diagonal entries by ALPHA.
1475*
1476 DO 90 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
1477 jtmp = j + ioffd
1478 a( jtmp, j ) = alpha * a( jtmp, j )
1479 90 CONTINUE
1480*
1481 ELSE
1482*
1483* Scales the entire array by ALPHA.
1484*
1485 DO 110 j = 1, n
1486 DO 100 i = 1, m
1487 a( i, j ) = alpha * a( i, j )
1488 100 CONTINUE
1489 110 CONTINUE
1490*
1491 END IF
1492*
1493 RETURN
1494*
1495* End of PB_CLASCAL
1496*
alpha
#define alpha
Definition eval.h:35

◆ pb_sran()

real function pb_sran ( integer idumm)

Definition at line 2627 of file pcblastim.f.

2628*
2629* -- PBLAS test routine (version 2.0) --
2630* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2631* and University of California, Berkeley.
2632* April 1, 1998
2633*
2634* .. Scalar Arguments ..
2635 INTEGER IDUMM
2636* ..
2637*
2638* Purpose
2639* =======
2640*
2641* PB_SRAN generates the next number in the random sequence.
2642*
2643* Arguments
2644* =========
2645*
2646* IDUMM (local input) INTEGER
2647* This argument is ignored, but necessary to a FORTRAN 77 func-
2648* tion.
2649*
2650* Further Details
2651* ===============
2652*
2653* On entry, the array IRAND stored in the common block RANCOM contains
2654* the information (2 integers) required to generate the next number in
2655* the sequence X( n ). This number is computed as
2656*
2657* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2658*
2659* where the constant d is the largest 32 bit positive integer. The
2660* array IRAND is then updated for the generation of the next number
2661* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2662* The constants a and c should have been preliminarily stored in the
2663* array IACS as 2 pairs of integers. The initial set up of IRAND and
2664* IACS is performed by the routine PB_SETRAN.
2665*
2666* -- Written on April 1, 1998 by
2667* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2668*
2669* =====================================================================
2670*
2671* .. Parameters ..
2672 REAL DIVFAC, POW16
2673 parameter( divfac = 2.147483648e+9,
2674 $ pow16 = 6.5536e+4 )
2675* ..
2676* .. Local Arrays ..
2677 INTEGER J( 2 )
2678* ..
2679* .. External Subroutines ..
2680 EXTERNAL pb_ladd, pb_lmul
2681* ..
2682* .. Intrinsic Functions ..
2683 INTRINSIC real
2684* ..
2685* .. Common Blocks ..
2686 INTEGER IACS( 4 ), IRAND( 2 )
2687 COMMON /rancom/ irand, iacs
2688* ..
2689* .. Save Statements ..
2690 SAVE /rancom/
2691* ..
2692* .. Executable Statements ..
2693*
2694 pb_sran = ( real( irand( 1 ) ) + pow16 * real( irand( 2 ) ) ) /
2695 $ divfac
2696*
2697 CALL pb_lmul( irand, iacs, j )
2698 CALL pb_ladd( j, iacs( 3 ), irand )
2699*
2700 RETURN
2701*
2702* End of PB_SRAN
2703*
pb_ladd
subroutine pb_ladd(j, k, i)
Definition pblastst.f:4480
pb_lmul
subroutine pb_lmul(k, j, i)
Definition pblastst.f:4559
pb_sran
real function pb_sran(idumm)
Definition pcblastim.f:2628

◆ pb_srand()

real function pb_srand ( integer idumm)

Definition at line 2565 of file pcblastim.f.

2566*
2567* -- PBLAS test routine (version 2.0) --
2568* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2569* and University of California, Berkeley.
2570* April 1, 1998
2571*
2572* .. Scalar Arguments ..
2573 INTEGER IDUMM
2574* ..
2575*
2576* Purpose
2577* =======
2578*
2579* PB_SRAND generates the next number in the random sequence. This func-
2580* tion ensures that this number will be in the interval ( -1.0, 1.0 ).
2581*
2582* Arguments
2583* =========
2584*
2585* IDUMM (local input) INTEGER
2586* This argument is ignored, but necessary to a FORTRAN 77 func-
2587* tion.
2588*
2589* Further Details
2590* ===============
2591*
2592* On entry, the array IRAND stored in the common block RANCOM contains
2593* the information (2 integers) required to generate the next number in
2594* the sequence X( n ). This number is computed as
2595*
2596* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2597*
2598* where the constant d is the largest 32 bit positive integer. The
2599* array IRAND is then updated for the generation of the next number
2600* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2601* The constants a and c should have been preliminarily stored in the
2602* array IACS as 2 pairs of integers. The initial set up of IRAND and
2603* IACS is performed by the routine PB_SETRAN.
2604*
2605* -- Written on April 1, 1998 by
2606* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2607*
2608* =====================================================================
2609*
2610* .. Parameters ..
2611 REAL ONE, TWO
2612 parameter( one = 1.0e+0, two = 2.0e+0 )
2613* ..
2614* .. External Functions ..
2615 REAL PB_SRAN
2616 EXTERNAL pb_sran
2617* ..
2618* .. Executable Statements ..
2619*
2620 pb_srand = one - two * pb_sran( idumm )
2621*
2622 RETURN
2623*
2624* End of PB_SRAND
2625*

◆ pcladom()

subroutine pcladom ( logical inplace,
integer n,
complex alpha,
complex, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca )

Definition at line 912 of file pcblastim.f.

913*
914* -- PBLAS test routine (version 2.0) --
915* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
916* and University of California, Berkeley.
917* April 1, 1998
918*
919* .. Scalar Arguments ..
920 LOGICAL INPLACE
921 INTEGER IA, JA, N
922 COMPLEX ALPHA
923* ..
924* .. Array Arguments ..
925 INTEGER DESCA( * )
926 COMPLEX A( * )
927* ..
928*
929* Purpose
930* =======
931*
932* PCLADOM adds alpha to the diagonal entries of an n by n submatrix
933* sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
934*
935* Notes
936* =====
937*
938* A description vector is associated with each 2D block-cyclicly dis-
939* tributed matrix. This vector stores the information required to
940* establish the mapping between a matrix entry and its corresponding
941* process and memory location.
942*
943* In the following comments, the character _ should be read as
944* "of the distributed matrix". Let A be a generic term for any 2D
945* block cyclicly distributed matrix. Its description vector is DESCA:
946*
947* NOTATION STORED IN EXPLANATION
948* ---------------- --------------- ------------------------------------
949* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
950* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
951* the NPROW x NPCOL BLACS process grid
952* A is distributed over. The context
953* itself is global, but the handle
954* (the integer value) may vary.
955* M_A (global) DESCA( M_ ) The number of rows in the distribu-
956* ted matrix A, M_A >= 0.
957* N_A (global) DESCA( N_ ) The number of columns in the distri-
958* buted matrix A, N_A >= 0.
959* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
960* block of the matrix A, IMB_A > 0.
961* INB_A (global) DESCA( INB_ ) The number of columns of the upper
962* left block of the matrix A,
963* INB_A > 0.
964* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
965* bute the last M_A-IMB_A rows of A,
966* MB_A > 0.
967* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
968* bute the last N_A-INB_A columns of
969* A, NB_A > 0.
970* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
971* row of the matrix A is distributed,
972* NPROW > RSRC_A >= 0.
973* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
974* first column of A is distributed.
975* NPCOL > CSRC_A >= 0.
976* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
977* array storing the local blocks of
978* the distributed matrix A,
979* IF( Lc( 1, N_A ) > 0 )
980* LLD_A >= MAX( 1, Lr( 1, M_A ) )
981* ELSE
982* LLD_A >= 1.
983*
984* Let K be the number of rows of a matrix A starting at the global in-
985* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
986* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
987* receive if these K rows were distributed over NPROW processes. If K
988* is the number of columns of a matrix A starting at the global index
989* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
990* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
991* these K columns were distributed over NPCOL processes.
992*
993* The values of Lr() and Lc() may be determined via a call to the func-
994* tion PB_NUMROC:
995* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
996* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
997*
998* Arguments
999* =========
1000*
1001* INPLACE (global input) LOGICAL
1002* On entry, INPLACE specifies if the matrix should be generated
1003* in place or not. If INPLACE is .TRUE., the local random array
1004* to be generated will start in memory at the local memory lo-
1005* cation A( 1, 1 ), otherwise it will start at the local posi-
1006* tion induced by IA and JA.
1007*
1008* N (global input) INTEGER
1009* On entry, N specifies the global order of the submatrix
1010* sub( A ) to be modified. N must be at least zero.
1011*
1012* ALPHA (global input) COMPLEX
1013* On entry, ALPHA specifies the scalar alpha.
1014*
1015* A (local input/local output) COMPLEX array
1016* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
1017* at least Lc( 1, JA+N-1 ). Before entry, this array contains
1018* the local entries of the matrix A. On exit, the local entries
1019* of this array corresponding to the main diagonal of sub( A )
1020* have been updated.
1021*
1022* IA (global input) INTEGER
1023* On entry, IA specifies A's global row index, which points to
1024* the beginning of the submatrix sub( A ).
1025*
1026* JA (global input) INTEGER
1027* On entry, JA specifies A's global column index, which points
1028* to the beginning of the submatrix sub( A ).
1029*
1030* DESCA (global and local input) INTEGER array
1031* On entry, DESCA is an integer array of dimension DLEN_. This
1032* is the array descriptor for the matrix A.
1033*
1034* -- Written on April 1, 1998 by
1035* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1036*
1037* =====================================================================
1038*
1039* .. Parameters ..
1040 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1041 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1042 $ RSRC_
1043 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1044 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1045 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1046 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1047* ..
1048* .. Local Scalars ..
1049 LOGICAL GODOWN, GOLEFT
1050 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
1051 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
1052 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
1053 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
1054 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
1055 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
1056 COMPLEX ATMP
1057* ..
1058* .. Local Scalars ..
1059 INTEGER DESCA2( DLEN_ )
1060* ..
1061* .. External Subroutines ..
1062 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
1063 $ pb_desctrans
1064* ..
1065* .. Intrinsic Functions ..
1066 INTRINSIC abs, aimag, cmplx, max, min, real
1067* ..
1068* .. Executable Statements ..
1069*
1070* Convert descriptor
1071*
1072 CALL pb_desctrans( desca, desca2 )
1073*
1074* Get grid parameters
1075*
1076 ictxt = desca2( ctxt_ )
1077 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1078*
1079 IF( n.EQ.0 )
1080 $ RETURN
1081*
1082 CALL pb_ainfog2l( n, n, ia, ja, desca2, nprow, npcol, myrow,
1083 $ mycol, imb1, inb1, np, nq, iia, jja, iarow,
1084 $ iacol, mrrow, mrcol )
1085*
1086* Decide where the entries shall be stored in memory
1087*
1088 IF( inplace ) THEN
1089 iia = 1
1090 jja = 1
1091 END IF
1092*
1093* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
1094* ILOW, LOW, IUPP, and UPP.
1095*
1096 mb = desca2( mb_ )
1097 nb = desca2( nb_ )
1098*
1099 CALL pb_binfo( 0, np, nq, imb1, inb1, mb, nb, mrrow, mrcol,
1100 $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
1101 $ lnbloc, ilow, low, iupp, upp )
1102*
1103 ioffa = iia - 1
1104 joffa = jja - 1
1105 lda = desca2( lld_ )
1106 ldap1 = lda + 1
1107*
1108 IF( desca2( rsrc_ ).LT.0 ) THEN
1109 pmb = mb
1110 ELSE
1111 pmb = nprow * mb
1112 END IF
1113 IF( desca2( csrc_ ).LT.0 ) THEN
1114 qnb = nb
1115 ELSE
1116 qnb = npcol * nb
1117 END IF
1118*
1119* Handle the first block of rows or columns separately, and update
1120* LCMT00, MBLKS and NBLKS.
1121*
1122 godown = ( lcmt00.GT.iupp )
1123 goleft = ( lcmt00.LT.ilow )
1124*
1125 IF( .NOT.godown .AND. .NOT.goleft ) THEN
1126*
1127* LCMT00 >= ILOW && LCMT00 <= IUPP
1128*
1129 IF( lcmt00.GE.0 ) THEN
1130 ijoffa = ioffa+lcmt00 + ( joffa - 1 ) * lda
1131 DO 10 i = 1, min( inbloc, max( 0, imbloc - lcmt00 ) )
1132 atmp = a( ijoffa + i*ldap1 )
1133 a( ijoffa + i*ldap1 ) = alpha +
1134 $ cmplx( abs( real( atmp ) ),
1135 $ abs( aimag( atmp ) ) )
1136 10 CONTINUE
1137 ELSE
1138 ijoffa = ioffa + ( joffa - lcmt00 - 1 ) * lda
1139 DO 20 i = 1, min( imbloc, max( 0, inbloc + lcmt00 ) )
1140 atmp = a( ijoffa + i*ldap1 )
1141 a( ijoffa + i*ldap1 ) = alpha +
1142 $ cmplx( abs( real( atmp ) ),
1143 $ abs( aimag( atmp ) ) )
1144 20 CONTINUE
1145 END IF
1146 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
1147 godown = .NOT.goleft
1148*
1149 END IF
1150*
1151 IF( godown ) THEN
1152*
1153 lcmt00 = lcmt00 - ( iupp - upp + pmb )
1154 mblks = mblks - 1
1155 ioffa = ioffa + imbloc
1156*
1157 30 CONTINUE
1158 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
1159 lcmt00 = lcmt00 - pmb
1160 mblks = mblks - 1
1161 ioffa = ioffa + mb
1162 GO TO 30
1163 END IF
1164*
1165 lcmt = lcmt00
1166 mblkd = mblks
1167 ioffd = ioffa
1168*
1169 mbloc = mb
1170 40 CONTINUE
1171 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
1172 IF( mblkd.EQ.1 )
1173 $ mbloc = lmbloc
1174 IF( lcmt.GE.0 ) THEN
1175 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
1176 DO 50 i = 1, min( inbloc, max( 0, mbloc - lcmt ) )
1177 atmp = a( ijoffa + i*ldap1 )
1178 a( ijoffa + i*ldap1 ) = alpha +
1179 $ cmplx( abs( real( atmp ) ),
1180 $ abs( aimag( atmp ) ) )
1181 50 CONTINUE
1182 ELSE
1183 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
1184 DO 60 i = 1, min( mbloc, max( 0, inbloc + lcmt ) )
1185 atmp = a( ijoffa + i*ldap1 )
1186 a( ijoffa + i*ldap1 ) = alpha +
1187 $ cmplx( abs( real( atmp ) ),
1188 $ abs( aimag( atmp ) ) )
1189 60 CONTINUE
1190 END IF
1191 lcmt00 = lcmt
1192 lcmt = lcmt - pmb
1193 mblks = mblkd
1194 mblkd = mblkd - 1
1195 ioffa = ioffd
1196 ioffd = ioffd + mbloc
1197 GO TO 40
1198 END IF
1199*
1200 lcmt00 = lcmt00 + low - ilow + qnb
1201 nblks = nblks - 1
1202 joffa = joffa + inbloc
1203*
1204 ELSE IF( goleft ) THEN
1205*
1206 lcmt00 = lcmt00 + low - ilow + qnb
1207 nblks = nblks - 1
1208 joffa = joffa + inbloc
1209*
1210 70 CONTINUE
1211 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
1212 lcmt00 = lcmt00 + qnb
1213 nblks = nblks - 1
1214 joffa = joffa + nb
1215 GO TO 70
1216 END IF
1217*
1218 lcmt = lcmt00
1219 nblkd = nblks
1220 joffd = joffa
1221*
1222 nbloc = nb
1223 80 CONTINUE
1224 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
1225 IF( nblkd.EQ.1 )
1226 $ nbloc = lnbloc
1227 IF( lcmt.GE.0 ) THEN
1228 ijoffa = ioffa + lcmt + ( joffd - 1 ) * lda
1229 DO 90 i = 1, min( nbloc, max( 0, imbloc - lcmt ) )
1230 atmp = a( ijoffa + i*ldap1 )
1231 a( ijoffa + i*ldap1 ) = alpha +
1232 $ cmplx( abs( real( atmp ) ),
1233 $ abs( aimag( atmp ) ) )
1234 90 CONTINUE
1235 ELSE
1236 ijoffa = ioffa + ( joffd - lcmt - 1 ) * lda
1237 DO 100 i = 1, min( imbloc, max( 0, nbloc + lcmt ) )
1238 atmp = a( ijoffa + i*ldap1 )
1239 a( ijoffa + i*ldap1 ) = alpha +
1240 $ cmplx( abs( real( atmp ) ),
1241 $ abs( aimag( atmp ) ) )
1242 100 CONTINUE
1243 END IF
1244 lcmt00 = lcmt
1245 lcmt = lcmt + qnb
1246 nblks = nblkd
1247 nblkd = nblkd - 1
1248 joffa = joffd
1249 joffd = joffd + nbloc
1250 GO TO 80
1251 END IF
1252*
1253 lcmt00 = lcmt00 - ( iupp - upp + pmb )
1254 mblks = mblks - 1
1255 ioffa = ioffa + imbloc
1256*
1257 END IF
1258*
1259 nbloc = nb
1260 110 CONTINUE
1261 IF( nblks.GT.0 ) THEN
1262 IF( nblks.EQ.1 )
1263 $ nbloc = lnbloc
1264 120 CONTINUE
1265 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
1266 lcmt00 = lcmt00 - pmb
1267 mblks = mblks - 1
1268 ioffa = ioffa + mb
1269 GO TO 120
1270 END IF
1271*
1272 lcmt = lcmt00
1273 mblkd = mblks
1274 ioffd = ioffa
1275*
1276 mbloc = mb
1277 130 CONTINUE
1278 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
1279 IF( mblkd.EQ.1 )
1280 $ mbloc = lmbloc
1281 IF( lcmt.GE.0 ) THEN
1282 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
1283 DO 140 i = 1, min( nbloc, max( 0, mbloc - lcmt ) )
1284 atmp = a( ijoffa + i*ldap1 )
1285 a( ijoffa + i*ldap1 ) = alpha +
1286 $ cmplx( abs( real( atmp ) ),
1287 $ abs( aimag( atmp ) ) )
1288 140 CONTINUE
1289 ELSE
1290 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
1291 DO 150 i = 1, min( mbloc, max( 0, nbloc + lcmt ) )
1292 atmp = a( ijoffa + i*ldap1 )
1293 a( ijoffa + i*ldap1 ) = alpha +
1294 $ cmplx( abs( real( atmp ) ),
1295 $ abs( aimag( atmp ) ) )
1296 150 CONTINUE
1297 END IF
1298 lcmt00 = lcmt
1299 lcmt = lcmt - pmb
1300 mblks = mblkd
1301 mblkd = mblkd - 1
1302 ioffa = ioffd
1303 ioffd = ioffd + mbloc
1304 GO TO 130
1305 END IF
1306*
1307 lcmt00 = lcmt00 + qnb
1308 nblks = nblks - 1
1309 joffa = joffa + nbloc
1310 GO TO 110
1311*
1312 END IF
1313*
1314 RETURN
1315*
1316* End of PCLADOM
1317*
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pb_ainfog2l
subroutine pb_ainfog2l(m, n, i, j, desc, nprow, npcol, myrow, mycol, imb1, inb1, mp, nq, ii, jj, prow, pcol, rprow, rpcol)
Definition pblastst.f:2023
pb_binfo
subroutine pb_binfo(offd, m, n, imb1, inb1, mb, nb, mrrow, mrcol, lcmt00, mblks, nblks, imbloc, inbloc, lmbloc, lnbloc, ilow, low, iupp, upp)
Definition pblastst.f:3577
pb_desctrans
subroutine pb_desctrans(descin, descout)
Definition pblastst.f:2964

◆ pclagen()

subroutine pclagen ( logical inplace,
character*1 aform,
character*1 diag,
integer offa,
integer m,
integer n,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer iaseed,
complex, dimension( lda, * ) a,
integer lda )

Definition at line 508 of file pcblastim.f.

510*
511* -- PBLAS test routine (version 2.0) --
512* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
513* and University of California, Berkeley.
514* April 1, 1998
515*
516* .. Scalar Arguments ..
517 LOGICAL INPLACE
518 CHARACTER*1 AFORM, DIAG
519 INTEGER IA, IASEED, JA, LDA, M, N, OFFA
520* ..
521* .. Array Arguments ..
522 INTEGER DESCA( * )
523 COMPLEX A( LDA, * )
524* ..
525*
526* Purpose
527* =======
528*
529* PCLAGEN generates (or regenerates) a submatrix sub( A ) denoting
530* A(IA:IA+M-1,JA:JA+N-1).
531*
532* Notes
533* =====
534*
535* A description vector is associated with each 2D block-cyclicly dis-
536* tributed matrix. This vector stores the information required to
537* establish the mapping between a matrix entry and its corresponding
538* process and memory location.
539*
540* In the following comments, the character _ should be read as
541* "of the distributed matrix". Let A be a generic term for any 2D
542* block cyclicly distributed matrix. Its description vector is DESCA:
543*
544* NOTATION STORED IN EXPLANATION
545* ---------------- --------------- ------------------------------------
546* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
547* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
548* the NPROW x NPCOL BLACS process grid
549* A is distributed over. The context
550* itself is global, but the handle
551* (the integer value) may vary.
552* M_A (global) DESCA( M_ ) The number of rows in the distribu-
553* ted matrix A, M_A >= 0.
554* N_A (global) DESCA( N_ ) The number of columns in the distri-
555* buted matrix A, N_A >= 0.
556* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
557* block of the matrix A, IMB_A > 0.
558* INB_A (global) DESCA( INB_ ) The number of columns of the upper
559* left block of the matrix A,
560* INB_A > 0.
561* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
562* bute the last M_A-IMB_A rows of A,
563* MB_A > 0.
564* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
565* bute the last N_A-INB_A columns of
566* A, NB_A > 0.
567* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
568* row of the matrix A is distributed,
569* NPROW > RSRC_A >= 0.
570* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
571* first column of A is distributed.
572* NPCOL > CSRC_A >= 0.
573* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
574* array storing the local blocks of
575* the distributed matrix A,
576* IF( Lc( 1, N_A ) > 0 )
577* LLD_A >= MAX( 1, Lr( 1, M_A ) )
578* ELSE
579* LLD_A >= 1.
580*
581* Let K be the number of rows of a matrix A starting at the global in-
582* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
583* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
584* receive if these K rows were distributed over NPROW processes. If K
585* is the number of columns of a matrix A starting at the global index
586* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
587* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
588* these K columns were distributed over NPCOL processes.
589*
590* The values of Lr() and Lc() may be determined via a call to the func-
591* tion PB_NUMROC:
592* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
593* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
594*
595* Arguments
596* =========
597*
598* INPLACE (global input) LOGICAL
599* On entry, INPLACE specifies if the matrix should be generated
600* in place or not. If INPLACE is .TRUE., the local random array
601* to be generated will start in memory at the local memory lo-
602* cation A( 1, 1 ), otherwise it will start at the local posi-
603* tion induced by IA and JA.
604*
605* AFORM (global input) CHARACTER*1
606* On entry, AFORM specifies the type of submatrix to be genera-
607* ted as follows:
608* AFORM = 'S', sub( A ) is a symmetric matrix,
609* AFORM = 'H', sub( A ) is a Hermitian matrix,
610* AFORM = 'T', sub( A ) is overrwritten with the transpose
611* of what would normally be generated,
612* AFORM = 'C', sub( A ) is overwritten with the conjugate
613* transpose of what would normally be genera-
614* ted.
615* AFORM = 'N', a random submatrix is generated.
616*
617* DIAG (global input) CHARACTER*1
618* On entry, DIAG specifies if the generated submatrix is diago-
619* nally dominant or not as follows:
620* DIAG = 'D' : sub( A ) is diagonally dominant,
621* DIAG = 'N' : sub( A ) is not diagonally dominant.
622*
623* OFFA (global input) INTEGER
624* On entry, OFFA specifies the offdiagonal of the underlying
625* matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
626* trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
627* specifies the main diagonal, OFFA > 0 specifies a subdiago-
628* nal, and OFFA < 0 specifies a superdiagonal (see further de-
629* tails).
630*
631* M (global input) INTEGER
632* On entry, M specifies the global number of matrix rows of the
633* submatrix sub( A ) to be generated. M must be at least zero.
634*
635* N (global input) INTEGER
636* On entry, N specifies the global number of matrix columns of
637* the submatrix sub( A ) to be generated. N must be at least
638* zero.
639*
640* IA (global input) INTEGER
641* On entry, IA specifies A's global row index, which points to
642* the beginning of the submatrix sub( A ).
643*
644* JA (global input) INTEGER
645* On entry, JA specifies A's global column index, which points
646* to the beginning of the submatrix sub( A ).
647*
648* DESCA (global and local input) INTEGER array
649* On entry, DESCA is an integer array of dimension DLEN_. This
650* is the array descriptor for the matrix A.
651*
652* IASEED (global input) INTEGER
653* On entry, IASEED specifies the seed number to generate the
654* matrix A. IASEED must be at least zero.
655*
656* A (local output) COMPLEX array
657* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
658* at least Lc( 1, JA+N-1 ). On exit, this array contains the
659* local entries of the randomly generated submatrix sub( A ).
660*
661* LDA (local input) INTEGER
662* On entry, LDA specifies the local leading dimension of the
663* array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
664* This restriction is however not enforced, and this subroutine
665* requires only that LDA >= MAX( 1, Mp ) where
666*
667* Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
668*
669* PB_NUMROC is a ScaLAPACK tool function; MYROW, MYCOL, NPROW
670* and NPCOL can be determined by calling the BLACS subroutine
671* BLACS_GRIDINFO.
672*
673* Further Details
674* ===============
675*
676* OFFD is tied to the matrix described by DESCA, as opposed to the
677* piece that is currently (re)generated. This is a global information
678* independent from the distribution parameters. Below are examples of
679* the meaning of OFFD for a global 7 by 5 matrix:
680*
681* ---------------------------------------------------------------------
682* OFFD | 0 -1 -2 -3 -4 0 -1 -2 -3 -4 0 -1 -2 -3 -4
683* -------|-------------------------------------------------------------
684* | | OFFD=-1 | OFFD=0 OFFD=2
685* | V V
686* 0 | . d . . . -> d . . . . . . . . .
687* 1 | . . d . . . d . . . . . . . .
688* 2 | . . . d . . . d . . -> d . . . .
689* 3 | . . . . d . . . d . . d . . .
690* 4 | . . . . . . . . . d . . d . .
691* 5 | . . . . . . . . . . . . . d .
692* 6 | . . . . . . . . . . . . . . d
693* ---------------------------------------------------------------------
694*
695* -- Written on April 1, 1998 by
696* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
697*
698* =====================================================================
699*
700* .. Parameters ..
701 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
702 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
703 $ RSRC_
704 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
705 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
706 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
707 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
708 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
709 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
710 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
711 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
712 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
713 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
714 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
715 $ jmp_len = 11 )
716 REAL ZERO
717 parameter( zero = 0.0e+0 )
718* ..
719* .. Local Scalars ..
720 LOGICAL DIAGDO, SYMM, HERM, NOTRAN
721 INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
722 $ ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
723 $ INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
724 $ IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
725 $ LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
726 $ MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
727 $ NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
728 COMPLEX ALPHA
729* ..
730* .. Local Arrays ..
731 INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
732 $ IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
733* ..
734* .. External Subroutines ..
735 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
736 $ pb_chkmat, pb_clagen, pb_desctrans, pb_initjmp,
737 $ pb_initmuladd, pb_jump, pb_jumpit, pb_locinfo,
738 $ pb_setlocran, pb_setran, pcladom, pxerbla
739* ..
740* .. External Functions ..
741 LOGICAL LSAME
742 EXTERNAL lsame
743* ..
744* .. Intrinsic Functions ..
745 INTRINSIC cmplx, max, min, real
746* ..
747* .. Data Statements ..
748 DATA ( muladd0( i ), i = 1, 4 ) / 20077, 16838,
749 $ 12345, 0 /
750* ..
751* .. Executable Statements ..
752*
753* Convert descriptor
754*
755 CALL pb_desctrans( desca, desca2 )
756*
757* Test the input arguments
758*
759 ictxt = desca2( ctxt_ )
760 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
761*
762* Test the input parameters
763*
764 info = 0
765 IF( nprow.EQ.-1 ) THEN
766 info = -( 1000 + ctxt_ )
767 ELSE
768 symm = lsame( aform, 'S' )
769 herm = lsame( aform, 'H' )
770 notran = lsame( aform, 'N' )
771 diagdo = lsame( diag, 'D' )
772 IF( .NOT.( symm.OR.herm.OR.notran ) .AND.
773 $ .NOT.( lsame( aform, 'T' ) ) .AND.
774 $ .NOT.( lsame( aform, 'C' ) ) ) THEN
775 info = -2
776 ELSE IF( ( .NOT.diagdo ) .AND.
777 $ ( .NOT.lsame( diag, 'N' ) ) ) THEN
778 info = -3
779 END IF
780 CALL pb_chkmat( ictxt, m, 5, n, 6, ia, ja, desca2, 10, info )
781 END IF
782*
783 IF( info.NE.0 ) THEN
784 CALL pxerbla( ictxt, 'PCLAGEN', -info )
785 RETURN
786 END IF
787*
788* Quick return if possible
789*
790 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
791 $ RETURN
792*
793* Start the operations
794*
795 mb = desca2( mb_ )
796 nb = desca2( nb_ )
797 imb = desca2( imb_ )
798 inb = desca2( inb_ )
799 rsrc = desca2( rsrc_ )
800 csrc = desca2( csrc_ )
801*
802* Figure out local information about the distributed matrix operand
803*
804 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
805 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
806 $ iacol, mrrow, mrcol )
807*
808* Decide where the entries shall be stored in memory
809*
810 IF( inplace ) THEN
811 iia = 1
812 jja = 1
813 END IF
814*
815* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
816* ILOW, LOW, IUPP, and UPP.
817*
818 ioffda = ja + offa - ia
819 CALL pb_binfo( ioffda, mp, nq, imb1, inb1, mb, nb, mrrow,
820 $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
821 $ lmbloc, lnbloc, ilow, low, iupp, upp )
822*
823* Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
824* This values correspond to the square virtual underlying matrix
825* of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
826* to set up the random sequence. For practical purposes, the size
827* of this virtual matrix is upper bounded by M_ + N_ - 1.
828*
829 itmp = max( 0, -offa )
830 ivir = ia + itmp
831 imbvir = imb + itmp
832 nvir = desca2( m_ ) + itmp
833*
834 CALL pb_locinfo( ivir, imbvir, mb, myrow, rsrc, nprow, ilocblk,
835 $ ilocoff, myrdist )
836*
837 itmp = max( 0, offa )
838 jvir = ja + itmp
839 inbvir = inb + itmp
840 nvir = max( max( nvir, desca2( n_ ) + itmp ),
841 $ desca2( m_ ) + desca2( n_ ) - 1 )
842*
843 CALL pb_locinfo( jvir, inbvir, nb, mycol, csrc, npcol, jlocblk,
844 $ jlocoff, mycdist )
845*
846 IF( symm .OR. herm .OR. notran ) THEN
847*
848 CALL pb_initjmp( .true., nvir, imbvir, inbvir, imbloc, inbloc,
849 $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
850*
851* Compute constants to jump JMP( * ) numbers in the sequence
852*
853 CALL pb_initmuladd( muladd0, jmp, imuladd )
854*
855* Compute and set the random value corresponding to A( IA, JA )
856*
857 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
858 $ myrdist, mycdist, nprow, npcol, jmp,
859 $ imuladd, iran )
860*
861 CALL pb_clagen( 'Lower', aform, a( iia, jja ), lda, lcmt00,
862 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
863 $ nb, lnbloc, jmp, imuladd )
864*
865 END IF
866*
867 IF( symm .OR. herm .OR. ( .NOT. notran ) ) THEN
868*
869 CALL pb_initjmp( .false., nvir, imbvir, inbvir, imbloc, inbloc,
870 $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
871*
872* Compute constants to jump JMP( * ) numbers in the sequence
873*
874 CALL pb_initmuladd( muladd0, jmp, imuladd )
875*
876* Compute and set the random value corresponding to A( IA, JA )
877*
878 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
879 $ myrdist, mycdist, nprow, npcol, jmp,
880 $ imuladd, iran )
881*
882 CALL pb_clagen( 'Upper', aform, a( iia, jja ), lda, lcmt00,
883 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
884 $ nb, lnbloc, jmp, imuladd )
885*
886 END IF
887*
888 IF( diagdo ) THEN
889*
890 maxmn = max( desca2( m_ ), desca2( n_ ) )
891 IF( herm ) THEN
892 alpha = cmplx( real( 2 * maxmn ), zero )
893 ELSE
894 alpha = cmplx( real( maxmn ), real( maxmn ) )
895 END IF
896*
897 IF( ioffda.GE.0 ) THEN
898 CALL pcladom( inplace, min( max( 0, m-ioffda ), n ), alpha,
899 $ a, min( ia+ioffda, ia+m-1 ), ja, desca )
900 ELSE
901 CALL pcladom( inplace, min( m, max( 0, n+ioffda ) ), alpha,
902 $ a, ia, min( ja-ioffda, ja+n-1 ), desca )
903 END IF
904*
905 END IF
906*
907 RETURN
908*
909* End of PCLAGEN
910*
pxerbla
subroutine pxerbla(contxt, srname, info)
Definition mpi.f:1600
pb_setran
subroutine pb_setran(iran, iac)
Definition pblastst.f:4759
pb_locinfo
subroutine pb_locinfo(i, inb, nb, myroc, srcproc, nprocs, ilocblk, ilocoff, mydist)
Definition pblastst.f:3910
pb_chkmat
subroutine pb_chkmat(ictxt, m, mpos0, n, npos0, ia, ja, desca, dpos0, info)
Definition pblastst.f:2742
pb_jump
subroutine pb_jump(k, muladd, irann, iranm, ima)
Definition pblastst.f:4648
pb_setlocran
subroutine pb_setlocran(seed, ilocblk, jlocblk, ilocoff, jlocoff, myrdist, mycdist, nprow, npcol, jmp, imuladd, iran)
Definition pblastst.f:4302
pb_initmuladd
subroutine pb_initmuladd(muladd0, jmp, imuladd)
Definition pblastst.f:4196
pb_initjmp
subroutine pb_initjmp(colmaj, nvir, imbvir, inbvir, imbloc, inbloc, mb, nb, rsrc, csrc, nprow, npcol, stride, jmp)
Definition pblastst.f:4045
pcladom
subroutine pcladom(inplace, n, alpha, a, ia, ja, desca)
Definition pcblastim.f:913
pb_clagen
subroutine pb_clagen(uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
Definition pcblastim.f:1501

◆ pclascal()

subroutine pclascal ( character*1 type,
integer m,
integer n,
complex alpha,
complex, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca )

Definition at line 1 of file pcblastim.f.

2*
3* -- PBLAS test routine (version 2.0) --
4* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5* and University of California, Berkeley.
6* April 1, 1998
7*
8* .. Scalar Arguments ..
9 CHARACTER*1 TYPE
10 INTEGER IA, JA, M, N
11 COMPLEX ALPHA
12* ..
13* .. Array Arguments ..
14 INTEGER DESCA( * )
15 COMPLEX A( * )
16* ..
17*
18* Purpose
19* =======
20*
21* PCLASCAL scales the m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
22* by sub( A ) by the scalar alpha. TYPE specifies if sub( A ) is full,
23* upper triangular, lower triangular or upper Hessenberg.
24*
25* Notes
26* =====
27*
28* A description vector is associated with each 2D block-cyclicly dis-
29* tributed matrix. This vector stores the information required to
30* establish the mapping between a matrix entry and its corresponding
31* process and memory location.
32*
33* In the following comments, the character _ should be read as
34* "of the distributed matrix". Let A be a generic term for any 2D
35* block cyclicly distributed matrix. Its description vector is DESCA:
36*
37* NOTATION STORED IN EXPLANATION
38* ---------------- --------------- ------------------------------------
39* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
40* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
41* the NPROW x NPCOL BLACS process grid
42* A is distributed over. The context
43* itself is global, but the handle
44* (the integer value) may vary.
45* M_A (global) DESCA( M_ ) The number of rows in the distribu-
46* ted matrix A, M_A >= 0.
47* N_A (global) DESCA( N_ ) The number of columns in the distri-
48* buted matrix A, N_A >= 0.
49* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
50* block of the matrix A, IMB_A > 0.
51* INB_A (global) DESCA( INB_ ) The number of columns of the upper
52* left block of the matrix A,
53* INB_A > 0.
54* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
55* bute the last M_A-IMB_A rows of A,
56* MB_A > 0.
57* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
58* bute the last N_A-INB_A columns of
59* A, NB_A > 0.
60* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
61* row of the matrix A is distributed,
62* NPROW > RSRC_A >= 0.
63* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
64* first column of A is distributed.
65* NPCOL > CSRC_A >= 0.
66* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
67* array storing the local blocks of
68* the distributed matrix A,
69* IF( Lc( 1, N_A ) > 0 )
70* LLD_A >= MAX( 1, Lr( 1, M_A ) )
71* ELSE
72* LLD_A >= 1.
73*
74* Let K be the number of rows of a matrix A starting at the global in-
75* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
76* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
77* receive if these K rows were distributed over NPROW processes. If K
78* is the number of columns of a matrix A starting at the global index
79* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
80* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
81* these K columns were distributed over NPCOL processes.
82*
83* The values of Lr() and Lc() may be determined via a call to the func-
84* tion PB_NUMROC:
85* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
86* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
87*
88* Arguments
89* =========
90*
91* TYPE (global input) CHARACTER*1
92* On entry, TYPE specifies the type of the input submatrix as
93* follows:
94* = 'L' or 'l': sub( A ) is a lower triangular matrix,
95* = 'U' or 'u': sub( A ) is an upper triangular matrix,
96* = 'H' or 'h': sub( A ) is an upper Hessenberg matrix,
97* otherwise sub( A ) is a full matrix.
98*
99* M (global input) INTEGER
100* On entry, M specifies the number of rows of the submatrix
101* sub( A ). M must be at least zero.
102*
103* N (global input) INTEGER
104* On entry, N specifies the number of columns of the submatrix
105* sub( A ). N must be at least zero.
106*
107* ALPHA (global input) COMPLEX
108* On entry, ALPHA specifies the scalar alpha.
109*
110* A (local input/local output) COMPLEX array
111* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
112* at least Lc( 1, JA+N-1 ). Before entry, this array contains
113* the local entries of the matrix A.
114* On exit, the local entries of this array corresponding to the
115* to the entries of the submatrix sub( A ) are overwritten by
116* the local entries of the m by n scaled submatrix.
117*
118* IA (global input) INTEGER
119* On entry, IA specifies A's global row index, which points to
120* the beginning of the submatrix sub( A ).
121*
122* JA (global input) INTEGER
123* On entry, JA specifies A's global column index, which points
124* to the beginning of the submatrix sub( A ).
125*
126* DESCA (global and local input) INTEGER array
127* On entry, DESCA is an integer array of dimension DLEN_. This
128* is the array descriptor for the matrix A.
129*
130* -- Written on April 1, 1998 by
131* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
132*
133* =====================================================================
134*
135* .. Parameters ..
136 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
137 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
138 $ RSRC_
139 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
140 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
141 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
142 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
143* ..
144* .. Local Scalars ..
145 CHARACTER*1 UPLO
146 LOGICAL GODOWN, GOLEFT, LOWER, UPPER
147 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
148 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
149 $ IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
150 $ LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
151 $ MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
152 $ NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
153 $ QNB, TMP1, UPP
154* ..
155* .. Local Arrays ..
156 INTEGER DESCA2( DLEN_ )
157* ..
158* .. External Subroutines ..
159 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
160 $ pb_clascal, pb_desctrans, pb_infog2l
161* ..
162* .. External Functions ..
163 LOGICAL LSAME
164 INTEGER PB_NUMROC
165 EXTERNAL lsame, pb_numroc
166* ..
167* .. Intrinsic Functions ..
168 INTRINSIC min
169* ..
170* .. Executable Statements ..
171*
172* Convert descriptor
173*
174 CALL pb_desctrans( desca, desca2 )
175*
176* Get grid parameters
177*
178 ictxt = desca2( ctxt_ )
179 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
180*
181* Quick return if possible
182*
183 IF( m.EQ.0 .OR. n.EQ.0 )
184 $ RETURN
185*
186 IF( lsame( TYPE, 'L' ) ) THEN
187 itype = 1
188 uplo = TYPE
189 upper = .false.
190 lower = .true.
191 ioffd = 0
192 ELSE IF( lsame( TYPE, 'U' ) ) THEN
193 itype = 2
194 uplo = TYPE
195 upper = .true.
196 lower = .false.
197 ioffd = 0
198 ELSE IF( lsame( TYPE, 'H' ) ) THEN
199 itype = 3
200 uplo = 'U'
201 upper = .true.
202 lower = .false.
203 ioffd = 1
204 ELSE
205 itype = 0
206 uplo = 'A'
207 upper = .true.
208 lower = .true.
209 ioffd = 0
210 END IF
211*
212* Compute local indexes
213*
214 IF( itype.EQ.0 ) THEN
215*
216* Full matrix
217*
218 CALL pb_infog2l( ia, ja, desca2, nprow, npcol, myrow, mycol,
219 $ iia, jja, iarow, iacol )
220 mp = pb_numroc( m, ia, desca2( imb_ ), desca2( mb_ ), myrow,
221 $ desca2( rsrc_ ), nprow )
222 nq = pb_numroc( n, ja, desca2( inb_ ), desca2( nb_ ), mycol,
223 $ desca2( csrc_ ), npcol )
224*
225 IF( mp.LE.0 .OR. nq.LE.0 )
226 $ RETURN
227*
228 lda = desca2( lld_ )
229 ioffa = iia + ( jja - 1 ) * lda
230*
231 CALL pb_clascal( 'All', mp, nq, 0, alpha, a( ioffa ), lda )
232*
233 ELSE
234*
235* Trapezoidal matrix
236*
237 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
238 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
239 $ iacol, mrrow, mrcol )
240*
241 IF( mp.LE.0 .OR. nq.LE.0 )
242 $ RETURN
243*
244* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
245* LNBLOC, ILOW, LOW, IUPP, and UPP.
246*
247 mb = desca2( mb_ )
248 nb = desca2( nb_ )
249 lda = desca2( lld_ )
250*
251 CALL pb_binfo( ioffd, mp, nq, imb1, inb1, mb, nb, mrrow,
252 $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
253 $ lmbloc, lnbloc, ilow, low, iupp, upp )
254*
255 m1 = mp
256 n1 = nq
257 ioffa = iia - 1
258 joffa = jja - 1
259 iimax = ioffa + mp
260 jjmax = joffa + nq
261*
262 IF( desca2( rsrc_ ).LT.0 ) THEN
263 pmb = mb
264 ELSE
265 pmb = nprow * mb
266 END IF
267 IF( desca2( csrc_ ).LT.0 ) THEN
268 qnb = nb
269 ELSE
270 qnb = npcol * nb
271 END IF
272*
273* Handle the first block of rows or columns separately, and
274* update LCMT00, MBLKS and NBLKS.
275*
276 godown = ( lcmt00.GT.iupp )
277 goleft = ( lcmt00.LT.ilow )
278*
279 IF( .NOT.godown .AND. .NOT.goleft ) THEN
280*
281* LCMT00 >= ILOW && LCMT00 <= IUPP
282*
283 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
284 godown = .NOT.goleft
285*
286 CALL pb_clascal( uplo, imbloc, inbloc, lcmt00, alpha,
287 $ a( iia+joffa*lda ), lda )
288 IF( godown ) THEN
289 IF( upper .AND. nq.GT.inbloc )
290 $ CALL pb_clascal( 'All', imbloc, nq-inbloc, 0, alpha,
291 $ a( iia+(joffa+inbloc)*lda ), lda )
292 iia = iia + imbloc
293 m1 = m1 - imbloc
294 ELSE
295 IF( lower .AND. mp.GT.imbloc )
296 $ CALL pb_clascal( 'All', mp-imbloc, inbloc, 0, alpha,
297 $ a( iia+imbloc+joffa*lda ), lda )
298 jja = jja + inbloc
299 n1 = n1 - inbloc
300 END IF
301*
302 END IF
303*
304 IF( godown ) THEN
305*
306 lcmt00 = lcmt00 - ( iupp - upp + pmb )
307 mblks = mblks - 1
308 ioffa = ioffa + imbloc
309*
310 10 CONTINUE
311 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
312 lcmt00 = lcmt00 - pmb
313 mblks = mblks - 1
314 ioffa = ioffa + mb
315 GO TO 10
316 END IF
317*
318 tmp1 = min( ioffa, iimax ) - iia + 1
319 IF( upper .AND. tmp1.GT.0 ) THEN
320 CALL pb_clascal( 'All', tmp1, n1, 0, alpha,
321 $ a( iia+joffa*lda ), lda )
322 iia = iia + tmp1
323 m1 = m1 - tmp1
324 END IF
325*
326 IF( mblks.LE.0 )
327 $ RETURN
328*
329 lcmt = lcmt00
330 mblkd = mblks
331 ioffd = ioffa
332*
333 mbloc = mb
334 20 CONTINUE
335 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
336 IF( mblkd.EQ.1 )
337 $ mbloc = lmbloc
338 CALL pb_clascal( uplo, mbloc, inbloc, lcmt, alpha,
339 $ a( ioffd+1+joffa*lda ), lda )
340 lcmt00 = lcmt
341 lcmt = lcmt - pmb
342 mblks = mblkd
343 mblkd = mblkd - 1
344 ioffa = ioffd
345 ioffd = ioffd + mbloc
346 GO TO 20
347 END IF
348*
349 tmp1 = m1 - ioffd + iia - 1
350 IF( lower .AND. tmp1.GT.0 )
351 $ CALL pb_clascal( 'All', tmp1, inbloc, 0, alpha,
352 $ a( ioffd+1+joffa*lda ), lda )
353*
354 tmp1 = ioffa - iia + 1
355 m1 = m1 - tmp1
356 n1 = n1 - inbloc
357 lcmt00 = lcmt00 + low - ilow + qnb
358 nblks = nblks - 1
359 joffa = joffa + inbloc
360*
361 IF( upper .AND. tmp1.GT.0 .AND. n1.GT.0 )
362 $ CALL pb_clascal( 'All', tmp1, n1, 0, alpha,
363 $ a( iia+joffa*lda ), lda )
364*
365 iia = ioffa + 1
366 jja = joffa + 1
367*
368 ELSE IF( goleft ) THEN
369*
370 lcmt00 = lcmt00 + low - ilow + qnb
371 nblks = nblks - 1
372 joffa = joffa + inbloc
373*
374 30 CONTINUE
375 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
376 lcmt00 = lcmt00 + qnb
377 nblks = nblks - 1
378 joffa = joffa + nb
379 GO TO 30
380 END IF
381*
382 tmp1 = min( joffa, jjmax ) - jja + 1
383 IF( lower .AND. tmp1.GT.0 ) THEN
384 CALL pb_clascal( 'All', m1, tmp1, 0, alpha,
385 $ a( iia+(jja-1)*lda ), lda )
386 jja = jja + tmp1
387 n1 = n1 - tmp1
388 END IF
389*
390 IF( nblks.LE.0 )
391 $ RETURN
392*
393 lcmt = lcmt00
394 nblkd = nblks
395 joffd = joffa
396*
397 nbloc = nb
398 40 CONTINUE
399 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
400 IF( nblkd.EQ.1 )
401 $ nbloc = lnbloc
402 CALL pb_clascal( uplo, imbloc, nbloc, lcmt, alpha,
403 $ a( iia+joffd*lda ), lda )
404 lcmt00 = lcmt
405 lcmt = lcmt + qnb
406 nblks = nblkd
407 nblkd = nblkd - 1
408 joffa = joffd
409 joffd = joffd + nbloc
410 GO TO 40
411 END IF
412*
413 tmp1 = n1 - joffd + jja - 1
414 IF( upper .AND. tmp1.GT.0 )
415 $ CALL pb_clascal( 'All', imbloc, tmp1, 0, alpha,
416 $ a( iia+joffd*lda ), lda )
417*
418 tmp1 = joffa - jja + 1
419 m1 = m1 - imbloc
420 n1 = n1 - tmp1
421 lcmt00 = lcmt00 - ( iupp - upp + pmb )
422 mblks = mblks - 1
423 ioffa = ioffa + imbloc
424*
425 IF( lower .AND. m1.GT.0 .AND. tmp1.GT.0 )
426 $ CALL pb_clascal( 'All', m1, tmp1, 0, alpha,
427 $ a( ioffa+1+(jja-1)*lda ), lda )
428*
429 iia = ioffa + 1
430 jja = joffa + 1
431*
432 END IF
433*
434 nbloc = nb
435 50 CONTINUE
436 IF( nblks.GT.0 ) THEN
437 IF( nblks.EQ.1 )
438 $ nbloc = lnbloc
439 60 CONTINUE
440 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
441 lcmt00 = lcmt00 - pmb
442 mblks = mblks - 1
443 ioffa = ioffa + mb
444 GO TO 60
445 END IF
446*
447 tmp1 = min( ioffa, iimax ) - iia + 1
448 IF( upper .AND. tmp1.GT.0 ) THEN
449 CALL pb_clascal( 'All', tmp1, n1, 0, alpha,
450 $ a( iia+joffa*lda ), lda )
451 iia = iia + tmp1
452 m1 = m1 - tmp1
453 END IF
454*
455 IF( mblks.LE.0 )
456 $ RETURN
457*
458 lcmt = lcmt00
459 mblkd = mblks
460 ioffd = ioffa
461*
462 mbloc = mb
463 70 CONTINUE
464 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
465 IF( mblkd.EQ.1 )
466 $ mbloc = lmbloc
467 CALL pb_clascal( uplo, mbloc, nbloc, lcmt, alpha,
468 $ a( ioffd+1+joffa*lda ), lda )
469 lcmt00 = lcmt
470 lcmt = lcmt - pmb
471 mblks = mblkd
472 mblkd = mblkd - 1
473 ioffa = ioffd
474 ioffd = ioffd + mbloc
475 GO TO 70
476 END IF
477*
478 tmp1 = m1 - ioffd + iia - 1
479 IF( lower .AND. tmp1.GT.0 )
480 $ CALL pb_clascal( 'All', tmp1, nbloc, 0, alpha,
481 $ a( ioffd+1+joffa*lda ), lda )
482*
483 tmp1 = min( ioffa, iimax ) - iia + 1
484 m1 = m1 - tmp1
485 n1 = n1 - nbloc
486 lcmt00 = lcmt00 + qnb
487 nblks = nblks - 1
488 joffa = joffa + nbloc
489*
490 IF( upper .AND. tmp1.GT.0 .AND. n1.GT.0 )
491 $ CALL pb_clascal( 'All', tmp1, n1, 0, alpha,
492 $ a( iia+joffa*lda ), lda )
493*
494 iia = ioffa + 1
495 jja = joffa + 1
496*
497 GO TO 50
498*
499 END IF
500*
501 END IF
502*
503 RETURN
504*
505* End of PCLASCAL
506*
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
pb_numroc
integer function pb_numroc(n, i, inb, nb, proc, srcproc, nprocs)
Definition pblastst.f:2548
pb_clascal
subroutine pb_clascal(uplo, m, n, ioffd, alpha, a, lda)
Definition pcblastim.f:1320