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

◆ pdchkmat()

subroutine pdchkmat ( integer  ictxt,
integer  nout,
external  subptr,
integer  scode,
character*(*)  sname,
character*1  argnam,
integer  argpos 
)

Definition at line 1672 of file pdblastst.f.

1674*
1675* -- PBLAS test routine (version 2.0) --
1676* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1677* and University of California, Berkeley.
1678* April 1, 1998
1679*
1680* .. Scalar Arguments ..
1681 CHARACTER*1 ARGNAM
1682 INTEGER ARGPOS, ICTXT, NOUT, SCODE
1683* ..
1684* .. Array Arguments ..
1685 CHARACTER*(*) SNAME
1686* ..
1687* .. Subroutine Arguments ..
1688 EXTERNAL subptr
1689* ..
1690*
1691* Purpose
1692* =======
1693*
1694* PDCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine.
1695*
1696* Notes
1697* =====
1698*
1699* A description vector is associated with each 2D block-cyclicly dis-
1700* tributed matrix. This vector stores the information required to
1701* establish the mapping between a matrix entry and its corresponding
1702* process and memory location.
1703*
1704* In the following comments, the character _ should be read as
1705* "of the distributed matrix". Let A be a generic term for any 2D
1706* block cyclicly distributed matrix. Its description vector is DESCA:
1707*
1708* NOTATION STORED IN EXPLANATION
1709* ---------------- --------------- ------------------------------------
1710* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1711* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1712* the NPROW x NPCOL BLACS process grid
1713* A is distributed over. The context
1714* itself is global, but the handle
1715* (the integer value) may vary.
1716* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1717* ted matrix A, M_A >= 0.
1718* N_A (global) DESCA( N_ ) The number of columns in the distri-
1719* buted matrix A, N_A >= 0.
1720* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1721* block of the matrix A, IMB_A > 0.
1722* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1723* left block of the matrix A,
1724* INB_A > 0.
1725* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1726* bute the last M_A-IMB_A rows of A,
1727* MB_A > 0.
1728* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1729* bute the last N_A-INB_A columns of
1730* A, NB_A > 0.
1731* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1732* row of the matrix A is distributed,
1733* NPROW > RSRC_A >= 0.
1734* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1735* first column of A is distributed.
1736* NPCOL > CSRC_A >= 0.
1737* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1738* array storing the local blocks of
1739* the distributed matrix A,
1740* IF( Lc( 1, N_A ) > 0 )
1741* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1742* ELSE
1743* LLD_A >= 1.
1744*
1745* Let K be the number of rows of a matrix A starting at the global in-
1746* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1747* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1748* receive if these K rows were distributed over NPROW processes. If K
1749* is the number of columns of a matrix A starting at the global index
1750* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1751* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1752* these K columns were distributed over NPCOL processes.
1753*
1754* The values of Lr() and Lc() may be determined via a call to the func-
1755* tion PB_NUMROC:
1756* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1757* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1758*
1759* Arguments
1760* =========
1761*
1762* ICTXT (local input) INTEGER
1763* On entry, ICTXT specifies the BLACS context handle, indica-
1764* ting the global context of the operation. The context itself
1765* is global, but the value of ICTXT is local.
1766*
1767* NOUT (global input) INTEGER
1768* On entry, NOUT specifies the unit number for the output file.
1769* When NOUT is 6, output to screen, when NOUT is 0, output to
1770* stderr. NOUT is only defined for process 0.
1771*
1772* SUBPTR (global input) SUBROUTINE
1773* On entry, SUBPTR is a subroutine. SUBPTR must be declared
1774* EXTERNAL in the calling subroutine.
1775*
1776* SCODE (global input) INTEGER
1777* On entry, SCODE specifies the calling sequence code.
1778*
1779* SNAME (global input) CHARACTER*(*)
1780* On entry, SNAME specifies the subroutine name calling this
1781* subprogram.
1782*
1783* ARGNAM (global input) CHARACTER*(*)
1784* On entry, ARGNAM specifies the name of the matrix or vector
1785* to be checked. ARGNAM can either be 'A', 'B' or 'C' when one
1786* wants to check a matrix, and 'X' or 'Y' for a vector.
1787*
1788* ARGPOS (global input) INTEGER
1789* On entry, ARGPOS indicates the position of the first argument
1790* of the matrix (or vector) ARGNAM.
1791*
1792* -- Written on April 1, 1998 by
1793* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1794*
1795* =====================================================================
1796*
1797* .. Parameters ..
1798 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1799 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1800 $ RSRC_
1801 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1802 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1803 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1804 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1805 INTEGER DESCMULT
1806 parameter( descmult = 100 )
1807* ..
1808* .. Local Scalars ..
1809 INTEGER I, INFOT, NPROW, NPCOL, MYROW, MYCOL
1810* ..
1811* .. External Subroutines ..
1812 EXTERNAL blacs_gridinfo, pchkpbe, pdcallsub, pdsetpblas
1813* ..
1814* .. External Functions ..
1815 LOGICAL LSAME
1816 EXTERNAL lsame
1817* ..
1818* .. Common Blocks ..
1819 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
1820 $ JC, JX, JY
1821 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
1822 $ DESCX( DLEN_ ), DESCY( DLEN_ )
1823 COMMON /pblasd/desca, descb, descc, descx, descy
1824 COMMON /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
1825 $ ja, jb, jc, jx, jy
1826* ..
1827* .. Executable Statements ..
1828*
1829 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1830*
1831 IF( lsame( argnam, 'A' ) ) THEN
1832*
1833* Check IA. Set all other OK, bad IA
1834*
1835 CALL pdsetpblas( ictxt )
1836 ia = -1
1837 infot = argpos + 1
1838 CALL pdcallsub( subptr, scode )
1839 CALL pchkpbe( ictxt, nout, sname, infot )
1840*
1841* Check JA. Set all other OK, bad JA
1842*
1843 CALL pdsetpblas( ictxt )
1844 ja = -1
1845 infot = argpos + 2
1846 CALL pdcallsub( subptr, scode )
1847 CALL pchkpbe( ictxt, nout, sname, infot )
1848*
1849* Check DESCA. Set all other OK, bad DESCA
1850*
1851 DO 10 i = 1, dlen_
1852*
1853* Set I'th entry of DESCA to incorrect value, rest ok.
1854*
1855 CALL pdsetpblas( ictxt )
1856 desca( i ) = -2
1857 infot = ( ( argpos + 3 ) * descmult ) + i
1858 CALL pdcallsub( subptr, scode )
1859 CALL pchkpbe( ictxt, nout, sname, infot )
1860*
1861* Extra tests for RSRCA, CSRCA, LDA
1862*
1863 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1864 $ ( i.EQ.lld_ ) ) THEN
1865*
1866 CALL pdsetpblas( ictxt )
1867*
1868* Test RSRCA >= NPROW
1869*
1870 IF( i.EQ.rsrc_ )
1871 $ desca( i ) = nprow
1872*
1873* Test CSRCA >= NPCOL
1874*
1875 IF( i.EQ.csrc_ )
1876 $ desca( i ) = npcol
1877*
1878* Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1879*
1880 IF( i.EQ.lld_ ) THEN
1881 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
1882 desca( i ) = 1
1883 ELSE
1884 desca( i ) = 0
1885 END IF
1886 END IF
1887*
1888 infot = ( ( argpos + 3 ) * descmult ) + i
1889 CALL pdcallsub( subptr, scode )
1890 CALL pchkpbe( ictxt, nout, sname, infot )
1891*
1892 END IF
1893*
1894 10 CONTINUE
1895*
1896 ELSE IF( lsame( argnam, 'B' ) ) THEN
1897*
1898* Check IB. Set all other OK, bad IB
1899*
1900 CALL pdsetpblas( ictxt )
1901 ib = -1
1902 infot = argpos + 1
1903 CALL pdcallsub( subptr, scode )
1904 CALL pchkpbe( ictxt, nout, sname, infot )
1905*
1906* Check JB. Set all other OK, bad JB
1907*
1908 CALL pdsetpblas( ictxt )
1909 jb = -1
1910 infot = argpos + 2
1911 CALL pdcallsub( subptr, scode )
1912 CALL pchkpbe( ictxt, nout, sname, infot )
1913*
1914* Check DESCB. Set all other OK, bad DESCB
1915*
1916 DO 20 i = 1, dlen_
1917*
1918* Set I'th entry of DESCB to incorrect value, rest ok.
1919*
1920 CALL pdsetpblas( ictxt )
1921 descb( i ) = -2
1922 infot = ( ( argpos + 3 ) * descmult ) + i
1923 CALL pdcallsub( subptr, scode )
1924 CALL pchkpbe( ictxt, nout, sname, infot )
1925*
1926* Extra tests for RSRCB, CSRCB, LDB
1927*
1928 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1929 $ ( i.EQ.lld_ ) ) THEN
1930*
1931 CALL pdsetpblas( ictxt )
1932*
1933* Test RSRCB >= NPROW
1934*
1935 IF( i.EQ.rsrc_ )
1936 $ descb( i ) = nprow
1937*
1938* Test CSRCB >= NPCOL
1939*
1940 IF( i.EQ.csrc_ )
1941 $ descb( i ) = npcol
1942*
1943* Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1944*
1945 IF( i.EQ.lld_ ) THEN
1946 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
1947 descb( i ) = 1
1948 ELSE
1949 descb( i ) = 0
1950 END IF
1951 END IF
1952*
1953 infot = ( ( argpos + 3 ) * descmult ) + i
1954 CALL pdcallsub( subptr, scode )
1955 CALL pchkpbe( ictxt, nout, sname, infot )
1956*
1957 END IF
1958*
1959 20 CONTINUE
1960*
1961 ELSE IF( lsame( argnam, 'C' ) ) THEN
1962*
1963* Check IC. Set all other OK, bad IC
1964*
1965 CALL pdsetpblas( ictxt )
1966 ic = -1
1967 infot = argpos + 1
1968 CALL pdcallsub( subptr, scode )
1969 CALL pchkpbe( ictxt, nout, sname, infot )
1970*
1971* Check JC. Set all other OK, bad JC
1972*
1973 CALL pdsetpblas( ictxt )
1974 jc = -1
1975 infot = argpos + 2
1976 CALL pdcallsub( subptr, scode )
1977 CALL pchkpbe( ictxt, nout, sname, infot )
1978*
1979* Check DESCC. Set all other OK, bad DESCC
1980*
1981 DO 30 i = 1, dlen_
1982*
1983* Set I'th entry of DESCC to incorrect value, rest ok.
1984*
1985 CALL pdsetpblas( ictxt )
1986 descc( i ) = -2
1987 infot = ( ( argpos + 3 ) * descmult ) + i
1988 CALL pdcallsub( subptr, scode )
1989 CALL pchkpbe( ictxt, nout, sname, infot )
1990*
1991* Extra tests for RSRCC, CSRCC, LDC
1992*
1993 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1994 $ ( i.EQ.lld_ ) ) THEN
1995*
1996 CALL pdsetpblas( ictxt )
1997*
1998* Test RSRCC >= NPROW
1999*
2000 IF( i.EQ.rsrc_ )
2001 $ descc( i ) = nprow
2002*
2003* Test CSRCC >= NPCOL
2004*
2005 IF( i.EQ.csrc_ )
2006 $ descc( i ) = npcol
2007*
2008* Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2009*
2010 IF( i.EQ.lld_ ) THEN
2011 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2012 descc( i ) = 1
2013 ELSE
2014 descc( i ) = 0
2015 END IF
2016 END IF
2017*
2018 infot = ( ( argpos + 3 ) * descmult ) + i
2019 CALL pdcallsub( subptr, scode )
2020 CALL pchkpbe( ictxt, nout, sname, infot )
2021*
2022 END IF
2023*
2024 30 CONTINUE
2025*
2026 ELSE IF( lsame( argnam, 'X' ) ) THEN
2027*
2028* Check IX. Set all other OK, bad IX
2029*
2030 CALL pdsetpblas( ictxt )
2031 ix = -1
2032 infot = argpos + 1
2033 CALL pdcallsub( subptr, scode )
2034 CALL pchkpbe( ictxt, nout, sname, infot )
2035*
2036* Check JX. Set all other OK, bad JX
2037*
2038 CALL pdsetpblas( ictxt )
2039 jx = -1
2040 infot = argpos + 2
2041 CALL pdcallsub( subptr, scode )
2042 CALL pchkpbe( ictxt, nout, sname, infot )
2043*
2044* Check DESCX. Set all other OK, bad DESCX
2045*
2046 DO 40 i = 1, dlen_
2047*
2048* Set I'th entry of DESCX to incorrect value, rest ok.
2049*
2050 CALL pdsetpblas( ictxt )
2051 descx( i ) = -2
2052 infot = ( ( argpos + 3 ) * descmult ) + i
2053 CALL pdcallsub( subptr, scode )
2054 CALL pchkpbe( ictxt, nout, sname, infot )
2055*
2056* Extra tests for RSRCX, CSRCX, LDX
2057*
2058 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
2059 $ ( i.EQ.lld_ ) ) THEN
2060*
2061 CALL pdsetpblas( ictxt )
2062*
2063* Test RSRCX >= NPROW
2064*
2065 IF( i.EQ.rsrc_ )
2066 $ descx( i ) = nprow
2067*
2068* Test CSRCX >= NPCOL
2069*
2070 IF( i.EQ.csrc_ )
2071 $ descx( i ) = npcol
2072*
2073* Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2074*
2075 IF( i.EQ.lld_ ) THEN
2076 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2077 descx( i ) = 1
2078 ELSE
2079 descx( i ) = 0
2080 END IF
2081 END IF
2082*
2083 infot = ( ( argpos + 3 ) * descmult ) + i
2084 CALL pdcallsub( subptr, scode )
2085 CALL pchkpbe( ictxt, nout, sname, infot )
2086*
2087 END IF
2088*
2089 40 CONTINUE
2090*
2091* Check INCX. Set all other OK, bad INCX
2092*
2093 CALL pdsetpblas( ictxt )
2094 incx = -1
2095 infot = argpos + 4
2096 CALL pdcallsub( subptr, scode )
2097 CALL pchkpbe( ictxt, nout, sname, infot )
2098*
2099 ELSE
2100*
2101* Check IY. Set all other OK, bad IY
2102*
2103 CALL pdsetpblas( ictxt )
2104 iy = -1
2105 infot = argpos + 1
2106 CALL pdcallsub( subptr, scode )
2107 CALL pchkpbe( ictxt, nout, sname, infot )
2108*
2109* Check JY. Set all other OK, bad JY
2110*
2111 CALL pdsetpblas( ictxt )
2112 jy = -1
2113 infot = argpos + 2
2114 CALL pdcallsub( subptr, scode )
2115 CALL pchkpbe( ictxt, nout, sname, infot )
2116*
2117* Check DESCY. Set all other OK, bad DESCY
2118*
2119 DO 50 i = 1, dlen_
2120*
2121* Set I'th entry of DESCY to incorrect value, rest ok.
2122*
2123 CALL pdsetpblas( ictxt )
2124 descy( i ) = -2
2125 infot = ( ( argpos + 3 ) * descmult ) + i
2126 CALL pdcallsub( subptr, scode )
2127 CALL pchkpbe( ictxt, nout, sname, infot )
2128*
2129* Extra tests for RSRCY, CSRCY, LDY
2130*
2131 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
2132 $ ( i.EQ.lld_ ) ) THEN
2133*
2134 CALL pdsetpblas( ictxt )
2135*
2136* Test RSRCY >= NPROW
2137*
2138 IF( i.EQ.rsrc_ )
2139 $ descy( i ) = nprow
2140*
2141* Test CSRCY >= NPCOL
2142*
2143 IF( i.EQ.csrc_ )
2144 $ descy( i ) = npcol
2145*
2146* Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2147*
2148 IF( i.EQ.lld_ ) THEN
2149 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2150 descy( i ) = 1
2151 ELSE
2152 descy( i ) = 0
2153 END IF
2154 END IF
2155*
2156 infot = ( ( argpos + 3 ) * descmult ) + i
2157 CALL pdcallsub( subptr, scode )
2158 CALL pchkpbe( ictxt, nout, sname, infot )
2159*
2160 END IF
2161*
2162 50 CONTINUE
2163*
2164* Check INCY. Set all other OK, bad INCY
2165*
2166 CALL pdsetpblas( ictxt )
2167 incy = -1
2168 infot = argpos + 4
2169 CALL pdcallsub( subptr, scode )
2170 CALL pchkpbe( ictxt, nout, sname, infot )
2171*
2172 END IF
2173*
2174 RETURN
2175*
2176* End of PDCHKMAT
2177*
pchkpbe
subroutine pchkpbe(ictxt, nout, sname, infot)
Definition pblastst.f:1084
pdsetpblas
subroutine pdsetpblas(ictxt)
Definition pdblastst.f:1478
pdcallsub
subroutine pdcallsub(subptr, scode)
Definition pdblastst.f:2180
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
Here is the call graph for this function:
Here is the caller graph for this function: