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

Go to the source code of this file.

Functions/Subroutines

subroutine pzlascal (type, m, n, alpha, a, ia, ja, desca)
subroutine pzlagen (inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
subroutine pzladom (inplace, n, alpha, a, ia, ja, desca)
subroutine pb_zlascal (uplo, m, n, ioffd, alpha, a, lda)
subroutine pb_zlagen (uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
double precision function pb_drand (idumm)
double precision function pb_dran (idumm)

Function/Subroutine Documentation

◆ pb_dran()

double precision function pb_dran ( integer idumm)

Definition at line 2631 of file pzblastim.f.

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

◆ pb_drand()

double precision function pb_drand ( integer idumm)

Definition at line 2569 of file pzblastim.f.

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

◆ pb_zlagen()

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

Definition at line 1499 of file pzblastim.f.

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

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

Definition at line 1320 of file pzblastim.f.

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

◆ pzladom()

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

Definition at line 913 of file pzblastim.f.

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

◆ pzlagen()

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

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

◆ pzlascal()

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

Definition at line 1 of file pzblastim.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*16 ALPHA
12* ..
13* .. Array Arguments ..
14 INTEGER DESCA( * )
15 COMPLEX*16 A( * )
16* ..
17*
18* Purpose
19* =======
20*
21* PZLASCAL 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*16
108* On entry, ALPHA specifies the scalar alpha.
109*
110* A (local input/local output) COMPLEX*16 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_zlascal
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_zlascal( '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_zlascal( 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_zlascal( '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_zlascal( '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_zlascal( '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_zlascal( 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_zlascal( '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_zlascal( '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_zlascal( '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_zlascal( 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_zlascal( '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_zlascal( '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_zlascal( '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_zlascal( 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_zlascal( '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_zlascal( '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 PZLASCAL
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_zlascal
subroutine pb_zlascal(uplo, m, n, ioffd, alpha, a, lda)
Definition pzblastim.f:1321