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

Go to the source code of this file.

Functions/Subroutines

subroutine pslascal (type, m, n, alpha, a, ia, ja, desca)
subroutine pslagen (inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
subroutine psladom (inplace, n, alpha, a, ia, ja, desca)
subroutine pb_slascal (uplo, m, n, ioffd, alpha, a, lda)
subroutine pb_slagen (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_slagen()

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

Definition at line 1477 of file psblastim.f.

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

◆ pb_slascal()

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

Definition at line 1298 of file psblastim.f.

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

◆ pb_sran()

real function pb_sran ( integer idumm)

Definition at line 2182 of file psblastim.f.

2183*
2184* -- PBLAS test routine (version 2.0) --
2185* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2186* and University of California, Berkeley.
2187* April 1, 1998
2188*
2189* .. Scalar Arguments ..
2190 INTEGER IDUMM
2191* ..
2192*
2193* Purpose
2194* =======
2195*
2196* PB_SRAN generates the next number in the random sequence.
2197*
2198* Arguments
2199* =========
2200*
2201* IDUMM (local input) INTEGER
2202* This argument is ignored, but necessary to a FORTRAN 77 func-
2203* tion.
2204*
2205* Further Details
2206* ===============
2207*
2208* On entry, the array IRAND stored in the common block RANCOM contains
2209* the information (2 integers) required to generate the next number in
2210* the sequence X( n ). This number is computed as
2211*
2212* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2213*
2214* where the constant d is the largest 32 bit positive integer. The
2215* array IRAND is then updated for the generation of the next number
2216* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2217* The constants a and c should have been preliminarily stored in the
2218* array IACS as 2 pairs of integers. The initial set up of IRAND and
2219* IACS is performed by the routine PB_SETRAN.
2220*
2221* -- Written on April 1, 1998 by
2222* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2223*
2224* =====================================================================
2225*
2226* .. Parameters ..
2227 REAL DIVFAC, POW16
2228 parameter( divfac = 2.147483648e+9,
2229 $ pow16 = 6.5536e+4 )
2230* ..
2231* .. Local Arrays ..
2232 INTEGER J( 2 )
2233* ..
2234* .. External Subroutines ..
2235 EXTERNAL pb_ladd, pb_lmul
2236* ..
2237* .. Intrinsic Functions ..
2238 INTRINSIC real
2239* ..
2240* .. Common Blocks ..
2241 INTEGER IACS( 4 ), IRAND( 2 )
2242 COMMON /rancom/ irand, iacs
2243* ..
2244* .. Save Statements ..
2245 SAVE /rancom/
2246* ..
2247* .. Executable Statements ..
2248*
2249 pb_sran = ( real( irand( 1 ) ) + pow16 * real( irand( 2 ) ) ) /
2250 $ divfac
2251*
2252 CALL pb_lmul( irand, iacs, j )
2253 CALL pb_ladd( j, iacs( 3 ), irand )
2254*
2255 RETURN
2256*
2257* End of PB_SRAN
2258*
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 psblastim.f:2183

◆ pb_srand()

real function pb_srand ( integer idumm)

Definition at line 2120 of file psblastim.f.

2121*
2122* -- PBLAS test routine (version 2.0) --
2123* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2124* and University of California, Berkeley.
2125* April 1, 1998
2126*
2127* .. Scalar Arguments ..
2128 INTEGER IDUMM
2129* ..
2130*
2131* Purpose
2132* =======
2133*
2134* PB_SRAND generates the next number in the random sequence. This func-
2135* tion ensures that this number will be in the interval ( -1.0, 1.0 ).
2136*
2137* Arguments
2138* =========
2139*
2140* IDUMM (local input) INTEGER
2141* This argument is ignored, but necessary to a FORTRAN 77 func-
2142* tion.
2143*
2144* Further Details
2145* ===============
2146*
2147* On entry, the array IRAND stored in the common block RANCOM contains
2148* the information (2 integers) required to generate the next number in
2149* the sequence X( n ). This number is computed as
2150*
2151* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
2152*
2153* where the constant d is the largest 32 bit positive integer. The
2154* array IRAND is then updated for the generation of the next number
2155* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
2156* The constants a and c should have been preliminarily stored in the
2157* array IACS as 2 pairs of integers. The initial set up of IRAND and
2158* IACS is performed by the routine PB_SETRAN.
2159*
2160* -- Written on April 1, 1998 by
2161* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2162*
2163* =====================================================================
2164*
2165* .. Parameters ..
2166 REAL ONE, TWO
2167 parameter( one = 1.0e+0, two = 2.0e+0 )
2168* ..
2169* .. External Functions ..
2170 REAL PB_SRAN
2171 EXTERNAL pb_sran
2172* ..
2173* .. Executable Statements ..
2174*
2175 pb_srand = one - two * pb_sran( idumm )
2176*
2177 RETURN
2178*
2179* End of PB_SRAND
2180*

◆ psladom()

subroutine psladom ( logical inplace,
integer n,
real alpha,
real, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca )

Definition at line 907 of file psblastim.f.

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

◆ pslagen()

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

Definition at line 508 of file psblastim.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 REAL A( LDA, * )
524* ..
525*
526* Purpose
527* =======
528*
529* PSLAGEN 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) REAL 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* ..
717* .. Local Scalars ..
718 LOGICAL DIAGDO, SYMM, HERM, NOTRAN
719 INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
720 $ ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
721 $ INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
722 $ IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
723 $ LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
724 $ MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
725 $ NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
726 REAL ALPHA
727* ..
728* .. Local Arrays ..
729 INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
730 $ IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
731* ..
732* .. External Subroutines ..
733 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
734 $ pb_chkmat, pb_desctrans, pb_initjmp,
735 $ pb_initmuladd, pb_jump, pb_jumpit, pb_locinfo,
736 $ pb_setlocran, pb_setran, pb_slagen, psladom,
737 $ pxerbla
738* ..
739* .. External Functions ..
740 LOGICAL LSAME
741 EXTERNAL lsame
742* ..
743* .. Intrinsic Functions ..
744 INTRINSIC max, min, real
745* ..
746* .. Data Statements ..
747 DATA ( muladd0( i ), i = 1, 4 ) / 20077, 16838,
748 $ 12345, 0 /
749* ..
750* .. Executable Statements ..
751*
752* Convert descriptor
753*
754 CALL pb_desctrans( desca, desca2 )
755*
756* Test the input arguments
757*
758 ictxt = desca2( ctxt_ )
759 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
760*
761* Test the input parameters
762*
763 info = 0
764 IF( nprow.EQ.-1 ) THEN
765 info = -( 1000 + ctxt_ )
766 ELSE
767 symm = lsame( aform, 'S' )
768 herm = lsame( aform, 'H' )
769 notran = lsame( aform, 'N' )
770 diagdo = lsame( diag, 'D' )
771 IF( .NOT.( symm.OR.herm.OR.notran ) .AND.
772 $ .NOT.( lsame( aform, 'T' ) ) .AND.
773 $ .NOT.( lsame( aform, 'C' ) ) ) THEN
774 info = -2
775 ELSE IF( ( .NOT.diagdo ) .AND.
776 $ ( .NOT.lsame( diag, 'N' ) ) ) THEN
777 info = -3
778 END IF
779 CALL pb_chkmat( ictxt, m, 5, n, 6, ia, ja, desca2, 10, info )
780 END IF
781*
782 IF( info.NE.0 ) THEN
783 CALL pxerbla( ictxt, 'PSLAGEN', -info )
784 RETURN
785 END IF
786*
787* Quick return if possible
788*
789 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
790 $ RETURN
791*
792* Start the operations
793*
794 mb = desca2( mb_ )
795 nb = desca2( nb_ )
796 imb = desca2( imb_ )
797 inb = desca2( inb_ )
798 rsrc = desca2( rsrc_ )
799 csrc = desca2( csrc_ )
800*
801* Figure out local information about the distributed matrix operand
802*
803 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
804 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
805 $ iacol, mrrow, mrcol )
806*
807* Decide where the entries shall be stored in memory
808*
809 IF( inplace ) THEN
810 iia = 1
811 jja = 1
812 END IF
813*
814* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
815* ILOW, LOW, IUPP, and UPP.
816*
817 ioffda = ja + offa - ia
818 CALL pb_binfo( ioffda, mp, nq, imb1, inb1, mb, nb, mrrow,
819 $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
820 $ lmbloc, lnbloc, ilow, low, iupp, upp )
821*
822* Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
823* This values correspond to the square virtual underlying matrix
824* of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
825* to set up the random sequence. For practical purposes, the size
826* of this virtual matrix is upper bounded by M_ + N_ - 1.
827*
828 itmp = max( 0, -offa )
829 ivir = ia + itmp
830 imbvir = imb + itmp
831 nvir = desca2( m_ ) + itmp
832*
833 CALL pb_locinfo( ivir, imbvir, mb, myrow, rsrc, nprow, ilocblk,
834 $ ilocoff, myrdist )
835*
836 itmp = max( 0, offa )
837 jvir = ja + itmp
838 inbvir = inb + itmp
839 nvir = max( max( nvir, desca2( n_ ) + itmp ),
840 $ desca2( m_ ) + desca2( n_ ) - 1 )
841*
842 CALL pb_locinfo( jvir, inbvir, nb, mycol, csrc, npcol, jlocblk,
843 $ jlocoff, mycdist )
844*
845 IF( symm .OR. herm .OR. notran ) THEN
846*
847 CALL pb_initjmp( .true., nvir, imbvir, inbvir, imbloc, inbloc,
848 $ mb, nb, rsrc, csrc, nprow, npcol, 1, jmp )
849*
850* Compute constants to jump JMP( * ) numbers in the sequence
851*
852 CALL pb_initmuladd( muladd0, jmp, imuladd )
853*
854* Compute and set the random value corresponding to A( IA, JA )
855*
856 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
857 $ myrdist, mycdist, nprow, npcol, jmp,
858 $ imuladd, iran )
859*
860 CALL pb_slagen( 'Lower', aform, a( iia, jja ), lda, lcmt00,
861 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
862 $ nb, lnbloc, jmp, imuladd )
863*
864 END IF
865*
866 IF( symm .OR. herm .OR. ( .NOT. notran ) ) THEN
867*
868 CALL pb_initjmp( .false., nvir, imbvir, inbvir, imbloc, inbloc,
869 $ mb, nb, rsrc, csrc, nprow, npcol, 1, jmp )
870*
871* Compute constants to jump JMP( * ) numbers in the sequence
872*
873 CALL pb_initmuladd( muladd0, jmp, imuladd )
874*
875* Compute and set the random value corresponding to A( IA, JA )
876*
877 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
878 $ myrdist, mycdist, nprow, npcol, jmp,
879 $ imuladd, iran )
880*
881 CALL pb_slagen( 'Upper', aform, a( iia, jja ), lda, lcmt00,
882 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
883 $ nb, lnbloc, jmp, imuladd )
884*
885 END IF
886*
887 IF( diagdo ) THEN
888*
889 maxmn = max( desca2( m_ ), desca2( n_ ) )
890 alpha = real( maxmn )
891*
892 IF( ioffda.GE.0 ) THEN
893 CALL psladom( inplace, min( max( 0, m-ioffda ), n ), alpha,
894 $ a, min( ia+ioffda, ia+m-1 ), ja, desca )
895 ELSE
896 CALL psladom( inplace, min( m, max( 0, n+ioffda ) ), alpha,
897 $ a, ia, min( ja-ioffda, ja+n-1 ), desca )
898 END IF
899*
900 END IF
901*
902 RETURN
903*
904* End of PSLAGEN
905*
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
psladom
subroutine psladom(inplace, n, alpha, a, ia, ja, desca)
Definition psblastim.f:908
pb_slagen
subroutine pb_slagen(uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
Definition psblastim.f:1480

◆ pslascal()

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

Definition at line 1 of file psblastim.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 REAL ALPHA
12* ..
13* .. Array Arguments ..
14 INTEGER DESCA( * )
15 REAL A( * )
16* ..
17*
18* Purpose
19* =======
20*
21* PSLASCAL 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) REAL
108* On entry, ALPHA specifies the scalar alpha.
109*
110* A (local input/local output) REAL 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_desctrans, pb_infog2l, pb_slascal
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_slascal( '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_slascal( 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_slascal( '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_slascal( '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_slascal( '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_slascal( 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_slascal( '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_slascal( '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_slascal( '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.LE. IF( NBLKS0 )
391 $ RETURN
392*
393 LCMT = LCMT00
394 NBLKD = NBLKS
395 JOFFD = JOFFA
396*
397 NBLOC = NB
398 40 CONTINUE
399.GT..AND..LE. IF( NBLKD0 LCMTIUPP ) THEN
400.EQ. IF( NBLKD1 )
401 $ NBLOC = LNBLOC
402 CALL PB_SLASCAL( 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.AND..GT. IF( UPPER TMP10 )
415 $ CALL PB_SLASCAL( '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.AND..GT..AND..GT. IF( LOWER M10 TMP10 )
426 $ CALL PB_SLASCAL( '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.GT. IF( NBLKS0 ) THEN
437.EQ. IF( NBLKS1 )
438 $ NBLOC = LNBLOC
439 60 CONTINUE
440.GT..AND..GT. IF( MBLKS0 LCMT00UPP ) 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.AND..GT. IF( UPPER TMP10 ) THEN
449 CALL PB_SLASCAL( 'all', TMP1, N1, 0, ALPHA,
450 $ A( IIA+JOFFA*LDA ), LDA )
451 IIA = IIA + TMP1
452 M1 = M1 - TMP1
453 END IF
454*
455.LE. IF( MBLKS0 )
456 $ RETURN
457*
458 LCMT = LCMT00
459 MBLKD = MBLKS
460 IOFFD = IOFFA
461*
462 MBLOC = MB
463 70 CONTINUE
464.GT..AND..GE. IF( MBLKD0 LCMTLOW ) THEN
465.EQ. IF( MBLKD1 )
466 $ MBLOC = LMBLOC
467 CALL PB_SLASCAL( 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.AND..GT. IF( LOWER TMP10 )
480 $ CALL PB_SLASCAL( '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.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
491 $ CALL PB_SLASCAL( '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 PSLASCAL
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_slascal
subroutine pb_slascal(uplo, m, n, ioffd, alpha, a, lda)
Definition psblastim.f:1299