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

◆ pcchkmat()

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

Definition at line 1675 of file pcblastst.f.

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